refactoring GHCApi.
This commit is contained in:
parent
3089d36071
commit
13bb6cb599
@ -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
|
||||
|
4
Check.hs
4
Check.hs
@ -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
|
||||
|
6
Debug.hs
6
Debug.hs
@ -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
|
||||
|
51
GHCApi.hs
51
GHCApi.hs
@ -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
|
||||
|
6
Info.hs
6
Info.hs
@ -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
|
||||
|
4
List.hs
4
List.hs
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user