{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables, TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}

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

module Clash.Main (defaultMain) 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(GHCI)
import Clash.GHCi.UI    ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )
#endif

-- Frontend plugins
#if defined(GHCI)
import DynamicLoading   ( loadFrontendPlugin )
import Plugins
#else
import DynamicLoading   ( pluginError )
#endif
import Module           ( ModuleName )


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

-- 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 Data.Char
import Data.List
import Data.Maybe

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

import qualified Clash.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.Netlist.BlackBox.Types (HdlSyn (..))
import           Clash.Util (clashLibVersion)
import           Clash.GHC.LoadModules (ghcLibDir, wantedLanguageExtensions)
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 = ([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 :: * -> *) 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 "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
    (argv2 :: [Located String]
argv2, clashFlagWarnings :: [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
mode, argv3 :: [Located String]
argv3, modeFlagWarnings :: [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
preStartupMode ->
          do case PreStartupMode
preStartupMode of
                 ShowSupportedExtensions   -> IO ()
showSupportedExtensions
                 ShowVersion               -> IO ()
showVersion
                 ShowNumVersion            -> FatalMessager
putStrLn String
cProjectVersion
                 ShowOptions isInteractive :: Bool
isInteractive -> Bool -> IO ()
showOptions Bool
isInteractive
      Right postStartupMode :: 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 :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
          let dflagsExtra :: DynFlags
dflagsExtra = DynFlags -> DynFlags
wantedLanguageExtensions DynFlags
dflags

              ghcTyLitNormPlugin :: ModuleName
ghcTyLitNormPlugin = String -> ModuleName
GHC.mkModuleName "GHC.TypeLits.Normalise"
              ghcTyLitExtrPlugin :: ModuleName
ghcTyLitExtrPlugin = String -> ModuleName
GHC.mkModuleName "GHC.TypeLits.Extra.Solver"
              ghcTyLitKNPlugin :: ModuleName
ghcTyLitKNPlugin   = String -> ModuleName
GHC.mkModuleName "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
preLoadMode ->
                  IO () -> Ghc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
                      case PreLoadMode
preLoadMode of
                          ShowInfo               -> DynFlags -> IO ()
showInfo DynFlags
dflagsExtra1
                          ShowGhcUsage           -> DynFlags -> IO ()
showGhcUsage  DynFlags
dflagsExtra1
                          ShowGhciUsage          -> DynFlags -> IO ()
showGhciUsage DynFlags
dflagsExtra1
                          PrintWithDynFlags f :: DynFlags -> String
f    -> FatalMessager
putStrLn (DynFlags -> String
f DynFlags
dflagsExtra1)
              Right postLoadMode :: PostLoadMode
postLoadMode ->
                  PostLoadMode
-> DynFlags
-> [Located String]
-> [Warn]
-> IORef ClashOpts
-> Ghc ()
main' PostLoadMode
postLoadMode DynFlags
dflagsExtra1 [Located String]
argv3 [Warn]
flagWarnings IORef ClashOpts
r

main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn]
      -> IORef ClashOpts
      -> Ghc ()
main' :: PostLoadMode
-> DynFlags
-> [Located String]
-> [Warn]
-> IORef ClashOpts
-> Ghc ()
main' postLoadMode :: PostLoadMode
postLoadMode dflags0 :: DynFlags
dflags0 args :: [Located String]
args flagWarnings :: [Warn]
flagWarnings clashOpts :: 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
      (mode :: GhcMode
mode, lang :: HscTarget
lang, link :: GhcLink
link)
         = case PostLoadMode
postLoadMode of
               DoInteractive   -> (GhcMode
CompManager, HscTarget
HscInterpreted, GhcLink
LinkInMemory)
               DoEval _        -> (GhcMode
CompManager, HscTarget
HscInterpreted, GhcLink
LinkInMemory)
               DoMake          -> (GhcMode
CompManager, HscTarget
dflt_target,    GhcLink
LinkBinary)
               DoBackpack      -> (GhcMode
CompManager, HscTarget
dflt_target,    GhcLink
LinkBinary)
               DoMkDependHS    -> (GhcMode
MkDepend,    HscTarget
dflt_target,    GhcLink
LinkBinary)
               DoAbiHash       -> (GhcMode
OneShot,     HscTarget
dflt_target,    GhcLink
LinkBinary)
               DoVHDL          -> (GhcMode
CompManager, HscTarget
HscNothing,     GhcLink
NoLink)
               DoVerilog       -> (GhcMode
CompManager, HscTarget
HscNothing,     GhcLink
NoLink)
               DoSystemVerilog -> (GhcMode
CompManager, HscTarget
HscNothing,     GhcLink
NoLink)
               _               -> (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 _ -> 0
                                         _other :: PostLoadMode
_other   -> 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 _      <- 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
  (dflags3 :: DynFlags
dflags3, fileish_args :: [Located String]
fileish_args, dynamicFlagWarnings :: [Warn]
dynamicFlagWarnings) <-
      DynFlags
-> [Located String] -> Ghc (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
GHC.parseDynamicFlags DynFlags
dflags2 [Located String]
args

  let dflags4 :: DynFlags
dflags4 = case HscTarget
lang of
                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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Platform -> Way -> [GeneralFlag]
wayUnsetGeneralFlags Platform
platform)
                                             [Way]
interpWays
                    in DynFlags
dflags3c
                _ ->
                    DynFlags
dflags3

  DynFlags -> Ghc () -> Ghc ()
forall (m :: * -> *) 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 :: * -> *) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
handleSourceError (\e :: SourceError
e -> do
       SourceError -> Ghc ()
forall (m :: * -> *). GhcMonad m => SourceError -> m ()
GHC.printException SourceError
e
       IO () -> Ghc ()
forall (m :: * -> *) 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 1)) (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
         IO () -> Ghc ()
forall (m :: * -> *) 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 :: * -> *) 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 fp :: String
fp
        | Bool
strt_dot_sl Bool -> Bool -> Bool
&& "-" 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 -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
fp
#endif
          cur_dir :: String
cur_dir = '.' 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
    (srcs :: [(String, Maybe Phase)]
srcs, objs :: [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]
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 :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
dflags5
  DynFlags
dflags6 <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  HscEnv
hsc_env <- Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
GHC.getSession

        ---------------- Display configuration -----------
  case DynFlags -> Int
verbosity DynFlags
dflags6 of
    v :: Int
v | Int
v Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 4 -> IO () -> Ghc ()
forall (m :: * -> *) 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
>= 5 -> IO () -> Ghc ()
forall (m :: * -> *) 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 :: * -> *) a. Monad m => a -> m a
return ()

  IO () -> Ghc ()
forall (m :: * -> *) 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 :: * -> *) 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 :: * -> *) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
handleSourceError (\e :: SourceError
e -> do
       SourceError -> Ghc ()
forall (m :: * -> *). GhcMonad m => SourceError -> m ()
GHC.printException SourceError
e
       IO () -> Ghc ()
forall (m :: * -> *) 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 1)) (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
    ClashOpts
clashOpts' <- IO ClashOpts -> Ghc ClashOpts
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef ClashOpts -> IO ClashOpts
forall a. IORef a -> IO a
readIORef IORef ClashOpts
clashOpts)
    let clash :: (IORef ClashOpts -> [(String, Maybe Phase)] -> m a) -> m a
