{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}

-----------------------------------------------------------------------------
--
-- GHC Driver program
--
-- (c) The University of Glasgow 2005
--
-----------------------------------------------------------------------------

module Clash.Main (defaultMain, defaultMainWithAction) where

-- The official GHC API
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

-- Standard Haskell libraries
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

-- clash additions
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)

-----------------------------------------------------------------------------
-- ToDo:

-- time commands when run with -v
-- user ways
-- Win32 support: proper signal handling
-- reading the package configuration file is too slow
-- -K<size>

-----------------------------------------------------------------------------
-- GHC's command-line interface

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
    -- 1. extract the -B flag from the args
    [String]
argv0 <- IO [String]
getArgs

    -- let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0
    --     mbMinusB | null minusB_args = Nothing
    --              | otherwise = Just (drop 2 (last minusB_args))

    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

    -- 2. Parse the "mode" flags (--make, --interactive etc.)
    (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

    -- If all we want to do is something like showing the version number
    -- then do it now, before we start a GHC session etc. This makes
    -- getting basic information much more resilient.

    -- In particular, if we wait until later before giving the version
    -- number then bootstrapping gets confused, as it tries to find out
    -- what version of GHC it's using before package.conf exists, so
    -- starting the session fails.
    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 ->
            -- start our GHC session
            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

  -- set the default GhcMode, backend and GhcLink.  The backend
  -- can be further adjusted on a module by module basis, using only
  -- the -fllvm and -fasm flags.  If the default backend is not
  -- LLVM or NCG, -fllvm and -fasm have no effect.
  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
                        }

      -- turn on -fimplicit-import-qualified for GHCi now, so that it
      -- can be overridden from the command-line
      -- XXX: this should really be in the interactive DynFlags, but
      -- we don't set that until later in interactiveUI
      -- We also set -fignore-optim-changes and -fignore-hpc-changes,
      -- which are program-level options. Again, this doesn't really
      -- feel like the right place to handle this, but we don't have
      -- a great story for the moment.
      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
                                       -- Setting this by default has the nice effect that
                                       -- -fno-code and --interactive falls back to interpreter rather than
                                       -- object code but has little other effect unless you are also using
                                       -- fat interface files.
                                       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)

        -- The rest of the arguments are "dynamic"
        -- Leftover ones are presumably files
  (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'

  -- Propagate -Werror to Clash
  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)

  -- we've finished manipulating the DynFlags, update the session
  ()
_ <- 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

  -- Must do this before loading plugins
  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)

  -- Initialise plugins here because the plugin author might already expect this
  -- subsequent call to `getLogger` to be affected by a plugin.
  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


        ---------------- Display configuration -----------
  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 ()

        ---------------- Final sanity checking -----------
  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

  ---------------- Do the business -----------
  (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


-- -----------------------------------------------------------------------------
-- Option sanity checks

-- | Ensure sanity of options.
--
-- Throws 'UsageError' or 'CmdLineError' if not.
checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> [String] -> IO ()
     -- Final sanity checking before kicking off a compilation (pipeline).
checkOptions :: PostLoadMode
-> DynFlags
-> [(String, Maybe Phase)]
-> [String]
-> [String]
-> IO ()
checkOptions PostLoadMode
mode DynFlags
dflags [(String, Maybe Phase)]
srcs [String]
objs [String]
units = do
     -- Complain about any unknown flags
   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")

        -- -prof and --interactive are not a good combination
   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).")
        -- -ohi sanity check
   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

        -- -o sanity checking
   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)

        -- Check that there are some input files
        -- (except in the interactive case)
   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 ()

     -- Verify that output files point somewhere sensible.
   DynFlags -> IO ()
verifyOutputFiles DynFlags
dflags

-- Compiler output options

-- Called to verify that the output files point somewhere valid.
--
-- The assumption is that the directory portion of these output
-- options will have to exist by the time 'verifyOutputFiles'
-- is invoked.
--
-- We create the directories for -odir, -hidir, -outputdir etc. ourselves if
-- they don't exist, so don't check for those here (#2278).
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.)"))

-----------------------------------------------------------------------------
-- GHC modes of operation

type Mode = Either PreStartupMode PostStartupMode
type PostStartupMode = Either PreLoadMode PostLoadMode

data PreStartupMode
  = ShowVersion                          -- ghc -V/--version
  | ShowNumVersion                       -- ghc --numeric-version
  | ShowSupportedExtensions              -- ghc --supported-extensions
  | ShowOptions Bool {- isInteractive -} -- ghc --show-options

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                           -- ghc -?
  | ShowGhciUsage                          -- ghci -?
  | ShowInfo                               -- ghc --info
  | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo

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  -- ghc --show-iface
  | DoMkDependHS            -- ghc -M
  | StopBefore StopPhase    -- ghc -E | -C | -S
                            -- StopBefore StopLn is the default
  | DoMake                  -- ghc --make
  | DoBackpack              -- ghc --backpack foo.bkp
  | DoInteractive           -- ghc --interactive
  | DoEval [String]         -- ghc -e foo -e bar => DoEval ["bar", "foo"]
  | DoRun                   -- ghc --run
  | DoAbiHash               -- ghc --abi-hash
  | ShowPackages            -- ghc --show-packages
  | DoFrontend ModuleName   -- ghc --frontend Plugin.Module
  | DoVHDL                  -- ghc --vhdl
  | DoVerilog               -- ghc --verilog
  | DoSystemVerilog         -- ghc --systemverilog

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: byte-code compiler involved
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

-- True if we are going to attempt to link in this mode.
-- (we might not actually link, depending on the GhcLink flag)
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

-- -----------------------------------------------------------------------------
-- Parsing the mode flag

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

  -- See Note [Handling errors when parsing command-line flags]
  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 sometimes give rise to new DynFlags (eg. -C, see below)
  -- so we collect the new ones and return them.

mode_flags :: [Flag ModeM]
mode_flags :: [Flag ModeM]
mode_flags =
  [  ------- help / version ----------------------------------------------
    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]
++
      ------- interfaces ----------------------------------------------------
  [ 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"))

      ------- primary modes ------------------------------------------------
  , 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
                    -- -c/--make are allowed together, and mean --make -no-link
                    (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"), [])

                    -- If we have both --help and --interactive then we
                    -- want showGhciUsage
                    (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), [])

                    -- If we have both -e and --interactive then -e always wins
                    (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), [])

                    -- Otherwise, --help/--version/--numeric-version always win
                      | Mode -> Bool
isDominantFlag Mode
oldMode -> ((Mode
oldMode, String
oldFlag), [])
                      | Mode -> Bool
isDominantFlag Mode
newMode -> ((Mode
newMode, String
newFlag), [])
                    -- We need to accumulate eval flags like "-e foo -e bar"
                    (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)
                    -- Saying e.g. --interactive --interactive is OK
                    (Mode, Mode)
_ | String
oldFlag String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
newFlag -> ((Mode
oldMode, String
oldFlag), [String]
errs)

                    -- --interactive and --show-options are used together
                    (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)
                    -- Otherwise, complain
                    (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"

-- ----------------------------------------------------------------------------
-- Run --make mode

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 we have no haskell sources from which to do a dependency
    -- analysis, then just do one-shot compilation and/or linking.
    -- This means that "ghc Foo.o Bar.o -o baz" links the program as
    -- we expect.
    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

-- Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list.
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

    -- This is dubious as the whole unit environment won't be set-up correctly, but
    -- that doesn't matter for what we use it for (linking and oneShot)
    let dubious_hsc_env :: HscEnv
dubious_hsc_env = (() :: Constraint) => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags4 HscEnv
hsc_env
    -- if we have no haskell sources from which to do a dependency
    -- analysis, then just do one-shot compilation and/or linking.
    -- This means that "ghc Foo.o Bar.o -o baz" links the program as
    -- we expect.
    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 we have no haskell sources from which to do a dependency
  -- analysis, then just do one-shot compilation and/or linking.
  -- This means that "ghc Foo.o Bar.o -o baz" links the program as
  -- we expect.
  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

{-
  o_files <- liftIO $ mapMaybeM
                (\(src, uid, mphase) ->
                  compileFile (hscSetActiveHomeUnit (ue_unitHomeUnit (fromJust uid) unitEnv) final_hsc_env) NoStop (src, mphase)
                )
                (concat non_hs_srcs)
                -}

  -- MP: This should probably modify dflags for each unit?
  --let dflags' = dflags { ldInputs = map (FileOption "") o_files
  --                                  ++ ldInputs dflags }
  [(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

-- | Check that we don't have multiple units with the same UnitId.

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)

-- ---------------------------------------------------------------------------
-- Various banners and verbosity output.

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)
   -- Show the GHCi banner
   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

   -- Display details of the configuration in verbose mode
   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

-- We print out a Read-friendly string, but a prettier one than the
-- Show instance gives us
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

-- TODO use GHC.Utils.Error once that is disentangled from all the other GhcMonad stuff?
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)
        ])
        -- we usually get more "has z-encoding" than "z-encoded", because
        -- when we z-encode a string it might hash to the exact same string,
        -- which is not counted as "z-encoded".  Only strings whose
        -- Z-encoding is different from the original string are counted in
        -- the "z-encoded" total.
  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))

-- -----------------------------------------------------------------------------
-- Frontend plugin support

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 -- TODO do these need to recorded?
    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

-- -----------------------------------------------------------------------------
-- ABI hash support

{-
        ghc --abi-hash Data.Foo System.Bar

Generates a combined hash of the ABI for modules Data.Foo and
System.Bar.  The modules must already be compiled, and appropriate -i
options may be necessary in order to find the .hi files.

This is used by Cabal for generating the ComponentId for a
package.  The ComponentId must change when the visible ABI of
the package changes, so during registration Cabal calls ghc --abi-hash
to get a hash of the package's ABI.
-}

-- | Print ABI hash of input modules.
--
-- The resulting hash is the MD5 of the GHC version used (#5328,
-- see 'hiVersion') and of the existing ABI hash from each module (see
-- 'mi_mod_hash').
abiHash :: [String] -- ^ List of module names
        -> 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) -- just less than a block
  BinHandle -> Integer -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Integer
hiVersion
    -- package hashes change when the compiler version changes (for now)
    -- see #5328
  (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)

-----------------------------------------------------------------------------
-- HDL Generation

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)

-- -----------------------------------------------------------------------------
-- Util

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))
    -- fixes #11789
    -- If the flag contains '=',
    -- this uses both the whole and the left side of '=' for comparing.
    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