From d7230e532eb485db85d4e446d7fba4192507b3ba Mon Sep 17 00:00:00 2001
From: Tim Chevalier <chevalier@alum.wellesley.edu>
Date: Mon, 25 Jun 2007 22:06:08 +0000
Subject: [PATCH] Add a compileToCore function to the GHC API

Added a compileToCore function to the GHC API that takes a
  session, module, and filename, and returns a list of Core
  bindings if successful. This is just a first try and could
  probably be improved (for example, there's probably a way to
  get the filename from the module so that it doesn't have to
  be passed in, I just don't see it offhand.)
---
 compiler/main/GHC.hs |   35 +++++++++++++++++++++++++++++++++--
 1 file changed, 33 insertions(+), 2 deletions(-)

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index f53fddc..1fc21c9 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -41,6 +41,7 @@ module GHC (
 	workingDirectoryChanged,
 	checkModule, CheckedModule(..),
 	TypecheckedSource, ParsedSource, RenamedSource,
+        compileToCore,
 
 	-- * Parsing Haddock comments
 	parseHaddockComment,
@@ -225,8 +226,11 @@ import Name             hiding ( varName )
 import OccName		( parenSymOcc )
 import InstEnv		( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
 import SrcLoc
+import Desugar
+import CoreSyn
+import TcRnDriver       ( tcRnModule )
 import DriverPipeline
-import DriverPhases	( Phase(..), isHaskellSrcFilename, startPhase )
+import DriverPhases	( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase )
 import HeaderInfo	( getImports, getOptions )
 import Finder
 import HscMain          ( newHscEnv, hscFileCheck, HscChecked(..) )
@@ -827,7 +831,34 @@ checkModule session@(Session ref) mod = do
 					typecheckedSource = Just tc_binds,
 					checkedModuleInfo = Just minf }))
 
--- ---------------------------------------------------------------------------
+-- | This is the way to get access to the Core bindings corresponding
+-- to a module. 'compileToCore' first invokes 'checkModule' to parse and
+-- typecheck the module, then desugars it and returns the resulting list
+-- of Core bindings if successful.
+compileToCore :: Session -> ModuleName -> FilePath -> IO (Maybe [CoreBind])
+compileToCore session@(Session ref) mod fn = do
+   hsc_env <- readIORef ref
+   maybeCheckedModule <- checkModule session mod
+   case maybeCheckedModule of
+     Nothing -> return Nothing 
+     Just checkedMod -> do
+       let parsedMod = parsedSource checkedMod
+       -- Note: this typechecks the module twice (because checkModule
+       -- also calls tcRnModule), but arranging for checkModule to
+       -- return the type env would require changing a lot of data
+       -- structures, so I'm leaving it like that for now.
+       (_, maybe_tc_result) <- tcRnModule hsc_env HsSrcFile False parsedMod
+       case maybe_tc_result of
+       -- TODO: this ignores the type error messages and just returns Nothing
+         Nothing -> return Nothing
+         Just tcgEnv -> do
+           let dflags = hsc_dflags hsc_env 
+           location <- mkHomeModLocation dflags mod fn
+           maybeModGuts <- deSugar hsc_env location tcgEnv
+           case maybeModGuts of
+             Nothing -> return Nothing
+             Just mg -> return $ Just $ mg_binds mg
+ -- ---------------------------------------------------------------------------
 -- Unloading
 
 unload :: HscEnv -> [Linkable] -> IO ()
-- 
1.7.10.4