clash fun :: IORef ClashOpts -> [(String, Maybe Phase)] -> m a
fun = m a -> (SomeException -> m a) -> m a
forall (m :: * -> *) e a.
(ExceptionMonad m, Exception e) =>
m a -> (e -> m a) -> m a
gcatch (IORef ClashOpts -> [(String, Maybe Phase)] -> m a
fun IORef ClashOpts
clashOpts [(String, Maybe Phase)]
srcs) (DynFlags -> ClashOpts -> SomeException -> m a
forall (m :: * -> *) a.
GhcMonad m =>
DynFlags -> ClashOpts -> SomeException -> m a
handleClashException DynFlags
dflags6 ClashOpts
clashOpts')
    case PostLoadMode
postLoadMode of
       ShowInterface f :: String
f        -> IO () -> Ghc ()
forall (m :: * -> *) 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
       DoMake                 -> [(String, Maybe Phase)] -> Ghc ()
doMake [(String, Maybe Phase)]
srcs
       DoMkDependHS           -> [String] -> Ghc ()
forall (m :: * -> *). 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 p :: Phase
p           -> IO () -> Ghc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> Phase -> [(String, Maybe Phase)] -> IO ()
oneShot HscEnv
hsc_env Phase
p [(String, Maybe Phase)]
srcs)
       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 exprs :: [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
       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)
       ShowPackages           -> IO () -> Ghc ()
