Refactoring around FunRhs

* Clarify the comments around the mc_strictness field of FunRhs
* Use record field names consistently for FunRhs

7 files changed, 45 insertions, 32 deletions

diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index ce114e727b..365524afab 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -1741,9 +1741,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 { mc_fun = L _ fun }
+                  -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
+             _    -> (pprMatchContext kind, \ pp -> pp)
 
 ppr_pats :: HsMatchContext Name -> [Pat GhcTc] -> SDoc
 ppr_pats kind pats
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index f08a6af700..d766ab2c13 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -129,9 +129,8 @@ 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]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
+{- Note [FunBind vs PatBind]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~
 The distinction between FunBind and PatBind is a bit subtle. FunBind covers
 patterns which resemble function bindings and simple variable bindings.
 
@@ -142,12 +141,17 @@ patterns which resemble function bindings and simple variable bindings.
     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 m_ctxt field of each Match in fun_matches will be FunRhs and carries
+two bits of information about the match,
+
+  * The mc_fixity field on each Match describes the fixity of the
+    function binder in that match.  E.g. this is legal:
+         f True False  = e1
+         True `f` True = e2
 
-  * 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
+  * The mc_strictness field is used /only/ for nullary FunBinds: ones
+    with one Match, which has no pats. For these, it describes whether
+    the match is decorated with a bang (e.g. `!x = e`).
 
 By contrast, PatBind represents data constructor patterns, as well as a few
 other interesting cases. Namely,
@@ -175,7 +179,7 @@ data HsBindLR idL idR
     --                                        @(f :: a -> a) = ... @
     --
     -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their
-    -- 'MatchContext'. See Note [Varieties of binding pattern matches] for
+    -- 'MatchContext'. See Note [FunBind vs PatBind] for
     -- details about the relationship between FunBind and PatBind.
     --
     --  'ApiAnnotation.AnnKeywordId's
@@ -219,7 +223,7 @@ data HsBindLR idL idR
   --
   -- The pattern is never a simple variable;
   -- That case is done by FunBind.
-  -- See Note [Varieties of binding pattern matches] for details about the
+  -- See Note [FunBind vs PatBind] for details about the
   -- relationship between FunBind and PatBind.
 
   --
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index 016b02fe2f..ae95b9caee 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -2359,11 +2359,10 @@ pp_dotdot = text " .. "
 -- Context of a pattern match. This is more subtle than it would seem. See Note
 -- [Varieties of pattern matches].
 data HsMatchContext id -- Not an extensible tag
-  = FunRhs { mc_fun :: Located id -- ^ function binder of @f@
-           , mc_fixity :: LexicalFixity -- ^ fixing of @f@
-           , mc_strictness :: SrcStrictness
-             -- ^ was the pattern banged? See
-             -- Note [Varieties of binding pattern matches]
+  = FunRhs { mc_fun        :: Located id    -- ^ function binder of @f@
+           , mc_fixity     :: LexicalFixity -- ^ fixing of @f@
+           , mc_strictness :: SrcStrictness -- ^ was @f@ banged?
+                                            -- See Note [FunBind vs PatBind]
            }
                                 -- ^A pattern matching on an argument of a
                                 -- function binding
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index ba001ea7ff..e953697ce2 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -758,7 +758,9 @@ mk_easy_FunBind loc fun pats expr
 
 -- | Make a prefix, non-strict function 'HsMatchContext'
 mkPrefixFunRhs :: Located id -> HsMatchContext id
-mkPrefixFunRhs n = FunRhs n Prefix NoSrcStrict
+mkPrefixFunRhs n = FunRhs { mc_fun = n
+                          , mc_fixity = Prefix
+                          , mc_strictness = NoSrcStrict }
 
 ------------
 mkMatch :: HsMatchContext (NameOrRdrName (IdP p)) -> [LPat p] -> LHsExpr p
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index f2c8b33000..408da044a9 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -514,10 +514,16 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
         do { unless (name == patsyn_name) $
                wrongNameBindingErr loc decl
            ; match <- case details of
-               PrefixCon pats ->
-                        return $ Match (FunRhs ln Prefix NoSrcStrict) pats Nothing rhs
-               InfixCon pat1 pat2 ->
-                       return $ Match (FunRhs ln Infix NoSrcStrict) [pat1, pat2] Nothing rhs
+               PrefixCon pats -> return $ Match { m_ctxt = ctxt, m_pats = pats
+                                                , m_type = Nothing, m_grhss = rhs }
+                   where
+                     ctxt = FunRhs { mc_fun = ln, mc_fixity = Prefix, mc_strictness = NoSrcStrict }
+
+               InfixCon p1 p2 -> return $ Match { m_ctxt = ctxt, m_pats = [p1, p2]
+                                                , m_type = Nothing, m_grhss = rhs }
+                   where
+                     ctxt = FunRhs { mc_fun = ln, mc_fixity = Infix, mc_strictness = NoSrcStrict }
+
                RecCon{} -> recordPatSynErr loc pat
            ; return $ L loc match }
     fromDecl (L loc decl) = extraDeclErr loc decl
@@ -960,7 +966,9 @@ checkFunBind msg strictness ann lhs_loc fun is_infix pats opt_sig (L rhs_span gr
         -- 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 { mc_fun    = fun
+                                                         , mc_fixity = is_infix
+                                                         , mc_strictness = strictness }
                                        , m_pats = ps
                                        , m_type = opt_sig
                                        , m_grhss = grhss })])
