refactoring GHCApi.

This commit is contained in:
Kazu Yamamoto 2013-03-04 13:41:56 +09:00
parent 3089d36071
commit 13bb6cb599
6 changed files with 43 additions and 32 deletions

View File

@ -33,8 +33,8 @@ browseModule opt mdlName = convert opt . format <$> browse opt mdlName
formatOps' [] = error "formatOps'"
browse :: Options -> String -> IO [String]
browse opt mdlName = withGHC $ do
_ <- initSession0 opt
browse opt mdlName = withGHCDummyFile $ do
initializeFlags opt
getModule >>= getModuleInfo >>= listExports
where
getModule = findModule (mkModuleName mdlName) Nothing

View File

@ -17,10 +17,10 @@ checkSyntax opt cradle file = unlines <$> check opt cradle file
----------------------------------------------------------------
check :: Options -> Cradle -> String -> IO [String]
check opt cradle fileName = withGHC' fileName $ checkIt `gcatch` handleErrMsg
check opt cradle fileName = withGHC fileName $ checkIt `gcatch` handleErrMsg
where
checkIt = do
readLog <- initializeGHC opt cradle fileName options True
readLog <- initializeFlagsWithCradle opt cradle fileName options True
setTargetFile fileName
_ <- load LoadAllTargets
liftIO readLog

View File

@ -1,4 +1,4 @@
module Debug where
module Debug (debugInfo) where
import CabalApi
import GHCApi
@ -20,8 +20,8 @@ debug opt cradle fileName = do
fromCabalFile (ghcOpts opt) cradle
else
return (ghcOpts opt, [], [], [])
dflags <- getDynFlags
fast <- isFastCheck dflags fileName (Just langext)
dflags <- getDynamicFlags
fast <- getFastCheck dflags fileName (Just langext)
return [
"GHC version: " ++ ghcVer
, "Current directory: " ++ currentDir

View File

@ -1,8 +1,17 @@
module GHCApi where
module GHCApi (
withGHC
, withGHCDummyFile
, initializeFlags
, initializeFlagsWithCradle
, setTargetFile
, getDynamicFlags
, getFastCheck
) where
import CabalApi
import Control.Applicative
import Control.Exception
import Control.Monad
import CoreMonad
import Data.Maybe (isJust)
import DynFlags
@ -17,11 +26,11 @@ import Types
----------------------------------------------------------------
withGHC :: Alternative m => Ghc (m a) -> IO (m a)
withGHC = withGHC' "Dummy"
withGHCDummyFile :: Alternative m => Ghc (m a) -> IO (m a)
withGHCDummyFile = withGHC "Dummy"
withGHC' :: Alternative m => FilePath -> Ghc (m a) -> IO (m a)
withGHC' file body = ghandle ignore $ runGhc (Just libdir) $ do
withGHC :: Alternative m => FilePath -> Ghc (m a) -> IO (m a)
withGHC file body = ghandle ignore $ runGhc (Just libdir) $ do
dflags <- getSessionDynFlags
defaultCleanupHandler dflags body
where
@ -33,19 +42,11 @@ withGHC' file body = ghandle ignore $ runGhc (Just libdir) $ do
----------------------------------------------------------------
initSession0 :: Options -> Ghc [PackageId]
initSession0 opt = do
dflags0 <- getSessionDynFlags
dflags1 <- setGhcFlags dflags0 opt
setSessionDynFlags dflags1
----------------------------------------------------------------
importDirs :: [IncludeDir]
importDirs = [".","..","../..","../../..","../../../..","../../../../.."]
initializeGHC :: Options -> Cradle -> FilePath -> [GHCOption] -> Bool -> Ghc LogReader
initializeGHC opt cradle fileName ghcOptions logging
initializeFlagsWithCradle :: Options -> Cradle -> FilePath -> [GHCOption] -> Bool -> Ghc LogReader
initializeFlagsWithCradle opt cradle fileName ghcOptions logging
| cabal = do
(gopts,idirs,depPkgs,hdrExts) <- liftIO $ fromCabalFile ghcOptions cradle
initSession opt gopts idirs (Just depPkgs) (Just hdrExts) logging fileName
@ -54,6 +55,8 @@ initializeGHC opt cradle fileName ghcOptions logging
where
cabal = isJust $ cradleCabalFile cradle
----------------------------------------------------------------
initSession :: Options
-> [GHCOption]
-> [IncludeDir]
@ -70,20 +73,28 @@ initSession opt cmdOpts idirs mDepPkgs mLangExts logging file = do
where
setupDynamicFlags df0 = do
df1 <- modifyFlagsWithOpts df0 cmdOpts
fast <- liftIO $ isFastCheck df0 file mLangExts
fast <- liftIO $ getFastCheck df0 file mLangExts
let df2 = modifyFlags df1 idirs mDepPkgs fast (expandSplice opt)
df3 <- setGhcFlags df2 opt
liftIO $ setLogger logging df3
----------------------------------------------------------------
initializeFlags :: Options -> Ghc ()
initializeFlags opt = do
dflags0 <- getSessionDynFlags
dflags1 <- setGhcFlags dflags0 opt
void $ setSessionDynFlags dflags1
----------------------------------------------------------------
getHeaderExtension :: DynFlags -> FilePath -> IO [String]
getHeaderExtension dflags file = map unLoc <$> getOptionsFromFile dflags file
----------------------------------------------------------------
isFastCheck :: DynFlags -> FilePath -> Maybe [LangExt] -> IO Bool
isFastCheck dflags file mLangExts = do
getFastCheck :: DynFlags -> FilePath -> Maybe [LangExt] -> IO Bool
getFastCheck dflags file mLangExts = do
hdrExts <- getHeaderExtension dflags file
return . not $ useTemplateHaskell mLangExts hdrExts
@ -149,5 +160,5 @@ setTargetFile file = do
----------------------------------------------------------------
getDynFlags :: IO DynFlags
getDynFlags = runGhc (Just libdir) getSessionDynFlags
getDynamicFlags :: IO DynFlags
getDynamicFlags = runGhc (Just libdir) getSessionDynFlags

View File

@ -139,15 +139,15 @@ pprInfo pefas (thing, fixity, insts)
inModuleContext :: Options -> Cradle -> FilePath -> ModuleString -> Ghc String -> String -> IO String
inModuleContext opt cradle fileName modstr action errmsg =
withGHC (valid ||> invalid ||> return errmsg)
withGHCDummyFile (valid ||> invalid ||> return errmsg)
where
valid = do
_ <- initializeGHC opt cradle fileName ["-w"] False
_ <- initializeFlagsWithCradle opt cradle fileName ["-w"] False
setTargetFile fileName
_ <- load LoadAllTargets
doif setContextFromTarget action
invalid = do
_ <- initializeGHC opt cradle fileName ["-w"] False
_ <- initializeFlagsWithCradle opt cradle fileName ["-w"] False
setTargetBuffer
_ <- load LoadAllTargets
doif setContextFromTarget action

View File

@ -14,8 +14,8 @@ listModules :: Options -> IO String
listModules opt = convert opt . nub . sort <$> list opt
list :: Options -> IO [String]
list opt = withGHC $ do
_ <- initSession0 opt
list opt = withGHCDummyFile $ do
initializeFlags opt
getExposedModules <$> getSessionDynFlags
where
getExposedModules = map moduleNameString