{-# 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              ( -- DynFlags(..), HscTarget(..),
                          -- GhcMode(..), GhcLink(..),
                          Ghc, GhcMonad(..),
                          LoadHowMuch(..) )
import CmdLineParser

-- Implementations of the various modes (--show-iface, mkdependHS. etc.)
import LoadIface        ( showIface )
import HscMain          ( newHscEnv )
import DriverPipeline   ( oneShot, compileFile )
import DriverMkDepend   ( doMkDependHS )
import DriverBkp   ( doBackpack )
#if defined(HAVE_INTERNAL_INTERPRETER)
import Clash.GHCi.UI    ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )
#endif

-- Frontend plugins
import DynamicLoading   ( loadFrontendPlugin )
import Plugins
#if defined(HAVE_INTERNAL_INTERPRETER)
import DynamicLoading   ( initializePlugins )
#endif
import Module           ( ModuleName )


-- Various other random stuff that we need
import GHC.HandleEncoding
import GHC.Platform
import GHC.Platform.Host
import Config
import Constants
import HscTypes
import Packages         ( pprPackages, pprPackagesSimple )
import DriverPhases
import BasicTypes       ( failed )
import DynFlags hiding (WarnReason(..))
import EnumSet as EnumSet
import ErrUtils
import FastString
import Outputable
import SysTools.BaseDir
import SysTools.Settings
import SrcLoc
import Util
import Panic
import UniqSupply
import MonadUtils       ( liftIO )

-- Imports for --abi-hash
import LoadIface           ( loadUserInterface )
import Module              ( mkModuleName )
import Finder              ( findImportedModule, cannotFindModule )
import TcRnMonad           ( initIfaceCheck )
import Binary              ( openBinMem, put_ )
import BinFingerprint      ( fingerprintBinMem )

-- 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 ( isPrefixOf, partition, intercalate, nub )
import Data.Proxy
import Data.Maybe

-- clash additions
import           Paths_clash_ghc
import           Clash.GHCi.UI (makeHDL)
import           Exception (gcatch)
import           Data.IORef (IORef, newIORef, readIORef, modifyIORef')
import qualified Data.Version (showVersion)

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 (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
   IO ()
initGCStatistics -- See Note [-Bsymbolic and hooks]
   Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
LineBuffering
   Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
LineBuffering

   IO ()
configureHandleEncoding
   FatalMessager -> FlushOut -> IO () -> IO ()
forall (m :: Type -> Type) a.
ExceptionMonad m =>
FatalMessager -> FlushOut -> m a -> m a
GHC.defaultErrorHandler FatalMessager
defaultFatalMessager FlushOut
defaultFlushOut (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    -- 1. extract the -B flag from the args
    [String]
argv0 <- IO [String]
getArgs

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

    let argv1 :: [Located String]
argv1 = (String -> Located String) -> [String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> SrcSpanLess (Located String) -> Located String
forall e. HasSrcSpan e => String -> SrcSpanLess e -> e
mkGeneralLocated String
"on the commandline") [String]
argv0
    String
libDir <- IO String
ghcLibDir

    IORef ClashOpts
r <- ClashOpts -> IO (IORef ClashOpts)
forall a. a -> IO (IORef a)
newIORef ClashOpts
defClashOpts
    ([Located String]
argv2, [Warn]
clashFlagWarnings) <- IORef ClashOpts
-> [Located String] -> IO ([Located String], [Warn])
parseClashFlags IORef ClashOpts
r [Located String]
argv1

    -- 2. Parse the "mode" flags (--make, --interactive etc.)
    (Mode
mode, [Located String]
argv3, [Warn]
modeFlagWarnings) <- [Located String] -> IO (Mode, [Located String], [Warn])
parseModeFlags [Located String]
argv2
    let flagWarnings :: [Warn]
flagWarnings = [Warn]
modeFlagWarnings [Warn] -> [Warn] -> [Warn]
forall a. [a] -> [a] -> [a]
++ [Warn]
clashFlagWarnings

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

    -- In particular, if we wait until later before giving the version
    -- number then bootstrapping gets confused, as it tries to find out
    -- what version of GHC it's using before package.conf exists, so
    -- starting the session fails.
    case Mode
mode of
        Left PreStartupMode
preStartupMode ->
            do case PreStartupMode
preStartupMode of
                   PreStartupMode
ShowSupportedExtensions   -> Maybe String -> IO ()
showSupportedExtensions (String -> Maybe String
forall a. a -> Maybe a
Just String
libDir)
                   PreStartupMode
ShowVersion               -> IO ()
showVersion
                   PreStartupMode
ShowNumVersion            -> FatalMessager
putStrLn String
cProjectVersion
                   ShowOptions Bool
isInteractive -> Bool -> IORef ClashOpts -> IO ()
showOptions Bool
isInteractive IORef ClashOpts
r
        Right PostStartupMode
postStartupMode ->
            -- start our GHC session
            Maybe String -> Ghc () -> IO ()
forall a. Maybe String -> Ghc a -> IO a
GHC.runGhc (String -> Maybe String
forall a. a -> Maybe a
Just String
libDir) (Ghc () -> IO ()) -> Ghc () -> IO ()
forall a b. (a -> b) -> a -> b
$ do

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

                ghcTyLitNormPlugin :: ModuleName
ghcTyLitNormPlugin = String -> ModuleName
GHC.mkModuleName String
"GHC.TypeLits.Normalise"
                ghcTyLitExtrPlugin :: ModuleName
ghcTyLitExtrPlugin = String -> ModuleName
GHC.mkModuleName String
"GHC.TypeLits.Extra.Solver"
                ghcTyLitKNPlugin :: ModuleName
ghcTyLitKNPlugin   = String -> ModuleName
GHC.mkModuleName String
"GHC.TypeLits.KnownNat.Solver"
                dflagsExtra1 :: DynFlags
dflagsExtra1 = DynFlags
dflagsExtra
                                  { pluginModNames :: [ModuleName]
DynFlags.pluginModNames = [ModuleName] -> [ModuleName]
forall a. Eq a => [a] -> [a]
nub ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$
                                      ModuleName
ghcTyLitNormPlugin ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
: ModuleName
ghcTyLitExtrPlugin ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
:
                                      ModuleName
ghcTyLitKNPlugin ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
:
                                      DynFlags -> [ModuleName]
DynFlags.pluginModNames DynFlags
dflagsExtra
                                  }

            case PostStartupMode
postStartupMode of
                Left PreLoadMode
preLoadMode ->
                    IO () -> Ghc ()
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
-> DynFlags
-> [Located String]
-> [Warn]
-> Ghc ()
-> IORef ClashOpts
-> Ghc ()
main' PostLoadMode
postLoadMode DynFlags
dflagsExtra1 [Located String]
argv3 [Warn]
flagWarnings Ghc ()
startAction IORef ClashOpts
r

main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn]
      -> Ghc ()
      -> IORef ClashOpts
      -> Ghc ()
main' :: PostLoadMode
-> DynFlags
-> [Located String]
-> [Warn]
-> Ghc ()
-> IORef ClashOpts
-> Ghc ()
main' PostLoadMode
postLoadMode DynFlags
dflags0 [Located String]
args [Warn]
flagWarnings Ghc ()
startAction IORef ClashOpts
clashOpts = do
  -- set the default GhcMode, HscTarget and GhcLink.  The HscTarget
  -- can be further adjusted on a module by module basis, using only
  -- the -fvia-C and -fasm flags.  If the default HscTarget is not
  -- HscC or HscAsm, -fvia-C and -fasm have no effect.
  let dflt_target :: HscTarget
dflt_target = DynFlags -> HscTarget
hscTarget DynFlags
dflags0
      (GhcMode
mode, HscTarget
lang, GhcLink
link)
         = case PostLoadMode
postLoadMode of
               PostLoadMode
DoInteractive   -> (GhcMode
CompManager, HscTarget
HscInterpreted, GhcLink
LinkInMemory)
               DoEval [String]
_        -> (GhcMode
CompManager, HscTarget
HscInterpreted, GhcLink
LinkInMemory)
               PostLoadMode
DoMake          -> (GhcMode
CompManager, HscTarget
dflt_target,    GhcLink
LinkBinary)
               PostLoadMode
DoBackpack      -> (GhcMode
CompManager, HscTarget
dflt_target,    GhcLink
LinkBinary)
               PostLoadMode
DoMkDependHS    -> (GhcMode
MkDepend,    HscTarget
dflt_target,    GhcLink
LinkBinary)
               PostLoadMode
DoAbiHash       -> (GhcMode
OneShot,     HscTarget
dflt_target,    GhcLink
LinkBinary)
               PostLoadMode
DoVHDL          -> (GhcMode
CompManager, HscTarget
HscNothing,     GhcLink
NoLink)
               PostLoadMode
DoVerilog       -> (GhcMode
CompManager, HscTarget
HscNothing,     GhcLink
NoLink)
               PostLoadMode
DoSystemVerilog -> (GhcMode
CompManager, HscTarget
HscNothing,     GhcLink
NoLink)
               PostLoadMode
_               -> (GhcMode
OneShot,     HscTarget
dflt_target,    GhcLink
LinkBinary)

  let dflags1 :: DynFlags
dflags1 = DynFlags
dflags0{ ghcMode :: GhcMode
ghcMode   = GhcMode
mode,
                         hscTarget :: HscTarget
hscTarget = HscTarget
lang,
                         ghcLink :: GhcLink
ghcLink   = GhcLink
link,
                         verbosity :: Int
verbosity = case PostLoadMode
postLoadMode of
                                         DoEval [String]
_ -> Int
0
                                         PostLoadMode
_other   -> Int
1
                        }

      -- turn on -fimplicit-import-qualified for GHCi now, so that it
      -- can be overriden 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
               | 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

        -- The rest of the arguments are "dynamic"
        -- Leftover ones are presumably files
  (DynFlags
dflags3, [Located String]
fileish_args, [Warn]
dynamicFlagWarnings) <-
      DynFlags
-> [Located String] -> Ghc (DynFlags, [Located String], [Warn])
forall (m :: Type -> Type).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
GHC.parseDynamicFlags DynFlags
dflags2 [Located String]
args

  -- Propagate -Werror to Clash
  IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ())
-> ((ClashOpts -> ClashOpts) -> IO ())
-> (ClashOpts -> ClashOpts)
-> Ghc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef ClashOpts -> (ClashOpts -> ClashOpts) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef ClashOpts
clashOpts ((ClashOpts -> ClashOpts) -> Ghc ())
-> (ClashOpts -> ClashOpts) -> Ghc ()
forall a b. (a -> b) -> a -> b
$ \ClashOpts
opts ->
    ClashOpts
opts { opt_werror :: Bool
opt_werror = GeneralFlag -> EnumSet GeneralFlag -> Bool
forall a. Enum a => a -> EnumSet a -> Bool
EnumSet.member GeneralFlag
Opt_WarnIsError (DynFlags -> EnumSet GeneralFlag
generalFlags DynFlags
dflags3) }

  let dflags4 :: DynFlags
dflags4 = case HscTarget
lang of
                HscTarget
HscInterpreted | Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
dflags3) ->
                    let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags3
                        dflags3a :: DynFlags