@@ -1075,7 +1083,7 @@ isFunLhs e = go e [] []
    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]
+        -- See Note [FunBind vs PatBind]
    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))
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index e18068bc2b..47bd0d9b79 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -47,7 +47,7 @@ import NameSet
 import RdrName          ( RdrName, rdrNameOcc )
 import SrcLoc
 import ListSetOps       ( findDupsEq )
-import BasicTypes       ( RecFlag(..), LexicalFixity(..) )
+import BasicTypes       ( RecFlag(..) )
 import Digraph          ( SCC(..) )
 import Bag
 import Util
@@ -1162,14 +1162,13 @@ rnMatch' ctxt rnBody match@(Match { m_ctxt = mf, m_pats = pats
                 Nothing -> return ()
                 Just (L loc ty) -> addErrAt loc (resSigErr match ty)
 
-        ; let fixity = if isInfixMatch match then Infix else Prefix
                -- Now the main event
                -- Note that there are no local fixity decls for matches
         ; rnPats ctxt pats      $ \ pats' -> do
         { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss
-        ; let mf' = case (ctxt,mf) of
-                      (FunRhs (L _ funid) _ _,FunRhs (L lf _) _ strict)
-                                            -> FunRhs (L lf funid) fixity strict
+        ; let mf' = case (ctxt, mf) of
+                      (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ })
+                                            -> mf { mc_fun = L lf funid }
                       _                     -> ctxt
         ; return (Match { m_ctxt = mf', m_pats = pats'
                         , m_type = Nothing, m_grhss = grhss'}, grhss_fvs ) }}
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
index 8207169d41..d4fdc11111 100644
--- a/compiler/typecheck/TcMatches.hs
+++ b/compiler/typecheck/TcMatches.hs
@@ -99,10 +99,11 @@ tcMatchesFun fn@(L _ fun_name) matches exp_ty
     arity = matchGroupArity matches
     herald = text "The equation(s) for"
              <+> quotes (ppr fun_name) <+> text "have"
-    match_ctxt = MC { mc_what = FunRhs fn Prefix strictness, mc_body = tcBody }
+    what = FunRhs { mc_fun = fn, mc_fixity = Prefix, mc_strictness = strictness }
+    match_ctxt = MC { mc_what = what, mc_body = tcBody }
     strictness
       | [L _ match] <- unLoc $ mg_alts matches
-      , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match
+      , FunRhs{ mc_strictness = SrcStrict } <- m_ctxt match
       = SrcStrict
       | otherwise
       = NoSrcStrict