{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
-- | Convenience functions for loading a file into a GHC API session
module HIE.Bios.Ghc.Load ( loadFileWithMessage, loadFile, setTargetFiles, setTargetFilesWithMessage) where


import Control.Monad (forM, void)
import Control.Monad.IO.Class

import Data.List
import Data.Time.Clock
import Data.IORef

import GHC
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 GhcMake as G
import qualified HscMain as G
#endif

import qualified HIE.Bios.Ghc.Gap as Gap
import qualified HIE.Bios.Internal.Log as Log

-- | Load a target into the GHC session.
--
-- The target is represented as a tuple. The tuple consists of the
-- original filename and another file that contains the actual
-- source code to compile.
--
-- The optional messager can be used to log diagnostics, warnings or errors
-- that occurred during loading the target.
--
-- If the loading succeeds, the typechecked module is returned
-- together with all the typechecked modules that had to be loaded
-- in order to typecheck the given target.
loadFileWithMessage :: GhcMonad m
         => Maybe G.Messager -- ^ Optional messager hook
                             -- to log messages produced by GHC.
         -> (FilePath, FilePath)  -- ^ Target file to load.
         -> m (Maybe TypecheckedModule, [TypecheckedModule])
         -- ^ Typechecked module and modules that had to
         -- be loaded for the target.
loadFileWithMessage :: Maybe Messager
-> (FilePath, FilePath)
-> m (Maybe TypecheckedModule, [TypecheckedModule])
loadFileWithMessage Maybe Messager
msg (FilePath, FilePath)
file = do
  -- STEP 1: Load the file into the session, using collectASTs to also retrieve
  -- typechecked and parsed modules.
  (()
_, [TypecheckedModule]
tcs) <- m () -> m ((), [TypecheckedModule])
forall (m :: * -> *) a.
GhcMonad m =>
m a -> m (a, [TypecheckedModule])
collectASTs (m () -> m ((), [TypecheckedModule]))
-> m () -> m ((), [TypecheckedModule])
forall a b. (a -> b) -> a -> b
$ (Maybe Messager -> [(FilePath, FilePath)] -> m ()
forall (m :: * -> *).
GhcMonad m =>
Maybe Messager -> [(FilePath, FilePath)] -> m ()
setTargetFilesWithMessage Maybe Messager
msg [(FilePath, FilePath)
file])
  FilePath -> m ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
Log.debugm (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"loaded " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst (FilePath, FilePath)
file FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" - " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> b
snd (FilePath, FilePath)
file
  let get_fp :: TypecheckedModule -> Maybe FilePath
get_fp = ModLocation -> Maybe FilePath
ml_hs_file (ModLocation -> Maybe FilePath)
-> (TypecheckedModule -> ModLocation)
-> TypecheckedModule
-> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> ModLocation
ms_location (ModSummary -> ModLocation)
-> (TypecheckedModule -> ModSummary)
-> TypecheckedModule
-> ModLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> ModSummary
pm_mod_summary (ParsedModule -> ModSummary)
-> (TypecheckedModule -> ParsedModule)
-> TypecheckedModule
-> ModSummary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypecheckedModule -> ParsedModule
tm_parsed_module
  FilePath -> m ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
Log.debugm (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Typechecked modules for: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ([FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ (TypecheckedModule -> FilePath)
-> [TypecheckedModule] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe FilePath -> FilePath
forall a. Show a => a -> FilePath
show (Maybe FilePath -> FilePath)
-> (TypecheckedModule -> Maybe FilePath)
-> TypecheckedModule
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypecheckedModule -> Maybe FilePath
get_fp) [TypecheckedModule]
tcs)
  -- Find the specific module in the list of returned typechecked modules if it exists.
  let findMod :: [TypecheckedModule] -> Maybe TypecheckedModule
findMod [] = Maybe TypecheckedModule
forall a. Maybe a
Nothing
      findMod (TypecheckedModule
x:[TypecheckedModule]
xs) = case TypecheckedModule -> Maybe FilePath
get_fp TypecheckedModule
x of
                         Just FilePath
fp -> if FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` ((FilePath, FilePath) -> FilePath
forall a b. (a, b) -> b
snd (FilePath, FilePath)
file) then TypecheckedModule -> Maybe TypecheckedModule
forall a. a -> Maybe a
Just TypecheckedModule
x else [TypecheckedModule] -> Maybe TypecheckedModule
findMod [TypecheckedModule]
xs
                         Maybe FilePath
Nothing -> [TypecheckedModule] -> Maybe TypecheckedModule
findMod [TypecheckedModule]
xs
  (Maybe TypecheckedModule, [TypecheckedModule])
-> m (Maybe TypecheckedModule, [TypecheckedModule])
forall (m :: * -> *) a. Monad m => a -> m a
return ([TypecheckedModule] -> Maybe TypecheckedModule
findMod [TypecheckedModule]
tcs, [TypecheckedModule]
tcs)

-- | Load a target into the GHC session with the default messager
--  which outputs updates in the same format as normal GHC.
--
-- The target is represented as a tuple. The tuple consists of the
-- original filename and another file that contains the actual
-- source code to compile.
--
-- If the message should configured, use 'loadFileWithMessage'.
--
-- If the loading succeeds, the typechecked module is returned
-- together with all the typechecked modules that had to be loaded
-- in order to typecheck the given target.
loadFile :: (GhcMonad m)
         => (FilePath, FilePath) -- ^ Target file to load.
         -> m (Maybe TypecheckedModule, [TypecheckedModule])
         -- ^ Typechecked module and modules that had to
         -- be loaded for the target.
loadFile :: (FilePath, FilePath)
-> m (Maybe TypecheckedModule, [TypecheckedModule])
loadFile = Maybe Messager
-> (FilePath, FilePath)
-> m (Maybe TypecheckedModule, [TypecheckedModule])
forall (m :: * -> *).
GhcMonad m =>
Maybe Messager
-> (FilePath, FilePath)
-> m (Maybe TypecheckedModule, [TypecheckedModule])
loadFileWithMessage (Messager -> Maybe Messager
forall a. a -> Maybe a
Just Messager
G.batchMsg)


-- | Set the files as targets and load them. This will reset GHC's targets so only the modules you
-- set as targets and its dependencies will be loaded or reloaded.
-- Produced diagnostics will be printed similar to the normal output of GHC.
-- To configure this, use 'setTargetFilesWithMessage'.
setTargetFiles :: GhcMonad m => [(FilePath, FilePath)] -> m ()
setTargetFiles :: [(FilePath, FilePath)] -> m ()
setTargetFiles = Maybe Messager -> [(FilePath, FilePath)] -> m ()
forall (m :: * -> *).
GhcMonad m =>
Maybe Messager -> [(FilePath, FilePath)] -> m ()
setTargetFilesWithMessage (Messager -> Maybe Messager
forall a. a -> Maybe a
Just Messager
G.batchMsg)

msTargetIs :: ModSummary -> Target -> Bool
msTargetIs :: ModSummary -> Target -> Bool
msTargetIs ModSummary
ms Target
t = case Target -> TargetId
targetId Target
t of
  TargetModule ModuleName
m -> Module -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
ms) ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
m
  TargetFile FilePath
f Maybe Phase
_ -> ModLocation -> Maybe FilePath
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
ms) Maybe FilePath -> Maybe FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
f

-- | We bump the times for any ModSummary's that are Targets, to
-- fool the recompilation checker so that we can get the typechecked modules
updateTime :: MonadIO m => [Target] -> ModuleGraph -> m ModuleGraph
updateTime :: [Target] -> ModuleGraph -> m ModuleGraph
updateTime [Target]
ts ModuleGraph
graph = IO ModuleGraph -> m ModuleGraph
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModuleGraph -> m ModuleGraph)
-> IO ModuleGraph -> m ModuleGraph
forall a b. (a -> b) -> a -> b
$ do
  UTCTime
cur_time <- IO UTCTime
getCurrentTime
  let go :: ModSummary -> ModSummary
go ModSummary
ms
        | (Target -> Bool) -> [Target] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ModSummary -> Target -> Bool
msTargetIs ModSummary
ms) [Target]
ts = ModSummary
ms {ms_hs_date :: UTCTime
ms_hs_date = UTCTime
cur_time}
        | Bool
otherwise = ModSummary
ms
  ModuleGraph -> IO ModuleGraph
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModuleGraph -> IO ModuleGraph) -> ModuleGraph -> IO ModuleGraph
forall a b. (a -> b) -> a -> b
$ (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph
Gap.mapMG ModSummary -> ModSummary
go ModuleGraph
graph

-- | Set the files as targets and load them. This will reset GHC's targets so only the modules you
-- set as targets and its dependencies will be loaded or reloaded.
setTargetFilesWithMessage :: (GhcMonad m)  => Maybe G.Messager -> [(FilePath, FilePath)] -> m ()
setTargetFilesWithMessage :: Maybe Messager -> [(FilePath, FilePath)] -> m ()
setTargetFilesWithMessage Maybe Messager
msg [(FilePath, FilePath)]
files = do
    [Target]
targets <- [(FilePath, FilePath)]
-> ((FilePath, FilePath) -> m Target) -> m [Target]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(FilePath, FilePath)]
files (FilePath, FilePath) -> m Target
forall (m :: * -> *).
GhcMonad m =>
(FilePath, FilePath) -> m Target
guessTargetMapped
    FilePath -> m ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
Log.debugm (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"setTargets: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [(FilePath, FilePath)] -> FilePath
forall a. Show a => a -> FilePath
show [(FilePath, FilePath)]
files
    [Target] -> m ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
G.setTargets [Target]
targets
    ModuleGraph
mod_graph <- [Target] -> ModuleGraph -> m ModuleGraph
forall (m :: * -> *).
MonadIO m =>
[Target] -> ModuleGraph -> m ModuleGraph
updateTime [Target]
targets (ModuleGraph -> m ModuleGraph) -> m ModuleGraph -> m ModuleGraph
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [ModuleName] -> Bool -> m ModuleGraph
forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m ModuleGraph
depanal [] Bool
False
    FilePath -> m ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
Log.debugm (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"modGraph: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [ModLocation] -> FilePath
forall a. Show a => a -> FilePath
show ((ModSummary -> ModLocation) -> [ModSummary] -> [ModLocation]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModLocation
ms_location ([ModSummary] -> [ModLocation]) -> [ModSummary] -> [ModLocation]
forall a b. (a -> b) -> a -> b
$ ModuleGraph -> [ModSummary]
Gap.mgModSummaries ModuleGraph
mod_graph)
    m SuccessFlag -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m SuccessFlag -> m ()) -> m SuccessFlag -> m ()
forall a b. (a -> b) -> a -> b
$ 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

-- | Add a hook to record the contents of any 'TypecheckedModule's which are produced
-- during compilation.
collectASTs :: (GhcMonad m) => m a -> m (a, [TypecheckedModule])
collectASTs :: m a -> m (a, [TypecheckedModule])
collectASTs m a
action = do
  IORef [TypecheckedModule]
ref1 <- IO (IORef [TypecheckedModule]) -> m (IORef [TypecheckedModule])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [TypecheckedModule]) -> m (IORef [TypecheckedModule]))
-> IO (IORef [TypecheckedModule]) -> m (IORef [TypecheckedModule])
forall a b. (a -> b) -> a -> b
$ [TypecheckedModule] -> IO (IORef [TypecheckedModule])
forall a. a -> IO (IORef a)
newIORef []
  -- Modify session is much faster than `setSessionDynFlags`.
  (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
Gap.modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe (ModSummary -> Hsc FrontendResult) -> HscEnv -> HscEnv
Gap.setFrontEndHooks ((ModSummary -> Hsc FrontendResult)
-> Maybe (ModSummary -> Hsc FrontendResult)
forall a. a -> Maybe a
Just (IORef [TypecheckedModule] -> ModSummary -> Hsc FrontendResult
astHook IORef [TypecheckedModule]
ref1))
  a
res <- m a
action
  [TypecheckedModule]
tcs <- IO [TypecheckedModule] -> m [TypecheckedModule]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [TypecheckedModule] -> m [TypecheckedModule])
-> IO [TypecheckedModule] -> m [TypecheckedModule]
forall a b. (a -> b) -> a -> b
$ IORef [TypecheckedModule] -> IO [TypecheckedModule]
forall a. IORef a -> IO a
readIORef IORef [TypecheckedModule]
ref1
  -- Unset the hook so that we don't retain the reference ot the IORef so it can be gced.
  -- This stops the typechecked modules being retained in some cases.
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [TypecheckedModule] -> [TypecheckedModule] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [TypecheckedModule]
ref1 []
  (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
Gap.modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe (ModSummary -> Hsc FrontendResult) -> HscEnv -> HscEnv
Gap.setFrontEndHooks Maybe (ModSummary -> Hsc FrontendResult)
forall a. Maybe a
Nothing

  (a, [TypecheckedModule]) -> m (a, [TypecheckedModule])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, [TypecheckedModule]
tcs)

-- | This hook overwrites the default frontend action of GHC.
astHook :: IORef [TypecheckedModule] -> ModSummary -> Gap.Hsc Gap.FrontendResult
astHook :: IORef [TypecheckedModule] -> ModSummary -> Hsc FrontendResult
astHook IORef [TypecheckedModule]
tc_ref ModSummary
ms = Ghc FrontendResult -> Hsc FrontendResult
forall a. Ghc a -> Hsc a
ghcInHsc (Ghc FrontendResult -> Hsc FrontendResult)
-> Ghc FrontendResult -> Hsc FrontendResult
forall a b. (a -> b) -> a -> b
$ do
  ParsedModule
p <- ModSummary -> Ghc ParsedModule
forall (m :: * -> *). GhcMonad m => ModSummary -> m ParsedModule
G.parseModule (ModSummary -> Ghc ParsedModule)
-> Ghc ModSummary -> Ghc ParsedModule
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ModSummary -> Ghc ModSummary
initializePluginsGhc ModSummary
ms
  TypecheckedModule
tcm <- ParsedModule -> Ghc TypecheckedModule
forall (m :: * -> *).
GhcMonad m =>
ParsedModule -> m TypecheckedModule
G.typecheckModule ParsedModule
p
  let tcg_env :: TcGblEnv
tcg_env = (TcGblEnv, ModDetails) -> TcGblEnv
forall a b. (a, b) -> a
fst (TypecheckedModule -> (TcGblEnv, ModDetails)
tm_internals_ TypecheckedModule
tcm)
  IO () -> Ghc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ IORef [TypecheckedModule]
-> ([TypecheckedModule] -> [TypecheckedModule]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [TypecheckedModule]
tc_ref (TypecheckedModule
tcm TypecheckedModule -> [TypecheckedModule] -> [TypecheckedModule]
forall a. a -> [a] -> [a]
:)
  FrontendResult -> Ghc FrontendResult
forall (m :: * -> *) a. Monad m => a -> m a
return (FrontendResult -> Ghc FrontendResult)
-> FrontendResult -> Ghc FrontendResult
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> FrontendResult
Gap.FrontendTypecheck TcGblEnv
tcg_env

initializePluginsGhc :: ModSummary -> Ghc ModSummary
initializePluginsGhc :: ModSummary -> Ghc ModSummary
initializePluginsGhc ModSummary
ms = do
  HscEnv
hsc_env <- Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  (Int
pluginsLoaded, [ModuleName]
pluginNames, ModSummary
newMs) <- IO (Int, [ModuleName], ModSummary)
-> Ghc (Int, [ModuleName], ModSummary)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Int, [ModuleName], ModSummary)
 -> Ghc (Int, [ModuleName], ModSummary))
-> IO (Int, [ModuleName], ModSummary)
-> Ghc (Int, [ModuleName], ModSummary)
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> IO (Int, [ModuleName], ModSummary)
Gap.initializePluginsForModSummary HscEnv
hsc_env ModSummary
ms
  FilePath -> Ghc ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
Log.debugm (FilePath
"init-plugins(loaded):" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
pluginsLoaded)
  FilePath -> Ghc ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
Log.debugm (FilePath
"init-plugins(specified):" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show ([ModuleName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ModuleName]
pluginNames))
  ModSummary -> Ghc ModSummary
forall (m :: * -> *) a. Monad m => a -> m a
return ModSummary
newMs


ghcInHsc :: Ghc a -> Gap.Hsc a
ghcInHsc :: Ghc a -> Hsc a
ghcInHsc Ghc a
gm = do
  HscEnv
hsc_session <- Hsc HscEnv
Gap.getHscEnv
  IORef HscEnv
session <- IO (IORef HscEnv) -> Hsc (IORef HscEnv)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef HscEnv) -> Hsc (IORef HscEnv))
-> IO (IORef HscEnv) -> Hsc (IORef HscEnv)
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO (IORef HscEnv)
forall a. a -> IO (IORef a)
newIORef HscEnv
hsc_session
  IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Hsc a) -> IO a -> Hsc a
forall a b. (a -> b) -> a -> b
$ Ghc a -> Session -> IO a
forall a. Ghc a -> Session -> IO a
Gap.reflectGhc Ghc a
gm (IORef HscEnv -> Session
Gap.Session IORef HscEnv
session)

-- | A variant of 'guessTarget' which after guessing the target for a filepath, overwrites the
-- target file to be a temporary file.
guessTargetMapped :: (GhcMonad m) => (FilePath, FilePath) -> m Target
guessTargetMapped :: (FilePath, FilePath) -> m Target
guessTargetMapped (FilePath
orig_file_name, FilePath
mapped_file_name) = do
  Target
t <- FilePath -> Maybe Phase -> m Target
forall (m :: * -> *).
GhcMonad m =>
FilePath -> Maybe Phase -> m Target
Gap.guessTarget FilePath
orig_file_name Maybe Phase
forall a. Maybe a
Nothing
  Target -> m Target
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Target -> Target
setTargetFilename FilePath
mapped_file_name Target
t)

setTargetFilename :: FilePath -> Target -> Target
setTargetFilename :: FilePath -> Target -> Target
setTargetFilename FilePath
fn Target
t =
  Target
t { targetId :: TargetId
targetId = case Target -> TargetId
targetId Target
t of
                  TargetFile FilePath
_ Maybe Phase
p -> FilePath -> Maybe Phase -> TargetId
TargetFile FilePath
fn Maybe Phase
p
                  TargetId
tid -> TargetId
tid }