dataConRepType, dataConSig, dataConFullSig,
dataConName, dataConTag, dataConTyCon, dataConUserType,
dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, dataConResTys,
+ dataConInstTys,
dataConEqSpec, eqSpecPreds, dataConTheta, dataConStupidTheta,
dataConInstArgTys, dataConOrigArgTys,
dataConInstOrigArgTys, dataConRepArgTys,
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,
-- 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
-> [TyVar] -> [TyVar]
-> [(TyVar,Type)] -> ThetaType
-> [Type] -> TyCon
+ -> Maybe [Type]
-> ThetaType -> DataConIds
-> DataCon
-- Can get the tag from the TyCon
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
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*,
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
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 )
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 )
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,
import DmdAnal ( dmdAnalTopRhs )
import CoreSyn
import Unique ( mkBuiltinUnique, mkPrimOpIdUnique )
+import Maybe ( fromJust )
import Maybes
import PrelNames
import Util ( dropList, isSingleton )
| 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
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
-- 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
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
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
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
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
put_ bh a7
put_ bh a8
put_ bh a9
+ put_ bh a10
get bh = do a1 <- get bh
a2 <- get bh
a3 <- get bh
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
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,
-> 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
}
-> 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
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 }
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
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
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
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")
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
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)
-- 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) &&&
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 )
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,
ifCons = IfAbstractTyCon,
ifGadtSyntax = False,
ifGeneric = False,
- ifRec = NonRecursive}
+ ifRec = NonRecursive,
+ ifFamily = Nothing }
| otherwise = pprPanic "toIfaceDecl" (ppr tycon)
where
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]
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(..),
import Util ( zipWithEqual, equalLength, splitAtList )
import DynFlags ( DynFlag(..), isOneShot )
+import Monad ( liftM )
\end{code}
This module takes
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)
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
-- 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
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(..) )
[] -- 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
[] -- No equality spec
[] -- No theta
arg_tys tycon
+ Nothing -- not a data instance
[] -- No stupid theta
(mkDataConIds bogus_wrap_name wrk_name data_con)
-- 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)
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 )
import Outputable
import Bag
import BasicTypes ( Activation( AlwaysActive ), InlineSpec(..) )
+import HscTypes ( implicitTyThings )
import FastString
\end{code}
-- (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
; 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
\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 []) $
+ recoverM (returnM ([], [])) $
setSrcSpan loc $
addErrCtxt (instDeclCtxt1 poly_ty) $
; checkValidInstance tyvars theta clas inst_tys
-- Next, process any associated types.
- ; idxty_inst_info <- mappM tcIdxTyInstDecl ats
+ ; idxty_info_tycons <- mappM tcIdxTyInstDecl ats
-- Finally, construct the Core representation of the instance.
-- (This no longer includes the associated types.)
; dfun_name <- newDFunName clas inst_tys (srcSpanStart loc)
; overlap_flag <- getOverlapFlag
- ; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys
- ispec = mkLocalInstance dfun overlap_flag
-
- ; return $ [InstInfo { iSpec = ispec,
- iBinds = VanillaInst binds uprags }] ++
- catMaybes idxty_inst_info }
+ ; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys
+ ispec = mkLocalInstance dfun overlap_flag
+ (idxty_infos,
+ idxty_tycons) = unzip idxty_info_tycons
+
+ ; return ([InstInfo { iSpec = ispec,
+ iBinds = VanillaInst binds uprags }] ++
+ catMaybes idxty_infos,
+ catMaybes idxty_tycons)
+ }
\end{code}
ConDecl(..), Sig(..), NewOrData(..), ResType(..),
tyClDeclTyVars, isSynDecl, isClassDecl, isIdxTyDecl,
isKindSigDecl, hsConArgs, LTyClDecl, tcdName,
- hsTyVarName, LHsTyVarBndr, LHsType
+ hsTyVarName, LHsTyVarBndr, LHsType, HsType(..),
+ mkHsAppTy
)
import HsTypes ( HsBang(..), getBangStrictness )
import BasicTypes ( RecFlag(..), StrictnessMark(..) )
data types (and GADTs).
\begin{code}
-tcIdxTyInstDecl :: LTyClDecl Name -> TcM (Maybe InstInfo) -- Nothing if error
+tcIdxTyInstDecl :: LTyClDecl Name
+ -> TcM (Maybe InstInfo, Maybe TyThing) -- Nothing if error
tcIdxTyInstDecl (L loc decl)
= -- Prime error recovery, set source location
- recoverM (returnM Nothing) $
- setSrcSpan loc $
- tcAddDeclCtxt decl $
+ recoverM (returnM (Nothing, Nothing)) $
+ setSrcSpan loc $
+ tcAddDeclCtxt decl $
do { -- indexed data types require -fglasgow-exts and can't be in an
-- hs-boot file
; gla_exts <- doptM Opt_GlasgowExts
; tcIdxTyInstDecl1 decl
}
-tcIdxTyInstDecl1 :: TyClDecl Name -> TcM (Maybe InstInfo) -- Nothing if error
+tcIdxTyInstDecl1 :: TyClDecl Name
+ -> TcM (Maybe InstInfo, Maybe TyThing) -- Nothing if error
tcIdxTyInstDecl1 (decl@TySynonym {})
- = kcIdxTyPats decl $ \k_tvs k_typats resKind ->
+ = kcIdxTyPats decl $ \k_tvs k_typats resKind _ ->
do { -- (1) kind check the right hand side of the type equation
; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind
-- construct type rewrite rule
-- !!!of the form: forall t_tvs. (tcdLName decl) t_typats = t_rhs
- ; return Nothing -- !!!TODO: need InstInfo for indexed types
+ ; return (Nothing, Nothing) -- !!!TODO: need InstInfo for eq axioms
}}
-tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L _ tc_name,
+tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
tcdCons = cons})
- = kcIdxTyPats decl $ \k_tvs k_typats resKind ->
+ = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
do { -- (1) kind check the data declaration as usual
; k_decl <- kcDataDecl decl k_tvs
- ; let k_ctxt = tcdCtxt decl
- k_cons = tcdCons decl
+ ; let k_ctxt = tcdCtxt k_decl
+ k_cons = tcdCons k_decl
-- result kind must be '*' (otherwise, we have too few patterns)
; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr tc_name
; checkTc h98_syntax (badGadtIdxTyDecl tc_name)
-- Check that a newtype has exactly one constructor
- ; checkTc (new_or_data == DataType || isSingleton cons) $
- newtypeConError tc_name (length cons)
+ ; checkTc (new_or_data == DataType || isSingleton k_cons) $
+ newtypeConError tc_name (length k_cons)
+ ; final_tvs <- tcDataKindSig (Just $ tyConKind family)
; t_typats <- mappM tcHsKindedType k_typats
; stupid_theta <- tcHsKindedContext k_ctxt
+
; tycon <- fixM (\ tycon -> do
{ data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data
- tycon t_tvs))
+ tycon final_tvs (Just t_typats)))
k_cons
; tc_rhs <-
case new_or_data of
NewType ->
ASSERT( isSingleton data_cons )
mkNewTyConRhs tc_name tycon (head data_cons)
- --vvvvvvv !!! need a new derived tc_name here
; buildAlgTyCon tc_name t_tvs stupid_theta tc_rhs Recursive
- False h98_syntax
+ False h98_syntax (Just family)
-- We always assume that indexed types are recursive. Why?
-- (1) Due to their open nature, we can never be sure that a
-- further instance might not introduce a new recursive
})
-- construct result
- -- !!!twofold: (1) (ATyCon tycon) and (2) an equality axiom
- ; return Nothing -- !!!TODO: need InstInfo for indexed types
+ -- !!!TODO: missing eq axiom
+ ; return (Nothing, Just (ATyCon tycon))
}}
where
h98_syntax = case cons of -- All constructors have same shape
-- check is only required for type functions.
--
kcIdxTyPats :: TyClDecl Name
- -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TcM a)
+ -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a)
-- ^^kinded tvs ^^kinded ty pats ^^res kind
-> TcM a
kcIdxTyPats decl thing_inside
= kcHsTyVars (tcdTyVars decl) $ \tvs ->
do { tc_ty_thing <- tcLookupLocated (tcdLName decl)
- ; let { tc_kind = case tc_ty_thing of
- AGlobal (ATyCon tycon) -> tyConKind tycon
- ; (kinds, resKind) = splitKindFunTys tc_kind
+ ; let { family = case tc_ty_thing of
+ AGlobal (ATyCon family) -> family
+ ; (kinds, resKind) = splitKindFunTys (tyConKind family)
; hs_typats = fromJust $ tcdTyPats decl }
-- we may not have more parameters than the kind indicates
-- type functions can have a higher-kinded result
; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
; typats <- zipWithM kcCheckHsType hs_typats kinds
- ; thing_inside tvs typats resultKind
+ ; thing_inside tvs typats resultKind family
}
where
\end{code}
(case new_or_data of
DataType -> OpenDataTyCon
NewType -> OpenNewTyCon)
- Recursive False True
+ Recursive False True Nothing
; return [ATyCon tycon]
}
; tycon <- fixM (\ tycon -> do
{ data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data
- tycon final_tvs))
+ tycon final_tvs Nothing))
cons
; tc_rhs <-
if null cons && is_boot -- In a hs-boot file, empty cons means
ASSERT( isSingleton data_cons )
mkNewTyConRhs tc_name tycon (head data_cons)
; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
- (want_generic && canDoGenerics data_cons) h98_syntax
+ (want_generic && canDoGenerics data_cons) h98_syntax Nothing
})
; return [ATyCon tycon]
}
-----------------------------------
tcConDecl :: Bool -- True <=> -funbox-strict_fields
- -> NewOrData -> TyCon -> [TyVar]
- -> ConDecl Name -> TcM DataCon
+ -> NewOrData
+ -> TyCon -> [TyVar]
+ -> Maybe [Type] -- Just ts <=> type patterns of instance type
+ -> ConDecl Name
+ -> TcM DataCon
-tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes
+tcConDecl unbox_strict NewType tycon tc_tvs mb_typats -- Newtypes
(ConDecl name _ ex_tvs ex_ctxt details ResTyH98)
= do { let tc_datacon field_lbls arg_ty
= do { arg_ty' <- tcHsKindedType arg_ty -- No bang on newtype
tc_tvs [] -- No existentials
[] [] -- No equalities, predicates
[arg_ty']
- tycon }
+ tycon
+ mb_typats}
-- Check that a newtype has no existential stuff
; checkTc (null ex_tvs && null (unLoc ex_ctxt)) (newtypeExError name)
; case details of
- PrefixCon [arg_ty] -> tc_datacon [] arg_ty
+ PrefixCon [arg_ty] -> tc_datacon [] arg_ty
RecCon [(field_lbl, arg_ty)] -> tc_datacon [field_lbl] arg_ty
- other -> failWithTc (newtypeFieldErr name (length (hsConArgs details)))
+ other ->
+ failWithTc (newtypeFieldErr name (length (hsConArgs details)))
-- Check that the constructor has exactly one field
}
-tcConDecl unbox_strict DataType tycon tc_tvs -- Data types
+tcConDecl unbox_strict DataType tycon tc_tvs mb_typats -- Data types
(ConDecl name _ tvs ctxt details res_ty)
= tcTyVarBndrs tvs $ \ tvs' -> do
{ ctxt' <- tcHsKindedContext ctxt
(argStrictness unbox_strict tycon bangs arg_tys)
(map unLoc field_lbls)
univ_tvs ex_tvs eq_preds ctxt' arg_tys
- data_tc }
- -- NB: we put data_tc, the type constructor gotten from the constructor
- -- type signature into the data constructor; that way
- -- checkValidDataCon can complain if it's wrong.
+ data_tc
+ mb_typats}
+ -- NB: we put data_tc, the type constructor gotten from the
+ -- constructor type signature into the data constructor;
+ -- that way checkValidDataCon can complain if it's wrong.
; case details of
PrefixCon btys -> tc_datacon False [] btys
PrimRep(..),
tyConPrimRep,
- AlgTyConRhs(..), visibleDataCons,
+ AlgTyConRhs(..), visibleDataCons, AlgTyConParent(..),
SynTyConRhs(..),
isFunTyCon, isUnLiftedTyCon, isProductTyCon,
tyConStupidTheta,
tyConArity,
isClassTyCon, tyConClass_maybe,
+ isFamInstTyCon, tyConFamily_maybe,
synTyConDefn, synTyConRhs, synTyConType, synTyConResKind,
tyConExtName, -- External name for foreign types
hasGenerics :: Bool, -- True <=> generic to/from functions are available
-- (in the exports of the data type's source module)
- algTcClass :: Maybe Class
- -- Just cl if this tycon came from a class declaration
+ algTcParent :: AlgTyConParent -- Gives the class or family tycon for
+ -- derived tycons representing classes
+ -- or family instances, respectively.
}
| TupleTyCon {
visibleDataCons (DataTyCon{ data_cons = cs }) = cs
visibleDataCons (NewTyCon{ data_con = c }) = [c]
+data AlgTyConParent = NoParentTyCon -- ordinary data type
+ | ClassTyCon Class -- class dictionary
+ | FamilyTyCon TyCon -- instance of type family
+
data SynTyConRhs
= OpenSynTyCon Kind -- Type family: *result* kind given
| SynonymTyCon Type -- Mentioning head type vars. Acts as a template for
-- This is the making of a TyCon. Just the same as the old mkAlgTyCon,
-- but now you also have to pass in the generic information about the type
-- constructor - you can get hold of it easily (see Generics module)
-mkAlgTyCon name kind tyvars stupid rhs sel_ids is_rec gen_info gadt_syn
+mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info gadt_syn
= AlgTyCon {
tyConName = name,
tyConUnique = nameUnique name,
algTcStupidTheta = stupid,
algTcRhs = rhs,
algTcSelIds = sel_ids,
- algTcClass = Nothing,
+ algTcParent = parent,
algTcRec = is_rec,
algTcGadtSyntax = gadt_syn,
hasGenerics = gen_info
}
-mkClassTyCon name kind tyvars rhs clas is_rec
- = AlgTyCon {
- tyConName = name,
- tyConUnique = nameUnique name,
- tyConKind = kind,
- tyConArity = length tyvars,
- tyConTyVars = tyvars,
- algTcStupidTheta = [],
- algTcRhs = rhs,
- algTcSelIds = [],
- algTcClass = Just clas,
- algTcRec = is_rec,
- algTcGadtSyntax = False, -- Doesn't really matter
- hasGenerics = False
- }
-
+mkClassTyCon name kind tyvars rhs clas is_rec =
+ mkAlgTyCon name kind tyvars [] rhs [] (ClassTyCon clas) is_rec False False
mkTupleTyCon name kind arity tyvars con boxed gen_info
= TupleTyCon {
tyConDataCons_maybe other = Nothing
tyConFamilySize :: TyCon -> Int
-tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon { data_cons = cons }}) = length cons
-tyConFamilySize (AlgTyCon {algTcRhs = NewTyCon {}}) = 1
-tyConFamilySize (TupleTyCon {}) = 1
+tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon {data_cons = cons}}) =
+ length cons
+tyConFamilySize (AlgTyCon {algTcRhs = NewTyCon {}}) = 1
+tyConFamilySize (AlgTyCon {algTcRhs = OpenDataTyCon}) = 0
+tyConFamilySize (TupleTyCon {}) = 1
#ifdef DEBUG
tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other)
#endif
\begin{code}
isClassTyCon :: TyCon -> Bool
-isClassTyCon (AlgTyCon {algTcClass = Just _}) = True
-isClassTyCon other_tycon = False
+isClassTyCon (AlgTyCon {algTcParent = ClassTyCon _}) = True
+isClassTyCon other_tycon = False
tyConClass_maybe :: TyCon -> Maybe Class
-tyConClass_maybe (AlgTyCon {algTcClass = maybe_clas}) = maybe_clas
-tyConClass_maybe ther_tycon = Nothing
+tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas}) = Just clas
+tyConClass_maybe ther_tycon = Nothing
+
+isFamInstTyCon :: TyCon -> Bool
+isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _}) = True
+isFamInstTyCon other_tycon = False
+
+tyConFamily_maybe :: TyCon -> Maybe TyCon
+tyConFamily_maybe (AlgTyCon {algTcParent = FamilyTyCon fam}) = Just fam
+tyConFamily_maybe ther_tycon = Nothing
\end{code}
projects / ghc-hetmet.git / commitdiff