Revert "Treat banged bindings as FunBinds"
authorBen Gamari <ben@smart-cactus.org>
Fri, 12 May 2017 20:59:33 +0000 (16:59 -0400)
committerBen Gamari <ben@smart-cactus.org>
Fri, 12 May 2017 22:26:51 +0000 (18:26 -0400)
This partially reverts commit 372995364c52eef15066132d7d1ea8b6760034e6 as it
doesn't actually fix #13594. Namely it does not revert the mkPrefixFunRhs
refactoring since this is rather independent from the functional changes.

Going to try again with a whole working patch

compiler/deSugar/Check.hs
compiler/hsSyn/HsBinds.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsUtils.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/rename/RnBinds.hs
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr

index 3215856..4b01aac 100644 (file)
@@ -1742,9 +1742,9 @@ pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun
 
     (ppr_match, pref)
         = case kind of
-             FunRhs (L _ fun) _ -> (pprMatchContext kind,
-                                      \ pp -> ppr fun <+> pp)
-             _                    -> (pprMatchContext kind, \ pp -> pp)
+             FunRhs (L _ fun) _ -> (pprMatchContext kind,
+                                    \ pp -> ppr fun <+> pp)
+             _                  -> (pprMatchContext kind, \ pp -> pp)
 
 ppr_pats :: HsMatchContext Name -> [Pat Id] -> SDoc
 ppr_pats kind pats
index 5fd523f..b39e25a 100644 (file)
@@ -132,41 +132,12 @@ type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
 -- | Located Haskell Binding with separate Left and Right identifier types
 type LHsBindLR  idL idR = Located (HsBindLR idL idR)
 
-{- Note [Varieties of binding pattern matches]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The distinction between FunBind and PatBind is a bit subtle. FunBind covers
-patterns which resemble function bindings and simple variable bindings.
-
-    f x = e
-    f !x = e
-    f = e
-    !x = e          -- FunRhs has SrcStrict
-    x `f` y = e     -- FunRhs has Infix
-
-The actual patterns and RHSs of a FunBind are encoding in fun_matches.
-The m_ctxt field of Match will be FunRhs and carries two bits of information
-about the match,
-
-  * the mc_strictness field describes whether the match is decorated with a bang
-    (e.g. `!x = e`)
-  * the mc_fixity field describes the fixity of the function binder
-
-By contrast, PatBind represents data constructor patterns, as well as a few
-other interesting cases. Namely,
-
-    Just x = e
-    (x) = e
-    x :: Ty = e
--}
-
 -- | Haskell Binding with separate Left and Right id's
 data HsBindLR idL idR
-  = -- | Function-like Binding
+  = -- | Function Binding
     --
     -- FunBind is used for both functions     @f x = e@
     -- and variables                          @f = \x -> e@
-    -- and strict variables                   @!x = x + 1@
     --
     -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'.
     --
@@ -177,10 +148,6 @@ data HsBindLR idL idR
     -- parses as a pattern binding, just like
     --                                        @(f :: a -> a) = ... @
     --
-    -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their
-    -- 'MatchContext'. See Note [Varities of binding pattern matches] for
-    -- details about the relationship between FunBind and PatBind.
-    --
     --  'ApiAnnotation.AnnKeywordId's
     --
     --  - 'ApiAnnotation.AnnFunId', attached to each element of fun_matches
@@ -221,10 +188,7 @@ data HsBindLR idL idR
   -- | Pattern Binding
   --
   -- The pattern is never a simple variable;
-  -- That case is done by FunBind.
-  -- See Note [Varities of binding pattern matches] for details about the
-  -- relationship between FunBind and PatBind.
-
+  -- That case is done by FunBind
   --
   --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang',
   --       'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',
index 750578b..f32c24e 100644 (file)
@@ -1454,8 +1454,8 @@ Example infix function definition requiring individual API Annotations
 
 isInfixMatch :: Match id body -> Bool
 isInfixMatch match = case m_ctxt match of
-  FunRhs {mc_fixity = Infix} -> True
-  _                          -> False
+  FunRhs _ Infix -> True
+  _              -> False
 
 isEmptyMatchGroup :: MatchGroup id body -> Bool
 isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms
