{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
module Seminal.Compiler.Runner (runCompiler) where
import Seminal.Compiler.API
import GHC.Paths (libdir) --  We dont import is from wrapped API because it's not provided by GHC
import Data.List (find)
import Text.Printf (printf)
import Control.Exception (try, SomeException)

type ErrorMessage = String

-- | Setup and run a GHC Session.
-- The file paths are the paths to the source files to load.
-- The action to run takes the list of loaded modules.
-- Upon error (file access, syntax, ...), throws
runCompiler :: forall a . [FilePath] -> ([(FilePath, ParsedModule)] -> Ghc a) -> IO (Either ErrorMessage a)
runCompiler :: forall a.
[FilePath]
-> ([(FilePath, ParsedModule)] -> Ghc a) -> IO (Either FilePath a)
runCompiler [FilePath]
filePaths [(FilePath, ParsedModule)] -> Ghc a
action = do
    Either SomeException a
res <- IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
session :: IO (Either SomeException a)
    Either FilePath a -> IO (Either FilePath a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath a -> IO (Either FilePath a))
-> Either FilePath a -> IO (Either FilePath a)
forall a b. (a -> b) -> a -> b
$ case Either SomeException a
res of
        Left SomeException
e -> FilePath -> Either FilePath a
forall a b. a -> Either a b
Left (FilePath -> Either FilePath a) -> FilePath -> Either FilePath a
forall a b. (a -> b) -> a -> b
$ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e
        Right a
r -> a -> Either FilePath a
forall a b. b -> Either a b
Right a
r
    where
        session :: IO a
session = Maybe FilePath -> Ghc a -> IO a
forall a. Maybe FilePath -> Ghc a -> IO a
runGhc (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
libdir) (Ghc a -> IO a) -> Ghc a -> IO a
forall a b. (a -> b) -> a -> b
$ do
            DynFlags
flags <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
            DynFlags -> Ghc ()
forall (m :: * -> *).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
setSessionDynFlags (DynFlags
flags {
                mainFunIs :: Maybe FilePath
mainFunIs = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"undefined",
                mainModuleNameIs :: ModuleName
mainModuleNameIs = FilePath -> ModuleName
mkModuleName FilePath
"Prelude",
                backend :: Backend
backend = Backend
noBackend,
                ghcLink :: GhcLink
ghcLink = GhcLink
NoLink,
                maxErrors :: Maybe Int
maxErrors = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0,
                extensionFlags :: EnumSet Extension
extensionFlags = Extension -> EnumSet Extension -> EnumSet Extension
forall a. Enum a => a -> EnumSet a -> EnumSet a
insert Extension
PartialTypeSignatures (DynFlags -> EnumSet Extension
extensionFlags DynFlags
flags)
                })
            [Target]
targets <- [FilePath] -> Ghc [Target]
guessTargets [FilePath]
filePaths
            [Target] -> Ghc ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
setTargets [Target]
targets
            SuccessFlag
_ <- LoadHowMuch -> Ghc SuccessFlag
forall (f :: * -> *). GhcMonad f => LoadHowMuch -> f SuccessFlag
load LoadHowMuch
LoadAllTargets
            ModuleGraph
modGraph <- [ModuleName] -> Bool -> Ghc ModuleGraph
forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m ModuleGraph
depanal [] Bool
True
            [(FilePath, ParsedModule)]
parseResults <- (FilePath -> Ghc (FilePath, ParsedModule))
-> [FilePath] -> Ghc [(FilePath, ParsedModule)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\FilePath
f -> (FilePath
f,) (ParsedModule -> (FilePath, ParsedModule))
-> Ghc ParsedModule -> Ghc (FilePath, ParsedModule)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleGraph -> FilePath -> Ghc ParsedModule
forall {m :: * -> *}.
GhcMonad m =>
ModuleGraph -> FilePath -> m ParsedModule
getModule ModuleGraph
modGraph FilePath
f) [FilePath]
filePaths
            [(FilePath, ParsedModule)] -> Ghc a
action [(FilePath, ParsedModule)]
parseResults
#if MIN_VERSION_ghc(9,4,1)
        guessTargets :: [FilePath] -> Ghc [Target]
guessTargets = (FilePath -> Ghc Target) -> [FilePath] -> Ghc [Target]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\FilePath
t -> FilePath -> Maybe UnitId -> Maybe Phase -> Ghc Target
forall (m :: * -> *).
GhcMonad m =>
FilePath -> Maybe UnitId -> Maybe Phase -> m Target
guessTarget FilePath
t Maybe UnitId
forall a. Maybe a
Nothing Maybe Phase
forall a. Maybe a
Nothing)
#else
        guessTargets = mapM (`guessTarget` Nothing)
#endif
        -- Retrieves the module of a file using its paths and the modgraph
        getModule :: ModuleGraph -> FilePath -> m ParsedModule
getModule ModuleGraph
modGraph FilePath
filePath = case (ModSummary -> Bool) -> [ModSummary] -> Maybe ModSummary
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
filePath) (FilePath -> Bool)
-> (ModSummary -> FilePath) -> ModSummary -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> FilePath
msHsFilePath) (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
modGraph) of
            -- Do not worry, this should never happen.
            Maybe ModSummary
Nothing -> GhcException -> m ParsedModule
forall a. GhcException -> a
throwGhcException (GhcException -> m ParsedModule) -> GhcException -> m ParsedModule
forall a b. (a -> b) -> a -> b
$ FilePath -> GhcException
Panic (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%s: Could not find module" FilePath
filePath) 
            Just ModSummary
modsum -> ModSummary -> m ParsedModule
forall (m :: * -> *). GhcMonad m => ModSummary -> m ParsedModule
parseModule ModSummary
modsum