Add 'hadrian/' from commit '45f3bff7016a2a0cd9a5455a882ced984655e90b'

git-subtree-dir: hadrian
git-subtree-mainline: 575b35f4cdc18045bccd42d341d6f25d95c0696c
git-subtree-split: 45f3bff7016a2a0cd9a5455a882ced984655e90b

1 files changed, 258 insertions, 0 deletions

diff --git a/hadrian/src/CommandLine.hs b/hadrian/src/CommandLine.hs
new file mode 100644
index 0000000000..1532ec51d7
--- /dev/null
+++ b/hadrian/src/CommandLine.hs
@@ -0,0 +1,258 @@
+module CommandLine (
+    optDescrs, cmdLineArgsMap, cmdFlavour, lookupFreeze1, cmdIntegerSimple,
+    cmdProgressColour, cmdProgressInfo, cmdConfigure, cmdSplitObjects,
+    lookupBuildRoot, TestArgs(..), TestSpeed(..), defaultTestArgs
+    ) where
+
+import Data.Either
+import qualified Data.HashMap.Strict as Map
+import Data.List.Extra
+import Development.Shake hiding (Normal)
+import Hadrian.Utilities hiding (buildRoot)
+import System.Console.GetOpt
+import System.Environment
+
+data TestSpeed = Slow | Average | Fast deriving (Show, Eq)
+
+-- | All arguments that can be passed to Hadrian via the command line.
+data CommandLineArgs = CommandLineArgs
+    { configure      :: Bool
+    , flavour        :: Maybe String
+    , freeze1        :: Bool
+    , integerSimple  :: Bool
+    , progressColour :: UseColour
+    , progressInfo   :: ProgressInfo
+    , splitObjects   :: Bool
+    , buildRoot      :: BuildRoot
+    , testArgs       :: TestArgs }
+    deriving (Eq, Show)
+
+-- | Default values for 'CommandLineArgs'.
+defaultCommandLineArgs :: CommandLineArgs
+defaultCommandLineArgs = CommandLineArgs
+    { configure      = False
+    , flavour        = Nothing
+    , freeze1        = False
+    , integerSimple  = False
+    , progressColour = Auto
+    , progressInfo   = Brief
+    , splitObjects   = False
+    , buildRoot      = BuildRoot "_build"
+    , testArgs       = defaultTestArgs }
+
+-- | These arguments are used by the `test` target.
+data TestArgs = TestArgs
+    { testCompiler   :: String
+    , testConfigFile :: String
+    , testConfigs    :: [String]
+    , testJUnit      :: Maybe FilePath
+    , testOnly       :: Maybe String
+    , testOnlyPerf   :: Bool
+    , testSkipPerf   :: Bool
+    , testSpeed      :: TestSpeed
+    , testSummary    :: Maybe FilePath
+    , testVerbosity  :: Maybe String
+    , testWays       :: [String] }
+    deriving (Eq, Show)
+
+-- | Default value for `TestArgs`.
+defaultTestArgs :: TestArgs
+defaultTestArgs = TestArgs
+    { testCompiler   = "stage2"
+    , testConfigFile = "testsuite/config/ghc"
+    , testConfigs    = []
+    , testJUnit      = Nothing
+    , testOnly       = Nothing
+    , testOnlyPerf   = False
+    , testSkipPerf   = False
+    , testSpeed      = Fast
+    , testSummary    = Nothing
+    , testVerbosity  = Nothing
+    , testWays       = [] }
+
+readConfigure :: Either String (CommandLineArgs -> CommandLineArgs)
+readConfigure = Right $ \flags -> flags { configure = True }
+
+readFlavour :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readFlavour ms = Right $ \flags -> flags { flavour = lower <$> ms }
+
+readBuildRoot :: Maybe FilePath -> Either String (CommandLineArgs -> CommandLineArgs)
+readBuildRoot ms =
+    maybe (Left "Cannot parse build-root") (Right . set) (go =<< ms)
+  where
+    go :: String -> Maybe BuildRoot
+    go = Just . BuildRoot
+    set :: BuildRoot -> CommandLineArgs -> CommandLineArgs
+    set flag flags = flags { buildRoot = flag }
+
+readFreeze1 :: Either String (CommandLineArgs -> CommandLineArgs)
+readFreeze1 = Right $ \flags -> flags { freeze1 = True }
+
+readIntegerSimple :: Either String (CommandLineArgs -> CommandLineArgs)
+readIntegerSimple = Right $ \flags -> flags { integerSimple = True }
+
+readProgressColour :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readProgressColour ms =
+    maybe (Left "Cannot parse progress-colour") (Right . set) (go =<< lower <$> ms)
+  where
+    go :: String -> Maybe UseColour
+    go "never"   = Just Never
+    go "auto"    = Just Auto
+    go "always"  = Just Always
+    go _         = Nothing
+    set :: UseColour -> CommandLineArgs -> CommandLineArgs
+    set flag flags = flags { progressColour = flag }
+
+readProgressInfo :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readProgressInfo ms =
+    maybe (Left "Cannot parse progress-info") (Right . set) (go =<< lower <$> ms)
+  where
+    go :: String -> Maybe ProgressInfo
+    go "none"    = Just None
+    go "brief"   = Just Brief
+    go "normal"  = Just Normal
+    go "unicorn" = Just Unicorn
+    go _         = Nothing
+    set :: ProgressInfo -> CommandLineArgs -> CommandLineArgs
+    set flag flags = flags { progressInfo = flag }
+
+readSplitObjects :: Either String (CommandLineArgs -> CommandLineArgs)
+readSplitObjects = Right $ \flags -> flags { splitObjects = True }
+
+readTestCompiler :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestCompiler compiler = maybe (Left "Cannot parse compiler") (Right . set) compiler
+  where
+     set compiler  = \flags -> flags { testArgs = (testArgs flags) { testCompiler = compiler } }
+
+readTestConfig :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestConfig config =
+    case config of
+         Nothing -> Right id
+         Just conf -> Right $ \flags ->
+                        let configs = conf : testConfigs (testArgs flags)
+                        in flags { testArgs = (testArgs flags) { testConfigs = configs } }
+
+readTestConfigFile :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestConfigFile filepath =
+    maybe (Left "Cannot parse test-speed") (Right . set) filepath
+  where
+    set filepath flags =  flags { testArgs = (testArgs flags) { testConfigFile = filepath } }
+
+readTestJUnit :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestJUnit filepath = Right $ \flags -> flags { testArgs = (testArgs flags) { testJUnit = filepath } }
+
+readTestOnly :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestOnly tests = Right $ \flags -> flags { testArgs = (testArgs flags) { testOnly = tests } }
+
+readTestOnlyPerf :: Either String (CommandLineArgs -> CommandLineArgs)
+readTestOnlyPerf = Right $ \flags -> flags { testArgs = (testArgs flags) { testOnlyPerf = True } }
+
+readTestSkipPerf :: Either String (CommandLineArgs -> CommandLineArgs)
+readTestSkipPerf = Right $ \flags -> flags { testArgs = (testArgs flags) { testSkipPerf = True } }
+
+readTestSpeed :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestSpeed ms =
+    maybe (Left "Cannot parse test-speed") (Right . set) (go =<< lower <$> ms)
+  where
+    go :: String -> Maybe TestSpeed
+    go "fast"    = Just Fast
+    go "slow"    = Just Slow
+    go "average" = Just Average
+    go _         = Nothing
+    set :: TestSpeed -> CommandLineArgs -> CommandLineArgs
+    set flag flags = flags { testArgs = (testArgs flags) {testSpeed = flag} }
+
+readTestSummary :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestSummary filepath = Right $ \flags -> flags { testArgs = (testArgs flags) { testJUnit = filepath } }
+
+readTestVerbose :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestVerbose verbose = Right $ \flags -> flags { testArgs = (testArgs flags) { testVerbosity = verbose } }
+
+readTestWay :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestWay way =
+    case way of
+        Nothing -> Right id
+        Just way -> Right $ \flags ->
+            let newWays = way : testWays (testArgs flags)
+            in flags { testArgs = (testArgs flags) {testWays = newWays} }
+
+-- | Standard 'OptDescr' descriptions of Hadrian's command line arguments.
+optDescrs :: [OptDescr (Either String (CommandLineArgs -> CommandLineArgs))]
+optDescrs =
+    [ Option ['c'] ["configure"] (NoArg readConfigure)
+      "Run the boot and configure scripts (if you do not want to run them manually)."
+    , Option ['o'] ["build-root"] (OptArg readBuildRoot "BUILD_ROOT")
+      "Where to store build artifacts. (Default _build)."
+    , Option [] ["flavour"] (OptArg readFlavour "FLAVOUR")
+      "Build flavour (Default, Devel1, Devel2, Perf, Prof, Quick or Quickest)."
+    , Option [] ["freeze1"] (NoArg readFreeze1)
+      "Freeze Stage1 GHC."
+    , Option [] ["integer-simple"] (NoArg readIntegerSimple)
+      "Build GHC with integer-simple library."
+    , Option [] ["progress-colour"] (OptArg readProgressColour "MODE")
+      "Use colours in progress info (Never, Auto or Always)."
+    , Option [] ["progress-info"] (OptArg readProgressInfo "STYLE")
+      "Progress info style (None, Brief, Normal or Unicorn)."
+    , Option [] ["split-objects"] (NoArg readSplitObjects)
+      "Generate split objects (requires a full clean rebuild)."
+    , Option [] ["test-compiler"] (OptArg readTestCompiler "TEST_COMPILER")
+      "Use given compiler [Default=stage2]."
+    , Option [] ["test-config-file"] (OptArg readTestConfigFile "CONFIG_FILE")
+      "congiguration file for testsuite. Default=testsuite/config/ghc"
+    , Option [] ["config"] (OptArg readTestConfig "EXTRA_TEST_CONFIG")
+      "Configurations to run test, in key=value format."
+    , Option [] ["summary-junit"] (OptArg readTestJUnit "TEST_SUMMARY_JUNIT")
+      "Output testsuite summary in JUnit format."
+    , Option [] ["only"] (OptArg readTestOnly "TESTS")
+      "Test cases to run."
+    , Option [] ["only-perf"] (NoArg readTestOnlyPerf)
+      "Only run performance tests."
+    , Option [] ["skip-perf"] (NoArg readTestSkipPerf)
+      "Skip performance tests."
+    , Option [] ["test-speed"] (OptArg readTestSpeed "SPEED")
+      "fast, slow or normal. Normal by default"
+    , Option [] ["summary"] (OptArg readTestSummary "TEST_SUMMARY")
+      "Where to output the test summary file."
+    , Option [] ["test-verbose"] (OptArg readTestVerbose "TEST_VERBOSE")
+      "A verbosity value between 0 and 5. 0 is silent, 4 and higher activates extra output."
+    , Option [] ["test-way"] (OptArg readTestWay "TEST_WAY")
+      "only run these ways" ]
+
+-- | A type-indexed map containing Hadrian command line arguments to be passed
+-- to Shake via 'shakeExtra'.
+cmdLineArgsMap :: IO (Map.HashMap TypeRep Dynamic)
+cmdLineArgsMap = do
+    (opts, _, _) <- getOpt Permute optDescrs <$> getArgs
+    let args = foldl (flip id) defaultCommandLineArgs (rights opts)
+    return $ insertExtra (progressColour args) -- Accessed by Hadrian.Utilities
+           $ insertExtra (progressInfo   args) -- Accessed by Hadrian.Utilities
+           $ insertExtra (buildRoot      args) -- Accessed by Hadrian.Utilities
+           $ insertExtra (testArgs       args) -- Accessed by Settings.Builders.RunTest
+           $ insertExtra args Map.empty
+
+cmdLineArgs :: Action CommandLineArgs
+cmdLineArgs = userSetting defaultCommandLineArgs
+
+cmdConfigure :: Action Bool
+cmdConfigure = configure <$> cmdLineArgs
+
+cmdFlavour :: Action (Maybe String)
+cmdFlavour = flavour <$> cmdLineArgs
+
+lookupBuildRoot :: Map.HashMap TypeRep Dynamic -> BuildRoot
+lookupBuildRoot = buildRoot . lookupExtra defaultCommandLineArgs
+
+lookupFreeze1 :: Map.HashMap TypeRep Dynamic -> Bool
+lookupFreeze1 = freeze1 . lookupExtra defaultCommandLineArgs
+
+cmdIntegerSimple :: Action Bool
+cmdIntegerSimple = integerSimple <$> cmdLineArgs
+
+cmdProgressColour :: Action UseColour
+cmdProgressColour = progressColour <$> cmdLineArgs
+
+cmdProgressInfo :: Action ProgressInfo
+cmdProgressInfo = progressInfo <$> cmdLineArgs
+
+cmdSplitObjects :: Action Bool
+cmdSplitObjects = splitObjects <$> cmdLineArgs