{-# LANGUAGE ScopedTypeVariables, CPP #-}
-- | These functions are for conveniently implementing the simple CLI
module HIE.Bios.Ghc.Api (
    initializeFlagsWithCradle
  , initializeFlagsWithCradleWithMessage
  , G.SuccessFlag(..)
  , withDynFlags
  ) where

import GHC (LoadHowMuch(..), DynFlags, GhcMonad)
import qualified GHC as G

#if __GLASGOW_HASKELL__ >= 900
import qualified GHC.Driver.Main as G
import qualified GHC.Driver.Make as G
#else
import qualified HscMain as G
import qualified GhcMake as G
#endif

import qualified HIE.Bios.Ghc.Gap as Gap
import Control.Monad (void)
import Control.Monad.IO.Class
import HIE.Bios.Types
import HIE.Bios.Environment
import HIE.Bios.Flags

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

-- | Initialize a GHC session by loading a given file into a given cradle.
initializeFlagsWithCradle ::
    GhcMonad m
    => FilePath -- ^ The file we are loading the 'Cradle' because of
    -> Cradle a   -- ^ The cradle we want to load
    -> m (CradleLoadResult (m G.SuccessFlag, ComponentOptions))
initializeFlagsWithCradle :: FilePath
-> Cradle a
-> m (CradleLoadResult (m SuccessFlag, ComponentOptions))
initializeFlagsWithCradle = Maybe Messager
-> FilePath
-> Cradle a
-> m (CradleLoadResult (m SuccessFlag, ComponentOptions))
forall (m :: * -> *) a.
GhcMonad m =>
Maybe Messager
-> FilePath
-> Cradle a
-> m (CradleLoadResult (m SuccessFlag, ComponentOptions))
initializeFlagsWithCradleWithMessage (Messager -> Maybe Messager
forall a. a -> Maybe a
Just Messager
Gap.batchMsg)

-- | The same as 'initializeFlagsWithCradle' but with an additional argument to control
-- how the loading progress messages are displayed to the user. In @haskell-ide-engine@
-- the module loading progress is displayed in the UI by using a progress notification.
initializeFlagsWithCradleWithMessage ::
  GhcMonad m
  => Maybe G.Messager
  -> FilePath -- ^ The file we are loading the 'Cradle' because of
  -> Cradle a  -- ^ The cradle we want to load
  -> m (CradleLoadResult (m G.SuccessFlag, ComponentOptions)) -- ^ Whether we actually loaded the cradle or not.
initializeFlagsWithCradleWithMessage :: Maybe Messager
-> FilePath
-> Cradle a
-> m (CradleLoadResult (m SuccessFlag, ComponentOptions))
initializeFlagsWithCradleWithMessage Maybe Messager
msg FilePath
fp Cradle a
cradle =
    (ComponentOptions -> (m SuccessFlag, ComponentOptions))
-> CradleLoadResult ComponentOptions
-> CradleLoadResult (m SuccessFlag, ComponentOptions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Messager
-> ComponentOptions -> (m SuccessFlag, ComponentOptions)
forall (m :: * -> *).
GhcMonad m =>
Maybe Messager
-> ComponentOptions -> (m SuccessFlag, ComponentOptions)
initSessionWithMessage Maybe Messager
msg) (CradleLoadResult ComponentOptions
 -> CradleLoadResult (m SuccessFlag, ComponentOptions))
-> m (CradleLoadResult ComponentOptions)
-> m (CradleLoadResult (m SuccessFlag, ComponentOptions))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (CradleLoadResult ComponentOptions)
-> m (CradleLoadResult ComponentOptions)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> Cradle a -> IO (CradleLoadResult ComponentOptions)
forall a.
FilePath -> Cradle a -> IO (CradleLoadResult ComponentOptions)
getCompilerOptions FilePath
fp Cradle a
cradle)

-- | Actually perform the initialisation of the session. Initialising the session corresponds to
-- parsing the command line flags, setting the targets for the session and then attempting to load
-- all the targets.
initSessionWithMessage :: (GhcMonad m)
            => Maybe G.Messager
            -> ComponentOptions
            -> (m G.SuccessFlag, ComponentOptions)
initSessionWithMessage :: Maybe Messager
-> ComponentOptions -> (m SuccessFlag, ComponentOptions)
initSessionWithMessage Maybe Messager
msg ComponentOptions
compOpts = (do
    [Target]
targets <- ComponentOptions -> m [Target]
forall (m :: * -> *). GhcMonad m => ComponentOptions -> m [Target]
initSession ComponentOptions
compOpts
    [Target] -> m ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
G.setTargets [Target]
targets
    -- Get the module graph using the function `getModuleGraph`
    ModuleGraph
mod_graph <- [ModuleName] -> Bool -> m ModuleGraph
forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m ModuleGraph
G.depanal [] Bool
True
    LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
forall (m :: * -> *).
GhcMonad m =>
LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
G.load' LoadHowMuch
LoadAllTargets Maybe Messager
msg ModuleGraph
mod_graph, ComponentOptions
compOpts)

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

withDynFlags ::
  (GhcMonad m)
  => (DynFlags -> DynFlags) -> m a -> m a
withDynFlags :: (DynFlags -> DynFlags) -> m a -> m a
withDynFlags DynFlags -> DynFlags
setFlag m a
body = m DynFlags -> (DynFlags -> m ()) -> (DynFlags -> m a) -> m a
forall (m :: * -> *) a c b.
ExceptionMonad m =>
m a -> (a -> m c) -> (a -> m b) -> m b
Gap.bracket m DynFlags
setup DynFlags -> m ()
teardown (\DynFlags
_ -> m a
body)
  where
    setup :: m DynFlags
setup = do
        DynFlags
dflag <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
G.getSessionDynFlags
        m [InstalledUnitId] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m [InstalledUnitId] -> m ()) -> m [InstalledUnitId] -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> m [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
G.setSessionDynFlags (DynFlags -> DynFlags
setFlag DynFlags
dflag)
        DynFlags -> m DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflag
    teardown :: DynFlags -> m ()
teardown = m [InstalledUnitId] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m [InstalledUnitId] -> m ())
-> (DynFlags -> m [InstalledUnitId]) -> DynFlags -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> m [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
G.setSessionDynFlags

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