-tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name]
- -> TcM TcGblEnv -- Input env extended by types and classes
- -- and their implicit Ids,DataCons
-tcTyAndClassDecls boot_details decls
- = do { -- First check for cyclic type synonysm or classes
- -- See notes with checkCycleErrs
- checkCycleErrs decls
- ; mod <- getModule
- ; traceTc (text "tcTyAndCl" <+> ppr mod)
- ; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) ->
- do { let { -- Calculate variances and rec-flag
- ; (syn_decls, alg_decls_pre) = partition (isSynDecl . unLoc) decls
- ; alg_decls = alg_decls_pre ++
- concat [tcdATs decl -- add AT decls
- | declLoc <- alg_decls_pre
- , let decl = unLoc declLoc
- , isClassDecl decl] }
-
- -- Extend the global env with the knot-tied results
- -- for data types and classes
- --
- -- We must populate the environment with the loop-tied T's right
- -- away, because the kind checker may "fault in" some type
- -- constructors that recursively mention T
- ; let { gbl_things = mkGlobalThings alg_decls rec_alg_tyclss }
- ; tcExtendRecEnv gbl_things $ do
-
- -- Kind-check the declarations
- { (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls
-
- ; let { calc_vrcs = calcTyConArgVrcs (rec_syn_tycons ++ rec_alg_tyclss)
- ; calc_rec = calcRecFlags boot_details rec_alg_tyclss
- ; tc_decl = addLocM (tcTyClDecl calc_vrcs calc_rec) }
- -- Type-check the type synonyms, and extend the envt
- ; syn_tycons <- tcSynDecls calc_vrcs kc_syn_decls
- ; tcExtendGlobalEnv syn_tycons $ do
-
- -- Type-check the data types and classes
- { alg_tyclss <- mappM tc_decl kc_alg_decls
- ; return (syn_tycons, alg_tyclss)
- }}})
- -- Finished with knot-tying now
- -- Extend the environment with the finished things
- ; tcExtendGlobalEnv (syn_tycons ++ alg_tyclss) $ do
-
- -- Perform the validity check
- { traceTc (text "ready for validity check")
- ; mappM_ (addLocM checkValidTyCl) decls
- ; traceTc (text "done")
-
- -- Add the implicit things;
- -- we want them in the environment because
- -- they may be mentioned in interface files
- ; let { implicit_things = concatMap implicitTyThings alg_tyclss }
- ; traceTc ((text "Adding" <+> ppr alg_tyclss) $$ (text "and" <+> ppr implicit_things))
- ; tcExtendGlobalEnv implicit_things getGblEnv
- }}
-
-mkGlobalThings :: [LTyClDecl Name] -- The decls
- -> [TyThing] -- Knot-tied, in 1-1 correspondence with the decls
- -> [(Name,TyThing)]
--- Driven by the Decls, and treating the TyThings lazily
--- make a TypeEnv for the new things
-mkGlobalThings decls things
- = map mk_thing (decls `zipLazy` things)
- where
- mk_thing (L _ (ClassDecl {tcdLName = L _ name}), ~(AClass cl))
- = (name, AClass cl)
- mk_thing (L _ decl, ~(ATyCon tc))
- = (tcdName decl, ATyCon tc)
+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
+
+ -- Check that we don't use GADT syntax in H98 world
+ ; gadt_ok <- xoptM Opt_GADTs
+ ; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name)
+
+ -- (b) a newtype has exactly one constructor
+ ; checkTc (new_or_data == DataType || isSingleton k_cons) $
+ newtypeConError tc_name (length 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
+ }