{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
-- | Convenience functions for loading a file into a GHC API session
module HIE.Bios.Ghc.Load  where


import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&))
import Control.Monad (forM, void)
import Control.Monad.IO.Class

import Data.List
import Data.Time.Clock
import Data.Text.Prettyprint.Doc
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 GHC.Fingerprint

data Log =
  LogLoaded FilePath FilePath
  | LogTypechecked [TypecheckedModule]
  | LogInitPlugins Int [ModuleName]
  | LogSetTargets [(FilePath, FilePath)]
  | LogModGraph ModuleGraph

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty (LogLoaded FilePath
fp1 FilePath
fp2) = Doc ann
"Loaded" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow FilePath
fp1 forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"-" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow FilePath
fp2
  pretty (LogTypechecked [TypecheckedModule]
tcs) = Doc ann
"Typechecked modules for:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> (forall ann. [Doc ann] -> Doc ann
cat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a ann. Show a => a -> Doc ann
viaShow forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypecheckedModule -> Maybe FilePath
get_fp) [TypecheckedModule]
tcs)
  pretty (LogInitPlugins Int
n [ModuleName]
ns) = Doc ann
"Loaded" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow Int
n forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"plugins, specified" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ModuleName]
ns)
  pretty (LogSetTargets [(FilePath, FilePath)]
ts) = Doc ann
"Set targets:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow [(FilePath, FilePath)]
ts
  pretty (LogModGraph ModuleGraph
mod_graph) = Doc ann
"ModGraph:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow (forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModLocation
ms_location forall a b. (a -> b) -> a -> b
$ ModuleGraph -> [ModSummary]
Gap.mgModSummaries ModuleGraph
mod_graph)

get_fp :: TypecheckedModule -> Maybe FilePath
get_fp :: TypecheckedModule -> Maybe FilePath
get_fp = ModLocation -> Maybe FilePath
ml_hs_file forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> ModLocation
ms_location forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> ModSummary
pm_mod_summary forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypecheckedModule -> ParsedModule
tm_parsed_module

-- | 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
         => LogAction IO (WithSeverity Log)
         -> 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 :: forall (m :: * -> *).
GhcMonad m =>
LogAction IO (WithSeverity Log)
-> Maybe Messager
-> (FilePath, FilePath)
-> m (Maybe TypecheckedModule, [TypecheckedModule])
loadFileWithMessage LogAction IO (WithSeverity Log)
logger 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) <- forall (m :: * -> *) a.
GhcMonad m =>
LogAction IO (WithSeverity Log)
-> m a -> m (a, [TypecheckedModule])
collectASTs LogAction IO (WithSeverity Log)
logger forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *).
GhcMonad m =>
LogAction IO (WithSeverity Log)
-> Maybe Messager -> [(FilePath, FilePath)] -> m ()
setTargetFilesWithMessage LogAction IO (WithSeverity Log)
logger Maybe Messager
msg [(FilePath, FilePath)
file])
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ LogAction IO (WithSeverity Log)
logger forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& FilePath -> FilePath -> Log
LogLoaded (forall a b. (a, b) -> a
fst (FilePath, FilePath)
file) (forall a b. (a, b) -> b
snd (FilePath, FilePath)
file) forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ LogAction IO (WithSeverity Log)
logger forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& [TypecheckedModule] -> Log
LogTypechecked [TypecheckedModule]
tcs forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
  -- Find the specific module in the list of returned typechecked modules if it exists.
  let findMod :: [TypecheckedModule] -> Maybe TypecheckedModule
