X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=016e405819784cc3ea29b72bfc37a80af345aceb;hb=c2527e8dea810f1584609ad20408a38691131d28;hp=d0e45d502e64a2ca527ede8b093113e9a8527b99;hpb=f714e6b642fd614a9971717045ae47c3d871275e;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index d0e45d5..016e405 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -6,7 +6,8 @@ \begin{code} module TcRnDriver ( #ifdef GHCI - mkExportEnv, getModuleContents, tcRnStmt, tcRnThing, tcRnExpr, + mkExportEnv, getModuleContents, tcRnStmt, + tcRnThing, tcRnExpr, tcRnType, #endif tcRnModule, tcTopSrcDecls, @@ -21,7 +22,8 @@ import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt ) import DriverState ( v_MainModIs, v_MainFunIs ) -import HsSyn +import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..), + nlHsApp, nlHsVar, pprLHsBinds ) import RdrHsSyn ( findSplice ) import PrelNames ( runIOName, rootMainName, mAIN_Name, @@ -31,11 +33,11 @@ import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv, import TcHsSyn ( zonkTopDecls ) import TcExpr ( tcInferRho ) import TcRnMonad -import TcType ( tidyTopType ) +import TcType ( tidyTopType, isUnLiftedType ) import Inst ( showLIE ) import TcBinds ( tcTopBinds ) import TcDefaults ( tcDefaults ) -import TcEnv ( tcExtendGlobalValEnv, tcLookupGlobal ) +import TcEnv ( tcExtendGlobalValEnv ) import TcRules ( tcRules ) import TcForeign ( tcForeignImports, tcForeignExports ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) @@ -44,68 +46,74 @@ import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) import LoadIface ( loadOrphanModules ) import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail, - reportUnusedNames ) + reportUnusedNames, reportDeprecations ) import RnEnv ( lookupSrcOcc_maybe ) import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec ) import PprCore ( pprIdRules, pprCoreBindings ) import CoreSyn ( IdCoreRule, bindersOfBinds ) -import ErrUtils ( mkDumpDoc, showPass ) +import ErrUtils ( Messages, mkDumpDoc, showPass ) import Id ( mkExportedLocalId, isLocalId, idName, idType ) import Var ( Var ) import Module ( mkHomeModule, mkModuleName, moduleName, moduleEnvElts ) import OccName ( mkVarOcc ) -import Name ( Name, isExternalName, getSrcLoc, getOccName ) +import Name ( Name, isExternalName, getSrcLoc, getOccName, nameSrcLoc ) import NameSet import TyCon ( tyConHasGenerics ) -import SrcLoc ( srcLocSpan, Located(..), noLoc ) +import SrcLoc ( SrcLoc, srcLocSpan, Located(..), noLoc ) import Outputable import HscTypes ( ModGuts(..), HscEnv(..), - GhciMode(..), noDependencies, + GhciMode(..), Dependencies(..), noDependencies, Deprecs( NoDeprecs ), plusDeprecs, - GenAvailInfo(Avail), availsToNameSet, availName, - ForeignStubs(NoStubs), TypeEnv, typeEnvTyCons, + ForeignStubs(NoStubs), TypeEnv, extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, emptyFixityEnv ) #ifdef GHCI -import HsSyn ( HsStmtContext(..), - Stmt(..), - collectStmtsBinders, mkSimpleMatch, placeHolderType ) +import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..), + LStmt, LHsExpr, LHsType, + collectStmtsBinders, mkSimpleMatch, placeHolderType, + nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat ) import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..), Provenance(..), ImportSpec(..), lookupLocalRdrEnv, extendLocalRdrEnv ) import RnSource ( addTcgDUs ) import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs ) +import TcHsType ( kcHsType ) import TcExpr ( tcCheckRho ) import TcMType ( zonkTcType ) import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) ) import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer ) import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType ) -import TcEnv ( tcLookupTyCon, tcLookupId ) -import TyCon ( DataConDetails(..) ) +import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal ) +import RnTypes ( rnLHsType ) import Inst ( tcStdSyntaxName ) import RnExpr ( rnStmts, rnLExpr ) import RnNames ( exportsToAvails ) import LoadIface ( loadSrcInterface ) -import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceExtName(..), +import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), + IfaceExtName(..), IfaceConDecls(..), tyThingToIfaceDecl ) import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn ) -import Id ( Id, isImplicitId ) +import Id ( Id, isImplicitId, globalIdDetails ) +import FieldLabel ( fieldLabelTyCon ) import MkId ( unsafeCoerceId ) +import DataCon ( dataConTyCon ) import TysWiredIn ( mkListTy, unitTy ) import IdInfo ( GlobalIdDetails(..) ) import SrcLoc ( interactiveSrcLoc, unLoc ) -import Var ( setGlobalIdDetails ) +import Kind ( Kind ) +import Var ( globaliseId ) import Name ( nameOccName, nameModuleName ) import NameEnv ( delListFromNameEnv ) import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName ) import Module ( ModuleName, lookupModuleEnvByName ) import HscTypes ( InteractiveContext(..), HomeModInfo(..), typeEnvElts, - TyThing(..), availNames, icPrintUnqual, + TyThing(..), availName, availNames, icPrintUnqual, ModIface(..), ModDetails(..) ) import BasicTypes ( RecFlag(..), Fixity ) import Bag ( unitBag ) +import ListSetOps ( removeDups ) import Panic ( ghcError, GhcException(..) ) #endif @@ -128,7 +136,7 @@ import Maybe ( isJust ) \begin{code} tcRnModule :: HscEnv -> Located (HsModule RdrName) - -> IO (Maybe TcGblEnv) + -> IO (Messages, Maybe TcGblEnv) tcRnModule hsc_env (L loc (HsModule maybe_mod exports import_decls local_decls mod_deprec)) @@ -164,9 +172,17 @@ tcRnModule hsc_env (L loc (HsModule maybe_mod exports traceRn (text "rn3") ; + -- Report the use of any deprecated things + -- We do this before processsing the export list so + -- that we don't bleat about re-exporting a deprecated + -- thing (especially via 'module Foo' export item) + -- Only uses in the body of the module are complained about + reportDeprecations tcg_env ; + -- Process the export list - export_avails <- exportsFromAvail (isJust maybe_mod) exports ; + exports <- exportsFromAvail (isJust maybe_mod) exports ; +{- Jan 04: I don't think this is necessary any more; usage info is derived from tcg_dus -- Get any supporting decls for the exports that have not already -- been sucked in for the declarations in the body of the module. -- (This can happen if something is imported only to be re-exported.) @@ -177,15 +193,15 @@ tcRnModule hsc_env (L loc (HsModule maybe_mod exports -- We don't need the results, but sucking them in may side-effect -- the ExternalPackageState, apart from recording usage mappM (tcLookupGlobal . availName) export_avails ; +-} -- Check whether the entire module is deprecated -- This happens only once per module let { mod_deprecs = checkModDeprec mod_deprec } ; -- Add exports and deprecations to envt - let { export_fvs = availsToNameSet export_avails ; - final_env = tcg_env { tcg_exports = export_avails, - tcg_dus = tcg_dus tcg_env `plusDU` usesOnly export_fvs, + let { final_env = tcg_env { tcg_exports = exports, + tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports, tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs` mod_deprecs } -- A module deprecation over-rides the earlier ones @@ -220,7 +236,7 @@ tcRnStmt :: HscEnv -- a list of the bound values, coerced to (). tcRnStmt hsc_env ictxt rdr_stmt - = initTc hsc_env iNTERACTIVE $ + = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext ictxt $ do { -- Rename; use CmdLineMode because tcRnStmt is only used interactively @@ -237,8 +253,7 @@ tcRnStmt hsc_env ictxt rdr_stmt -- important: otherwise when we come to compile an expression -- using these ids later, the byte code generator will consider -- the occurrences to be free rather than global. - global_ids = map globaliseId bound_ids ; - globaliseId id = setGlobalIdDetails id VanillaGlobal ; + global_ids = map (globaliseId VanillaGlobal) bound_ids ; -- Update the interactive context rn_env = ic_rn_local_env ictxt ; @@ -267,7 +282,7 @@ tcRnStmt hsc_env ictxt rdr_stmt returnM (new_ic, bound_names, tc_expr) } -\end{code} +\end{code} Here is the grand plan, implemented in tcUserStmt @@ -280,10 +295,10 @@ Here is the grand plan, implemented in tcUserStmt pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] bindings: [x,y,...] - expr (of IO type) ==> expr >>= \ v -> return [coerce HVal v] + expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it] [NB: result not printed] bindings: [it] - expr (of non-IO type, ==> let v = expr in print v >> return [coerce HVal v] + expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it] result showable) bindings: [it] expr (of non-IO type, @@ -305,8 +320,8 @@ tcUserStmt (L _ (ExprStmt expr _)) tc_stmts [ nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive], nlExprStmt (nlHsApp (nlHsVar printName) - (nlHsVar fresh_it)) - ] }) + (nlHsVar fresh_it)) + ] }) (do { -- Try this first traceTc (text "tcs 1a") ; tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] }) @@ -378,10 +393,16 @@ tc_stmts stmts zonked_expr <- zonkTopLExpr expr ; zonked_ids <- zonkTopBndrs ids ; + -- None of the Ids should be of unboxed type, because we + -- cast them all to HValues in the end! + mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ; + return (zonked_ids, zonked_expr) } where combine stmt (ids, stmts) = (ids, stmt:stmts) + bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"), + nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) \end{code} @@ -393,7 +414,7 @@ tcRnExpr :: HscEnv -> LHsExpr RdrName -> IO (Maybe Type) tcRnExpr hsc_env ictxt rdr_expr - = initTc hsc_env iNTERACTIVE $ + = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext ictxt $ do { (rn_expr, fvs) <- rnLExpr rdr_expr ; @@ -414,19 +435,40 @@ tcRnExpr hsc_env ictxt rdr_expr smpl_doc = ptext SLIT("main expression") \end{code} +tcRnExpr just finds the kind of a type + +\begin{code} +tcRnType :: HscEnv + -> InteractiveContext + -> LHsType RdrName + -> IO (Maybe Kind) +tcRnType hsc_env ictxt rdr_type + = initTcPrintErrors hsc_env iNTERACTIVE $ + setInteractiveContext ictxt $ do { + + rn_type <- rnLHsType doc rdr_type ; + failIfErrsM ; + + -- Now kind-check the type + (ty', kind) <- kcHsType rn_type ; + return kind + } + where + doc = ptext SLIT("In GHCi input") +\end{code} \begin{code} tcRnThing :: HscEnv -> InteractiveContext -> RdrName - -> IO (Maybe [(IfaceDecl, Fixity)]) + -> IO (Maybe [(IfaceDecl, Fixity, SrcLoc)]) -- Look up a RdrName and return all the TyThings it might be -- A capitalised RdrName is given to us in the DataName namespace, -- but we want to treat it as *both* a data constructor -- *and* as a type or class constructor; -- hence the call to dataTcOccs, and we return up to two results tcRnThing hsc_env ictxt rdr_name - = initTc hsc_env iNTERACTIVE $ + = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext ictxt $ do { -- If the identifier is a constructor (begins with an @@ -453,21 +495,38 @@ tcRnThing hsc_env ictxt rdr_name else -- Add deprecation warnings mapM_ addMessages warns_s ; - -- And lookup up the entities - mapM do_one good_names + -- And lookup up the entities, avoiding duplicates, which arise + -- because constructors and record selectors are represented by + -- their parent declaration + let { do_one name = do { thing <- tcLookupGlobal name + ; let decl = toIfaceDecl ictxt thing + ; fixity <- lookupFixityRn name + ; return (decl, fixity, getSrcLoc thing) } ; + -- For the SrcLoc, the 'thing' has better info than + -- the 'name' because getting the former forced the + -- declaration to be loaded into the cache + cmp (d1,_,_) (d2,_,_) = ifName d1 `compare` ifName d2 } ; + results <- mapM do_one good_names ; + return (fst (removeDups cmp results)) } - where - do_one name = do { thing <- tcLookupGlobal name - ; fixity <- lookupFixityRn name - ; return (toIfaceDecl ictxt thing, fixity) } toIfaceDecl :: InteractiveContext -> TyThing -> IfaceDecl toIfaceDecl ictxt thing - = tyThingToIfaceDecl True {- Discard IdInfo -} ext_nm thing + = tyThingToIfaceDecl True -- Discard IdInfo + emptyNameSet -- Show data cons + ext_nm (munge thing) where unqual = icPrintUnqual ictxt ext_nm n | unqual n = LocalTop (nameOccName n) -- What a hack | otherwise = ExtPkg (nameModuleName n) (nameOccName n) + + -- munge transforms a thing to it's "parent" thing + munge (ADataCon dc) = ATyCon (dataConTyCon dc) + munge (AnId id) = case globalIdDetails id of + RecordSelId lbl -> ATyCon (fieldLabelTyCon lbl) + ClassOpId cls -> AClass cls + other -> AnId id + munge other_thing = other_thing \end{code} @@ -491,7 +550,7 @@ setInteractiveContext icxt thing_inside \begin{code} tcRnExtCore :: HscEnv -> HsExtCore RdrName - -> IO (Maybe ModGuts) + -> IO (Messages, Maybe ModGuts) -- Nothing => some error occurred tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) @@ -529,7 +588,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- Wrap up let { bndrs = bindersOfBinds core_binds ; - my_exports = map (Avail . idName) bndrs ; + my_exports = mkNameSet (map idName bndrs) ; -- ToDo: export the data types also? final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ; @@ -796,7 +855,7 @@ mkExportEnv :: HscEnv -> [ModuleName] -- Expose these modules' exports only -> IO GlobalRdrEnv mkExportEnv hsc_env exports - = do { mb_envs <- initTc hsc_env iNTERACTIVE $ + = do { mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $ mappM getModuleExports exports ; case mb_envs of Just envs -> return (foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs) @@ -807,9 +866,11 @@ mkExportEnv hsc_env exports getModuleExports :: ModuleName -> TcM GlobalRdrEnv getModuleExports mod = do { iface <- load_iface mod + ; loadOrphanModules (dep_orphs (mi_deps iface)) + -- Load any orphan-module interfaces, + -- so their instances are visible ; avails <- exportsToAvails (mi_exports iface) - ; let { gres = [ GRE { gre_name = name, gre_prov = vanillaProv mod, - gre_deprec = mi_dep_fn iface name } + ; let { gres = [ GRE { gre_name = name, gre_prov = vanillaProv mod } | avail <- avails, name <- availNames avail ] } ; returnM (mkGlobalRdrEnv gres) } @@ -829,10 +890,10 @@ getModuleContents -> IO (Maybe [IfaceDecl]) getModuleContents hsc_env ictxt mod exports_only - = initTc hsc_env iNTERACTIVE (get_mod_contents exports_only) + = initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only) where get_mod_contents exports_only - | not exports_only -- We want the whole top-level type env + | not exports_only -- We want the whole top-level type env -- so it had better be a home module = do { hpt <- getHpt ; case lookupModuleEnvByName hpt mod of @@ -857,13 +918,16 @@ getModuleContents hsc_env ictxt mod exports_only --------------------- filter_decl occs decl@(IfaceClass {ifSigs = sigs}) = decl { ifSigs = filter (keep_sig occs) sigs } -filter_decl occs decl@(IfaceData {ifCons = DataCons cons}) - = decl { ifCons = DataCons (filter (keep_con occs) cons) } +filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon cons}) + = decl { ifCons = IfDataTyCon (filter (keep_con occs) cons) } +filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con}) + | keep_con occs con = decl + | otherwise = decl {ifCons = IfAbstractTyCon} -- Hmm? filter_decl occs decl = decl -keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs -keep_con occs (IfaceConDecl occ _ _ _ _ _) = occ `elem` occs +keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs +keep_con occs (IfaceConDecl occ _ _ _ _ _ _) = occ `elem` occs availOccs avail = map nameOccName (availNames avail) @@ -981,7 +1045,7 @@ tcDump env } where short_dump = pprTcGblEnv env - full_dump = ppr (tcg_binds env) + full_dump = pprLHsBinds (tcg_binds env) -- NB: foreign x-d's have undefined's in their types; -- hence can't show the tc_fords