X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FDataCon.lhs;h=406d02a9df17207d3fc43c4f9ac81fd0cfa20a04;hp=0fb7fae87bd61fd7f209d929dad180185620a178;hb=215ce9f15215399ce30ae55c9521087847d78646;hpb=84923cc7de2a93c22a2f72daf9ac863959efae13 diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 0fb7fae..406d02a 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -6,14 +6,21 @@ \begin{code} module DataCon ( + -- * Main data types DataCon, DataConIds(..), - ConTag, fIRST_TAG, - mkDataCon, + ConTag, + + -- ** Type construction + mkDataCon, fIRST_TAG, + + -- ** Type deconstruction dataConRepType, dataConSig, dataConFullSig, - dataConName, dataConTag, dataConTyCon, dataConUserType, - dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, dataConResTys, - dataConEqSpec, eqSpecPreds, dataConTheta, dataConStupidTheta, - dataConInstArgTys, dataConOrigArgTys, + dataConName, dataConIdentity, dataConTag, dataConTyCon, + dataConOrigTyCon, dataConUserType, + dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, + dataConEqSpec, eqSpecPreds, dataConEqTheta, dataConDictTheta, + dataConStupidTheta, + dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, dataConInstOrigArgTys, dataConRepArgTys, dataConFieldLabels, dataConFieldType, dataConStrictMarks, dataConExStricts, @@ -21,9 +28,12 @@ module DataCon ( dataConIsInfix, dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds, dataConRepStrictness, + + -- ** Predicates on DataCons isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon, isVanillaDataCon, classDataCon, + -- * Splitting product types splitProductType_maybe, splitProductType, deepSplitProductType, deepSplitProductType_maybe ) where @@ -41,8 +51,13 @@ import Outputable import Unique import ListSetOps import Util -import Maybes import FastString +import Module + +import qualified Data.Data as Data +import Data.Char +import Data.Word +import Data.List ( partition ) \end{code} @@ -81,15 +96,20 @@ differently, as follows. Note [Data Constructor Naming] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Each data constructor C has two, and possibly three, Names associated with it: - - OccName Name space Used for - --------------------------------------------------------------------------- - * The "source data con" C DataName The DataCon itself - * The "real data con" C VarName Its worker Id - * The "wrapper data con" $WC VarName Wrapper Id (optional) - -Each of these three has a distinct Unique. The "source data con" name +Each data constructor C has two, and possibly up to four, Names associated with it: + + OccName Name space Name of Notes + --------------------------------------------------------------------------- + The "data con itself" C DataName DataCon In dom( GlobalRdrEnv ) + The "worker data con" C VarName Id The worker + The "wrapper data con" $WC VarName Id The wrapper + The "newtype coercion" :CoT TcClsName TyCon + +EVERY data constructor (incl for newtypes) has the former two (the +data con itself, and its worker. But only some data constructors have a +wrapper (see Note [The need for a wrapper]). + +Each of these three has a distinct Unique. The "data con itself" name appears in the output of the renamer, and names the Haskell-source data constructor. The type checker translates it into either the wrapper Id (if it exists) or worker Id (otherwise). @@ -108,11 +128,11 @@ The "worker Id", is the actual data constructor. does a cast, e.g. newtype T = MkT Int The worker for MkT has unfolding - \(x:Int). x `cast` sym CoT + \\(x:Int). x `cast` sym CoT Here CoT is the type constructor, witnessing the FC axiom axiom CoT : T = Int -The "wrapper Id", $WC, goes as follows +The "wrapper Id", \$WC, goes as follows * Its type is exactly what it looks like in the source program. @@ -121,14 +141,16 @@ The "wrapper Id", $WC, goes as follows * The wrapper Id isn't generated for a data type if there is nothing for the wrapper to do. That is, if its defn would be - $wC = C + \$wC = C +Note [The need for a wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Why might the wrapper have anything to do? Two reasons: * Unboxing strict fields (with -funbox-strict-fields) data T = MkT !(Int,Int) - $wMkT :: (Int,Int) -> T - $wMkT (x,y) = MkT x y + \$wMkT :: (Int,Int) -> T + \$wMkT (x,y) = MkT x y Notice that the worker has two fields where the wapper has just one. That is, the worker has type MkT :: Int -> Int -> T @@ -141,11 +163,13 @@ Why might the wrapper have anything to do? Two reasons: MkT :: forall a b. (a=[b]) => b -> T a The wrapper has the programmer-specified type: - $wMkT :: a -> T [a] - $wMkT a x = MkT [a] a [a] x + \$wMkT :: a -> T [a] + \$wMkT a x = MkT [a] a [a] x The third argument is a coerion - [a] :: [a]:=:[a] + [a] :: [a]~[a] +INVARIANT: the dictionary constructor for a class + never has a wrapper. A note about the stupid context @@ -208,44 +232,49 @@ Note that (Foo a) might not be an instance of Ord. %************************************************************************ \begin{code} +-- | A data constructor data DataCon = MkData { dcName :: Name, -- This is the name of the *source data con* -- (see "Note [Data Constructor Naming]" above) dcUnique :: Unique, -- Cached from Name - dcTag :: ConTag, + dcTag :: ConTag, -- ^ Tag, used for ordering 'DataCon's -- Running example: -- -- *** As declared by the user -- data T a where - -- MkT :: forall x y. (Ord x) => x -> y -> T (x,y) + -- MkT :: forall x y. (x~y,Ord x) => x -> y -> T (x,y) -- *** As represented internally -- data T a where - -- MkT :: forall a. forall x y. (a:=:(x,y), Ord x) => x -> y -> T a + -- MkT :: forall a. forall x y. (a~(x,y),x~y,Ord x) => x -> y -> T a -- -- The next six fields express the type of the constructor, in pieces -- e.g. -- -- dcUnivTyVars = [a] -- dcExTyVars = [x,y] - -- dcEqSpec = [a:=:(x,y)] - -- dcTheta = [Ord x] + -- dcEqSpec = [a~(x,y)] + -- dcEqTheta = [x~y] + -- dcDictTheta = [Ord x] -- dcOrigArgTys = [a,List b] - -- dcTyCon = T + -- dcRepTyCon = T dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor -- Its type is of form -- forall a1..an . t1 -> ... tm -> T a1..an -- No existentials, no coercions, nothing. - -- That is: dcExTyVars = dcEqSpec = dcTheta = [] + -- That is: dcExTyVars = dcEqSpec = dcEqTheta = dcDictTheta = [] -- NB 1: newtypes always have a vanilla data con -- NB 2: a vanilla constructor can still be declared in GADT-style -- syntax, provided its type looks like the above. -- The declaration format is held in the TyCon (algTcGadtSyntax) - dcUnivTyVars :: [TyVar], -- Universally-quantified type vars + dcUnivTyVars :: [TyVar], -- Universally-quantified type vars [a,b,c] + -- INVARIANT: length matches arity of the dcRepTyCon + --- result type of (rep) data con is exactly (T a b c) + dcExTyVars :: [TyVar], -- Existentially-quantified type vars -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE TYVARS -- FOR THE PARENT TyCon. With GADTs the data con might not even have @@ -257,19 +286,22 @@ data DataCon -- Reason: less confusing, and easier to generate IfaceSyn dcEqSpec :: [(TyVar,Type)], -- Equalities derived from the result type, - -- *as written by the programmer* + -- _as written by the programmer_ -- This field allows us to move conveniently between the two ways -- of representing a GADT constructor's type: - -- MkT :: forall a b. (a :=: [b]) => b -> T a + -- MkT :: forall a b. (a ~ [b]) => b -> T a -- MkT :: forall b. b -> T [b] - -- Each equality is of the form (a :=: ty), where 'a' is one of + -- Each equality is of the form (a ~ ty), where 'a' is one of -- the universally quantified type variables - dcTheta :: ThetaType, -- The context of the constructor + -- The next two fields give the type context of the data constructor + -- (aside from the GADT constraints, + -- which are given by the dcExpSpec) -- In GADT form, this is *exactly* what the programmer writes, even if -- the context constrains only universally quantified variables - -- MkT :: forall a. Eq a => a -> T a - -- It may contain user-written equality predicates too + -- MkT :: forall a b. (a ~ b, Ord b) => a -> T a b + dcEqTheta :: ThetaType, -- The *equational* constraints + dcDictTheta :: ThetaType, -- The *type-class and implicit-param* constraints dcStupidTheta :: ThetaType, -- The context of the data type declaration -- data Eq a => T a = ... @@ -288,19 +320,21 @@ data DataCon dcOrigArgTys :: [Type], -- Original argument types -- (before unboxing and flattening of strict fields) - - -- Result type of constructor is T t1..tn - dcTyCon :: TyCon, -- Result tycon, T + dcOrigResTy :: Type, -- Original result type, as seen by the user + -- NB: for a data instance, the original user result type may + -- differ from the DataCon's representation TyCon. Example + -- data instance T [a] where MkT :: a -> T [a] + -- The OrigResTy is T [a], but the dcRepTyCon might be :T123 -- Now the strictness annotations and field labels of the constructor - dcStrictMarks :: [StrictnessMark], + dcStrictMarks :: [HsBang], -- Strictness annotations as decided by the compiler. -- Does *not* include the existential dictionaries -- length = dataConSourceArity dataCon dcFields :: [FieldLabel], -- Field labels for this constructor, in the - -- same order as the argument types; + -- same order as the dcOrigArgTys; -- length = 0 (if not a record) or dataConSourceArity. -- Constructor representation @@ -308,23 +342,29 @@ data DataCon -- after unboxing and flattening, -- and *including* existential dictionaries - dcRepStrictness :: [StrictnessMark], -- One for each *representation* argument + dcRepStrictness :: [StrictnessMark], + -- One for each *representation* *value* argument -- See also Note [Data-con worker strictness] in MkId.lhs + -- Result type of constructor is T t1..tn + dcRepTyCon :: TyCon, -- Result tycon, T + dcRepType :: Type, -- Type of the constructor - -- forall a x y. (a:=:(x,y), Ord x) => x -> y -> MkT a + -- forall a x y. (a~(x,y), x~y, Ord x) => + -- x -> y -> T a -- (this is *not* of the constructor wrapper Id: -- see Note [Data con representation] below) -- Notice that the existential type parameters come *second*. -- Reason: in a case expression we may find: - -- case (e :: T t) of { MkT b (d:Ord b) (x:t) (xs:[b]) -> ... } + -- case (e :: T t) of + -- MkT x y co1 co2 (d:Ord x) (v:r) (w:F s) -> ... -- It's convenient to apply the rep-type of MkT to 't', to get - -- forall b. Ord b => ... + -- forall x y. (t~(x,y), x~y, Ord x) => x -> y -> T t -- and use that to check the pattern. Mind you, this is really only - -- use in CoreLint. + -- used in CoreLint. - -- Finally, the curried worker function that corresponds to the constructor + -- The curried worker function that corresponds to the constructor: -- It doesn't have an unfolding; the code generator saturates these Ids -- and allocates a real constructor when it finds one. -- @@ -336,6 +376,7 @@ data DataCon -- The actual fixity is stored elsewhere } +-- | Contains the Ids of the data constructor functions data DataConIds = DCIds (Maybe Id) Id -- Algebraic data types always have a worker, and -- may or may not have a wrapper, depending on whether @@ -350,7 +391,7 @@ data DataConIds -- The 'Nothing' case of DCIds is important -- Not only is this efficient, -- but it also ensures that the wrapper is replaced - -- by the worker (becuase it *is* the wroker) + -- by the worker (because it *is* the worker) -- even when there are no args. E.g. in -- f (:) x -- the (:) *is* the worker. @@ -359,10 +400,12 @@ data DataConIds -- but that makes it less likely that rules will match -- when we bring bits of unfoldings together.) +-- | Type of the tags associated with each constructor possibility type ConTag = Int fIRST_TAG :: ConTag -fIRST_TAG = 1 -- Tags allocated from here for real constructors +-- ^ Tags are allocated from here for real constructors +fIRST_TAG = 1 \end{code} Note [Data con representation] @@ -413,6 +456,15 @@ instance Outputable DataCon where instance Show DataCon where showsPrec p con = showsPrecSDoc p (ppr con) + +instance Data.Typeable DataCon where + typeOf _ = Data.mkTyConApp (Data.mkTyCon "DataCon") [] + +instance Data.Data DataCon where + -- don't traverse? + toConstr _ = abstractConstr "DataCon" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "DataCon" \end{code} @@ -423,13 +475,22 @@ instance Show DataCon where %************************************************************************ \begin{code} +-- | Build a new data constructor mkDataCon :: Name - -> Bool -- Declared infix - -> [StrictnessMark] -> [FieldLabel] - -> [TyVar] -> [TyVar] - -> [(TyVar,Type)] -> ThetaType - -> [Type] -> TyCon - -> ThetaType -> DataConIds + -> Bool -- ^ Is the constructor declared infix? + -> [HsBang] -- ^ Strictness annotations written in the source file + -> [FieldLabel] -- ^ Field labels for the constructor, if it is a record, + -- otherwise empty + -> [TyVar] -- ^ Universally quantified type variables + -> [TyVar] -- ^ Existentially quantified type variables + -> [(TyVar,Type)] -- ^ GADT equalities + -> ThetaType -- ^ Theta-type occuring before the arguments proper + -> [Type] -- ^ Original argument types + -> Type -- ^ Original result type + -> TyCon -- ^ Representation type constructor + -> ThetaType -- ^ The "stupid theta", context of the data declaration + -- e.g. @data Eq a => T a ...@ + -> DataConIds -- ^ The Ids of the actual builder functions -> DataCon -- Can get the tag from the TyCon @@ -438,7 +499,7 @@ mkDataCon name declared_infix fields univ_tvs ex_tvs eq_spec theta - orig_arg_tys tycon + orig_arg_tys orig_res_ty rep_tycon stupid_theta ids -- Warning: mkDataCon is not a good place to check invariants. -- If the programmer writes the wrong result type in the decl, thus: @@ -448,7 +509,7 @@ mkDataCon name declared_infix -- so the error is detected properly... it's just that asaertions here -- are a little dodgy. - = ASSERT( not (any isEqPred theta) ) + = -- ASSERT( not (any isEqPred theta) ) -- We don't currently allow any equality predicates on -- a data constructor (apart from the GADT ones in eq_spec) con @@ -458,8 +519,10 @@ mkDataCon name declared_infix dcVanilla = is_vanilla, dcInfix = declared_infix, dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, - dcStupidTheta = stupid_theta, dcTheta = theta, - dcOrigArgTys = orig_arg_tys, dcTyCon = tycon, + dcStupidTheta = stupid_theta, + dcEqTheta = eq_theta, dcDictTheta = dict_theta, + dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty, + dcRepTyCon = rep_tycon, dcRepArgTys = rep_arg_tys, dcStrictMarks = arg_stricts, dcRepStrictness = rep_arg_stricts, @@ -473,217 +536,309 @@ mkDataCon name declared_infix -- The 'arg_stricts' passed to mkDataCon are simply those for the -- source-language arguments. We add extra ones for the -- dictionary arguments right here. - dict_tys = mkPredTys theta - real_arg_tys = dict_tys ++ orig_arg_tys - real_stricts = map mk_dict_strict_mark theta ++ arg_stricts + (eq_theta,dict_theta) = partition isEqPred theta + dict_tys = mkPredTys dict_theta + real_arg_tys = dict_tys ++ orig_arg_tys + real_stricts = map mk_dict_strict_mark dict_theta ++ arg_stricts -- Representation arguments and demands -- To do: eliminate duplication with MkId (rep_arg_stricts, rep_arg_tys) = computeRep real_stricts real_arg_tys - tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con + tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $ mkFunTys (mkPredTys (eqSpecPreds eq_spec)) $ + mkFunTys (mkPredTys eq_theta) $ -- NB: the dict args are already in rep_arg_tys -- because they might be flattened.. -- but the equality predicates are not mkFunTys rep_arg_tys $ - mkTyConApp tycon (mkTyVarTys univ_tvs) + mkTyConApp rep_tycon (mkTyVarTys univ_tvs) eqSpecPreds :: [(TyVar,Type)] -> ThetaType eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv, ty) | (tv,ty) <- spec ] -mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict - | otherwise = NotMarkedStrict +mk_dict_strict_mark :: PredType -> HsBang +mk_dict_strict_mark pred | isStrictPred pred = HsStrict + | otherwise = HsNoBang \end{code} \begin{code} +-- | The 'Name' of the 'DataCon', giving it a unique, rooted identification dataConName :: DataCon -> Name dataConName = dcName +-- | The tag used for ordering 'DataCon's dataConTag :: DataCon -> ConTag dataConTag = dcTag +-- | The type constructor that we are building via this data constructor dataConTyCon :: DataCon -> TyCon -dataConTyCon = dcTyCon - +dataConTyCon = dcRepTyCon + +-- | The original type constructor used in the definition of this data +-- constructor. In case of a data family instance, that will be the family +-- type constructor. +dataConOrigTyCon :: DataCon -> TyCon +dataConOrigTyCon dc + | Just (tc, _) <- tyConFamInst_maybe (dcRepTyCon dc) = tc + | otherwise = dcRepTyCon dc + +-- | The representation type of the data constructor, i.e. the sort +-- type that will represent values of this type at runtime dataConRepType :: DataCon -> Type dataConRepType = dcRepType +-- | Should the 'DataCon' be presented infix? dataConIsInfix :: DataCon -> Bool dataConIsInfix = dcInfix +-- | The universally-quantified type variables of the constructor dataConUnivTyVars :: DataCon -> [TyVar] dataConUnivTyVars = dcUnivTyVars +-- | The existentially-quantified type variables of the constructor dataConExTyVars :: DataCon -> [TyVar] dataConExTyVars = dcExTyVars +-- | Both the universal and existentiatial type variables of the constructor dataConAllTyVars :: DataCon -> [TyVar] dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs }) = univ_tvs ++ ex_tvs +-- | Equalities derived from the result type of the data constructor, as written +-- by the programmer in any GADT declaration dataConEqSpec :: DataCon -> [(TyVar,Type)] dataConEqSpec = dcEqSpec -dataConTheta :: DataCon -> ThetaType -dataConTheta = dcTheta +-- | The equational constraints on the data constructor type +dataConEqTheta :: DataCon -> ThetaType +dataConEqTheta = dcEqTheta +-- | The type class and implicit parameter contsraints on the data constructor type +dataConDictTheta :: DataCon -> ThetaType +dataConDictTheta = dcDictTheta + +-- | Get the Id of the 'DataCon' worker: a function that is the "actual" +-- constructor and has no top level binding in the program. The type may +-- be different from the obvious one written in the source program. Panics +-- if there is no such 'Id' for this 'DataCon' dataConWorkId :: DataCon -> Id dataConWorkId dc = case dcIds dc of DCIds _ wrk_id -> wrk_id +-- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual" +-- constructor so it has the type visible in the source program: c.f. 'dataConWorkId'. +-- Returns Nothing if there is no wrapper, which occurs for an algebraic data constructor +-- and also for a newtype (whose constructor is inlined compulsorily) dataConWrapId_maybe :: DataCon -> Maybe Id --- Returns Nothing if there is no wrapper for an algebraic data con --- and also for a newtype (whose constructor is inlined compulsorily) dataConWrapId_maybe dc = case dcIds dc of DCIds mb_wrap _ -> mb_wrap +-- | Returns an Id which looks like the Haskell-source constructor by using +-- the wrapper if it exists (see 'dataConWrapId_maybe') and failing over to +-- the worker (see 'dataConWorkId') dataConWrapId :: DataCon -> Id --- Returns an Id which looks like the Haskell-source constructor dataConWrapId dc = case dcIds dc of DCIds (Just wrap) _ -> wrap DCIds Nothing wrk -> wrk -- worker=wrapper +-- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently, +-- the union of the 'dataConWorkId' and the 'dataConWrapId' dataConImplicitIds :: DataCon -> [Id] dataConImplicitIds dc = case dcIds dc of DCIds (Just wrap) work -> [wrap,work] DCIds Nothing work -> [work] +-- | The labels for the fields of this particular 'DataCon' dataConFieldLabels :: DataCon -> [FieldLabel] dataConFieldLabels = dcFields +-- | Extract the type for any given labelled field of the 'DataCon' dataConFieldType :: DataCon -> FieldLabel -> Type -dataConFieldType con label = expectJust "unexpected label" $ - lookup label (dcFields con `zip` dcOrigArgTys con) - -dataConStrictMarks :: DataCon -> [StrictnessMark] +dataConFieldType con label + = case lookup label (dcFields con `zip` dcOrigArgTys con) of + Just ty -> ty + Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label) + +-- | The strictness markings decided on by the compiler. Does not include those for +-- existential dictionaries. The list is in one-to-one correspondence with the arity of the 'DataCon' +dataConStrictMarks :: DataCon -> [HsBang] dataConStrictMarks = dcStrictMarks -dataConExStricts :: DataCon -> [StrictnessMark] --- Strictness of *existential* arguments only +-- | Strictness of /existential/ arguments only +dataConExStricts :: DataCon -> [HsBang] -- Usually empty, so we don't bother to cache this -dataConExStricts dc = map mk_dict_strict_mark (dcTheta dc) +dataConExStricts dc = map mk_dict_strict_mark $ dcDictTheta dc +-- | Source-level arity of the data constructor dataConSourceArity :: DataCon -> Arity - -- Source-level arity of the data constructor dataConSourceArity dc = length (dcOrigArgTys dc) --- dataConRepArity gives the number of actual fields in the --- {\em representation} of the data constructor. This may be more than appear --- in the source code; the extra ones are the existentially quantified --- dictionaries +-- | Gives the number of actual fields in the /representation/ of the +-- data constructor. This may be more than appear in the source code; +-- the extra ones are the existentially quantified dictionaries +dataConRepArity :: DataCon -> Int dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys -isNullarySrcDataCon, isNullaryRepDataCon :: DataCon -> Bool +-- | Return whether there are any argument types for this 'DataCon's original source type +isNullarySrcDataCon :: DataCon -> Bool isNullarySrcDataCon dc = null (dcOrigArgTys dc) + +-- | Return whether there are any argument types for this 'DataCon's runtime representation type +isNullaryRepDataCon :: DataCon -> Bool isNullaryRepDataCon dc = null (dcRepArgTys dc) dataConRepStrictness :: DataCon -> [StrictnessMark] - -- Give the demands on the arguments of a - -- Core constructor application (Con dc args) +-- ^ Give the demands on the arguments of a +-- Core constructor application (Con dc args) dataConRepStrictness dc = dcRepStrictness dc -dataConSig :: DataCon -> ([TyVar], ThetaType, [Type]) +-- | The \"signature\" of the 'DataCon' returns, in order: +-- +-- 1) The result of 'dataConAllTyVars', +-- +-- 2) All the 'ThetaType's relating to the 'DataCon' (coercion, dictionary, implicit +-- parameter - whatever) +-- +-- 3) The type arguments to the constructor +-- +-- 4) The /original/ result type of the 'DataCon' +dataConSig :: DataCon -> ([TyVar], ThetaType, [Type], Type) dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, - dcTheta = theta, dcOrigArgTys = arg_tys, dcTyCon = tycon}) - = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ theta, arg_tys) - + dcEqTheta = eq_theta, dcDictTheta = dict_theta, + dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) + = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ eq_theta ++ dict_theta, arg_tys, res_ty) + +-- | The \"full signature\" of the 'DataCon' returns, in order: +-- +-- 1) The result of 'dataConUnivTyVars' +-- +-- 2) The result of 'dataConExTyVars' +-- +-- 3) The result of 'dataConEqSpec' +-- +-- 4) The result of 'dataConDictTheta' +-- +-- 5) The original argument types to the 'DataCon' (i.e. before +-- any change of the representation of the type) +-- +-- 6) The original result type of the 'DataCon' dataConFullSig :: DataCon - -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type]) + -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, ThetaType, [Type], Type) dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, - dcTheta = theta, dcOrigArgTys = arg_tys, dcTyCon = tycon}) - = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys) + dcEqTheta = eq_theta, dcDictTheta = dict_theta, + dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) + = (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, res_ty) +dataConOrigResTy :: DataCon -> Type +dataConOrigResTy dc = dcOrigResTy dc + +-- | The \"stupid theta\" of the 'DataCon', such as @data Eq a@ in: +-- +-- > data Eq a => T a = ... dataConStupidTheta :: DataCon -> ThetaType dataConStupidTheta dc = dcStupidTheta dc -dataConResTys :: DataCon -> [Type] -dataConResTys dc = [substTyVar env tv | tv <- dcUnivTyVars dc] - where - env = mkTopTvSubst (dcEqSpec dc) - dataConUserType :: DataCon -> Type --- The user-declared type of the data constructor --- in the nice-to-read form --- T :: forall a. a -> T [a] --- rather than --- T :: forall b. forall a. (a=[b]) => a -> T b +-- ^ The user-declared type of the data constructor +-- in the nice-to-read form: +-- +-- > T :: forall a b. a -> b -> T [a] +-- +-- rather than: +-- +-- > T :: forall a c. forall b. (c~[a]) => a -> b -> T c +-- -- NB: If the constructor is part of a data instance, the result type -- mentions the family tycon, not the internal one. dataConUserType (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, - dcTheta = theta, dcOrigArgTys = arg_tys, - dcTyCon = tycon }) + dcEqTheta = eq_theta, dcDictTheta = dict_theta, dcOrigArgTys = arg_tys, + dcOrigResTy = res_ty }) = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $ - mkFunTys (mkPredTys theta) $ + mkFunTys (mkPredTys eq_theta) $ + mkFunTys (mkPredTys dict_theta) $ mkFunTys arg_tys $ - case tyConFamInst_maybe tycon of - Nothing -> mkTyConApp tycon (substTyVars subst univ_tvs) - Just (ftc, insttys) -> mkTyConApp ftc insttys -- data instance - where - subst = mkTopTvSubst eq_spec - -dataConInstArgTys :: DataCon - -> [Type] -- Instantiated at these types - -- NB: these INCLUDE the existentially quantified arg types - -> [Type] -- Needs arguments of these types - -- NB: these INCLUDE the existentially quantified dict args - -- but EXCLUDE the data-decl context which is discarded - -- It's all post-flattening etc; this is a representation type -dataConInstArgTys (MkData {dcRepArgTys = arg_tys, - dcUnivTyVars = univ_tvs, - dcExTyVars = ex_tvs}) inst_tys - = ASSERT( length tyvars == length inst_tys ) - map (substTyWith tyvars inst_tys) arg_tys - where - tyvars = univ_tvs ++ ex_tvs - - --- And the same deal for the original arg tys -dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] + res_ty + +-- | Finds the instantiated types of the arguments required to construct a 'DataCon' representation +-- NB: these INCLUDE any dictionary args +-- but EXCLUDE the data-declaration context, which is discarded +-- It's all post-flattening etc; this is a representation type +dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality constraints + -- However, it can have a dcTheta (notably it can be a + -- class dictionary, with superclasses) + -> [Type] -- ^ Instantiated at these types + -> [Type] +dataConInstArgTys dc@(MkData {dcRepArgTys = rep_arg_tys, + dcUnivTyVars = univ_tvs, dcEqSpec = eq_spec, + dcExTyVars = ex_tvs}) inst_tys + = ASSERT2 ( length univ_tvs == length inst_tys + , ptext (sLit "dataConInstArgTys") <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) + ASSERT2 ( null ex_tvs && null eq_spec, ppr dc ) + map (substTyWith univ_tvs inst_tys) rep_arg_tys + +-- | Returns just the instantiated /value/ argument types of a 'DataCon', +-- (excluding dictionary args) +dataConInstOrigArgTys + :: DataCon -- Works for any DataCon + -> [Type] -- Includes existential tyvar args, but NOT + -- equality constraints or dicts + -> [Type] +-- For vanilla datacons, it's all quite straightforward +-- But for the call in MatchCon, we really do want just the value args dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, - dcUnivTyVars = univ_tvs, - dcExTyVars = ex_tvs}) inst_tys - = ASSERT2( length tyvars == length inst_tys, ptext SLIT("dataConInstOrigArgTys") <+> ppr dc <+> ppr inst_tys ) - map (substTyWith tyvars inst_tys) arg_tys - where - tyvars = univ_tvs ++ ex_tvs + dcUnivTyVars = univ_tvs, + dcExTyVars = ex_tvs}) inst_tys + = ASSERT2( length tyvars == length inst_tys + , ptext (sLit "dataConInstOrigArgTys") <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) + map (substTyWith tyvars inst_tys) arg_tys + where + tyvars = univ_tvs ++ ex_tvs \end{code} -These two functions get the real argument types of the constructor, -without substituting for any type variables. - -dataConOrigArgTys returns the arg types of the wrapper, excluding all dictionary args. - -dataConRepArgTys retuns the arg types of the worker, including all dictionaries, and -after any flattening has been done. - \begin{code} +-- | Returns the argument types of the wrapper, excluding all dictionary arguments +-- and without substituting for any type variables dataConOrigArgTys :: DataCon -> [Type] dataConOrigArgTys dc = dcOrigArgTys dc +-- | Returns the arg types of the worker, including all dictionaries, after any +-- flattening has been done and without substituting for any type variables dataConRepArgTys :: DataCon -> [Type] dataConRepArgTys dc = dcRepArgTys dc \end{code} +\begin{code} +-- | The string @package:module.name@ identifying a constructor, which is attached +-- to its info table and used by the GHCi debugger and the heap profiler +dataConIdentity :: DataCon -> [Word8] +-- We want this string to be UTF-8, so we get the bytes directly from the FastStrings. +dataConIdentity dc = bytesFS (packageIdFS (modulePackageId mod)) ++ + fromIntegral (ord ':') : bytesFS (moduleNameFS (moduleName mod)) ++ + fromIntegral (ord '.') : bytesFS (occNameFS (nameOccName name)) + where name = dataConName dc + mod = ASSERT( isExternalName name ) nameModule name +\end{code} \begin{code} isTupleCon :: DataCon -> Bool -isTupleCon (MkData {dcTyCon = tc}) = isTupleTyCon tc +isTupleCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc isUnboxedTupleCon :: DataCon -> Bool -isUnboxedTupleCon (MkData {dcTyCon = tc}) = isUnboxedTupleTyCon tc +isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc +-- | Vanilla 'DataCon's are those that are nice boring Haskell 98 constructors isVanillaDataCon :: DataCon -> Bool isVanillaDataCon dc = dcVanilla dc \end{code} - \begin{code} classDataCon :: Class -> DataCon classDataCon clas = case tyConDataCons (classTyCon clas) of (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr + [] -> panic "classDataCon" \end{code} %************************************************************************ @@ -693,19 +848,25 @@ classDataCon clas = case tyConDataCons (classTyCon clas) of %************************************************************************ \begin{code} +-- | Extract the type constructor, type argument, data constructor and it's +-- /representation/ argument types from a type if it is a product type. +-- +-- Precisely, we return @Just@ for any type that is all of: +-- +-- * Concrete (i.e. constructors visible) +-- +-- * Single-constructor +-- +-- * Not existentially quantified +-- +-- Whether the type is a @data@ type or a @newtype@ splitProductType_maybe - :: Type -- A product type, perhaps + :: Type -- ^ A product type, perhaps -> Maybe (TyCon, -- The type constructor [Type], -- Type args of the tycon DataCon, -- The data constructor - [Type]) -- Its *representation* arg types + [Type]) -- Its /representation/ arg types - -- Returns (Just ...) for any - -- concrete (i.e. constructors visible) - -- single-constructor - -- not existentially quantified - -- type whether a data type or a new type - -- -- Rejecing existentials is conservative. Maybe some things -- could be made to work with them, but I'm not going to sweat -- it through till someone finds it's important. @@ -717,43 +878,54 @@ splitProductType_maybe ty -- and for constructors visible -> Just (tycon, ty_args, data_con, dataConInstArgTys data_con ty_args) where - data_con = head (tyConDataCons tycon) - other -> Nothing + data_con = ASSERT( not (null (tyConDataCons tycon)) ) + head (tyConDataCons tycon) + _other -> Nothing +-- | As 'splitProductType_maybe', but panics if the 'Type' is not a product type +splitProductType :: String -> Type -> (TyCon, [Type], DataCon, [Type]) splitProductType str ty = case splitProductType_maybe ty of Just stuff -> stuff Nothing -> pprPanic (str ++ ": not a product") (pprType ty) +-- | As 'splitProductType_maybe', but in turn instantiates the 'TyCon' returned +-- and hence recursively tries to unpack it as far as it able to +deepSplitProductType_maybe :: Type -> Maybe (TyCon, [Type], DataCon, [Type]) deepSplitProductType_maybe ty = do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty ; let {result - | isClosedNewTyCon tycon && not (isRecursiveTyCon tycon) - = deepSplitProductType_maybe (newTyConInstRhs tycon tycon_args) + | Just (ty', _co) <- instNewTyCon_maybe tycon tycon_args + , not (isRecursiveTyCon tycon) + = deepSplitProductType_maybe ty' -- Ignore the coercion? | isNewTyCon tycon = Nothing -- cannot unbox through recursive -- newtypes nor through families | otherwise = Just res} ; result } - + +-- | As 'deepSplitProductType_maybe', but panics if the 'Type' is not a product type +deepSplitProductType :: String -> Type -> (TyCon, [Type], DataCon, [Type]) deepSplitProductType str ty = case deepSplitProductType_maybe ty of Just stuff -> stuff Nothing -> pprPanic (str ++ ": not a product") (pprType ty) -computeRep :: [StrictnessMark] -- Original arg strictness - -> [Type] -- and types +-- | Compute the representation type strictness and type suitable for a 'DataCon' +computeRep :: [HsBang] -- ^ Original argument strictness + -> [Type] -- ^ Original argument types -> ([StrictnessMark], -- Representation arg strictness [Type]) -- And type computeRep stricts tys = unzip $ concat $ zipWithEqual "computeRep" unbox stricts tys where - unbox NotMarkedStrict ty = [(NotMarkedStrict, ty)] - unbox MarkedStrict ty = [(MarkedStrict, ty)] - unbox MarkedUnboxed ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys - where - (_tycon, _tycon_args, arg_dc, arg_tys) - = deepSplitProductType "unbox_strict_arg_ty" ty + unbox HsNoBang ty = [(NotMarkedStrict, ty)] + unbox HsStrict ty = [(MarkedStrict, ty)] + unbox HsUnpackFailed ty = [(MarkedStrict, ty)] + unbox HsUnpack ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys + where + (_tycon, _tycon_args, arg_dc, arg_tys) + = deepSplitProductType "unbox_strict_arg_ty" ty \end{code}