path: root/hadrian/src/CommandLine.hs

module CommandLine (
    optDescrs, cmdLineArgsMap, cmdFlavour, lookupFreeze1, lookupFreeze2, lookupSkipDepends,
    cmdBignum, cmdBignumCheck, cmdProgressInfo, cmdCompleteSetting,
    cmdDocsArgs, cmdUnitIdHash, lookupBuildRoot, TestArgs(..), TestSpeed(..), defaultTestArgs,
    cmdPrefix, DocArgs(..), defaultDocArgs
    ) where

import Data.Either
import qualified Data.HashMap.Strict as Map
import Data.List.Extra
import Development.Shake hiding (Normal)
import Flavour (DocTargets, DocTarget(..))
import Hadrian.Utilities hiding (buildRoot)
import Settings.Parser
import System.Console.GetOpt
import System.Environment
import qualified System.Directory as Directory

import qualified Data.Set as Set
import Data.Maybe

data TestSpeed = TestSlow | TestNormal | TestFast 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
    , freeze2        :: Bool
    , skipDepends    :: Bool
    , unitIdHash     :: Bool
    , bignum         :: Maybe String
    , bignumCheck    :: Bool
    , progressInfo   :: ProgressInfo
    , buildRoot      :: BuildRoot
    , testArgs       :: TestArgs
    , docsArgs       :: DocArgs
    , docTargets     :: DocTargets
    , prefix         :: Maybe FilePath
    , completeStg    :: Maybe String }
    deriving (Eq, Show)

-- | Default values for 'CommandLineArgs'.
defaultCommandLineArgs :: CommandLineArgs
defaultCommandLineArgs = CommandLineArgs
    { configure      = False
    , flavour        = Nothing
    , freeze1        = False
    , freeze2        = False
    , skipDepends    = False
    , unitIdHash     = False
    , bignum         = Nothing
    , bignumCheck    = False
    , progressInfo   = Brief
    , buildRoot      = BuildRoot "_build"
    , testArgs       = defaultTestArgs
    , docsArgs       = defaultDocArgs
    , docTargets     = Set.fromList [minBound..maxBound]
    , prefix         = Nothing
    , completeStg    = Nothing }

-- | These arguments are used by the `test` target.
data TestArgs = TestArgs
    { testKeepFiles  :: Bool
    , testCompiler   :: String
    , testConfigFile :: String
    , testConfigs    :: [String]
    , testJUnit      :: Maybe FilePath
    , testMetricsFile:: Maybe FilePath
    , testOnly       :: [String]
    , testOnlyPerf   :: Bool
    , testSkipPerf   :: Bool
    , testRootDirs   :: [FilePath]
    , testSpeed      :: TestSpeed
    , testSummary    :: Maybe FilePath
    , testVerbosity  :: Maybe String
    , testWays       :: [String]
    , brokenTests    :: [String]
    , testAccept     :: Bool
    , testHasInTreeFiles :: Bool
      -- ^ This is used to signal that we have access to in-tree files like
      -- the rts sources and the haddock stats directory even if the test
      -- compiler is not in-tree
      -- If this flag is set, then those tests will also be run.
      -- This is useful when we want to test the bindist, but we still
      -- have access to the build directory
    }
    deriving (Eq, Show)

-- | Default value for `TestArgs`.
defaultTestArgs :: TestArgs
defaultTestArgs = TestArgs
    { testKeepFiles  = False
    , testCompiler   = "stage2"
    , testConfigFile = "testsuite/config/ghc"
    , testConfigs    = []
    , testJUnit      = Nothing
    , testMetricsFile= Nothing
    , testOnly       = []
    , testOnlyPerf   = False
    , testSkipPerf   = False
    , testRootDirs   = []
    , testSpeed      = TestNormal
    , testSummary    = Nothing
    , testVerbosity  = Nothing
    , testWays       = []
    , brokenTests    = []
    , testAccept     = False
    , testHasInTreeFiles = False
    }

data DocArgs = DocArgs
  { docsBaseUrl :: String
  } deriving (Eq, Show)

defaultDocArgs :: DocArgs
defaultDocArgs = DocArgs { docsBaseUrl = "../%pkg%" }

readConfigure :: Either String (CommandLineArgs -> CommandLineArgs)
readConfigure = Left "hadrian --configure has been deprecated (see #20167). Please run ./boot; ./configure manually"