forall (m :: * -> *) 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 f :: ModuleName
f           -> ModuleName -> [(String, Maybe Phase)] -> Ghc ()
doFrontend ModuleName
f [(String, Maybe Phase)]
srcs
       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)
       DoVHDL                 -> (IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()) -> Ghc ()
forall (m :: * -> *) a.
GhcMonad m =>
(IORef ClashOpts -> [(String, Maybe Phase)] -> m a) -> m a
clash IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeVHDL
       DoVerilog              -> (IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()) -> Ghc ()
forall (m :: * -> *) a.
GhcMonad m =>
(IORef ClashOpts -> [(String, Maybe Phase)] -> m a) -> m a
clash IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeVerilog
       DoSystemVerilog        -> (IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()) -> Ghc ()
forall (m :: * -> *) a.
GhcMonad m =>
(IORef ClashOpts -> [(String, Maybe Phase)] -> m a) -> m a
clash IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeSystemVerilog

  IO () -> Ghc ()
forall (m :: * -> *) 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(GHCI)
ghciUI _ _ _ _ _ = throwGhcException (CmdLineError "not built for interactive use")
#else
ghciUI :: IORef ClashOpts
-> HscEnv
-> DynFlags
-> [(String, Maybe Phase)]
-> Maybe [String]
-> Ghc ()
ghciUI clashOpts :: IORef ClashOpts
clashOpts hsc_env :: HscEnv
hsc_env dflags0 :: DynFlags
dflags0 srcs :: [(String, Maybe Phase)]
srcs maybe_expr :: Maybe [String]
maybe_expr = do
  DynFlags
dflags1 <- IO DynFlags -> Ghc DynFlags
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> DynFlags -> IO DynFlags
initializePlugins HscEnv
hsc_env DynFlags
dflags0)
  [InstalledUnitId]
