Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
GHC
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Locked Files
Issues
4,251
Issues
4,251
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
394
Merge Requests
394
Requirements
Requirements
List
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Security & Compliance
Security & Compliance
Dependency List
License Compliance
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Code Review
Insights
Issue
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
893a261c
Commit
893a261c
authored
Jul 29, 2014
by
cactus
1
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Refactor PatSynBind so that we can pass around PSBs instead of several arguments
parent
f3262fe8
Changes
8
Hide whitespace changes
Inline
Side-by-side
Showing
8 changed files
with
124 additions
and
118 deletions
+124
-118
compiler/hsSyn/HsBinds.lhs
compiler/hsSyn/HsBinds.lhs
+27
-24
compiler/hsSyn/HsUtils.lhs
compiler/hsSyn/HsUtils.lhs
+8
-6
compiler/rename/RnBinds.lhs
compiler/rename/RnBinds.lhs
+32
-22
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcBinds.lhs
+8
-19
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcHsSyn.lhs
+9
-8
compiler/typecheck/TcPatSyn.lhs
compiler/typecheck/TcPatSyn.lhs
+36
-28
compiler/typecheck/TcPatSyn.lhs-boot
compiler/typecheck/TcPatSyn.lhs-boot
+3
-10
utils/ghctags/Main.hs
utils/ghctags/Main.hs
+1
-1
No files found.
compiler/hsSyn/HsBinds.lhs
View file @
893a261c
...
...
@@ -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}
...
...
compiler/hsSyn/HsUtils.lhs
View file @
893a261c
...
...
@@ -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 []
...
...
compiler/rename/RnBinds.lhs
View file @
893a261c
...
...
@@ -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{ p
atsyn
_args = details'
, p
atsyn
_def = pat'
, p
atsyn
_dir = dir'
,
bind
_fvs = fvs' }
; let bind' = bind{ p
sb
_args = details'
, p
sb
_def = pat'
, p
sb
_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.
-}
---------------------
...
...
compiler/typecheck/TcBinds.lhs
View file @
893a261c
...
...
@@ -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"
...
...
compiler/typecheck/TcHsSyn.lhs
View file @
893a261c
...
...
@@ -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)
...
...
compiler/typecheck/TcPatSyn.lhs
View file @
893a261c
...
...
@@ -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
...
...
compiler/typecheck/TcPatSyn.lhs-boot
View file @
893a261c
...
...
@@ -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}
utils/ghctags/Main.hs
View file @
893a261c
...
...
@@ -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
...
...
Administrator
@root
mentioned in commit
846d9302
·
Dec 17, 2018
mentioned in commit
846d9302
mentioned in commit 846d93023ef94217620caab56d41cafb73c51a3a
Toggle commit list
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment