Commit 88e989a4 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

parents cb269f58 fe0ae8d5
......@@ -1034,7 +1034,9 @@ isPromotableType ty
-- If tc's kind is [ *^n -> * ] returns [ Just n ], else returns [ Nothing ]
isPromotableTyCon :: TyCon -> Maybe Int
isPromotableTyCon tc
| all isLiftedTypeKind (res:args) = Just $ length args
| isDataTyCon tc -- Only *data* types can be promoted, not newtypes
-- not synonyms, not type families
, all isLiftedTypeKind (res:args) = Just $ length args
| otherwise = Nothing
where
(args, res) = splitKindFunTys (tyConKind tc)
......
......@@ -471,8 +471,10 @@ data HsTyDefn name -- The payload of a type synonym or data type defn
td_kindSig:: Maybe (LHsKind name),
-- ^ Optional kind signature.
--
-- @(Just k)@ for a GADT-style @data@, or @data
-- instance@ decl with explicit kind sig
-- @(Just k)@ for a GADT-style @data@,
-- or @data instance@ decl, with explicit kind sig
--
-- Always @Nothing@ for H98-syntax decls
td_cons :: [LConDecl name],
-- ^ Data constructors
......
......@@ -2134,6 +2134,7 @@ impliedFlags
, (Opt_TypeFamilies, turnOn, Opt_MonoLocalBinds)
, (Opt_TypeFamilies, turnOn, Opt_KindSignatures) -- Type families use kind signatures
, (Opt_PolyKinds, turnOn, Opt_KindSignatures) -- Ditto polmorphic kinds
-- We turn this on so that we can export associated type
-- type synonyms in subordinates (e.g. MyClass(type AssocType))
......
......@@ -73,6 +73,7 @@ import MonadUtils
import System.Directory
import Data.Dynamic
import Data.Either
import Data.List (find)
import Control.Monad
#if __GLASGOW_HASKELL__ >= 701
......@@ -813,20 +814,29 @@ fromListBL bound l = BL (length l) bound l []
setContext :: GhcMonad m => [InteractiveImport] -> m ()
setContext imports
= do { hsc_env <- getSession
; all_env <- liftIO $ findGlobalRdrEnv hsc_env imports
; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports
; case all_env_err of
Left (mod, err) -> ghcError (formatError mod err)
Right all_env -> do {
; let old_ic = hsc_IC hsc_env
final_rdr_env = ic_tythings old_ic `icPlusGblRdrEnv` all_env
; modifySession $ \_ ->
hsc_env{ hsc_IC = old_ic { ic_imports = imports
, ic_rn_gbl_env = final_rdr_env }}}
, ic_rn_gbl_env = final_rdr_env }}}}
where
formatError mod err = ProgramError . showSDoc $
text "Cannot add module" <+> ppr mod <+>
text "to context:" <+> text err
findGlobalRdrEnv :: HscEnv -> [InteractiveImport] -> IO GlobalRdrEnv
findGlobalRdrEnv :: HscEnv -> [InteractiveImport]
-> IO (Either (ModuleName, String) GlobalRdrEnv)
-- Compute the GlobalRdrEnv for the interactive context
findGlobalRdrEnv hsc_env imports
= do { idecls_env <- hscRnImportDecls hsc_env idecls
-- This call also loads any orphan modules
; imods_env <- mapM (mkTopLevEnv (hsc_HPT hsc_env)) imods
; return (foldr plusGlobalRdrEnv idecls_env imods_env) }
; return $ case partitionEithers (map mkEnv imods) of
([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env)
(err : _, _) -> Left err }
where
idecls :: [LImportDecl RdrName]
idecls = [noLoc d | IIDecl d <- imports]
......@@ -834,6 +844,10 @@ findGlobalRdrEnv hsc_env imports
imods :: [ModuleName]
imods = [m | IIModule m <- imports]
mkEnv mod = case mkTopLevEnv (hsc_HPT hsc_env) mod of
Left err -> Left (mod, err)
Right env -> Right env
availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
availsToGlobalRdrEnv mod_name avails
= mkGlobalRdrEnv (gresFromAvails imp_prov avails)
......@@ -845,17 +859,14 @@ availsToGlobalRdrEnv mod_name avails
is_qual = False,
is_dloc = srcLocSpan interactiveSrcLoc }
mkTopLevEnv :: HomePackageTable -> ModuleName -> IO GlobalRdrEnv
mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv
mkTopLevEnv hpt modl
= case lookupUFM hpt modl of
Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++
showSDoc (ppr modl)))
Nothing -> Left "not a home module"
Just details ->
case mi_globals (hm_iface details) of
Nothing ->
ghcError (ProgramError ("mkTopLevEnv: not interpreted "
++ showSDoc (ppr modl)))
Just env -> return env
Nothing -> Left "not interpreted"
Just env -> Right env
-- | Get the interactive evaluation context, consisting of a pair of the
-- set of modules from which we take the full top-level scope, and the set
......
......@@ -37,7 +37,7 @@ module RnEnv (
extendTyVarEnvFVRn,
checkDupRdrNames, checkShadowedRdrNames,
checkDupNames, checkDupAndShadowedNames,
checkDupNames, checkDupAndShadowedNames, checkTupSize,
addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS,
warnUnusedMatches,
warnUnusedTopBinds, warnUnusedLocalBinds,
......@@ -61,7 +61,8 @@ import NameEnv
import Avail
import Module ( ModuleName, moduleName )
import UniqFM
import DataCon ( dataConFieldLabels )
import DataCon ( dataConFieldLabels, dataConTyCon )
import TyCon ( isTupleTyCon, tyConArity )
import PrelNames ( mkUnboundName, rOOT_MAIN, forall_tv_RDR )
import ErrUtils ( MsgDoc )
import SrcLoc
......@@ -73,6 +74,7 @@ import DynFlags
import FastString
import Control.Monad
import qualified Data.Set as Set
import Constants ( mAX_TUPLE_SIZE )
\end{code}
\begin{code}
......@@ -234,8 +236,18 @@ lookupTopBndrRn_maybe rdr_name
lookupExactOcc :: Name -> RnM Name
-- See Note [Looking up Exact RdrNames]
lookupExactOcc name
| Just thing <- wiredInNameTyThing_maybe name
, Just tycon <- case thing of
ATyCon tc -> Just tc
ADataCon dc -> Just (dataConTyCon dc)
_ -> Nothing
, isTupleTyCon tycon
= do { checkTupSize (tyConArity tycon)
; return name }
| isExternalName name
= return name
| otherwise
= do { env <- getGlobalRdrEnv
; let -- See Note [Splicing Exact names]
......@@ -1649,6 +1661,15 @@ opDeclErr :: RdrName -> SDoc
opDeclErr n
= hang (ptext (sLit "Illegal declaration of a type or class operator") <+> quotes (ppr n))
2 (ptext (sLit "Use -XTypeOperators to declare operators in type and declarations"))
checkTupSize :: Int -> RnM ()
checkTupSize tup_size
| tup_size <= mAX_TUPLE_SIZE
= return ()
| otherwise
= addErr (sep [ptext (sLit "A") <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"),
nest 2 (parens (ptext (sLit "max size is") <+> int mAX_TUPLE_SIZE)),
nest 2 (ptext (sLit "Workaround: use nested tuples or define a data type"))])
\end{code}
......
......@@ -50,7 +50,6 @@ import RnEnv
import RnTypes
import DynFlags
import PrelNames
import Constants ( mAX_TUPLE_SIZE )
import Name
import NameSet
import RdrName
......@@ -626,15 +625,6 @@ rnOverLit lit@(OverLit {ol_val=val})
%************************************************************************
\begin{code}
checkTupSize :: Int -> RnM ()
checkTupSize tup_size
| tup_size <= mAX_TUPLE_SIZE
= return ()
| otherwise
= addErr (sep [ptext (sLit "A") <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"),
nest 2 (parens (ptext (sLit "max size is") <+> int mAX_TUPLE_SIZE)),
nest 2 (ptext (sLit "Workaround: use nested tuples or define a data type"))])
patSigErr :: Outputable a => a -> SDoc
patSigErr ty
= (ptext (sLit "Illegal signature in pattern:") <+> ppr ty)
......
......@@ -1210,8 +1210,7 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
ATcId { tct_closed = cl } -> isTopLevel cl -- This is the key line
ATyVar {} -> False -- In-scope type variables
AGlobal {} -> True -- are not closed!
AThing {} -> pprPanic "is_closed_id" (ppr name)
ANothing {} -> pprPanic "is_closed_id" (ppr name)
_ -> pprPanic "is_closed_id" (ppr name)
| otherwise
= WARN( isInternalName name, ppr name ) True
-- The free-var set for a top level binding mentions
......
......@@ -15,7 +15,6 @@ Typechecking class declarations
module TcClassDcl ( tcClassSigs, tcClassDecl2,
findMethodBind, instantiateMethod, tcInstanceMethodBody,
mkGenericDefMethBind,
HsSigFun, mkHsSigFun, lookupHsSig, emptyHsSigs,
tcAddDeclCtxt, badMethodErr
) where
......@@ -41,8 +40,6 @@ import NameEnv
import NameSet
import Var
import Outputable
import DynFlags
import ErrUtils
import SrcLoc
import Maybes
import BasicTypes
......@@ -348,52 +345,6 @@ and wrap it in a let, thus
This makes the error messages right.
%************************************************************************
%* *
Extracting generic instance declaration from class declarations
%* *
%************************************************************************
@getGenericInstances@ extracts the generic instance declarations from a class
declaration. For exmaple
class C a where
op :: a -> a
op{ x+y } (Inl v) = ...
op{ x+y } (Inr v) = ...
op{ x*y } (v :*: w) = ...
op{ 1 } Unit = ...
gives rise to the instance declarations
instance C (x+y) where
op (Inl v) = ...
op (Inr v) = ...
instance C (x*y) where
op (v :*: w) = ...
instance C 1 where
op Unit = ...
\begin{code}
mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
mkGenericDefMethBind clas inst_tys sel_id dm_name
= -- A generic default method
-- If the method is defined generically, we only have to call the
-- dm_name.
do { dflags <- getDynFlags
; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
(vcat [ppr clas <+> ppr inst_tys,
nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
; return (noLoc $ mkTopFunBind (noLoc (idName sel_id))
[mkSimpleMatch [] rhs]) }
where
rhs = nlHsVar dm_name
\end{code}
%************************************************************************
%* *
Error messages
......
......@@ -24,13 +24,13 @@ module TcHsType (
-- Kind-checking types
-- No kind generalisation, no checkValidType
tcHsTyVarBndrs,
tcHsLiftedType,
kcHsTyVarBndrs, tcHsTyVarBndrs,
tcHsLiftedType, tcHsOpenType,
tcLHsType, tcCheckLHsType,
tcHsContext, tcInferApps, tcHsArgTys,
ExpKind(..), ekConstraint, expArgKind, checkExpectedKind,
kindGeneralize,
bindScopedKindVars, kindGeneralize,
-- Sort-checking kinds
tcLHsKind,
......@@ -579,12 +579,16 @@ tcTyVar name -- Could be a tyvar, a tycon, or a datacon
ty = dataConUserType dc
tc = buildPromotedDataCon dc
ANothing -> failWithTc (ptext (sLit "Promoted kind") <+>
quotes (ppr name) <+>
ptext (sLit "used in a mutually recursive group"))
AFamDataCon -> bad_promote (ptext (sLit "it comes from a data family instance"))
ARecDataCon -> bad_promote (ptext (sLit "it is defined and used in the same recursive group"))
_ -> wrongThingErr "type" thing name }
where
bad_promote reason
= failWithTc (hang (ptext (sLit "You can't use data constructor") <+> quotes (ppr name)
<+> ptext (sLit "here"))
2 (parens reason))
get_loopy_tc name
= do { env <- getGblEnv
; case lookupNameEnv (tcg_type_env env) name of
......@@ -785,19 +789,42 @@ then we'd also need
since we only have BOX for a super kind)
\begin{code}
bindScopedKindVars :: [Name] -> TcM a -> TcM a
bindScopedKindVars :: [Name] -> ([KindVar] -> TcM a) -> TcM a
-- Given some tyvar binders like [a (b :: k -> *) (c :: k)]
-- bind each scoped kind variable (k in this case) to a fresh
-- kind skolem variable
bindScopedKindVars kvs thing_inside
= tcExtendTyVarEnv (map mkKindSigVar kvs) thing_inside
bindScopedKindVars kv_ns thing_inside
= tcExtendTyVarEnv kvs (thing_inside kvs)
where
kvs = map mkKindSigVar kv_ns
kcHsTyVarBndrs :: Bool -- Default UserTyVar to *
-> LHsTyVarBndrs Name
-> ([TcKind] -> TcM r)
-> TcM r
kcHsTyVarBndrs default_to_star (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside
= bindScopedKindVars kvs $ \ _ ->
do { nks <- mapM (kc_hs_tv . unLoc) hs_tvs
; tcExtendKindEnv nks (thing_inside (map snd nks)) }
where
kc_hs_tv :: HsTyVarBndr Name -> TcM (Name, TcKind)
kc_hs_tv (UserTyVar n)
= do { mb_thing <- tcLookupLcl_maybe n
; kind <- case mb_thing of
Just (AThing k) -> return k
_ | default_to_star -> return liftedTypeKind
| otherwise -> newMetaKindVar
; return (n, kind) }
kc_hs_tv (KindedTyVar n k)
= do { kind <- tcLHsKind k
; return (n, kind) }
tcHsTyVarBndrs :: LHsTyVarBndrs Name
-> ([TyVar] -> TcM r)
-> TcM r
-- Bind the type variables to skolems, each with a meta-kind variable kind
tcHsTyVarBndrs (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside
= bindScopedKindVars kvs $
= bindScopedKindVars kvs $ \ _ ->
do { tvs <- mapM tcHsTyVarBndr hs_tvs
; traceTc "tcHsTyVarBndrs" (ppr hs_tvs $$ ppr tvs)
; tcExtendTyVarEnv tvs (thing_inside tvs) }
......@@ -906,7 +933,7 @@ kcTyClTyVars :: Name -> LHsTyVarBndrs Name -> (TcKind -> TcM a) -> TcM a
-- Used for the type variables of a type or class decl,
-- when doing the initial kind-check.
kcTyClTyVars name (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside
= bindScopedKindVars kvs $
= bindScopedKindVars kvs $ \ _ ->
do { tc_kind <- kcLookupKind name
; let (arg_ks, res_k) = splitKindFunTysN (length hs_tvs) tc_kind
-- There should be enough arrows, because
......@@ -1356,7 +1383,6 @@ tc_kind_var_app name arg_kis
= do { (_errs, mb_thing) <- tryTc (tcLookup name)
; case mb_thing of
Just (AGlobal (ATyCon tc))
| isAlgTyCon tc || isTupleTyCon tc
-> do { data_kinds <- xoptM Opt_DataKinds
; unless data_kinds $ addErr (dataKindsErr name)
; case isPromotableTyCon tc of
......
......@@ -19,8 +19,12 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
import HsSyn
import TcBinds
import TcTyClsDecls
import TcClassDcl
import TcTyClsDecls( tcAddImplicits, tcAddFamInstCtxt, tcSynFamInstDecl,
wrongKindOfFamily, tcFamTyPats, kcTyDefn, dataDeclChecks,
tcConDecls, checkValidTyCon, badATErr, wrongATArgErr )
import TcClassDcl( tcClassDecl2,
HsSigFun, lookupHsSig, mkHsSigFun, emptyHsSigs,
findMethodBind, instantiateMethod, tcInstanceMethodBody )
import TcPat ( addInlinePrags )
import TcRnMonad
import TcMType
......@@ -51,15 +55,14 @@ import PrelNames ( typeableClassNames )
import Bag
import BasicTypes
import DynFlags
import ErrUtils
import FastString
import Id
import MkId
import Name
import NameSet
import NameEnv
import Outputable
import SrcLoc
import Digraph( SCC(..) )
import Util
import Control.Monad
......@@ -373,8 +376,12 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
-- round)
-- Do class and family instance declarations
; (gbl_env, local_infos) <- tcLocalInstDecls (calcInstDeclCycles inst_decls)
; setGblEnv gbl_env $
; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls
; let (local_infos_s, fam_insts_s) = unzip stuff
local_infos = concat local_infos_s
fam_insts = concat fam_insts_s
; addClsInsts local_infos $
addFamInsts fam_insts $
do { -- Compute instances from "deriving" clauses;
-- This stuff computes a context for the derived instance
......@@ -389,7 +396,8 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
; th_stage <- getStage -- See Note [Deriving inside TH brackets ]
; (gbl_env, deriv_inst_info, deriv_binds)
<- if isBrackStage th_stage
then return (gbl_env, emptyBag, emptyValBindsOut)
then do { gbl_env <- getGblEnv
; return (gbl_env, emptyBag, emptyValBindsOut) }
else tcDeriving tycl_decls inst_decls deriv_decls
......@@ -414,20 +422,6 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe"
++ " Haskell! Can only derive them"
tcLocalInstDecls :: [SCC (LInstDecl Name)] -> TcM (TcGblEnv, [InstInfo Name])
tcLocalInstDecls []
= do { gbl_env <- getGblEnv
; return (gbl_env, []) }
tcLocalInstDecls (AcyclicSCC inst_decl : sccs)
= do { (inst_infos, fam_insts) <- recoverM (return ([], [])) $
tcLocalInstDecl inst_decl
; (gbl_env, more_infos) <- addClsInsts inst_infos $
addFamInsts fam_insts $
tcLocalInstDecls sccs
; return (gbl_env, inst_infos ++ more_infos) }
tcLocalInstDecls (CyclicSCC inst_decls : _)
= do { cyclicDeclErr inst_decls; failM }
addClsInsts :: [InstInfo Name] -> TcM a -> TcM a
addClsInsts infos thing_inside
= tcExtendLocalInstEnv (map iSpec infos) thing_inside
......@@ -464,59 +458,6 @@ bindings.) This will become moot when we shift to the new TH plan, so
the brutal solution will do.
Note [Instance declaration cycles]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
With -XDataKinds we can get this
data instance Foo [a] = MkFoo (MkFoo a)
where the constructor MkFoo is used in a type before it is
defined. Here is a more complicated situation, involving an
associated type and mutual recursion
data instance T [a] = MkT (MkS a)
instance C [a] where
data S [a] = MkS (MkT a)
When type checking ordinary data type decls we detect this staging
problem in the kind-inference phase, but there *is* no kind inference
phase here.
So intead we extract the strongly connected components and look for
cycles.
\begin{code}
calcInstDeclCycles :: [LInstDecl Name] -> [SCC (LInstDecl Name)]
-- see Note [Instance declaration cycles]
calcInstDeclCycles decls
= depAnal get_defs get_uses decls
where
-- get_defs extracts the *constructor* bindings of the declaration
get_defs :: LInstDecl Name -> [Name]
get_defs (L _ (FamInstD { lid_inst = fid })) = get_fi_defs fid
get_defs (L _ (ClsInstD { cid_fam_insts = fids })) = concatMap (get_fi_defs . unLoc) fids
get_fi_defs :: FamInstDecl Name -> [Name]
get_fi_defs (FamInstDecl { fid_defn = TyData { td_cons = cons } })
= map (unLoc . con_name . unLoc) cons
get_fi_defs (FamInstDecl {}) = []
-- get_uses extracts the *tycon or constructor* uses of the declaration
get_uses :: LInstDecl Name -> [Name]
get_uses (L _ (FamInstD { lid_inst = fid })) = nameSetToList (fid_fvs fid)
get_uses (L _ (ClsInstD { cid_fam_insts = fids }))
= nameSetToList (foldr (unionNameSets . fid_fvs . unLoc) emptyNameSet fids)
cyclicDeclErr :: Outputable d => [Located d] -> TcRn ()
cyclicDeclErr inst_decls
= setSrcSpan (getLoc (head sorted_decls)) $
addErr (sep [ptext (sLit "Cycle in type declarations: data constructor used (in a type) before it is defined"),
nest 2 (vcat (map ppr_decl sorted_decls))])
where
sorted_decls = sortLocated inst_decls
ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl
\end{code}
\begin{code}
tcLocalInstDecl :: LInstDecl Name
-> TcM ([InstInfo Name], [FamInst])
......@@ -878,7 +819,6 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
loc = getSrcSpan dfun_id
------------------------------
----------------------
mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar]
-> [TcType] -> Id -> TcM (TcId, TcSigInfo)
mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id
......@@ -1275,6 +1215,22 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
(_, local_meth_ty) = tcSplitPredFunTy_maybe sel_rho
`orElse` pprPanic "tcInstanceMethods" (ppr sel_id)
------------------
mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
mkGenericDefMethBind clas inst_tys sel_id dm_name
= -- A generic default method
-- If the method is defined generically, we only have to call the
-- dm_name.
do { dflags <- getDynFlags
; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
(vcat [ppr clas <+> ppr inst_tys,
nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
; return (noLoc $ mkTopFunBind (noLoc (idName sel_id))
[mkSimpleMatch [] rhs]) }
where
rhs = nlHsVar dm_name
----------------------
wrapId :: HsWrapper -> id -> HsExpr id
wrapId wrapper id = mkHsWrap wrapper (HsVar id)
......
......@@ -773,7 +773,7 @@ zonkTcType ty
| otherwise = TyVarTy <$> updateTyVarKindM go tyvar
-- Ordinary (non Tc) tyvars occur inside quantified types
go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar ) do
go (ForAllTy tyvar ty) = ASSERT2( isImmutableTyVar tyvar, ppr tyvar ) do
ty' <- go ty
tyvar' <- updateTyVarKindM go tyvar
return (ForAllTy tyvar' ty')
......
......@@ -551,17 +551,10 @@ tcRnHsBootDecls decls
; mapM_ (badBootDecl "rule") rule_decls
; mapM_ (badBootDecl "vect") vect_decls
-- Typecheck type/class decls
-- Typecheck type/class/isntance decls
; traceTc "Tc2 (boot)" empty
; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls
; setGblEnv tcg_env $ do {
-- Typecheck instance decls
-- Family instance declarations are rejected here
; traceTc "Tc3" empty
; (tcg_env, inst_infos, _deriv_binds)
<- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls
<- tcTyClsInstDecls emptyModDetails tycl_decls inst_decls deriv_decls
; setGblEnv tcg_env $ do {
-- Typecheck value declarations
......@@ -583,7 +576,7 @@ tcRnHsBootDecls decls
}
; setGlobalTypeEnv gbl_env type_env2
}}}
}}
; traceTc "boot" (ppr lie); return gbl_env }
badBootDecl :: String -> Located decl -> TcM ()
......@@ -897,14 +890,11 @@ tcTopSrcDecls boot_details
-- The latter come in via tycl_decls
traceTc "Tc2 (src)" empty ;
tcg_env <- tcTyAndClassDecls boot_details tycl_decls ;
setGblEnv tcg_env $ do {
-- Source-language instances, including derivings,
-- and import the supporting declarations
traceTc "Tc3" empty ;
(tcg_env, inst_infos, deriv_binds)
<- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls;
<- tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls ;
setGblEnv tcg_env $ do {
-- Foreign import declarations next.
......@@ -964,9 +954,55 @@ tcTopSrcDecls boot_details
, tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
return (tcg_env', tcl_env)
}}}}}}}
}}}}}}
---------------------------
tcTyClsInstDecls :: ModDetails
-> [TyClGroup Name]
-> [LInstDecl Name]
-> [LDerivDecl Name]
-> TcM (TcGblEnv, -- The full inst env
[InstInfo Name], -- Source-code instance decls to process;
-- contains all dfuns for this module
HsValBinds Name) -- Supporting bindings for derived instances
tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls
= tcExtendTcTyThingEnv [(con, AFamDataCon) | lid <- inst_decls
, con <- get_cons lid ] $
-- Note [AFamDataCon: not promoting data family constructors]
do { tcg_env <- tcTyAndClassDecls boot_details tycl_decls ;
; setGblEnv tcg_env $
tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls }
where
-- get_cons extracts the *constructor* bindings of the declaration
get_cons :: LInstDecl Name -> [Name]
get_cons (L _ (FamInstD { lid_inst = fid })) = get_fi_cons fid
get_cons (L _ (ClsInstD { cid_fam_insts = fids })) = concatMap (get_fi_cons . unLoc) fids
get_fi_cons :: FamInstDecl Name -> [Name]
get_fi_cons (FamInstDecl { fid_defn = TyData { td_cons = cons } })
= map (unLoc . con_name . unLoc) cons
get_fi_cons (FamInstDecl {}) = []
\end{code}
Note [AFamDataCon: not promoting data family constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
data family T a
data instance T Int = MkT
data Proxy (a :: k)
data S = MkS (Proxy 'MkT)