_ <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: * -> *). 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 [] srcs :: [(String, Maybe Phase)]
srcs objs :: [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 ("-x":suff :: String
suff:args :: [String]
args) srcs :: [(String, Maybe Phase)]
srcs objs :: [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
              (slurp :: [String]
slurp,rest :: [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
== "-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 (arg :: String
arg:args :: [String]
args) srcs :: [(String, Maybe Phase)]
srcs objs :: [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 m :: String
m =  String -> Bool
isSourceFilename String
m
                      Bool -> Bool -> Bool
|| String -> Bool
looksLikeModuleName String
m
                      Bool -> Bool -> Bool
|| "-" 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 mode :: PostLoadMode
mode dflags :: DynFlags
dflags srcs :: [(String, Maybe Phase)]
srcs objs :: [String]
objs = do
     -- Complain about any unknown flags
   let unknown_opts :: [String]
unknown_opts = [ String
f | (f :: String
f@('-':_), _) <- [(String, Maybe Phase)]
srcs ]
   Bool -> IO () -> IO ()
forall (f :: * -> *). 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 :: * -> *). 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 ("Warning: -debug, -threaded and -ticky are ignored by GHCi")

        -- -prof and --interactive are not a good combination
   Bool -> IO () -> IO ()
forall (f :: * -> *). 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
              "-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` 1))
        then GhcException -> IO ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
UsageError "-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` 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 "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 :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
not_linking Bool -> Bool -> Bool
&& Bool -> Bool
not ([String] -> Bool
forall (t :: * -> *) 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 ("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 :: * -> *) a. Foldable t => t a -> Bool
null [(String, Maybe Phase)]
srcs Bool -> Bool -> Bool
&& ([String] -> Bool
forall (t :: * -> *) 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 "no input files")
        else do

   case PostLoadMode
mode of
      StopBefore 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
$
           "the option -C is only available with an unregisterised GHC"
      _ -> () -> IO ()
forall (m :: * -> *) 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 dflags :: DynFlags
dflags = do
  let ofile :: Maybe String
ofile = DynFlags -> Maybe String
outputFile DynFlags
dflags
  Bool -> IO () -> IO ()
forall (f :: * -> *). 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 :: * -> *). 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 "-o" String
fn)
  let ohi :: Maybe String
ohi = DynFlags -> Maybe String
outputHi DynFlags
dflags
  Bool -> IO () -> IO ()
forall (f :: * -> *). 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 :: * -> *). 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 "-ohi" String
hi)
 where
   nonExistentDir :: a -> a -> a
nonExistentDir flg :: a
flg dir :: a
dir =
     GhcException -> a
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError ("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]
++ " 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]
++ " 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 ShowVersion) = Bool
True
isShowVersionMode _ = Bool
False

isShowNumVersionMode :: Mode -> Bool
isShowNumVersionMode :: Mode -> Bool
isShowNumVersionMode (Left ShowNumVersion) = Bool
True
isShowNumVersionMode _ = 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 k :: String
k = PreLoadMode -> Mode
mkPreLoadMode ((DynFlags -> String) -> PreLoadMode
PrintWithDynFlags DynFlags -> String
f)
    where f :: DynFlags -> String
f dflags :: DynFlags
dflags = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String -> String
forall a. String -> a
panic ("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 ShowGhcUsage)) = Bool
True
isShowGhcUsageMode _ = Bool
False

isShowGhciUsageMode :: Mode -> Bool
isShowGhciUsageMode :: Mode -> Bool
isShowGhciUsageMode (Right (Left ShowGhciUsage)) = Bool
True
isShowGhciUsageMode _ = 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 fp :: String
fp = PostLoadMode -> Mode
mkPostLoadMode (String -> PostLoadMode
ShowInterface String
fp)

stopBeforeMode :: Phase -> Mode
stopBeforeMode :: Phase -> Mode
stopBeforeMode phase :: Phase
phase = PostLoadMode -> Mode
mkPostLoadMode (Phase -> PostLoadMode
StopBefore Phase
phase)

doEvalMode :: String -> Mode
doEvalMode :: String -> Mode
doEvalMode str :: String
str = PostLoadMode -> Mode
mkPostLoadMode ([String] -> PostLoadMode
DoEval [String
str])

doFrontendMode :: String -> Mode
doFrontendMode :: String -> Mode
doFrontendMode str :: 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 DoInteractive)) = Bool
True
isDoInteractiveMode _ = Bool
False

isStopLnMode :: Mode -> Bool
isStopLnMode :: Mode -> Bool
isStopLnMode (Right (Right (StopBefore StopLn))) = Bool
True
isStopLnMode _ = Bool
False

isDoMakeMode :: Mode -> Bool
isDoMakeMode :: Mode -> Bool
isDoMakeMode (Right (Right DoMake)) = Bool
True
isDoMakeMode _ = Bool
False

isDoEvalMode :: Mode -> Bool
isDoEvalMode :: Mode -> Bool
isDoEvalMode (Right (Right (DoEval _))) = Bool
True
isDoEvalMode _ = Bool
False

#if defined(GHCI)
isInteractiveMode :: PostLoadMode -> Bool
isInteractiveMode :: PostLoadMode -> Bool
isInteractiveMode DoInteractive = Bool
True
isInteractiveMode _             = Bool
False
#endif

-- isInterpretiveMode: byte-code compiler involved
isInterpretiveMode :: PostLoadMode -> Bool
isInterpretiveMode :: PostLoadMode -> Bool
isInterpretiveMode DoInteractive = Bool
True
isInterpretiveMode (DoEval _)    = Bool
True
isInterpretiveMode _             = Bool
False

needsInputsMode :: PostLoadMode -> Bool
needsInputsMode :: PostLoadMode -> Bool
needsInputsMode DoMkDependHS    = Bool
True
needsInputsMode (StopBefore _)  = Bool
True
needsInputsMode DoMake          = Bool
True
needsInputsMode DoVHDL          = Bool
True
needsInputsMode DoVerilog       = Bool
True
needsInputsMode DoSystemVerilog = Bool
True
needsInputsMode _               = 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 StopLn) = Bool
True
isLinkMode DoMake              = Bool
True
isLinkMode DoInteractive       = Bool
True
isLinkMode (DoEval _)          = Bool
True
isLinkMode _                   = Bool
False

