X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=c322d98258883877949bc597864f545972e6a058;hb=10ab808b4c8575f62bcc7998e5ab45fa0e0d33c5;hp=a7cec102bb69956a77d41e4afa0f8d427a97bfa0;hpb=ad90960b191bfa5cb409ac62cbc8caaa61d37aab;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index a7cec10..c322d98 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 ) @@ -60,28 +62,30 @@ import TyCon ( tyConHasGenerics ) import 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 TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal ) +import RnTypes ( rnLHsType ) import Inst ( tcStdSyntaxName ) import RnExpr ( rnStmts, rnLExpr ) import RnNames ( exportsToAvails ) @@ -90,11 +94,14 @@ 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 Kind ( Kind ) import Var ( globaliseId ) import Name ( nameOccName, nameModuleName ) import NameEnv ( delListFromNameEnv ) @@ -102,10 +109,11 @@ import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, retu 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 @@ -274,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 @@ -287,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, @@ -312,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] }) @@ -385,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} @@ -421,6 +435,27 @@ 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 @@ -460,22 +495,35 @@ 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) } ; + 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 -} emptyNameSet {- Show data cons -} - 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} @@ -815,6 +863,9 @@ 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 } | avail <- avails, name <- availNames avail ] } @@ -839,7 +890,7 @@ getModuleContents hsc_env ictxt mod 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 @@ -872,8 +923,8 @@ filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con}) 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) @@ -991,7 +1042,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