Remove fun_infix from Funbind, as it is now in Match
authorAlan Zimmerman <alan.zimm@gmail.com>
Wed, 11 Nov 2015 11:03:18 +0000 (12:03 +0100)
committerBen Gamari <ben@smart-cactus.org>
Wed, 11 Nov 2015 11:04:22 +0000 (12:04 +0100)
One of the changes D538 introduced is to add `m_fun_id_infix` to `Match`

```lang=hs
data Match id body
  = Match {
        m_fun_id_infix :: (Maybe (Located id,Bool)),
          -- fun_id and fun_infix for functions with multiple equations
          -- only present for a RdrName. See note [fun_id in Match]
        m_pats :: [LPat id], -- The patterns
        m_type :: (Maybe (LHsType id)),
                                 -- A type signature for the result of the match
                                 -- Nothing after typechecking
        m_grhss :: (GRHSs id body)
  } deriving (Typeable)
```

This was done to track the individual locations and fixity of the
`fun_id` for each of the defining equations for a function when there
are more than one.

For example, the function `(&&&)` is defined with some prefix and some
infix equations below.

```lang=hs
    (&&&  ) [] [] =  []
    xs    &&&   [] =  xs
    (  &&&  ) [] ys =  ys
```

This means that the fun_infix is now superfluous in the `FunBind`. This
has not been removed as a potentially risky change just before 7.10 RC2,
and so must be done after.

This ticket captures that task, which includes processing these fields
through the renamer and beyond.

Ticket #9988 introduced these fields into `Match` through renaming, this
ticket it to continue through type checking and then remove it from
`FunBind` completely.

The split happened so that #9988 could land in 7.10

Trac ticket : #10061

Test Plan: ./validate

Reviewers: goldfire, austin, simonpj, bgamari

Reviewed By: bgamari

Subscribers: simonpj, thomie, mpickering

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

GHC Trac Issues: #10061

16 files changed:
compiler/deSugar/DsBinds.hs
compiler/deSugar/DsExpr.hs
compiler/deSugar/Match.hs
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsBinds.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsExpr.hs-boot
compiler/hsSyn/HsUtils.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/rename/RnBinds.hs
compiler/typecheck/TcArrows.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcMatches.hs
compiler/typecheck/TcMatches.hs-boot
compiler/typecheck/TcPatSyn.hs

index 93b50df..47a3419 100644 (file)
@@ -108,10 +108,9 @@ dsHsBind (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless
         ; return (unitOL (makeCorePair dflags var' False 0 core_expr)) }
 
 dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches
-                  , fun_co_fn = co_fn, fun_tick = tick
-                  , fun_infix = inf })
+                  , fun_co_fn = co_fn, fun_tick = tick })
  = do   { dflags <- getDynFlags
-        ; (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
+        ; (args, body) <- matchWrapper (FunRhs (idName fun)) matches
         ; let body' = mkOptTickBox tick body
         ; rhs <- dsHsWrapper co_fn (mkLams args body')
         ; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -}
index 075a647..0f5d6e5 100644 (file)
@@ -144,10 +144,10 @@ dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
        ; return (mkCoreLets ds_binds body2) }
 
 dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn
-                      , fun_tick = tick, fun_infix = inf }) body
+                      , fun_tick = tick }) body
                 -- Can't be a bang pattern (that looks like a PatBind)
                 -- so must be simply unboxed