isCompManagerMode :: PostLoadMode -> Bool
isCompManagerMode :: PostLoadMode -> Bool
isCompManagerMode DoMake        = Bool
True
isCompManagerMode DoInteractive = Bool
True
isCompManagerMode (DoEval _)    = Bool
True
isCompManagerMode DoVHDL        = Bool
True
isCompManagerMode DoVerilog     = Bool
True
isCompManagerMode DoSystemVerilog = Bool
True
isCompManagerMode _             = Bool
False

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

parseModeFlags :: [Located String]
               -> IO (Mode,
                      [Located String],
                      [Warn])
parseModeFlags :: [Located String] -> IO (Mode, [Located String], [Warn])
parseModeFlags args :: [Located String]
args = do
  let ((leftover :: [Located String]
leftover, errs1 :: [Err]
errs1, warns :: [Warn]
warns), (mModeFlag :: Maybe (Mode, String)
mModeFlag, errs2 :: [String]
errs2, flags' :: [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 :: * -> *).
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
             Nothing     -> Mode
doMakeMode
             Just (m :: Mode
m, _) -> Mode
m

  -- See Note [Handling errors when parsing commandline flags]
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Err] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Err]
errs1 Bool -> Bool -> Bool
&& [String] -> Bool
forall (t :: * -> *) 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 (("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 :: * -> *) 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 :: * -> *). String -> OptKind m -> Flag m
defFlag "?"                     ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
showGhcUsageMode))
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "-help"                 ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
showGhcUsageMode))
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "V"                     ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
showVersionMode))
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "-version"              ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
showVersionMode))
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "-numeric-version"      ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
showNumVersionMode))
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "-info"                 ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
showInfoMode))
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "-show-options"         ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
showOptionsMode))
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "-supported-languages"  ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
showSupportedExtensionsMode))
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "-supported-extensions" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
showSupportedExtensionsMode))
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "-show-packages"        ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (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 :: * -> *). String -> OptKind m -> Flag m
defFlag String
k'                      ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode (String -> Mode
printSetting String
k)))
  | String
k <- ["Project version",
          "Project Git commit id",
          "Booter version",
          "Stage",
          "Build platform",
          "Host platform",
          "Target platform",
          "Have interpreter",
          "Object splitting supported",
          "Have native code generator",
          "Support SMP",
          "Unregisterised",
          "Tables next to code",
          "RTS ways",
          "Leading underscore",
          "Debug on",
          "LibDir",
          "Global Package DB",
          "C compiler flags",
          "C compiler link flags",
          "ld flags"],
    let k' :: String
k' = "-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 ' ' = '-'
        replaceSpace c :: Char
c   = Char
c
  ] [Flag ModeM] -> [Flag ModeM] -> [Flag ModeM]
forall a. [a] -> [a] -> [a]
++
      ------- interfaces ----------------------------------------------------
  [ String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "-show-iface"  ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
HasArg (\f :: String
f -> Mode -> String -> EwM ModeM ()
setMode (String -> Mode
showInterfaceMode String
f)
                                               "--show-iface"))

      ------- primary modes ------------------------------------------------
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "c"            ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
PassFlag (\f :: String
f -> do Mode -> String -> EwM ModeM ()
setMode (Phase -> Mode
stopBeforeMode Phase
StopLn) String
f
                                               String -> String -> EwM ModeM ()
addFlag "-no-link" String
f))
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "M"            ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
doMkDependHSMode))
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "E"            ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode (Phase -> Mode
stopBeforeMode Phase
anyHsc)))
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "C"            ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode (Phase -> Mode
stopBeforeMode Phase
HCc)))
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "S"            ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (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 :: * -> *). String -> OptKind m -> Flag m
defFlag "-make"        ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
doMakeMode))
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "-backpack"    ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
doBackpackMode))
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "-interactive" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
doInteractiveMode))
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "-abi-hash"    ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
doAbiHashMode))
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "e"            ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
SepArg   (\s :: String
s -> Mode -> String -> EwM ModeM ()
setMode (String -> Mode
doEvalMode String
s) "-e"))
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "-frontend"    ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
SepArg   (\s :: String
s -> Mode -> String -> EwM ModeM ()
setMode (String -> Mode
doFrontendMode String
s) "-frontend"))
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "-vhdl"        ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
doVHDLMode))
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "-verilog"     ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
doVerilogMode))
  , String -> OptKind ModeM -> Flag ModeM
