-hscThing -- like hscStmt, but deals with a single identifier
- :: DynFlags
- -> HomeSymbolTable
- -> HomeIfaceTable
- -> PersistentCompilerState -- IN: persistent compiler state
- -> InteractiveContext -- Context for compiling
- -> String -- The identifier
- -> IO ( PersistentCompilerState,
- [TyThing] )
-
-hscThing dflags hst hit pcs0 icontext str
- = do maybe_rdr_name <- myParseIdentifier dflags str
- case maybe_rdr_name of {
- 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) }
+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)
+ ; let tidy_expr = tidyExpr emptyTidyEnv 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
+ }