Ensure nested binders have Internal Names

This is a long-standing bug.  A nested (non-top-level) binder
in Core should not have an External Name, like M.x. But

- Lint was not checking this invariant

- The desugarer could generate programs that failed the
  invariant.  An example is in
  tests/deSugar/should_compile/T13043, which had
     let !_ = M.scState in ...
  This desugared to
     let ds = case M.scSate of M.scState { DEFAULT -> () }
     in case ds of () -> ...

  We were wrongly re-using that scrutinee as a case binder.
  And Trac #13043 showed that could ultimately lead to two
  top-level bindings with the same closure name.  Alas!

- The desugarer had one other place (in DsUtils.mkCoreAppDs)
  that could generate bogus code

This patch fixes all three bugs, and adds a regression test.

1 files changed, 29 insertions, 15 deletions

diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index ef194756b0..672157e0d7 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -155,9 +155,20 @@ constructors, or all variables (or similar beasts), etc.
 @match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the
 Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@
 corresponds roughly to @matchVarCon@.
+
+Note [Match Ids]
+~~~~~~~~~~~~~~~~
+Most of the matching fuctions take an Id or [Id] as argument.  This Id
+is the scrutinee(s) of the match. The desugared expression may
+sometimes use that Id in a local binding or as a case binder.  So it
+should not have an External name; Lint rejects non-top-level binders
+with External names (Trac #13043).
 -}
 
-match :: [Id]             -- Variables rep\'ing the exprs we\'re matching with
+type MatchId = Id   -- See Note [Match Ids]
+
+match :: [MatchId]        -- Variables rep\'ing the exprs we\'re matching with
+                          -- See Note [Match Ids]
       -> Type             -- Type of the case expression
       -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)
       -> DsM MatchResult  -- Desugared result!
@@ -171,7 +182,8 @@ match [] ty eqns
                     | eqn <- eqns ]
 
 match vars@(v:_) ty eqns    -- Eqns *can* be empty
-  = do  { dflags <- getDynFlags
+  = ASSERT2( all (isInternalName . idName) vars, ppr vars )
+    do  { dflags <- getDynFlags
                 -- Tidy the first pattern, generating
                 -- auxiliary bindings if necessary
         ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
@@ -224,7 +236,7 @@ match vars@(v:_) ty eqns    -- Eqns *can* be empty
           maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))
                        (filter (not . null) gs))
 
-matchEmpty :: Id -> Type -> DsM [MatchResult]
+matchEmpty :: MatchId -> Type -> DsM [MatchResult]
 -- See Note [Empty case expressions]
 matchEmpty var res_ty
   = return [MatchResult CanFail mk_seq]
@@ -232,20 +244,20 @@ matchEmpty var res_ty
     mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty
                                       [(DEFAULT, [], fail)]
 
-matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+matchVariables :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
 -- Real true variables, just like in matchVar, SLPJ p 94
 -- No binding to do: they'll all be wildcards by now (done in tidy)
 matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)
 matchVariables [] _ _ = panic "matchVariables"
 
-matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+matchBangs :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
 matchBangs (var:vars) ty eqns
   = do  { match_result <- match (var:vars) ty $
                           map (decomposeFirstPat getBangPat) eqns
         ; return (mkEvalMatchResult var ty match_result) }
 matchBangs [] _ _ = panic "matchBangs"
 
-matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
 -- Apply the coercion to the match variable and then match that
 matchCoercion (var:vars) ty (eqns@(eqn1:_))
   = do  { let CoPat co pat _ = firstPat eqn1
@@ -258,7 +270,7 @@ matchCoercion (var:vars) ty (eqns@(eqn1:_))
         ; return (mkCoLetMatchResult bind match_result) }
 matchCoercion _ _ _ = panic "matchCoercion"
 
-matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+matchView :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
 -- Apply the view function to the match variable and then match that
 matchView (var:vars) ty (eqns@(eqn1:_))
   = do  { -- we could pass in the expr from the PgView,
@@ -277,7 +289,7 @@ matchView (var:vars) ty (eqns@(eqn1:_))
                     match_result) }
 matchView _ _ _ = panic "matchView"
 
-matchOverloadedList :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
 matchOverloadedList (var:vars) ty (eqns@(eqn1:_))
 -- Since overloaded list patterns are treated as view patterns,
 -- the code is roughly the same as for matchView
@@ -725,7 +737,7 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
 
 
 matchEquations  :: HsMatchContext Name
-                -> [Id] -> [EquationInfo] -> Type
+                -> [MatchId] -> [EquationInfo] -> Type
                 -> DsM CoreExpr
 matchEquations ctxt vars eqns_info rhs_ty
   = do  { let error_doc = matchContextErrString ctxt
@@ -764,12 +776,15 @@ matchSimply scrut hs_ctx pat result_expr fail_expr = do
 
 matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
                -> Type -> MatchResult -> DsM MatchResult
+-- matchSinglePat ensures that the scrutinee is a variable
+-- and then calls match_single_pat_var
+--
 -- matchSinglePat does not warn about incomplete patterns
 -- Used for things like [ e | pat <- stuff ], where
 -- incomplete patterns are just fine
 
 matchSinglePat (Var var) ctx pat ty match_result
-  | isLocalId var
+  | not (isExternalName (idName var))
   = match_single_pat_var var ctx pat ty match_result
 
 matchSinglePat scrut hs_ctx pat ty match_result
@@ -777,12 +792,12 @@ matchSinglePat scrut hs_ctx pat ty match_result
        ; match_result' <- match_single_pat_var var hs_ctx pat ty match_result
        ; return (adjustMatchResult (bindNonRec var scrut) match_result') }
 
-match_single_pat_var :: Id -> HsMatchContext Name -> LPat Id
+match_single_pat_var :: Id   -- See Note [Match Ids]
+                     -> HsMatchContext Name -> LPat Id
                      -> Type -> MatchResult -> DsM MatchResult
--- matchSinglePat ensures that the scrutinee is a variable
--- and then calls match_single_pat_var
 match_single_pat_var var ctx pat ty match_result
-  = do { dflags <- getDynFlags
+  = ASSERT2( isInternalName (idName var), ppr var )
+    do { dflags <- getDynFlags
        ; locn   <- getSrcSpanDs
 
                     -- Pattern match check warnings
@@ -793,7 +808,6 @@ match_single_pat_var var ctx pat ty match_result
        ; match [var] ty [eqn_info] }
 
 
-
 {-
 ************************************************************************
 *                                                                      *