diff options
author | Dr. ERDI Gergo <gergo@erdi.hu> | 2014-07-29 11:27:26 +0200 |
---|---|---|
committer | Dr. ERDI Gergo <gergo@erdi.hu> | 2014-07-29 15:44:31 +0200 |
commit | 893a261c8c15783c8f86c74f4e8c57df9c44a155 (patch) | |
tree | cca55e276728eeec41d07427811af62183268e04 | |
parent | f3262fe82ce7d810809beecabd4257522db4cc55 (diff) | |
download | haskell-893a261c8c15783c8f86c74f4e8c57df9c44a155.tar.gz |
Refactor PatSynBind so that we can pass around PSBs instead of several arguments
-rw-r--r-- | compiler/hsSyn/HsBinds.lhs | 51 | ||||
-rw-r--r-- | compiler/hsSyn/HsUtils.lhs | 14 | ||||
-rw-r--r-- | compiler/rename/RnBinds.lhs | 54 | ||||
-rw-r--r-- | compiler/typecheck/TcBinds.lhs | 27 | ||||
-rw-r--r-- | compiler/typecheck/TcHsSyn.lhs | 17 | ||||
-rw-r--r-- | compiler/typecheck/TcPatSyn.lhs | 64 | ||||
-rw-r--r-- | compiler/typecheck/TcPatSyn.lhs-boot | 13 | ||||
-rw-r--r-- | utils/ghctags/Main.hs | 2 |
8 files changed, 124 insertions, 118 deletions
diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 54d574640a..04a72225f1 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -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} diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index e12daf45cc..5d4d22fae2 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -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 [] diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 1259edd58f..4efd847702 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -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. -} --------------------- diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 25c2ee68ad..bbbed51a8d 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -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" diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 1a48fe8260..f4d5cf262c 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -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) diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs index a0dd95a048..b5fbc295f5 100644 --- a/compiler/typecheck/TcPatSyn.lhs +++ b/compiler/typecheck/TcPatSyn.lhs @@ -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 diff --git a/compiler/typecheck/TcPatSyn.lhs-boot b/compiler/typecheck/TcPatSyn.lhs-boot index 681bfb2faa..700137c16c 100644 --- a/compiler/typecheck/TcPatSyn.lhs-boot +++ b/compiler/typecheck/TcPatSyn.lhs-boot @@ -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} diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index 815cc7ca18..4a094f50a1 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -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 |