X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FDataCon.lhs;h=345060204ccaf37d4931b98bf532aef19c32a1ce;hp=af19a586139492f2f3dbbcabcdf61edc899723c1;hb=9da4639011348fb6c318e3cba4b08622f811d9c4;hpb=19e64b50409a331ddf816cb4c7f33d646dabd43a diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index af19a58..3450602 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -33,22 +33,21 @@ import Type ( Type, ThetaType, substTyWith, substTyVar, mkTopTvSubst, mkForAllTys, mkFunTys, mkTyConApp, mkTyVarTy, mkTyVarTys, splitTyConApp_maybe, newTyConInstRhs, - mkPredTys, isStrictPred, pprType, mkPredTy + mkPredTys, isStrictPred, pprType ) import Coercion ( isEqPred, mkEqPred ) import TyCon ( TyCon, FieldLabel, tyConDataCons, isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon, - isNewTyCon, isRecursiveTyCon ) + isNewTyCon, isClosedNewTyCon, isRecursiveTyCon, + tyConFamInst_maybe ) import Class ( Class, classTyCon ) -import Name ( Name, NamedThing(..), nameUnique, mkSysTvName, mkSystemName ) -+ import Var ( TyVar, CoVar, Id, mkTyVar, tyVarKind, setVarUnique, -+ mkCoVar ) +import Name ( Name, NamedThing(..), nameUnique ) +import Var ( TyVar, Id ) import BasicTypes ( Arity, StrictnessMark(..) ) import Outputable import Unique ( Unique, Uniquable(..) ) import ListSetOps ( assoc, minusList ) import Util ( zipEqual, zipWithEqual ) -import List ( partition ) import Maybes ( expectJust ) import FastString \end{code} @@ -104,21 +103,55 @@ data constructor. The type checker translates it into either the wrapper Id The data con has one or two Ids associated with it: - The "worker Id", is the actual data constructor. - Its type may be different to the Haskell source constructor - because: - - useless dict args are dropped - - strict args may be flattened - The worker is very like a primop, in that it has no binding. +The "worker Id", is the actual data constructor. +* Every data constructor (newtype or data type) has a worker +* The worker is very like a primop, in that it has no binding. +* For a *data* type, the worker *is* the data constructor; + it has no unfolding - The "wrapper Id", $WC, whose type is exactly what it looks like - in the source program. It is an ordinary function, - and it gets a top-level binding like any other function. +* For a *newtype*, the worker has a compulsory unfolding which + does a cast, e.g. + newtype T = MkT Int + The worker for MkT has unfolding + \(x:Int). x `cast` sym CoT + Here CoT is the type constructor, witnessing the FC axiom + axiom CoT : T = Int - The wrapper Id isn't generated for a data type if the worker - and wrapper are identical. +The "wrapper Id", $WC, goes as follows + +* Its type is exactly what it looks like in the source program. + +* It is an ordinary function, and it gets a top-level binding + like any other function. + +* 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 + +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 + Notice that the worker has two fields where the wapper has + just one. That is, the worker has type + MkT :: Int -> Int -> T + +* Equality constraints for GADTs + data T a where { MkT :: a -> T [a] } + + The worker gets a type with explicit equality + constraints, thus: + 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 + The third argument is a coerion + [a] :: [a]:=:[a] @@ -410,22 +443,29 @@ mkDataCon name declared_infix eq_spec theta orig_arg_tys 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: +-- data T a where { MkT :: S } +-- then it's possible that the univ_tvs may hit an assertion failure +-- if you pull on univ_tvs. This case is checked by checkValidDataCon, +-- so the error is detected properly... it's just that asaertions here +-- are a little dodgy. + = 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 where is_vanilla = null ex_tvs && null eq_spec && null theta - con = ASSERT( is_vanilla || not (isNewTyCon tycon) ) - -- Invariant: newtypes have a vanilla data-con - MkData {dcName = name, dcUnique = nameUnique name, + con = MkData {dcName = name, dcUnique = nameUnique name, 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, dcRepArgTys = rep_arg_tys, - dcStrictMarks = arg_stricts, dcRepStrictness = rep_arg_stricts, + dcStrictMarks = arg_stricts, + dcRepStrictness = rep_arg_stricts, dcFields = fields, dcTag = tag, dcRepType = ty, dcIds = ids } @@ -572,6 +612,8 @@ dataConUserType :: DataCon -> Type -- T :: forall a. a -> T [a] -- rather than -- T :: forall b. forall a. (a=[b]) => a -> T b +-- 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, @@ -579,7 +621,9 @@ dataConUserType (MkData { dcUnivTyVars = univ_tvs, = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $ mkFunTys (mkPredTys theta) $ mkFunTys arg_tys $ - mkTyConApp tycon (map (substTyVar subst) univ_tvs) + case tyConFamInst_maybe tycon of + Nothing -> mkTyConApp tycon (map (substTyVar subst) univ_tvs) + Just (ftc, insttys) -> mkTyConApp ftc insttys -- data instance where subst = mkTopTvSubst eq_spec @@ -688,9 +732,10 @@ splitProductType str ty deepSplitProductType_maybe ty = do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty ; let {result - | isNewTyCon tycon && not (isRecursiveTyCon tycon) + | isClosedNewTyCon tycon && not (isRecursiveTyCon tycon) = deepSplitProductType_maybe (newTyConInstRhs tycon tycon_args) - | isNewTyCon tycon = Nothing -- cannot unbox through recursive newtypes + | isNewTyCon tycon = Nothing -- cannot unbox through recursive + -- newtypes nor through families | otherwise = Just res} ; result } @@ -712,6 +757,6 @@ computeRep stricts tys unbox MarkedStrict ty = [(MarkedStrict, ty)] unbox MarkedUnboxed ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys where - (tycon, tycon_args, arg_dc, arg_tys) + (_tycon, _tycon_args, arg_dc, arg_tys) = deepSplitProductType "unbox_strict_arg_ty" ty \end{code}