forall (m :: * -> *). String -> OptKind m -> Flag m
defFlag "-systemverilog" ((String -> EwM ModeM ()) -> OptKind ModeM
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
PassFlag (Mode -> String -> EwM ModeM ()
setMode Mode
doSystemVerilogMode))
  ]

setMode :: Mode -> String -> EwM ModeM ()
setMode :: Mode -> String -> EwM ModeM ()
setMode newMode :: Mode
newMode newFlag :: String
newFlag = CmdLineP (Maybe (Mode, String), [String], [Located String]) ()
-> EwM ModeM ()
forall (m :: * -> *) 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
    (mModeFlag :: Maybe (Mode, String)
mModeFlag, errs :: [String]
errs, flags' :: [Located String]
flags') <- CmdLineP
  (Maybe (Mode, String), [String], [Located String])
  (Maybe (Mode, String), [String], [Located String])
forall s. CmdLineP s s
getCmdLineState
    let (modeFlag' :: (Mode, String)
modeFlag', errs' :: [String]
errs') =
            case Maybe (Mode, String)
mModeFlag of
            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 -> 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, "--make"), [])

                    -- If we have both --help and --interactive then we
                    -- want showGhciUsage
                    _ | 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 -> 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 esOld :: [String]
esOld)),
                     Right (Right (DoEval [eNew :: 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
                    _ | 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 DoInteractive), Left (ShowOptions _)) ->
                      ((PreStartupMode -> Mode
forall a b. a -> Either a b
Left (Bool -> PreStartupMode
ShowOptions Bool
True),
                        "--interactive --show-options"), [String]
errs)
                    (Left (ShowOptions _), (Right (Right DoInteractive))) ->
                      ((PreStartupMode -> Mode
forall a b. a -> Either a b
Left (Bool -> PreStartupMode
ShowOptions Bool
True),
                        "--show-options --interactive"), [String]
errs)
                    -- Otherwise, complain
                    _ -> 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 f :: 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 oldFlag :: String
oldFlag newFlag :: String
newFlag
    = "cannot use `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
oldFlag String -> String -> String
forall a. [a] -> [a] -> [a]
++  "' with `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
newFlag String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'"

addFlag :: String -> String -> EwM ModeM ()
addFlag :: String -> String -> EwM ModeM ()
addFlag s :: String
s flag :: String
flag = CmdLineP (Maybe (Mode, String), [String], [Located String]) ()
-> EwM ModeM ()
forall (m :: * -> *) 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
  (m :: Maybe (Mode, String)
m, e :: [String]
e, flags' :: [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 = "addFlag by " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
flag String -> String -> String
forall a. [a] -> [a] -> [a]
++ " on the commandline"

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

doMake :: [(String,Maybe Phase)] -> Ghc ()
doMake :: [(String, Maybe Phase)] -> Ghc ()
doMake srcs :: [(String, Maybe Phase)]
srcs  = do
    let (hs_srcs :: [(String, Maybe Phase)]
hs_srcs, non_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 :: * -> *). 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 :: * -> *) a. Foldable t => t a -> Bool
null [(String, Maybe Phase)]
hs_srcs)
       then IO () -> Ghc ()
forall (m :: * -> *) 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 :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\x :: (String, Maybe Phase)
x -> IO String -> Ghc String
forall (m :: * -> *) 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 :: * -> *). 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]
o_files
                                      [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ DynFlags -> [Option]
ldInputs DynFlags
dflags }
    [InstalledUnitId]
_ <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
dflags'

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

    Bool -> Ghc () -> Ghc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SuccessFlag -> Bool
failed SuccessFlag
ok_flag) (IO () -> Ghc ()
forall (m :: * -> *) 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 1))
    () -> Ghc ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


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

