import TcRnMonad
import TcMType
import TcType
+import BuildTyCl
import Inst
import InstEnv
import FamInst
import FamInstEnv
-import MkCore ( nO_METHOD_BINDING_ERROR_ID )
import TcDeriv
import TcEnv
import RnSource ( addTcgDUs )
import TcHsType
import TcUnify
+import MkCore ( nO_METHOD_BINDING_ERROR_ID )
import Type
import Coercion
import TyCon
import DataCon
import Class
import Var
+import Pair
import VarSet
import CoreUtils ( mkPiTypes )
import CoreUnfold ( mkDFunUnfolding )
| isTyVarTy ty = return ()
| otherwise = addErrTc $ mustBeVarArgErr ty
checkIndex ty (Just instTy)
- | ty `tcEqType` instTy = return ()
- | otherwise = addErrTc $ wrongATArgErr ty instTy
+ | ty `eqType` instTy = return ()
+ | otherwise = addErrTc $ wrongATArgErr ty instTy
listToNameSet = addListToNameSet emptyNameSet
tv1 `sameLexeme` tv2 =
nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
in
- extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
+ TcType.extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
+\end{code}
+
+
+%************************************************************************
+%* *
+ Type checking family instances
+%* *
+%************************************************************************
+
+Family instances are somewhat of a hybrid. They are processed together with
+class instance heads, but can contain data constructors and hence they share a
+lot of kinding and type checking code with ordinary algebraic data types (and
+GADTs).
+
+\begin{code}
+tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing
+tcFamInstDecl top_lvl (L loc decl)
+ = -- Prime error recovery, set source location
+ setSrcSpan loc $
+ tcAddDeclCtxt decl $
+ do { -- type family instances require -XTypeFamilies
+ -- and can't (currently) be in an hs-boot file
+ ; type_families <- xoptM Opt_TypeFamilies
+ ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
+ ; checkTc type_families $ badFamInstDecl (tcdLName decl)
+ ; checkTc (not is_boot) $ badBootFamInstDeclErr
+
+ -- Perform kind and type checking
+ ; tc <- tcFamInstDecl1 decl
+ ; checkValidTyCon tc -- Remember to check validity;
+ -- no recursion to worry about here
+
+ -- Check that toplevel type instances are not for associated types.
+ ; when (isTopLevel top_lvl && isAssocFamily tc)
+ (addErr $ assocInClassErr (tcdName decl))
+
+ ; return (ATyCon tc) }
+
+isAssocFamily :: TyCon -> Bool -- Is an assocaited type
+isAssocFamily tycon
+ = case tyConFamInst_maybe tycon of
+ Nothing -> panic "isAssocFamily: no family?!?"
+ Just (fam, _) -> isTyConAssoc fam
+
+assocInClassErr :: Name -> SDoc
+assocInClassErr name
+ = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
+ ptext (sLit "must be inside a class instance")
+
+
+
+tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
+
+ -- "type instance"
+tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
+ = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
+ do { -- check that the family declaration is for a synonym
+ checkTc (isFamilyTyCon family) (notFamily family)
+ ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
+
+ ; -- (1) kind check the right-hand side of the type equation
+ ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
+ -- ToDo: the ExpKind could be better
+
+ -- we need the exact same number of type parameters as the family
+ -- declaration
+ ; let famArity = tyConArity family
+ ; checkTc (length k_typats == famArity) $
+ wrongNumberOfParmsErr famArity
+
+ -- (2) type check type equation
+ ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
+ ; t_typats <- mapM tcHsKindedType k_typats
+ ; t_rhs <- tcHsKindedType k_rhs
+
+ -- (3) check the well-formedness of the instance
+ ; checkValidTypeInst t_typats t_rhs
+
+ -- (4) construct representation tycon
+ ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
+ ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs)
+ (typeKind t_rhs)
+ NoParentTyCon (Just (family, t_typats))
+ }}
+
+ -- "newtype instance" and "data instance"
+tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
+ tcdCons = cons})
+ = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon ->
+ do { -- check that the family declaration is for the right kind
+ checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon)
+ ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon)
+
+ ; -- (1) kind check the data declaration as usual
+ ; k_decl <- kcDataDecl decl k_tvs
+ ; 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 (tyConArity fam_tycon)
+
+ -- (2) type check indexed data type declaration
+ ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
+ ; unbox_strict <- doptM Opt_UnboxStrictFields
+
+ -- kind check the type indexes and the context
+ ; t_typats <- mapM tcHsKindedType k_typats
+ ; stupid_theta <- tcHsKindedContext k_ctxt
+
+ -- (3) Check that
+ -- (a) left-hand side contains no type family applications
+ -- (vanilla synonyms are fine, though, and we checked for
+ -- foralls earlier)
+ ; mapM_ checkTyFamFreeness t_typats
+
+ ; dataDeclChecks tc_name new_or_data stupid_theta k_cons
+
+ -- (4) construct representation tycon
+ ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
+ ; let ex_ok = True -- Existentials ok for type families!
+ ; fixM (\ rep_tycon -> do
+ { let orig_res_ty = mkTyConApp fam_tycon t_typats
+ ; data_cons <- tcConDecls unbox_strict ex_ok rep_tycon
+ (t_tvs, orig_res_ty) k_cons
+ ; tc_rhs <-
+ case new_or_data of
+ DataType -> return (mkDataTyConRhs data_cons)
+ NewType -> ASSERT( not (null data_cons) )
+ mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
+ ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
+ False h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
+ -- 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
+ -- dependency. (2) They are always valid loop breakers as
+ -- they involve a coercion.
+ })
+ }}
+ where
+ h98_syntax = case cons of -- All constructors have same shape
+ L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
+ _ -> True
+
+tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d)
+
+-- Kind checking of indexed types
+-- -
+
+-- Kind check type patterns and kind annotate the embedded type variables.
+--
+-- * Here we check that a type instance matches its kind signature, but we do
+-- not check whether there is a pattern for each type index; the latter
+-- check is only required for type synonym instances.
+
+kcIdxTyPats :: TyClDecl Name
+ -> ([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 { let tc_name = tcdLName decl
+ ; fam_tycon <- tcLookupLocatedTyCon tc_name
+ ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon)
+ ; hs_typats = fromJust $ tcdTyPats decl }
+
+ -- we may not have more parameters than the kind indicates
+ ; checkTc (length kinds >= length hs_typats) $
+ tooManyParmsErr (tcdLName decl)
+
+ -- type functions can have a higher-kinded result
+ ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
+ ; typats <- zipWithM kcCheckLHsType hs_typats
+ [ EK kind (EkArg (ppr tc_name) n)
+ | (kind,n) <- kinds `zip` [1..]]
+ ; thing_inside tvs typats resultKind fam_tycon
+ }
\end{code}
addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
do { -- Instantiate the instance decl with skolem constants
; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id)
+ -- We instantiate the dfun_id with superSkolems.
+ -- See Note [Subtle interaction of recursion and overlap]
+ -- and Note [Binding when looking up instances]
; let (clas, inst_tys) = tcSplitDFunHead inst_head
(class_tyvars, sc_theta, _, op_items) = classBigSig clas
sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
listToBag meth_binds)
}
where
- skol_info = InstSkol -- See Note [Subtle interaction of recursion and overlap]
+ skol_info = InstSkol
dfun_ty = idType dfun_id
dfun_id = instanceDFunId ispec
loc = getSrcSpan dfun_id
; return (sc_dict, DFunConstArg (Var sc_dict)) }
where
find _ [] = Nothing
- find i (ev:evs) | pred `tcEqPred` evVarPred ev = Just (ev, i)
- | otherwise = find (i+1) evs
+ find i (ev:evs) | pred `eqPred` evVarPred ev = Just (ev, i)
+ | otherwise = find (i+1) evs
------------------------------
tcSpecInstPrags :: DFunId -> InstBindings Name
inst_tvs = fst (tcSplitForAllTys (idType dfun_id))
Just (init_inst_tys, _) = snocView inst_tys
- rep_ty = fst (coercionKind co) -- [p]
+ rep_ty = pFst (coercionKind co) -- [p]
rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty])
-- co : [p] ~ T p
- co = substTyWith inst_tvs (mkTyVarTys tyvars) $
- case coi of { IdCo ty -> ty ;
- ACo co -> mkSymCoercion co }
+ co = substCoWithTys inst_tvs (mkTyVarTys tyvars) $
+ mkSymCo coi
----------------
tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId)
----------------
mk_op_wrapper :: Id -> EvVar -> HsWrapper
mk_op_wrapper sel_id rep_d
- = WpCast (substTyWith sel_tvs (init_inst_tys ++ [co]) local_meth_ty)
+ = WpCast (liftCoSubstWith sel_tvs (map mkReflCo init_inst_tys ++ [co])
+ local_meth_ty)
<.> WpEvApp (EvId rep_d)
<.> mkWpTyApps (init_inst_tys ++ [rep_ty])
where
, ptext (sLit "Found") <+> quotes (ppr ty)
<+> ptext (sLit "but expected") <+> quotes (ppr instTy)
]
+
+tooManyParmsErr :: Located Name -> SDoc
+tooManyParmsErr tc_name
+ = ptext (sLit "Family instance has too many parameters:") <+>
+ quotes (ppr tc_name)
+
+tooFewParmsErr :: Arity -> SDoc
+tooFewParmsErr arity
+ = ptext (sLit "Family instance has too few parameters; expected") <+>
+ ppr arity
+
+wrongNumberOfParmsErr :: Arity -> SDoc
+wrongNumberOfParmsErr exp_arity
+ = ptext (sLit "Number of parameters must match family declaration; expected")
+ <+> ppr exp_arity
+
+badBootFamInstDeclErr :: SDoc
+badBootFamInstDeclErr
+ = ptext (sLit "Illegal family instance in hs-boot file")
+
+notFamily :: TyCon -> SDoc
+notFamily tycon
+ = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
+ , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
+
+wrongKindOfFamily :: TyCon -> SDoc
+wrongKindOfFamily family
+ = ptext (sLit "Wrong category of family instance; declaration was for a")
+ <+> kindOfFamily
+ where
+ kindOfFamily | isSynTyCon family = ptext (sLit "type synonym")
+ | isAlgTyCon family = ptext (sLit "data type")
+ | otherwise = pprPanic "wrongKindOfFamily" (ppr family)
\end{code}
projects / ghc-hetmet.git / blobdiff