Commit 893a261c authored by cactus's avatar cactus

Refactor PatSynBind so that we can pass around PSBs instead of several arguments

parent f3262fe8
......@@ -166,13 +166,7 @@ data HsBindLR idL idR
abs_binds :: LHsBinds idL -- ^ Typechecked user bindings
}
| PatSynBind {
patsyn_id :: Located idL, -- ^ Name of the pattern synonym
bind_fvs :: NameSet, -- ^ See Note [Bind free vars]
patsyn_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names
patsyn_def :: LPat idR, -- ^ Right-hand side
patsyn_dir :: HsPatSynDir idR -- ^ Directionality
}
| PatSynBind (PatSynBind idL idR)
deriving (Data, Typeable)
-- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
......@@ -195,6 +189,14 @@ data ABExport id
, abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas
} deriving (Data, Typeable)
data PatSynBind idL idR
= PSB { psb_id :: Located idL, -- ^ Name of the pattern synonym
psb_fvs :: NameSet, -- ^ See Note [Bind free vars]
psb_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names
psb_def :: LPat idR, -- ^ Right-hand side
psb_dir :: HsPatSynDir idR -- ^ Directionality
} deriving (Data, Typeable)
-- | Used for the NameSet in FunBind and PatBind prior to the renamer
placeHolderNames :: NameSet
placeHolderNames = panic "placeHolderNames"
......@@ -437,23 +439,7 @@ ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
$$ ifPprDebug (pprBndr LetBind (unLoc fun))
$$ pprFunBind (unLoc fun) inf matches
$$ ifPprDebug (ppr wrap)
ppr_monobind (PatSynBind{ patsyn_id = L _ psyn, patsyn_args = details,
patsyn_def = pat, patsyn_dir = dir })
= ppr_lhs <+> ppr_rhs
where
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_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)
ppr_monobind (PatSynBind psb) = ppr psb
ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
, abs_exports = exports, abs_binds = val_binds
, abs_ev_binds = ev_binds })
......@@ -470,6 +456,23 @@ instance (OutputableBndr id) => Outputable (ABExport id) where
= vcat [ ppr gbl <+> ptext (sLit "<=") <+> ppr lcl
, nest 2 (pprTcSpecPrags prags)
, nest 2 (ppr wrap)]
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL idR) where
ppr (PSB{ psb_id = L _ psyn, psb_args = details, psb_def = pat, psb_dir = dir })
= ppr_lhs <+> ppr_rhs
where
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_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)
\end{code}
......
......@@ -505,11 +505,13 @@ mkVarBind var rhs = L (getLoc rhs) $
VarBind { var_id = var, var_rhs = rhs, var_inline = False }
mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName
mkPatSynBind name details lpat dir = PatSynBind{ patsyn_id = name
, patsyn_args = details
, patsyn_def = lpat
, patsyn_dir = dir
, bind_fvs = placeHolderNames }
mkPatSynBind name details lpat dir = PatSynBind psb
where
psb = PSB{ psb_id = name
, psb_args = details
, psb_def = lpat
, psb_dir = dir
, psb_fvs = placeHolderNames }
------------
mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
......@@ -577,7 +579,7 @@ collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
-- I don't think we want the binders from the nested binds
-- The only time we collect binders from a typechecked
-- binding (hence see AbsBinds) is in zonking in TcHsSyn
collect_bind (PatSynBind { patsyn_id = L _ ps }) acc = ps : acc
collect_bind (PatSynBind (PSB { psb_id = L _ ps })) acc = ps : acc
collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
collectHsBindsBinders binds = collect_binds binds []
......
......@@ -433,12 +433,12 @@ rnBindLHS name_maker _ bind@(FunBind { fun_id = name@(L nameLoc _) })
= do { newname <- applyNameMaker name_maker name
; return (bind { fun_id = L nameLoc newname }) }
rnBindLHS name_maker _ bind@(PatSynBind{ patsyn_id = rdrname@(L nameLoc _) })
rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname@(L nameLoc _) })
= do { unless (isTopRecNameMaker name_maker) $
addErr localPatternSynonymErr
; addLocM checkConName rdrname
; name <- applyNameMaker name_maker rdrname
; return (bind{ patsyn_id = L nameLoc name }) }
; return (PatSynBind psb{ psb_id = L nameLoc name }) }
where
localPatternSynonymErr :: SDoc
localPatternSynonymErr
......@@ -515,10 +515,32 @@ rnBind sig_fn bind@(FunBind { fun_id = name
[plain_name], rhs_fvs)
}
rnBind _sig_fn bind@(PatSynBind { patsyn_id = L _ name
, patsyn_args = details
, patsyn_def = pat
, patsyn_dir = dir })
rnBind sig_fn (PatSynBind bind)
= do { (bind', name, fvs) <- rnPatSynBind sig_fn bind
; return (PatSynBind bind', name, fvs) }
rnBind _ b = pprPanic "rnBind" (ppr b)
{-
Note [Free-variable space leak]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We have
fvs' = trim fvs
and we seq fvs' before turning it as part of a record.
The reason is that trim is sometimes something like
\xs -> intersectNameSet (mkNameSet bound_names) xs
and we don't want to retain the list bound_names. This showed up in
trac ticket #1136.
-}
rnPatSynBind :: (Name -> [Name]) -- Signature tyvar function
-> PatSynBind Name RdrName
-> RnM (PatSynBind Name Name, [Name], Uses)
rnPatSynBind _sig_fn bind@(PSB { psb_id = L _ name
, psb_args = details
, psb_def = pat
, psb_dir = dir })
-- invariant: no free vars here when it's a FunBind
= do { pattern_synonym_ok <- xoptM Opt_PatternSynonyms
; unless pattern_synonym_ok (addErr patternSynonymErr)
......@@ -553,10 +575,10 @@ rnBind _sig_fn bind@(PatSynBind { patsyn_id = L _ name
-- As well as dependency analysis, we need these for the
-- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
; let bind' = bind{ patsyn_args = details'
, patsyn_def = pat'
, patsyn_dir = dir'
, bind_fvs = fvs' }
; let bind' = bind{ psb_args = details'
, psb_def = pat'
, psb_dir = dir'
, psb_fvs = fvs' }
; fvs' `seq` -- See Note [Free-variable space leak]
return (bind', [name], fvs1)
......@@ -569,20 +591,8 @@ rnBind _sig_fn bind@(PatSynBind { patsyn_id = L _ name
= hang (ptext (sLit "Illegal pattern synonym declaration"))
2 (ptext (sLit "Use -XPatternSynonyms to enable this extension"))
rnBind _ b = pprPanic "rnBind" (ppr b)
{-
Note [Free-variable space leak]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We have
fvs' = trim fvs
and we seq fvs' before turning it as part of a record.
The reason is that trim is sometimes something like
\xs -> intersectNameSet (mkNameSet bound_names) xs
and we don't want to retain the list bound_names. This showed up in
trac ticket #1136.
-}
---------------------
......
......@@ -318,27 +318,17 @@ tcValBinds top_lvl binds sigs thing_inside
; tcExtendIdEnv2 [(idName id, id) | id <- poly_ids] $ do
{ (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
{ thing <- thing_inside
; patsyn_wrappers <- forM patsyns $ \(name, loc, args, lpat, dir) -> do
{ patsyn <- tcLookupPatSyn name
; case patSynWrapper patsyn of
Nothing -> return emptyBag
Just wrapper_id -> tcPatSynWrapper (L loc wrapper_id) lpat dir args }
; patsyn_wrappers <- mapM tcPatSynWrapper patsyns
; let extra_binds = [ (NonRecursive, wrapper) | wrapper <- patsyn_wrappers ]
; return (extra_binds, thing) }
; return (binds' ++ extra_binds', thing) }}
where
patsyns = [ (name, loc, args, lpat, dir)
| (_, lbinds) <- binds
, L loc (PatSynBind{ patsyn_id = L _ name, patsyn_args = details, patsyn_def = lpat, patsyn_dir = dir }) <- bagToList lbinds
, let args = map unLoc $ case details of
PrefixPatSyn args -> args
InfixPatSyn arg1 arg2 -> [arg1, arg2]
]
patsyns
= [psb | (_, lbinds) <- binds, L _ (PatSynBind psb) <- bagToList lbinds]
patsyn_placeholder_kinds -- See Note [Placeholder PatSyn kinds]
= [ (name, placeholder_patsyn_tything)
| (name, _, _, _, _) <- patsyns ]
= [(name, placeholder_patsyn_tything)| PSB{ psb_id = L _ name } <- patsyns ]
placeholder_patsyn_tything
= AGlobal $ AConLike $ PatSynCon $ panic "fakePatSynCon"
= AGlobal $ AConLike $ PatSynCon $ panic "fakePatSynCon"
------------------------
tcBindGroups :: TopLevelFlag -> TcSigFun -> PragFun
......@@ -427,9 +417,8 @@ tc_single :: forall thing.
TopLevelFlag -> TcSigFun -> PragFun
-> LHsBind Name -> TcM thing
-> TcM (LHsBinds TcId, thing)
tc_single _top_lvl _sig_fn _prag_fn (L _ ps@PatSynBind{}) thing_inside
= do { (pat_syn, aux_binds) <-
tcPatSynDecl (patsyn_id ps) (patsyn_args ps) (patsyn_def ps) (patsyn_dir ps)
tc_single _top_lvl _sig_fn _prag_fn (L _ (PatSynBind psb)) thing_inside
= do { (pat_syn, aux_binds) <- tcPatSynDecl psb
; let tything = AConLike (PatSynCon pat_syn)
implicit_ids = (patSynMatcher pat_syn) :
......@@ -471,7 +460,7 @@ mkEdges sig_fn binds
bindersOfHsBind :: HsBind Name -> [Name]
bindersOfHsBind (PatBind { pat_lhs = pat }) = collectPatBinders pat
bindersOfHsBind (FunBind { fun_id = L _ f }) = [f]
bindersOfHsBind (PatSynBind { patsyn_id = L _ psyn }) = [psyn]
bindersOfHsBind (PatSynBind PSB{ psb_id = L _ psyn }) = [psyn]
bindersOfHsBind (AbsBinds {}) = panic "bindersOfHsBind AbsBinds"
bindersOfHsBind (VarBind {}) = panic "bindersOfHsBind VarBind"
......
......@@ -468,18 +468,19 @@ zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
, abe_mono = zonkIdOcc env mono_id
, abe_prags = new_prags })
zonk_bind env _sig_warn bind@(PatSynBind { patsyn_id = L loc id
, patsyn_args = details
, patsyn_def = lpat
, patsyn_dir = dir })
zonk_bind env _sig_warn (PatSynBind bind@(PSB { psb_id = L loc id
, psb_args = details
, psb_def = lpat
, psb_dir = dir }))
= do { id' <- zonkIdBndr env id
; details' <- zonkPatSynDetails env details
;(env1, lpat') <- zonkPat env lpat
; (_env2, dir') <- zonkPatSynDir env1 dir
; return (bind { patsyn_id = L loc id'
, patsyn_args = details'
, patsyn_def = lpat'
, patsyn_dir = dir' }) }
; return $ PatSynBind $
bind { psb_id = L loc id'
, psb_args = details'
, psb_def = lpat'
, psb_dir = dir' } }
zonkPatSynDetails :: ZonkEnv
-> HsPatSynDetails (Located TcId)
......
......@@ -40,12 +40,10 @@ import TypeRep
\end{code}
\begin{code}
tcPatSynDecl :: Located Name
-> HsPatSynDetails (Located Name)
-> LPat Name
-> HsPatSynDir Name
tcPatSynDecl :: PatSynBind Name Name
-> TcM (PatSyn, LHsBinds Id)
tcPatSynDecl lname@(L _ name) details lpat dir
tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
psb_def = lpat, psb_dir = dir }
= do { traceTc "tcPatSynDecl {" $ ppr name $$ ppr lpat
; tcCheckPatSynPat lpat
; pat_ty <- newFlexiTyVarTy openTypeKind
......@@ -194,31 +192,41 @@ isBidirectional Unidirectional = False
isBidirectional ImplicitBidirectional = True
isBidirectional ExplicitBidirectional{} = True
tcPatSynWrapper :: Located Id
-> LPat Name
-> HsPatSynDir Name
-> [Name]
tcPatSynWrapper :: PatSynBind Name Name
-> TcM (LHsBinds Id)
-- See Note [Matchers and wrappers for pattern synonyms] in PatSyn
tcPatSynWrapper _ _ Unidirectional _
= panic "tcPatSynWrapper"
tcPatSynWrapper (L _ wrapper_id) lpat ImplicitBidirectional args
= do { lexpr <- case tcPatToExpr (mkNameSet args) lpat of
Nothing -> cannotInvertPatSynErr lpat
Just lexpr -> return lexpr
; let wrapper_args = map (noLoc . VarPat) args
wrapper_lname = L (getLoc lpat) (idName wrapper_id)
wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds
wrapper_bind = mkTopFunBind Generated wrapper_lname [wrapper_match]
; mkPatSynWrapper wrapper_id wrapper_bind }
tcPatSynWrapper (L loc wrapper_id) _ (ExplicitBidirectional mg) _
= mkPatSynWrapper wrapper_id $
FunBind{ fun_id = L loc (idName wrapper_id)
, fun_infix = False
, fun_matches = mg
, fun_co_fn = idHsWrapper
, bind_fvs = placeHolderNames
, fun_tick = Nothing }
tcPatSynWrapper PSB{ psb_id = L loc name, psb_def = lpat, psb_dir = dir, psb_args = details }
= case dir of
Unidirectional -> return emptyBag
ImplicitBidirectional ->
do { wrapper_id <- tcLookupPatSynWrapper name
; lexpr <- case tcPatToExpr (mkNameSet args) lpat of
Nothing -> cannotInvertPatSynErr lpat
Just lexpr -> return lexpr
; let wrapper_args = map (noLoc . VarPat) args
wrapper_lname = L (getLoc lpat) (idName wrapper_id)
wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds
wrapper_bind = mkTopFunBind Generated wrapper_lname [wrapper_match]
; mkPatSynWrapper wrapper_id wrapper_bind }
ExplicitBidirectional mg ->
do { wrapper_id <- tcLookupPatSynWrapper name
; mkPatSynWrapper wrapper_id $
FunBind{ fun_id = L loc (idName wrapper_id)
, fun_infix = False
, fun_matches = mg
, fun_co_fn = idHsWrapper
, bind_fvs = placeHolderNames
, fun_tick = Nothing }}
where
args = map unLoc $ case details of
PrefixPatSyn args -> args
InfixPatSyn arg1 arg2 -> [arg1, arg2]
tcLookupPatSynWrapper name
= do { patsyn <- tcLookupPatSyn name
; case patSynWrapper patsyn of
Nothing -> panic "tcLookupPatSynWrapper"
Just wrapper_id -> return wrapper_id }
mkPatSynWrapperId :: Located Name
-> [Var] -> [TyVar] -> [TyVar] -> ThetaType -> Type
......
......@@ -3,20 +3,13 @@ module TcPatSyn where
import Name ( Name )
import Id ( Id )
import HsSyn ( LPat, HsPatSynDetails, HsPatSynDir, LHsBinds )
import HsSyn ( PatSynBind, LHsBinds )
import TcRnTypes ( TcM )
import SrcLoc ( Located )
import PatSyn ( PatSyn )
tcPatSynDecl :: Located Name
-> HsPatSynDetails (Located Name)
-> LPat Name
-> HsPatSynDir Name
tcPatSynDecl :: PatSynBind Name Name
-> TcM (PatSyn, LHsBinds Id)
tcPatSynWrapper :: Located Id
-> LPat Name
-> HsPatSynDir Name
-> [Name]
tcPatSynWrapper :: PatSynBind Name Name
-> TcM (LHsBinds Id)
\end{code}
......@@ -282,7 +282,7 @@ boundThings modname lbinding =
PatBind { pat_lhs = lhs } -> patThings lhs []
VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)]
AbsBinds { } -> [] -- nothing interesting in a type abstraction
PatSynBind { patsyn_id = id } -> [thing id]
PatSynBind PSB{ psb_id = id } -> [thing id]
where thing = foundOfLName modname
patThings lpat tl =
let loc = startOfLocated lpat
......
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