Treat banged bindings as FunBinds

This is another attempt at resolving #13594 by treating strict variable
binds as FunBinds instead of PatBinds (as suggested in comment:1).

Test Plan: Validate

Reviewers: austin, alanz

Subscribers: rwbarton, thomie, mpickering

GHC Trac Issues: #13594

Differential Revision: https://phabricator.haskell.org/D3670

2 files changed, 36 insertions, 20 deletions

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 02aeb86180..6e4b7740d5 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -2181,20 +2181,28 @@ docdecld :: { LDocDecl }
 decl_no_th :: { LHsDecl GhcPs }
         : sigdecl               { $1 }
 
-        | '!' aexp rhs          {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2) };
-                                        pat <- checkPattern empty e;
-                                        _ <- ams (sLL $1 $> ())
-                                               (fst $ unLoc $3);
-                                        return $ sLL $1 $> $ ValD $
-                                            PatBind pat (snd $ unLoc $3)
-                                                    placeHolderType
-                                                    placeHolderNames
-                                                    ([],[]) } }
-                                -- Turn it all into an expression so that
-                                -- checkPattern can check that bangs are enabled
-
-        | infixexp_top opt_sig rhs  {% do { (ann,r) <- checkValDef empty $1 (snd $2) $3;
+        | '!' aexp rhs          {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)
+                                              -- Turn it all into an expression so that
+                                              -- checkPattern can check that bangs are enabled
+                                            ; l = comb2 $1 $> };
+                                        (ann, r) <- checkValDef empty SrcStrict e Nothing $3 ;
+                                        -- Depending upon what the pattern looks like we might get either
+                                        -- a FunBind or PatBind back from checkValDef. See Note
+                                        -- [Varieties of binding pattern matches]
+                                        case r of {
+                                          (FunBind n _ _ _ _) ->
+                                                ams (L l ()) [mj AnnFunId n] >> return () ;
+                                          (PatBind (L lh _lhs) _rhs _ _ _) ->
+                                                ams (L lh ()) [] >> return () } ;
+
+                                        _ <- ams (L l ()) (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ;
+                                        return $! (sL l $ ValD r) } }
+
+        | infixexp_top opt_sig rhs  {% do { (ann,r) <- checkValDef empty NoSrcStrict $1 (snd $2) $3;
                                         let { l = comb2 $1 $> };
+                                        -- Depending upon what the pattern looks like we might get either
+                                        -- a FunBind or PatBind back from checkValDef. See Note
+                                        -- [Varieties of binding pattern matches]
                                         case r of {
                                           (FunBind n _ _ _ _) ->
                                                 ams (L l ()) (mj AnnFunId n:(fst $2)) >> return () ;
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index eb78073b66..f2c8b33000 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -515,9 +515,9 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
                wrongNameBindingErr loc decl
            ; match <- case details of
                PrefixCon pats ->
-                        return $ Match (FunRhs ln Prefix) pats Nothing rhs
+                        return $ Match (FunRhs ln Prefix NoSrcStrict) pats Nothing rhs
                InfixCon pat1 pat2 ->
-                       return $ Match (FunRhs ln Infix) [pat1, pat2] Nothing rhs
+                       return $ Match (FunRhs ln Infix NoSrcStrict) [pat1, pat2] Nothing rhs
                RecCon{} -> recordPatSynErr loc pat
            ; return $ L loc match }
     fromDecl (L loc decl) = extraDeclErr loc decl
@@ -925,25 +925,27 @@ patIsRec e = e == mkUnqual varName (fsLit "rec")
 -- Check Equation Syntax
 
 checkValDef :: SDoc
+            -> SrcStrictness
             -> LHsExpr GhcPs
             -> Maybe (LHsType GhcPs)
             -> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
             -> P ([AddAnn],HsBind GhcPs)
 
-checkValDef msg lhs (Just sig) grhss
+checkValDef msg _strictness lhs (Just sig) grhss
         -- x :: ty = rhs  parses as a *pattern* binding
   = checkPatBind msg (L (combineLocs lhs sig)
                         (ExprWithTySig lhs (mkLHsSigWcType sig))) grhss
 
-checkValDef msg lhs opt_sig g@(L l (_,grhss))
+checkValDef msg strictness lhs opt_sig g@(L l (_,grhss))
   = do  { mb_fun <- isFunLhs lhs
         ; case mb_fun of
             Just (fun, is_infix, pats, ann) ->
-              checkFunBind msg ann (getLoc lhs)
+              checkFunBind msg strictness ann (getLoc lhs)
                            fun is_infix pats opt_sig (L l grhss)
             Nothing -> checkPatBind msg lhs g }
 
 checkFunBind :: SDoc
+             -> SrcStrictness
              -> [AddAnn]
              -> SrcSpan
              -> Located RdrName
@@ -952,13 +954,13 @@ checkFunBind :: SDoc
              -> Maybe (LHsType GhcPs)
              -> Located (GRHSs GhcPs (LHsExpr GhcPs))
              -> P ([AddAnn],HsBind GhcPs)
-checkFunBind msg ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
+checkFunBind msg strictness ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
   = do  ps <- checkPatterns msg pats
         let match_span = combineSrcSpans lhs_loc rhs_span
         -- Add back the annotations stripped from any HsPar values in the lhs
         -- mapM_ (\a -> a match_span) ann
         return (ann, makeFunBind fun
-                  [L match_span (Match { m_ctxt = FunRhs fun is_infix
+                  [L match_span (Match { m_ctxt = FunRhs fun is_infix strictness
                                        , m_pats = ps
                                        , m_type = opt_sig
                                        , m_grhss = grhss })])
@@ -1072,6 +1074,12 @@ isFunLhs e = go e [] []
    go (L _ (HsApp f e)) es       ann = go f (e:es) ann
    go (L l (HsPar e))   es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
 
+        -- Things of the form `!x` are also FunBinds
+        -- See Note [Varieties of binding pattern matches]
+   go (L _ (SectionR (L _ (HsVar (L _ bang))) (L l (HsVar (L _ var))))) [] ann
+        | bang == bang_RDR
+        , not (isRdrDataCon var)     = return (Just (L l var, Prefix, [], ann))
+
         -- For infix function defns, there should be only one infix *function*
         -- (though there may be infix *datacons* involved too).  So we don't
         -- need fixity info to figure out which function is being defined.