dflags3a = DynFlags -> DynFlags
updateWays (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags
dflags3 { ways :: [Way]
ways = [Way]
interpWays }
                        dflags3b :: DynFlags
dflags3b = (DynFlags -> GeneralFlag -> DynFlags)
-> DynFlags -> [GeneralFlag] -> DynFlags
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]) -> [Way] -> [GeneralFlag]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (Platform -> Way -> [GeneralFlag]
wayGeneralFlags Platform
platform)
                                             [Way]
interpWays
                        dflags3c :: DynFlags
dflags3c = (DynFlags -> GeneralFlag -> DynFlags)
-> DynFlags -> [GeneralFlag] -> DynFlags
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]) -> [Way] -> [GeneralFlag]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (Platform -> Way -> [GeneralFlag]
wayUnsetGeneralFlags Platform
platform)
                                             [Way]
interpWays
                    in DynFlags
dflags3c
                HscTarget
_ ->
                    DynFlags
dflags3

  DynFlags -> Ghc () -> Ghc ()
forall (m :: Type -> Type) a.
ExceptionMonad m =>
DynFlags -> m a -> m a
GHC.prettyPrintGhcErrors DynFlags
dflags4 (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do

  let flagWarnings' :: [Warn]
flagWarnings' = [Warn]
flagWarnings [Warn] -> [Warn] -> [Warn]
forall a. [a] -> [a] -> [a]
++ [Warn]
dynamicFlagWarnings

  (SourceError -> Ghc ()) -> Ghc () -> Ghc ()
forall (m :: Type -> Type) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
handleSourceError (\SourceError
e -> do
       SourceError -> Ghc ()
forall (m :: Type -> Type). GhcMonad m => SourceError -> m ()
GHC.printException SourceError
e
       IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)) (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
         IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Warn] -> IO ()
handleFlagWarnings DynFlags
dflags4 [Warn]
flagWarnings'

  IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ PostLoadMode -> DynFlags -> IO ()
showBanner PostLoadMode
postLoadMode DynFlags
dflags4

  let
     -- To simplify the handling of filepaths, we normalise all filepaths right
     -- away. Note the asymmetry of FilePath.normalise:
     --    Linux:   p/q -> p/q; p\q -> p\q
     --    Windows: p/q -> p\q; p\q -> p\q
     -- #12674: Filenames starting with a hypen get normalised from ./-foo.hs
     -- to -foo.hs. We have to re-prepend the current directory.
    normalise_hyp :: String -> String
normalise_hyp String
fp
        | Bool
strt_dot_sl Bool -> Bool -> Bool
&& String
"-" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
nfp = String
cur_dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nfp
        | Bool
otherwise                           = String
nfp
        where
#if defined(mingw32_HOST_OS)
          strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp
#else
          strt_dot_sl :: Bool
strt_dot_sl = String
"./" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
fp
#endif
          cur_dir :: String
cur_dir = Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: [Char
pathSeparator]
          nfp :: String
nfp = String -> String
normalise String
fp
    normal_fileish_paths :: [String]
normal_fileish_paths = (Located String -> String) -> [Located String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
normalise_hyp (String -> String)
-> (Located String -> String) -> Located String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located String -> String
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [Located String]
fileish_args
    ([(String, Maybe Phase)]
srcs, [String]
objs)         = [String]
-> [(String, Maybe Phase)]
-> [String]
-> ([(String, Maybe Phase)], [String])
partition_args [String]
normal_fileish_paths [] []

    dflags5 :: DynFlags
dflags5 = DynFlags
dflags4 { ldInputs :: [Option]
ldInputs = (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Option
FileOption String
"") [String]
objs
                                   [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ DynFlags -> [Option]
ldInputs DynFlags
dflags4 }

  -- we've finished manipulating the DynFlags, update the session
  [InstalledUnitId]
_ <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: Type -> Type).
GhcMonad m =>
DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
dflags5
  DynFlags
dflags6 <- Ghc DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  HscEnv
hsc_env <- Ghc HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession

        ---------------- Display configuration -----------
  case DynFlags -> Int
verbosity DynFlags
dflags6 of
    Int
v | Int
v Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4 -> IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO ()
dumpPackagesSimple DynFlags
dflags6
      | Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
5 -> IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO ()
dumpPackages DynFlags
dflags6
      | Bool
otherwise -> () -> Ghc ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

  IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> IO ()
initUniqSupply (DynFlags -> Int
initialUnique DynFlags
dflags6) (DynFlags -> Int
uniqueIncrement DynFlags
dflags6)
        ---------------- Final sanity checking -----------
  IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ PostLoadMode
-> DynFlags -> [(String, Maybe Phase)] -> [String] -> IO ()
checkOptions PostLoadMode
postLoadMode DynFlags
dflags6 [(String, Maybe Phase)]
srcs [String]
objs

  ---------------- Do the business -----------
  (SourceError -> Ghc ()) -> Ghc () -> Ghc ()
forall (m :: Type -> Type) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
handleSourceError (\SourceError
e -> do
       SourceError -> Ghc ()
forall (m :: Type -> Type). GhcMonad m => SourceError -> m ()
GHC.printException SourceError
e
       IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)) (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
    ClashOpts
clashOpts' <- IO ClashOpts -> Ghc ClashOpts
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IORef ClashOpts -> IO ClashOpts
forall a. IORef a -> IO a
readIORef IORef ClashOpts
clashOpts)
    let clash :: (Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> m a)
