\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 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 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 )
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
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 ] }
---------------------
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)
}
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