diff options
author | Richard Eisenberg <eir@cis.upenn.edu> | 2013-08-05 16:54:44 +0100 |
---|---|---|
committer | Richard Eisenberg <eir@cis.upenn.edu> | 2013-08-05 17:28:03 +0100 |
commit | 9082111dcdbad7d161ecb0a08bb467f6c62e0a1b (patch) | |
tree | 84f7b23a26ba73b3c3da5746254429a2fd54b689 /compiler | |
parent | 334131bce7822ede7099c0d825b78200094c779e (diff) | |
download | haskell-9082111dcdbad7d161ecb0a08bb467f6c62e0a1b.tar.gz |
Added support for writing and checking closed type families is hs-boot files.
As documented in the users' guide, you can now write
type family Foo a where ..
in a hs-boot file to declare an abstract closed type family.
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/hsSyn/HsDecls.lhs | 6 | ||||
-rw-r--r-- | compiler/iface/IfaceSyn.lhs | 21 | ||||
-rw-r--r-- | compiler/iface/MkIface.lhs | 9 | ||||
-rw-r--r-- | compiler/iface/TcIface.lhs | 1 | ||||
-rw-r--r-- | compiler/main/PprTyThing.hs | 9 | ||||
-rw-r--r-- | compiler/parser/Parser.y.pp | 2 | ||||
-rw-r--r-- | compiler/typecheck/TcHsType.lhs | 7 | ||||
-rw-r--r-- | compiler/typecheck/TcRnDriver.lhs | 51 | ||||
-rw-r--r-- | compiler/typecheck/TcSplice.lhs | 2 | ||||
-rw-r--r-- | compiler/typecheck/TcTyClsDecls.lhs | 27 | ||||
-rw-r--r-- | compiler/types/TyCon.lhs | 17 |
11 files changed, 110 insertions, 42 deletions
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 1ebc5a0cd2..ee4b0fab34 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -480,6 +480,8 @@ data FamilyDecl name = FamilyDecl data FamilyInfo name = DataFamily | OpenTypeFamily + -- this list might be empty, if we're in an hs-boot file and the user + -- said "type family Foo x where .." | ClosedTypeFamily [LTyFamInstEqn name] deriving( Data, Typeable ) @@ -622,7 +624,9 @@ instance (OutputableBndr name) => Outputable (FamilyDecl name) where Just kind -> dcolon <+> ppr kind (pp_where, pp_eqns) = case info of ClosedTypeFamily eqns -> ( ptext (sLit "where") - , vcat $ map ppr eqns ) + , if null eqns + then ptext (sLit "..") + else vcat $ map ppr eqns ) _ -> (empty, empty) pprFlavour :: FamilyInfo name -> SDoc diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 3bbcdd395e..497c3ae525 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -222,18 +222,21 @@ instance Binary IfaceDecl where data IfaceSynTyConRhs = IfaceOpenSynFamilyTyCon | IfaceClosedSynFamilyTyCon IfExtName -- name of associated axiom + | IfaceAbstractClosedSynFamilyTyCon | IfaceSynonymTyCon IfaceType instance Binary IfaceSynTyConRhs where - put_ bh IfaceOpenSynFamilyTyCon = putByte bh 0 - put_ bh (IfaceClosedSynFamilyTyCon ax) = putByte bh 1 >> put_ bh ax - put_ bh (IfaceSynonymTyCon ty) = putByte bh 2 >> put_ bh ty + put_ bh IfaceOpenSynFamilyTyCon = putByte bh 0 + put_ bh (IfaceClosedSynFamilyTyCon ax) = putByte bh 1 >> put_ bh ax + put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 2 + put_ bh (IfaceSynonymTyCon ty) = putByte bh 3 >> put_ bh ty get bh = do { h <- getByte bh ; case h of - 0 -> do { return IfaceOpenSynFamilyTyCon } + 0 -> return IfaceOpenSynFamilyTyCon 1 -> do { ax <- get bh ; return (IfaceClosedSynFamilyTyCon ax) } + 2 -> return IfaceAbstractClosedSynFamilyTyCon _ -> do { ty <- get bh ; return (IfaceSynonymTyCon ty) } } @@ -1035,8 +1038,9 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifRoles = roles, = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars roles) 4 (dcolon <+> ppr kind) +-- this case handles both abstract and instantiated closed family tycons pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifRoles = roles, - ifSynRhs = IfaceClosedSynFamilyTyCon {}, ifSynKind = kind }) + ifSynRhs = _closedSynFamilyTyCon, ifSynKind = kind }) = hang (ptext (sLit "closed type family") <+> pprIfaceDeclHead [] tycon tyvars roles) 4 (dcolon <+> ppr kind) @@ -1352,9 +1356,10 @@ freeNamesIfIdDetails _ = emptyNameSet -- All other changes are handled via the version info on the tycon freeNamesIfSynRhs :: IfaceSynTyConRhs -> NameSet -freeNamesIfSynRhs (IfaceSynonymTyCon ty) = freeNamesIfType ty -freeNamesIfSynRhs IfaceOpenSynFamilyTyCon = emptyNameSet -freeNamesIfSynRhs (IfaceClosedSynFamilyTyCon ax) = unitNameSet ax +freeNamesIfSynRhs (IfaceSynonymTyCon ty) = freeNamesIfType ty +freeNamesIfSynRhs IfaceOpenSynFamilyTyCon = emptyNameSet +freeNamesIfSynRhs (IfaceClosedSynFamilyTyCon ax) = unitNameSet ax +freeNamesIfSynRhs IfaceAbstractClosedSynFamilyTyCon = emptyNameSet freeNamesIfContext :: IfaceContext -> NameSet freeNamesIfContext = fnList freeNamesIfType diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index bf48f889a4..94c5264d35 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1513,9 +1513,12 @@ tyConToIfaceDecl env tycon where (env1, tyvars) = tidyTyClTyVarBndrs env (tyConTyVars tycon) - to_ifsyn_rhs OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon - to_ifsyn_rhs (ClosedSynFamilyTyCon ax) = IfaceClosedSynFamilyTyCon (coAxiomName ax) - to_ifsyn_rhs (SynonymTyCon ty) = IfaceSynonymTyCon (tidyToIfaceType env1 ty) + to_ifsyn_rhs OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon + to_ifsyn_rhs (ClosedSynFamilyTyCon ax) + = IfaceClosedSynFamilyTyCon (coAxiomName ax) + to_ifsyn_rhs AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon + to_ifsyn_rhs (SynonymTyCon ty) + = IfaceSynonymTyCon (tidyToIfaceType env1 ty) ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index c379199214..ae517ec0ab 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -496,6 +496,7 @@ tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, tc_syn_rhs (IfaceClosedSynFamilyTyCon ax_name) = do { ax <- tcIfaceCoAxiom ax_name ; return (ClosedSynFamilyTyCon ax) } + tc_syn_rhs IfaceAbstractClosedSynFamilyTyCon = return AbstractClosedSynFamilyTyCon tc_syn_rhs (IfaceSynonymTyCon ty) = do { rhs_ty <- tcIfaceType ty ; return (SynonymTyCon rhs_ty) } diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index 56d7afc4fa..b95c69902a 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -179,9 +179,9 @@ pprTyCon pefas ss tyCon OpenSynFamilyTyCon -> pprTyConHdr pefas tyCon <+> dcolon <+> pprTypeForUser pefas (GHC.synTyConResKind tyCon) ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) -> - hang (pprTyConHdr pefas tyCon <+> dcolon <+> - pprTypeForUser pefas (GHC.synTyConResKind tyCon) <+> ptext (sLit "where")) + hang closed_family_header 2 (vcat (brListMap (pprCoAxBranch tyCon) branches)) + AbstractClosedSynFamilyTyCon -> closed_family_header <+> ptext (sLit "..") SynonymTyCon rhs_ty -> hang (pprTyConHdr pefas tyCon <+> equals) 2 (ppr rhs_ty) -- Don't suppress foralls on RHS type! -- e.g. type T = forall a. a->a @@ -190,6 +190,11 @@ pprTyCon pefas ss tyCon | otherwise = pprAlgTyCon pefas ss tyCon + where + closed_family_header + = pprTyConHdr pefas tyCon <+> dcolon <+> + pprTypeForUser pefas (GHC.synTyConResKind tyCon) <+> ptext (sLit "where") + pprAlgTyCon :: PrintExplicitForalls -> ShowSub -> TyCon -> SDoc pprAlgTyCon pefas ss tyCon | gadt = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$ diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index b35bbf38b4..b6f0c88adb 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -712,6 +712,8 @@ where_type_family :: { Located (FamilyInfo RdrName) } ty_fam_inst_eqn_list :: { Located [LTyFamInstEqn RdrName] } : '{' ty_fam_inst_eqns '}' { LL (unLoc $2) } | vocurly ty_fam_inst_eqns close { $2 } + | '{' '..' '}' { LL [] } + | vocurly '..' close { let L loc _ = $2 in L loc [] } ty_fam_inst_eqns :: { Located [LTyFamInstEqn RdrName] } : ty_fam_inst_eqns ';' ty_fam_inst_eqn { LL ($3 : unLoc $1) } diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index ba027b10dc..b0e7d7a789 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -1070,6 +1070,7 @@ data KindCheckingStrategy -- See Note [Kind-checking strategies] = ParametricKinds | NonParametricKinds | FullKindSignature + deriving (Eq) -- determine the appropriate strategy for a decl kcStrategy :: TyClDecl Name -> KindCheckingStrategy @@ -1082,10 +1083,10 @@ kcStrategy (DataDecl { tcdDataDefn = HsDataDefn { dd_kindSig = m_ksig }}) | otherwise = ParametricKinds kcStrategy (ClassDecl {}) = ParametricKinds +-- if the ClosedTypeFamily has no equations, do the defaulting to *, etc. kcStrategyFamDecl :: FamilyDecl Name -> KindCheckingStrategy -kcStrategyFamDecl (FamilyDecl { fdInfo = info }) - | isClosedTypeFamilyInfo info = NonParametricKinds - | otherwise = FullKindSignature +kcStrategyFamDecl (FamilyDecl { fdInfo = ClosedTypeFamily (_:_) }) = NonParametricKinds +kcStrategyFamDecl _ = FullKindSignature mkKindSigVar :: Name -> TcM KindVar -- Use the specified name; don't clone it diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index d96dd22299..b5bf4a7169 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -34,7 +34,7 @@ import TcHsSyn import TcExpr import TcRnMonad import TcEvidence -import Coercion( pprCoAxiom ) +import Coercion( pprCoAxiom, pprCoAxBranch ) import FamInst import InstEnv import FamInstEnv @@ -49,7 +49,6 @@ import TcInstDcls import TcIface import TcMType import MkIface -import IfaceSyn import TcSimplify import TcTyClsDecls import LoadIface @@ -75,7 +74,7 @@ import Outputable import DataCon import Type import Class -import CoAxiom ( CoAxBranch(..) ) +import CoAxiom import Inst ( tcGetInstEnvs ) import Data.List ( sortBy ) import Data.IORef ( readIORef ) @@ -660,10 +659,7 @@ checkHiBootIface Just boot_thing <- mb_boot_thing = when (not (checkBootDecl boot_thing real_thing)) $ addErrAt (nameSrcSpan (getName boot_thing)) - (let boot_decl = tyThingToIfaceDecl - (fromJust mb_boot_thing) - real_decl = tyThingToIfaceDecl real_thing - in bootMisMatch real_thing boot_decl real_decl) + (bootMisMatch real_thing boot_thing) | otherwise = addErrTc (missingBootThing name "defined in") @@ -772,8 +768,10 @@ checkBootTyCon tc1 tc2 , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) = ASSERT(tc1 == tc2) let eqSynRhs OpenSynFamilyTyCon OpenSynFamilyTyCon = True + eqSynRhs AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True + eqSynRhs (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True eqSynRhs (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2) - = ax1 == ax2 + = eqClosedFamilyAx ax1 ax2 eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2) = eqTypeX env t1 t2 eqSynRhs _ _ = False @@ -814,6 +812,19 @@ checkBootTyCon tc1 tc2 && dataConFieldLabels c1 == dataConFieldLabels c2 && eqType (dataConUserType c1) (dataConUserType c2) + eqClosedFamilyAx (CoAxiom { co_ax_branches = branches1 }) + (CoAxiom { co_ax_branches = branches2 }) + = brListLength branches1 == brListLength branches2 + && (and $ brListZipWith eqClosedFamilyBranch branches1 branches2) + + eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_lhs = lhs1, cab_rhs = rhs1 }) + (CoAxBranch { cab_tvs = tvs2, cab_lhs = lhs2, cab_rhs = rhs2 }) + | Just env <- eqTyVarBndrs emptyRnEnv2 tvs1 tvs2 + = eqListBy (eqTypeX env) lhs1 lhs2 && + eqTypeX env rhs1 rhs2 + + | otherwise = False + emptyRnEnv2 :: RnEnv2 emptyRnEnv2 = mkRnEnv2 emptyInScopeSet @@ -823,11 +834,25 @@ missingBootThing name what = ppr name <+> ptext (sLit "is exported by the hs-boot file, but not") <+> text what <+> ptext (sLit "the module") -bootMisMatch :: TyThing -> IfaceDecl -> IfaceDecl -> SDoc -bootMisMatch thing boot_decl real_decl - = vcat [ppr thing <+> ptext (sLit "has conflicting definitions in the module and its hs-boot file"), - ptext (sLit "Main module:") <+> ppr real_decl, - ptext (sLit "Boot file: ") <+> ppr boot_decl] +bootMisMatch :: TyThing -> TyThing -> SDoc +bootMisMatch real_thing boot_thing + = vcat [ppr real_thing <+> + ptext (sLit "has conflicting definitions in the module"), + ptext (sLit "and its hs-boot file"), + ptext (sLit "Main module:") <+> ppr_mismatch real_thing, + ptext (sLit "Boot file: ") <+> ppr_mismatch boot_thing] + where + -- closed type families need special treatment, because they might differ + -- in their equations, which are not stored in the corresponding IfaceDecl + ppr_mismatch thing + | ATyCon tc <- thing + , Just (ClosedSynFamilyTyCon ax) <- synTyConRhs_maybe tc + = hang (ppr iface_decl <+> ptext (sLit "where")) + 2 (vcat $ brListMap (pprCoAxBranch tc) (coAxiomBranches ax)) + + | otherwise + = ppr iface_decl + where iface_decl = tyThingToIfaceDecl thing instMisMatch :: ClsInst -> SDoc instMisMatch inst diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index bb24708882..2528e69d7e 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -1394,6 +1394,8 @@ reifyFamFlavour tc | isOpenSynFamilyTyCon tc = return $ Left TH.TypeFam | isDataFamilyTyCon tc = return $ Left TH.DataFam + -- this doesn't really handle abstract closed families, but let's not worry + -- about that now | Just ax <- isClosedSynFamilyTyCon_maybe tc = do { eqns <- brListMapM reifyAxBranch $ coAxiomBranches ax ; return $ Right eqns } diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index bae332d50f..0cd4f2d5a9 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -422,7 +422,6 @@ getFamDeclInitialKinds decls getFamDeclInitialKind :: FamilyDecl Name -> TcM [(Name, TcTyThing)] getFamDeclInitialKind decl@(FamilyDecl { fdLName = L _ name - , fdInfo = info , fdTyVars = ktvs , fdKindSig = ksig }) = do { (fam_kind, _, _) <- @@ -435,7 +434,7 @@ getFamDeclInitialKind decl@(FamilyDecl { fdLName = L _ name ; return (res_k, ()) } ; return [ (name, AThing fam_kind) ] } where - defaultResToStar = not $ isClosedTypeFamilyInfo info + defaultResToStar = (kcStrategyFamDecl decl == FullKindSignature) ---------------- kcSynDecls :: [SCC (LTyClDecl Name)] @@ -697,6 +696,7 @@ tcFamDecl1 parent , fdLName = lname@(L _ tc_name), fdTyVars = tvs }) -- Closed type families are a little tricky, because they contain the definition -- of both the type family and the equations for a CoAxiom. +-- Note: eqns might be empty, in a hs-boot file! = do { traceTc "closed type family:" (ppr tc_name) -- the variables in the header have no scope: ; (tvs', kind) <- tcTyClTyVars tc_name tvs $ \ tvs' kind -> @@ -727,14 +727,22 @@ tcFamDecl1 parent -- See [Zonking inside the knot] in TcHsType ; loc <- getSrcSpanM ; co_ax_name <- newFamInstAxiomName loc tc_name [] + + -- mkBranchedCoAxiom will fail on an empty list of branches, but + -- we'll never look at co_ax in this case ; let co_ax = mkBranchedCoAxiom co_ax_name fam_tc branches -- now, finally, build the TyCon - ; let syn_rhs = ClosedSynFamilyTyCon co_ax + ; let syn_rhs = if null eqns + then AbstractClosedSynFamilyTyCon + else ClosedSynFamilyTyCon co_ax roles = map (const Nominal) tvs' ; tycon <- buildSynTyCon tc_name tvs' roles syn_rhs kind parent - ; return [ATyCon tycon, ACoAxiom co_ax] } + ; let result = if null eqns + then [ATyCon tycon] + else [ATyCon tycon, ACoAxiom co_ax] + ; return result } -- We check for instance validity later, when doing validity checking for -- the tycon @@ -1404,9 +1412,14 @@ checkValidTyCon tc mroles | Just syn_rhs <- synTyConRhs_maybe tc = case syn_rhs of - ClosedSynFamilyTyCon ax -> checkValidClosedCoAxiom ax - OpenSynFamilyTyCon -> return () - SynonymTyCon ty -> + ClosedSynFamilyTyCon ax -> checkValidClosedCoAxiom ax + AbstractClosedSynFamilyTyCon -> + do { hsBoot <- tcIsHsBoot + ; checkTc hsBoot $ + ptext (sLit "You may omit the equations in a closed type family") $$ + ptext (sLit "only in a .hs-boot file") } + OpenSynFamilyTyCon -> return () + SynonymTyCon ty -> do { check_roles ; checkValidType syn_ctxt ty } diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 8a699614c6..47e64301b0 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -624,6 +624,10 @@ data SynTyConRhs -- | A closed type synonym family e.g. @type family F x where { F Int = Bool }@ | ClosedSynFamilyTyCon (CoAxiom Branched) -- The one axiom for this family + + -- | A closed type synonym family declared in an hs-boot file with + -- type family F a where .. + | AbstractClosedSynFamilyTyCon \end{code} Note [Closed type families] @@ -1200,9 +1204,10 @@ isEnumerationTyCon _ = False -- | Is this a 'TyCon', synonym or otherwise, that defines a family? isFamilyTyCon :: TyCon -> Bool -isFamilyTyCon (SynTyCon {synTcRhs = OpenSynFamilyTyCon }) = True -isFamilyTyCon (SynTyCon {synTcRhs = ClosedSynFamilyTyCon {} }) = True -isFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True +isFamilyTyCon (SynTyCon {synTcRhs = OpenSynFamilyTyCon }) = True +isFamilyTyCon (SynTyCon {synTcRhs = ClosedSynFamilyTyCon {} }) = True +isFamilyTyCon (SynTyCon {synTcRhs = AbstractClosedSynFamilyTyCon {} }) = True +isFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True isFamilyTyCon _ = False -- | Is this a 'TyCon', synonym or otherwise, that defines an family with @@ -1214,14 +1219,16 @@ isOpenFamilyTyCon _ = False -- | Is this a synonym 'TyCon' that can have may have further instances appear? isSynFamilyTyCon :: TyCon -> Bool -isSynFamilyTyCon (SynTyCon {synTcRhs = OpenSynFamilyTyCon {}}) = True -isSynFamilyTyCon (SynTyCon {synTcRhs = ClosedSynFamilyTyCon {}}) = True +isSynFamilyTyCon (SynTyCon {synTcRhs = OpenSynFamilyTyCon {}}) = True +isSynFamilyTyCon (SynTyCon {synTcRhs = ClosedSynFamilyTyCon {}}) = True +isSynFamilyTyCon (SynTyCon {synTcRhs = AbstractClosedSynFamilyTyCon {}}) = True isSynFamilyTyCon _ = False isOpenSynFamilyTyCon :: TyCon -> Bool isOpenSynFamilyTyCon (SynTyCon {synTcRhs = OpenSynFamilyTyCon }) = True isOpenSynFamilyTyCon _ = False +-- leave out abstract closed families here isClosedSynFamilyTyCon_maybe :: TyCon -> Maybe (CoAxiom Branched) isClosedSynFamilyTyCon_maybe (SynTyCon {synTcRhs = ClosedSynFamilyTyCon ax}) = Just ax |