doShowIface :: DynFlags -> FilePath -> IO ()
doShowIface :: DynFlags -> FatalMessager
doShowIface dflags :: DynFlags
dflags file :: 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
_postLoadMode dflags :: DynFlags
dflags = do
   let verb :: Int
verb = DynFlags -> Int
verbosity DynFlags
dflags

#if defined(GHCI)
   -- Show the GHCi banner
   Bool -> IO () -> IO ()
forall (f :: * -> *). 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
>= 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 :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
verb Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    do Handle -> FatalMessager
hPutStr Handle
stderr "Glasgow Haskell Compiler, Version "
       Handle -> FatalMessager
hPutStr Handle
stderr String
cProjectVersion
       Handle -> FatalMessager
hPutStr Handle
stderr ", stage "
       Handle -> FatalMessager
hPutStr Handle
stderr String
cStage
       Handle -> FatalMessager
hPutStr Handle
stderr " 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 dflags :: DynFlags
dflags = do
        let sq :: String -> String
sq x :: String
x = " [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\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 "\n ," ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
forall a. Show a => a -> String
show ([(String, String)] -> [String]) -> [(String, String)] -> [String]
forall a b. (a -> b) -> a -> b
$ DynFlags -> [(String, String)]
compilerInfo DynFlags
dflags

showSupportedExtensions :: IO ()
showSupportedExtensions :: IO ()
showSupportedExtensions = FatalMessager -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FatalMessager
putStrLn [String]
supportedLanguagesAndExtensions

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

showOptions :: Bool -> IO ()
showOptions :: Bool -> IO ()
showOptions isInteractive :: Bool
isInteractive = FatalMessager
putStr ([String] -> String
unlines [String]
availableOptions)
    where
      availableOptions :: [String]
availableOptions = [[String]] -> [String]
forall (t :: * -> *) 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 -> String -> String
forall a. a -> [a] -> [a]
:) ([Flag ModeM] -> [String]
forall (m :: * -> *). [Flag m] -> [String]
getFlagNames [Flag ModeM]
mode_flags)
        ]
      getFlagNames :: [Flag m] -> [String]
getFlagNames opts :: [Flag m]
opts         = (Flag m -> String) -> [Flag m] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Flag m -> String
forall (m :: * -> *). 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 ghci :: Bool
ghci dflags :: 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 ""          = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     dump ('$':'$':s :: String
s) = FatalMessager
putStr String
progName IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FatalMessager
dump String
s
     dump (c :: Char
c:s :: String
s)       = Char -> IO ()
putChar Char
c IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FatalMessager
dump String
s

dumpFinalStats :: DynFlags -> IO ()
dumpFinalStats :: DynFlags -> IO ()
dumpFinalStats dflags :: DynFlags
dflags =
  Bool -> IO () -> IO ()
forall (f :: * -> *). 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 dflags :: DynFlags
dflags = do
  [[[FastString]]]
segments <- IO [[[FastString]]]
getFastStringTable
  let buckets :: [[FastString]]
buckets = [[[FastString]]] -> [[FastString]]
forall (t :: * -> *) 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 :: * -> *) 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 :: * -> *) a. Foldable t => t a -> Int
length [[FastString]]
buckets
      entries :: Int
entries = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
entriesPerBucket
      hasZ :: Int
hasZ = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ([FastString] -> Int) -> [[FastString]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([FastString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([FastString] -> Int)
-> ([FastString] -> [FastString]) -> [FastString] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FastString -> Bool) -> [FastString] -> [FastString]
forall a. (a -> Bool) -> [a] -> [a]
filter FastString -> Bool
hasZEncoding) [[FastString]]
buckets
      msg :: SDoc
msg = String -> SDoc
text "FastString stats:" SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 4 ([SDoc] -> SDoc
vcat
        [ String -> SDoc
text "segments:         " SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int ([[[FastString]]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[[FastString]]]
segments)
        , String -> SDoc
text "buckets:          " SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
bucketsPerSegment)
        , String -> SDoc
text "entries:          " SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
entries
        , String -> SDoc
text "largest segment:  " SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
bucketsPerSegment)
        , String -> SDoc
text "smallest segment: " SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Int]
bucketsPerSegment)
        , String -> SDoc