-  = do { (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
+  = do { (args, rhs) <- matchWrapper (FunRhs (idName fun )) matches
        ; MASSERT( null args ) -- Functions aren't lifted
        ; MASSERT( isIdHsWrapper co_fn )
        ; let rhs' = mkOptTickBox tick rhs
index 5840578..8af0a6e 100644 (file)
@@ -148,8 +148,8 @@ pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun
   where
     (ppr_match, pref)
         = case kind of
-             FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
-             _            -> (pprMatchContext kind, \ pp -> pp)
+             FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
+             _          -> (pprMatchContext kind, \ pp -> pp)
 
 ppr_pats :: Outputable a => [a] -> SDoc
 ppr_pats pats = sep (map ppr pats)
index 28b699d..2d7194e 100644 (file)
@@ -630,7 +630,7 @@ cvtClause (Clause ps body wheres)
   = do  { ps' <- cvtPats ps
         ; g'  <- cvtGuard body
         ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres
-        ; returnL $ Hs.Match Nothing ps' Nothing (GRHSs g' ds') }
+        ; returnL $ Hs.Match NonFunBindMatch ps' Nothing (GRHSs g' ds') }
 
 
 -------------------------------------------------------------------
@@ -851,7 +851,7 @@ cvtMatch (TH.Match p body decs)
   = do  { p' <- cvtPat p
         ; g' <- cvtGuard body
         ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs
-        ; returnL $ Hs.Match Nothing [p'] Nothing (GRHSs g' decs') }
+        ; returnL $ Hs.Match NonFunBindMatch [p'] Nothing (GRHSs g' decs') }
 
 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)]
 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
index b1d13ca..978d363 100644 (file)
@@ -140,8 +140,6 @@ data HsBindLR idL idR
 
         fun_id :: Located idL, -- Note [fun_id in Match] in HsExpr
 
-        fun_infix :: Bool,      -- ^ True => infix declaration
-
         fun_matches :: MatchGroup idR (LHsExpr idR),  -- ^ The payload
 
         fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of
@@ -488,14 +486,14 @@ ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
   = pprPatBind pat grhss
 ppr_monobind (VarBind { var_id = var, var_rhs = rhs })
   = sep [pprBndr CaseBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]
-ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
+ppr_monobind (FunBind { fun_id = fun,
                         fun_co_fn = wrap,
                         fun_matches = matches,
                         fun_tick = ticks })
   = pprTicks empty (if null ticks then empty
                     else text "-- ticks = " <> ppr ticks)
     $$  ifPprDebug (pprBndr LetBind (unLoc fun))
-    $$  pprFunBind (unLoc fun) inf matches
+    $$  pprFunBind (unLoc fun) matches
     $$  ifPprDebug (ppr wrap)
 ppr_monobind (PatSynBind psb) = ppr psb
 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
@@ -522,18 +520,18 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL
       ppr_lhs = ptext (sLit "pattern") <+> ppr_details
       ppr_simple syntax = syntax <+> ppr pat
 
-      (is_infix, ppr_details) = case details of
-          InfixPatSyn v1 v2 -> (True, hsep [ppr v1, pprInfixOcc psyn, ppr v2])
-          PrefixPatSyn vs   -> (False, hsep (pprPrefixOcc psyn : map ppr vs))
+      ppr_details = case details of
+          InfixPatSyn v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2]
+          PrefixPatSyn vs   -> hsep (pprPrefixOcc psyn : map ppr vs)
           RecordPatSyn vs   ->
-            (False, pprPrefixOcc psyn
-                      <> braces (sep (punctuate comma (map ppr vs))))
+            pprPrefixOcc psyn
+                      <> braces (sep (punctuate comma (map ppr vs)))
 
       ppr_rhs = case dir of
           Unidirectional           -> ppr_simple (ptext (sLit "<-"))
           ImplicitBidirectional    -> ppr_simple equals
           ExplicitBidirectional mg -> ppr_simple (ptext (sLit "<-")) <+> ptext (sLit "where") $$
-                                      (nest 2 $ pprFunBind psyn is_infix mg)
+                                      (nest 2 $ pprFunBind psyn mg)
 
 pprTicks :: SDoc -> SDoc -> SDoc
 -- Print stuff about ticks only when -dppr-debug is on, to avoid
index 5ee17cf..19e7d2f 100644 (file)
@@ -1123,9 +1123,8 @@ type LMatch id body = Located (Match id body)
 -- For details on above see note [Api annotations] in ApiAnnotation
 data Match id body
   = Match {
-        m_fun_id_infix :: (Maybe (Located id,Bool)),
-          -- fun_id and fun_infix for functions with multiple equations
-          -- only present for a RdrName. See note [fun_id in Match]
+        m_fixity :: MatchFixity id,
+          -- See note [m_fixity in Match]
         m_pats :: [LPat id], -- The patterns
         m_type :: (Maybe (LHsType id)),
                                  -- A type signature for the result of the match
@@ -1135,7 +1134,7 @@ data Match id body
 deriving instance (Data body,DataId id) => Data (Match id body)
 
 {-
-Note [fun_id in Match]
+Note [m_fixity in Match]
 ~~~~~~~~~~~~~~~~~~~~~~
 
 The parser initially creates a FunBind with a single Match in it for
@@ -1160,6 +1159,20 @@ Example infix function definition requiring individual API Annotations
 
 -}
 
+-- |When a Match is part of a FunBind, it captures one complete equation for the
+-- function. As such it has the function name, and its fixity.
+data MatchFixity id
+  = NonFunBindMatch
+  | FunBindMatch (Located id) -- of the Id
+                 Bool         -- is infix
+  deriving (Typeable)
+deriving instance (DataId id) => Data (MatchFixity id)
+
+isInfixMatch :: Match id body -> Bool
+isInfixMatch match = case m_fixity match of
+  FunBindMatch _ True -> True
+  _                   -> False
+
 isEmptyMatchGroup :: MatchGroup id body -> Bool
 isEmptyMatchGroup (MG { mg_alts = ms }) = null ms
 
@@ -1206,8 +1219,8 @@ pprMatches ctxt (MG { mg_alts = matches })
 
 -- Exported to HsBinds, which can't see the defn of HsMatchContext
 pprFunBind :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
-           => idL -> Bool -> MatchGroup idR body -> SDoc
-pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches
+           => idL -> MatchGroup idR body -> SDoc
+pprFunBind fun matches = pprMatches (FunRhs fun) matches
 
 -- Exported to HsBinds, which can't see the defn of HsMatchContext
 pprPatBind :: forall bndr id body. (OutputableBndr bndr, OutputableBndr id, Outputable body)
@@ -1217,15 +1230,16 @@ pprPatBind pat (grhss)
 
 pprMatch :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
          => HsMatchContext idL -> Match idR body -> SDoc
-pprMatch ctxt (Match _ pats maybe_ty grhss)
+pprMatch ctxt match
   = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats)
         , nest 2 ppr_maybe_ty
-        , nest 2 (pprGRHSs ctxt grhss) ]
+        , nest 2 (pprGRHSs ctxt (m_grhss match)) ]
   where
+    is_infix = isInfixMatch match
     (herald, other_pats)
         = case ctxt of
-            FunRhs fun is_infix
-                | not is_infix -> (pprPrefixOcc fun, pats)
+            FunRhs fun
+                | not is_infix -> (pprPrefixOcc fun, m_pats match)
                         -- f x y z = e
                         -- Not pprBndr; the AbsBinds will
                         -- have printed the signature
@@ -1238,14 +1252,14 @@ pprMatch ctxt (Match _ pats maybe_ty grhss)
                 where
                   pp_infix = pprParendLPat pat1 <+> pprInfixOcc fun <+> pprParendLPat pat2
 
-            LambdaExpr -> (char '\\', pats)
+            LambdaExpr -> (char '\\', m_pats match)
 
             _  -> ASSERT( null pats1 )
                   (ppr pat1, [])        -- No parens around the single pat
 
-    (pat1:pats1) = pats
+    (pat1:pats1) = m_pats match
     (pat2:pats2) = pats1
-    ppr_maybe_ty = case maybe_ty of
+    ppr_maybe_ty = case m_type match of
                         Just ty -> dcolon <+> ppr ty
                         Nothing -> empty
 
@@ -1918,7 +1932,7 @@ pp_dotdot = ptext (sLit " .. ")
 -}
 
 data HsMatchContext id  -- Context of a Match
-  = FunRhs id Bool              -- Function binding for f; True <=> written infix
+  = FunRhs id                   -- Function binding for f
   | LambdaExpr                  -- Patterns of a lambda
   | CaseAlt                     -- Patterns and guards on a case alternative
   | IfAlt                       -- Guards of a multi-way if alternative
@@ -1990,7 +2004,7 @@ pprMatchContext ctxt
     want_an _           = False
 
 pprMatchContextNoun :: Outputable id => HsMatchContext id -> SDoc
-pprMatchContextNoun (FunRhs fun _)  = ptext (sLit "equation for")
+pprMatchContextNoun (FunRhs fun)    = ptext (sLit "equation for")
                                       <+> quotes (ppr fun)
 pprMatchContextNoun CaseAlt         = ptext (sLit "case alternative")
 pprMatchContextNoun IfAlt           = ptext (sLit "multi-way if alternative")
@@ -2042,13 +2056,13 @@ pprStmtContext (TransStmtCtxt c)
 
 -- Used to generate the string for a *runtime* error message
 matchContextErrString :: Outputable id => HsMatchContext id -> SDoc
-matchContextErrString (FunRhs fun _)             = ptext (sLit "function") <+> ppr fun
-matchContextErrString CaseAlt                    = ptext (sLit "case")
-matchContextErrString IfAlt                      = ptext (sLit "multi-way if")
-matchContextErrString PatBindRhs                 = ptext (sLit "pattern binding")
-matchContextErrString RecUpd                     = ptext (sLit "record update")
-matchContextErrString LambdaExpr                 = ptext (sLit "lambda")
-matchContextErrString ProcExpr                   = ptext (sLit "proc")
+matchContextErrString (FunRhs fun)         = ptext (sLit "function") <+> ppr fun
+matchContextErrString CaseAlt              = ptext (sLit "case")
+matchContextErrString IfAlt                = ptext (sLit "multi-way if")
+matchContextErrString PatBindRhs           = ptext (sLit "pattern binding")
+matchContextErrString RecUpd               = ptext (sLit "record update")
+matchContextErrString LambdaExpr           = ptext (sLit "lambda")
+matchContextErrString ProcExpr             = ptext (sLit "proc")
 matchContextErrString ThPatSplice                = panic "matchContextErrString"  -- Not used at runtime
 matchContextErrString ThPatQuote                 = panic "matchContextErrString"  -- Not used at runtime
 matchContextErrString PatSyn                     = panic "matchContextErrString"  -- Not used at runtime
index eb9d23a..bb5142f 100644 (file)
@@ -53,4 +53,4 @@ pprPatBind :: (OutputableBndr bndr, OutputableBndr id, Outputable body)
            => LPat bndr -> GRHSs id body -> SDoc
 
 pprFunBind :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
-           => idL -> Bool -> MatchGroup idR body -> SDoc
+           => idL -> MatchGroup idR body -> SDoc
index a2ed948..e88c7b6 100644 (file)
@@ -39,6 +39,7 @@ module HsUtils(
   -- Bindings
   mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
   mkPatSynBind,
+  isInfixFunBind,
 
   -- Literals
   mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,
@@ -134,7 +135,7 @@ mkHsPar e = L (getLoc e) (HsPar e)
 mkSimpleMatch :: [LPat id] -> Located (body id) -> LMatch id (Located (body id))
 mkSimpleMatch pats rhs
   = L loc $
-    Match Nothing pats Nothing (unguardedGRHSs rhs)
+    Match NonFunBindMatch pats Nothing (unguardedGRHSs rhs)
   where
     loc = case pats of
                 []      -> getLoc rhs
@@ -603,7 +604,7 @@ l
 mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)]
           -> HsBind RdrName
 -- Not infix, with place holders for coercion and free vars
-mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
+mkFunBind fn ms = FunBind { fun_id = fn
                           , fun_matches = mkMatchGroup Generated ms
                           , fun_co_fn = idHsWrapper
                           , bind_fvs = placeHolderNames
@@ -612,7 +613,7 @@ mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
 mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)]
              -> HsBind Name
 -- In Name-land, with empty bind_fvs
-mkTopFunBind origin fn ms = FunBind { fun_id = fn, fun_infix = False
+mkTopFunBind origin fn ms = FunBind { fun_id = fn
                                     , fun_matches = mkMatchGroupName origin ms
                                     , fun_co_fn = idHsWrapper
                                     , bind_fvs = emptyNameSet -- NB: closed
@@ -636,6 +637,16 @@ mkPatSynBind name details lpat dir = PatSynBind psb
              , psb_dir = dir
              , psb_fvs = placeHolderNames }
 
+-- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
+-- considered infix.
+isInfixFunBind :: HsBindLR id1 id2 -> Bool
+isInfixFunBind (FunBind _ (MG matches _ _ _) _ _ _)
+  = any isInfix matches
+  where
+    isInfix (L _ match) = isInfixMatch match
+isInfixFunBind _ = False
+
+
 ------------
 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
                 -> LHsExpr RdrName -> LHsBind RdrName
@@ -645,7 +656,7 @@ mk_easy_FunBind loc fun pats expr
 ------------
 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id)
 mkMatch pats expr binds