findMod [] = 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 forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` (forall a b. (a, b) -> b
snd (FilePath, FilePath)
file) then forall a. a -> Maybe a
Just TypecheckedModule
x else [TypecheckedModule] -> Maybe TypecheckedModule
findMod [TypecheckedModule]
xs
                         Maybe FilePath
Nothing -> [TypecheckedModule] -> Maybe TypecheckedModule
findMod [TypecheckedModule]
xs
  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)
         => LogAction IO (WithSeverity Log)
         -> (FilePath, FilePath) -- ^ Target file to load.
         -> m (Maybe TypecheckedModule, [TypecheckedModule])
         -- ^ Typechecked module and modules that had to
         -- be loaded for the target.
loadFile :: forall (m :: * -> *).
GhcMonad m =>
LogAction IO (WithSeverity Log)
-> (FilePath, FilePath)
-> m (Maybe TypecheckedModule, [TypecheckedModule])
loadFile LogAction IO (WithSeverity Log)
logger = forall (m :: * -> *).
GhcMonad m =>
LogAction IO (WithSeverity Log)
-> Maybe Messager
-> (FilePath, FilePath)
-> m (Maybe TypecheckedModule, [TypecheckedModule])
loadFileWithMessage LogAction IO (WithSeverity Log)
logger (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
  => LogAction IO (WithSeverity Log)
  -> [(FilePath, FilePath)]
  -> m ()
setTargetFiles :: forall (m :: * -> *).
GhcMonad m =>
LogAction IO (WithSeverity Log) -> [(FilePath, FilePath)] -> m ()
setTargetFiles LogAction IO (WithSeverity Log)
logger = forall (m :: * -> *).
GhcMonad m =>
LogAction IO (WithSeverity Log)
-> Maybe Messager -> [(FilePath, FilePath)] -> m ()
setTargetFilesWithMessage LogAction IO (WithSeverity Log)
logger (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 -> forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
ms) 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) forall a. Eq a => a -> a -> Bool
== 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 :: forall (m :: * -> *).
MonadIO m =>
[Target] -> ModuleGraph -> m ModuleGraph
updateTime [Target]
ts ModuleGraph
graph = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  UTCTime
cur_time <- IO UTCTime
getCurrentTime
  let go :: ModSummary -> ModSummary
go ModSummary
ms
        | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ModSummary -> Target -> Bool
msTargetIs ModSummary
ms) [Target]
ts =
#if __GLASGOW_HASKELL__ >= 903
            ms {ms_hs_hash = fingerprint0}
#else
            ModSummary
ms {ms_hs_date :: UTCTime
ms_hs_date = UTCTime
cur_time}
#endif
        | Bool
otherwise = ModSummary
ms
  forall (f :: * -> *) a. Applicative f => a -> f a
pure 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)
  => LogAction IO (WithSeverity Log)
  -> Maybe G.Messager
  -> [(FilePath, FilePath)]
  -> m ()
setTargetFilesWithMessage :: forall (m :: * -> *).
GhcMonad m =>
LogAction IO (WithSeverity Log)
-> Maybe Messager -> [(FilePath, FilePath)] -> m ()
setTargetFilesWithMessage LogAction IO (WithSeverity Log)
logger Maybe Messager
msg [(FilePath, FilePath)]
files = do
    [Target]
targets <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(FilePath, FilePath)]
files forall (m :: * -> *).
GhcMonad m =>
(FilePath, FilePath) -> m Target
guessTargetMapped
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ LogAction IO (WithSeverity Log)
logger forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& [(FilePath, FilePath)] -> Log
LogSetTargets [(FilePath, FilePath)]
files forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
    forall (m :: * -> *). GhcMonad m => [Target] -> m ()
G.setTargets [Target]
targets
    ModuleGraph
mod_graph <- forall (m :: * -> *).
MonadIO m =>
[Target] -> ModuleGraph -> m ModuleGraph
updateTime [Target]
targets forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m ModuleGraph
depanal [] Bool
False
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ LogAction IO (WithSeverity Log)
logger forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& ModuleGraph -> Log
LogModGraph ModuleGraph
mod_graph forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
GhcMonad m =>
a -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
Gap.load' forall a. Maybe a
Nothing 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)
  => LogAction IO (WithSeverity Log)
  -> m a
  -> m (a, [TypecheckedModule])
collectASTs :: forall (m :: * -> *) a.
GhcMonad m =>
LogAction IO (WithSeverity Log)
-> m a -> m (a, [TypecheckedModule])
collectASTs LogAction IO (WithSeverity Log)
logger m a
action = do
  IORef [TypecheckedModule]
ref1 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef []
  -- Modify session is much faster than `setSessionDynFlags`.
  forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
Gap.modifySession forall a b. (a -> b) -> a -> b
$ Maybe (ModSummary -> Hsc FrontendResult) -> HscEnv -> HscEnv
Gap.setFrontEndHooks (forall a. a -> Maybe a
Just (LogAction IO (WithSeverity Log)
-> IORef [TypecheckedModule] -> ModSummary -> Hsc FrontendResult
astHook LogAction IO (WithSeverity Log)
logger IORef [TypecheckedModule]
ref1))
  a
res <- m a
action
  [TypecheckedModule]
tcs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef [TypecheckedModule]
ref1
  -- Unset the hook so that we don't retain the reference to the IORef so it can be GCed.
  -- This stops the typechecked modules being retained in some cases.
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef [TypecheckedModule]
ref1 []
  forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
Gap.modifySession forall a b. (a -> b) -> a -> b
$ Maybe (ModSummary -> Hsc FrontendResult) -> HscEnv -> HscEnv
Gap.setFrontEndHooks forall a. Maybe a
Nothing

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

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

initializePluginsGhc
  :: GhcMonad m
  => LogAction IO (WithSeverity Log)
  -> ModSummary
  -> m ModSummary
initializePluginsGhc :: forall (m :: * -> *).
GhcMonad m =>
LogAction IO (WithSeverity Log) -> ModSummary -> m ModSummary
initializePluginsGhc LogAction IO (WithSeverity Log)
logger ModSummary
ms = do
  HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  (Int
pluginsLoaded, [ModuleName]
pluginNames, ModSummary
newMs) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> IO (Int, [ModuleName], ModSummary)
Gap.initializePluginsForModSummary HscEnv
hsc_env ModSummary
ms
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ LogAction IO (WithSeverity Log)
logger forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Int -> [ModuleName] -> Log
LogInitPlugins Int
pluginsLoaded [ModuleName]
pluginNames forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
  forall (m :: * -> *) a. Monad m => a -> m a
return ModSummary
newMs

ghcInHsc :: Ghc a -> Gap.Hsc a
ghcInHsc :: forall a. Ghc a -> Hsc a
ghcInHsc Ghc a
gm = do
  HscEnv
hsc_session <- Hsc HscEnv
Gap.getHscEnv
  IORef HscEnv
session <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef HscEnv
hsc_session
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 :: forall (m :: * -> *).
GhcMonad m =>
(FilePath, FilePath) -> m Target
guessTargetMapped (FilePath
orig_file_name, FilePath
mapped_file_name) = do
  DynFlags
df <- forall (m :: * -> *). HasDynFlags m => m DynFlags
Gap.getDynFlags
  Target
t <- forall (m :: * -> *) a.
GhcMonad m =>
FilePath -> a -> Maybe Phase -> m Target
Gap.guessTarget FilePath
orig_file_name (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ DynFlags -> UnitId
Gap.homeUnitId_ DynFlags
df) forall a. Maybe a
Nothing
  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 }