@@ -1534,7 +1534,7 @@ pprMatch match
     ctxt = m_ctxt match
     (herald, other_pats)
         = case ctxt of
-            FunRhs {mc_fun=L _ fun, mc_fixity=fixity}
+            FunRhs (L _ fun) fixity
                 | fixity == Prefix -> (pprPrefixOcc fun, m_pats match)
                         -- f x y z = e
                         -- Not pprBndr; the AbsBinds will
@@ -2333,17 +2333,9 @@ pp_dotdot = text " .. "
 
 -- | Haskell Match Context
 --
--- Context of a pattern match. This is more subtle than it would seem. See Note
--- [Varieties of pattern matches].
+-- Context of a Match
 data HsMatchContext id
-  = FunRhs { mc_fun :: Located id -- ^ function binder of @f@
-           , mc_fixity :: LexicalFixity -- ^ fixing of @f@
-           , mc_strictness :: SrcStrictness
-             -- ^ was the pattern banged? See
-             -- Note [Varities of binding pattern matches]
-           }
-                                -- ^A pattern matching on an argument of a
-                                -- function binding
+  = FunRhs (Located id) LexicalFixity -- ^Function binding for f, fixity
   | LambdaExpr                  -- ^Patterns of a lambda
   | CaseAlt                     -- ^Patterns and guards on a case alternative
   | IfAlt                       -- ^Guards of a multi-way if alternative
@@ -2364,8 +2356,7 @@ data HsMatchContext id
 deriving instance (DataIdPost id) => Data (HsMatchContext id)
 
 instance OutputableBndr id => Outputable (HsMatchContext id) where
-  ppr (FunRhs (L _ id) fix str)
-                            = text "FunRhs" <+> ppr id <+> ppr fix <+> ppr str
+  ppr (FunRhs (L _ id) fix) = text "FunRhs" <+> ppr id <+> ppr fix
   ppr LambdaExpr            = text "LambdaExpr"
   ppr CaseAlt               = text "CaseAlt"
   ppr IfAlt                 = text "IfAlt"
@@ -2450,8 +2441,7 @@ pprMatchContext ctxt
 
 pprMatchContextNoun :: (Outputable (NameOrRdrName id),Outputable id)
                     => HsMatchContext id -> SDoc
-pprMatchContextNoun (FunRhs {mc_fun=L _ fun})
-                                    = text "equation for"
+pprMatchContextNoun (FunRhs (L _ fun) _) = text "equation for"
                                       <+> quotes (ppr fun)
 pprMatchContextNoun CaseAlt         = text "case alternative"
 pprMatchContextNoun IfAlt           = text "multi-way if alternative"
@@ -2511,7 +2501,7 @@ instance (Outputable id, Outputable (NameOrRdrName id))
 -- Used to generate the string for a *runtime* error message
 matchContextErrString :: Outputable id
                       => HsMatchContext id -> SDoc
-matchContextErrString (FunRhs{mc_fun=L _ fun})   = text "function" <+> ppr fun
+matchContextErrString (FunRhs (L _ fun) _)       = text "function" <+> ppr fun
 matchContextErrString CaseAlt                    = text "case"
 matchContextErrString IfAlt                      = text "multi-way if"
 matchContextErrString PatBindRhs                 = text "pattern binding"
index a15aa15..4b07683 100644 (file)
@@ -751,9 +751,9 @@ mk_easy_FunBind loc fun pats expr
               [mkMatch (mkPrefixFunRhs (L loc fun)) pats expr
                        (noLoc emptyLocalBinds)]
 
--- | Make a prefix, non-strict function 'HsMatchContext'
+-- | Make a prefix 'FunRhs' 'HsMatchContext'
 mkPrefixFunRhs :: Located id -> HsMatchContext id
-mkPrefixFunRhs n = FunRhs n Prefix NoSrcStrict
+mkPrefixFunRhs n = FunRhs n Prefix
 
 ------------
 mkMatch :: HsMatchContext (NameOrRdrName id) -> [LPat id] -> LHsExpr id
index c525ddf..7af0205 100644 (file)
@@ -2181,28 +2181,20 @@ docdecld :: { LDocDecl }
 decl_no_th :: { LHsDecl RdrName }
         : sigdecl               { $1 }
 