-  = noLoc (Match Nothing (map paren pats) Nothing
+  = noLoc (Match NonFunBindMatch (map paren pats) Nothing
                  (GRHSs (unguardedRHS noSrcSpan expr) binds))
   where
     paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
index e4ff162..479fc28 100644 (file)
@@ -2021,7 +2021,7 @@ decl_no_th :: { LHsDecl RdrName }
         | infixexp opt_sig rhs  {% do { (ann,r) <- checkValDef empty $1 (snd $2) $3;
                                         let { l = comb2 $1 $> };
                                         case r of {
-                                          (FunBind n _ _ _ _ _) ->
+                                          (FunBind n _ _ _ _) ->
                                                 ams (L l ()) (mj AnnFunId n:(fst $2)) >> return () ;
                                           (PatBind (L lh _lhs) _rhs _ _ _) ->
                                                 ams (L lh ()) (fst $2) >> return () } ;
@@ -2158,7 +2158,7 @@ infixexp :: { LHsExpr RdrName }
 exp10 :: { LHsExpr RdrName }
         : '\\' apat apats opt_asig '->' exp
                    {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource
-                            [sLL $1 $> $ Match Nothing ($2:$3) (snd $4) (unguardedGRHSs $6)]))
+                            [sLL $1 $> $ Match NonFunBindMatch ($2:$3) (snd $4) (unguardedGRHSs $6)]))
                           (mj AnnLam $1:mj AnnRarrow $5:(fst $4)) }
         | 'let' binds 'in' exp          {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4)
                                                (mj AnnLet $1:mj AnnIn $3
@@ -2556,7 +2556,7 @@ alts1   :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) }
         | alt                   { sL1 $1 ([],[$1]) }
 
 alt     :: { LMatch RdrName (LHsExpr RdrName) }
