-\begin{code}
-tcFamInstDecl :: LTyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error
-tcFamInstDecl (L loc decl)
- = -- Prime error recovery, set source location
- recoverM (returnM Nothing) $
- setSrcSpan loc $
- tcAddDeclCtxt decl $
- do { -- type families require -ftype-families and can't be in an
- -- hs-boot file
- ; gla_exts <- doptM Opt_TypeFamilies
- ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
- ; checkTc gla_exts $ badFamInstDecl (tcdLName decl)
- ; checkTc (not is_boot) $ badBootFamInstDeclErr
-
- -- perform kind and type checking
- ; tcFamInstDecl1 decl
- }
-
-tcFamInstDecl1 :: TyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error
-
- -- "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
- unless (isSynTyCon family) $
- addErr (wrongKindOfFamily family)
-
- ; -- (1) kind check the right-hand side of the type equation
- ; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind
-
- -- (2) type check type equation
- ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
- ; t_typats <- mappM tcHsKindedType k_typats
- ; t_rhs <- tcHsKindedType k_rhs
-
- -- (3) check that
- -- - left-hand side contains no type family applications
- -- (vanilla synonyms are fine, though)
- ; mappM_ checkTyFamFreeness t_typats
-
- -- - the right-hand side is a tau type
- ; unless (isTauTy t_rhs) $
- addErr (polyTyErr t_rhs)
-
- -- (4) construct representation tycon
- ; rep_tc_name <- newFamInstTyConName tc_name loc
- ; tycon <- buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs)
- (Just (family, t_typats))
-
- ; return $ Just (ATyCon tycon)
- }}
-
- -- "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 family ->
- do { -- check that the family declaration is for the right kind
- unless (isAlgTyCon family) $
- addErr (wrongKindOfFamily family)
-
- ; -- (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 tc_name
-
- -- (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 <- mappM tcHsKindedType k_typats
- ; stupid_theta <- tcHsKindedContext k_ctxt
-
- -- (3) Check that
- -- - left-hand side contains no type family applications
- -- (vanilla synonyms are fine, though)
- ; mappM_ checkTyFamFreeness t_typats
-
- -- - we don't use GADT syntax for indexed types
- ; checkTc h98_syntax (badGadtIdxTyDecl tc_name)
-
- -- - 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 loc
- ; tycon <- fixM (\ tycon -> do
- { data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon t_tvs))
- k_cons
- ; tc_rhs <-
- case new_or_data of
- DataType -> return (mkDataTyConRhs data_cons)
- NewType -> ASSERT( isSingleton data_cons )
- mkNewTyConRhs rep_tc_name tycon (head data_cons)
- ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
- False h98_syntax (Just (family, 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.
- })
-
- -- construct result
- ; return $ Just (ATyCon tycon)
- }}
- where
- h98_syntax = case cons of -- All constructors have same shape
- L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
- other -> True
-
--- Check that a type index does not contain any type family applications
---
--- * Earlier phases have already checked that there are no foralls in the
--- type; we also cannot have PredTys and NoteTys are being skipped by using
--- the core view.
---
-checkTyFamFreeness :: Type -> TcM ()
-checkTyFamFreeness ty | Just (tycon, tys) <- splitTyConApp_maybe ty
- = if isSynTyCon tycon
- then addErr $ tyFamAppInIndexErr ty
- else mappM_ checkTyFamFreeness tys
- -- splitTyConApp_maybe uses the core view; hence,
- -- any synonym tycon must be a family tycon
-
- | Just (ty1, ty2) <- splitAppTy_maybe ty
- = checkTyFamFreeness ty1 >> checkTyFamFreeness ty2
-
- | otherwise -- only vars remaining
- = return ()