import TcRnMonad
import TcEnv ( TyThing(..),
tcLookupLocated, tcLookupLocatedGlobal,
import TcRnMonad
import TcEnv ( TyThing(..),
tcLookupLocated, tcLookupLocatedGlobal,
- tcExtendGlobalEnv, tcExtendKindEnv, tcExtendKindEnvTvs,
- tcExtendRecEnv, tcLookupTyVar, InstInfo )
+ tcExtendGlobalEnv, tcExtendKindEnv,
+ tcExtendKindEnvTvs, newFamInstTyConName,
+ tcExtendRecEnv, tcLookupTyVar, tcLookupLocatedTyCon )
import TcTyDecls ( calcRecFlags, calcClassCycles, calcSynCycles )
import TcClassDcl ( tcClassSigs, tcAddDeclCtxt )
import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType,
import TcTyDecls ( calcRecFlags, calcClassCycles, calcSynCycles )
import TcClassDcl ( tcClassSigs, tcAddDeclCtxt )
import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType,
mkArrowKind, liftedTypeKind, mkTyVarTys,
tcSplitSigmaTy, tcEqTypes, tcGetTyVar_maybe )
import Type ( PredType(..), splitTyConApp_maybe, mkTyVarTy,
mkArrowKind, liftedTypeKind, mkTyVarTys,
tcSplitSigmaTy, tcEqTypes, tcGetTyVar_maybe )
import Type ( PredType(..), splitTyConApp_maybe, mkTyVarTy,
- newTyConInstRhs, isLiftedTypeKind, Kind
+ newTyConInstRhs, isLiftedTypeKind, Kind,
+ splitKindFunTys, mkArrowKinds
-- pprParendType, pprThetaArrow
)
import Generics ( validGenericMethodType, canDoGenerics )
-- pprParendType, pprThetaArrow
)
import Generics ( validGenericMethodType, canDoGenerics )
import Unify ( tcMatchTys, tcMatchTyX )
import Util ( zipLazy, isSingleton, notNull, sortLe )
import List ( partition, elemIndex )
import Unify ( tcMatchTys, tcMatchTyX )
import Util ( zipLazy, isSingleton, notNull, sortLe )
import List ( partition, elemIndex )
-import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan )
+import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan,
+ srcSpanStart )
import ListSetOps ( equivClasses, minusList )
import Digraph ( SCC(..) )
import DynFlags ( DynFlag( Opt_GlasgowExts, Opt_Generics,
import ListSetOps ( equivClasses, minusList )
import Digraph ( SCC(..) )
import DynFlags ( DynFlag( Opt_GlasgowExts, Opt_Generics,
-- Add the implicit things;
-- we want them in the environment because
-- they may be mentioned in interface files
-- 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
}}
where
; let { implicit_things = concatMap implicitTyThings alg_tyclss }
; traceTc ((text "Adding" <+> ppr alg_tyclss)
$$ (text "and" <+> ppr implicit_things))
; tcExtendGlobalEnv implicit_things getGblEnv
}}
where
+ -- Pull associated types out of class declarations, to tie them into the
+ -- knot above.
+ -- NB: We put them in the same place in the list as `tcTyClDecl' will
+ -- eventually put the matching `TyThing's. That's crucial; otherwise,
+ -- the two argument lists of `mkGlobalThings' don't match up.
tcIdxTyInstDecl (L loc decl)
= -- Prime error recovery, set source location
tcIdxTyInstDecl (L loc decl)
= -- Prime error recovery, set source location
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; checkTc gla_exts $ badIdxTyDecl (tcdLName decl)
; checkTc (not is_boot) $ badBootTyIdxDeclErr
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; checkTc gla_exts $ badIdxTyDecl (tcdLName decl)
; checkTc (not is_boot) $ badBootTyIdxDeclErr
- NewType ->
- ASSERT( isSingleton data_cons )
- mkNewTyConRhs tc_name tycon (head data_cons)
- ; buildAlgTyCon tc_name t_tvs stupid_theta tc_rhs Recursive
+ NewType -> ASSERT( isSingleton data_cons )
+ mkNewTyConRhs 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
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
- do { tc_ty_thing <- tcLookupLocated (tcdLName decl)
- ; let { family = case tc_ty_thing of
- AGlobal (ATyCon family) -> family
- ; (kinds, resKind) = splitKindFunTys (tyConKind family)
+ do { family <- tcLookupLocatedTyCon (tcdLName decl)
+ ; let { (kinds, resKind) = splitKindFunTys (tyConKind family)
(TyFunction {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = kind})
= tcTyVarBndrs tvs $ \ tvs' -> do
{ traceTc (text "type family: " <+> ppr tc_name)
(TyFunction {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = kind})
= tcTyVarBndrs tvs $ \ tvs' -> do
{ traceTc (text "type family: " <+> ppr tc_name)
-- Check that we don't use kind signatures without Glasgow extensions
; checkTc gla_exts $ badSigTyDecl tc_name
-- Check that we don't use kind signatures without Glasgow extensions
; checkTc gla_exts $ badSigTyDecl tc_name
; let final_tvs = tvs' ++ extra_tvs -- we may not need these
; checkTc (null . unLoc $ ctxt) $ badKindSigCtxt tc_name
; let final_tvs = tvs' ++ extra_tvs -- we may not need these
; checkTc (null . unLoc $ ctxt) $ badKindSigCtxt tc_name
-- Check that we don't use kind signatures without Glasgow extensions
; checkTc gla_exts $ badSigTyDecl tc_name
-- Check that we don't use kind signatures without Glasgow extensions
; checkTc gla_exts $ badSigTyDecl tc_name