{-# LANGUAGE ScopedTypeVariables, RecordWildCards #-}
module Hhp.GHCApi (
withGHC
, withGHC'
, initializeFlagsWithCradle
, setTargetFiles
, getDynamicFlags
, getSystemLibDir
, withDynFlags
, withCmdFlags
, setNoWarningFlags
, setAllWarningFlags
, setDeferTypedHoles
, setDeferTypeErrors
, setPartialSignatures
, setWarnTypedHoles
) where
import GHC (Ghc, DynFlags(..), LoadHowMuch(..))
import qualified GHC as G
import qualified GHC.Data.EnumSet as E (EnumSet, empty)
import GHC.Driver.Session (GeneralFlag(Opt_BuildingCabalPackage, Opt_HideAllPackages),WarningFlag(Opt_WarnTypedHoles),gopt_set, xopt_set, wopt_set,ModRenaming(..), PackageFlag(ExposePackage), PackageArg(..), WarningFlag, parseDynamicFlagsCmdLine)
import GHC.LanguageExtensions (Extension(..))
import GHC.Utils.Monad (liftIO)
import Control.Applicative ((<|>))
import Control.Monad (forM, void)
import Control.Monad.Catch (SomeException, handle, bracket)
import Data.Maybe (isJust, fromJust)
import System.Exit (exitSuccess)
import System.IO (hPutStr, hPrint, stderr)
import System.IO.Unsafe (unsafePerformIO)
import System.Process (readProcess)
import Hhp.CabalApi
import Hhp.Gap
import Hhp.GhcPkg
import Hhp.Types
getSystemLibDir :: IO (Maybe FilePath)
getSystemLibDir :: IO (Maybe FilePath)
getSystemLibDir = do
FilePath
res <- FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
"ghc" [FilePath
"--print-libdir"] []
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case FilePath
res of
FilePath
"" -> forall a. Maybe a
Nothing
FilePath
dirn -> forall a. a -> Maybe a
Just (forall a. [a] -> [a]
init FilePath
dirn)
withGHC :: FilePath
-> Ghc a
-> IO a
withGHC :: forall a. FilePath -> Ghc a -> IO a
withGHC FilePath
file Ghc a
body = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle forall a. SomeException -> IO a
ignore forall a b. (a -> b) -> a -> b
$ forall a. Ghc a -> IO a
withGHC' Ghc a
body
where
ignore :: SomeException -> IO a
ignore :: forall a. SomeException -> IO a
ignore SomeException
e = do
Handle -> FilePath -> IO ()
hPutStr Handle
stderr forall a b. (a -> b) -> a -> b
$ FilePath
file forall a. [a] -> [a] -> [a]
++ FilePath
":0:0:Error:"
forall a. Show a => Handle -> a -> IO ()
hPrint Handle
stderr SomeException
e
forall a. IO a
exitSuccess
withGHC' :: Ghc a -> IO a
withGHC' :: forall a. Ghc a -> IO a
withGHC' Ghc a
body = do
Maybe FilePath
mlibdir <- IO (Maybe FilePath)
getSystemLibDir
forall a. Maybe FilePath -> Ghc a -> IO a
G.runGhc Maybe FilePath
mlibdir Ghc a
body
importDirs :: [IncludeDir]
importDirs :: [FilePath]
importDirs = [FilePath
".",FilePath
"..",FilePath
"../..",FilePath
"../../..",FilePath
"../../../..",FilePath
"../../../../.."]
data Build = CabalPkg | SingleFile deriving Build -> Build -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Build -> Build -> Bool
$c/= :: Build -> Build -> Bool
== :: Build -> Build -> Bool
$c== :: Build -> Build -> Bool
Eq
initializeFlagsWithCradle ::
Options
-> Cradle
-> Ghc ()
initializeFlagsWithCradle :: Options -> Cradle -> Ghc ()
initializeFlagsWithCradle Options
opt Cradle
cradle
| Bool
cabal = Ghc ()
withCabal forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Ghc ()
withSandbox
| Bool
otherwise = Ghc ()
withSandbox
where
mCradleFile :: Maybe FilePath
mCradleFile = Cradle -> Maybe FilePath
cradleCabalFile Cradle
cradle
cabal :: Bool
cabal = forall a. Maybe a -> Bool
isJust Maybe FilePath
mCradleFile
ghcopts :: [FilePath]
ghcopts = Options -> [FilePath]
ghcOpts Options
opt
withCabal :: Ghc ()
withCabal = do
PackageDescription
pkgDesc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO PackageDescription
parseCabalFile forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust Maybe FilePath
mCradleFile
CompilerOptions
compOpts <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [FilePath] -> Cradle -> PackageDescription -> IO CompilerOptions
getCompilerOptions [FilePath]
ghcopts Cradle
cradle PackageDescription
pkgDesc
Build -> Options -> CompilerOptions -> Ghc ()
initSession Build
CabalPkg Options
opt CompilerOptions
compOpts
withSandbox :: Ghc ()
withSandbox = Build -> Options -> CompilerOptions -> Ghc ()
initSession Build
SingleFile Options
opt CompilerOptions
compOpts
where
pkgOpts :: [FilePath]
pkgOpts = [GhcPkgDb] -> [FilePath]
ghcDbStackOpts forall a b. (a -> b) -> a -> b
$ Cradle -> [GhcPkgDb]
cradlePkgDbStack Cradle
cradle
compOpts :: CompilerOptions
compOpts
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
pkgOpts = [FilePath] -> [FilePath] -> [Package] -> CompilerOptions
CompilerOptions [FilePath]
ghcopts [FilePath]
importDirs []
| Bool
otherwise = [FilePath] -> [FilePath] -> [Package] -> CompilerOptions
CompilerOptions ([FilePath]
ghcopts forall a. [a] -> [a] -> [a]
++ [FilePath]
pkgOpts) [FilePath
wdir,FilePath
rdir] []
wdir :: FilePath
wdir = Cradle -> FilePath
cradleCurrentDir Cradle
cradle
rdir :: FilePath
rdir = Cradle -> FilePath
cradleRootDir Cradle
cradle
initSession :: Build
-> Options
-> CompilerOptions
-> Ghc ()
initSession :: Build -> Options -> CompilerOptions -> Ghc ()
initSession Build
build Options{} CompilerOptions{[FilePath]
[Package]
depPackages :: CompilerOptions -> [Package]
includeDirs :: CompilerOptions -> [FilePath]
ghcOptions :: CompilerOptions -> [FilePath]
depPackages :: [Package]
includeDirs :: [FilePath]
ghcOptions :: [FilePath]
..} = do
DynFlags
df <- forall (m :: * -> *). GhcMonad m => m DynFlags
G.getSessionDynFlags
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
G.setSessionDynFlags forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [FilePath] -> DynFlags -> Ghc DynFlags
addCmdOpts [FilePath]
ghcOptions
( DynFlags -> DynFlags
setLinkerOptions
forall a b. (a -> b) -> a -> b
$ [FilePath] -> DynFlags -> DynFlags
setIncludeDirs [FilePath]
includeDirs
forall a b. (a -> b) -> a -> b
$ Build -> DynFlags -> DynFlags
setBuildEnv Build
build
forall a b. (a -> b) -> a -> b
$ DynFlags -> DynFlags
setEmptyLogger
forall a b. (a -> b) -> a -> b
$ [Package] -> DynFlags -> DynFlags
addPackageFlags [Package]
depPackages DynFlags
df)
setIncludeDirs :: [IncludeDir] -> DynFlags -> DynFlags
setIncludeDirs :: [FilePath] -> DynFlags -> DynFlags
setIncludeDirs [FilePath]
idirs DynFlags
df = DynFlags
df { importPaths :: [FilePath]
importPaths = [FilePath]
idirs }
setBuildEnv :: Build -> DynFlags -> DynFlags
setBuildEnv :: Build -> DynFlags -> DynFlags
setBuildEnv Build
build = Build -> DynFlags -> DynFlags
setHideAllPackages Build
build forall b c a. (b -> c) -> (a -> b) -> a -> c
. Build -> DynFlags -> DynFlags
setCabalPackage Build
build
setCabalPackage :: Build -> DynFlags -> DynFlags
setCabalPackage :: Build -> DynFlags -> DynFlags
setCabalPackage Build
CabalPkg DynFlags
df = DynFlags -> DynFlags
setCabalPkg DynFlags
df
setCabalPackage Build
_ DynFlags
df = DynFlags
df
setHideAllPackages :: Build -> DynFlags -> DynFlags
setHideAllPackages :: Build -> DynFlags -> DynFlags
setHideAllPackages Build
CabalPkg DynFlags
df = DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
df GeneralFlag
Opt_HideAllPackages
setHideAllPackages Build
_ DynFlags
df = DynFlags
df
addCmdOpts :: [GHCOption] -> DynFlags -> Ghc DynFlags
addCmdOpts :: [FilePath] -> DynFlags -> Ghc DynFlags
addCmdOpts [FilePath]
cmdOpts DynFlags
df =
forall {a} {b} {c}. (a, b, c) -> a
tfst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
parseDynamicFlagsCmdLine DynFlags
df (forall a b. (a -> b) -> [a] -> [b]
map forall e. e -> Located e
G.noLoc [FilePath]
cmdOpts)
where
tfst :: (a, b, c) -> a
tfst (a
a,b
_,c
_) = a
a
setTargetFiles :: [FilePath] -> Ghc ()
setTargetFiles :: [FilePath] -> Ghc ()
setTargetFiles [FilePath]
files = do
[Target]
targets <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
files forall a b. (a -> b) -> a -> b
$ \FilePath
file -> forall (m :: * -> *). GhcMonad m => FilePath -> m Target
guessTarget FilePath
file
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
G.setTargets [Target]
targets
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
G.load LoadHowMuch
LoadAllTargets
getDynamicFlags :: IO DynFlags
getDynamicFlags :: IO DynFlags
getDynamicFlags = do
Maybe FilePath
mlibdir <- IO (Maybe FilePath)
getSystemLibDir
forall a. Maybe FilePath -> Ghc a -> IO a
G.runGhc Maybe FilePath
mlibdir forall (m :: * -> *). GhcMonad m => m DynFlags
G.getSessionDynFlags
withDynFlags :: (DynFlags -> DynFlags) -> Ghc a -> Ghc a
withDynFlags :: forall a. (DynFlags -> DynFlags) -> Ghc a -> Ghc a
withDynFlags DynFlags -> DynFlags
setFlag Ghc a
body = forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket Ghc DynFlags
setup DynFlags -> Ghc ()
teardown (forall a b. a -> b -> a
const Ghc a
body)
where
setup :: Ghc DynFlags
setup = do
DynFlags
dflag <- forall (m :: * -> *). GhcMonad m => m DynFlags
G.getSessionDynFlags
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
G.setSessionDynFlags (DynFlags -> DynFlags
setFlag DynFlags
dflag)
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflag
teardown :: DynFlags -> Ghc ()
teardown = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
G.setSessionDynFlags
withCmdFlags :: [GHCOption] -> Ghc a -> Ghc a
withCmdFlags :: forall a. [FilePath] -> Ghc a -> Ghc a
withCmdFlags [FilePath]
flags Ghc a
body = forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket Ghc DynFlags
setup DynFlags -> Ghc ()
teardown (forall a b. a -> b -> a
const Ghc a
body)
where
setup :: Ghc DynFlags
setup = do
DynFlags
dflag <- forall (m :: * -> *). GhcMonad m => m DynFlags
G.getSessionDynFlags forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [FilePath] -> DynFlags -> Ghc DynFlags
addCmdOpts [FilePath]
flags
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
G.setSessionDynFlags DynFlags
dflag
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflag
teardown :: DynFlags -> Ghc ()
teardown = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
G.setSessionDynFlags
setDeferTypedHoles :: DynFlags -> DynFlags
setDeferTypedHoles :: DynFlags -> DynFlags
setDeferTypedHoles DynFlags
dflag = DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dflag GeneralFlag
G.Opt_DeferTypedHoles
setDeferTypeErrors :: DynFlags -> DynFlags
setDeferTypeErrors :: DynFlags -> DynFlags
setDeferTypeErrors DynFlags
dflag = DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dflag GeneralFlag
G.Opt_DeferTypeErrors
setWarnTypedHoles :: DynFlags -> DynFlags
setWarnTypedHoles :: DynFlags -> DynFlags
setWarnTypedHoles DynFlags
dflag = DynFlags -> WarningFlag -> DynFlags
wopt_set DynFlags
dflag WarningFlag
Opt_WarnTypedHoles
setPartialSignatures :: DynFlags -> DynFlags
setPartialSignatures :: DynFlags -> DynFlags
setPartialSignatures DynFlags
df = DynFlags -> Extension -> DynFlags
xopt_set (DynFlags -> Extension -> DynFlags
xopt_set DynFlags
df Extension
PartialTypeSignatures) Extension
NamedWildCards
setNoWarningFlags :: DynFlags -> DynFlags
setNoWarningFlags :: DynFlags -> DynFlags
setNoWarningFlags DynFlags
df = DynFlags
df { warningFlags :: EnumSet WarningFlag
warningFlags = forall a. EnumSet a
E.empty}
setAllWarningFlags :: DynFlags -> DynFlags
setAllWarningFlags :: DynFlags -> DynFlags
setAllWarningFlags DynFlags
df = DynFlags
df { warningFlags :: EnumSet WarningFlag
warningFlags = EnumSet WarningFlag
allWarningFlags }
{-# NOINLINE allWarningFlags #-}
allWarningFlags :: E.EnumSet WarningFlag
allWarningFlags :: EnumSet WarningFlag
allWarningFlags = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
Maybe FilePath
mlibdir <- IO (Maybe FilePath)
getSystemLibDir
forall a. Maybe FilePath -> Ghc a -> IO a
G.runGhc Maybe FilePath
mlibdir forall a b. (a -> b) -> a -> b
$ do
DynFlags
df <- forall (m :: * -> *). GhcMonad m => m DynFlags
G.getSessionDynFlags
DynFlags
df' <- [FilePath] -> DynFlags -> Ghc DynFlags
addCmdOpts [FilePath
"-Wall"] DynFlags
df
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DynFlags -> EnumSet WarningFlag
G.warningFlags DynFlags
df'
setCabalPkg :: DynFlags -> DynFlags
setCabalPkg :: DynFlags -> DynFlags
setCabalPkg DynFlags
dflag = DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dflag GeneralFlag
Opt_BuildingCabalPackage
addPackageFlags :: [Package] -> DynFlags -> DynFlags
addPackageFlags :: [Package] -> DynFlags -> DynFlags
addPackageFlags [Package]
pkgs DynFlags
df =
DynFlags
df { packageFlags :: [PackageFlag]
packageFlags = DynFlags -> [PackageFlag]
packageFlags DynFlags
df forall a. [a] -> [a] -> [a]
++ Package -> PackageFlag
expose forall a b. (a -> b) -> [a] -> [b]
`map` [Package]
pkgs }
where
expose :: Package -> PackageFlag
expose Package
pkg = FilePath -> PackageArg -> ModRenaming -> PackageFlag
ExposePackage FilePath
pkgid (FilePath -> PackageArg
PackageArg FilePath
name) (Bool -> [(ModuleName, ModuleName)] -> ModRenaming
ModRenaming Bool
True [])
where
(FilePath
name,FilePath
_,FilePath
_) = Package
pkg
pkgid :: FilePath
pkgid = Package -> FilePath
showPkgId Package
pkg