- Nothing -> return (pcs0, []);
- Just 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
- | occNameSpace occ == dataName = [ rdr_name, tccls_name ]
- | otherwise = [ rdr_name ]
- where
- occ = rdrNameOcc rdr_name
- tccls_occ = setOccNameSpace occ tcClsName
- tccls_name = setRdrNameOcc rdr_name tccls_occ
-
- (pcs, unqual, maybe_rn_result) <-
- renameRdrName dflags hit hst pcs0 iNTERACTIVE icontext 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) }
- }}}
-
-myParseIdentifier dflags str
- = do buf <- stringToStringBuffer str
-
- let glaexts | dopt Opt_GlasgowExts dflags = 1#
- | otherwise = 0#
-
- case parseIdentifier buf
- PState{ bol = 0#, atbol = 1#,
- context = [], glasgow_exts = glaexts,
- loc = mkSrcLoc SLIT("<interactive>") 1 } of
-
- PFailed err -> do { hPutStrLn stderr (showSDoc err);
- freeStringBuffer buf;
- return Nothing }
-
- POk _ rdr_name -> do { --should, but can't: freeStringBuffer buf;
- return (Just rdr_name) }
+ 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
+ }}
+#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
+ }