-> m a
clash Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> m a
fun = m a -> (SomeException -> m a) -> m a
forall (m :: Type -> Type) e a.
(ExceptionMonad m, Exception e) =>
m a -> (e -> m a) -> m a
gcatch (Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> m a
fun Ghc ()
startAction IORef ClashOpts
clashOpts [(String, Maybe Phase)]
srcs) (DynFlags -> ClashOpts -> SomeException -> m a
forall (m :: Type -> Type) a.
GhcMonad m =>
DynFlags -> ClashOpts -> SomeException -> m a
handleClashException DynFlags
dflags6 ClashOpts
clashOpts')
    case PostLoadMode
postLoadMode of
       ShowInterface String
f        -> IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> FatalMessager
doShowIface DynFlags
dflags6 String
f
       PostLoadMode
DoMake                 -> [(String, Maybe Phase)] -> Ghc ()
doMake [(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 Phase
p           -> IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> Phase -> [(String, Maybe Phase)] -> IO ()
oneShot HscEnv
hsc_env Phase
p [(String, Maybe Phase)]
srcs)
       PostLoadMode
DoInteractive          -> IORef ClashOpts
-> HscEnv
-> DynFlags
-> [(String, Maybe Phase)]
-> Maybe [String]
-> Ghc ()
ghciUI IORef ClashOpts
clashOpts HscEnv
hsc_env DynFlags
dflags6 [(String, Maybe Phase)]
srcs Maybe [String]
forall a. Maybe a
Nothing
       DoEval [String]
exprs           -> IORef ClashOpts
-> HscEnv
-> DynFlags
-> [(String, Maybe Phase)]
-> Maybe [String]
-> Ghc ()
ghciUI IORef ClashOpts
clashOpts HscEnv
hsc_env DynFlags
dflags6 [(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
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 (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO ()
showPackages DynFlags
dflags6
       DoFrontend ModuleName
f           -> ModuleName -> [(String, Maybe Phase)] -> Ghc ()
doFrontend ModuleName
f [(String, Maybe Phase)]
srcs
       PostLoadMode
DoBackpack             -> [String] -> Ghc ()
doBackpack (((String, Maybe Phase) -> String)
-> [(String, Maybe Phase)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Maybe Phase) -> String
forall a b. (a, b) -> a
fst [(String, Maybe Phase)]
srcs)
       PostLoadMode
DoVHDL                 -> (Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ())
-> Ghc ()
forall (m :: Type -> Type) a.
GhcMonad m =>
(Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> m a)
-> m a
clash Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeVHDL
       PostLoadMode
DoVerilog              -> (Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ())
-> Ghc ()
forall (m :: Type -> Type) a.
GhcMonad m =>
(Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> m a)
-> m a
clash Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeVerilog
       PostLoadMode
DoSystemVerilog        -> (Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ())
-> Ghc ()
forall (m :: Type -> Type) a.
GhcMonad m =>
(Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> m a)
-> m a
clash Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeSystemVerilog

  IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO ()
dumpFinalStats DynFlags
dflags6

ghciUI :: IORef ClashOpts -> HscEnv -> DynFlags -> [(FilePath, Maybe Phase)] -> Maybe [String]
       -> Ghc ()
#if !defined(HAVE_INTERNAL_INTERPRETER)
ghciUI _ _ _ _ _ =
  throwGhcException (CmdLineError "not built for interactive use")
#else
ghciUI :: IORef ClashOpts
-> HscEnv
-> DynFlags
-> [(String, Maybe Phase)]
-> Maybe [String]
-> Ghc ()
ghciUI IORef ClashOpts
clashOpts HscEnv
hsc_env DynFlags
dflags0 [(String, Maybe Phase)]
srcs Maybe [String]
maybe_expr = do
  DynFlags
dflags1 <- IO DynFlags -> Ghc DynFlags
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> DynFlags -> IO DynFlags
initializePlugins HscEnv
hsc_env DynFlags
dflags0)
  [InstalledUnitId]
_ <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: Type -> Type).
GhcMonad m =>
DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
dflags1
  GhciSettings -> [(String, Maybe Phase)] -> Maybe [String] -> Ghc ()
interactiveUI (IORef ClashOpts -> GhciSettings
defaultGhciSettings IORef ClashOpts
clashOpts) [(String, Maybe Phase)]
srcs Maybe [String]
maybe_expr
#endif

-- -----------------------------------------------------------------------------
-- Splitting arguments into source files and object files.  This is where we
-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
-- file indicating the phase specified by the -x option in force, if any.

partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
               -> ([(String, Maybe Phase)], [String])
partition_args :: [String]
-> [(String, Maybe Phase)]
-> [String]
-> ([(String, Maybe Phase)], [String])
partition_args [] [(String, Maybe Phase)]
srcs [String]
objs = ([(String, Maybe Phase)] -> [(String, Maybe Phase)]
forall a. [a] -> [a]
reverse [(String, Maybe Phase)]
srcs, [String] -> [String]
forall a. [a] -> [a]
reverse [String]
objs)
partition_args (String
"-x":String
suff:[String]
args) [(String, Maybe Phase)]
srcs [String]
objs
  | String
"none" <- String
suff      = [String]
-> [(String, Maybe Phase)]
-> [String]
-> ([(String, Maybe Phase)], [String])
partition_args [String]
args [(String, Maybe Phase)]
srcs [String]
objs
  | Phase
StopLn <- Phase
phase     = [String]
-> [(String, Maybe Phase)]
-> [String]
-> ([(String, Maybe Phase)], [String])
partition_args [String]
args [(String, Maybe Phase)]
srcs ([String]
slurp [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
objs)
  | Bool
otherwise           = [String]
-> [(String, Maybe Phase)]
-> [String]
-> ([(String, Maybe Phase)], [String])
partition_args [String]
rest ([(String, Maybe Phase)]
these_srcs [(String, Maybe Phase)]
-> [(String, Maybe Phase)] -> [(String, Maybe Phase)]
forall a. [a] -> [a] -> [a]
++ [(String, Maybe Phase)]
srcs) [String]
objs
        where phase :: Phase
phase = String -> Phase
startPhase String
suff
              ([String]
slurp,[String]
rest) = (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"-x") [String]
args
              these_srcs :: [(String, Maybe Phase)]
these_srcs = [String] -> [Maybe Phase] -> [(String, Maybe Phase)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
slurp (Maybe Phase -> [Maybe Phase]
forall a. a -> [a]
repeat (Phase -> Maybe Phase
forall a. a -> Maybe a
Just Phase
phase))
partition_args (String
arg:[String]
args) [(String, Maybe Phase)]
srcs [String]
objs
  | String -> Bool
looks_like_an_input String
arg = [String]
-> [(String, Maybe Phase)]
-> [String]
-> ([(String, Maybe Phase)], [String])
partition_args [String]
args ((String
arg,Maybe Phase
forall a. Maybe a
Nothing)(String, Maybe Phase)
-> [(String, Maybe Phase)] -> [(String, Maybe Phase)]
forall a. a -> [a] -> [a]
:[(String, Maybe Phase)]
srcs) [String]
objs
  | Bool
otherwise               = [String]
-> [(String, Maybe Phase)]
-> [String]
-> ([(String, Maybe Phase)], [String])
partition_args [String]
args [(String, Maybe Phase)]
srcs (String
argString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
objs)

    {-
      We split out the object files (.o, .dll) and add them
      to ldInputs for use by the linker.

      The following things should be considered compilation manager inputs:

       - haskell source files (strings ending in .hs, .lhs or other
         haskellish extension),

       - module names (not forgetting hierarchical module names),

       - things beginning with '-' are flags that were not recognised by
         the flag parser, and we want them to generate errors later in
         checkOptions, so we class them as source files (#5921)

       - and finally we consider everything without an extension to be
         a comp manager input, as shorthand for a .hs or .lhs filename.

      Everything else is considered to be a linker object, and passed
      straight through to the linker.
    -}
looks_like_an_input :: String -> Bool
looks_like_an_input :: String -> Bool
looks_like_an_input String
m =  String -> Bool
isSourceFilename String
m
                      Bool -> Bool -> Bool
|| String -> Bool
looksLikeModuleName String
m
                      Bool -> Bool -> Bool
|| String
"-" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
m
                      Bool -> Bool -> Bool
|| Bool -> Bool
not (String -> Bool
hasExtension String
m)

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

-- | Ensure sanity of options.
--
-- Throws 'UsageError' or 'CmdLineError' if not.
checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()
     -- Final sanity checking before kicking off a compilation (pipeline).
checkOptions :: PostLoadMode
-> DynFlags -> [(String, Maybe Phase)] -> [String] -> IO ()
checkOptions PostLoadMode
mode DynFlags
dflags [(String, Maybe Phase)]
srcs [String]
objs = 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 a. [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 ([Way] -> Bool
forall a. [a] -> Bool
notNull ((Way -> Bool) -> [Way] -> [Way]
forall a. (a -> Bool) -> [a] -> [a]
filter Way -> Bool
wayRTSOnly (DynFlags -> [Way]
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 (((Way -> Bool) -> [Way] -> [Way]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Way -> Bool) -> Way -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Way -> Bool
wayRTSOnly) (DynFlags -> [Way]
ways DynFlags
dflags) [Way] -> [Way] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Way]
interpWays)
         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

        -- -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 (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 (t :: Type -> Type) a. Foldable t => t a -> Bool
null [(String, Maybe Phase)]
srcs Bool -> Bool -> Bool
&& ([String] -> 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
        then GhcException -> IO ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
UsageError String
"no input files")
        else do

   case PostLoadMode
mode of
      StopBefore Phase
HCc | DynFlags -> HscTarget
hscTarget DynFlags
dflags HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
/= HscTarget
HscC
        -> 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 (As Bool
False) | 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 (m :: Type -> Type) a. Monad m => a -> m a
return ()

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

-- Compiler output options

-- Called to verify that the output files point somewhere valid.
--
-- The assumption is that the directory portion of these output
-- options will have to exist by the time 'verifyOutputFiles'
-- is invoked.
--
-- We create the directories for -odir, -hidir, -outputdir etc. ourselves if
-- they don't exist, so don't check for those here (#2278).
verifyOutputFiles :: DynFlags -> IO ()
verifyOutputFiles :: DynFlags -> IO ()
verifyOutputFiles DynFlags
dflags = do
  let ofile :: Maybe String
ofile = DynFlags -> Maybe String
outputFile DynFlags
dflags
  Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
ofile) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
     let fn :: String
fn = Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
ofile
     Bool
flg <- String -> IO Bool
doesDirNameExist String
fn
     Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
flg) (String -> FatalMessager
forall a a a. (Show a, Show a) => a -> a -> a
nonExistentDir String
"-o" String
fn)
  let ohi :: Maybe String
ohi = DynFlags -> Maybe String
outputHi DynFlags
dflags
  Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
ohi) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
     let hi :: String
hi = Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
ohi
     Bool
flg <- String -> IO Bool
doesDirNameExist String
hi
     Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
flg) (String -> FatalMessager
forall a a a. (Show a, Show a) => a -> a -> a
nonExistentDir String
"-ohi" String
hi)
 where
   nonExistentDir :: a -> a -> a
nonExistentDir a
flg a
dir =
     GhcException -> a
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError (String
"error: directory portion of " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                             a -> String
forall a. Show a => a -> String
show a
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not exist (used with " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                             a -> String
forall a. Show a => a -> String
show a
flg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" option.)"))

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

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

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

showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode
showVersionMode :: Mode
showVersionMode             = PreStartupMode -> Mode
mkPreStartupMode PreStartupMode
ShowVersion
showNumVersionMode :: Mode
showNumVersionMode          = PreStartupMode -> Mode
mkPreStartupMode PreStartupMode
ShowNumVersion
showSupportedExtensionsMode :: Mode
showSupportedExtensionsMode = PreStartupMode -> Mode
mkPreStartupMode PreStartupMode
ShowSupportedExtensions
showOptionsMode :: Mode
showOptionsMode             = PreStartupMode -> Mode
mkPreStartupMode (Bool -> PreStartupMode
ShowOptions Bool
False)

mkPreStartupMode :: PreStartupMode -> Mode
mkPreStartupMode :: PreStartupMode -> Mode
mkPreStartupMode = PreStartupMode -> Mode
forall a b. a -> Either a b
Left

isShowVersionMode :: Mode -> Bool
isShowVersionMode :: Mode -> Bool
isShowVersionMode (Left PreStartupMode
ShowVersion) = Bool
True
isShowVersionMode Mode
_ = Bool
False

isShowNumVersionMode :: Mode -> Bool
isShowNumVersionMode :: Mode -> Bool
isShowNumVersionMode (Left PreStartupMode
ShowNumVersion) = Bool
True
isShowNumVersionMode Mode
_ = Bool
False

data PreLoadMode
  = ShowGhcUsage                           -- ghc -?
  | ShowGhciUsage                          -- ghci -?
  | ShowInfo                               -- ghc --info
  | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo

showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode
showGhcUsageMode :: Mode
showGhcUsageMode = PreLoadMode -> Mode
mkPreLoadMode PreLoadMode
ShowGhcUsage
showGhciUsageMode :: Mode
showGhciUsageMode = PreLoadMode -> Mode
mkPreLoadMode PreLoadMode
ShowGhciUsage
showInfoMode :: Mode
showInfoMode = PreLoadMode -> Mode
mkPreLoadMode PreLoadMode
ShowInfo

printSetting :: String -> Mode
printSetting :: String -> Mode
printSetting String
k = PreLoadMode -> Mode
mkPreLoadMode ((DynFlags -> String) -> PreLoadMode
PrintWithDynFlags DynFlags -> String
f)
    where f :: DynFlags -> String
f DynFlags
dflags = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String -> String
forall a. 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 Phase        -- 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"]
  | 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,
  doAbiHashMode, showPackagesMode, 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
doAbiHashMode :: Mode
doAbiHashMode = PostLoadMode -> Mode
mkPostLoadMode PostLoadMode
DoAbiHash
showPackagesMode :: Mode
showPackagesMode = 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 :: Phase -> Mode
stopBeforeMode :: Phase -> Mode
stopBeforeMode Phase
phase = PostLoadMode -> Mode
mkPostLoadMode (Phase -> PostLoadMode
StopBefore Phase
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 Phase
StopLn))) = 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 Phase
_)  = 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 Phase
StopLn) = Bool
True
isLinkMode PostLoadMode
DoMake              = Bool
True
isLinkMode PostLoadMode
DoInteractive       = Bool
True
isLinkMode (DoEval [String]
_)          = Bool
True
isLinkMode PostLoadMode
_                   = Bool
False

isCompManagerMode :: PostLoadMode -> Bool
isCompManagerMode :: PostLoadMode -> Bool
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,
                      [Located String],
                      [Warn])
parseModeFlags :: [Located String] -> IO (Mode, [Located String], [Warn])
parseModeFlags [Located String]
args = do
  let (([Located String]
leftover, [Err]
errs1, [Warn]
warns), (Maybe (Mode, String)
mModeFlag, [String]
errs2, [Located String]
flags')) =
          CmdLineP
  (Maybe (Mode, String), [String], [Located String])
  ([Located String], [Err], [Warn])
-> (Maybe (Mode, String), [String], [Located String])
-> (([Located String], [Err], [Warn]),
    (Maybe (Mode, String), [String], [Located String]))
forall s a. CmdLineP s a -> s -> (a, s)
runCmdLine ([Flag ModeM]
-> [Located String]
-> CmdLineP
     (Maybe (Mode, String), [String], [Located String])
     ([Located String], [Err], [Warn])
forall (m :: Type -> Type).
Monad m =>
[Flag m] -> [Located String] -> m ([Located String], [Err], [Warn])
processArgs [Flag ModeM]
mode_flags [Located String]
args)
                     (Maybe (Mode, String)
forall a. Maybe a
Nothing, [], [])
      mode :: Mode
mode = case Maybe (Mode, String)
mModeFlag of
             Maybe (Mode, String)
Nothing     -> Mode
doMakeMode
             Just (Mode
m, String
_) -> Mode
m

  -- See Note [Handling errors when parsing commandline flags]
  Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless ([Err] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Err]
errs1 Bool -> Bool -> Bool
&& [String] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [String]
errs2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ GhcException -> IO ()
forall a. GhcException -> a
throwGhcException (GhcException -> IO ()) -> GhcException -> IO ()
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> GhcException
errorsToGhcException ([(String, String)] -> GhcException)
-> [(String, String)] -> GhcException
forall a b. (a -> b) -> a -> b
$
      (String -> (String, String)) -> [String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"on the commandline", )) ([String] -> [(String, String)]) -> [String] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ (Err -> String) -> [Err] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Located String -> String
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located String -> String)
-> (Err -> Located String) -> Err -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> Located String
errMsg) [Err]
errs1 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
errs2

  (Mode, [Located String], [Warn])
