{-# 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

----------------------------------------------------------------

-- | Obtaining the directory for system libraries.
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)

----------------------------------------------------------------

-- | Converting the 'Ghc' monad to the 'IO' monad.
withGHC :: FilePath  -- ^ A target file displayed in an error message.
        -> Ghc a -- ^ 'Ghc' actions created by the Ghc utilities.
        -> 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

-- | Initialize the 'DynFlags' relating to the compilation of a single
-- file or GHC session according to the 'Cradle' and 'Options'
-- provided.
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

-- At the moment with this option set ghc only prints different error messages,
-- suggesting the user to add a hidden package to the build-depends in his cabal
-- file for example
setCabalPackage :: Build -> DynFlags -> DynFlags
setCabalPackage :: Build -> DynFlags -> DynFlags
setCabalPackage Build
CabalPkg DynFlags
df = DynFlags -> DynFlags
setCabalPkg DynFlags
df
setCabalPackage Build
_ DynFlags
df = DynFlags
df

-- | Enable hiding of all package not explicitly exposed (like Cabal does)
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

-- | Parse command line ghc options and add them to the 'DynFlags' passed
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

----------------------------------------------------------------

-- | Set the files as targets and load them.
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

----------------------------------------------------------------

-- | Return the 'DynFlags' currently in use in the GHC session.
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

----------------------------------------------------------------

-- | Set 'DynFlags' equivalent to "-fdefer-typed-holes"
setDeferTypedHoles :: DynFlags -> DynFlags
setDeferTypedHoles :: DynFlags -> DynFlags
setDeferTypedHoles DynFlags
dflag = DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dflag GeneralFlag
G.Opt_DeferTypedHoles

-- | Set 'DynFlags' equivalent to "-fdefer-type-errors"
setDeferTypeErrors :: DynFlags -> DynFlags
setDeferTypeErrors :: DynFlags -> DynFlags
setDeferTypeErrors DynFlags
dflag = DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dflag GeneralFlag
G.Opt_DeferTypeErrors

-- | Set 'DynFlags' equivalent to "-Wtyped-holes"
setWarnTypedHoles :: DynFlags -> DynFlags
setWarnTypedHoles :: DynFlags -> DynFlags
setWarnTypedHoles DynFlags
dflag = DynFlags -> WarningFlag -> DynFlags
wopt_set DynFlags
dflag WarningFlag
Opt_WarnTypedHoles

-- | Set 'DynFlags' equivalent to "-XPartialTypeSignatures"
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

-- | Set 'DynFlags' equivalent to "-w:".
setNoWarningFlags :: DynFlags -> DynFlags
setNoWarningFlags :: DynFlags -> DynFlags
setNoWarningFlags DynFlags
df = DynFlags
df { warningFlags :: EnumSet WarningFlag
warningFlags = forall a. EnumSet a
E.empty}

-- | Set 'DynFlags' equivalent to "-Wall".
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