ModDetails(..), GlobalSymbolTable,
HomeSymbolTable, PackageSymbolTable,
- TyThing(..), lookupTypeEnv, lookupFixityEnv,
+ TyThing(..), groupTyThings,
+
+ TypeEnv, extendTypeEnv, lookupTypeEnv,
+
+ lookupFixityEnv,
WhetherHasOrphans, ImportVersion, ExportItem, WhatsImported(..),
PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap,
-- Getting stuff from the environment
TcEnv, initTcEnv,
tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds, tcEnvTyVars,
- getTcGST,
+ getTcGST, getTcGEnv,
-- Instance environment
tcGetInstEnv, tcSetInstEnv,
tcEnvTyVars env = [tv | ATyVar tv <- nameEnvElts (tcLEnv env)]
tcEnvTcIds env = [id | ATcId id <- nameEnvElts (tcLEnv env)]
-getTcGST (TcEnv { tcGST = gst }) = gst
+getTcGST (TcEnv { tcGST = gst }) = gst
+getTcGEnv (TcEnv { tcGEnv = genv }) = genv
-- This data type is used to help tie the knot
-- when type checking type and class declarations
#include "HsVersions.h"
-import CmdLineOpts ( opt_GlasgowExts, opt_AllowUndecidableInstances, opt_D_dump_deriv )
+import CmdLineOpts ( DynFlag(..), dopt )
import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..),
MonoBinds(..), HsExpr(..), HsLit(..), Sig(..),
import HsTypes ( HsType (..), HsTyVarBndr(..), toHsTyVar )
import HsPat ( InPat (..) )
import HsMatches ( Match (..) )
-import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, extractHsTyVars )
+import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl,
+ extractHsTyVars )
import TcHsSyn ( TcMonoBinds, mkHsConApp )
import TcBinds ( tcSpecSigs )
import TcClassDcl ( tcMethodBind, badMethodErr )
import TcMonad
-import RnMonad ( RnNameSupply, FixityEnv )
import Inst ( InstOrigin(..),
newDicts, newClassDicts,
LIE, emptyLIE, plusLIE, plusLIEs )
tcAddImportedIdInfo, tcInstId, tcLookupClass,
newDFunName, tcExtendTyVarEnv
)
-import TcInstUtil ( InstInfo(..), pprInstInfo, classDataCon, simpleInstInfoTyCon, simpleInstInfoTy )
+import TcInstUtil ( InstInfo(..), InstEnv, pprInstInfo, classDataCon,
+ simpleInstInfoTyCon, simpleInstInfoTy, isLocalInst,
+ extendInstEnv )
import TcMonoType ( tcTyVars, tcHsSigType, tcHsType, kcHsSigType )
import TcSimplify ( tcSimplifyAndCheck )
import TcType ( zonkTcSigTyVars )
+import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, DFunId,
+ ModDetails(..) )
import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
foldBag, Bag, listToBag
import Maybes ( maybeToBool, expectJust )
import MkId ( mkDictFunId )
import Generics ( validGenericInstanceType )
-import Module ( Module )
+import Module ( Module, foldModuleEnv )
import Name ( isLocallyDefined )
import NameSet ( emptyNameSet, nameSetToList )
import PrelInfo ( eRROR_ID )
import PprType ( pprConstraint, pprPred )
-import TyCon ( isSynTyCon, tyConDerivings )
+import TyCon ( TyCon, isSynTyCon, tyConDerivings )
import Type ( mkTyVarTys, splitSigmaTy, isTyVarTy,
splitTyConApp_maybe, splitDictTy_maybe,
splitAlgTyConApp_maybe, classesToPreds, classesOfPreds,
import UniqFM ( mapUFM )
import Unique ( Uniquable(..) )
import BasicTypes ( NewOrData(..) )
-import ErrUtils ( dumpIfSet )
+import ErrUtils ( dumpIfSet_dyn )
import ListSetOps ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc,
assocElts, extendAssoc_C,
equivClassesByUniq, minusList
)
-import List ( intersect, (\\) )
+import List ( intersect, (\\), partition )
import Outputable
\end{code}
-> HomeSymbolTable -- Contains instances
-> TcEnv -- Contains IdInfo for dfun ids
-> Module -- Module for deriving
+ -> [TyCon]
-> [RenamedHsDecl]
-> TcM (PersistentCompilerState, InstEnv, [InstInfo], RenamedHsBinds)
-tcInstDecls1 pcs hst unf_env this_mod decls mod
+tcInstDecls1 pcs hst unf_env mod local_tycons decls
= let
inst_decls = [inst_decl | InstD inst_decl <- decls]
- clas_decls = [clas_decl | TyClD clas_decl <- decls, isClassDecl cl_decl]
+ clas_decls = [clas_decl | TyClD clas_decl <- decls, isClassDecl clas_decl]
in
-- (1) Do the ordinary instance declarations
- mapNF_Tc (tcInstDecl1 mod) inst_decls `thenNF_Tc` \ inst_infos ->
+ mapNF_Tc (tcInstDecl1 mod unf_env) inst_decls `thenNF_Tc` \ inst_infos ->
-- (2) Instances from generic class declarations
- getGenericInstances mod clas_decls `thenTc` \ generic_inst_info ->
+ getGenericInstances mod clas_decls `thenTc` \ generic_inst_info ->
- -- Next, consruct the instance environment so far, consisting of
+ -- Next, construct the instance environment so far, consisting of
-- a) cached non-home-package InstEnv (gotten from pcs) pcs_insts pcs
-- b) imported instance decls (not in the home package) inst_env1
-- c) other modules in this package (gotten from hst) inst_env2
-- e) generic instances inst_env4
-- The result of (b) replaces the cached InstEnv in the PCS
let
- (local_inst_info, imported_inst_info) = partition isLocalInst (concat inst_infos)
- generic_inst_info = concat generic_inst_infos -- All local
+ (local_inst_info, imported_inst_info)
+ = partition isLocalInst (concat inst_infos)
- imported_dfuns = map (tcAddImportedIdInfo unf_env . instInfoDFun) imported_inst_info
+ imported_dfuns = map (tcAddImportedIdInfo unf_env . iDFunId)
+ imported_inst_info
hst_dfuns = foldModuleEnv ((++) . md_insts) [] hst
in
addInstDFuns (pcs_insts pcs) imported_dfuns `thenNF_Tc` \ inst_env1 ->
addInstDFuns inst_env1 hst_dfuns `thenNF_Tc` \ inst_env2 ->
addInstInfos inst_env2 local_inst_info `thenNF_Tc` \ inst_env3 ->
addInstInfos inst_env3 generic_inst_info `thenNF_Tc` \ inst_env4 ->
- in
-- (3) Compute instances from "deriving" clauses;
-- note that we only do derivings for things in this module;
-- we ignore deriving decls from interfaces!
-- This stuff computes a context for the derived instance decl, so it
-- needs to know about all the instances possible; hecne inst_env4
- tcDeriving (pcs_PRS pcs) this_mod inst_env4 local_tycons `thenTc` \ (deriv_inst_info, deriv_binds) ->
- addInstInfos inst_env4 deriv_inst_info `thenNF_Tc` \ final_inst_env ->
+ tcDeriving (pcs_PRS pcs) mod inst_env4 local_tycons
+ `thenTc` \ (deriv_inst_info, deriv_binds) ->
+ addInstInfos inst_env4 deriv_inst_info
+ `thenNF_Tc` \ final_inst_env ->
returnTc (pcs { pcs_insts = inst_env1 },
final_inst_env,
deriv_binds)
addInstInfos :: InstEnv -> [InstInfo] -> NF_TcM InstEnv
-addInstInfos inst_env infos = addInstDfuns inst_env (map iDFun infos)
+addInstInfos inst_env infos = addInstDFuns inst_env (map iDFunId infos)
addInstDFuns :: InstEnv -> [DFunId] -> NF_TcM InstEnv
addInstDFuns dfuns infos
- = addErrsTc errs `thenNF_Tc_`
+ = getDOptsTc `thenTc` \ dflags ->
+ extendInstEnv dflags dfuns infos `bind` \ (inst_env', errs) ->
+ addErrsTc errs `thenNF_Tc_`
returnTc inst_env'
where
- (inst_env', errs) = extendInstEnv env dfuns
+ bind x f = f x
+
\end{code}
\begin{code}
\begin{code}
getGenericInstances :: Module -> [RenamedTyClDecl] -> TcM [InstInfo]
getGenericInstances mod class_decls
- = mapTc (get_generics mod) class_decls `thenTc` \ gen_inst_infos ->
+ = mapTc (get_generics mod) class_decls `thenTc` \ gen_inst_infos ->
let
gen_inst_info = concat gen_inst_infos
in
- ioToTc (dumpIfSet opt_D_dump_deriv "Generic instances"
- (vcat (map pprInstInfo gen_inst_info))) `thenNF_Tc_`
+ getDOptsTc `thenTc` \ dflags ->
+ ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
+ (vcat (map pprInstInfo gen_inst_info)))
+ `thenNF_Tc_`
returnTc gen_inst_info
get_generics mod decl@(ClassDecl context class_name tyvar_names
%************************************************************************
\begin{code}
-tcInstDecls2 :: Bag InstInfo
+tcInstDecls2 :: [InstInfo]
-> NF_TcM (LIE, TcMonoBinds)
tcInstDecls2 inst_decls
- = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls
+-- = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls
+ = foldr combine (returnNF_Tc (emptyLIE, EmptyMonoBinds))
+ (map tcInstDecl2 inst_decls)
where
combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
tc2 `thenNF_Tc` \ (lie2, binds2) ->
\begin{code}
scrutiniseInstanceConstraint pred
- | opt_AllowUndecidableInstances
- = returnNF_Tc ()
+ = getDOptsTc `thenTc` \ dflags -> case () of
+ ()
+ | dopt Opt_AllowUndecidableInstances dflags
+ -> returnNF_Tc ()
- | Just (clas,tys) <- getClassTys_maybe pred,
- all isTyVarTy tys
- = returnNF_Tc ()
+ | Just (clas,tys) <- getClassTys_maybe pred,
+ all isTyVarTy tys
+ -> returnNF_Tc ()
- | otherwise
- = addErrTc (instConstraintErr pred)
+ | otherwise
+ -> addErrTc (instConstraintErr pred)
scrutiniseInstanceHead clas inst_taus
- | -- CCALL CHECK
+ = getDOptsTc `thenTc` \ dflags -> case () of
+ ()
+ | -- CCALL CHECK
-- A user declaration of a CCallable/CReturnable instance
-- must be for a "boxed primitive" type.
- (clas `hasKey` cCallableClassKey && not (ccallable_type first_inst_tau)) ||
- (clas `hasKey` cReturnableClassKey && not (creturnable_type first_inst_tau))
- = addErrTc (nonBoxedPrimCCallErr clas first_inst_tau)
+ (clas `hasKey` cCallableClassKey
+ && not (ccallable_type dflags first_inst_tau))
+ ||
+ (clas `hasKey` cReturnableClassKey
+ && not (creturnable_type first_inst_tau))
+ -> addErrTc (nonBoxedPrimCCallErr clas first_inst_tau)
-- DERIVING CHECK
-- It is obviously illegal to have an explicit instance
-- for something that we are also planning to `derive'
- | maybeToBool alg_tycon_app_maybe && clas `elem` (tyConDerivings alg_tycon)
- = addErrTc (derivingWhenInstanceExistsErr clas first_inst_tau)
+ | maybeToBool alg_tycon_app_maybe && clas `elem` (tyConDerivings alg_tycon)
+ -> addErrTc (derivingWhenInstanceExistsErr clas first_inst_tau)
-- Kind check will have ensured inst_taus is of length 1
-- Allow anything for AllowUndecidableInstances
- | opt_AllowUndecidableInstances
- = returnNF_Tc ()
+ | dopt Opt_AllowUndecidableInstances dflags
+ -> returnNF_Tc ()
-- If GlasgowExts then check at least one isn't a type variable
- | opt_GlasgowExts
- = if all isTyVarTy inst_taus then
- addErrTc (instTypeErr clas inst_taus (text "There must be at least one non-type-variable in the instance head"))
- else
- returnNF_Tc ()
+ | dopt Opt_GlasgowExts dflags
+ -> if all isTyVarTy inst_taus
+ then addErrTc (instTypeErr clas inst_taus
+ (text "There must be at least one non-type-variable in the instance head"))
+ else returnNF_Tc ()
-- WITH HASKELL 1.4, MUST HAVE C (T a b c)
- | not (length inst_taus == 1 &&
- maybeToBool maybe_tycon_app && -- Yes, there's a type constuctor
- not (isSynTyCon tycon) && -- ...but not a synonym
- all isTyVarTy arg_tys && -- Applied to type variables
- length (varSetElems (tyVarsOfTypes arg_tys)) == length arg_tys
- -- This last condition checks that all the type variables are distinct
- )
- = addErrTc (instTypeErr clas inst_taus
- (text "the instance type must be of form (T a b c)" $$
- text "where T is not a synonym, and a,b,c are distinct type variables")
- )
-
- | otherwise
- = returnNF_Tc ()
+ | not (length inst_taus == 1 &&
+ maybeToBool maybe_tycon_app && -- Yes, there's a type constuctor
+ not (isSynTyCon tycon) && -- ...but not a synonym
+ all isTyVarTy arg_tys && -- Applied to type variables
+ length (varSetElems (tyVarsOfTypes arg_tys)) == length arg_tys
+ -- This last condition checks that all the type variables are distinct
+ )
+ -> addErrTc (instTypeErr clas inst_taus
+ (text "the instance type must be of form (T a b c)" $$
+ text "where T is not a synonym, and a,b,c are distinct type variables")
+ )
+
+ | otherwise
+ -> returnNF_Tc ()
where
(first_inst_tau : _) = inst_taus
-- The "Alg" part looks through synonyms
Just (alg_tycon, _, _) = alg_tycon_app_maybe
-ccallable_type ty = isFFIArgumentTy False {- Not safe call -} ty
-creturnable_type ty = isFFIResultTy ty
+ ccallable_type dflags ty = isFFIArgumentTy dflags False {- Not safe call -} ty
+ creturnable_type ty = isFFIResultTy ty
\end{code}
-- Instance environment
InstEnv, emptyInstEnv, extendInstEnv,
lookupInstEnv, InstLookupResult(..),
- classInstEnv, classDataCon
+ classInstEnv, classDataCon,
+
+ isLocalInst
) where
#include "HsVersions.h"
#include "HsVersions.h"
-import CmdLineOpts ( opt_D_dump_tc, opt_D_dump_types, opt_PprStyle_Debug )
+import CmdLineOpts ( DynFlag(..), DynFlags, opt_PprStyle_Debug )
import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..) )
import HsTypes ( toHsType )
-import RnHsSyn ( RenamedHsModule )
+import RnHsSyn ( RenamedHsModule, RenamedHsDecl )
import TcHsSyn ( TypecheckedMonoBinds,
TypecheckedForeignDecl, TypecheckedRuleDecl,
zonkTopBinds, zonkForeignExports, zonkRules
import TcBinds ( tcTopBinds )
import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds )
import TcDefaults ( tcDefaults )
-import TcEnv ( tcExtendGlobalValEnv, tcLookupGlobal_maybe,
+import TcEnv ( TcEnv, tcExtendGlobalValEnv, tcLookupGlobal_maybe,
tcEnvTyCons, tcEnvClasses,
- tcSetEnv, tcSetInstEnv, initEnv
+ tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv
)
import TcRules ( tcRules )
import TcForeign ( tcForeignImports, tcForeignExports )
import TcIfaceSig ( tcInterfaceSigs )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
-import TcInstUtil ( InstInfo )
+import TcInstUtil ( InstInfo(..) )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
import TcTyDecls ( mkImplicitDataBinds )
import CoreUnfold ( unfoldingTemplate )
import Type ( funResultTy, splitForAllTys )
-import RnMonad ( RnNameSupply, FixityEnv )
import Bag ( isEmptyBag )
-import ErrUtils ( printErrorsAndWarnings, dumpIfSet )
+import ErrUtils ( printErrorsAndWarnings, dumpIfSet_dyn )
import Id ( idType, idName, idUnfolding )
-import Module ( pprModuleName, mkThisModule, plusModuleEnv )
+import Module ( Module, moduleName, {-mkThisModule,-} plusModuleEnv )
import Name ( nameOccName, isLocallyDefined, isGlobalName,
- toRdrName, nameEnvElts,
+ toRdrName, nameEnvElts, emptyNameEnv
)
import TyCon ( TyCon, isDataTyCon, tyConName, tyConGenInfo )
import OccName ( isSysOcc )
import TyCon ( TyCon, isClassTyCon )
import Class ( Class )
-import PrelNames ( mAIN_Name, mainKey )
+import PrelNames ( mAIN_Name, mainName )
import UniqSupply ( UniqSupply )
import Maybes ( maybeToBool )
import Util
import BasicTypes ( EP(..) )
import Bag ( Bag, isEmptyBag )
-vimport Outputable
-
+import Outputable
+import HscTypes ( PersistentCompilerState(..), HomeSymbolTable,
+ PackageSymbolTable, DFunId,
+ TypeEnv, extendTypeEnv,
+ TyThing(..), groupTyThings )
+import FiniteMap ( FiniteMap, delFromFM, lookupWithDefaultFM )
\end{code}
Outside-world interface:
tc_insts :: [DFunId], -- Instances, just for this module
tc_binds :: TypecheckedMonoBinds,
tc_fords :: [TypecheckedForeignDecl], -- Foreign import & exports.
- tc_rules :: [TypecheckedRuleDecl], -- Transformation rules
+ tc_rules :: [TypecheckedRuleDecl] -- Transformation rules
}
---------------
typecheckModule
- :: PersistentCompilerState
+ :: DynFlags
+ -> PersistentCompilerState
-> HomeSymbolTable
-> RenamedHsModule
- -> IO (Maybe (PersistentCompilerState, TcResults))
-
-typecheckModule pcs hst (HsModule mod_name _ _ _ decls _ src_loc)
- = do { env <- initTcEnv global_symbol_table ;
-
- (_, (maybe_result, msgs)) <- initTc env src_loc tc_module
-
- printErrorsAndWarnings msgs ;
-
- printTcDumps maybe_result ;
-
- if isEmptyBag errs then
- return Nothing
- else
- return result
- }
+ -> IO (Maybe (TcEnv, TcResults))
+
+typecheckModule dflags pcs hst (HsModule mod_name _ _ _ decls _ src_loc)
+ = do env <- initTcEnv global_symbol_table
+ (maybe_result, (errs,warns)) <- initTc dflags env src_loc tc_module
+ printErrorsAndWarnings (errs,warns)
+ printTcDump dflags maybe_result
+ if isEmptyBag errs then
+ return Nothing
+ else
+ return maybe_result
where
- this_mod = mkThisModule
+ this_mod = panic "mkThisModule: unimp" -- WAS: mkThisModule
global_symbol_table = pcs_PST pcs `plusModuleEnv` hst
tc_module = fixTc (\ ~(unf_env ,_) -> tcModule pcs hst this_mod decls unf_env)
-> Module
-> [RenamedHsDecl]
-> TcEnv -- The knot-tied environment
- -> TcM TcResults
+ -> TcM (TcEnv, TcResults)
-- (unf_env :: TcEnv) is used for type-checking interface pragmas
-- which is done lazily [ie failure just drops the pragma
let groups :: FiniteMap Module TypeEnv
- groups = groupTyThings (nameEnvElts (tcGEnv final_env))
+ groups = groupTyThings (nameEnvElts (getTcGEnv final_env))
local_type_env :: TypeEnv
- local_type_env = lookupWithDefaultFM groups this_mod emptyNameEnv
+ local_type_env = lookupWithDefaultFM groups emptyNameEnv this_mod
new_pst :: PackageSymbolTable
new_pst = extendTypeEnv (pcs_PST pcs) (delFromFM groups this_mod)
final_pcs :: PersistentCompilerState
final_pcs = pcs_with_insts {pcs_PST = new_pst}
in
- returnTc (really_final_env,
+ returnTc (final_env, -- WAS: really_final_env,
TcResults { tc_pcs = final_pcs,
tc_env = local_type_env,
tc_binds = all_binds',
- tc_insts = map instInfoDfunId inst_infos,
+ tc_insts = map iDFunId inst_info,
tc_fords = foi_decls ++ foe_decls',
tc_rules = rules'
- }))
+ })
get_binds decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
\end{code}
| otherwise = returnTc ()
noMainErr
- = hsep [ptext SLIT("Module"), quotes (pprModuleName mAIN_Name),
+ = hsep [ptext SLIT("Module"), quotes (ppr mAIN_Name),
ptext SLIT("must include a definition for"), quotes (ptext SLIT("main"))]
\end{code}
%************************************************************************
\begin{code}
-printTcDump Nothing = return ()
-printTcDump (Just results)
- = do { dumpIfSet opt_D_dump_types "Type signatures" (dump_sigs results) ;
- dumpIfSet opt_D_dump_tc "Typechecked" (dump_tc results)
- }
+printTcDump dflags Nothing = return ()
+printTcDump dflags (Just (_,results))
+ = do dumpIfSet_dyn dflags Opt_D_dump_types
+ "Type signatures" (dump_sigs results)
+ dumpIfSet_dyn dflags Opt_D_dump_tc
+ "Typechecked" (dump_tc results)
dump_tc results
= vcat [ppr (tc_binds results),
- pp_rules (tc_rules results),
- ppr_gen_tycons (tc_tycons results)
+ pp_rules (tc_rules results) --,
+-- ppr_gen_tycons (tc_tycons results)
]
dump_sigs results -- Print type signatures
= -- Convert to HsType so that we get source-language style printing
-- And sort by RdrName
vcat $ map ppr_sig $ sortLt lt_sig $
- [(toRdrName id, toHsType (idType id)) | id <- nameEnvElts (tc_env results),
- want_sig id
+ [(toRdrName id, toHsType (idType id))
+ | AnId id <- nameEnvElts (tc_env results),
+ want_sig id
]
where
lt_sig (n1,_) (n2,_) = n1 < n2
import BasicTypes ( RecFlag(..), NewOrData(..) )
import TcMonad
-import TcEnv ( TcEnv, TyThing(..), TyThingDetails(..), tyThingKind,
- tcExtendTypeEnv, tcExtendKindEnv, tcLookupGlobal
- )
+import TcEnv ( TcEnv, TyThing(..), TyThingDetails(..),
+ tcExtendKindEnv, tcLookupGlobal, tcExtendGlobalEnv )
import TcTyDecls ( tcTyDecl1, kcConDetails, mkNewTyConRep )
import TcClassDcl ( tcClassDecl1 )
import TcMonoType ( kcHsTyVars, kcHsType, kcHsBoxedSigType, kcHsContext, mkTyClTyVars )
import Type ( Kind, mkArrowKind, boxedTypeKind, zipFunTys )
import Variance ( calcTyConArgVrcs )
import Class ( Class, mkClass, classTyCon )
-import TyCon ( TyCon, ArgVrcs, AlgTyConFlavour(..), mkSynTyCon, mkAlgTyConRep, mkClassTyCon )
+import TyCon ( TyCon, tyConKind, ArgVrcs, AlgTyConFlavour(..),
+ mkSynTyCon, mkAlgTyConRep, mkClassTyCon )
import DataCon ( isNullaryDataCon )
import Var ( varName )
import FiniteMap
import Unique ( Unique, Uniquable(..) )
import HsDecls ( fromClassDeclNameList )
import Generics ( mkTyConGenInfo )
+import CmdLineOpts ( DynFlags )
\end{code}
\begin{code}
tcGroup :: TcEnv -> SCC RenamedTyClDecl -> TcM TcEnv
tcGroup unf_env scc
- = -- Step 1
+ = getDOptsTc `thenTc` \ dflags ->
+ -- Step 1
mapNF_Tc getInitialKind decls `thenNF_Tc` \ initial_kinds ->
-- Step 2
rec_details = mkNameEnv rec_details_list
tyclss, all_tyclss :: [(Name, TyThing)]
- tyclss = map (buildTyConOrClass is_rec kind_env rec_vrcs rec_details) decls
+ tyclss = map (buildTyConOrClass dflags is_rec kind_env
+ rec_vrcs rec_details) decls
-- Add the tycons that come from the classes
-- We want them in the environment because
\begin{code}
buildTyConOrClass
- :: RecFlag -> NameEnv Kind
+ :: DynFlags
+ -> RecFlag -> NameEnv Kind
-> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
-> RenamedTyClDecl -> (Name, TyThing)
-- Can't fail; the only reason it's in the monad
-- is so it can zonk the kinds
-buildTyConOrClass is_rec kenv rec_vrcs rec_details
+buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
(TySynonym tycon_name tyvar_names rhs src_loc)
= (tycon_name, ATyCon tycon)
where
SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
-buildTyConOrClass is_rec kenv rec_vrcs rec_details
+buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
(TyData data_or_new context tycon_name tyvar_names _ nconstrs _ _ src_loc name1 name2)
= (tycon_name, ATyCon tycon)
where
data_cons nconstrs
derived_classes
flavour is_rec gen_info
- gen_info = mkTyConGenInfo tycon name1 name2
+ gen_info = mkTyConGenInfo dflags tycon name1 name2
DataTyDetails ctxt data_cons derived_classes = lookupNameEnv_NF rec_details tycon_name
DataType | all isNullaryDataCon data_cons -> EnumTyCon
| otherwise -> DataTyCon
-buildTyConOrClass is_rec kenv rec_vrcs rec_details
+buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
(ClassDecl context class_name
tyvar_names fundeps class_sigs def_methods pragmas
name_list src_loc)
) where
-import CmdLineOpts ( opt_Generics )
+import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import RnHsSyn ( RenamedHsExpr )
import HsSyn ( HsExpr(..), InPat(..), mkSimpleMatch )
%************************************************************************
\begin{code}
-mkTyConGenInfo :: TyCon -> Name -> Name -> Maybe (EP Id)
+mkTyConGenInfo :: DynFlags -> TyCon -> Name -> Name -> Maybe (EP Id)
-- mkTyConGenInfo is called twice
-- once from TysWiredIn for Tuples
-- once the typechecker TcTyDecls
-- The two names are the names constructed by the renamer
-- for the fromT and toT conversion functions.
-mkTyConGenInfo tycon from_name to_name
- | not opt_Generics
+mkTyConGenInfo dflags tycon from_name to_name
+ | dopt Opt_Generics dflags
= Nothing
| null datacons -- Abstractly imported types don't have
projects / ghc-hetmet.git / commitdiff