-        | '!' 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)) ;
-                                        return $! (sL l $ ValD r) } }
-
-        | infixexp_top opt_sig rhs  {% do { (ann,r) <- checkValDef empty NoSrcStrict $1 (snd $2) $3;
+        | '!' 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;
                                         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 () ;
index d7facdc..d6fc6fb 100644 (file)
@@ -514,9 +514,9 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
                wrongNameBindingErr loc decl
            ; match <- case details of
                PrefixCon pats ->
-                        return $ Match (FunRhs ln Prefix NoSrcStrict) pats Nothing rhs
+                        return $ Match (FunRhs ln Prefix) pats Nothing rhs
                InfixCon pat1 pat2 ->
-                       return $ Match (FunRhs ln Infix NoSrcStrict) [pat1, pat2] Nothing rhs
+                       return $ Match (FunRhs ln Infix) [pat1, pat2] Nothing rhs
                RecCon{} -> recordPatSynErr loc pat
            ; return $ L loc match }
     fromDecl (L loc decl) = extraDeclErr loc decl
@@ -923,27 +923,25 @@ patIsRec e = e == mkUnqual varName (fsLit "rec")
 -- Check Equation Syntax
 
 checkValDef :: SDoc
-            -> SrcStrictness
             -> LHsExpr RdrName
             -> Maybe (LHsType RdrName)
             -> Located (a,GRHSs RdrName (LHsExpr RdrName))
             -> P ([AddAnn],HsBind RdrName)
 
-checkValDef msg _strictness lhs (Just sig) grhss
+checkValDef msg 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 strictness lhs opt_sig g@(L l (_,grhss))
+checkValDef msg lhs opt_sig g@(L l (_,grhss))
   = do  { mb_fun <- isFunLhs lhs
         ; case mb_fun of
             Just (fun, is_infix, pats, ann) ->
-              checkFunBind msg strictness ann (getLoc lhs)
+              checkFunBind msg 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 +950,13 @@ checkFunBind :: SDoc
              -> Maybe (LHsType RdrName)
              -> Located (GRHSs RdrName (LHsExpr RdrName))
              -> P ([AddAnn],HsBind RdrName)
-checkFunBind msg strictness ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
+checkFunBind msg 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 strictness
+                  [L match_span (Match { m_ctxt = FunRhs fun is_infix
                                        , m_pats = ps
                                        , m_type = opt_sig
                                        , m_grhss = grhss })])
index f91ca52..7f0490a 100644 (file)
@@ -1166,8 +1166,8 @@ rnMatch' ctxt rnBody match@(Match { m_ctxt = mf, m_pats = pats
         ; rnPats ctxt pats      $ \ pats' -> do
         { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss
         ; let mf' = case (ctxt,mf) of
-                      (FunRhs (L _ funid) _ _,FunRhs (L lf _) _ _)
-                                            -> FunRhs (L lf funid) fixity NoSrcStrict -- TODO: Is this right?
+                      (FunRhs (L _ funid) _,FunRhs (L lf _) _)
+                                            -> FunRhs (L lf funid) fixity
                       _                     -> ctxt
         ; return (Match { m_ctxt = mf', m_pats = pats'
                         , m_type = Nothing, m_grhss = grhss'}, grhss_fvs ) }}
index ad3680e..9f9cf65 100644 (file)
            (FunRhs 
             ({ DumpParsedAst.hs:11:1-4 }
              (Unqual {OccName: main})) 
-            (Prefix) 
-            (NoSrcStrict)) 
+            (Prefix)) 
            [] 
            (Nothing) 
            (GRHSs 
index c873ee1..d0b456a 100644 (file)
@@ -17,8 +17,7 @@
            (Match 
             (FunRhs 
              ({ DumpRenamedAst.hs:11:1-4 }{Name: main:DumpRenamedAst.main{v}}) 
-             (Prefix) 
-             (NoSrcStrict)) 
+             (Prefix)) 
             [] 
             (Nothing) 
             (GRHSs 
index 663a7d7..4b10222 100644 (file)
           (Match 
            (FunRhs 
             ({ DumpTypecheckedAst.hs:11:1-4 }{Name: main:DumpTypecheckedAst.main{v}}) 
-            (Prefix) 
-            (NoSrcStrict)) 
+            (Prefix)) 
            [] 
            (Nothing) 
            (GRHSs