From: sewardj Date: Wed, 18 Oct 2000 12:47:56 +0000 (+0000) Subject: [project @ 2000-10-18 12:47:55 by sewardj] X-Git-Tag: Approximately_9120_patches~3541 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=1b91b7e5adb10bb9d9c6bfe6112f3ef03ab47e31;p=ghc-hetmet.git [project @ 2000-10-18 12:47:55 by sewardj] Finish getting the typechecker to compile. Wahey! --- diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 51126ef..63f80de 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -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, diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index eb65396..63f91ae 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -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 diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 459160d..987d1d5 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -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} diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index ac7615e..083ea79 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -13,7 +13,9 @@ module TcInstUtil ( -- Instance environment InstEnv, emptyInstEnv, extendInstEnv, lookupInstEnv, InstLookupResult(..), - classInstEnv, classDataCon + classInstEnv, classDataCon, + + isLocalInst ) where #include "HsVersions.h" diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 150b266..a26f066 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -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 diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index ae7e4d2..da1ad9f 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -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) diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index 24782a7..674dc3b 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -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 + | dopt Opt_Generics dflags = Nothing | null datacons -- Abstractly imported types don't have