\begin{code}
module TcRnDriver (
#ifdef GHCI
- mkExportEnv, getModuleContents, tcRnStmt, tcRnThing, tcRnExpr,
+ mkExportEnv, getModuleContents, tcRnStmt,
+ tcRnThing, tcRnExpr, tcRnType,
#endif
tcRnModule,
tcTopSrcDecls,
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,
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 )
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 )
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 )
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
returnM (new_ic, bound_names, tc_expr)
}
-\end{code}
+\end{code}
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,
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] })
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}
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
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 -} 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}
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 ] }
= 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
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)
}
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
projects / ghc-hetmet.git / blobdiff