{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
module Clash.Main (defaultMain, defaultMainWithAction) where
import qualified GHC
import GHC (parseTargetFiles, Ghc, GhcMonad(..),
LoadHowMuch(..) )
import GHC.Driver.Backend
import GHC.Driver.CmdLine
import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Driver.Phases
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Driver.Pipeline ( oneShot, compileFile )
import GHC.Driver.MakeFile ( doMkDependHS )
import GHC.Driver.Backpack ( doBackpack )
import GHC.Driver.Plugins
import GHC.Driver.Config.Logger (initLogFlags)
import GHC.Driver.Config.Diagnostic
import GHC.Platform
import GHC.Platform.Ways
import GHC.Platform.Host
#if defined(HAVE_INTERNAL_INTERPRETER)
import Clash.GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )
#endif
import GHC.Runtime.Loader ( loadFrontendPlugin, initializeSessionPlugins )
import GHC.Unit.Env
import GHC.Unit (UnitId, homeUnitDepends)
import GHC.Unit.Home.ModInfo (emptyHomePackageTable)
import GHC.Unit.Module ( ModuleName, mkModuleName )
import GHC.Unit.Module.ModIface
import GHC.Unit.State ( pprUnits, pprUnitsSimple )
import GHC.Unit.Finder ( findImportedModule, FindResult(..) )
import qualified GHC.Unit.State as State
import GHC.Unit.Types ( IsBootInterface(..) )
import GHC.Types.Basic ( failed )
import GHC.Types.SrcLoc
import GHC.Types.SourceError
import GHC.Types.Unique.Supply
import GHC.Types.PkgQual
import GHC.Utils.Error
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Monad ( liftIO, mapMaybeM )
import GHC.Utils.Binary ( openBinMem, put_ )
import GHC.Utils.Logger
import GHC.Settings.Config
import GHC.Settings.Constants
import GHC.Settings.IO
import GHC.HandleEncoding
import GHC.Data.FastString
import GHC.SysTools.BaseDir
import GHC.Iface.Load
import GHC.Iface.Recomp.Binary ( fingerprintBinMem )
import GHC.Tc.Utils.Monad ( initIfaceCheck )
import System.FilePath
import System.IO
import System.Environment
import System.Exit
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except (throwE, runExceptT)
import Data.Char
import Data.List ( partition, intercalate, (\\) )
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Maybe
import Prelude
import GHC.ResponseFile (expandResponse)
import Data.Bifunctor
import GHC.Data.Graph.Directed
import qualified Data.List.NonEmpty as NE
import Paths_clash_ghc
import Clash.GHCi.UI (makeHDL)
import Control.Monad.Catch (catch)
import Data.List (nub)
import Data.Proxy
import Data.IORef (IORef, newIORef, readIORef, modifyIORef')
import qualified Data.Version (showVersion)
import GHC.Data.EnumSet as EnumSet
import GHC.Driver.Session as Session
import Clash.Backend (Backend)
import Clash.Backend.SystemVerilog (SystemVerilogState)
import Clash.Backend.VHDL (VHDLState)
import Clash.Backend.Verilog (VerilogState)
import Clash.Driver.Types
(ClashOpts (..), defClashOpts)
import Clash.GHC.ClashFlags
import Clash.Util (clashLibVersion)
import Clash.GHC.LoadModules (ghcLibDir, setWantedLanguageExtensions)
import Clash.GHC.Util (handleClashException)
defaultMain :: [String] -> IO ()
defaultMain :: [String] -> IO ()
defaultMain = Ghc () -> [String] -> IO ()
defaultMainWithAction (() -> Ghc ()
forall a. a -> Ghc a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ())
defaultMainWithAction :: Ghc () -> [String] -> IO ()
defaultMainWithAction :: Ghc () -> [String] -> IO ()
defaultMainWithAction Ghc ()
startAction = ([String] -> IO () -> IO ()) -> IO () -> [String] -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip [String] -> IO () -> IO ()
forall a. [String] -> IO a -> IO a
withArgs (IO () -> [String] -> IO ()) -> IO () -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
LineBuffering
Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
LineBuffering
IO ()
configureHandleEncoding
FatalMessager -> FlushOut -> IO () -> IO ()
forall (m :: Type -> Type) a.
ExceptionMonad m =>
FatalMessager -> FlushOut -> m a -> m a
GHC.defaultErrorHandler FatalMessager
defaultFatalMessager FlushOut
defaultFlushOut (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[String]
argv0 <- IO [String]
getArgs
let argv1 :: [Located String]
argv1 = (String -> Located String) -> [String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Located String
forall e. String -> e -> Located e
mkGeneralLocated String
"on the commandline") [String]
argv0
String
libDir <- IO String
ghcLibDir
IORef ClashOpts
r <- ClashOpts -> IO (IORef ClashOpts)
forall a. a -> IO (IORef a)
newIORef ClashOpts
defClashOpts
([Located String]
argv2, [Warn]
clashFlagWarnings) <- IORef ClashOpts
-> [Located String] -> IO ([Located String], [Warn])
parseClashFlags IORef ClashOpts
r [Located String]
argv1
(Mode
mode, [String]
units, [Located String]
argv3, [Warn]
modeFlagWarnings) <- [Located String] -> IO (Mode, [String], [Located String], [Warn])
parseModeFlags [Located String]
argv2
let flagWarnings :: [Warn]
flagWarnings = [Warn]
modeFlagWarnings [Warn] -> [Warn] -> [Warn]
forall a. [a] -> [a] -> [a]
++ [Warn]
clashFlagWarnings
case Mode
mode of
Left PreStartupMode
preStartupMode ->
do case PreStartupMode
preStartupMode of
PreStartupMode
ShowSupportedExtensions -> Maybe String -> IO ()
showSupportedExtensions (String -> Maybe String
forall a. a -> Maybe a
Just String
libDir)
PreStartupMode
ShowVersion -> IO ()
showVersion
PreStartupMode
ShowNumVersion -> FatalMessager
putStrLn String
cProjectVersion
ShowOptions Bool
isInteractive -> Bool -> IORef ClashOpts -> IO ()
showOptions Bool
isInteractive IORef ClashOpts
r
Right PostStartupMode
postStartupMode ->
Maybe String -> Ghc () -> IO ()
forall a. Maybe String -> Ghc a -> IO a
GHC.runGhc (String -> Maybe String
forall a. a -> Maybe a
Just String
libDir) (Ghc () -> IO ()) -> Ghc () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
DynFlags
dflags <- Ghc DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
let dflagsExtra :: DynFlags
dflagsExtra = DynFlags -> DynFlags
setWantedLanguageExtensions DynFlags
dflags
ghcTyLitNormPlugin :: ModuleName
ghcTyLitNormPlugin = String -> ModuleName
GHC.mkModuleName String
"GHC.TypeLits.Normalise"
ghcTyLitExtrPlugin :: ModuleName
ghcTyLitExtrPlugin = String -> ModuleName
GHC.mkModuleName String
"GHC.TypeLits.Extra.Solver"
ghcTyLitKNPlugin :: ModuleName
ghcTyLitKNPlugin = String -> ModuleName
GHC.mkModuleName String
"GHC.TypeLits.KnownNat.Solver"
dflagsExtra1 :: DynFlags
dflagsExtra1 = DynFlags
dflagsExtra
{ Session.pluginModNames = nub $
ghcTyLitNormPlugin : ghcTyLitExtrPlugin :
ghcTyLitKNPlugin :
Session.pluginModNames dflagsExtra
}
case PostStartupMode
postStartupMode of
Left PreLoadMode
preLoadMode ->
IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
case PreLoadMode
preLoadMode of
PreLoadMode
ShowInfo -> DynFlags -> IO ()
showInfo DynFlags
dflagsExtra1
PreLoadMode
ShowGhcUsage -> DynFlags -> IO ()
showGhcUsage DynFlags
dflagsExtra1
PreLoadMode
ShowGhciUsage -> DynFlags -> IO ()
showGhciUsage DynFlags
dflagsExtra1
PrintWithDynFlags DynFlags -> String
f -> FatalMessager
putStrLn (DynFlags -> String
f DynFlags
dflagsExtra1)
Right PostLoadMode
postLoadMode ->
PostLoadMode
-> [String]
-> DynFlags
-> [Located String]
-> [Warn]
-> Ghc ()
-> IORef ClashOpts
-> Ghc ()
main' PostLoadMode
postLoadMode [String]
units DynFlags
dflagsExtra1 [Located String]
argv3 [Warn]
flagWarnings Ghc ()
startAction IORef ClashOpts
r
main' :: PostLoadMode -> [String] -> DynFlags -> [Located String] -> [Warn]
-> Ghc () -> IORef ClashOpts
-> Ghc ()
main' :: PostLoadMode
-> [String]
-> DynFlags
-> [Located String]
-> [Warn]
-> Ghc ()
-> IORef ClashOpts
-> Ghc ()
main' PostLoadMode
postLoadMode [String]
units DynFlags
dflags0 [Located String]
args [Warn]
flagWarnings Ghc ()
startAction IORef ClashOpts
clashOpts = do
let args' :: [Located String]
args' = case PostLoadMode
postLoadMode of
PostLoadMode
DoRun -> (Located String -> Bool) -> [Located String] -> [Located String]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Located String
arg -> Located String -> String
forall l e. GenLocated l e -> e
unLoc Located String
arg String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"--") [Located String]
args
PostLoadMode
_ -> [Located String]
args
let dflt_backend :: Backend
dflt_backend = DynFlags -> Backend
backend DynFlags
dflags0
(GhcMode
mode, Backend
bcknd, GhcLink
link)
= case PostLoadMode
postLoadMode of
PostLoadMode
DoInteractive -> (GhcMode
CompManager, Backend
interpreterBackend, GhcLink
LinkInMemory)
DoEval [String]
_ -> (GhcMode
CompManager, Backend
interpreterBackend, GhcLink
LinkInMemory)
PostLoadMode
DoRun -> (GhcMode
CompManager, Backend
interpreterBackend, GhcLink
LinkInMemory)
PostLoadMode
DoMake -> (GhcMode
CompManager, Backend
dflt_backend, GhcLink
LinkBinary)
PostLoadMode
DoBackpack -> (GhcMode
CompManager, Backend
dflt_backend, GhcLink
LinkBinary)
PostLoadMode
DoMkDependHS -> (GhcMode
MkDepend, Backend
dflt_backend, GhcLink
LinkBinary)
PostLoadMode
DoAbiHash -> (GhcMode
OneShot, Backend
dflt_backend, GhcLink
LinkBinary)
PostLoadMode
DoVHDL -> (GhcMode
CompManager, Backend
noBackend, GhcLink
NoLink)
PostLoadMode
DoVerilog -> (GhcMode
CompManager, Backend
noBackend, GhcLink
NoLink)
PostLoadMode
DoSystemVerilog -> (GhcMode
CompManager, Backend
noBackend, GhcLink
NoLink)
PostLoadMode
_ -> (GhcMode
OneShot, Backend
dflt_backend, GhcLink
LinkBinary)
let dflags1 :: DynFlags
dflags1 = DynFlags
dflags0{ ghcMode = mode,
backend = bcknd,
ghcLink = link,
verbosity = case postLoadMode of
DoEval [String]
_ -> Int
0
PostLoadMode
DoRun -> Int
0
PostLoadMode
_other -> Int
1
}
dflags2 :: DynFlags
dflags2 | PostLoadMode
DoInteractive <- PostLoadMode
postLoadMode = DynFlags
def_ghci_flags
| DoEval [String]
_ <- PostLoadMode
postLoadMode = DynFlags
def_ghci_flags
| PostLoadMode
DoRun <- PostLoadMode
postLoadMode = DynFlags
def_ghci_flags
| Bool
otherwise = DynFlags
dflags1
where def_ghci_flags :: DynFlags
def_ghci_flags = DynFlags
dflags1 DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_ImplicitImportQualified
DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_IgnoreOptimChanges
DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_IgnoreHpcChanges
DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_UseBytecodeRatherThanObjects
Logger
logger1 <- Ghc Logger
forall (m :: Type -> Type). HasLogger m => m Logger
getLogger
let logger2 :: Logger
logger2 = Logger -> LogFlags -> Logger
setLogFlags Logger
logger1 (DynFlags -> LogFlags
initLogFlags DynFlags
dflags2)
(DynFlags
dflags3, [Located String]
fileish_args, [Warn]
dynamicFlagWarnings) <-
Logger
-> DynFlags
-> [Located String]
-> Ghc (DynFlags, [Located String], [Warn])
forall (m :: Type -> Type).
MonadIO m =>
Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], [Warn])
GHC.parseDynamicFlags Logger
logger2 DynFlags
dflags2 [Located String]
args'
IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ())
-> ((ClashOpts -> ClashOpts) -> IO ())
-> (ClashOpts -> ClashOpts)
-> Ghc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef ClashOpts -> (ClashOpts -> ClashOpts) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef ClashOpts
clashOpts ((ClashOpts -> ClashOpts) -> Ghc ())
-> (ClashOpts -> ClashOpts) -> Ghc ()
forall a b. (a -> b) -> a -> b
$ \ClashOpts
opts ->
ClashOpts
opts { opt_werror = EnumSet.member Opt_WarnIsError (generalFlags dflags3) }
let dflags4 :: DynFlags
dflags4 = if Backend -> Bool
backendNeedsFullWays Backend
bcknd Bool -> Bool -> Bool
&&
Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
dflags3)
then
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags3
dflags3a :: DynFlags
dflags3a = DynFlags
dflags3 { targetWays_ = hostFullWays }
dflags3b :: DynFlags
dflags3b = (DynFlags -> GeneralFlag -> DynFlags)
-> DynFlags -> [GeneralFlag] -> DynFlags
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dflags3a
([GeneralFlag] -> DynFlags) -> [GeneralFlag] -> DynFlags
forall a b. (a -> b) -> a -> b
$ (Way -> [GeneralFlag]) -> Ways -> [GeneralFlag]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (Platform -> Way -> [GeneralFlag]
wayGeneralFlags Platform
platform)
Ways
hostFullWays
dflags3c :: DynFlags
dflags3c = (DynFlags -> GeneralFlag -> DynFlags)
-> DynFlags -> [GeneralFlag] -> DynFlags
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DynFlags -> GeneralFlag -> DynFlags
gopt_unset DynFlags
dflags3b
([GeneralFlag] -> DynFlags) -> [GeneralFlag] -> DynFlags
forall a b. (a -> b) -> a -> b
$ (Way -> [GeneralFlag]) -> Ways -> [GeneralFlag]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (Platform -> Way -> [GeneralFlag]
wayUnsetGeneralFlags Platform
platform)
Ways
hostFullWays
in DynFlags
dflags3c
else
DynFlags
dflags3
let logger4 :: Logger
logger4 = Logger -> LogFlags -> Logger
setLogFlags Logger
logger2 (DynFlags -> LogFlags
initLogFlags DynFlags
dflags4)
Logger -> Ghc () -> Ghc ()
forall (m :: Type -> Type) a.
ExceptionMonad m =>
Logger -> m a -> m a
GHC.prettyPrintGhcErrors Logger
logger4 (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
let flagWarnings' :: [Warn]
flagWarnings' = [Warn]
flagWarnings [Warn] -> [Warn] -> [Warn]
forall a. [a] -> [a] -> [a]
++ [Warn]
dynamicFlagWarnings
(SourceError -> Ghc ()) -> Ghc () -> Ghc ()
forall (m :: Type -> Type) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError (\SourceError
e -> do
SourceError -> Ghc ()
forall (m :: Type -> Type).
(HasLogger m, MonadIO m, HasDynFlags m) =>
SourceError -> m ()
GHC.printException SourceError
e
IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)) (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ Logger -> GhcMessageOpts -> DiagOpts -> [Warn] -> IO ()
handleFlagWarnings Logger
logger4 (DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig DynFlags
dflags4) (DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags4) [Warn]
flagWarnings'
IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ PostLoadMode -> DynFlags -> IO ()
showBanner PostLoadMode
postLoadMode DynFlags
dflags4
let (DynFlags
dflags5, [(String, Maybe Phase)]
srcs, [String]
objs) = DynFlags
-> [String] -> (DynFlags, [(String, Maybe Phase)], [String])
parseTargetFiles DynFlags
dflags4 ((Located String -> String) -> [Located String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Located String -> String
forall l e. GenLocated l e -> e
unLoc [Located String]
fileish_args)
()
_ <- DynFlags -> Ghc ()
forall (m :: Type -> Type).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
GHC.setSessionDynFlags DynFlags
dflags5
DynFlags
dflags6 <- Ghc DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ Word -> Int -> IO ()
initUniqSupply (DynFlags -> Word
initialUnique DynFlags
dflags6) (DynFlags -> Int
uniqueIncrement DynFlags
dflags6)
Ghc ()
forall (m :: Type -> Type). GhcMonad m => m ()
initializeSessionPlugins
HscEnv
hsc_env <- Ghc HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
getSession
Logger
logger <- Ghc Logger
forall (m :: Type -> Type). HasLogger m => m Logger
getLogger
case DynFlags -> Int
verbosity DynFlags
dflags6 of
Int
v | Int
v Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4 -> IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ()
dumpUnitsSimple HscEnv
hsc_env
| Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
5 -> IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ()
dumpUnits HscEnv
hsc_env
| Bool
otherwise -> () -> Ghc ()
forall a. a -> Ghc a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ PostLoadMode
-> DynFlags
-> [(String, Maybe Phase)]
-> [String]
-> [String]
-> IO ()
checkOptions PostLoadMode
postLoadMode DynFlags
dflags6 [(String, Maybe Phase)]
srcs [String]
objs [String]
units
(SourceError -> Ghc ()) -> Ghc () -> Ghc ()
forall (m :: Type -> Type) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError (\SourceError
e -> do
SourceError -> Ghc ()
forall (m :: Type -> Type).
(HasLogger m, MonadIO m, HasDynFlags m) =>
SourceError -> m ()
GHC.printException SourceError
e
IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)) (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
ClashOpts
clashOpts' <- IO ClashOpts -> Ghc ClashOpts
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IORef ClashOpts -> IO ClashOpts
forall a. IORef a -> IO a
readIORef IORef ClashOpts
clashOpts)
let clash :: (Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> m a)
-> m a
clash Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> m a
fun = m a -> (SomeException -> m a) -> m a
forall e a. (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
forall (m :: Type -> Type) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch (Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> m a
fun Ghc ()
startAction IORef ClashOpts
clashOpts [(String, Maybe Phase)]
srcs) (DynFlags -> ClashOpts -> SomeException -> m a
forall (m :: Type -> Type) a.
GhcMonad m =>
DynFlags -> ClashOpts -> SomeException -> m a
handleClashException DynFlags
dflags6 ClashOpts
clashOpts')
case PostLoadMode
postLoadMode of
ShowInterface String
f -> IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> UnitState -> NameCache -> FatalMessager
showIface Logger
logger
(HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
((() :: Constraint) => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env)
(HscEnv -> NameCache
hsc_NC HscEnv
hsc_env)
String
f
PostLoadMode
DoMake -> [String] -> [(String, Maybe Phase)] -> Ghc ()
doMake [String]
units [(String, Maybe Phase)]
srcs
PostLoadMode
DoMkDependHS -> [String] -> Ghc ()
forall (m :: Type -> Type). GhcMonad m => [String] -> m ()
doMkDependHS (((String, Maybe Phase) -> String)
-> [(String, Maybe Phase)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Maybe Phase) -> String
forall a b. (a, b) -> a
fst [(String, Maybe Phase)]
srcs)
StopBefore StopPhase
p -> IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> StopPhase -> [(String, Maybe Phase)] -> IO ()
oneShot HscEnv
hsc_env StopPhase
p [(String, Maybe Phase)]
srcs)
PostLoadMode
DoInteractive -> IORef ClashOpts
-> [String] -> [(String, Maybe Phase)] -> Maybe [String] -> Ghc ()
ghciUI IORef ClashOpts
clashOpts [String]
units [(String, Maybe Phase)]
srcs Maybe [String]
forall a. Maybe a
Nothing
DoEval [String]
exprs -> IORef ClashOpts
-> [String] -> [(String, Maybe Phase)] -> Maybe [String] -> Ghc ()
ghciUI IORef ClashOpts
clashOpts [String]
units [(String, Maybe Phase)]
srcs (Maybe [String] -> Ghc ()) -> Maybe [String] -> Ghc ()
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe [String]
forall a. a -> Maybe a
Just ([String] -> Maybe [String]) -> [String] -> Maybe [String]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
reverse [String]
exprs
PostLoadMode
DoRun -> IORef ClashOpts
-> [String]
-> [(String, Maybe Phase)]
-> [Located String]
-> Ghc ()
doRun IORef ClashOpts
clashOpts [String]
units [(String, Maybe Phase)]
srcs [Located String]
args
PostLoadMode
DoAbiHash -> [String] -> Ghc ()
abiHash (((String, Maybe Phase) -> String)
-> [(String, Maybe Phase)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Maybe Phase) -> String
forall a b. (a, b) -> a
fst [(String, Maybe Phase)]
srcs)
PostLoadMode
ShowPackages -> IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ()
showUnits HscEnv
hsc_env
DoFrontend ModuleName
f -> ModuleName -> [(String, Maybe Phase)] -> Ghc ()
doFrontend ModuleName
f [(String, Maybe Phase)]
srcs
PostLoadMode
DoBackpack -> [String] -> Ghc ()
doBackpack (((String, Maybe Phase) -> String)
-> [(String, Maybe Phase)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Maybe Phase) -> String
forall a b. (a, b) -> a
fst [(String, Maybe Phase)]
srcs)
PostLoadMode
DoVHDL -> (Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ())
-> Ghc ()
forall {m :: Type -> Type} {a}.
GhcMonad m =>
(Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> m a)
-> m a
clash Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeVHDL
PostLoadMode
DoVerilog -> (Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ())
-> Ghc ()
forall {m :: Type -> Type} {a}.
GhcMonad m =>
(Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> m a)
-> m a
clash Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeVerilog
PostLoadMode
DoSystemVerilog -> (Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ())
-> Ghc ()
forall {m :: Type -> Type} {a}.
GhcMonad m =>
(Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> m a)
-> m a
clash Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeSystemVerilog
IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ Logger -> IO ()
dumpFinalStats Logger
logger
doRun :: IORef ClashOpts -> [String] -> [(FilePath, Maybe Phase)] -> [Located String] -> Ghc ()
doRun :: IORef ClashOpts
-> [String]
-> [(String, Maybe Phase)]
-> [Located String]
-> Ghc ()
doRun IORef ClashOpts
clashOpts [String]
units [(String, Maybe Phase)]
srcs [Located String]
args = do
DynFlags
dflags <- Ghc DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
let mainFun :: String
mainFun = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"main" (DynFlags -> Maybe String
mainFunIs DynFlags
dflags)
IORef ClashOpts
-> [String] -> [(String, Maybe Phase)] -> Maybe [String] -> Ghc ()
ghciUI IORef ClashOpts
clashOpts [String]
units [(String, Maybe Phase)]
srcs ([String] -> Maybe [String]
forall a. a -> Maybe a
Just [String
"System.Environment.withArgs " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
args' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (Control.Monad.void " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mainFun String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"])
where
args' :: [String]
args' = Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
1 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"--") ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Located String -> String) -> [Located String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Located String -> String
forall l e. GenLocated l e -> e
unLoc [Located String]
args
ghciUI :: IORef ClashOpts -> [String] -> [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()
#if !defined(HAVE_INTERNAL_INTERPRETER)
ghciUI _ _ _ _ =
throwGhcException (CmdLineError "not built for interactive use")
#else
ghciUI :: IORef ClashOpts
-> [String] -> [(String, Maybe Phase)] -> Maybe [String] -> Ghc ()
ghciUI IORef ClashOpts
clashOpts [String]
units [(String, Maybe Phase)]
srcs Maybe [String]
maybe_expr = do
[(String, Maybe UnitEnvGraphKey, Maybe Phase)]
hs_srcs <- case [String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [String]
units of
Just NonEmpty String
ne_units -> do
NonEmpty String
-> Ghc [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
initMulti NonEmpty String
ne_units
Maybe (NonEmpty String)
Nothing -> do
case [(String, Maybe Phase)]
srcs of
[] -> [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
-> Ghc [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
forall a. a -> Ghc a
forall (m :: Type -> Type) a. Monad m => a -> m a
return []
[(String, Maybe Phase)]
_ -> do
[(String, Maybe Phase)]
s <- [(String, Maybe Phase)] -> Ghc [(String, Maybe Phase)]
initMake [(String, Maybe Phase)]
srcs
[(String, Maybe UnitEnvGraphKey, Maybe Phase)]
-> Ghc [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
forall a. a -> Ghc a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(String, Maybe UnitEnvGraphKey, Maybe Phase)]
-> Ghc [(String, Maybe UnitEnvGraphKey, Maybe Phase)])
-> [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
-> Ghc [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
forall a b. (a -> b) -> a -> b
$ ((String, Maybe Phase)
-> (String, Maybe UnitEnvGraphKey, Maybe Phase))
-> [(String, Maybe Phase)]
-> [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
forall a b. (a -> b) -> [a] -> [b]
map ((String
-> Maybe Phase -> (String, Maybe UnitEnvGraphKey, Maybe Phase))
-> (String, Maybe Phase)
-> (String, Maybe UnitEnvGraphKey, Maybe Phase)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (,Maybe UnitEnvGraphKey
forall a. Maybe a
Nothing,)) [(String, Maybe Phase)]
s
GhciSettings
-> [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
-> Maybe [String]
-> Ghc ()
interactiveUI (IORef ClashOpts -> GhciSettings
defaultGhciSettings IORef ClashOpts
clashOpts) [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
hs_srcs Maybe [String]
maybe_expr
#endif
checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> [String] -> IO ()
checkOptions :: PostLoadMode
-> DynFlags
-> [(String, Maybe Phase)]
-> [String]
-> [String]
-> IO ()
checkOptions PostLoadMode
mode DynFlags
dflags [(String, Maybe Phase)]
srcs [String]
objs [String]
units = do
let unknown_opts :: [String]
unknown_opts = [ String
f | (f :: String
f@(Char
'-':String
_), Maybe Phase
_) <- [(String, Maybe Phase)]
srcs ]
Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when ([String] -> Bool
forall (f :: Type -> Type) a. Foldable f => f a -> Bool
notNull [String]
unknown_opts) ([String] -> IO ()
forall a. [String] -> a
unknownFlagsErr [String]
unknown_opts)
Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Ways -> Bool
forall a. Set a -> Bool
Set.null (Ways -> Ways
rtsWays (DynFlags -> Ways
ways DynFlags
dflags)))
Bool -> Bool -> Bool
&& PostLoadMode -> Bool
isInterpretiveMode PostLoadMode
mode) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Handle -> FatalMessager
hPutStrLn Handle
stderr (String
"Warning: -debug, -threaded and -ticky are ignored by GHCi")
Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when ((Ways -> Ways
fullWays (DynFlags -> Ways
ways DynFlags
dflags) Ways -> Ways -> Bool
forall a. Eq a => a -> a -> Bool
/= Ways
hostFullWays)
Bool -> Bool -> Bool
&& PostLoadMode -> Bool
isInterpretiveMode PostLoadMode
mode
Bool -> Bool -> Bool
&& Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
dflags)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
do GhcException -> IO ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
UsageError
String
"-fexternal-interpreter is required when using --interactive with a non-standard way (-prof, -static, or -dynamic).")
if (Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (DynFlags -> Maybe String
outputHi DynFlags
dflags) Bool -> Bool -> Bool
&&
(PostLoadMode -> Bool
isCompManagerMode PostLoadMode
mode Bool -> Bool -> Bool
|| [(String, Maybe Phase)]
srcs [(String, Maybe Phase)] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
1))
then GhcException -> IO ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
UsageError String
"-ohi can only be used when compiling a single source file")
else do
if (Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (DynFlags -> Maybe String
dynOutputHi DynFlags
dflags) Bool -> Bool -> Bool
&&
(PostLoadMode -> Bool
isCompManagerMode PostLoadMode
mode Bool -> Bool -> Bool
|| [(String, Maybe Phase)]
srcs [(String, Maybe Phase)] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
1))
then GhcException -> IO ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
UsageError String
"-dynohi can only be used when compiling a single source file")
else do
if ([(String, Maybe Phase)]
srcs [(String, Maybe Phase)] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
1 Bool -> Bool -> Bool
&& Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (DynFlags -> Maybe String
outputFile DynFlags
dflags)
Bool -> Bool -> Bool
&& Bool -> Bool
not (PostLoadMode -> Bool
isLinkMode PostLoadMode
mode))
then GhcException -> IO ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
UsageError String
"can't apply -o to multiple source files")
else do
let not_linking :: Bool
not_linking = Bool -> Bool
not (PostLoadMode -> Bool
isLinkMode PostLoadMode
mode) Bool -> Bool -> Bool
|| GhcLink -> Bool
isNoLink (DynFlags -> GhcLink
ghcLink DynFlags
dflags)
Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool
not_linking Bool -> Bool -> Bool
&& Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [String]
objs)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Handle -> FatalMessager
hPutStrLn Handle
stderr (String
"Warning: the following files would be used as linker inputs, but linking is not being done: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
objs)
if [(String, Maybe Phase)] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [(String, Maybe Phase)]
srcs Bool -> Bool -> Bool
&& ([String] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [String]
objs Bool -> Bool -> Bool
|| Bool
not_linking) Bool -> Bool -> Bool
&& PostLoadMode -> Bool
needsInputsMode PostLoadMode
mode Bool -> Bool -> Bool
&& [String] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [String]
units
then GhcException -> IO ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
UsageError String
"no input files" )
else do
case PostLoadMode
mode of
StopBefore StopPhase
StopC | Bool -> Bool
not (Backend -> Bool
backendGeneratesHc (DynFlags -> Backend
backend DynFlags
dflags))
-> GhcException -> IO ()
forall a. GhcException -> a
throwGhcException (GhcException -> IO ()) -> GhcException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> GhcException
UsageError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$
String
"the option -C is only available with an unregisterised GHC"
StopBefore StopPhase
StopAs | DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
== GhcLink
NoLink
-> GhcException -> IO ()
forall a. GhcException -> a
throwGhcException (GhcException -> IO ()) -> GhcException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> GhcException
UsageError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$
String
"the options -S and -fno-code are incompatible. Please omit -S"
PostLoadMode
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
DynFlags -> IO ()
verifyOutputFiles DynFlags
dflags
verifyOutputFiles :: DynFlags -> IO ()
verifyOutputFiles :: DynFlags -> IO ()
verifyOutputFiles DynFlags
dflags = do
let ofile :: Maybe String
ofile = DynFlags -> Maybe String
outputFile DynFlags
dflags
Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
ofile) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let fn :: String
fn = Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
ofile
Bool
flg <- String -> IO Bool
doesDirNameExist String
fn
Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
flg) (String -> FatalMessager
forall {a} {a} {a}. (Show a, Show a) => a -> a -> a
nonExistentDir String
"-o" String
fn)
let ohi :: Maybe String
ohi = DynFlags -> Maybe String
outputHi DynFlags
dflags
Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
ohi) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let hi :: String
hi = Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
ohi
Bool
flg <- String -> IO Bool
doesDirNameExist String
hi
Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
flg) (String -> FatalMessager
forall {a} {a} {a}. (Show a, Show a) => a -> a -> a
nonExistentDir String
"-ohi" String
hi)
where
nonExistentDir :: a -> a -> a
nonExistentDir a
flg a
dir =
GhcException -> a
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError (String
"error: directory portion of " String -> String -> String
forall a. [a] -> [a] -> [a]
++
a -> String
forall a. Show a => a -> String
show a
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not exist (used with " String -> String -> String
forall a. [a] -> [a] -> [a]
++
a -> String
forall a. Show a => a -> String
show a
flg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" option.)"))
type Mode = Either PreStartupMode PostStartupMode
type PostStartupMode = Either PreLoadMode PostLoadMode
data PreStartupMode
= ShowVersion
| ShowNumVersion
| ShowSupportedExtensions
| ShowOptions Bool
showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode
showVersionMode :: Mode
showVersionMode = PreStartupMode -> Mode
mkPreStartupMode PreStartupMode
ShowVersion
showNumVersionMode :: Mode
showNumVersionMode = PreStartupMode -> Mode
mkPreStartupMode PreStartupMode
ShowNumVersion
showSupportedExtensionsMode :: Mode
showSupportedExtensionsMode = PreStartupMode -> Mode
mkPreStartupMode PreStartupMode
ShowSupportedExtensions
showOptionsMode :: Mode
showOptionsMode = PreStartupMode -> Mode
mkPreStartupMode (Bool -> PreStartupMode
ShowOptions Bool
False)
mkPreStartupMode :: PreStartupMode -> Mode
mkPreStartupMode :: PreStartupMode -> Mode
mkPreStartupMode = PreStartupMode -> Mode
forall a b. a -> Either a b
Left
isShowVersionMode :: Mode -> Bool
isShowVersionMode :: Mode -> Bool
isShowVersionMode (Left PreStartupMode
ShowVersion) = Bool
True
isShowVersionMode Mode
_ = Bool
False
isShowNumVersionMode :: Mode -> Bool
isShowNumVersionMode :: Mode -> Bool
isShowNumVersionMode (Left PreStartupMode
ShowNumVersion) = Bool
True
isShowNumVersionMode Mode
_ = Bool
False
data PreLoadMode
= ShowGhcUsage
| ShowGhciUsage
| ShowInfo
| PrintWithDynFlags (DynFlags -> String)
showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode
showGhcUsageMode :: Mode
showGhcUsageMode = PreLoadMode -> Mode
mkPreLoadMode PreLoadMode
ShowGhcUsage
showGhciUsageMode :: Mode
showGhciUsageMode = PreLoadMode -> Mode
mkPreLoadMode PreLoadMode
ShowGhciUsage
showInfoMode :: Mode
showInfoMode = PreLoadMode -> Mode
mkPreLoadMode PreLoadMode
ShowInfo
printSetting :: String -> Mode
printSetting :: String -> Mode
printSetting String
k = PreLoadMode -> Mode
mkPreLoadMode ((DynFlags -> String) -> PreLoadMode
PrintWithDynFlags DynFlags -> String
f)
where f :: DynFlags -> String
f DynFlags
dflags = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String -> String
forall a. HasCallStack => String -> a
panic (String
"Setting not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
k))
(Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
k (DynFlags -> [(String, String)]
compilerInfo DynFlags
dflags)
mkPreLoadMode :: PreLoadMode -> Mode
mkPreLoadMode :: PreLoadMode -> Mode
mkPreLoadMode = PostStartupMode -> Mode
forall a b. b -> Either a b
Right (PostStartupMode -> Mode)
-> (PreLoadMode -> PostStartupMode) -> PreLoadMode -> Mode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PreLoadMode -> PostStartupMode
forall a b. a -> Either a b
Left
isShowGhcUsageMode :: Mode -> Bool
isShowGhcUsageMode :: Mode -> Bool
isShowGhcUsageMode (Right (Left PreLoadMode
ShowGhcUsage)) = Bool
True
isShowGhcUsageMode Mode
_ = Bool
False
isShowGhciUsageMode :: Mode -> Bool
isShowGhciUsageMode :: Mode -> Bool
isShowGhciUsageMode (Right (Left PreLoadMode
ShowGhciUsage)) = Bool
True
isShowGhciUsageMode Mode
_ = Bool
False
data PostLoadMode
= ShowInterface FilePath
| DoMkDependHS
| StopBefore StopPhase
| DoMake
| DoBackpack
| DoInteractive
| DoEval [String]
| DoRun
| DoAbiHash
| ShowPackages
| DoFrontend ModuleName
| DoVHDL
| DoVerilog
| DoSystemVerilog
doMkDependHSMode, doMakeMode, doInteractiveMode, doRunMode,
doAbiHashMode, showUnitsMode, doVHDLMode, doVerilogMode,
doSystemVerilogMode :: Mode
doMkDependHSMode :: Mode
doMkDependHSMode = PostLoadMode -> Mode
mkPostLoadMode PostLoadMode
DoMkDependHS
doMakeMode :: Mode
doMakeMode = PostLoadMode -> Mode
mkPostLoadMode PostLoadMode
DoMake
doInteractiveMode :: Mode
doInteractiveMode = PostLoadMode -> Mode
mkPostLoadMode PostLoadMode
DoInteractive
doRunMode :: Mode
doRunMode = PostLoadMode -> Mode
mkPostLoadMode PostLoadMode
DoRun
doAbiHashMode :: Mode
doAbiHashMode = PostLoadMode -> Mode
mkPostLoadMode PostLoadMode
DoAbiHash
showUnitsMode :: Mode
showUnitsMode = PostLoadMode -> Mode
mkPostLoadMode PostLoadMode
ShowPackages
doVHDLMode :: Mode
doVHDLMode = PostLoadMode -> Mode
mkPostLoadMode PostLoadMode
DoVHDL
doVerilogMode :: Mode
doVerilogMode = PostLoadMode -> Mode
mkPostLoadMode PostLoadMode
DoVerilog
doSystemVerilogMode :: Mode
doSystemVerilogMode = PostLoadMode -> Mode
mkPostLoadMode PostLoadMode
DoSystemVerilog
showInterfaceMode :: FilePath -> Mode
showInterfaceMode :: String -> Mode
showInterfaceMode String
fp = PostLoadMode -> Mode
mkPostLoadMode (String -> PostLoadMode
ShowInterface String
fp)
stopBeforeMode :: StopPhase -> Mode
stopBeforeMode :: StopPhase -> Mode
stopBeforeMode StopPhase
phase = PostLoadMode -> Mode
mkPostLoadMode (StopPhase -> PostLoadMode
StopBefore StopPhase
phase)
doEvalMode :: String -> Mode
doEvalMode :: String -> Mode
doEvalMode String
str = PostLoadMode -> Mode
mkPostLoadMode ([String] -> PostLoadMode
DoEval [String
str])
doFrontendMode :: String -> Mode
doFrontendMode :: String -> Mode
doFrontendMode String
str = PostLoadMode -> Mode
mkPostLoadMode (ModuleName -> PostLoadMode
DoFrontend (String -> ModuleName
mkModuleName String
str))
doBackpackMode :: Mode
doBackpackMode :: Mode
doBackpackMode = PostLoadMode -> Mode
mkPostLoadMode PostLoadMode
DoBackpack
mkPostLoadMode :: PostLoadMode -> Mode
mkPostLoadMode :: PostLoadMode -> Mode
mkPostLoadMode = PostStartupMode -> Mode
forall a b. b -> Either a b
Right (PostStartupMode -> Mode)
-> (PostLoadMode -> PostStartupMode) -> PostLoadMode -> Mode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PostLoadMode -> PostStartupMode
forall a b. b -> Either a b
Right
isDoInteractiveMode :: Mode -> Bool
isDoInteractiveMode :: Mode -> Bool
isDoInteractiveMode (Right (Right PostLoadMode
DoInteractive)) = Bool
True
isDoInteractiveMode Mode
_ = Bool
False
isStopLnMode :: Mode -> Bool
isStopLnMode :: Mode -> Bool
isStopLnMode (Right (Right (StopBefore StopPhase
NoStop))) = Bool
True
isStopLnMode Mode
_ = Bool
False
isDoMakeMode :: Mode -> Bool
isDoMakeMode :: Mode -> Bool
isDoMakeMode (Right (Right PostLoadMode
DoMake)) = Bool
True
isDoMakeMode Mode
_ = Bool
False
isDoEvalMode :: Mode -> Bool
isDoEvalMode :: Mode -> Bool
isDoEvalMode (Right (Right (DoEval [String]
_))) = Bool
True
isDoEvalMode Mode
_ = Bool
False
#if defined(HAVE_INTERNAL_INTERPRETER)
isInteractiveMode :: PostLoadMode -> Bool
isInteractiveMode :: PostLoadMode -> Bool
isInteractiveMode PostLoadMode
DoInteractive = Bool
True
isInteractiveMode PostLoadMode
_ = Bool
False
#endif
isInterpretiveMode :: PostLoadMode -> Bool
isInterpretiveMode :: PostLoadMode -> Bool
isInterpretiveMode PostLoadMode
DoInteractive = Bool
True
isInterpretiveMode (DoEval [String]
_) = Bool
True
isInterpretiveMode PostLoadMode
_ = Bool
False
needsInputsMode :: PostLoadMode -> Bool
needsInputsMode :: PostLoadMode -> Bool
needsInputsMode PostLoadMode
DoMkDependHS = Bool
True
needsInputsMode (StopBefore StopPhase
_) = Bool
True
needsInputsMode PostLoadMode
DoMake = Bool
True
needsInputsMode PostLoadMode
DoVHDL = Bool
True
needsInputsMode PostLoadMode
DoVerilog = Bool
True
needsInputsMode PostLoadMode
DoSystemVerilog = Bool
True
needsInputsMode PostLoadMode
_ = Bool
False
isLinkMode :: PostLoadMode -> Bool
isLinkMode :: PostLoadMode -> Bool
isLinkMode (StopBefore StopPhase
NoStop) = Bool
True
isLinkMode PostLoadMode
DoMake = Bool
True
isLinkMode PostLoadMode
DoRun = Bool
True
isLinkMode PostLoadMode
DoInteractive = Bool
True
isLinkMode (DoEval [String]
_) = Bool
True
isLinkMode PostLoadMode
_ = Bool
False
isCompManagerMode :: PostLoadMode -> Bool
isCompManagerMode :: PostLoadMode -> Bool
isCompManagerMode PostLoadMode
DoRun = Bool
True
isCompManagerMode PostLoadMode
DoMake = Bool
True
isCompManagerMode PostLoadMode
DoInteractive = Bool
True
isCompManagerMode (DoEval [String]
_) = Bool
True
isCompManagerMode PostLoadMode
DoVHDL = Bool
True
isCompManagerMode PostLoadMode
DoVerilog = Bool
True
isCompManagerMode PostLoadMode
DoSystemVerilog = Bool
True
isCompManagerMode PostLoadMode
_ = Bool
False
parseModeFlags :: [Located String]
-> IO (Mode, [String],
[Located String],
[Warn])
parseModeFlags :: [Located String] -> IO (Mode, [String], [Located String], [Warn])
parseModeFlags [Located String]
args = do
(([Located String]
leftover, [Err]
errs1, [Warn]
warns), (Maybe (Mode, String)
mModeFlag, [String]
units, [String]
errs2, [Located String]
flags')) <-
[Flag ModeM]
-> (Maybe (Mode, String), [String], [String], [Located String])
-> [Located String]
-> IO
(([Located String], [Err], [Warn]),
(Maybe (Mode, String), [String], [String], [Located String]))
forall s (m :: Type -> Type).
MonadIO m =>
[Flag (CmdLineP s)]
-> s
-> [Located String]
-> m (([Located String], [Err], [Warn]), s)
processCmdLineP [Flag ModeM]
mode_flags (Maybe (Mode, String)
forall a. Maybe a
Nothing, [], [], []) [Located String]
args
let mode :: Mode
mode = case Maybe (Mode, String)
mModeFlag of
Maybe (Mode, String)
Nothing -> Mode
doMakeMode
Just (Mode
m, String
_) -> Mode
m
Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless ([Err] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Err]
errs1 Bool -> Bool -> Bool
&& [String] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [String]
errs2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ GhcException -> IO ()
forall a. GhcException -> a
throwGhcException (GhcException -> IO ()) -> GhcException -> IO ()
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> GhcException
errorsToGhcException ([(String, String)] -> GhcException)
-> [(String, String)] -> GhcException
forall a b. (a -> b) -> a -> b
$
(String -> (String, String)) -> [String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"on the commandline", )) ([String] -> [(String, String)]) -> [String] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ (Err -> String) -> [Err] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Located String -> String
forall l e. GenLocated l e -> e
unLoc (Located String -> String)
-> (Err -> Located String) -> Err -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> Located String
errMsg) [Err]
errs1 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
errs2
(Mode, [String], [Located String], [Warn])
-> IO (Mode, [String], [Located String], [Warn])
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Mode
mode, [String]
units, [Located String]
flags' [Located String] -> [Located String] -> [Located String]
forall a. [a] -> [a] -> [a]
++ [Located String]
leftover, [Warn]
warns)
type ModeM = CmdLineP (Maybe (Mode, String), [String], [String], [Located String])
mode_flags :: [Flag ModeM]
mode_flags :: [Flag ModeM]
mode_flags =
[
String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"?" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
showGhcUsageMode))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"-help" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
showGhcUsageMode))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"V" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
showVersionMode))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"-version" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
showVersionMode))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"-numeric-version" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
showNumVersionMode))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"-info" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
showInfoMode))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"-show-options" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
showOptionsMode))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"-supported-languages" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
showSupportedExtensionsMode))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"-supported-extensions" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
showSupportedExtensionsMode))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"-show-packages" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
showUnitsMode))
] [Flag ModeM] -> [Flag ModeM] -> [Flag ModeM]
forall a. [a] -> [a] -> [a]
++
[ String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
k' ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode (String -> Mode
printSetting String
k)))
| String
k <- [String
"Project version",
String
"Project Git commit id",
String
"Booter version",
String
"Stage",
String
"Build platform",
String
"Host platform",
String
"Target platform",
String
"Have interpreter",
String
"Object splitting supported",
String
"Have native code generator",
String
"Support SMP",
String
"Unregisterised",
String
"Tables next to code",
String
"RTS ways",
String
"Leading underscore",
String
"Debug on",
String
"LibDir",
String
"Global Package DB",
String
"C compiler flags",
String
"C compiler link flags",
String
"ld flags"],
let k' :: String
k' = String
"-print-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (Char -> Char
replaceSpace (Char -> Char) -> (Char -> Char) -> Char -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
toLower) String
k
replaceSpace :: Char -> Char
replaceSpace Char
' ' = Char
'-'
replaceSpace Char
c = Char
c
] [Flag ModeM] -> [Flag ModeM] -> [Flag ModeM]
forall a. [a] -> [a] -> [a]
++
[ String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"-show-iface" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
HasArg (\String
f -> Mode -> String -> EwM ModeM ()
setMode (String -> Mode
showInterfaceMode String
f)
String
"--show-iface"))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"c" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (\String
f -> do Mode -> String -> EwM ModeM ()
setMode (StopPhase -> Mode
stopBeforeMode StopPhase
NoStop) String
f
String -> String -> EwM ModeM ()
addFlag String
"-no-link" String
f))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"M" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
doMkDependHSMode))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"E" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode (StopPhase -> Mode
stopBeforeMode StopPhase
StopPreprocess )))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"C" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode (StopPhase -> Mode
stopBeforeMode StopPhase
StopC)))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"S" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode (StopPhase -> Mode
stopBeforeMode StopPhase
StopAs)))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"-run" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
doRunMode))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"-make" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
doMakeMode))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"unit" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
SepArg (\String
s -> String -> String -> EwM ModeM ()
addUnit String
s String
"-unit"))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"-backpack" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
doBackpackMode))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"-interactive" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
doInteractiveMode))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"-abi-hash" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
doAbiHashMode))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"e" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
SepArg (\String
s -> Mode -> String -> EwM ModeM ()
setMode (String -> Mode
doEvalMode String
s) String
"-e"))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"-frontend" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
SepArg (\String
s -> Mode -> String -> EwM ModeM ()
setMode (String -> Mode
doFrontendMode String
s) String
"-frontend"))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"-vhdl" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
doVHDLMode))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"-verilog" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
doVerilogMode))
, String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"-systemverilog" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
doSystemVerilogMode))
]
addUnit :: String -> String -> EwM ModeM ()
addUnit :: String -> String -> EwM ModeM ()
addUnit String
unit_str String
_arg = ModeM () -> EwM ModeM ()
forall (m :: Type -> Type) a. Monad m => m a -> EwM m a
liftEwM (ModeM () -> EwM ModeM ()) -> ModeM () -> EwM ModeM ()
forall a b. (a -> b) -> a -> b
$ do
(Maybe (Mode, String)
mModeFlag, [String]
units, [String]
errs, [Located String]
flags') <- CmdLineP
(Maybe (Mode, String), [String], [String], [Located String])
(Maybe (Mode, String), [String], [String], [Located String])
forall s. CmdLineP s s
getCmdLineState
(Maybe (Mode, String), [String], [String], [Located String])
-> ModeM ()
forall s. s -> CmdLineP s ()
putCmdLineState (Maybe (Mode, String)
mModeFlag, String
unit_strString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
units, [String]
errs, [Located String]
flags')
setMode :: Mode -> String -> EwM ModeM ()
setMode :: Mode -> String -> EwM ModeM ()
setMode Mode
newMode String
newFlag = ModeM () -> EwM ModeM ()
forall (m :: Type -> Type) a. Monad m => m a -> EwM m a
liftEwM (ModeM () -> EwM ModeM ()) -> ModeM () -> EwM ModeM ()
forall a b. (a -> b) -> a -> b
$ do
(Maybe (Mode, String)
mModeFlag, [String]
units, [String]
errs, [Located String]
flags') <- CmdLineP
(Maybe (Mode, String), [String], [String], [Located String])
(Maybe (Mode, String), [String], [String], [Located String])
forall s. CmdLineP s s
getCmdLineState
let ((Mode, String)
modeFlag', [String]
errs') =
case Maybe (Mode, String)
mModeFlag of
Maybe (Mode, String)
Nothing -> ((Mode
newMode, String
newFlag), [String]
errs)
Just (Mode
oldMode, String
oldFlag) ->
case (Mode
oldMode, Mode
newMode) of
(Mode, Mode)
_ | Mode -> Bool
isStopLnMode Mode
oldMode Bool -> Bool -> Bool
&& Mode -> Bool
isDoMakeMode Mode
newMode
Bool -> Bool -> Bool
|| Mode -> Bool
isStopLnMode Mode
newMode Bool -> Bool -> Bool
&& Mode -> Bool
isDoMakeMode Mode
oldMode ->
((Mode
doMakeMode, String
"--make"), [])
(Mode, Mode)
_ | Mode -> Bool
isShowGhcUsageMode Mode
oldMode Bool -> Bool -> Bool
&&
Mode -> Bool
isDoInteractiveMode Mode
newMode ->
((Mode
showGhciUsageMode, String
oldFlag), [])
| Mode -> Bool
isShowGhcUsageMode Mode
newMode Bool -> Bool -> Bool
&&
Mode -> Bool
isDoInteractiveMode Mode
oldMode ->
((Mode
showGhciUsageMode, String
newFlag), [])
(Mode, Mode)
_ | Mode -> Bool
isDoEvalMode Mode
oldMode Bool -> Bool -> Bool
&&
Mode -> Bool
isDoInteractiveMode Mode
newMode ->
((Mode
oldMode, String
oldFlag), [])
| Mode -> Bool
isDoEvalMode Mode
newMode Bool -> Bool -> Bool
&&
Mode -> Bool
isDoInteractiveMode Mode
oldMode ->
((Mode
newMode, String
newFlag), [])
| Mode -> Bool
isDominantFlag Mode
oldMode -> ((Mode
oldMode, String
oldFlag), [])
| Mode -> Bool
isDominantFlag Mode
newMode -> ((Mode
newMode, String
newFlag), [])
(Right (Right (DoEval [String]
esOld)),
Right (Right (DoEval [String
eNew]))) ->
((PostStartupMode -> Mode
forall a b. b -> Either a b
Right (PostLoadMode -> PostStartupMode
forall a b. b -> Either a b
Right ([String] -> PostLoadMode
DoEval (String
eNew String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
esOld))), String
oldFlag),
[String]
errs)
(Mode, Mode)
_ | String
oldFlag String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
newFlag -> ((Mode
oldMode, String
oldFlag), [String]
errs)
(Right (Right PostLoadMode
DoInteractive), Left (ShowOptions Bool
_)) ->
((PreStartupMode -> Mode
forall a b. a -> Either a b
Left (Bool -> PreStartupMode
ShowOptions Bool
True),
String
"--interactive --show-options"), [String]
errs)
(Left (ShowOptions Bool
_), (Right (Right PostLoadMode
DoInteractive))) ->
((PreStartupMode -> Mode
forall a b. a -> Either a b
Left (Bool -> PreStartupMode
ShowOptions Bool
True),
String
"--show-options --interactive"), [String]
errs)
(Mode, Mode)
_ -> let err :: String
err = String -> String -> String
flagMismatchErr String
oldFlag String
newFlag
in ((Mode
oldMode, String
oldFlag), String
err String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
errs)
(Maybe (Mode, String), [String], [String], [Located String])
-> ModeM ()
forall s. s -> CmdLineP s ()
putCmdLineState ((Mode, String) -> Maybe (Mode, String)
forall a. a -> Maybe a
Just (Mode, String)
modeFlag', [String]
units, [String]
errs', [Located String]
flags')
where isDominantFlag :: Mode -> Bool
isDominantFlag Mode
f = Mode -> Bool
isShowGhcUsageMode Mode
f Bool -> Bool -> Bool
||
Mode -> Bool
isShowGhciUsageMode Mode
f Bool -> Bool -> Bool
||
Mode -> Bool
isShowVersionMode Mode
f Bool -> Bool -> Bool
||
Mode -> Bool
isShowNumVersionMode Mode
f
flagMismatchErr :: String -> String -> String
flagMismatchErr :: String -> String -> String
flagMismatchErr String
oldFlag String
newFlag
= String
"cannot use `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
oldFlag String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' with `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
newFlag String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
addFlag :: String -> String -> EwM ModeM ()
addFlag :: String -> String -> EwM ModeM ()
addFlag String
s String
flag = ModeM () -> EwM ModeM ()
forall (m :: Type -> Type) a. Monad m => m a -> EwM m a
liftEwM (ModeM () -> EwM ModeM ()) -> ModeM () -> EwM ModeM ()
forall a b. (a -> b) -> a -> b
$ do
(Maybe (Mode, String)
m, [String]
units, [String]
e, [Located String]
flags') <- CmdLineP
(Maybe (Mode, String), [String], [String], [Located String])
(Maybe (Mode, String), [String], [String], [Located String])
forall s. CmdLineP s s
getCmdLineState
(Maybe (Mode, String), [String], [String], [Located String])
-> ModeM ()
forall s. s -> CmdLineP s ()
putCmdLineState (Maybe (Mode, String)
m, [String]
units, [String]
e, String -> String -> Located String
forall e. String -> e -> Located e
mkGeneralLocated String
loc String
s Located String -> [Located String] -> [Located String]
forall a. a -> [a] -> [a]
: [Located String]
flags')
where loc :: String
loc = String
"addFlag by " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
flag String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" on the commandline"
doMake :: [String] -> [(String, Maybe Phase)] -> Ghc ()
doMake :: [String] -> [(String, Maybe Phase)] -> Ghc ()
doMake [String]
units [(String, Maybe Phase)]
targets = do
[(String, Maybe UnitEnvGraphKey, Maybe Phase)]
hs_srcs <- case [String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [String]
units of
Just NonEmpty String
ne_units -> do
NonEmpty String
-> Ghc [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
initMulti NonEmpty String
ne_units
Maybe (NonEmpty String)
Nothing -> do
[(String, Maybe Phase)]
s <- [(String, Maybe Phase)] -> Ghc [(String, Maybe Phase)]
initMake [(String, Maybe Phase)]
targets
[(String, Maybe UnitEnvGraphKey, Maybe Phase)]
-> Ghc [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
forall a. a -> Ghc a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(String, Maybe UnitEnvGraphKey, Maybe Phase)]
-> Ghc [(String, Maybe UnitEnvGraphKey, Maybe Phase)])
-> [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
-> Ghc [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
forall a b. (a -> b) -> a -> b
$ ((String, Maybe Phase)
-> (String, Maybe UnitEnvGraphKey, Maybe Phase))
-> [(String, Maybe Phase)]
-> [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
forall a b. (a -> b) -> [a] -> [b]
map ((String
-> Maybe Phase -> (String, Maybe UnitEnvGraphKey, Maybe Phase))
-> (String, Maybe Phase)
-> (String, Maybe UnitEnvGraphKey, Maybe Phase)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (,Maybe UnitEnvGraphKey
forall a. Maybe a
Nothing,)) [(String, Maybe Phase)]
s
case [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
hs_srcs of
[] -> () -> Ghc ()
forall a. a -> Ghc a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
[(String, Maybe UnitEnvGraphKey, Maybe Phase)]
_ -> do
[Target]
targets' <- ((String, Maybe UnitEnvGraphKey, Maybe Phase) -> Ghc Target)
-> [(String, Maybe UnitEnvGraphKey, Maybe Phase)] -> Ghc [Target]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (\(String
src, Maybe UnitEnvGraphKey
uid, Maybe Phase
phase) -> String -> Maybe UnitEnvGraphKey -> Maybe Phase -> Ghc Target
forall (m :: Type -> Type).
GhcMonad m =>
String -> Maybe UnitEnvGraphKey -> Maybe Phase -> m Target
GHC.guessTarget String
src Maybe UnitEnvGraphKey
uid Maybe Phase
phase) [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
hs_srcs
[Target] -> Ghc ()
forall (m :: Type -> Type). GhcMonad m => [Target] -> m ()
GHC.setTargets [Target]
targets'
SuccessFlag
ok_flag <- LoadHowMuch -> Ghc SuccessFlag
forall (f :: Type -> Type).
GhcMonad f =>
LoadHowMuch -> f SuccessFlag
GHC.load LoadHowMuch
LoadAllTargets
Bool -> Ghc () -> Ghc ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (SuccessFlag -> Bool
failed SuccessFlag
ok_flag) (IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1))
initMake :: [(String,Maybe Phase)] -> Ghc [(String, Maybe Phase)]
initMake :: [(String, Maybe Phase)] -> Ghc [(String, Maybe Phase)]
initMake [(String, Maybe Phase)]
srcs = do
let ([(String, Maybe Phase)]
hs_srcs, [(String, Maybe Phase)]
non_hs_srcs) = ((String, Maybe Phase) -> Bool)
-> [(String, Maybe Phase)]
-> ([(String, Maybe Phase)], [(String, Maybe Phase)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (String, Maybe Phase) -> Bool
isHaskellishTarget [(String, Maybe Phase)]
srcs
HscEnv
hsc_env <- Ghc HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
if ([(String, Maybe Phase)] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [(String, Maybe Phase)]
hs_srcs)
then IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> StopPhase -> [(String, Maybe Phase)] -> IO ()
oneShot HscEnv
hsc_env StopPhase
NoStop [(String, Maybe Phase)]
srcs) Ghc ()
-> Ghc [(String, Maybe Phase)] -> Ghc [(String, Maybe Phase)]
forall a b. Ghc a -> Ghc b -> Ghc b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> [(String, Maybe Phase)] -> Ghc [(String, Maybe Phase)]
forall a. a -> Ghc a
forall (m :: Type -> Type) a. Monad m => a -> m a
return []
else do
[String]
o_files <- ((String, Maybe Phase) -> Ghc (Maybe String))
-> [(String, Maybe Phase)] -> Ghc [String]
forall (m :: Type -> Type) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (\(String, Maybe Phase)
x -> IO (Maybe String) -> Ghc (Maybe String)
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> Ghc (Maybe String))
-> IO (Maybe String) -> Ghc (Maybe String)
forall a b. (a -> b) -> a -> b
$ HscEnv -> StopPhase -> (String, Maybe Phase) -> IO (Maybe String)
compileFile HscEnv
hsc_env StopPhase
NoStop (String, Maybe Phase)
x)
[(String, Maybe Phase)]
non_hs_srcs
DynFlags
dflags <- Ghc DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
let dflags' :: DynFlags
dflags' = DynFlags
dflags { ldInputs = map (FileOption "") o_files
++ ldInputs dflags }
()
_ <- DynFlags -> Ghc ()
forall (m :: Type -> Type).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
GHC.setSessionDynFlags DynFlags
dflags'
[(String, Maybe Phase)] -> Ghc [(String, Maybe Phase)]
forall a. a -> Ghc a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [(String, Maybe Phase)]
hs_srcs
removeRTS :: [String] -> [String]
removeRTS :: [String] -> [String]
removeRTS (String
"+RTS" : [String]
xs) =
case (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"-RTS") [String]
xs of
[] -> []
(String
_ : [String]
ys) -> [String] -> [String]
removeRTS [String]
ys
removeRTS (String
y:[String]
ys) = String
y String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String]
removeRTS [String]
ys
removeRTS [] = []
initMulti :: NE.NonEmpty String -> Ghc ([(String, Maybe UnitId, Maybe Phase)])
initMulti :: NonEmpty String
-> Ghc [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
initMulti NonEmpty String
unitArgsFiles = do
HscEnv
hsc_env <- Ghc HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
DynFlags
initial_dflags <- Ghc DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
NonEmpty (DynFlags, [(String, Maybe Phase)])
dynFlagsAndSrcs <- NonEmpty String
-> (String -> Ghc (DynFlags, [(String, Maybe Phase)]))
-> Ghc (NonEmpty (DynFlags, [(String, Maybe Phase)]))
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty String
unitArgsFiles ((String -> Ghc (DynFlags, [(String, Maybe Phase)]))
-> Ghc (NonEmpty (DynFlags, [(String, Maybe Phase)])))
-> (String -> Ghc (DynFlags, [(String, Maybe Phase)]))
-> Ghc (NonEmpty (DynFlags, [(String, Maybe Phase)]))
forall a b. (a -> b) -> a -> b
$ \String
f -> do
Bool -> Ghc () -> Ghc ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Int
verbosity DynFlags
initial_dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2) (IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ FatalMessager
forall a. Show a => a -> IO ()
print String
f)
[String]
args <- IO [String] -> Ghc [String]
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> Ghc [String]) -> IO [String] -> Ghc [String]
forall a b. (a -> b) -> a -> b
$ [String] -> IO [String]
expandResponse [String
f]
(DynFlags
dflags2, [Located String]
fileish_args, [Warn]
warns) <- DynFlags
-> [Located String] -> Ghc (DynFlags, [Located String], [Warn])
forall (m :: Type -> Type).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFlagsCmdLine DynFlags
initial_dflags ((String -> Located String) -> [String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Located String
forall e. String -> e -> Located e
mkGeneralLocated String
f) ([String] -> [String]
removeRTS [String]
args))
(SourceError -> Ghc ()) -> Ghc () -> Ghc ()
forall (m :: Type -> Type) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError (\SourceError
e -> do
SourceError -> Ghc ()
forall (m :: Type -> Type).
(HasLogger m, MonadIO m, HasDynFlags m) =>
SourceError -> m ()
GHC.printException SourceError
e
IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)) (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ Logger -> GhcMessageOpts -> DiagOpts -> [Warn] -> IO ()
handleFlagWarnings Logger
logger (DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig DynFlags
dflags2) (DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags2) [Warn]
warns
let (DynFlags
dflags3, [(String, Maybe Phase)]
srcs, [String]
objs) = DynFlags
-> [String] -> (DynFlags, [(String, Maybe Phase)], [String])
parseTargetFiles DynFlags
dflags2 ((Located String -> String) -> [Located String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Located String -> String
forall l e. GenLocated l e -> e
unLoc [Located String]
fileish_args)
dflags4 :: DynFlags
dflags4 = DynFlags -> DynFlags
offsetDynFlags DynFlags
dflags3
let ([(String, Maybe Phase)]
hs_srcs, [(String, Maybe Phase)]
non_hs_srcs) = ((String, Maybe Phase) -> Bool)
-> [(String, Maybe Phase)]
-> ([(String, Maybe Phase)], [(String, Maybe Phase)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (String, Maybe Phase) -> Bool
isHaskellishTarget [(String, Maybe Phase)]
srcs
let dubious_hsc_env :: HscEnv
dubious_hsc_env = (() :: Constraint) => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags4 HscEnv
hsc_env
if ([(String, Maybe Phase)] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [(String, Maybe Phase)]
hs_srcs)
then IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> StopPhase -> [(String, Maybe Phase)] -> IO ()
oneShot HscEnv
dubious_hsc_env StopPhase
NoStop [(String, Maybe Phase)]
srcs) Ghc ()
-> Ghc (DynFlags, [(String, Maybe Phase)])
-> Ghc (DynFlags, [(String, Maybe Phase)])
forall a b. Ghc a -> Ghc b -> Ghc b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> (DynFlags, [(String, Maybe Phase)])
-> Ghc (DynFlags, [(String, Maybe Phase)])
forall a. a -> Ghc a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (DynFlags
dflags4, [])
else do
[String]
o_files <- ((String, Maybe Phase) -> Ghc (Maybe String))
-> [(String, Maybe Phase)] -> Ghc [String]
forall (m :: Type -> Type) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (\(String, Maybe Phase)
x -> IO (Maybe String) -> Ghc (Maybe String)
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> Ghc (Maybe String))
-> IO (Maybe String) -> Ghc (Maybe String)
forall a b. (a -> b) -> a -> b
$ HscEnv -> StopPhase -> (String, Maybe Phase) -> IO (Maybe String)
compileFile HscEnv
dubious_hsc_env StopPhase
NoStop (String, Maybe Phase)
x)
[(String, Maybe Phase)]
non_hs_srcs
let dflags5 :: DynFlags
dflags5 = DynFlags
dflags4 { ldInputs = map (FileOption "") o_files
++ ldInputs dflags4 }
IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ PostLoadMode
-> DynFlags
-> [(String, Maybe Phase)]
-> [String]
-> [String]
-> IO ()
checkOptions PostLoadMode
DoMake DynFlags
dflags5 [(String, Maybe Phase)]
srcs [String]
objs []
(DynFlags, [(String, Maybe Phase)])
-> Ghc (DynFlags, [(String, Maybe Phase)])
forall a. a -> Ghc a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (DynFlags
dflags5, [(String, Maybe Phase)]
hs_srcs)
let
unitDflags :: NonEmpty DynFlags
unitDflags = ((DynFlags, [(String, Maybe Phase)]) -> DynFlags)
-> NonEmpty (DynFlags, [(String, Maybe Phase)])
-> NonEmpty DynFlags
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (DynFlags, [(String, Maybe Phase)]) -> DynFlags
forall a b. (a, b) -> a
fst NonEmpty (DynFlags, [(String, Maybe Phase)])
dynFlagsAndSrcs
srcs :: NonEmpty [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
srcs = ((DynFlags, [(String, Maybe Phase)])
-> [(String, Maybe UnitEnvGraphKey, Maybe Phase)])
-> NonEmpty (DynFlags, [(String, Maybe Phase)])
-> NonEmpty [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (\(DynFlags
dflags, [(String, Maybe Phase)]
lsrcs) -> ((String, Maybe Phase)
-> (String, Maybe UnitEnvGraphKey, Maybe Phase))
-> [(String, Maybe Phase)]
-> [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
forall a b. (a -> b) -> [a] -> [b]
map ((String
-> Maybe Phase -> (String, Maybe UnitEnvGraphKey, Maybe Phase))
-> (String, Maybe Phase)
-> (String, Maybe UnitEnvGraphKey, Maybe Phase)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (,UnitEnvGraphKey -> Maybe UnitEnvGraphKey
forall a. a -> Maybe a
Just (UnitEnvGraphKey -> Maybe UnitEnvGraphKey)
-> UnitEnvGraphKey -> Maybe UnitEnvGraphKey
forall a b. (a -> b) -> a -> b
$ DynFlags -> UnitEnvGraphKey
homeUnitId_ DynFlags
dflags,)) [(String, Maybe Phase)]
lsrcs) NonEmpty (DynFlags, [(String, Maybe Phase)])
dynFlagsAndSrcs
([[(String, Maybe UnitEnvGraphKey, Maybe Phase)]]
hs_srcs, [[(String, Maybe UnitEnvGraphKey, Maybe Phase)]]
_non_hs_srcs) = [([(String, Maybe UnitEnvGraphKey, Maybe Phase)],
[(String, Maybe UnitEnvGraphKey, Maybe Phase)])]
-> ([[(String, Maybe UnitEnvGraphKey, Maybe Phase)]],
[[(String, Maybe UnitEnvGraphKey, Maybe Phase)]])
forall a b. [(a, b)] -> ([a], [b])
unzip (([(String, Maybe UnitEnvGraphKey, Maybe Phase)]
-> ([(String, Maybe UnitEnvGraphKey, Maybe Phase)],
[(String, Maybe UnitEnvGraphKey, Maybe Phase)]))
-> [[(String, Maybe UnitEnvGraphKey, Maybe Phase)]]
-> [([(String, Maybe UnitEnvGraphKey, Maybe Phase)],
[(String, Maybe UnitEnvGraphKey, Maybe Phase)])]
forall a b. (a -> b) -> [a] -> [b]
map (((String, Maybe UnitEnvGraphKey, Maybe Phase) -> Bool)
-> [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
-> ([(String, Maybe UnitEnvGraphKey, Maybe Phase)],
[(String, Maybe UnitEnvGraphKey, Maybe Phase)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(String
file, Maybe UnitEnvGraphKey
_uid, Maybe Phase
phase) -> (String, Maybe Phase) -> Bool
isHaskellishTarget (String
file, Maybe Phase
phase))) (NonEmpty [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
-> [[(String, Maybe UnitEnvGraphKey, Maybe Phase)]]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
srcs))
DynFlags -> [(String, DynFlags)] -> Ghc ()
checkDuplicateUnits DynFlags
initial_dflags (NonEmpty (String, DynFlags) -> [(String, DynFlags)]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty String -> NonEmpty DynFlags -> NonEmpty (String, DynFlags)
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip NonEmpty String
unitArgsFiles NonEmpty DynFlags
unitDflags))
let (HomeUnitGraph
initial_home_graph, UnitEnvGraphKey
mainUnitId) = NonEmpty DynFlags -> (HomeUnitGraph, UnitEnvGraphKey)
createUnitEnvFromFlags NonEmpty DynFlags
unitDflags
home_units :: Set UnitEnvGraphKey
home_units = HomeUnitGraph -> Set UnitEnvGraphKey
forall v. UnitEnvGraph v -> Set UnitEnvGraphKey
unitEnv_keys HomeUnitGraph
initial_home_graph
HomeUnitGraph
home_unit_graph <- HomeUnitGraph
-> (HomeUnitEnv -> Ghc HomeUnitEnv) -> Ghc HomeUnitGraph
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM HomeUnitGraph
initial_home_graph ((HomeUnitEnv -> Ghc HomeUnitEnv) -> Ghc HomeUnitGraph)
-> (HomeUnitEnv -> Ghc HomeUnitEnv) -> Ghc HomeUnitGraph
forall a b. (a -> b) -> a -> b
$ \HomeUnitEnv
homeUnitEnv -> do
let cached_unit_dbs :: Maybe [UnitDatabase UnitEnvGraphKey]
cached_unit_dbs = HomeUnitEnv -> Maybe [UnitDatabase UnitEnvGraphKey]
homeUnitEnv_unit_dbs HomeUnitEnv
homeUnitEnv
hue_flags :: DynFlags
hue_flags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
homeUnitEnv
dflags :: DynFlags
dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
homeUnitEnv
([UnitDatabase UnitEnvGraphKey]
dbs,UnitState
unit_state,HomeUnit
home_unit,Maybe PlatformConstants
mconstants) <- IO
([UnitDatabase UnitEnvGraphKey], UnitState, HomeUnit,
Maybe PlatformConstants)
-> Ghc
([UnitDatabase UnitEnvGraphKey], UnitState, HomeUnit,
Maybe PlatformConstants)
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO
([UnitDatabase UnitEnvGraphKey], UnitState, HomeUnit,
Maybe PlatformConstants)
-> Ghc
([UnitDatabase UnitEnvGraphKey], UnitState, HomeUnit,
Maybe PlatformConstants))
-> IO
([UnitDatabase UnitEnvGraphKey], UnitState, HomeUnit,
Maybe PlatformConstants)
-> Ghc
([UnitDatabase UnitEnvGraphKey], UnitState, HomeUnit,
Maybe PlatformConstants)
forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags
-> Maybe [UnitDatabase UnitEnvGraphKey]
-> Set UnitEnvGraphKey
-> IO
([UnitDatabase UnitEnvGraphKey], UnitState, HomeUnit,
Maybe PlatformConstants)
State.initUnits Logger
logger DynFlags
hue_flags Maybe [UnitDatabase UnitEnvGraphKey]
cached_unit_dbs Set UnitEnvGraphKey
home_units
DynFlags
updated_dflags <- IO DynFlags -> Ghc DynFlags
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO DynFlags -> Ghc DynFlags) -> IO DynFlags -> Ghc DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe PlatformConstants -> IO DynFlags
updatePlatformConstants DynFlags
dflags Maybe PlatformConstants
mconstants
HomeUnitEnv -> Ghc HomeUnitEnv
forall a. a -> Ghc a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HomeUnitEnv -> Ghc HomeUnitEnv) -> HomeUnitEnv -> Ghc HomeUnitEnv
forall a b. (a -> b) -> a -> b
$ HomeUnitEnv
{ homeUnitEnv_units :: UnitState
homeUnitEnv_units = UnitState
unit_state
, homeUnitEnv_unit_dbs :: Maybe [UnitDatabase UnitEnvGraphKey]
homeUnitEnv_unit_dbs = [UnitDatabase UnitEnvGraphKey]
-> Maybe [UnitDatabase UnitEnvGraphKey]
forall a. a -> Maybe a
Just [UnitDatabase UnitEnvGraphKey]
dbs
, homeUnitEnv_dflags :: DynFlags
homeUnitEnv_dflags = DynFlags
updated_dflags
, homeUnitEnv_hpt :: HomePackageTable
homeUnitEnv_hpt = HomePackageTable
emptyHomePackageTable
, homeUnitEnv_home_unit :: Maybe HomeUnit
homeUnitEnv_home_unit = HomeUnit -> Maybe HomeUnit
forall a. a -> Maybe a
Just HomeUnit
home_unit
}
DynFlags -> HomeUnitGraph -> Ghc ()
checkUnitCycles DynFlags
initial_dflags HomeUnitGraph
home_unit_graph
let dflags :: DynFlags
dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags (HomeUnitEnv -> DynFlags) -> HomeUnitEnv -> DynFlags
forall a b. (a -> b) -> a -> b
$ UnitEnvGraphKey -> HomeUnitGraph -> HomeUnitEnv
forall v. UnitEnvGraphKey -> UnitEnvGraph v -> v
unitEnv_lookup UnitEnvGraphKey
mainUnitId HomeUnitGraph
home_unit_graph
UnitEnv
unitEnv <- (() :: Constraint) => UnitEnv -> UnitEnv
UnitEnv -> UnitEnv
assertUnitEnvInvariant (UnitEnv -> UnitEnv) -> Ghc UnitEnv -> Ghc UnitEnv
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO UnitEnv -> Ghc UnitEnv
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO UnitEnv -> Ghc UnitEnv) -> IO UnitEnv -> Ghc UnitEnv
forall a b. (a -> b) -> a -> b
$ UnitEnvGraphKey
-> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
initUnitEnv UnitEnvGraphKey
mainUnitId HomeUnitGraph
home_unit_graph (DynFlags -> GhcNameVersion
ghcNameVersion DynFlags
dflags) (DynFlags -> Platform
targetPlatform DynFlags
dflags))
let final_hsc_env :: HscEnv
final_hsc_env = HscEnv
hsc_env { hsc_unit_env = unitEnv }
HscEnv -> Ghc ()
forall (m :: Type -> Type). GhcMonad m => HscEnv -> m ()
GHC.setSession HscEnv
final_hsc_env
if ([[(String, Maybe UnitEnvGraphKey, Maybe Phase)]] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [[(String, Maybe UnitEnvGraphKey, Maybe Phase)]]
hs_srcs)
then do
IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ Handle -> FatalMessager
hPutStrLn Handle
stderr FatalMessager -> FatalMessager
forall a b. (a -> b) -> a -> b
$ String
"Multi Mode can not be used for one-shot mode."
IO [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
-> Ghc [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
-> Ghc [(String, Maybe UnitEnvGraphKey, Maybe Phase)])
-> IO [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
-> Ghc [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
else do
[(String, Maybe UnitEnvGraphKey, Maybe Phase)]
-> Ghc [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
forall a. a -> Ghc a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(String, Maybe UnitEnvGraphKey, Maybe Phase)]
-> Ghc [(String, Maybe UnitEnvGraphKey, Maybe Phase)])
-> [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
-> Ghc [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
forall a b. (a -> b) -> a -> b
$ [[(String, Maybe UnitEnvGraphKey, Maybe Phase)]]
-> [(String, Maybe UnitEnvGraphKey, Maybe Phase)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(String, Maybe UnitEnvGraphKey, Maybe Phase)]]
hs_srcs
checkUnitCycles :: DynFlags -> UnitEnvGraph HomeUnitEnv -> Ghc ()
checkUnitCycles :: DynFlags -> HomeUnitGraph -> Ghc ()
checkUnitCycles DynFlags
dflags HomeUnitGraph
graph = [SCC UnitEnvGraphKey] -> Ghc ()
forall {m :: Type -> Type} {a}.
(Monad m, Outputable a) =>
[SCC a] -> m ()
processSCCs [SCC UnitEnvGraphKey]
sccs
where
mkNode :: (UnitId, HomeUnitEnv) -> Node UnitId UnitId
mkNode :: (UnitEnvGraphKey, HomeUnitEnv)
-> Node UnitEnvGraphKey UnitEnvGraphKey
mkNode (UnitEnvGraphKey
uid, HomeUnitEnv
hue) = UnitEnvGraphKey
-> UnitEnvGraphKey
-> [UnitEnvGraphKey]
-> Node UnitEnvGraphKey UnitEnvGraphKey
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode UnitEnvGraphKey
uid UnitEnvGraphKey
uid (UnitState -> [UnitEnvGraphKey]
homeUnitDepends (HomeUnitEnv -> UnitState
homeUnitEnv_units HomeUnitEnv
hue))
nodes :: [Node UnitEnvGraphKey UnitEnvGraphKey]
nodes = ((UnitEnvGraphKey, HomeUnitEnv)
-> Node UnitEnvGraphKey UnitEnvGraphKey)
-> [(UnitEnvGraphKey, HomeUnitEnv)]
-> [Node UnitEnvGraphKey UnitEnvGraphKey]
forall a b. (a -> b) -> [a] -> [b]
map (UnitEnvGraphKey, HomeUnitEnv)
-> Node UnitEnvGraphKey UnitEnvGraphKey
mkNode (HomeUnitGraph -> [(UnitEnvGraphKey, HomeUnitEnv)]
forall v. UnitEnvGraph v -> [(UnitEnvGraphKey, v)]
unitEnv_elts HomeUnitGraph
graph)
sccs :: [SCC UnitEnvGraphKey]
sccs = [Node UnitEnvGraphKey UnitEnvGraphKey] -> [SCC UnitEnvGraphKey]
forall key payload. Ord key => [Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesOrd [Node UnitEnvGraphKey UnitEnvGraphKey]
nodes
processSCCs :: [SCC a] -> m ()
processSCCs [] = () -> m ()
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
processSCCs (AcyclicSCC a
_: [SCC a]
other_sccs) = [SCC a] -> m ()
processSCCs [SCC a]
other_sccs
processSCCs (CyclicSCC [a]
uids: [SCC a]
_) = GhcException -> m ()
forall a. GhcException -> a
throwGhcException (GhcException -> m ()) -> GhcException -> m ()
forall a b. (a -> b) -> a -> b
$ String -> GhcException
CmdLineError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags ([a] -> SDoc
forall {a}. Outputable a => [a] -> SDoc
cycle_err [a]
uids)
cycle_err :: [a] -> SDoc
cycle_err [a]
uids =
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Units form a dependency cycle:")
Int
2
([a] -> SDoc
forall {a}. Outputable a => [a] -> SDoc
one_err [a]
uids)
one_err :: [a] -> SDoc
one_err [a]
uids = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$
((a -> SDoc) -> [a] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\a
uid -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
uid SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"depends on") [a]
start)
[SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
final]
where
start :: [a]
start = [a] -> [a]
forall a. HasCallStack => [a] -> [a]
init [a]
uids
final :: a
final = [a] -> a
forall a. HasCallStack => [a] -> a
last [a]
uids
checkDuplicateUnits :: DynFlags -> [(FilePath, DynFlags)] -> Ghc ()
checkDuplicateUnits :: DynFlags -> [(String, DynFlags)] -> Ghc ()
checkDuplicateUnits DynFlags
dflags [(String, DynFlags)]
flags =
Bool -> Ghc () -> Ghc ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (Set UnitEnvGraphKey -> Bool
forall a. Set a -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null Set UnitEnvGraphKey
duplicate_ids)
(GhcException -> Ghc ()
forall a. GhcException -> a
throwGhcException (GhcException -> Ghc ()) -> GhcException -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String -> GhcException
CmdLineError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags SDoc
multi_err)
where
uids :: [(String, UnitEnvGraphKey)]
uids = ((String, DynFlags) -> (String, UnitEnvGraphKey))
-> [(String, DynFlags)] -> [(String, UnitEnvGraphKey)]
forall a b. (a -> b) -> [a] -> [b]
map ((DynFlags -> UnitEnvGraphKey)
-> (String, DynFlags) -> (String, UnitEnvGraphKey)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: Type -> Type -> Type) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second DynFlags -> UnitEnvGraphKey
homeUnitId_) [(String, DynFlags)]
flags
deduplicated_uids :: [(String, UnitEnvGraphKey)]
deduplicated_uids = ((String, UnitEnvGraphKey) -> UnitEnvGraphKey)
-> [(String, UnitEnvGraphKey)] -> [(String, UnitEnvGraphKey)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
ordNubOn (String, UnitEnvGraphKey) -> UnitEnvGraphKey
forall a b. (a, b) -> b
snd [(String, UnitEnvGraphKey)]
uids
duplicate_ids :: Set UnitEnvGraphKey
duplicate_ids = [UnitEnvGraphKey] -> Set UnitEnvGraphKey
forall a. Ord a => [a] -> Set a
Set.fromList (((String, UnitEnvGraphKey) -> UnitEnvGraphKey)
-> [(String, UnitEnvGraphKey)] -> [UnitEnvGraphKey]
forall a b. (a -> b) -> [a] -> [b]
map (String, UnitEnvGraphKey) -> UnitEnvGraphKey
forall a b. (a, b) -> b
snd [(String, UnitEnvGraphKey)]
uids [UnitEnvGraphKey] -> [UnitEnvGraphKey] -> [UnitEnvGraphKey]
forall a. Eq a => [a] -> [a] -> [a]
\\ ((String, UnitEnvGraphKey) -> UnitEnvGraphKey)
-> [(String, UnitEnvGraphKey)] -> [UnitEnvGraphKey]
forall a b. (a -> b) -> [a] -> [b]
map (String, UnitEnvGraphKey) -> UnitEnvGraphKey
forall a b. (a, b) -> b
snd [(String, UnitEnvGraphKey)]
deduplicated_uids)
duplicate_flags :: [(String, UnitEnvGraphKey)]
duplicate_flags = ((String, UnitEnvGraphKey) -> Bool)
-> [(String, UnitEnvGraphKey)] -> [(String, UnitEnvGraphKey)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((UnitEnvGraphKey -> Set UnitEnvGraphKey -> Bool)
-> Set UnitEnvGraphKey -> UnitEnvGraphKey -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip UnitEnvGraphKey -> Set UnitEnvGraphKey -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Set UnitEnvGraphKey
duplicate_ids (UnitEnvGraphKey -> Bool)
-> ((String, UnitEnvGraphKey) -> UnitEnvGraphKey)
-> (String, UnitEnvGraphKey)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, UnitEnvGraphKey) -> UnitEnvGraphKey
forall a b. (a, b) -> b
snd) [(String, UnitEnvGraphKey)]
uids
one_err :: (String, a) -> SDoc
one_err (String
fp, a
home_uid) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
home_uid SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"defined in" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
fp
multi_err :: SDoc
multi_err =
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Multiple units with the same unit-id:")
Int
2
([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (((String, UnitEnvGraphKey) -> SDoc)
-> [(String, UnitEnvGraphKey)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String, UnitEnvGraphKey) -> SDoc
forall {a}. Outputable a => (String, a) -> SDoc
one_err [(String, UnitEnvGraphKey)]
duplicate_flags))
offsetDynFlags :: DynFlags -> DynFlags
offsetDynFlags :: DynFlags -> DynFlags
offsetDynFlags DynFlags
dflags =
DynFlags
dflags { hiDir = c hiDir
, objectDir = c objectDir
, stubDir = c stubDir
, hieDir = c hieDir
, dumpDir = c dumpDir }
where
c :: (DynFlags -> Maybe String) -> Maybe String
c DynFlags -> Maybe String
f = Maybe String -> Maybe String
augment_maybe (DynFlags -> Maybe String
f DynFlags
dflags)
augment_maybe :: Maybe String -> Maybe String
augment_maybe Maybe String
Nothing = Maybe String
forall a. Maybe a
Nothing
augment_maybe (Just String
f) = String -> Maybe String
forall a. a -> Maybe a
Just (String -> String
augment String
f)
augment :: String -> String
augment String
f | String -> Bool
isRelative String
f, Just String
offset <- DynFlags -> Maybe String
workingDirectory DynFlags
dflags = String
offset String -> String -> String
</> String
f
| Bool
otherwise = String
f
createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> (HomeUnitGraph, UnitId)
createUnitEnvFromFlags :: NonEmpty DynFlags -> (HomeUnitGraph, UnitEnvGraphKey)
createUnitEnvFromFlags NonEmpty DynFlags
unitDflags =
let
newInternalUnitEnv :: DynFlags -> HomeUnitEnv
newInternalUnitEnv DynFlags
dflags = DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv
mkHomeUnitEnv DynFlags
dflags HomePackageTable
emptyHomePackageTable Maybe HomeUnit
forall a. Maybe a
Nothing
unitEnvList :: NonEmpty (UnitEnvGraphKey, HomeUnitEnv)
unitEnvList = (DynFlags -> (UnitEnvGraphKey, HomeUnitEnv))
-> NonEmpty DynFlags -> NonEmpty (UnitEnvGraphKey, HomeUnitEnv)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (\DynFlags
dflags -> (DynFlags -> UnitEnvGraphKey
homeUnitId_ DynFlags
dflags, DynFlags -> HomeUnitEnv
newInternalUnitEnv DynFlags
dflags)) NonEmpty DynFlags
unitDflags
activeUnit :: UnitEnvGraphKey
activeUnit = (UnitEnvGraphKey, HomeUnitEnv) -> UnitEnvGraphKey
forall a b. (a, b) -> a
fst ((UnitEnvGraphKey, HomeUnitEnv) -> UnitEnvGraphKey)
-> (UnitEnvGraphKey, HomeUnitEnv) -> UnitEnvGraphKey
forall a b. (a -> b) -> a -> b
$ NonEmpty (UnitEnvGraphKey, HomeUnitEnv)
-> (UnitEnvGraphKey, HomeUnitEnv)
forall a. NonEmpty a -> a
NE.head NonEmpty (UnitEnvGraphKey, HomeUnitEnv)
unitEnvList
in
(Map UnitEnvGraphKey HomeUnitEnv -> HomeUnitGraph
forall v. Map UnitEnvGraphKey v -> UnitEnvGraph v
unitEnv_new ([(UnitEnvGraphKey, HomeUnitEnv)] -> Map UnitEnvGraphKey HomeUnitEnv
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (NonEmpty (UnitEnvGraphKey, HomeUnitEnv)
-> [(UnitEnvGraphKey, HomeUnitEnv)]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (UnitEnvGraphKey, HomeUnitEnv)
unitEnvList))), UnitEnvGraphKey
activeUnit)
showBanner :: PostLoadMode -> DynFlags -> IO ()
showBanner :: PostLoadMode -> DynFlags -> IO ()
showBanner PostLoadMode
_postLoadMode DynFlags
dflags = do
let verb :: Int
verb = DynFlags -> Int
verbosity DynFlags
dflags
#if defined(HAVE_INTERNAL_INTERPRETER)
Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (PostLoadMode -> Bool
isInteractiveMode PostLoadMode
_postLoadMode Bool -> Bool -> Bool
&& Int
verb Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FatalMessager
putStrLn String
ghciWelcomeMsg
#endif
Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Int
verb Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
do Handle -> FatalMessager
hPutStr Handle
stderr String
"Glasgow Haskell Compiler, Version "
Handle -> FatalMessager
hPutStr Handle
stderr String
cProjectVersion
Handle -> FatalMessager
hPutStr Handle
stderr String
", stage "
Handle -> FatalMessager
hPutStr Handle
stderr String
cStage
Handle -> FatalMessager
hPutStr Handle
stderr String
" booted by GHC version "
Handle -> FatalMessager
hPutStrLn Handle
stderr String
cBooterVersion
showInfo :: DynFlags -> IO ()
showInfo :: DynFlags -> IO ()
showInfo DynFlags
dflags = do
let sq :: String -> String
sq String
x = String
" [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n ]"
FatalMessager
putStrLn FatalMessager -> FatalMessager
forall a b. (a -> b) -> a -> b
$ String -> String
sq (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n ," ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
forall a. Show a => a -> String
show ([(String, String)] -> [String]) -> [(String, String)] -> [String]
forall a b. (a -> b) -> a -> b
$ DynFlags -> [(String, String)]
compilerInfo DynFlags
dflags
showSupportedExtensions :: Maybe String -> IO ()
showSupportedExtensions :: Maybe String -> IO ()
showSupportedExtensions Maybe String
m_top_dir = do
Either SettingsError Settings
res <- ExceptT SettingsError IO Settings
-> IO (Either SettingsError Settings)
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT SettingsError IO Settings
-> IO (Either SettingsError Settings))
-> ExceptT SettingsError IO Settings
-> IO (Either SettingsError Settings)
forall a b. (a -> b) -> a -> b
$ do
String
top_dir <- IO (Maybe String) -> ExceptT SettingsError IO (Maybe String)
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT SettingsError m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe String -> IO (Maybe String)
tryFindTopDir Maybe String
m_top_dir) ExceptT SettingsError IO (Maybe String)
-> (Maybe String -> ExceptT SettingsError IO String)
-> ExceptT SettingsError IO String
forall a b.
ExceptT SettingsError IO a
-> (a -> ExceptT SettingsError IO b) -> ExceptT SettingsError IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe String
Nothing -> SettingsError -> ExceptT SettingsError IO String
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (SettingsError -> ExceptT SettingsError IO String)
-> SettingsError -> ExceptT SettingsError IO String
forall a b. (a -> b) -> a -> b
$ String -> SettingsError
SettingsError_MissingData String
"Could not find the top directory, missing -B flag"
Just String
dir -> String -> ExceptT SettingsError IO String
forall a. a -> ExceptT SettingsError IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure String
dir
String -> ExceptT SettingsError IO Settings
forall (m :: Type -> Type).
MonadIO m =>
String -> ExceptT SettingsError m Settings
initSettings String
top_dir
ArchOS
arch_os <- case Either SettingsError Settings
res of
Right Settings
s -> ArchOS -> IO ArchOS
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ArchOS -> IO ArchOS) -> ArchOS -> IO ArchOS
forall a b. (a -> b) -> a -> b
$ Platform -> ArchOS
platformArchOS (Platform -> ArchOS) -> Platform -> ArchOS
forall a b. (a -> b) -> a -> b
$ Settings -> Platform
sTargetPlatform Settings
s
Left (SettingsError_MissingData String
msg) -> do
Handle -> FatalMessager
hPutStrLn Handle
stderr FatalMessager -> FatalMessager
forall a b. (a -> b) -> a -> b
$ String
"WARNING: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
msg
Handle -> FatalMessager
hPutStrLn Handle
stderr FatalMessager -> FatalMessager
forall a b. (a -> b) -> a -> b
$ String
"cannot know target platform so guessing target == host (native compiler)."
ArchOS -> IO ArchOS
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ArchOS
hostPlatformArchOS
Left (SettingsError_BadData String
msg) -> do
Handle -> FatalMessager
hPutStrLn Handle
stderr String
msg
ExitCode -> IO ArchOS
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ArchOS) -> ExitCode -> IO ArchOS
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
FatalMessager -> [String] -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FatalMessager
putStrLn ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ ArchOS -> [String]
supportedLanguagesAndExtensions ArchOS
arch_os
showVersion :: IO ()
showVersion :: IO ()
showVersion = FatalMessager
putStrLn FatalMessager -> FatalMessager
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [ String
"Clash, version "
, Version -> String
Data.Version.showVersion Version
Paths_clash_ghc.version
, String
" (using clash-lib, version: "
, Version -> String
Data.Version.showVersion Version
clashLibVersion
, String
")"
]
showOptions :: Bool -> IORef ClashOpts -> IO ()
showOptions :: Bool -> IORef ClashOpts -> IO ()
showOptions Bool
isInteractive = FatalMessager
putStr FatalMessager
-> (IORef ClashOpts -> String) -> IORef ClashOpts -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String)
-> (IORef ClashOpts -> [String]) -> IORef ClashOpts -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef ClashOpts -> [String]
availableOptions
where
availableOptions :: IORef ClashOpts -> [String]
availableOptions IORef ClashOpts
opts = [[String]] -> [String]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat
[ Bool -> [String]
flagsForCompletion Bool
isInteractive
, (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char
'-'Char -> String -> String
forall a. a -> [a] -> [a]
:) ([Flag ModeM] -> [String]
forall {m :: Type -> Type}. [Flag m] -> [String]
getFlagNames [Flag ModeM]
mode_flags)
, (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char
'-'Char -> String -> String
forall a. a -> [a] -> [a]
:) ([Flag IO] -> [String]
forall {m :: Type -> Type}. [Flag m] -> [String]
getFlagNames (IORef ClashOpts -> [Flag IO]
flagsClash IORef ClashOpts
opts))
]
getFlagNames :: [Flag m] -> [String]
getFlagNames [Flag m]
opts = (Flag m -> String) -> [Flag m] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Flag m -> String
forall (m :: Type -> Type). Flag m -> String
flagName [Flag m]
opts
showGhcUsage :: DynFlags -> IO ()
showGhcUsage :: DynFlags -> IO ()
showGhcUsage = Bool -> DynFlags -> IO ()
showUsage Bool
False
showGhciUsage :: DynFlags -> IO ()
showGhciUsage :: DynFlags -> IO ()
showGhciUsage = Bool -> DynFlags -> IO ()
showUsage Bool
True
showUsage :: Bool -> DynFlags -> IO ()
showUsage :: Bool -> DynFlags -> IO ()
showUsage Bool
ghci DynFlags
dflags = do
let usage_path :: String
usage_path = if Bool
ghci then DynFlags -> String
ghciUsagePath DynFlags
dflags
else DynFlags -> String
ghcUsagePath DynFlags
dflags
String
usage <- String -> IO String
readFile String
usage_path
String
progName <- IO String
getProgName
String -> FatalMessager
dump String
progName String
usage
where
dump :: String -> FatalMessager
dump String
progName String
xs = case String
xs of
String
"" -> () -> IO ()
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
Char
'$':Char
'$':String
s -> FatalMessager
putStr String
progName IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> String -> FatalMessager
dump String
progName String
s
Char
c:String
s -> Char -> IO ()
putChar Char
c IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> String -> FatalMessager
dump String
progName String
s
dumpFinalStats :: Logger -> IO ()
dumpFinalStats :: Logger -> IO ()
dumpFinalStats Logger
logger = do
Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_faststring_stats) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Logger -> IO ()
dumpFastStringStats Logger
logger
Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_faststrings) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[[[FastString]]]
fss <- IO [[[FastString]]]
getFastStringTable
let ppr_table :: [SDoc]
ppr_table = (([[FastString]], Int) -> SDoc)
-> [([[FastString]], Int)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ([[FastString]], Int) -> SDoc
ppr_segment ([[[FastString]]]
fss [[[FastString]]] -> [Int] -> [([[FastString]], Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
0..])
ppr_segment :: ([[FastString]], Int) -> SDoc
ppr_segment ([[FastString]]
s,Int
n) = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Segment" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
n) Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((([FastString], Int) -> SDoc) -> [([FastString], Int)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ([FastString], Int) -> SDoc
ppr_bucket ([[FastString]]
s [[FastString]] -> [Int] -> [([FastString], Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
0..])))
ppr_bucket :: ([FastString], Int) -> SDoc
ppr_bucket ([FastString]
b,Int
n) = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Bucket" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
n) Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((FastString -> SDoc) -> [FastString] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext [FastString]
b))
Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_faststrings String
"FastStrings" DumpFormat
FormatText ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [SDoc]
ppr_table)
dumpFastStringStats :: Logger -> IO ()
dumpFastStringStats :: Logger -> IO ()
dumpFastStringStats Logger
logger = do
[[[FastString]]]
segments <- IO [[[FastString]]]
getFastStringTable
Int
hasZ <- IO Int
getFastStringZEncCounter
let buckets :: [[FastString]]
buckets = [[[FastString]]] -> [[FastString]]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[[FastString]]]
segments
bucketsPerSegment :: [Int]
bucketsPerSegment = ([[FastString]] -> Int) -> [[[FastString]]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [[FastString]] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [[[FastString]]]
segments
entriesPerBucket :: [Int]
entriesPerBucket = ([FastString] -> Int) -> [[FastString]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [FastString] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [[FastString]]
buckets
entries :: Int
entries = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: Type -> Type) a. (Foldable t, Num a) => t a -> a
sum [Int]
entriesPerBucket
msg :: SDoc
msg = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"FastString stats:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
4 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"segments: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int ([[[FastString]]] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [[[FastString]]]
segments)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"buckets: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: Type -> Type) a. (Foldable t, Num a) => t a -> a
sum [Int]
bucketsPerSegment)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"entries: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
entries
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"largest segment: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int ([Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: Type -> Type) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
bucketsPerSegment)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"smallest segment: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int ([Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: Type -> Type) a. (Foldable t, Ord a) => t a -> a
minimum [Int]
bucketsPerSegment)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"longest bucket: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int ([Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: Type -> Type) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
entriesPerBucket)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"has z-encoding: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (Int
hasZ Int -> Int -> SDoc
forall {doc}. IsLine doc => Int -> Int -> doc
`pcntOf` Int
entries)
])
Logger -> SDoc -> IO ()
putMsg Logger
logger SDoc
msg
where
Int
x pcntOf :: Int -> Int -> doc
`pcntOf` Int
y = Int -> doc
forall doc. IsLine doc => Int -> doc
int ((Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
100) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
y) doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
Outputable.<> Char -> doc
forall doc. IsLine doc => Char -> doc
char Char
'%'
showUnits, dumpUnits, dumpUnitsSimple :: HscEnv -> IO ()
showUnits :: HscEnv -> IO ()
showUnits HscEnv
hsc_env = FatalMessager
putStrLn (DynFlags -> SDoc -> String
showSDoc (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) (UnitState -> SDoc
pprUnits ((() :: Constraint) => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env)))
dumpUnits :: HscEnv -> IO ()
dumpUnits HscEnv
hsc_env = Logger -> SDoc -> IO ()
putMsg (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (UnitState -> SDoc
pprUnits ((() :: Constraint) => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env))
dumpUnitsSimple :: HscEnv -> IO ()
dumpUnitsSimple HscEnv
hsc_env = Logger -> SDoc -> IO ()
putMsg (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (UnitState -> SDoc
pprUnitsSimple ((() :: Constraint) => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env))
doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()
doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()
doFrontend ModuleName
modname [(String, Maybe Phase)]
srcs = do
HscEnv
hsc_env <- Ghc HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
getSession
(FrontendPlugin
frontend_plugin, [Linkable]
_pkgs, PkgsLoaded
_deps) <- IO (FrontendPlugin, [Linkable], PkgsLoaded)
-> Ghc (FrontendPlugin, [Linkable], PkgsLoaded)
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (FrontendPlugin, [Linkable], PkgsLoaded)
-> Ghc (FrontendPlugin, [Linkable], PkgsLoaded))
-> IO (FrontendPlugin, [Linkable], PkgsLoaded)
-> Ghc (FrontendPlugin, [Linkable], PkgsLoaded)
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> IO (FrontendPlugin, [Linkable], PkgsLoaded)
loadFrontendPlugin HscEnv
hsc_env ModuleName
modname
FrontendPlugin -> [String] -> [(String, Maybe Phase)] -> Ghc ()
frontend FrontendPlugin
frontend_plugin
([String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ DynFlags -> [String]
frontendPluginOpts (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) [(String, Maybe Phase)]
srcs
abiHash :: [String]
-> Ghc ()
abiHash :: [String] -> Ghc ()
abiHash [String]
strs = do
HscEnv
hsc_env <- Ghc HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
getSession
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
let find_it :: String -> IO Module
find_it String
str = do
let modname :: ModuleName
modname = String -> ModuleName
mkModuleName String
str
FindResult
r <- HscEnv -> ModuleName -> PkgQual -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
modname PkgQual
NoPkgQual
case FindResult
r of
Found ModLocation
_ Module
m -> Module -> IO Module
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Module
m
FindResult
_error -> GhcException -> IO Module
forall a. GhcException -> a
throwGhcException (GhcException -> IO Module) -> GhcException -> IO Module
forall a b. (a -> b) -> a -> b
$ String -> GhcException
CmdLineError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$
HscEnv -> ModuleName -> FindResult -> SDoc
cannotFindModule HscEnv
hsc_env ModuleName
modname FindResult
r
[Module]
mods <- (String -> IO Module) -> [String] -> IO [Module]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM String -> IO Module
find_it [String]
strs
let get_iface :: Module -> IfM lcl ModIface
get_iface Module
modl = IsBootInterface -> SDoc -> Module -> IfM lcl ModIface
forall lcl. IsBootInterface -> SDoc -> Module -> IfM lcl ModIface
loadUserInterface IsBootInterface
NotBoot (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"abiHash") Module
modl
[ModIface]
ifaces <- SDoc -> HscEnv -> IfG [ModIface] -> IO [ModIface]
forall a. SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"abiHash") HscEnv
hsc_env (IfG [ModIface] -> IO [ModIface])
-> IfG [ModIface] -> IO [ModIface]
forall a b. (a -> b) -> a -> b
$ (Module -> IOEnv (Env IfGblEnv ()) ModIface)
-> [Module] -> IfG [ModIface]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM Module -> IOEnv (Env IfGblEnv ()) ModIface
forall {lcl}. Module -> IfM lcl ModIface
get_iface [Module]
mods
BinHandle
bh <- Int -> IO BinHandle
openBinMem (Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1024)
BinHandle -> Integer -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Integer
hiVersion
(ModIface -> IO ()) -> [ModIface] -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (BinHandle -> Fingerprint -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Fingerprint -> IO ())
-> (ModIface -> Fingerprint) -> ModIface -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIfaceBackend -> Fingerprint
mi_mod_hash (ModIfaceBackend -> Fingerprint)
-> (ModIface -> ModIfaceBackend) -> ModIface -> Fingerprint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> IfaceBackendExts 'ModIfaceFinal
ModIface -> ModIfaceBackend
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts) [ModIface]
ifaces
Fingerprint
f <- BinHandle -> IO Fingerprint
fingerprintBinMem BinHandle
bh
FatalMessager
putStrLn (DynFlags -> Fingerprint -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags Fingerprint
f)
makeHDL'
:: forall backend
. Clash.Backend.Backend backend
=> Proxy backend
-> Ghc ()
-> IORef ClashOpts
-> [(String,Maybe Phase)]
-> Ghc ()
makeHDL' :: forall backend.
Backend backend =>
Proxy backend
-> Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeHDL' Proxy backend
_ Ghc ()
_ IORef ClashOpts
_ [] = GhcException -> Ghc ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError String
"No input files")
makeHDL' Proxy backend
proxy Ghc ()
startAction IORef ClashOpts
r [(String, Maybe Phase)]
srcs = Proxy backend -> Ghc () -> IORef ClashOpts -> [String] -> Ghc ()
forall backend (m :: Type -> Type).
(GhcMonad m, Backend backend) =>
Proxy backend -> Ghc () -> IORef ClashOpts -> [String] -> m ()
makeHDL Proxy backend
proxy Ghc ()
startAction IORef ClashOpts
r ([String] -> Ghc ()) -> [String] -> Ghc ()
forall a b. (a -> b) -> a -> b
$ ((String, Maybe Phase) -> String)
-> [(String, Maybe Phase)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, Maybe Phase) -> String
forall a b. (a, b) -> a
fst [(String, Maybe Phase)]
srcs
makeVHDL :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeVHDL :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeVHDL = Proxy VHDLState
-> Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
forall backend.
Backend backend =>
Proxy backend
-> Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeHDL' (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @VHDLState)
makeVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeVerilog = Proxy VerilogState
-> Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
forall backend.
Backend backend =>
Proxy backend
-> Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeHDL' (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @VerilogState)
makeSystemVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeSystemVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeSystemVerilog = Proxy SystemVerilogState
-> Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
forall backend.
Backend backend =>
Proxy backend
-> Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeHDL' (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @SystemVerilogState)
unknownFlagsErr :: [String] -> a
unknownFlagsErr :: forall a. [String] -> a
unknownFlagsErr [String]
fs = GhcException -> a
forall a. GhcException -> a
throwGhcException (GhcException -> a) -> GhcException -> a
forall a b. (a -> b) -> a -> b
$ String -> GhcException
UsageError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> String
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap String -> String
oneError [String]
fs
where
oneError :: String -> String
oneError String
f =
String
"unrecognised flag: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
(case String -> [String] -> [String]
match String
f ([String] -> [String]
forall a. Ord a => [a] -> [a]
nubSort [String]
allNonDeprecatedFlags) of
[] -> String
""
[String]
suggs -> String
"did you mean one of:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
suggs))
match :: String -> [String] -> [String]
match String
f [String]
allFlags
| Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
elem Char
'=' String
f =
let ([String]
flagsWithEq, [String]
flagsWithoutEq) = (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
elem Char
'=') [String]
allFlags
fName :: String
fName = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'=') String
f
in (String -> [String] -> [String]
fuzzyMatch String
f [String]
flagsWithEq) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (String -> [String] -> [String]
fuzzyMatch String
fName [String]
flagsWithoutEq)
| Bool
otherwise = String -> [String] -> [String]
fuzzyMatch String
f [String]
allFlags