Commit 1b91b7e5 authored by sewardj's avatar sewardj
Browse files

[project @ 2000-10-18 12:47:55 by sewardj]

Finish getting the typechecker to compile.  Wahey!
parent a3113e20
......@@ -8,7 +8,11 @@ module HscTypes (
ModDetails(..), GlobalSymbolTable,
HomeSymbolTable, PackageSymbolTable,
TyThing(..), lookupTypeEnv, lookupFixityEnv,
TyThing(..), groupTyThings,
TypeEnv, extendTypeEnv, lookupTypeEnv,
lookupFixityEnv,
WhetherHasOrphans, ImportVersion, ExportItem, WhatsImported(..),
PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap,
......
......@@ -6,7 +6,7 @@ module TcEnv(
-- Getting stuff from the environment
TcEnv, initTcEnv,
tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds, tcEnvTyVars,
getTcGST,
getTcGST, getTcGEnv,
-- Instance environment
tcGetInstEnv, tcSetInstEnv,
......@@ -160,7 +160,8 @@ tcEnvIds env = [id | AnId id <- nameEnvElts (tcGEnv env)]
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
......
......@@ -9,7 +9,7 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2, tcAddDeclCtxt ) where
#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(..),
......@@ -18,12 +18,12 @@ import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..),
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 )
......@@ -33,10 +33,14 @@ import TcEnv ( TcEnv, tcExtendGlobalValEnv,
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
......@@ -46,12 +50,12 @@ import Var ( idName, idType )
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,
......@@ -71,12 +75,12 @@ import VarSet ( varSetElems )
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}
......@@ -167,21 +171,22 @@ tcInstDecls1 :: PersistentCompilerState
-> 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
......@@ -189,25 +194,27 @@ tcInstDecls1 pcs hst unf_env this_mod decls mod
-- 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,
......@@ -215,14 +222,17 @@ tcInstDecls1 pcs hst unf_env this_mod decls mod
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}
......@@ -302,12 +312,14 @@ gives rise to the instance declarations
\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
......@@ -411,11 +423,13 @@ mkGenericInstance mod clas loc (hs_ty, binds)
%************************************************************************
\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) ->
......@@ -672,57 +686,64 @@ We can also have instances for functions: @instance Foo (a -> b) ...@.
\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
......@@ -736,8 +757,8 @@ scrutiniseInstanceHead clas 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}
......
......@@ -13,7 +13,9 @@ module TcInstUtil (
-- Instance environment
InstEnv, emptyInstEnv, extendInstEnv,
lookupInstEnv, InstLookupResult(..),
classInstEnv, classDataCon
classInstEnv, classDataCon,
isLocalInst
) where
#include "HsVersions.h"
......
......@@ -11,10 +11,10 @@ module TcModule (
#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
......@@ -25,41 +25,44 @@ import Inst ( emptyLIE, plusLIE )
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:
......@@ -74,32 +77,28 @@ data TcResults
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)
......@@ -112,7 +111,7 @@ tcModule :: PersistentCompilerState
-> 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
......@@ -231,10 +230,10 @@ tcModule pcs hst this_mod decls unf_env
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)
......@@ -242,14 +241,14 @@ tcModule pcs hst this_mod decls unf_env
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}
......@@ -267,7 +266,7 @@ checkMain this_mod
| 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}
......@@ -279,24 +278,26 @@ noMainErr
%************************************************************************
\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
......
......@@ -20,9 +20,8 @@ import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name )
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 )
......@@ -33,7 +32,8 @@ import TcInstDcls ( tcAddDeclCtxt )
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
......@@ -49,6 +49,7 @@ import ErrUtils ( Message )
import Unique ( Unique, Uniquable(..) )
import HsDecls ( fromClassDeclNameList )
import Generics ( mkTyConGenInfo )
import CmdLineOpts ( DynFlags )
\end{code}
......@@ -113,7 +114,8 @@ The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
\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
......@@ -130,7 +132,8 @@ tcGroup unf_env scc
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
......@@ -270,13 +273,14 @@ kcTyClDeclBody tc_name hs_tyvars thing_inside
\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
......@@ -287,7 +291,7 @@ buildTyConOrClass is_rec kenv rec_vrcs rec_details
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
......@@ -295,7 +299,7 @@ buildTyConOrClass is_rec kenv rec_vrcs rec_details
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
......@@ -308,7 +312,7 @@ buildTyConOrClass is_rec kenv rec_vrcs rec_details
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)
......
......@@ -4,7 +4,7 @@ module Generics ( mkTyConGenInfo, mkGenericRhs,
) where
import CmdLineOpts ( opt_Generics )
import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import RnHsSyn ( RenamedHsExpr )
import HsSyn ( HsExpr(..), InPat(..), mkSimpleMatch )
......@@ -219,7 +219,7 @@ valid ty
%************************************************************************
\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
......@@ -230,8 +230,8 @@ mkTyConGenInfo :: TyCon -> Name -> Name -> Maybe (EP Id)
-- 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