From 8406c69e81f9416bc4b93c4323bbd36b25655e65 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Fri, 23 Feb 2007 03:38:48 +0000 Subject: [PATCH] Moved argument position info of ATs into tycon rhs info --- compiler/iface/BuildTyCl.lhs | 6 +-- compiler/iface/MkIface.lhs | 14 ++--- compiler/iface/TcIface.lhs | 2 +- compiler/typecheck/TcTyClsDecls.lhs | 10 ++-- compiler/types/TyCon.lhs | 100 +++++++++++++++++++---------------- 5 files changed, 69 insertions(+), 63 deletions(-) diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 864cb19..aa01e70 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -37,7 +37,7 @@ import Data.List \begin{code} ------------------------------------------------------ buildSynTyCon :: Name -> [TyVar] -> SynTyConRhs -> TyCon -buildSynTyCon name tvs rhs@(OpenSynTyCon rhs_ki) +buildSynTyCon name tvs rhs@(OpenSynTyCon rhs_ki _) = mkSynTyCon name kind tvs rhs where kind = mkArrowKinds (map tyVarKind tvs) rhs_ki @@ -100,10 +100,10 @@ mkAbstractTyConRhs :: AlgTyConRhs mkAbstractTyConRhs = AbstractTyCon mkOpenDataTyConRhs :: AlgTyConRhs -mkOpenDataTyConRhs = OpenDataTyCon +mkOpenDataTyConRhs = OpenTyCon Nothing False mkOpenNewTyConRhs :: AlgTyConRhs -mkOpenNewTyConRhs = OpenNewTyCon +mkOpenNewTyConRhs = OpenTyCon Nothing True mkDataTyConRhs :: [DataCon] -> AlgTyConRhs mkDataTyConRhs cons diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index e491039..a02f449 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1085,16 +1085,16 @@ tyThingToIfaceDecl (ATyCon tycon) where tyvars = tyConTyVars tycon (syn_isOpen, syn_tyki) = case synTyConRhs tycon of - OpenSynTyCon ki -> (True , ki) - SynonymTyCon ty -> (False, ty) + OpenSynTyCon ki _ -> (True , ki) + SynonymTyCon ty -> (False, ty) - ifaceConDecls (NewTyCon { data_con = con }) = + ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) - ifaceConDecls (DataTyCon { data_cons = cons }) = + ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) - ifaceConDecls OpenDataTyCon = IfOpenDataTyCon - ifaceConDecls OpenNewTyCon = IfOpenNewTyCon - ifaceConDecls AbstractTyCon = IfAbstractTyCon + ifaceConDecls OpenTyCon { otIsNewtype = False } = IfOpenDataTyCon + ifaceConDecls OpenTyCon { otIsNewtype = True } = IfOpenNewTyCon + ifaceConDecls AbstractTyCon = IfAbstractTyCon -- The last case happens when a TyCon has been trimmed during tidying -- Furthermore, tyThingToIfaceDecl is also used -- in TcRnDriver for GHCi, when browsing a module, in which case the diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 1643e19..5af949e 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -380,7 +380,7 @@ tcIfaceDecl ignore_prags = bindIfaceTyVars tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name ; rhs_tyki <- tcIfaceType rdr_rhs_ty - ; let rhs = if isOpen then OpenSynTyCon rhs_tyki + ; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing else SynonymTyCon rhs_tyki ; return (ATyCon (buildSynTyCon tc_name tyvars rhs)) } diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 0474581..6788eee 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -615,7 +615,7 @@ tcTyClDecl1 _calc_isrec -- Check that we don't use families without -findexed-types ; checkTc idx_tys $ badFamInstDecl tc_name - ; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind)] + ; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing)] } -- "newtype family" or "data family" declaration @@ -634,8 +634,8 @@ tcTyClDecl1 _calc_isrec ; tycon <- buildAlgTyCon tc_name final_tvs [] (case new_or_data of - DataType -> OpenDataTyCon - NewType -> OpenNewTyCon) + DataType -> mkOpenDataTyConRhs + NewType -> mkOpenNewTyConRhs) Recursive False True Nothing ; return [ATyCon tycon] } @@ -945,8 +945,8 @@ checkValidTyCon :: TyCon -> TcM () checkValidTyCon tc | isSynTyCon tc = case synTyConRhs tc of - OpenSynTyCon _ -> return () - SynonymTyCon ty -> checkValidType syn_ctxt ty + OpenSynTyCon _ _ -> return () + SynonymTyCon ty -> checkValidType syn_ctxt ty | otherwise = -- Check the context on the data decl checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) `thenM_` diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 6dba52b..8b2b24c 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -108,15 +108,6 @@ data TyCon -- types if present -- But not over the data constructors - tyConArgPoss :: Maybe [Int], -- for associated families: for each - -- tyvar in the AT decl, gives the - -- position of that tyvar in the class - -- argument list (starting from 0). - -- NB: Length is less than tyConArity - -- if higher kind signature. - -- NB: Just _ <=> associated (not - -- toplevel) family - algTcSelIds :: [Id], -- Its record selectors (empty if none) algTcGadtSyntax :: Bool, -- True <=> the data type was declared using GADT syntax @@ -158,13 +149,6 @@ data TyCon tyConTyVars :: [TyVar], -- Bound tyvars - tyConArgPoss :: Maybe [Int], -- for associated families: for each - -- tyvar in the AT decl, gives the - -- position of that tyvar in the class - -- argument list (starting from 0). - -- NB: Length is less than tyConArity - -- if higher kind signature. - synTcRhs :: SynTyConRhs -- Expanded type in here } @@ -204,21 +188,37 @@ data TyCon type FieldLabel = Name +-- Right hand sides of type constructors for algebraic types +-- data AlgTyConRhs - = AbstractTyCon -- We know nothing about this data type, except - -- that it's represented by a pointer - -- Used when we export a data type abstractly into - -- an hi file - | OpenDataTyCon -- data family (further instances can appear - | OpenNewTyCon -- newtype family at any time) + -- We know nothing about this data type, except that it's represented by a + -- pointer. Used when we export a data type abstractly into an hi file. + -- + = AbstractTyCon + + -- The constructor represents an open family without a fixed right hand + -- side. Additional instances can appear at any time. + -- + | OpenTyCon { + + otArgPoss :: Maybe [Int], + -- for associated families: for each tyvar in the AT decl, gives the + -- position of that tyvar in the class argument list (starting from 0). + -- NB: Length is less than tyConArity iff higher kind signature. + -- NB: Just _ <=> associated (not toplevel) family + + otIsNewtype :: Bool + -- is a newtype (rather than data type)? + + } | DataTyCon { data_cons :: [DataCon], -- The constructors; can be empty if the user declares -- the type to have no constructors -- INVARIANT: Kept in order of increasing tag - -- (see the tag assignment in DataCon.mkDataCon) + -- (see the tag assignment in DataCon.mkDataCon) is_enum :: Bool -- Cached: True <=> an enumeration type } -- Includes data types with no constructors. @@ -257,8 +257,7 @@ data AlgTyConRhs visibleDataCons :: AlgTyConRhs -> [DataCon] visibleDataCons AbstractTyCon = [] -visibleDataCons OpenDataTyCon = [] -visibleDataCons OpenNewTyCon = [] +visibleDataCons OpenTyCon {} = [] visibleDataCons (DataTyCon{ data_cons = cs }) = cs visibleDataCons (NewTyCon{ data_con = c }) = [c] @@ -286,7 +285,14 @@ data AlgTyConParent -- with T77's algTcParent = FamilyTyCon T [a] co data SynTyConRhs - = OpenSynTyCon Kind -- Type family: *result* kind given + = OpenSynTyCon Kind -- Type family: *result* kind given + (Maybe [Int]) -- for associated families: for each tyvars in + -- the AT decl, gives the position of that + -- tyvar in the class argument list (starting + -- from 0). + -- NB: Length is less than tyConArity + -- if higher kind signature. + | SynonymTyCon Type -- Mentioning head type vars. Acts as a template for -- the expansion when the tycon is applied to some -- types. @@ -428,7 +434,6 @@ mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info gadt_syn tyConKind = kind, tyConArity = length tyvars, tyConTyVars = tyvars, - tyConArgPoss = Nothing, algTcStupidTheta = stupid, algTcRhs = rhs, algTcSelIds = sel_ids, @@ -498,7 +503,6 @@ mkSynTyCon name kind tyvars rhs tyConKind = kind, tyConArity = length tyvars, tyConTyVars = tyvars, - tyConArgPoss = Nothing, synTcRhs = rhs } @@ -556,20 +560,20 @@ isDataTyCon :: TyCon -> Bool -- unboxed tuples isDataTyCon tc@(AlgTyCon {algTcRhs = rhs}) = case rhs of - OpenDataTyCon -> True + OpenTyCon {} -> not (otIsNewtype rhs) DataTyCon {} -> True - OpenNewTyCon -> False NewTyCon {} -> False - AbstractTyCon -> False -- We don't know, so return False + AbstractTyCon -> False -- We don't know, so return False isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity isDataTyCon other = False isNewTyCon :: TyCon -> Bool -isNewTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of - OpenNewTyCon -> True - NewTyCon {} -> True - _ -> False -isNewTyCon other = False +isNewTyCon (AlgTyCon {algTcRhs = rhs}) = + case rhs of + OpenTyCon {} -> otIsNewtype rhs + NewTyCon {} -> True + _ -> False +isNewTyCon other = False -- This is an important refinement as typical newtype optimisations do *not* -- hold for newtype families. Why? Given a type `T a', if T is a newtype @@ -616,22 +620,24 @@ isEnumerationTyCon (AlgTyCon {algTcRhs = DataTyCon { is_enum = res }}) = res isEnumerationTyCon other = False isOpenTyCon :: TyCon -> Bool -isOpenTyCon (SynTyCon {synTcRhs = OpenSynTyCon _}) = True -isOpenTyCon (AlgTyCon {algTcRhs = OpenDataTyCon }) = True -isOpenTyCon (AlgTyCon {algTcRhs = OpenNewTyCon }) = True -isOpenTyCon _ = False +isOpenTyCon (SynTyCon {synTcRhs = OpenSynTyCon _ _}) = True +isOpenTyCon (AlgTyCon {algTcRhs = OpenTyCon {} }) = True +isOpenTyCon _ = False assocTyConArgPoss_maybe :: TyCon -> Maybe [Int] -assocTyConArgPoss_maybe (AlgTyCon { tyConArgPoss = poss }) = poss -assocTyConArgPoss_maybe (SynTyCon { tyConArgPoss = poss }) = poss -assocTyConArgPoss_maybe _ = Nothing +assocTyConArgPoss_maybe (AlgTyCon { + algTcRhs = OpenTyCon {otArgPoss = poss}}) = poss +assocTyConArgPoss_maybe (SynTyCon { synTcRhs = OpenSynTyCon _ poss }) = poss +assocTyConArgPoss_maybe _ = Nothing isTyConAssoc :: TyCon -> Bool isTyConAssoc = isJust . assocTyConArgPoss_maybe setTyConArgPoss :: TyCon -> [Int] -> TyCon -setTyConArgPoss tc@(AlgTyCon {}) poss = tc { tyConArgPoss = Just poss } -setTyConArgPoss tc@(SynTyCon {}) poss = tc { tyConArgPoss = Just poss } +setTyConArgPoss tc@(AlgTyCon { algTcRhs = rhs }) poss = + tc { algTcRhs = rhs {otArgPoss = Just poss} } +setTyConArgPoss tc@(SynTyCon { synTcRhs = OpenSynTyCon ki _ }) poss = + tc { synTcRhs = OpenSynTyCon ki (Just poss) } setTyConArgPoss tc _ = pprPanic "setTyConArgPoss" (ppr tc) isTupleTyCon :: TyCon -> Bool @@ -769,7 +775,7 @@ tyConFamilySize :: TyCon -> Int tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon {data_cons = cons}}) = length cons tyConFamilySize (AlgTyCon {algTcRhs = NewTyCon {}}) = 1 -tyConFamilySize (AlgTyCon {algTcRhs = OpenDataTyCon}) = 0 +tyConFamilySize (AlgTyCon {algTcRhs = OpenTyCon {}}) = 0 tyConFamilySize (TupleTyCon {}) = 1 #ifdef DEBUG tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) @@ -826,7 +832,7 @@ synTyConType tc = case synTcRhs tc of _ -> pprPanic "synTyConType" (ppr tc) synTyConResKind :: TyCon -> Kind -synTyConResKind (SynTyCon {synTcRhs = OpenSynTyCon kind}) = kind +synTyConResKind (SynTyCon {synTcRhs = OpenSynTyCon kind _}) = kind synTyConResKind tycon = pprPanic "synTyConResKind" (ppr tycon) \end{code} -- 1.7.10.4