Fix desugaring of pattern bindings (again)

This patch fixes Trac #12595.  The problem was with a
pattern binding like
     !x = e
For a start it's silly to match that pattern and build
a unit tuple (the General Case of mkSelectorBinds); but
that's what was happening because the bang fell through
to the general case.  But for a variable pattern building
any auxiliary bindings is stupid.  So the patch
introduces a new case in mkSelectorBinds for variable
patterns.

Then it turned out that if 'e' was a plain variable, and
moreover was imported GlobalId, then matchSinglePat made
it a /bound/ variable, which should never happen.  That
ultimately caused a linker error, but the original bug
was much earlier.

3 files changed, 98 insertions, 62 deletions

diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 8c05f43012..143d209b42 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -144,8 +144,7 @@ dsHsBind dflags
   = do  { body_expr <- dsGuarded grhss ty
         ; let body' = mkOptTickBox rhs_tick body_expr
               pat'  = decideBangHood dflags pat
-        ; (force_var,sel_binds) <-
-            mkSelectorBinds var_ticks pat body'
+        ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body'
           -- We silently ignore inline pragmas; no makeCorePair
           -- Not so cool, but really doesn't matter
         ; let force_var' = if isBangedLPat pat'
diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs
index 2e76c9334c..cc621d5d4f 100644
--- a/compiler/deSugar/DsUtils.hs
+++ b/compiler/deSugar/DsUtils.hs
@@ -597,23 +597,14 @@ in a binding group:
 where p binds x,y (this list of binders can be empty).
 There are two cases.
 
-General case (A).
-  In the general case we generate these bindings (A)
-
-       { t = case e of p -> (x,y)
-       ; x = case t of (x,y) -> x
-       ; y = case t of (x,y) -> y }
-
-  and we return 't' as the variable to force if the pattern
-  is strict.  So with -XStrict or an outermost-bang-pattern, the binding
-     let p = e in body
-  would turn into
-     let { t = case e of p -> (x,y)
-         ; x = case t of (x,y) -> x
-         ; y = case t of (x,y) -> y }
-     in t `seq` t
+------ Special case (A) -------
+  For a pattern that is just a variable,
+     let !x = e in body
+  ==>
+     let x = e in x `seq` body
+  So we return the binding, with 'x' as the variable to seq.
 
-Special case (B).
+------ Special case (B) -------
   For a pattern that is essentially just a tuple:
       * A product type, so cannot fail
       * Only one level, so that
@@ -625,7 +616,38 @@ Special case (B).
        ; y = case v of p -> y }
   with 'v' as the variable to force
 
-Examples:
+------ General case (C) -------
+  In the general case we generate these bindings:
+       let { ...; p = e; ... } in body
+  ==>
+       let { t = case e of p -> (x,y)
+           ; x = case t of (x,y) -> x
+           ; y = case t of (x,y) -> y }
+       in t `seq` body
+
+  Note that we return 't' as the variable to force if the pattern
+  is strict (i.e. with -XStrict or an outermost-bang-pattern)
+
+  Note that (A) /includes/ the situation where
+
+   * The pattern binds exactly one variable
+        let !(Just (Just x) = e in body
+     ==>
+       let { t = case e of Just (Just v) -> Unit v
+           ; v = case t of Unit v -> v }
+       in t `seq` body
+    The 'Unit' is a one-tuple; see Note [One-tuples] in TysWiredIn
+    Note that forcing 't' makes the pattern match happen,
+    but does not force 'v'.
+
+  * The pattern binds no variables
+        let !(True,False) = e in body
+    ==>
+        let t = case e of (True,False) -> ()
+        in t `seq` body
+
+
+------ Examples ----------
   *   !(_, (_, a)) = e
     ==>
       t = case e of (_, (_, a)) -> Unit a
@@ -708,14 +730,17 @@ mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly
                 -- and all the desugared binds
 
 mkSelectorBinds ticks pat val_expr
-  | is_simple_lpat pat  -- Special case (B)
-  = do { let pat_ty = hsLPatType pat
+  | L _ (VarPat (L _ v)) <- pat'     -- Special case (A)
+  = return (v, [(v, val_expr)])
+
+  | is_flat_prod_lpat pat'           -- Special case (B)
+  = do { let pat_ty = hsLPatType pat'
        ; val_var <- newSysLocalDs pat_ty
 
-       ; let mk_bind scrut_var tick bndr_var
+       ; let mk_bind tick bndr_var
                -- (mk_bind sv bv)  generates  bv = case sv of { pat -> bv }
                -- Remember, 'pat' binds 'bv'
-               = do { rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat
+               = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat'
                                        (Var bndr_var)
                                        (Var bndr_var)  -- Neat hack
                       -- Neat hack: since 'pat' can't fail, the
@@ -724,12 +749,12 @@ mkSelectorBinds ticks pat val_expr
                       -- that bndr_var is just the ticket.
                     ; return (bndr_var, mkOptTickBox tick rhs_expr) }
 
-       ; binds <- zipWithM (mk_bind val_var) ticks' binders
+       ; binds <- zipWithM mk_bind ticks' binders
        ; return ( val_var, (val_var, val_expr) : binds) }
 
-  | otherwise
+  | otherwise                          -- General case (C)
   = do { tuple_var  <- newSysLocalDs tuple_ty
-       ; error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat)
+       ; error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat')
        ; tuple_expr <- matchSimply val_expr PatBindRhs pat
                                    local_tuple error_expr
        ; let mk_tup_bind tick binder
@@ -739,30 +764,34 @@ mkSelectorBinds ticks pat val_expr
              tup_binds = zipWith mk_tup_bind ticks' binders
        ; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) }
   where