-> IO (Mode, [Located String], [Warn])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Mode
mode, [Located String]
flags' [Located String] -> [Located String] -> [Located String]
forall a. [a] -> [a] -> [a]
++ [Located String]
leftover, [Warn]
warns)

type ModeM = CmdLineP (Maybe (Mode, String), [String], [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
showPackagesMode))
  ] [Flag ModeM] -> [Flag ModeM] -> [Flag ModeM]
forall a. [a] -> [a] -> [a]
++
  [ String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
k'                      ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode (String -> Mode
printSetting String
k)))
  | String
k <- [String
"Project version",
          String
"Project Git commit id",
          String
"Booter version",
          String
"Stage",
          String
"Build platform",
          String
"Host platform",
          String
"Target platform",
          String
"Have interpreter",
          String
"Object splitting supported",
          String
"Have native code generator",
          String
"Support SMP",
          String
"Unregisterised",
          String
"Tables next to code",
          String
"RTS ways",
          String
"Leading underscore",
          String
"Debug on",
          String
"LibDir",
          String
"Global Package DB",
          String
"C compiler flags",
          String
"C compiler link flags",
          String
"ld flags"],
    let k' :: String
k' = String
"-print-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (Char -> Char
replaceSpace (Char -> Char) -> (Char -> Char) -> Char -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
toLower) String
k
        replaceSpace :: Char -> Char
