- -> IO ( PersistentCompilerState,
- [TyThing] )
-
-hscThing dflags hst hit pcs0 icontext str
- = do let
- InteractiveContext {
- ic_rn_env = rn_env,
- ic_type_env = type_env,
- ic_module = scope_mod } = icontext
-
- rdr_names
- | '.' `elem` str
- = [ mkQual ns (fmod,fvar) | ns <- namespaces var ]
- | otherwise
- = [ mkUnqual ns fstr | ns <- namespaces str ]
- where (mod,var) = split_longest_prefix str '.'
- fmod = mkFastString mod
- fvar = mkFastString var
- fstr = mkFastString str
- namespaces s | isLower (head s) = [ varName ]
- | otherwise = [ tcClsName, dataName ]
-
- (pcs, unqual, maybe_rn_result) <-
- renameRdrName dflags hit hst pcs0 scope_mod scope_mod
- rn_env rdr_names
-
- case maybe_rn_result of {
- Nothing -> return (pcs, []);
- Just (names, decls) -> do {
-
- maybe_pcs <- typecheckExtraDecls dflags pcs hst unqual
- iNTERACTIVE decls;
-
- case maybe_pcs of {
- Nothing -> return (pcs, []);
- Just pcs ->
- let maybe_ty_things = map (lookupType hst (pcs_PTE pcs)) names
- in
- return (pcs, catMaybes maybe_ty_things) }
- }}
+ -> IO [(IfaceDecl, Fixity)]
+
+hscThing hsc_env ic str
+ = do maybe_rdr_name <- myParseIdentifier (hsc_dflags hsc_env) str
+ case maybe_rdr_name of {
+ Nothing -> return [];
+ Just (L _ rdr_name) -> do
+
+ maybe_tc_result <- tcRnThing hsc_env ic rdr_name
+
+ case maybe_tc_result of {
+ Nothing -> return [] ;
+ Just things -> return things
+ }}
+
+myParseIdentifier dflags str
+ = do buf <- stringToStringBuffer str
+
+ let loc = mkSrcLoc FSLIT("<interactive>") 1 0
+ case unP parseIdentifier (mkPState buf loc dflags) of
+
+ PFailed span err -> do { printError span err;
+ return Nothing }
+
+ POk _ rdr_name -> return (Just rdr_name)
+#endif
+\end{code}
+
+%************************************************************************
+%* *
+ Desugar, simplify, convert to bytecode, and link an expression
+%* *
+%************************************************************************
+
+\begin{code}
+#ifdef GHCI
+compileExpr :: HscEnv
+ -> Module -> GlobalRdrEnv -> TypeEnv
+ -> LHsExpr Id
+ -> IO HValue
+
+compileExpr hsc_env this_mod rdr_env type_env tc_expr
+ = do { let { dflags = hsc_dflags hsc_env ;
+ lint_on = dopt Opt_DoCoreLinting dflags }
+
+ -- Desugar it
+ ; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
+
+ -- Flatten it
+ ; flat_expr <- flattenExpr hsc_env ds_expr
+
+ -- Simplify it
+ ; simpl_expr <- simplifyExpr dflags flat_expr
+
+ -- Tidy it (temporary, until coreSat does cloning)
+ ; tidy_expr <- tidyCoreExpr simpl_expr
+
+ -- Prepare for codegen
+ ; prepd_expr <- corePrepExpr dflags tidy_expr
+
+ -- Lint if necessary
+ -- ToDo: improve SrcLoc
+ ; if lint_on then
+ case lintUnfolding noSrcLoc [] prepd_expr of
+ Just err -> pprPanic "compileExpr" err
+ Nothing -> return ()
+ else
+ return ()
+
+ -- Convert to BCOs
+ ; bcos <- coreExprToBCOs dflags prepd_expr
+
+ -- link it
+ ; hval <- linkExpr hsc_env bcos
+
+ ; return hval
+ }