-        : pat opt_sig alt_rhs      {%ams (sLL $1 $> (Match Nothing [$1] (snd $2)
+        : pat opt_sig alt_rhs      {%ams (sLL $1 $> (Match NonFunBindMatch [$1] (snd $2)
                                                               (snd $ unLoc $3)))
                                          ((fst $2) ++ (fst $ unLoc $3))}
 
index 5aa91ec..2a5faff 100644 (file)
@@ -387,21 +387,22 @@ getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
 --
 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
 
-getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
+getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1),
                                fun_matches = MG { mg_alts = mtchs1 } })) binds
   | has_args mtchs1
-  = go is_infix1 mtchs1 loc1 binds []
+  = go mtchs1 loc1 binds []
   where
-    go is_infix mtchs loc
-       (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
+    go mtchs loc
+       (L loc2 (ValD (FunBind { fun_id = L _ f2,
                                 fun_matches = MG { mg_alts = mtchs2 } })) : binds) _
-        | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
+        | f1 == f2 = go (mtchs2 ++ mtchs)
                         (combineSrcSpans loc loc2) binds []
-    go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
+    go mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
         = let doc_decls' = doc_decl : doc_decls
-          in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
-    go is_infix mtchs loc binds doc_decls
-        = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
+          in go mtchs (combineSrcSpans loc loc2) binds doc_decls'
+    go mtchs loc binds doc_decls
+        = ( L loc (makeFunBind fun_id1 (reverse mtchs))
+          , (reverse doc_decls) ++ binds)
         -- Reverse the final matches, to get it back in the right order
         -- Do the same thing with the trailing doc comments
 
@@ -465,9 +466,9 @@ mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
         do { unless (name == patsyn_name) $
                wrongNameBindingErr loc decl
            ; match <- case details of
-               PrefixCon pats -> return $ Match Nothing pats Nothing rhs
+               PrefixCon pats -> return $ Match NonFunBindMatch pats Nothing rhs
                InfixCon pat1 pat2 ->
-                         return $ Match Nothing [pat1, pat2] Nothing rhs
+                         return $ Match NonFunBindMatch [pat1, pat2] Nothing rhs
                RecCon{} -> recordPatSynErr loc pat
            ; return $ L loc match }
     fromDecl (L loc decl) = extraDeclErr loc decl
@@ -912,16 +913,17 @@ checkFunBind msg ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
         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 is_infix
-                  [L match_span (Match (Just (fun,is_infix)) ps opt_sig grhss)])
+        return (ann,makeFunBind fun
+                  [L match_span (Match (FunBindMatch fun is_infix)
+                                 ps opt_sig grhss)])
         -- The span of the match covers the entire equation.
         -- That isn't quite right, but it'll do for now.
 