readFlavour :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readFlavour ms = Right $ \flags -> flags { flavour = lower <$> ms }

readBignum :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readBignum Nothing   = Right id
readBignum (Just ms) = Right $ \flags -> case break (== '-') (lower ms) of
   (backend,"")          -> flags { bignum = Just backend }
   ("check",'-':backend) -> flags { bignum = Just backend, bignumCheck = True }
   _                     -> flags { bignum = Just (lower ms) }

readBuildRoot :: FilePath -> Either String (CommandLineArgs -> CommandLineArgs)
readBuildRoot ms =
    Right $ \flags -> flags { buildRoot = BuildRoot ms }

readFreeze1, readFreeze2, readSkipDepends :: Either String (CommandLineArgs -> CommandLineArgs)
readFreeze1 = Right $ \flags -> flags { freeze1 = True }
readFreeze2 = Right $ \flags -> flags { freeze1 = True, freeze2 = True }
readSkipDepends = Right $ \flags -> flags { skipDepends = True }

readUnitIdHash :: Either String (CommandLineArgs -> CommandLineArgs)
readUnitIdHash = Right $ \flags -> flags { unitIdHash = True }

readProgressInfo :: String -> Either String (CommandLineArgs -> CommandLineArgs)
readProgressInfo ms =
  case lower ms of
    "none"    -> set None
    "brief"   -> set Brief
    "normal"  -> set Normal
    "unicorn" -> set Unicorn
    _         -> Left "Cannot parse progress-info"
  where
    set :: ProgressInfo -> Either String (CommandLineArgs -> CommandLineArgs)
    set flag = Right $ \flags -> flags { progressInfo = flag }

readTestKeepFiles :: Either String (CommandLineArgs -> CommandLineArgs)
readTestKeepFiles = Right $ \flags -> flags { testArgs = (testArgs flags) { testKeepFiles = True } }

readTestAccept :: Either String (CommandLineArgs -> CommandLineArgs)
readTestAccept = Right $ \flags -> flags { testArgs = (testArgs flags) { testAccept = True } }

readTestHasInTreeFiles :: Either String (CommandLineArgs -> CommandLineArgs)
readTestHasInTreeFiles = Right $ \flags -> flags { testArgs = (testArgs flags) { testHasInTreeFiles = True } }

readTestCompiler :: String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestCompiler compiler = Right $ \flags -> flags { testArgs = (testArgs flags) { testCompiler = compiler } }

readTestConfig :: String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestConfig conf = Right $ \flags ->
                        let configs = conf : testConfigs (testArgs flags)
                        in flags { testArgs = (testArgs flags) { testConfigs = configs } }

readTestConfigFile :: String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestConfigFile filepath = Right $ \flags ->  flags { testArgs = (testArgs flags) { testConfigFile = filepath } }

readTestJUnit :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestJUnit filepath = Right $ \flags -> flags { testArgs = (testArgs flags) { testJUnit = filepath } }

readTestMetrics :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestMetrics filepath = Right $ \flags -> flags { testArgs = (testArgs flags) { testMetricsFile = filepath } }

readTestOnly :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestOnly tests = Right $ \flags ->
  flags { testArgs = (testArgs flags) { testOnly = tests'' flags } }

  where tests' = maybe [] words tests
        tests'' flags = testOnly (testArgs flags) ++ 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 } }