text "longest bucket:   " SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
entriesPerBucket)
        , String -> SDoc
text "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
   x :: Int
x pcntOf :: Int -> Int -> SDoc
`pcntOf` y :: Int
y = Int -> SDoc
int ((Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* 100) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
y) SDoc -> SDoc -> SDoc
Outputable.<> Char -> SDoc
char '%'

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

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

doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()
#if !defined(GHCI)
doFrontend modname _ = pluginError [modname]
#else
doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()
doFrontend modname :: ModuleName
modname srcs :: [(String, Maybe Phase)]
srcs = do
    HscEnv
hsc_env <- Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    FrontendPlugin
frontend_plugin <- IO FrontendPlugin -> Ghc FrontendPlugin
forall (m :: * -> *) 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
#endif

-- -----------------------------------------------------------------------------
-- 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 (Trac #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 strs :: [String]
strs = do
  HscEnv
hsc_env <- Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

  IO () -> Ghc ()
forall (m :: * -> *) 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 str :: 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 _ m :: Module
m -> Module -> IO Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
           _error :: 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 :: * -> *) (m :: * -> *) 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 modl :: Module
modl = Bool -> SDoc -> Module -> IfM lcl ModIface
forall lcl. Bool -> SDoc -> Module -> IfM lcl ModIface
loadUserInterface Bool
False (String -> SDoc
text "abiHash") Module
modl
  [ModIface]
ifaces <- SDoc -> HscEnv -> IfG [ModIface] -> IO [ModIface]
forall a. SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck (String -> SDoc
text "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 :: * -> *) (m :: * -> *) 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 (3Int -> Int -> Int
forall a. Num a => a -> a -> a
*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 :: * -> *) (m :: * -> *) 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
. ModIface -> Fingerprint
mi_mod_hash) [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' :: Clash.Backend.Backend backend => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) ->  backend)
         -> IORef ClashOpts -> [(String,Maybe Phase)] -> Ghc ()
makeHDL' :: (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)
-> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeHDL' _       _ []   = GhcException -> Ghc ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError "No input files")
makeHDL' backend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend
backend r :: IORef ClashOpts
r srcs :: [(String, Maybe Phase)]
srcs = (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)
-> IORef ClashOpts -> [String] -> Ghc ()
forall (m :: * -> *) backend.
(GhcMonad m, Backend backend) =>
(Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)
-> IORef ClashOpts -> [String] -> m ()
makeHDL Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend
backend IORef ClashOpts
r ([String] -> Ghc ()) -> [String] -> Ghc ()
forall a b. (a -> b) -> a -> b
$ ((String, Maybe Phase) -> String)
-> [(String, Maybe Phase)] -> [String]
forall (f :: * -> *) 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 :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeVHDL :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeVHDL = (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VHDLState)
-> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
forall backend.
Backend backend =>
(Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)
-> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeHDL' (Backend VHDLState =>
Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VHDLState
forall state.
Backend state =>
Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> state
Clash.Backend.initBackend @VHDLState)

makeVerilog ::  IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeVerilog :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeVerilog = (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VerilogState)
-> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
forall backend.
Backend backend =>
(Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)
-> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeHDL' (Backend VerilogState =>
Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VerilogState
forall state.
Backend state =>
Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> state
Clash.Backend.initBackend @VerilogState)

makeSystemVerilog ::  IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeSystemVerilog :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeSystemVerilog = (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> SystemVerilogState)
-> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
forall backend.
Backend backend =>
(Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)
-> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()
makeHDL' (Backend SystemVerilogState =>
Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> SystemVerilogState
forall state.
Backend state =>
Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> state
Clash.Backend.initBackend @SystemVerilogState)

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

unknownFlagsErr :: [String] -> a
unknownFlagsErr :: [String] -> a
unknownFlagsErr fs :: [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 :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> String
oneError [String]
fs
  where
    oneError :: String -> String
oneError f :: String
f =
        "unrecognised flag: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\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
            [] -> ""
            suggs :: [String]
suggs -> "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
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 f :: String
f allFlags :: [String]
allFlags
        | Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem '=' String
f =
              let (flagsWithEq :: [String]
flagsWithEq, flagsWithoutEq :: [String]
flagsWithoutEq) = (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem '=') [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
/= '=') 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