-makeFunBind :: Located RdrName -> Bool -> [LMatch RdrName (LHsExpr RdrName)]
+makeFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)]
             -> HsBind RdrName
 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
-makeFunBind fn is_infix ms
-  = FunBind { fun_id = fn, fun_infix = is_infix,
+makeFunBind fn ms
+  = FunBind { fun_id = fn,
               fun_matches = mkMatchGroup FromSource ms,
               fun_co_fn = idHsWrapper,
               bind_fvs = placeHolderNames,
index 159ed8b..8db6603 100644 (file)
@@ -471,15 +471,15 @@ rnBind _ bind@(PatBind { pat_lhs = pat
           return (bind', bndrs, all_fvs) }
 
 rnBind sig_fn bind@(FunBind { fun_id = name
-                            , fun_infix = is_infix
                             , fun_matches = matches })
        -- invariant: no free vars here when it's a FunBind
   = do  { let plain_name = unLoc name
 
         ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
                                 -- bindSigTyVars tests for Opt_ScopedTyVars
-                                 rnMatchGroup (FunRhs plain_name is_infix)
+                                 rnMatchGroup (FunRhs plain_name)
                                               rnLExpr matches
+        ; let is_infix = isInfixFunBind bind
         ; when is_infix $ checkPrecMatch plain_name matches'
 
         ; mod <- getModule
@@ -1059,22 +1059,23 @@ rnMatch' :: Outputable (body RdrName) => HsMatchContext Name
          -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
          -> Match RdrName (Located (body RdrName))
          -> RnM (Match Name (Located (body Name)), FreeVars)
-rnMatch' ctxt rnBody match@(Match { m_fun_id_infix = mf, m_pats = pats
+rnMatch' ctxt rnBody match@(Match { m_fixity = mf, m_pats = pats
                                   , m_type = maybe_rhs_sig, m_grhss = grhss })
   = do  {       -- Result type signatures are no longer supported
           case maybe_rhs_sig of
                 Nothing -> return ()
                 Just (L loc ty) -> addErrAt loc (resSigErr ctxt match ty)
 
+        ; let isinfix = isInfixMatch match
                -- 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 funid isinfix,Just (L lf _,_))
-                                                    -> Just (L lf funid,isinfix)
-                      _                             -> Nothing
-        ; return (Match { m_fun_id_infix = mf', m_pats = pats'
+                      (FunRhs funid,FunBindMatch (L lf _) _)
+                                            -> FunBindMatch (L lf funid) isinfix
+                      _                     -> NonFunBindMatch
+        ; return (Match { m_fixity = mf', m_pats = pats'
                         , m_type = Nothing, m_grhss = grhss'}, grhss_fvs ) }}
 
 emptyCaseErr :: HsMatchContext Name -> SDoc
index dc2a382..76ef037 100644 (file)
@@ -246,7 +246,7 @@ tc_cmd env
                              tcPats LambdaExpr pats arg_tys     $
                              tc_grhss grhss cmd_stk' res_ty
 
-        ; let match' = L mtch_loc (Match Nothing pats' Nothing grhss')
+        ; let match' = L mtch_loc (Match NonFunBindMatch pats' Nothing grhss')
               arg_tys = map hsLPatType pats'
               cmd' = HsCmdLam (MG { mg_alts = [match'], mg_arg_tys = arg_tys
                                   , mg_res_ty = res_ty, mg_origin = origin })
index 2cf517d..9f96a91 100644 (file)
@@ -1340,7 +1340,7 @@ tcMonoBinds :: RecFlag  -- Whether the binding is recursive for typechecking pur
             -> TcM (LHsBinds TcId, [MonoBindInfo])
 
 tcMonoBinds is_rec sig_fn no_gen
-           [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
+           [ L b_loc (FunBind { fun_id = L nm_loc name,
                                 fun_matches = matches, bind_fvs = fvs })]
                              -- Single function binding,
   | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS
@@ -1357,10 +1357,10 @@ tcMonoBinds is_rec sig_fn no_gen
                                  -- We extend the error context even for a non-recursive
                                  -- function so that in type error messages we show the
                                  -- type of the thing whose rhs we are type checking
-                               tcMatchesFun name inf matches rhs_ty
+                               tcMatchesFun name matches rhs_ty
 
         ; return (unitBag $ L b_loc $
-                     FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
+                     FunBind { fun_id = L nm_loc mono_id,
                                fun_matches = matches', bind_fvs = fvs,
                                fun_co_fn = co_fn, fun_tick = [] },
                   [(name, Nothing, mono_id)]) }
@@ -1400,7 +1400,7 @@ tcMonoBinds _ sig_fn no_gen binds
 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
 
 data TcMonoBind         -- Half completed; LHS done, RHS not done
-  = TcFunBind  MonoBindInfo  SrcSpan Bool (MatchGroup Name (LHsExpr Name))
+  = TcFunBind  MonoBindInfo  SrcSpan (MatchGroup Name (LHsExpr Name))
   | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name (LHsExpr Name)) TcSigmaType
 
 type MonoBindInfo = (Name, Maybe TcIdSigInfo, TcId)
@@ -1408,7 +1408,7 @@ type MonoBindInfo = (Name, Maybe TcIdSigInfo, TcId)
         -- the monomorphic bound things
 
 tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
-tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
+tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_matches = matches })
   | Just (TcIdSig sig) <- sig_fn name
   , TISI { sig_bndr = s_bndr, sig_tau = tau } <- sig
   = ASSERT2( case no_gen of { LetLclBndr -> True; LetGblBndr {} -> False }
@@ -1424,12 +1424,12 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matc
               -> addErrCtxt (typeSigCtxt s_bndr) $
                  emitWildcardHoleConstraints nwcs
             CompleteSig {} -> return ()
-        ; return (TcFunBind (name, Just sig, mono_id) nm_loc inf matches) }
+        ; return (TcFunBind (name, Just sig, mono_id) nm_loc matches) }
 
   | otherwise
   = do  { mono_ty <- newFlexiTyVarTy openTypeKind
         ; mono_id <- newNoSigLetBndr no_gen name mono_ty
-        ; return (TcFunBind (name, Nothing, mono_id) nm_loc inf matches) }
+        ; return (TcFunBind (name, Nothing, mono_id) nm_loc matches) }
 
 -- TODO: emit Hole Constraints for wildcards
 tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