readHaddockBaseUrl :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readHaddockBaseUrl base_url = Right $ \flags ->
  flags { docsArgs = (docsArgs flags) { docsBaseUrl = base_url' } }

  where base_url' = fromMaybe "https://hackage.haskell.org/package/%pkg%/docs" base_url


readTestRootDirs :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestRootDirs rootdirs = Right $ \flags ->
  flags { testArgs = (testArgs flags) { testRootDirs = rootdirs'' flags } }

  where rootdirs' = maybe [] (splitOn ":") rootdirs
        rootdirs'' flags = testRootDirs (testArgs flags) ++ rootdirs'

readTestSpeed :: String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestSpeed ms =
  case lower ms of
    "fast"    -> set TestFast
    "slow"    -> set TestSlow
    "normal"  -> set TestNormal
    _         -> Left "Cannot parse test-speed"
  where
    set :: TestSpeed -> Either String (CommandLineArgs -> CommandLineArgs)
    set flag = Right $ \flags -> flags { testArgs = (testArgs flags) {testSpeed = flag} }

readTestSummary :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestSummary filepath = Right $ \flags -> flags { testArgs = (testArgs flags) { testSummary = filepath } }

readTestVerbose :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestVerbose verbose = Right $ \flags -> flags { testArgs = (testArgs flags) { testVerbosity = verbose } }

readTestWay :: String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestWay way =
    Right $ \flags ->
            let newWays = way : testWays (testArgs flags)
            in flags { testArgs = (testArgs flags) {testWays = newWays} }

readBrokenTests :: String -> Either String (CommandLineArgs -> CommandLineArgs)
readBrokenTests tests =
    Right $ \flags ->
            let newTests = words tests ++ brokenTests (testArgs flags)
            in flags { testArgs = (testArgs flags) {brokenTests = newTests} }

readPrefix :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readPrefix ms = Right $ \flags -> flags { prefix = ms }

readCompleteStg :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readCompleteStg ms = Right $ \flags -> flags { completeStg = ms }

readDocsArg :: String -> Either String (CommandLineArgs -> CommandLineArgs)
readDocsArg ms =
  case ms of
    "none"           -> set (const Set.empty)
    "no-haddocks"    -> set (Set.delete Haddocks)
    "no-sphinx-html" -> set (Set.delete SphinxHTML)
    "no-sphinx-pdfs" -> set (Set.delete SphinxPDFs)
    "no-sphinx-man"  -> set (Set.delete SphinxMan)
    "no-sphinx-info" -> set (Set.delete SphinxInfo)
    "no-sphinx"      -> set (Set.delete SphinxHTML
                           . Set.delete SphinxPDFs
                           . Set.delete SphinxMan
                           . Set.delete SphinxInfo)
    _                -> Left "Cannot parse docs argument"

  where
    set :: (DocTargets -> DocTargets) -> Either String (CommandLineArgs -> CommandLineArgs)
    set tweakTargets = Right $ \flags ->
      flags { docTargets = tweakTargets (docTargets flags) }

-- | Standard 'OptDescr' descriptions of Hadrian's command line arguments.
optDescrs :: [OptDescr (Either String (CommandLineArgs -> CommandLineArgs))]
optDescrs =
    [ Option ['c'] ["configure"] (NoArg readConfigure)
      "Deprecated: Run the boot and configure scripts."
    , Option ['o'] ["build-root"] (ReqArg 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 [] ["freeze2"] (NoArg readFreeze2)
      "Freeze Stage2 GHC."
    , Option [] ["hash-unit-ids"] (NoArg readUnitIdHash)
      "Include package hashes in unit ids."
    , Option [] ["skip-depends"] (NoArg readSkipDepends)
      "Skip rebuilding dependency information."
    , Option [] ["bignum"] (OptArg readBignum "BACKEND")
      "Select ghc-bignum backend: native, gmp (default), check-gmp, ffi."
    , Option [] ["progress-info"] (ReqArg readProgressInfo "STYLE")
      "Progress info style (None, Brief, Normal or Unicorn)."
    , Option [] ["docs"] (ReqArg readDocsArg "TARGET")
      "Strip down docs targets (none, no-haddocks, no-sphinx[-{html, pdfs, man}]."
    , Option ['k'] ["keep-test-files"] (NoArg readTestKeepFiles)
      "Keep all the files generated when running the testsuite."
    , Option [] ["test-compiler"] (ReqArg readTestCompiler "TEST_COMPILER")
      "Use given compiler [Default=stage2]."
    , Option [] ["test-config-file"] (ReqArg readTestConfigFile "CONFIG_FILE")
      "configuration file for testsuite. Default=testsuite/config/ghc"
    , Option [] ["config"] (ReqArg 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 [] ["summary-metrics"] (OptArg readTestMetrics "METRICS_FILE")
      "Output testsuite performance metrics summary."
    , 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-root-dirs"] (OptArg readTestRootDirs "DIR1:[DIR2:...:DIRn]")
      "Test root directories to look at (all by default)."
    , Option [] ["test-speed"] (ReqArg 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"] (ReqArg readTestWay "TEST_WAY")
      "only run these ways"
    , Option [] ["broken-test"] (ReqArg readBrokenTests "TEST_NAME")
      "consider these tests to be broken"
    , Option ['a'] ["test-accept"] (NoArg readTestAccept) "Accept new output of tests"
    , Option [] ["test-have-intree-files"] (NoArg readTestHasInTreeFiles) "Run the in-tree tests even with an out of tree compiler"
    , Option [] ["prefix"] (OptArg readPrefix "PATH")
        "Destination path for the bindist 'install' rule"
    , Option [] ["complete-setting"] (OptArg readCompleteStg "SETTING")
        "Setting key to autocomplete, for the 'autocomplete' target."
    , Option [] ["haddock-base-url"] (OptArg readHaddockBaseUrl "BASE_URL")
        "Generate documentation suitable for upload to hackage or for another base URL (for example a local hackage server)."
    ]

-- | A type-indexed map containing Hadrian command line arguments to be passed
-- to Shake via 'shakeExtra'.
cmdLineArgsMap :: IO (Map.HashMap TypeRep Dynamic)
cmdLineArgsMap = do
    xs <- getArgs
    let -- We split the arguments between the ones that look like
        -- "k = v" or "k += v", in cliSettings, and the rest in
        -- optArgs.
        (optsArgs, cliSettings) = partitionKVs xs

        -- We only use the arguments that don't look like setting
        -- updates for parsing Hadrian and Shake flags/options.
        (opts, _, _) = getOpt Permute optDescrs optsArgs
        args = foldl (flip id) defaultCommandLineArgs (rights opts)

        BuildRoot root = buildRoot args
        settingsFile = root -/- "hadrian.settings"

    -- We try to look at <root>/hadrian.settings, and if it exists
    -- we read as many settings as we can from it, combining
    -- them with the ones we got on the command line, in allSettings.
    -- We then insert all those settings in the dynamic map, so that
    -- the 'Settings.flavour' action can look them up and apply
    -- all the relevant updates to the flavour that Hadrian is set
    -- to run with.
    settingsFileExists <- Directory.doesFileExist settingsFile
    fileSettings <-
      if settingsFileExists
        then parseJustKVs . lines <$> readFile settingsFile
        else return []
    let allSettings = cliSettings ++ fileSettings

    return $ insertExtra (progressInfo   args) -- Accessed by Hadrian.Utilities
           $ insertExtra (buildRoot      args) -- Accessed by Hadrian.Utilities
           $ insertExtra (testArgs       args) -- Accessed by Settings.Builders.RunTest
           $ insertExtra (docsArgs       args) -- Accessed by Rules.Documentation
           $ insertExtra allSettings           -- Accessed by Settings
           $ insertExtra args Map.empty

cmdLineArgs :: Action CommandLineArgs
cmdLineArgs = userSetting defaultCommandLineArgs

cmdFlavour :: Action (Maybe String)
cmdFlavour = flavour <$> cmdLineArgs

cmdPrefix :: Action (Maybe String)
cmdPrefix = prefix <$> cmdLineArgs

cmdCompleteSetting :: Action (Maybe String)
cmdCompleteSetting = completeStg <$> cmdLineArgs

lookupBuildRoot :: Map.HashMap TypeRep Dynamic -> BuildRoot
lookupBuildRoot = buildRoot . lookupExtra defaultCommandLineArgs

lookupFreeze1 :: Map.HashMap TypeRep Dynamic -> Bool
lookupFreeze1 = freeze1 . lookupExtra defaultCommandLineArgs

lookupFreeze2 :: Map.HashMap TypeRep Dynamic -> Bool
lookupFreeze2 = freeze2 . lookupExtra defaultCommandLineArgs

lookupSkipDepends :: Map.HashMap TypeRep Dynamic -> Bool
lookupSkipDepends = skipDepends . lookupExtra defaultCommandLineArgs

cmdUnitIdHash :: Action Bool
cmdUnitIdHash = unitIdHash <$> cmdLineArgs

cmdBignum :: Action (Maybe String)
cmdBignum = bignum <$> cmdLineArgs

cmdBignumCheck :: Action Bool
cmdBignumCheck = bignumCheck <$> cmdLineArgs

cmdProgressInfo :: Action ProgressInfo
cmdProgressInfo = progressInfo <$> cmdLineArgs

cmdDocsArgs :: Action DocTargets
cmdDocsArgs = docTargets <$> cmdLineArgs