Commit 80c89b80 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Extend TyCons and DataCons to represent data instance decls

Mon Sep 18 19:05:18 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Extend TyCons and DataCons to represent data instance decls
  Fri Aug 18 19:11:37 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Extend TyCons and DataCons to represent data instance decls
    - This is a faily involved patch, but it is not entirely complete:
      + The data con wrapper code for instance data cons needs to apply the
        coercions (which we still have to generate).
      + There are still bugs, but it doesn't seem to affect the compilation of
        code that doesn't use type families.
    
    ** WARNING: Yet another change of the iface format.  **
    **          Recompile everything.                    **
parent a4572b40
......@@ -11,6 +11,7 @@ module DataCon (
dataConRepType, dataConSig, dataConFullSig,
dataConName, dataConTag, dataConTyCon, dataConUserType,
dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, dataConResTys,
dataConInstTys,
dataConEqSpec, eqSpecPreds, dataConTheta, dataConStupidTheta,
dataConInstArgTys, dataConOrigArgTys,
dataConInstOrigArgTys, dataConRepArgTys,
......@@ -38,7 +39,7 @@ import Type ( Type, ThetaType,
import Coercion ( isEqPred, mkEqPred )
import TyCon ( TyCon, FieldLabel, tyConDataCons,
isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon,
isNewTyCon, isRecursiveTyCon )
isNewTyCon, isRecursiveTyCon, tyConFamily_maybe )
import Class ( Class, classTyCon )
import Name ( Name, NamedThing(..), nameUnique, mkSysTvName, mkSystemName )
import Var ( TyVar, CoVar, Id, mkTyVar, tyVarKind, setVarUnique,
......@@ -335,9 +336,13 @@ data DataCon
-- An entirely separate wrapper function is built in TcTyDecls
dcIds :: DataConIds,
dcInfix :: Bool -- True <=> declared infix
dcInfix :: Bool, -- True <=> declared infix
-- Used for Template Haskell and 'deriving' only
-- The actual fixity is stored elsewhere
dcInstTys :: Maybe [Type] -- If this data constructor is part of a
-- data instance, then these are the type
-- patterns of the instance.
}
data DataConIds
......@@ -433,6 +438,7 @@ mkDataCon :: Name
-> [TyVar] -> [TyVar]
-> [(TyVar,Type)] -> ThetaType
-> [Type] -> TyCon
-> Maybe [Type]
-> ThetaType -> DataConIds
-> DataCon
-- Can get the tag from the TyCon
......@@ -443,6 +449,7 @@ mkDataCon name declared_infix
univ_tvs ex_tvs
eq_spec theta
orig_arg_tys tycon
mb_typats
stupid_theta ids
= ASSERT( not (any isEqPred theta) )
-- We don't currently allow any equality predicates on
......@@ -459,9 +466,11 @@ mkDataCon name declared_infix
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 }
dcIds = ids,
dcInstTys = mb_typats }
-- Strictness marks for source-args
-- *after unboxing choices*,
......@@ -600,20 +609,32 @@ dataConResTys dc = [substTyVar env tv | tv <- dcUnivTyVars dc]
where
env = mkTopTvSubst (dcEqSpec dc)
dataConInstTys :: DataCon -> Maybe [Type]
dataConInstTys = dcInstTys
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
-- 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 })
dcTyCon = tycon, dcInstTys = mb_insttys })
= mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
mkFunTys (mkPredTys theta) $
mkFunTys arg_tys $
mkTyConApp tycon (map (substTyVar subst) univ_tvs)
case mb_insttys of
Nothing -> mkTyConApp tycon (map (substTyVar subst) univ_tvs)
Just insttys -> mkTyConApp ftycon insttys -- data instance
where
ftycon = case tyConFamily_maybe tycon of
Just ftycon -> ftycon
Nothing -> panic err
err = "dataConUserType: type patterns without family tycon"
where
subst = mkTopTvSubst eq_spec
......
......@@ -47,7 +47,7 @@ import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy,
import TysWiredIn ( charTy, mkListTy )
import PrelRules ( primOpRules )
import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes,
newTyConInstRhs, mkTopTvSubst, substTyVar )
newTyConInstRhs, mkTopTvSubst, substTyVar, substTy )
import TcGadt ( gadtRefine, refineType, emptyRefinement )
import HsBinds ( ExprCoFn(..), isIdCoercion )
import Coercion ( mkSymCoercion, mkUnsafeCoercion, isEqPred )
......@@ -61,8 +61,8 @@ import CoreUtils ( exprType, dataConOrigInstPat, mkCoerce )
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding )
import Literal ( nullAddrLit, mkStringLit )
import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon,
newTyConCo )
tyConStupidTheta, isProductTyCon, isDataTyCon,
isRecursiveTyCon, tyConFamily_maybe, newTyConCo )
import Class ( Class, classTyCon, classSelIds )
import Var ( Id, TyVar, Var, setIdType )
import VarSet ( isEmptyVarSet, subVarSet, varSetElems )
......@@ -70,12 +70,13 @@ import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..))
import OccName ( mkOccNameFS, varName )
import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag )
import ForeignCall ( ForeignCall )
import DataCon ( DataCon, DataConIds(..), dataConTyCon, dataConUnivTyVars,
import DataCon ( DataCon, DataConIds(..), dataConTyCon,
dataConUnivTyVars, dataConInstTys,
dataConFieldLabels, dataConRepArity, dataConResTys,
dataConRepArgTys, dataConRepType, dataConFullSig,
dataConStrictMarks, dataConExStricts,
splitProductType, isVanillaDataCon, dataConFieldType,
deepSplitProductType
deepSplitProductType,
)
import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
......@@ -92,6 +93,7 @@ import NewDemand ( mkStrictSig, DmdResult(..),
import DmdAnal ( dmdAnalTopRhs )
import CoreSyn
import Unique ( mkBuiltinUnique, mkPrimOpIdUnique )
import Maybe ( fromJust )
import Maybes
import PrelNames
import Util ( dropList, isSingleton )
......@@ -196,13 +198,22 @@ mkDataConIds wrap_name wkr_name data_con
| any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper
|| not (null eq_spec)
|| isInst
= DCIds (Just alg_wrap_id) wrk_id
| otherwise -- Algebraic, no wrapper
= DCIds Nothing wrk_id
where
(univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys) = dataConFullSig data_con
tycon = dataConTyCon data_con
(univ_tvs, ex_tvs, eq_spec,
theta, orig_arg_tys) = dataConFullSig data_con
tycon = dataConTyCon data_con
(isInst, instTys, familyTyCon) =
case dataConInstTys data_con of
Nothing -> (False, [] , familyTyCon)
Just instTys -> (True , instTys, familyTyCon)
where
familyTyCon = fromJust $ tyConFamily_maybe tycon
-- this is defined whenever `isInst'
----------- Wrapper --------------
-- We used to include the stupid theta in the wrapper's args
......@@ -212,7 +223,10 @@ mkDataConIds wrap_name wkr_name data_con
subst = mkTopTvSubst eq_spec
dict_tys = mkPredTys theta
result_ty_args = map (substTyVar subst) univ_tvs
result_ty = mkTyConApp tycon result_ty_args
familyArgs = map (substTy subst) instTys
result_ty = if isInst
then mkTyConApp familyTyCon familyArgs -- instance con
else mkTyConApp tycon result_ty_args -- ordinary con
wrap_ty = mkForAllTys wrap_tvs $ mkFunTys dict_tys $
mkFunTys orig_arg_tys $ result_ty
-- NB: watch out here if you allow user-written equality
......@@ -256,7 +270,7 @@ mkDataConIds wrap_name wkr_name data_con
-- RetCPR is only true for products that are real data types;
-- that is, not unboxed tuples or [non-recursive] newtypes
----------- Wrappers for newtypes --------------
----------- Workers for newtypes --------------
nt_work_id = mkGlobalId (DataConWrapId data_con) wkr_name wrap_ty nt_work_info
nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
`setArityInfo` 1 -- Arity 1
......
......@@ -903,7 +903,7 @@ instance Binary IfaceDecl where
put_ bh idinfo
put_ bh (IfaceForeign ae af) =
error "Binary.put_(IfaceDecl): IfaceForeign"
put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do
put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
putByte bh 2
put_ bh a1
put_ bh a2
......@@ -912,7 +912,7 @@ instance Binary IfaceDecl where
put_ bh a5
put_ bh a6
put_ bh a7
put_ bh a8
put_ bh (IfaceSyn aq ar as at) = do
putByte bh 3
put_ bh aq
......@@ -944,7 +944,8 @@ instance Binary IfaceDecl where
a5 <- get bh
a6 <- get bh
a7 <- get bh
return (IfaceData a1 a2 a3 a4 a5 a6 a7)
a8 <- get bh
return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8)
3 -> do
aq <- get bh
ar <- get bh
......@@ -1005,7 +1006,7 @@ instance Binary IfaceConDecls where
return (IfNewTyCon aa)
instance Binary IfaceConDecl where
put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
put_ bh a1
put_ bh a2
put_ bh a3
......@@ -1015,6 +1016,7 @@ instance Binary IfaceConDecl where
put_ bh a7
put_ bh a8
put_ bh a9
put_ bh a10
get bh = do a1 <- get bh
a2 <- get bh
a3 <- get bh
......@@ -1024,7 +1026,8 @@ instance Binary IfaceConDecl where
a7 <- get bh
a8 <- get bh
a9 <- get bh
return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9)
a10 <- get bh
return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
instance Binary IfaceClassOp where
put_ bh (IfaceClassOp n def ty) = do
......
......@@ -23,15 +23,16 @@ import VarSet ( isEmptyVarSet, intersectVarSet, elemVarSet )
import TysWiredIn ( unitTy )
import BasicTypes ( RecFlag, StrictnessMark(..) )
import Name ( Name )
import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, mkClassTyConOcc,
mkClassDataConOcc, mkSuperDictSelOcc, mkNewTyCoOcc )
import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc,
mkClassTyConOcc, mkClassDataConOcc,
mkSuperDictSelOcc, mkNewTyCoOcc, mkLocalOcc )
import MkId ( mkDataConIds, mkRecordSelId, mkDictSelId )
import Class ( mkClass, Class( classTyCon), FunDep, DefMeth(..) )
import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons,
tyConStupidTheta, tyConDataCons, isNewTyCon,
mkClassTyCon, TyCon( tyConTyVars ),
isRecursiveTyCon, tyConArity, AlgTyConRhs(..),
SynTyConRhs(..), newTyConRhs )
SynTyConRhs(..), newTyConRhs, AlgTyConParent(..) )
import Type ( mkArrowKinds, liftedTypeKind, typeKind,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
splitTyConApp_maybe, splitAppTy_maybe,
......@@ -67,11 +68,23 @@ buildAlgTyCon :: Name -> [TyVar]
-> RecFlag
-> Bool -- True <=> want generics functions
-> Bool -- True <=> was declared in GADT syntax
-> Maybe TyCon -- Just family <=> instance of `family'
-> TcRnIf m n TyCon
buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
= do { let { tycon = mkAlgTyCon tc_name kind tvs stupid_theta
rhs fields is_rec want_generics gadt_syn
mb_family
= do { -- In case of a type instance, we need to invent a new name for the
-- instance type, as `tc_name' is the family name.
; uniq <- newUnique
; (final_name, parent) <-
case mb_family of
Nothing -> return (tc_name, NoParentTyCon)
Just family ->
do { final_name <- newImplicitBinder tc_name (mkLocalOcc uniq)
; return (final_name, FamilyTyCon family)
}
; let { tycon = mkAlgTyCon final_name kind tvs stupid_theta rhs
fields parent is_rec want_generics gadt_syn
; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
; fields = mkTyConSelIds tycon rhs
}
......@@ -177,13 +190,14 @@ buildDataCon :: Name -> Bool
-> ThetaType -- Does not include the "stupid theta"
-- or the GADT equalities
-> [Type] -> TyCon
-> Maybe [Type] -- Just ts <=> type pats of inst type
-> TcRnIf m n DataCon
-- A wrapper for DataCon.mkDataCon that
-- a) makes the worker Id
-- b) makes the wrapper Id if necessary, including
-- allocating its unique (hence monadic)
buildDataCon src_name declared_infix arg_stricts field_lbls
univ_tvs ex_tvs eq_spec ctxt arg_tys tycon
univ_tvs ex_tvs eq_spec ctxt arg_tys tycon mb_typats
= do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
-- This last one takes the name of the data constructor in the source
......@@ -195,7 +209,8 @@ buildDataCon src_name declared_infix arg_stricts field_lbls
data_con = mkDataCon src_name declared_infix
arg_stricts field_lbls
univ_tvs ex_tvs eq_spec ctxt
arg_tys tycon stupid_ctxt dc_ids
arg_tys tycon mb_typats
stupid_ctxt dc_ids
dc_ids = mkDataConIds wrap_name work_name data_con
; returnM data_con }
......@@ -271,7 +286,7 @@ buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec
tvs [{- no existentials -}]
[{- No equalities -}] [{-No context-}]
dict_component_tys
rec_tycon
rec_tycon Nothing
; rhs <- case dict_component_tys of
[rep_ty] -> mkNewTyConRhs tycon_name rec_tycon dict_con
......
......@@ -70,16 +70,23 @@ data IfaceDecl
ifType :: IfaceType,
ifIdInfo :: IfaceIdInfo }
| IfaceData { ifName :: OccName, -- Type constructor
| IfaceData { ifName :: OccName, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
ifCtxt :: IfaceContext, -- The "stupid theta"
ifCons :: IfaceConDecls, -- Includes new/data info
ifRec :: RecFlag, -- Recursive or not?
ifGadtSyntax :: Bool, -- True <=> declared using GADT syntax
ifGeneric :: Bool -- True <=> generic converter functions available
} -- We need this for imported data decls, since the
-- imported modules may have been compiled with
-- different flags to the current compilation unit
ifGadtSyntax :: Bool, -- True <=> declared using
-- GADT syntax
ifGeneric :: Bool, -- True <=> generic converter
-- functions available
-- We need this for imported
-- data decls, since the
-- imported modules may have
-- been compiled with
-- different flags to the
-- current compilation unit
ifFamily :: Maybe IfaceTyCon-- Just fam <=> instance of fam
}
| IfaceSyn { ifName :: OccName, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
......@@ -130,8 +137,10 @@ data IfaceConDecl
ifConCtxt :: IfaceContext, -- Non-stupid context
ifConArgTys :: [IfaceType], -- Arg types
ifConFields :: [OccName], -- ...ditto... (field labels)
ifConStricts :: [StrictnessMark] } -- Empty (meaning all lazy), or 1-1 corresp with arg types
ifConStricts :: [StrictnessMark], -- Empty (meaning all lazy),
-- or 1-1 corresp with arg tys
ifConInstTys :: Maybe [IfaceType] } -- instance types
data IfaceInst
= IfaceInst { ifInstCls :: IfaceExtName, -- See comments with
ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance
......@@ -249,9 +258,10 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
ifTyVars = tyvars, ifCons = condecls,
ifRec = isrec})
ifRec = isrec, ifFamily = mbFamily})
= hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls])
4 (vcat [pprRec isrec, pprGen gen, pprFamily mbFamily,
pp_condecls tycon condecls])
where
pp_nd = case condecls of
IfAbstractTyCon -> ptext SLIT("data")
......@@ -272,6 +282,9 @@ pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec
pprGen True = ptext SLIT("Generics: yes")
pprGen False = ptext SLIT("Generics: no")
pprFamily Nothing = ptext SLIT("DataFamily: none")
pprFamily (Just fam) = ptext SLIT("DataFamily:") <+> ppr fam
instance Outputable IfaceClassOp where
ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
......@@ -529,6 +542,7 @@ eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
ifRec d1 == ifRec d2 &&
ifGadtSyntax d1 == ifGadtSyntax d2 &&
ifGeneric d1 == ifGeneric d2) &&&
ifFamily d1 `eqIfTc_mb` ifFamily d2 &&&
eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
eq_hsCD env (ifCons d1) (ifCons d2)
......@@ -536,6 +550,10 @@ eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
-- The type variables of the data type do not scope
-- over the constructors (any more), but they do scope
-- over the stupid context in the IfaceConDecls
where
Nothing `eqIfTc_mb` Nothing = Equal
(Just fam1) `eqIfTc_mb` (Just fam2) = fam1 `eqIfTc` fam2
_ `eqIfTc_mb` _ = NotEqual
eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
= bool (ifName d1 == ifName d2) &&&
......
......@@ -190,10 +190,12 @@ import TyCon ( TyCon, AlgTyConRhs(..), SynTyConRhs(..),
isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon,
isTupleTyCon, tupleTyConBoxity, tyConStupidTheta,
tyConHasGenerics, synTyConRhs, isGadtSyntaxTyCon,
tyConArity, tyConTyVars, algTyConRhs, tyConExtName )
tyConArity, tyConTyVars, algTyConRhs, tyConExtName,
tyConFamily_maybe )
import DataCon ( dataConName, dataConFieldLabels, dataConStrictMarks,
dataConTyCon, dataConIsInfix, dataConUnivTyVars, dataConExTyVars, dataConEqSpec,
dataConTheta, dataConOrigArgTys )
dataConTyCon, dataConIsInfix, dataConUnivTyVars,
dataConExTyVars, dataConEqSpec, dataConTheta,
dataConOrigArgTys, dataConInstTys )
import Type ( TyThing(..), splitForAllTys, funResultTy )
import TcType ( deNoteType )
import TysPrim ( alphaTyVars )
......@@ -1033,7 +1035,8 @@ tyThingToIfaceDecl ext (ATyCon tycon)
ifCons = ifaceConDecls (algTyConRhs tycon),
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifGadtSyntax = isGadtSyntaxTyCon tycon,
ifGeneric = tyConHasGenerics tycon }
ifGeneric = tyConHasGenerics tycon,
ifFamily = fmap (toIfaceTyCon ext) $ tyConFamily_maybe tycon }
| isForeignTyCon tycon
= IfaceForeign { ifName = getOccName tycon,
......@@ -1047,7 +1050,8 @@ tyThingToIfaceDecl ext (ATyCon tycon)
ifCons = IfAbstractTyCon,
ifGadtSyntax = False,
ifGeneric = False,
ifRec = NonRecursive}
ifRec = NonRecursive,
ifFamily = Nothing }
| otherwise = pprPanic "toIfaceDecl" (ppr tycon)
where
......@@ -1075,9 +1079,13 @@ tyThingToIfaceDecl ext (ATyCon tycon)
ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con),
ifConEqSpec = to_eq_spec (dataConEqSpec data_con),
ifConCtxt = toIfaceContext ext (dataConTheta data_con),
ifConArgTys = map (toIfaceType ext) (dataConOrigArgTys data_con),
ifConFields = map getOccName (dataConFieldLabels data_con),
ifConStricts = dataConStrictMarks data_con }
ifConArgTys = map (toIfaceType ext)
(dataConOrigArgTys data_con),
ifConFields = map getOccName
(dataConFieldLabels data_con),
ifConStricts = dataConStrictMarks data_con,
ifConInstTys = fmap (map (toIfaceType ext))
(dataConInstTys data_con) }
to_eq_spec spec = [(getOccName tv, toIfaceType ext ty) | (tv,ty) <- spec]
......
......@@ -30,7 +30,8 @@ import Type ( liftedTypeKind, splitTyConApp, mkTyConApp,
ubxTupleKindTyCon,
mkTyVarTys, ThetaType )
import TypeRep ( Type(..), PredType(..) )
import TyCon ( TyCon, tyConName, SynTyConRhs(..) )
import TyCon ( TyCon, tyConName, SynTyConRhs(..),
AlgTyConParent(..) )
import HscTypes ( ExternalPackageState(..),
TyThing(..), tyThingClass, tyThingTyCon,
ModIface(..), ModDetails(..), HomeModInfo(..),
......@@ -68,6 +69,7 @@ import SrcLoc ( noSrcLoc )
import Util ( zipWithEqual, equalLength, splitAtList )
import DynFlags ( DynFlag(..), isOneShot )
import Monad ( liftM )
\end{code}
This module takes
......@@ -358,15 +360,22 @@ tcIfaceDecl (IfaceData {ifName = occ_name,
ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
ifCons = rdr_cons,
ifRec = is_rec,
ifGeneric = want_generic })
ifGeneric = want_generic,
ifFamily = mb_family })
= do { tc_name <- lookupIfaceTop occ_name
; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ tycon <- fixM ( \ tycon -> do
{ stupid_theta <- tcIfaceCtxt ctxt
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
; family <- case mb_family of
Nothing -> return Nothing
Just fam ->
do { famTyCon <- tcIfaceTyCon fam
; return $ Just famTyCon
}
; buildAlgTyCon tc_name tyvars stupid_theta
cons is_rec want_generic gadt_syn
cons is_rec want_generic gadt_syn family
})
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon)
......@@ -428,7 +437,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
ifConArgTys = args, ifConFields = field_lbls,
ifConStricts = stricts})
ifConStricts = stricts, ifConInstTys = mb_insttys })
= bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do
bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do
{ name <- lookupIfaceTop occ
......@@ -447,12 +456,17 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
-- the component types unless they are really needed
; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
; lbl_names <- mappM lookupIfaceTop field_lbls
; mb_insttys' <- case mb_insttys of
Nothing -> return Nothing
Just insttys -> liftM Just $
mappM tcIfaceType insttys
; buildDataCon name is_infix {- Not infix -}
stricts lbl_names
univ_tyvars ex_tyvars
eq_spec theta
arg_tys tycon
mb_insttys'
}
mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name
......
......@@ -67,7 +67,8 @@ import OccName ( mkOccNameFS, tcName, dataName, mkTupleOcc,
import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity )
import Var ( TyVar, tyVarKind )
import TyCon ( TyCon, AlgTyConRhs(DataTyCon), tyConDataCons,
mkTupleTyCon, mkAlgTyCon, tyConName )
mkTupleTyCon, mkAlgTyCon, tyConName,
AlgTyConParent(NoParentTyCon) )
import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed,
StrictnessMark(..) )
......@@ -204,6 +205,7 @@ pcTyCon is_enum is_rec name tyvars cons
[] -- No stupid theta
(DataTyCon cons is_enum)
[] -- No record selectors
NoParentTyCon
is_rec
True -- All the wired-in tycons have generics
False -- Not in GADT syntax
......@@ -230,6 +232,7 @@ pcDataConWithFixity declared_infix dc_name tyvars arg_tys tycon
[] -- No equality spec
[] -- No theta
arg_tys tycon
Nothing -- not a data instance
[] -- No stupid theta
(mkDataConIds bogus_wrap_name wrk_name data_con)
......
......@@ -630,7 +630,8 @@ tcDataKindSig :: Maybe Kind -> TcM [TyVar]
-- GADT decls can have a (perhaps partial) kind signature
-- e.g. data T :: * -> * -> * where ...
-- This function makes up suitable (kinded) type variables for
-- the argument kinds, and checks that the result kind is indeed *
-- the argument kinds, and checks that the result kind is indeed *.
-- We use it also to make up argument type variables for for data instances.
tcDataKindSig Nothing = return []
tcDataKindSig (Just kind)
= do { checkTc (isLiftedTypeKind res_kind) (badKindSig kind)
......
......@@ -22,13 +22,13 @@ import Inst ( newDictBndr, newDictBndrs, instToId, showLIE,
import InstEnv ( mkLocalInstance, instanceDFunId )
import TcDeriv ( tcDeriving )
import TcEnv ( InstInfo(..), InstBindings(..),
newDFunName, tcExtendIdEnv
newDFunName, tcExtendIdEnv, tcExtendGlobalEnv
)
import TcHsType ( kcHsSigType, tcHsKindedType )
import TcUnify ( checkSigTyVars )
import TcSimplify ( tcSimplifySuperClasses )
import Type ( zipOpenTvSubst, substTheta, mkTyConApp, mkTyVarTy,
splitFunTys )
splitFunTys, TyThing )
import Coercion ( mkSymCoercion )
import TyCon ( TyCon, newTyConCo, tyConTyVars )
import DataCon ( classDataCon, dataConTyCon, dataConInstArgTys )
......@@ -44,6 +44,7 @@ import ListSetOps ( minusList )
import Outputable
import Bag
import BasicTypes ( Activation( AlwaysActive ), InlineSpec(..) )
import HscTypes ( implicitTyThings )
import FastString
\end{code}
......@@ -146,24 +147,35 @@ tcInstDecls1 tycl_decls inst_decls
-- (1) Do the ordinary instance declarations and instances of
-- indexed types
; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls }
; local_inst_infos <- mappM tcLocalInstDecl1 inst_decls
; idxty_inst_infos <- mappM tcIdxTyInstDecl idxty_decls
; let { local_inst_info = concat local_inst_infos ++
catMaybes idxty_inst_infos
; clas_decls = filter (isClassDecl.unLoc) tycl_decls }
-- (2) Instances from generic class declarations
; local_info_tycons <- mappM tcLocalInstDecl1 inst_decls
; idxty_info_tycons <- mappM tcIdxTyInstDecl idxty_decls
; let { (local_infos,
local_tycons) = unzip local_info_tycons
; (idxty_infos,
idxty_tycons) = unzip idxty_info_tycons
; local_idxty_info = concat local_infos ++ catMaybes idxty_infos
; local_idxty_tycon = concat local_tycons ++
catMaybes idxty_tycons
; clas_decls = filter (isClassDecl.unLoc) tycl_decls
; implicit_things = concatMap implicitTyThings local_idxty_tycon
}
-- (2) Add the tycons of associated types and their implicit
-- tythings to the global environment
; tcExtendGlobalEnv (local_idxty_tycon ++ implicit_things) $ do {
-- (3) Instances from generic class declarations
; generic_inst_info <- getGenericInstances clas_decls
-- Next, construct the instance environment so far, consisting
-- of
-- a) local instance decls
-- b) generic instances
; addInsts local_inst_info $ do {
; addInsts local_idxty_info $ do {
; addInsts generic_inst_info $ do {
-- (3) Compute instances from "deriving" clauses;
-- (4) Compute instances from "deriving" clauses;
-- This stuff computes a context for the derived instance
-- decl, so it needs to know about all the instances possible
; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls
......@@ -171,9 +183,9 @@ tcInstDecls1 tycl_decls inst_decls
; gbl_env <- getGblEnv
; returnM (gbl_env,
generic_inst_info ++ deriv_inst_info ++ local_inst_info,
generic_inst_info ++ deriv_inst_info ++ local_idxty_info,
deriv_binds)
}}}}
}}}}}
addInsts :: [InstInfo] -> TcM a -> TcM a
addInsts infos thing_inside
......@@ -182,14 +194,14 @@ addInsts infos thing_inside
\begin{code}
tcLocalInstDecl1 :: LInstDecl Name
-> TcM [InstInfo] -- [] if there was an error
-> TcM ([InstInfo], [TyThing]) -- [] if there was an error
-- A source-file instance declaration
-- Type-check all the stuff before the "where"
--
-- We check for respectable instance type, and context
tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
= -- Prime error recovery, set source location
recoverM (returnM []) $