-    binders = collectPatBinders pat
+    pat' = strip_bangs pat
+           -- Strip the bangs before looking for case (A) or (B)
+           -- The incoming pattern may well have a bang on it
+
+    binders = collectPatBinders pat'
     ticks'  = ticks ++ repeat []
 
     local_binders = map localiseId binders      -- See Note [Localise pattern binders]
     local_tuple   = mkBigCoreVarTup1 binders
     tuple_ty      = exprType local_tuple
 
-is_simple_lpat :: LPat a -> Bool
-is_simple_lpat p = is_simple_pat (unLoc p)
+strip_bangs :: LPat a -> LPat a
+-- Remove outermost bangs and parens
+strip_bangs (L _ (ParPat p))  = strip_bangs p
+strip_bangs (L _ (BangPat p)) = strip_bangs p
+strip_bangs lp                = lp
 
-is_simple_pat :: Pat a -> Bool
-is_simple_pat (VarPat _)                   = True
-is_simple_pat (ParPat p)                   = is_simple_lpat p
-is_simple_pat (TuplePat ps Boxed _)        = all is_triv_lpat ps
-is_simple_pat (ConPatOut { pat_con = con
-                         , pat_args = ps}) = is_simple_con_pat con ps
-is_simple_pat _ = False
+is_flat_prod_lpat :: LPat a -> Bool
+is_flat_prod_lpat p = is_flat_prod_pat (unLoc p)
 
-is_simple_con_pat :: Located ConLike -> HsConPatDetails a -> Bool
-is_simple_con_pat con args
- = case con of
-     L _ (RealDataCon con) -> isProductTyCon (dataConTyCon con)
-                              && all is_triv_lpat (hsConPatArgs args)
-     L _ (PatSynCon {})    -> False
+is_flat_prod_pat :: Pat a -> Bool
+is_flat_prod_pat (ParPat p)            = is_flat_prod_lpat p
+is_flat_prod_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
+is_flat_prod_pat (ConPatOut { pat_con = L _ pcon, pat_args = ps})
+  | RealDataCon con <- pcon
+  , isProductTyCon (dataConTyCon con)
+  = all is_triv_lpat (hsConPatArgs ps)
+is_flat_prod_pat _ = False
 
 is_triv_lpat :: LPat a -> Bool
 is_triv_lpat p = is_triv_pat (unLoc p)
@@ -926,28 +955,25 @@ mkBinaryTickBox ixT ixF e = do
 
 -- *******************************************************************
 
--- | Remove any bang from a pattern and say if it is a strict bind,
--- also make irrefutable patterns ordinary patterns if -XStrict.
+-- | Use -XStrict to add a ! or remove a ~
 --
 -- Examples:
--- ~pat    => False, pat   -- when -XStrict
---                         -- even if pat = ~pat'
--- ~pat    => False, ~pat  -- without -XStrict
--- ~(~pat) => False, ~pat  -- when -XStrict
--- pat     => True,  pat   -- when -XStrict
--- !pat    => True,  pat   -- always
+-- ~pat    => pat    -- when -XStrict (even if pat = ~pat')
+-- !pat    => !pat   -- always
+-- pat     => !pat   -- when -XStrict
+-- pat     => pat    -- otherwise
 decideBangHood :: DynFlags
                -> LPat id  -- ^ Original pattern
                -> LPat id  -- Pattern with bang if necessary
 decideBangHood dflags lpat
+  | not (xopt LangExt.Strict dflags)
+  = lpat
+  | otherwise   --  -XStrict
   = go lpat
   where
-    xstrict = xopt LangExt.Strict dflags
-
     go lp@(L l p)
       = case p of
-           ParPat p              -> L l (ParPat (go p))
-           LazyPat lp' | xstrict -> lp'
-           BangPat _             -> lp
-           _ | xstrict   -> L l (BangPat lp)
-             | otherwise -> lp
+           ParPat p    -> L l (ParPat (go p))
+           LazyPat lp' -> lp'
+           BangPat _   -> lp
+           _           -> L l (BangPat lp)
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index 93d43c8d26..288fc40f45 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -763,12 +763,27 @@ matchSimply scrut hs_ctx pat result_expr fail_expr = do
 
 matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
                -> Type -> MatchResult -> DsM MatchResult
--- Do not warn about incomplete patterns
+-- 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
+  = match_single_pat_var var ctx pat ty match_result
+
+matchSinglePat scrut hs_ctx pat ty match_result
+  = do { var           <- selectSimpleMatchVarL pat
+       ; 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
+                     -> 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
        ; locn   <- getSrcSpanDs
+
                     -- Pattern match check warnings
        ; checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat)
 
@@ -776,10 +791,6 @@ matchSinglePat (Var var) ctx pat ty match_result
                                 , eqn_rhs  = match_result }
        ; match [var] ty [eqn_info] }
 
-matchSinglePat scrut hs_ctx pat ty match_result
-  = do { var <- selectSimpleMatchVarL pat
-       ; match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result
-       ; return (adjustMatchResult (bindNonRec var scrut) match_result') }
 
 
 {-