replaceSpace Char
' ' = Char
'-'
        replaceSpace Char
c   = Char
c
  ] [Flag ModeM] -> [Flag ModeM] -> [Flag ModeM]
forall a. [a] -> [a] -> [a]
++
      ------- interfaces ----------------------------------------------------
  [ String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"-show-iface"  ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
HasArg (\String
f -> Mode -> String -> EwM ModeM ()
setMode (String -> Mode
showInterfaceMode String
f)
                                               String
"--show-iface"))

      ------- primary modes ------------------------------------------------
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: Type -> Type). String -> OptKind m -> Flag m
defFlag String
"c"            ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: Type -> Type). (String -> EwM m ()) -> OptKind m
PassFlag (\String
f -> do Mode -> String -> EwM ModeM ()
setMode (Phase -> Mode
stopBeforeMode Phase
StopLn) 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 (Phase -> Mode
stopBeforeMode Phase
anyHsc)))
  , 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 (Phase -> Mode
stopBeforeMode Phase
HCc)))
  , 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 (Phase -> Mode
stopBeforeMode (Bool -> Phase
As Bool
False))))
  , 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
"-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))
  ]

setMode :: Mode -> String -> EwM ModeM ()
setMode :: Mode -> String -> EwM ModeM ()
setMode Mode
newMode String
newFlag = CmdLineP (Maybe (Mode, String), [String], [Located String]) ()
-> EwM ModeM ()
forall (m :: Type -> Type) a. Monad m => m a -> EwM m a
liftEwM (CmdLineP (Maybe (Mode, String), [String], [Located String]) ()
 -> EwM ModeM ())