@@ -1456,13 +1456,13 @@ tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
 
 -------------------
 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
-tcRhs (TcFunBind info@(_, mb_sig, mono_id) loc inf matches)
+tcRhs (TcFunBind info@(_, mb_sig, mono_id) loc matches)
   = tcExtendForRhs [info]                           $
     tcExtendTyVarEnv2 (lexically_scoped_tvs mb_sig) $
     do  { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
-        ; (co_fn, matches') <- tcMatchesFun (idName mono_id) inf
+        ; (co_fn, matches') <- tcMatchesFun (idName mono_id)
                                             matches (idType mono_id)
-        ; return (FunBind { fun_id = L loc mono_id, fun_infix = inf
+        ; return (FunBind { fun_id = L loc mono_id
                           , fun_matches = matches'
                           , fun_co_fn = co_fn
                           , bind_fvs = placeHolderNamesTc
@@ -1511,7 +1511,7 @@ getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
 getMonoBindInfo tc_binds
   = foldr (get_info . unLoc) [] tc_binds
   where
-    get_info (TcFunBind info _ _ _)  rest = info : rest
+    get_info (TcFunBind info _ _)  rest = info : rest
     get_info (TcPatBind infos _ _ _) rest = infos ++ rest
 
 {-
index 70afae4..81dfb6c 100644 (file)
@@ -63,12 +63,12 @@ so it must be prepared to use tcGen to skolemise it.
 See Note [sig_tau may be polymorphic] in TcPat.
 -}
 
-tcMatchesFun :: Name -> Bool
+tcMatchesFun :: Name
              -> MatchGroup Name (LHsExpr Name)
              -> TcSigmaType     -- Expected type of function
              -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId))
                                 -- Returns type of body
-tcMatchesFun fun_name inf matches exp_ty
+tcMatchesFun fun_name matches exp_ty
   = do  {  -- Check that they all have the same no of arguments
            -- Location is in the monad, set the caller so that
            -- any inter-equation error messages get some vaguely
@@ -88,7 +88,7 @@ tcMatchesFun fun_name inf matches exp_ty
     arity = matchGroupArity matches
     herald = ptext (sLit "The equation(s) for")
              <+> quotes (ppr fun_name) <+> ptext (sLit "have")
-    match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
+    match_ctxt = MC { mc_what = FunRhs fun_name, mc_body = tcBody }
 
 {-
 @tcMatchesCase@ doesn't do the argument-count check because the
@@ -189,7 +189,7 @@ tcMatch ctxt pat_tys rhs_ty match
       = add_match_ctxt match $
         do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
                                 tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
-           ; return (Match Nothing pats' Nothing grhss') }
+           ; return (Match NonFunBindMatch pats' Nothing grhss') }
 
     tc_grhss ctxt Nothing grhss rhs_ty
       = tcGRHSs ctxt grhss rhs_ty       -- No result signature
index 50bad30..5fea21d 100644 (file)
@@ -10,7 +10,7 @@ tcGRHSsPat    :: GRHSs Name (LHsExpr Name)
               -> TcRhoType
               -> TcM (GRHSs TcId (LHsExpr TcId))
 
-tcMatchesFun :: Name -> Bool
+tcMatchesFun :: Name
              -> MatchGroup Name (LHsExpr Name)
              -> TcRhoType
              -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId))
index aec7ac8..094d3f6 100644 (file)
@@ -351,7 +351,6 @@ tcPatSynMatcher (L loc name) lpat
                     }
 
        ; let bind = FunBind{ fun_id = L loc matcher_id
-                           , fun_infix = False
                            , fun_matches = mg
                            , fun_co_fn = idHsWrapper
                            , bind_fvs = emptyNameSet
@@ -426,7 +425,6 @@ tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat
                           | otherwise      = match_group
 
              bind = FunBind { fun_id      = L loc (idName builder_id)
-                            , fun_infix   = False
                             , fun_matches = match_group'
                             , fun_co_fn   = idHsWrapper
                             , bind_fvs    = placeHolderNamesTc
@@ -458,8 +456,8 @@ tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat
               RecordPatSyn args     -> map recordPatSynPatVar args
 
     add_dummy_arg :: MatchGroup Name (LHsExpr Name) -> MatchGroup Name (LHsExpr Name)
-    add_dummy_arg mg@(MG { mg_alts = [L loc (Match Nothing [] ty grhss)] })
-      = mg { mg_alts = [L loc (Match Nothing [nlWildPatName] ty grhss)] }
+    add_dummy_arg mg@(MG {mg_alts = [L l (Match NonFunBindMatch [] ty grhss)] })
+      = mg { mg_alts = [L l (Match NonFunBindMatch [nlWildPatName] ty grhss)] }
     add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
                              pprMatches (PatSyn :: HsMatchContext Name) other_mg