+%*********************************************************
+%* *
+ GHCi stuff
+%* *
+%*********************************************************
+
+\begin{code}
+#ifdef GHCI
+setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
+setInteractiveContext hsc_env icxt thing_inside
+ = let
+ -- Initialise the tcg_inst_env with instances
+ -- from all home modules. This mimics the more selective
+ -- call to hptInstances in tcRnModule
+ dfuns = hptInstances hsc_env (\mod -> True)
+ in
+ updGblEnv (\env -> env {
+ tcg_rdr_env = ic_rn_gbl_env icxt,
+ tcg_type_env = ic_type_env icxt,
+ tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $
+
+ updLclEnv (\env -> env { tcl_rdr = ic_rn_local_env icxt }) $
+
+ do { traceTc (text "setIC" <+> ppr (ic_type_env icxt))
+ ; thing_inside }
+\end{code}
+
+
+\begin{code}
+tcRnStmt :: HscEnv
+ -> InteractiveContext
+ -> LStmt RdrName
+ -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
+ -- The returned [Name] is the same as the input except for
+ -- ExprStmt, in which case the returned [Name] is [itName]
+ --
+ -- The returned TypecheckedHsExpr is of type IO [ () ],
+ -- a list of the bound values, coerced to ().
+
+tcRnStmt hsc_env ictxt rdr_stmt
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ setInteractiveContext hsc_env ictxt $ do {
+
+ -- Rename; use CmdLineMode because tcRnStmt is only used interactively
+ (([rn_stmt], _), fvs) <- rnStmts DoExpr [rdr_stmt] (return ((), emptyFVs)) ;
+ traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
+ failIfErrsM ;
+
+ -- The real work is done here
+ (bound_ids, tc_expr) <- mkPlan rn_stmt ;
+ zonked_expr <- zonkTopLExpr tc_expr ;
+ zonked_ids <- zonkTopBndrs bound_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) ;
+
+ traceTc (text "tcs 1") ;
+ let { -- (a) Make all the bound ids "global" ids, now that
+ -- they're notionally top-level bindings. This is
+ -- 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.
+ --
+ -- (b) Tidy their types; this is important, because :info may
+ -- ask to look at them, and :info expects the things it looks
+ -- up to have tidy types
+ global_ids = map globaliseAndTidy zonked_ids ;
+
+ -- Update the interactive context
+ rn_env = ic_rn_local_env ictxt ;
+ type_env = ic_type_env ictxt ;
+
+ bound_names = map idName global_ids ;
+ new_rn_env = extendLocalRdrEnv rn_env bound_names ;
+
+ -- Remove any shadowed bindings from the type_env;
+ -- they are inaccessible but might, I suppose, cause
+ -- a space leak if we leave them there
+ shadowed = [ n | name <- bound_names,
+ let rdr_name = mkRdrUnqual (nameOccName name),
+ Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
+
+ filtered_type_env = delListFromNameEnv type_env shadowed ;
+ new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
+
+ new_ic = ictxt { ic_rn_local_env = new_rn_env,
+ ic_type_env = new_type_env }
+ } ;
+
+ dumpOptTcRn Opt_D_dump_tc
+ (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
+ text "Typechecked expr" <+> ppr zonked_expr]) ;
+
+ returnM (new_ic, bound_names, zonked_expr)
+ }
+ where
+ bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
+ nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
+
+globaliseAndTidy :: Id -> Id
+globaliseAndTidy id
+-- Give the Id a Global Name, and tidy its type
+ = setIdType (globaliseId VanillaGlobal id) tidy_type
+ where
+ tidy_type = tidyTopType (idType id)
+\end{code}
+
+Here is the grand plan, implemented in tcUserStmt
+
+ What you type The IO [HValue] that hscStmt returns
+ ------------- ------------------------------------
+ let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
+ bindings: [x,y,...]
+
+ pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
+ bindings: [x,y,...]
+
+ expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it]
+ [NB: result not printed] bindings: [it]
+
+ expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it]
+ result showable) bindings: [it]
+
+ expr (of non-IO type,
+ result not showable) ==> error
+
+
+\begin{code}
+---------------------------
+type PlanResult = ([Id], LHsExpr Id)
+type Plan = TcM PlanResult
+
+runPlans :: [Plan] -> TcM PlanResult
+-- Try the plans in order. If one fails (by raising an exn), try the next.
+-- If one succeeds, take it.
+runPlans [] = panic "runPlans"
+runPlans [p] = p
+runPlans (p:ps) = tryTcLIE_ (runPlans ps) p
+
+--------------------
+mkPlan :: LStmt Name -> TcM PlanResult
+mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt
+ = do { uniq <- newUnique -- is treated very specially
+ ; let fresh_it = itName uniq
+ the_bind = L loc $ FunBind (L loc fresh_it) False matches emptyNameSet
+ matches = mkMatchGroup [mkMatch [] expr emptyLocalBinds]
+ let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(NonRecursive,unitBag the_bind)] []))
+ bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr
+ (HsVar bindIOName) noSyntaxExpr
+ print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
+ (HsVar thenIOName) placeHolderType
+
+ -- The plans are:
+ -- [it <- e; print it] but not if it::()
+ -- [it <- e]
+ -- [let it = e; print it]
+ ; runPlans [ -- Plan A
+ do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
+ ; it_ty <- zonkTcType (idType it_id)
+ ; ifM (isUnitTy it_ty) failM
+ ; return stuff },
+
+ -- Plan B; a naked bind statment
+ tcGhciStmts [bind_stmt],
+
+ -- Plan C; check that the let-binding is typeable all by itself.
+ -- If not, fail; if so, try to print it.
+ -- The two-step process avoids getting two errors: one from
+ -- the expression itself, and one from the 'print it' part
+ -- This two-step story is very clunky, alas
+ do { checkNoErrs (tcGhciStmts [let_stmt])
+ --- checkNoErrs defeats the error recovery of let-bindings
+ ; tcGhciStmts [let_stmt, print_it] }
+ ]}
+
+mkPlan stmt@(L loc (BindStmt {}))
+ | [L _ v] <- collectLStmtBinders stmt -- One binder, for a bind stmt
+ = do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
+ (HsVar thenIOName) placeHolderType
+ -- The plans are:
+ -- [stmt; print v] but not if v::()
+ -- [stmt]
+ ; runPlans [do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
+ ; v_ty <- zonkTcType (idType v_id)
+ ; ifM (isUnitTy v_ty || not (isTauTy v_ty)) failM
+ ; return stuff },
+ tcGhciStmts [stmt]
+ ]}
+
+mkPlan stmt
+ = tcGhciStmts [stmt]
+
+---------------------------
+tcGhciStmts :: [LStmt Name] -> TcM PlanResult
+tcGhciStmts stmts
+ = do { ioTyCon <- tcLookupTyCon ioTyConName ;
+ ret_id <- tcLookupId returnIOName ; -- return @ IO
+ let {
+ io_ty = mkTyConApp ioTyCon [] ;
+ ret_ty = mkListTy unitTy ;
+ io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
+
+ names = map unLoc (collectLStmtsBinders stmts) ;
+
+ -- mk_return builds the expression
+ -- returnIO @ [()] [coerce () x, .., coerce () z]
+ --
+ -- Despite the inconvenience of building the type applications etc,
+ -- this *has* to be done in type-annotated post-typecheck form
+ -- because we are going to return a list of *polymorphic* values
+ -- coerced to type (). If we built a *source* stmt
+ -- return [coerce x, ..., coerce z]
+ -- then the type checker would instantiate x..z, and we wouldn't
+ -- get their *polymorphic* values. (And we'd get ambiguity errs
+ -- if they were overloaded, since they aren't applied to anything.)
+ mk_return ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
+ (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
+ mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
+ (nlHsVar id)
+ } ;
+
+ -- OK, we're ready to typecheck the stmts
+ traceTc (text "tcs 2") ;
+ ((tc_stmts, ids), lie) <- getLIE $
+ tcStmts DoExpr (tcDoStmt io_ty io_ret_ty) stmts $
+ mappM tcLookupId names ;
+ -- Look up the names right in the middle,
+ -- where they will all be in scope
+
+ -- Simplify the context
+ const_binds <- checkNoErrs (tcSimplifyInteractive lie) ;
+ -- checkNoErrs ensures that the plan fails if context redn fails
+
+ return (ids, mkHsDictLet const_binds $
+ noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty))
+ }
+\end{code}
+
+
+tcRnExpr just finds the type of an expression
+
+\begin{code}
+tcRnExpr :: HscEnv
+ -> InteractiveContext
+ -> LHsExpr RdrName
+ -> IO (Maybe Type)
+tcRnExpr hsc_env ictxt rdr_expr
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ setInteractiveContext hsc_env ictxt $ do {
+
+ (rn_expr, fvs) <- rnLExpr rdr_expr ;
+ failIfErrsM ;
+
+ -- Now typecheck the expression;
+ -- it might have a rank-2 type (e.g. :t runST)
+ ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
+ ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
+ tcSimplifyInteractive lie_top ;
+ qtvs' <- mappM zonkQuantifiedTyVar qtvs ;
+
+ let { all_expr_ty = mkForAllTys qtvs' $
+ mkFunTys (map idType dict_ids) $
+ res_ty } ;
+ zonkTcType all_expr_ty
+ }
+ where
+ smpl_doc = ptext SLIT("main expression")
+\end{code}
+
+tcRnType 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 hsc_env 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")
+
+#endif /* GHCi */
+\end{code}
+
+
+%************************************************************************
+%* *
+ More GHCi stuff, to do with browsing and getting info
+%* *
+%************************************************************************
+
+\begin{code}
+#ifdef GHCI
+-- ASSUMES that the module is either in the HomePackageTable or is
+-- a package module with an interface on disk. If neither of these is
+-- true, then the result will be an error indicating the interface
+-- could not be found.
+getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe NameSet)
+getModuleExports hsc_env mod
+ = initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod)
+
+tcGetModuleExports :: Module -> TcM NameSet
+tcGetModuleExports mod = do
+ iface <- load_iface mod
+ loadOrphanModules (dep_orphs (mi_deps iface))
+ -- Load any orphan-module interfaces,
+ -- so their instances are visible
+ ifaceExportNames (mi_exports iface)
+
+load_iface mod = loadSrcInterface doc mod False {- Not boot iface -}
+ where
+ doc = ptext SLIT("context for compiling statements")
+
+
+tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name])
+tcRnLookupRdrName hsc_env rdr_name
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ setInteractiveContext hsc_env (hsc_IC hsc_env) $
+ lookup_rdr_name rdr_name
+
+lookup_rdr_name rdr_name = do {
+ -- If the identifier is a constructor (begins with an
+ -- upper-case letter), then we need to consider both
+ -- constructor and type class identifiers.
+ let { rdr_names = dataTcOccs rdr_name } ;
+
+ -- results :: [Either Messages Name]
+ results <- mapM (tryTcErrs . lookupOccRn) rdr_names ;
+
+ traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]);
+ -- The successful lookups will be (Just name)
+ let { (warns_s, good_names) = unzip [ (msgs, name)
+ | (msgs, Just name) <- results] ;
+ errs_s = [msgs | (msgs, Nothing) <- results] } ;
+
+ -- Fail if nothing good happened, else add warnings
+ if null good_names then
+ -- No lookup succeeded, so
+ -- pick the first error message and report it
+ -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
+ -- while the other is "X is not in scope",
+ -- we definitely want the former; but we might pick the latter
+ do { addMessages (head errs_s) ; failM }
+ else -- Add deprecation warnings
+ mapM_ addMessages warns_s ;
+
+ return good_names
+ }
+
+
+tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
+tcRnLookupName hsc_env name
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ setInteractiveContext hsc_env (hsc_IC hsc_env) $
+ tcLookupGlobal name
+
+
+tcRnGetInfo :: HscEnv
+ -> Name
+ -> IO (Maybe (TyThing, Fixity, [Instance]))
+
+-- Used to implemnent :info in GHCi
+--
+-- 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
+tcRnGetInfo hsc_env name
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ let ictxt = hsc_IC hsc_env in
+ setInteractiveContext hsc_env ictxt $ do
+
+ -- Load the interface for all unqualified types and classes
+ -- That way we will find all the instance declarations
+ -- (Packages have not orphan modules, and we assume that
+ -- in the home package all relevant modules are loaded.)
+ loadUnqualIfaces ictxt
+
+ thing <- tcLookupGlobal name
+ fixity <- lookupFixityRn name
+ ispecs <- lookupInsts (icPrintUnqual ictxt) thing
+ return (thing, fixity, ispecs)
+
+
+lookupInsts :: PrintUnqualified -> TyThing -> TcM [Instance]
+-- Filter the instances by the ones whose tycons (or clases resp)
+-- are in scope unqualified. Otherwise we list a whole lot too many!
+lookupInsts print_unqual (AClass cls)
+ = do { inst_envs <- tcGetInstEnvs
+ ; return [ ispec
+ | ispec <- classInstances inst_envs cls
+ , plausibleDFun print_unqual (instanceDFunId ispec) ] }
+
+lookupInsts print_unqual (ATyCon tc)
+ = do { eps <- getEps -- Load all instances for all classes that are
+ -- in the type environment (which are all the ones
+ -- we've seen in any interface file so far)
+ ; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all
+ ; return [ ispec
+ | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
+ , let dfun = instanceDFunId ispec
+ , relevant dfun
+ , plausibleDFun print_unqual dfun ] }
+ where
+ relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
+ tc_name = tyConName tc
+
+lookupInsts print_unqual other = return []
+
+plausibleDFun print_unqual dfun -- Dfun involving only names that print unqualified
+ = all ok (nameSetToList (tyClsNamesOfType (idType dfun)))
+ where
+ ok name | isBuiltInSyntax name = True
+ | isExternalName name = print_unqual (nameModule name) (nameOccName name)
+ | otherwise = True
+
+loadUnqualIfaces :: InteractiveContext -> TcM ()
+-- Load the home module for everything that is in scope unqualified
+-- This is so that we can accurately report the instances for
+-- something
+loadUnqualIfaces ictxt
+ = initIfaceTcRn $
+ mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
+ where
+ unqual_mods = [ nameModule name
+ | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt),
+ let name = gre_name gre,
+ isTcOcc (nameOccName name), -- Types and classes only
+ unQualOK gre ] -- In scope unqualified
+ doc = ptext SLIT("Need interface for module whose export(s) are in scope unqualified")
+#endif /* GHCI */
+\end{code}