-> CmdLineP (Maybe (Mode, String), [String], [Located String]) ()
-> EwM ModeM ()
forall a b. (a -> b) -> a -> b
$ do
    (Maybe (Mode, String)
mModeFlag, [String]
errs, [Located String]
flags') <- CmdLineP
  (Maybe (Mode, String), [String], [Located String])
  (Maybe (Mode, String), [String], [Located String])
forall s. CmdLineP s s
getCmdLineState
    let ((Mode, String)
modeFlag', [String]
errs') =
            case Maybe (Mode, String)
mModeFlag of
            Maybe (Mode, String)
Nothing -> ((Mode
newMode, String
newFlag), [String]
errs)
            Just (oldMode, oldFlag) ->
                case (Mode
oldMode, Mode
newMode) of
                    -- -c/--make are allowed together, and mean --make -no-link
                    (Mode, Mode)
_ |  Mode -> Bool
isStopLnMode Mode
oldMode Bool -> Bool -> Bool
&& Mode -> Bool
isDoMakeMode Mode
newMode
                      Bool -> Bool -> Bool
|| Mode -> Bool
isStopLnMode Mode
newMode Bool -> Bool -> Bool
&& Mode -> Bool
isDoMakeMode Mode
oldMode ->
                      ((Mode
doMakeMode, String
"--make"), [])

                    -- If we have both --help and --interactive then we
                    -- want showGhciUsage
                    (Mode, Mode)
_ | Mode -> Bool
isShowGhcUsageMode Mode
oldMode Bool -> Bool -> Bool
&&
                        Mode -> Bool
isDoInteractiveMode Mode
newMode ->
                            ((Mode
showGhciUsageMode, String
oldFlag), [])
                      | Mode -> Bool
isShowGhcUsageMode Mode
newMode Bool -> Bool -> Bool
&&
                        Mode -> Bool
isDoInteractiveMode Mode
oldMode ->
                            ((Mode
showGhciUsageMode, String
newFlag), [])

                    -- If we have both -e and --interactive then -e always wins
                    (Mode, Mode)
_ | Mode -> Bool
isDoEvalMode Mode
oldMode Bool -> Bool -> Bool
&&
                        Mode -> Bool
isDoInteractiveMode Mode
newMode ->
                            ((Mode
oldMode, String
oldFlag), [])
                      | Mode -> Bool
isDoEvalMode Mode
newMode Bool -> Bool -> Bool
&&
                        Mode -> Bool
isDoInteractiveMode Mode
oldMode ->
                            ((Mode
newMode, String
newFlag), [])

                    -- Otherwise, --help/--version/--numeric-version always win
                      | Mode -> Bool
isDominantFlag Mode
oldMode -> ((Mode
oldMode, String
oldFlag), [])
                      | Mode -> Bool
isDominantFlag Mode
newMode -> ((Mode
newMode, String
newFlag), [])
                    -- We need to accumulate eval flags like "-e foo -e bar"
                    (Right (Right (DoEval [String]
esOld)),
                     Right (Right (DoEval [String
eNew]))) ->
                        ((PostStartupMode -> Mode
forall a b. b -> Either a b
Right (PostLoadMode -> PostStartupMode
forall a b. b -> Either a b
Right ([String] -> PostLoadMode
DoEval (String
eNew String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
esOld))), String
oldFlag),
                         [String]
errs)
                    -- Saying e.g. --interactive --interactive is OK
                    (Mode, Mode)
_ | String
oldFlag String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
newFlag -> ((Mode
oldMode, String
oldFlag), [String]
errs)

                    -- --interactive and --show-options are used together
                    (Right (Right PostLoadMode
DoInteractive), Left (ShowOptions Bool
_)) ->
                      ((PreStartupMode -> Mode
forall a b. a -> Either a b
Left (Bool -> PreStartupMode
ShowOptions Bool
True),
                        String
"--interactive --show-options"), [String]
errs)
                    (Left (ShowOptions Bool
_), (Right (Right PostLoadMode
DoInteractive))) ->
                      ((PreStartupMode -> Mode
forall a b. a -> Either a b
Left (Bool -> PreStartupMode
ShowOptions Bool
True),
                        String
"--show-options --interactive"), [String]
errs)
                    -- Otherwise, complain
                    (Mode, Mode)
_ -> let err :: String
err = String -> String -> String
flagMismatchErr String
oldFlag String
newFlag
                         in ((Mode
oldMode, String
oldFlag), String
err String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
errs)
    (Maybe (Mode, String), [String], [Located String])
-> CmdLineP (Maybe (Mode, String), [String], [Located String]) ()
forall s. s -> CmdLineP s ()
putCmdLineState ((Mode, String) -> Maybe (Mode, String)
forall a. a -> Maybe a
Just (Mode, String)
modeFlag', [String]
errs', [Located String]
flags')
  where isDominantFlag :: Mode -> Bool
isDominantFlag Mode
f = Mode -> Bool
isShowGhcUsageMode   Mode
f Bool -> Bool -> Bool
||
                           Mode -> Bool
isShowGhciUsageMode  Mode
f Bool -> Bool -> Bool
||
                           Mode -> Bool
isShowVersionMode    Mode
f Bool -> Bool -> Bool
||
                           Mode -> Bool
isShowNumVersionMode Mode
f

flagMismatchErr :: String -> String -> String
flagMismatchErr :: String -> String -> String
flagMismatchErr String
oldFlag String
newFlag
    = String
"cannot use `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
oldFlag String -> String -> String
forall a. [a] -> [a] -> [a]
++  String
"' with `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
newFlag String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"

addFlag :: String -> String -> EwM ModeM ()
addFlag :: String -> String -> EwM ModeM ()
addFlag String
s String
flag = CmdLineP (Maybe (Mode, String), [String], [Located String]) ()
-> EwM ModeM ()
forall (m :: Type -> Type) a. Monad m => m a -> EwM m a
liftEwM (CmdLineP (Maybe (Mode, String), [String], [Located String]) ()
 -> EwM ModeM ())
-> CmdLineP (Maybe (Mode, String), [String], [Located String]) ()
-> EwM ModeM ()
forall a b. (a -> b) -> a -> b
$ do
  (Maybe (Mode, String)
m, [String]
e, [Located String]
flags') <- CmdLineP
  (Maybe (Mode, String), [String], [Located String])
  (Maybe (Mode, String), [String], [Located String])
forall s. CmdLineP s s
getCmdLineState
  (Maybe (Mode, String), [String], [Located String])
-> CmdLineP (Maybe (Mode, String), [String], [Located String]) ()
forall s. s -> CmdLineP s ()
putCmdLineState (Maybe (Mode, String)
m, [String]
e, String -> SrcSpanLess (Located String) -> Located String
forall e. HasSrcSpan e => String -> SrcSpanLess e -> e
mkGeneralLocated String
loc String
SrcSpanLess (Located String)
s Located String -> [Located String] -> [Located String]
forall a. a -> [a] -> [a]
: [Located String]
flags')
    where loc :: String
loc = String
"addFlag by " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
flag String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" on the commandline"

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

doMake :: [(String,Maybe Phase)] -> Ghc ()
doMake :: [(String, Maybe Phase)] -> Ghc ()
doMake [(String, Maybe Phase)]
srcs  = do
    let ([(String, Maybe Phase)]
hs_srcs, [(String, Maybe Phase)]
non_hs_srcs) = ((String, Maybe Phase) -> Bool)
-> [(String, Maybe Phase)]
-> ([(String, Maybe Phase)], [(String, Maybe Phase)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (String, Maybe Phase) -> Bool
isHaskellishTarget [(String, Maybe Phase)]
srcs

    HscEnv
hsc_env <- Ghc HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession

    -- if we have no haskell sources from which to do a dependency
    -- analysis, then just do one-shot compilation and/or linking.
    -- This means that "ghc Foo.o Bar.o -o baz" links the program as
    -- we expect.
    if ([(String, Maybe Phase)] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [(String, Maybe Phase)]
hs_srcs)
       then IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> Phase -> [(String, Maybe Phase)] -> IO ()
oneShot HscEnv
hsc_env Phase
StopLn [(String, Maybe Phase)]
srcs)
       else do

    [String]
o_files <- ((String, Maybe Phase) -> Ghc String)
-> [(String, Maybe Phase)] -> Ghc [String]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(String, Maybe Phase)
x -> IO String -> Ghc String
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
$ HscEnv -> Phase -> (String, Maybe Phase) -> IO String
compileFile HscEnv
hsc_env Phase
StopLn (String, Maybe Phase)
x)
                 [(String, Maybe Phase)]
non_hs_srcs
    DynFlags
dflags <- Ghc DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
    let dflags' :: DynFlags
dflags' = DynFlags
dflags { ldInputs :: [Option]
ldInputs = (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Option
FileOption String
"") [String]
o_files
                                      [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ DynFlags -> [Option]
ldInputs DynFlags
dflags }
    [InstalledUnitId]
_ <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: Type -> Type).
GhcMonad m =>
DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
dflags'

    [Target]
targets <- ((String, Maybe Phase) -> Ghc Target)
-> [(String, 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)
mapM ((String -> Maybe Phase -> Ghc Target)
-> (String, Maybe Phase) -> Ghc Target
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Maybe Phase -> Ghc Target
forall (m :: Type -> Type).
GhcMonad m =>
String -> Maybe Phase -> m Target
GHC.guessTarget) [(String, Maybe Phase)]
hs_srcs
    [Target] -> Ghc ()
forall (m :: Type -> Type). GhcMonad m => [Target] -> m ()
GHC.setTargets [Target]
targets
    SuccessFlag
ok_flag <- LoadHowMuch -> Ghc SuccessFlag
forall (m :: Type -> Type).
GhcMonad m =>
LoadHowMuch -> m SuccessFlag
GHC.load LoadHowMuch
LoadAllTargets

    Bool -> Ghc () -> Ghc ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (SuccessFlag -> Bool
failed SuccessFlag
ok_flag) (IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1))
    () -> Ghc ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()


-- ---------------------------------------------------------------------------
-- --show-iface mode

doShowIface :: DynFlags -> FilePath -> IO ()
doShowIface :: DynFlags -> FatalMessager
doShowIface DynFlags
dflags String
file = do
  HscEnv
hsc_env <- DynFlags -> IO HscEnv
newHscEnv DynFlags
dflags
  HscEnv -> FatalMessager
showIface HscEnv
hsc_env String
file

-- ---------------------------------------------------------------------------
-- 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 ErrUtils once that is disentangled from all the other GhcMonad stuff?
showSupportedExtensions :: Maybe String -> IO ()
showSupportedExtensions :: Maybe String -> IO ()
showSupportedExtensions Maybe String
m_top_dir = do
  Either SettingsError Settings
res <- ExceptT SettingsError IO Settings
-> IO (Either SettingsError Settings)
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT SettingsError IO Settings
 -> IO (Either SettingsError Settings))
-> ExceptT SettingsError IO Settings
-> IO (Either SettingsError Settings)
forall a b. (a -> b) -> a -> b
$ do
    String
top_dir <- IO (Maybe String) -> ExceptT SettingsError IO (Maybe String)
forall (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 (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 (f :: Type -> Type) a. Applicative f => a -> f a
pure String
dir
    String -> ExceptT SettingsError IO Settings
forall (m :: Type -> Type).
MonadIO m =>
String -> ExceptT SettingsError m Settings
initSettings String
top_dir
  PlatformMini
targetPlatformMini <- case Either SettingsError Settings
res of
    Right Settings
s -> PlatformMini -> IO PlatformMini
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (PlatformMini -> IO PlatformMini)
-> PlatformMini -> IO PlatformMini
forall a b. (a -> b) -> a -> b
$ Platform -> PlatformMini
platformMini (Platform -> PlatformMini) -> Platform -> PlatformMini
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)."
      PlatformMini -> IO PlatformMini
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure PlatformMini
cHostPlatformMini
    Left (SettingsError_BadData String
msg) -> do
      Handle -> FatalMessager
hPutStrLn Handle
stderr String
msg
      ExitCode -> IO PlatformMini
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO PlatformMini) -> ExitCode -> IO PlatformMini
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
  FatalMessager -> [String] -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FatalMessager
putStrLn ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ PlatformMini -> [String]
supportedLanguagesAndExtensions PlatformMini
targetPlatformMini

showVersion :: IO ()
showVersion :: IO ()
showVersion = FatalMessager
putStrLn FatalMessager -> FatalMessager
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [ String
"Clash, version "
                                , Version -> String
Data.Version.showVersion Version
Paths_clash_ghc.version
                                , String
" (using clash-lib, version: "
                                , Version -> String
Data.Version.showVersion Version
clashLibVersion
                                , String
")"
                                ]

showOptions :: Bool -> IORef ClashOpts -> IO ()
showOptions :: Bool -> IORef ClashOpts -> IO ()
showOptions Bool
isInteractive = FatalMessager
putStr FatalMessager
-> (IORef ClashOpts -> String) -> IORef ClashOpts -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String)
-> (IORef ClashOpts -> [String]) -> IORef ClashOpts -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef ClashOpts -> [String]
availableOptions
    where
      availableOptions :: IORef ClashOpts -> [String]
availableOptions IORef ClashOpts
opts = [[String]] -> [String]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat
        [ Bool -> [String]
flagsForCompletion Bool
isInteractive
        , (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char
'-'Char -> String -> String
forall a. a -> [a] -> [a]
:) ([Flag ModeM] -> [String]
forall (m :: Type -> Type). [Flag m] -> [String]
getFlagNames [Flag ModeM]
mode_flags)
        , (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char
'-'Char -> String -> String
forall a. a -> [a] -> [a]
:) ([Flag IO] -> [String]
forall (m :: Type -> Type). [Flag m] -> [String]
getFlagNames (IORef ClashOpts -> [Flag IO]
flagsClash IORef ClashOpts
opts))
        ]
      getFlagNames :: [Flag m] -> [String]
getFlagNames [Flag m]
opts         = (Flag m -> String) -> [Flag m] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Flag m -> String
forall (m :: Type -> Type). Flag m -> String
flagName [Flag m]
opts

showGhcUsage :: DynFlags -> IO ()
showGhcUsage :: DynFlags -> IO ()
showGhcUsage = Bool -> DynFlags -> IO ()
showUsage Bool
False

showGhciUsage :: DynFlags -> IO ()
showGhciUsage :: DynFlags -> IO ()
showGhciUsage = Bool -> DynFlags -> IO ()
showUsage Bool
True

showUsage :: Bool -> DynFlags -> IO ()
showUsage :: Bool -> DynFlags -> IO ()
showUsage Bool
ghci DynFlags
dflags = do
  let usage_path :: String
usage_path = if Bool
ghci then DynFlags -> String
ghciUsagePath DynFlags
dflags
                           else DynFlags -> String
ghcUsagePath DynFlags
dflags
  String
usage <- String -> IO String
readFile String
usage_path
  FatalMessager
dump String
usage
  where
     dump :: FatalMessager
dump String
""          = () -> IO ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
     dump (Char
'$':Char
'$':String
s) = FatalMessager
putStr String
progName IO () -> IO () -> IO ()
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> FatalMessager
dump String
s
     dump (Char
c:String
s)       = Char -> IO ()
putChar Char
c IO () -> IO () -> IO ()
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> FatalMessager
dump String
s

dumpFinalStats :: DynFlags -> IO ()
dumpFinalStats :: DynFlags -> IO ()
dumpFinalStats DynFlags
dflags =
  Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_D_faststring_stats DynFlags
dflags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO ()
dumpFastStringStats DynFlags
dflags

dumpFastStringStats :: DynFlags -> IO ()
dumpFastStringStats :: DynFlags -> IO ()
dumpFastStringStats DynFlags
dflags = do
  [[[FastString]]]
segments <- IO [[[FastString]]]
getFastStringTable
  Int
hasZ <- IO Int
getFastStringZEncCounter
  let buckets :: [[FastString]]
buckets = [[[FastString]]] -> [[FastString]]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[[FastString]]]
segments
      bucketsPerSegment :: [Int]
bucketsPerSegment = ([[FastString]] -> Int) -> [[[FastString]]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [[FastString]] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [[[FastString]]]
segments
      entriesPerBucket :: [Int]
entriesPerBucket = ([FastString] -> Int) -> [[FastString]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [FastString] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [[FastString]]
buckets
      entries :: Int
entries = [Int] -> Int
forall (t :: Type -> Type) a. (Foldable t, Num a) => t a -> a
sum [Int]
entriesPerBucket
      msg :: SDoc
msg = String -> SDoc
text String
"FastString stats:" SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
4 ([SDoc] -> SDoc
vcat
        [ String -> SDoc
text String
"segments:         " SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int ([[[FastString]]] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [[[FastString]]]
segments)
        , String -> SDoc
text String
"buckets:          " SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int ([Int] -> Int
forall (t :: Type -> Type) a. (Foldable t, Num a) => t a -> a
sum [Int]
bucketsPerSegment)
        , String -> SDoc
text String
"entries:          " SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
entries
        , String -> SDoc
text String
"largest segment:  " SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int ([Int] -> Int
forall (t :: Type -> Type) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
bucketsPerSegment)
        , String -> SDoc
text String
"smallest segment: " SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int ([Int] -> Int
forall (t :: Type -> Type) a. (Foldable t, Ord a) => t a -> a
minimum [Int]
bucketsPerSegment)
        , String -> SDoc
text String
"longest bucket:   " SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int ([Int] -> Int
forall (t :: Type -> Type) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
entriesPerBucket)
        , String -> SDoc
text String
"has z-encoding:   " SDoc -> SDoc -> SDoc
<+> (Int
hasZ Int -> Int -> SDoc
`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.
  DynFlags -> SDoc -> IO ()
putMsg DynFlags
dflags SDoc
msg
  where
   Int
x pcntOf :: Int -> Int -> SDoc
`pcntOf` Int
y = Int -> SDoc
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) SDoc -> SDoc -> SDoc
Outputable.<> Char -> SDoc
char Char
'%'

showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO ()
showPackages :: DynFlags -> IO ()
showPackages       DynFlags
dflags = FatalMessager
putStrLn (DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (DynFlags -> SDoc
pprPackages DynFlags
dflags))
dumpPackages :: DynFlags -> IO ()
dumpPackages       DynFlags
dflags = DynFlags -> SDoc -> IO ()
putMsg DynFlags
dflags (DynFlags -> SDoc
pprPackages DynFlags
dflags)
dumpPackagesSimple :: DynFlags -> IO ()
dumpPackagesSimple DynFlags
dflags = DynFlags -> SDoc -> IO ()
putMsg DynFlags
dflags (DynFlags -> SDoc
pprPackagesSimple DynFlags
dflags)

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

doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()
doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()
doFrontend ModuleName
modname [(String, Maybe Phase)]
srcs = do
    HscEnv
hsc_env <- Ghc HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
getSession
    FrontendPlugin
frontend_plugin <- IO FrontendPlugin -> Ghc FrontendPlugin
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO FrontendPlugin -> Ghc FrontendPlugin)
-> IO FrontendPlugin -> Ghc FrontendPlugin
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> IO FrontendPlugin
loadFrontendPlugin HscEnv
hsc_env ModuleName
modname
    FrontendPlugin -> FrontendPluginAction
frontend FrontendPlugin
frontend_plugin
      ([String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ DynFlags -> [String]
frontendPluginOpts (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) [(String, Maybe Phase)]
srcs

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

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

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

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

-- | Print ABI hash of input modules.
--
-- The resulting hash is the MD5 of the GHC version used (#5328,
-- see 'hiVersion') and of the existing ABI hash from each module (see
-- 'mi_mod_hash').
abiHash :: [String] -- ^ List of module names
        -> Ghc ()
abiHash :: [String] -> Ghc ()
abiHash [String]
strs = do
  HscEnv
hsc_env <- Ghc HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
getSession
  let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

  IO () -> Ghc ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do

  let find_it :: String -> IO Module
find_it String
str = do
         let modname :: ModuleName
modname = String -> ModuleName
mkModuleName String
str
         FindResult
r <- HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
modname Maybe FastString
forall a. Maybe a
Nothing
         case FindResult
r of
           Found ModLocation
_ Module
m -> Module -> IO Module
forall (m :: Type -> Type) a. Monad m => a -> m a
return Module
m
           FindResult
_error    -> GhcException -> IO Module
forall a. GhcException -> a
throwGhcException (GhcException -> IO Module) -> GhcException -> IO Module
forall a b. (a -> b) -> a -> b
$ String -> GhcException
CmdLineError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$
                          DynFlags -> ModuleName -> FindResult -> SDoc
cannotFindModule DynFlags
dflags ModuleName
modname FindResult
r

  [Module]
mods <- (String -> IO Module) -> [String] -> IO [Module]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO Module
find_it [String]
strs

  let get_iface :: Module -> IfM lcl ModIface
get_iface Module
modl = Bool -> SDoc -> Module -> IfM lcl ModIface
forall lcl. Bool -> SDoc -> Module -> IfM lcl ModIface
loadUserInterface Bool
False (String -> SDoc
text String
"abiHash") Module
modl
  [ModIface]
ifaces <- SDoc -> HscEnv -> IfG [ModIface] -> IO [ModIface]
forall a. SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck (String -> SDoc
text String
"abiHash") HscEnv
hsc_env (IfG [ModIface] -> IO [ModIface])
-> IfG [ModIface] -> IO [ModIface]
forall a b. (a -> b) -> a -> b
$ (Module -> IOEnv (Env IfGblEnv ()) ModIface)
-> [Module] -> IfG [ModIface]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Module -> IOEnv (Env IfGblEnv ()) ModIface
forall lcl. Module -> IfM lcl ModIface
get_iface [Module]
mods

  BinHandle
bh <- Int -> IO BinHandle
openBinMem (Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1024) -- just less than a block
  BinHandle -> Integer -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Integer
hiVersion
    -- package hashes change when the compiler version changes (for now)
    -- see #5328
  (ModIface -> IO ()) -> [ModIface] -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (BinHandle -> Fingerprint -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Fingerprint -> IO ())
-> (ModIface -> Fingerprint) -> ModIface -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIfaceBackend -> Fingerprint
mi_mod_hash (ModIfaceBackend -> Fingerprint)
-> (ModIface -> ModIfaceBackend) -> ModIface -> Fingerprint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> ModIfaceBackend
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts) [ModIface]
ifaces
  Fingerprint
f <- BinHandle -> IO Fingerprint
fingerprintBinMem BinHandle
bh

  FatalMessager
putStrLn (DynFlags -> Fingerprint -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags Fingerprint
f)

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

makeHDL'
  :: forall backend
   . Backend backend
  => Proxy backend
  -> Ghc ()
  -> IORef ClashOpts
  -> [(String,Maybe Phase)]
  -> Ghc ()
makeHDL' :: 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 (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' (Proxy VHDLState
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' (Proxy VerilogState
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' (Proxy SystemVerilogState
forall k (t :: k). Proxy t
Proxy @SystemVerilogState)

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

unknownFlagsErr :: [String] -> a
unknownFlagsErr :: [String] -> a
unknownFlagsErr [String]
fs = GhcException -> a
forall a. GhcException -> a
throwGhcException (GhcException -> a) -> GhcException -> a
forall a b. (a -> b) -> a -> b
$ String -> GhcException
UsageError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> String
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap String -> String
oneError [String]
fs
  where
    oneError :: String -> String
oneError String
f =
        String
"unrecognised flag: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
        (case String -> [String] -> [String]
match String
f ([String] -> [String]
forall a. Ord a => [a] -> [a]
nubSort [String]
allNonDeprecatedFlags) of
            [] -> String
""
            [String]
suggs -> String
"did you mean one of:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
suggs))
    -- fixes #11789
    -- If the flag contains '=',
    -- this uses both the whole and the left side of '=' for comparing.
    match :: String -> [String] -> [String]
match String
f [String]
allFlags
        | Char -> String -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
elem Char
'=' String
f =
              let ([String]
flagsWithEq, [String]
flagsWithoutEq) = (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Char -> String -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
elem Char
'=') [String]
allFlags
                  fName :: String
fName = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'=') String
f
              in (String -> [String] -> [String]
fuzzyMatch String
f [String]
flagsWithEq) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (String -> [String] -> [String]
fuzzyMatch String
fName [String]
flagsWithoutEq)
        | Bool
otherwise = String -> [String] -> [String]
fuzzyMatch String
f [String]
allFlags

{- Note [-Bsymbolic and hooks]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Bsymbolic is a flag that prevents the binding of references to global
symbols to symbols outside the shared library being compiled (see `man
ld`). When dynamically linking, we don't use -Bsymbolic on the RTS
package: that is because we want hooks to be overridden by the user,
we don't want to constrain them to the RTS package.

Unfortunately this seems to have broken somehow on OS X: as a result,
defaultHooks (in hschooks.c) is not called, which does not initialize
the GC stats. As a result, this breaks things like `:set +s` in GHCi
(#8754). As a hacky workaround, we instead call 'defaultHooks'
directly to initalize the flags in the RTS.

A byproduct of this, I believe, is that hooks are likely broken on OS
X when dynamically linking. But this probably doesn't affect most
people since we're linking GHC dynamically, but most things themselves
link statically.
-}

-- If GHC_LOADED_INTO_GHCI is not set when GHC is loaded into GHCi, then
-- running it causes an error like this:
--
-- Loading temp shared object failed:
-- /tmp/ghc13836_0/libghc_1872.so: undefined symbol: initGCStatistics
--
-- Skipping the foreign call fixes this problem, and the outer GHCi
-- should have already made this call anyway.
#if defined(GHC_LOADED_INTO_GHCI)
initGCStatistics :: IO ()
initGCStatistics = return ()
#else
foreign import ccall safe "initGCStatistics"
  initGCStatistics :: IO ()
#endif