Commit f0f9365f authored by Alan Zimmerman's avatar Alan Zimmerman Committed by Ben Gamari

Remove fun_infix from Funbind, as it is now in Match

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
parent ea8c116a
......@@ -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)) $ -}
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......@@ -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)
......
......@@ -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))}
......
......@@ -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,
......
......@@ -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
......
......@@ -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 })
......
......@@ -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
{-
......
......@@ -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
......
......@@ -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))
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment