{-# 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.Errors.Types
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 GHC.Iface.Errors.Ppr

-- Standard Haskell libraries
import System.IO
import System.Environment
import System.Exit
import System.FilePath
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
    argv0 <- IO [String]
getArgs

    let 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
    libDir <- ghcLibDir

    r <- newIORef defClashOpts
    (argv2, clashFlagWarnings) <- parseClashFlags r argv1

    -- 2. Parse the "mode" flags (--make, --interactive etc.)
    (mode, units, argv3, modeFlagWarnings) <- parseModeFlags argv2
    let 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 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

            dflags <- Ghc DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
            let dflagsExtra = DynFlags -> DynFlags
setWantedLanguageExtensions DynFlags
dflags

                ghcTyLitNormPlugin = String -> ModuleName
GHC.mkModuleName String
"GHC.TypeLits.Normalise"
                ghcTyLitExtrPlugin = String -> ModuleName
GHC.mkModuleName String
"GHC.TypeLits.Extra.Solver"
                ghcTyLitKNPlugin   = String -> ModuleName
GHC.mkModuleName String
"GHC.TypeLits.KnownNat.Solver"
                dflagsExtra1 = DynFlags
dflagsExtra
                                  { Session.pluginModNames = nub $
                                      ghcTyLitNormPlugin : ghcTyLitExtrPlugin :
                                      ghcTyLitKNPlugin :
                                      Session.pluginModNames dflagsExtra
                                  }

            case 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
                                       -- By default enable the debugger by inserting breakpoints
                                       DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_InsertBreakpoints

  logger1 <- Ghc Logger
forall (m :: Type -> Type). HasLogger m => m Logger
getLogger
  let logger2 = Logger -> LogFlags -> Logger
setLogFlags Logger
logger1 (DynFlags -> LogFlags
initLogFlags DynFlags
dflags2)

        -- The rest of the arguments are "dynamic"
        -- Leftover ones are presumably files
  (dflags3, fileish_args, dynamicFlagWarnings) <-
      GHC.parseDynamicFlags logger2 dflags2 args'

  -- Propagate -Werror to Clash
  liftIO . modifyIORef' clashOpts $ \ClashOpts
opts ->
    ClashOpts
opts { opt_werror = EnumSet.member Opt_WarnIsError (generalFlags dflags3) }

  let 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 -> LogFlags -> Logger
setLogFlags Logger
logger2 (DynFlags -> LogFlags
initLogFlags DynFlags
dflags4)

  GHC.prettyPrintGhcErrors logger4 $ do

  let diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags4
  let flagWarnings' = DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage)
-> Messages DriverMessage -> Messages GhcMessage
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Messages DriverMessage] -> Messages DriverMessage
forall a. Monoid a => [a] -> a
mconcat [DiagOpts -> [Warn] -> Messages DriverMessage
warnsToMessages DiagOpts
diag_opts [Warn]
flagWarnings, Messages DriverMessage
dynamicFlagWarnings]

  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)) $ do
         liftIO $ printOrThrowDiagnostics logger4 (initPrintConfig dflags4) diag_opts flagWarnings'

  liftIO $ showBanner postLoadMode dflags4

  let (dflags5, srcs, objs) = parseTargetFiles dflags4 (map unLoc fileish_args)

  -- we've finished manipulating the DynFlags, update the session
  _ <- GHC.setSessionDynFlags dflags5
  dflags6 <- GHC.getSessionDynFlags

  -- Must do this before loading plugins
  liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6)

  -- Initialise plugins here because the plugin author might already expect this
  -- subsequent call to `getLogger` to be affected by a plugin.
  initializeSessionPlugins
  hsc_env <- getSession
  logger <- getLogger


        ---------------- Display configuration -----------
  case verbosity 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 -----------
  liftIO $ checkOptions postLoadMode dflags6 srcs objs units

  ---------------- Do the business -----------
  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)) $ do
    clashOpts' <- liftIO (readIORef clashOpts)
    let 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 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)
                                                    (HasDebugCallStack => 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

  liftIO $ dumpFinalStats 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
    dflags <- Ghc DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
    let mainFun = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"main" (DynFlags -> Maybe String
mainFunIs DynFlags
dflags)
    ghciUI clashOpts units srcs (Just ["System.Environment.withArgs " ++ show args' ++ " (Control.Monad.void " ++ mainFun ++ ")"])
  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
  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
          s <- [(String, Maybe Phase)] -> Ghc [(String, Maybe Phase)]
initMake [(String, Maybe Phase)]
srcs
          return $ map (uncurry (,Nothing,)) s
  interactiveUI (defaultGhciSettings clashOpts) hs_srcs 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
     flg <- String -> IO Bool
doesDirNameExist String
fn
     when (not flg) (nonExistentDir "-o" 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
     flg <- String -> IO Bool
doesDirNameExist String
hi
     when (not flg) (nonExistentDir "-ohi" 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
  ((leftover, errs1, warns), (mModeFlag, units, errs2, 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 = 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]
  unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $
      map (("on the commandline", )) $ map (unLoc . errMsg) errs1 ++ errs2

  return (mode, units, flags' ++ leftover, 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"
          ],
    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
  (mModeFlag, units, errs, flags') <- CmdLineP
  (Maybe (Mode, String), [String], [String], [Located String])
  (Maybe (Mode, String), [String], [String], [Located String])
forall s. CmdLineP s s
getCmdLineState
  putCmdLineState (mModeFlag, unit_str:units, errs, 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
    (mModeFlag, units, errs, flags') <- CmdLineP
  (Maybe (Mode, String), [String], [String], [Located String])
  (Maybe (Mode, String), [String], [String], [Located String])
forall s. CmdLineP s s
getCmdLineState
    let (modeFlag', errs') =
            case 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)
    putCmdLineState (Just modeFlag', units, errs', 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
  (m, units, e, flags') <- CmdLineP
  (Maybe (Mode, String), [String], [String], [Located String])
  (Maybe (Mode, String), [String], [String], [Located String])
forall s. CmdLineP s s
getCmdLineState
  putCmdLineState (m, units, e, mkGeneralLocated loc s : 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
  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
      s <- [(String, Maybe Phase)] -> Ghc [(String, Maybe Phase)]
initMake [(String, Maybe Phase)]
targets
      return $ map (uncurry (,Nothing,)) s
  case 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
      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
      GHC.setTargets targets'
      ok_flag <- GHC.load LoadAllTargets
      when (failed ok_flag) (liftIO $ exitWith (ExitFailure 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

    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 (null hs_srcs)
       then liftIO (oneShot hsc_env NoStop srcs) >> return []
       else do

    o_files <- 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)
                 non_hs_srcs
    dflags <- GHC.getSessionDynFlags
    let dflags' = DynFlags
dflags { ldInputs = map (FileOption "") o_files
                                      ++ ldInputs dflags }
    _ <- GHC.setSessionDynFlags dflags'
    return 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
  hsc_env <- Ghc HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
  let logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
  initial_dflags <- GHC.getSessionDynFlags

  dynFlagsAndSrcs <- forM unitArgsFiles $ \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)
    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]
    (dflags2, fileish_args, warns) <- parseDynamicFlagsCmdLine initial_dflags (map (mkGeneralLocated f) (removeRTS args))
    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)) $ do
         liftIO $ printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns)

    let (dflags3, srcs, objs) = parseTargetFiles dflags2 (map unLoc fileish_args)
        dflags4 = DynFlags -> DynFlags
offsetDynFlags DynFlags
dflags3

    let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget 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 = HasDebugCallStack => 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 (null hs_srcs)
       then liftIO (oneShot dubious_hsc_env NoStop srcs) >> return (dflags4, [])
       else do

    o_files <- 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)
                 non_hs_srcs
    let dflags5 = DynFlags
dflags4 { ldInputs = map (FileOption "") o_files
                                      ++ ldInputs dflags4 }

    liftIO $ checkOptions DoMake dflags5 srcs objs []

    pure (dflags5, hs_srcs)

  let
    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 = ((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
    (hs_srcs, _non_hs_srcs) = unzip (map (partition (\(String
file, Maybe UnitEnvGraphKey
_uid, Maybe Phase
phase) -> (String, Maybe Phase) -> Bool
isHaskellishTarget (String
file, Maybe Phase
phase))) (NE.toList srcs))

  checkDuplicateUnits initial_dflags (NE.toList (NE.zip unitArgsFiles unitDflags))

  let (initial_home_graph, mainUnitId) = createUnitEnvFromFlags unitDflags
      home_units = HomeUnitGraph -> Set UnitEnvGraphKey
forall v. UnitEnvGraph v -> Set UnitEnvGraphKey
unitEnv_keys HomeUnitGraph
initial_home_graph

  home_unit_graph <- forM initial_home_graph $ \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
    (dbs,unit_state,home_unit,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

    updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
    pure $ HomeUnitEnv
      { homeUnitEnv_units = unit_state
      , homeUnitEnv_unit_dbs = Just dbs
      , homeUnitEnv_dflags = updated_dflags
      , homeUnitEnv_hpt = emptyHomePackageTable
      , homeUnitEnv_home_unit = Just home_unit
      }

  checkUnitCycles initial_dflags home_unit_graph

  let 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 <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))
  let final_hsc_env = HscEnv
hsc_env { hsc_unit_env = unitEnv }

  GHC.setSession 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 (null hs_srcs)
      then do
        liftIO $ hPutStrLn stderr $ "Multi Mode can not be used for one-shot mode."
        liftIO $ exitWith (ExitFailure 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 }
  return $ concat 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
  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
    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
    initSettings top_dir
  arch_os <- case 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
  mapM_ putStrLn $ supportedLanguagesAndExtensions 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
  usage <- String -> IO String
readFile String
usage_path
  progName <- getProgName
  dump progName 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
    fss <- IO [[[FastString]]]
getFastStringTable
    let 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]]
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]
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))
    putDumpFileMaybe logger Opt_D_dump_faststrings "FastStrings" FormatText (vcat ppr_table)

dumpFastStringStats :: Logger -> IO ()
dumpFastStringStats :: Logger -> IO ()
dumpFastStringStats Logger
logger = do
  segments <- IO [[[FastString]]]
getFastStringTable
  hasZ <- getFastStringZEncCounter
  let buckets = [[[FastString]]] -> [[FastString]]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[[FastString]]]
segments
      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 = ([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] -> Int
forall a. Num a => [a] -> a
forall (t :: Type -> Type) a. (Foldable t, Num a) => t a -> a
sum [Int]
entriesPerBucket
      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.
  putMsg logger 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 (HasDebugCallStack => 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 (HasDebugCallStack => 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 (HasDebugCallStack => 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
    hsc_env <- Ghc HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
getSession
    (frontend_plugin, _pkgs, _deps) <- liftIO $ loadFrontendPlugin hsc_env modname -- TODO do these need to recorded?
    frontend frontend_plugin
      (reverse $ frontendPluginOpts (hsc_dflags hsc_env)) 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
  hsc_env <- Ghc HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
getSession
  let dflags    = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

  liftIO $ do

  let find_it String
str = do
         let modname :: ModuleName
modname = String -> ModuleName
mkModuleName String
str
         r <- HscEnv -> ModuleName -> PkgQual -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
modname PkgQual
NoPkgQual
         case 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    ->
            let opts :: DiagnosticOpts IfaceMessage
opts   = DynFlags -> DiagnosticOpts IfaceMessage
initIfaceMessageOpts DynFlags
dflags
                err_txt :: SDoc
err_txt = IfaceMessageOpts -> MissingInterfaceError -> SDoc
missingInterfaceErrorDiagnostic IfaceMessageOpts
opts
                        (MissingInterfaceError -> SDoc) -> MissingInterfaceError -> SDoc
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> FindResult -> MissingInterfaceError
cannotFindModule HscEnv
hsc_env ModuleName
modname FindResult
r
            in GhcException -> IO Module
forall a. GhcException -> a
throwGhcException (GhcException -> IO Module)
-> (String -> GhcException) -> String -> IO Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GhcException
CmdLineError (String -> IO Module) -> String -> IO Module
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags SDoc
err_txt

  mods <- mapM find_it strs

  let 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
  ifaces <- initIfaceCheck (text "abiHash") hsc_env $ mapM get_iface mods

  bh <- openBinMem (3*1024) -- just less than a block
  put_ bh hiVersion
    -- package hashes change when the compiler version changes (for now)
    -- see #5328
  mapM_ (put_ bh . mi_mod_hash . mi_final_exts) ifaces
  f <- fingerprintBinMem bh

  putStrLn (showPpr dflags 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]
flagSuggestions ([String] -> [String]
forall a. Ord a => [a] -> [a]
nubSort [String]
allNonDeprecatedFlags) String
f 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))