Fix compile error on GHC 8.2+
[hadrian.git] / src / CommandLine.hs
1 module CommandLine (
2 optDescrs, cmdLineArgsMap, cmdBuildHaddock, cmdFlavour, cmdIntegerSimple,
3 cmdProgressColour, cmdProgressInfo, cmdSkipConfigure, cmdSplitObjects
4 ) where
5
6 import Data.Dynamic (Dynamic)
7 import Data.Either
8 import qualified Data.HashMap.Strict as Map
9 import Data.List.Extra
10 import Data.Typeable (TypeRep)
11 import Development.Shake hiding (Normal)
12 import Hadrian.Utilities
13 import System.Console.GetOpt
14 import System.Environment
15
16 -- | All arguments that can be passed to Hadrian via the command line.
17 data CommandLineArgs = CommandLineArgs
18 { buildHaddock :: Bool
19 , flavour :: Maybe String
20 , integerSimple :: Bool
21 , progressColour :: UseColour
22 , progressInfo :: ProgressInfo
23 , skipConfigure :: Bool
24 , splitObjects :: Bool }
25 deriving (Eq, Show)
26
27 -- | Default values for 'CommandLineArgs'.
28 defaultCommandLineArgs :: CommandLineArgs
29 defaultCommandLineArgs = CommandLineArgs
30 { buildHaddock = False
31 , flavour = Nothing
32 , integerSimple = False
33 , progressColour = Auto
34 , progressInfo = Normal
35 , skipConfigure = False
36 , splitObjects = False }
37
38 readBuildHaddock :: Either String (CommandLineArgs -> CommandLineArgs)
39 readBuildHaddock = Right $ \flags -> flags { buildHaddock = True }
40
41 readFlavour :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
42 readFlavour ms = Right $ \flags -> flags { flavour = lower <$> ms }
43
44 readIntegerSimple :: Either String (CommandLineArgs -> CommandLineArgs)
45 readIntegerSimple = Right $ \flags -> flags { integerSimple = True }
46
47 readProgressColour :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
48 readProgressColour ms =
49 maybe (Left "Cannot parse progress-colour") (Right . set) (go =<< lower <$> ms)
50 where
51 go :: String -> Maybe UseColour
52 go "never" = Just Never
53 go "auto" = Just Auto
54 go "always" = Just Always
55 go _ = Nothing
56 set :: UseColour -> CommandLineArgs -> CommandLineArgs
57 set flag flags = flags { progressColour = flag }
58
59 readProgressInfo :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
60 readProgressInfo ms =
61 maybe (Left "Cannot parse progress-info") (Right . set) (go =<< lower <$> ms)
62 where
63 go :: String -> Maybe ProgressInfo
64 go "none" = Just None
65 go "brief" = Just Brief
66 go "normal" = Just Normal
67 go "unicorn" = Just Unicorn
68 go _ = Nothing
69 set :: ProgressInfo -> CommandLineArgs -> CommandLineArgs
70 set flag flags = flags { progressInfo = flag }
71
72 readSkipConfigure :: Either String (CommandLineArgs -> CommandLineArgs)
73 readSkipConfigure = Right $ \flags -> flags { skipConfigure = True }
74
75 readSplitObjects :: Either String (CommandLineArgs -> CommandLineArgs)
76 readSplitObjects = Right $ \flags -> flags { splitObjects = True }
77
78 -- | Standard 'OptDescr' descriptions of Hadrian's command line arguments.
79 optDescrs :: [OptDescr (Either String (CommandLineArgs -> CommandLineArgs))]
80 optDescrs =
81 [ Option [] ["flavour"] (OptArg readFlavour "FLAVOUR")
82 "Build flavour (Default, Devel1, Devel2, Perf, Prof, Quick or Quickest)."
83 , Option [] ["haddock"] (NoArg readBuildHaddock)
84 "Generate Haddock documentation."
85 , Option [] ["integer-simple"] (NoArg readIntegerSimple)
86 "Build GHC with integer-simple library."
87 , Option [] ["progress-colour"] (OptArg readProgressColour "MODE")
88 "Use colours in progress info (Never, Auto or Always)."
89 , Option [] ["progress-info"] (OptArg readProgressInfo "STYLE")
90 "Progress info style (None, Brief, Normal or Unicorn)."
91 , Option [] ["skip-configure"] (NoArg readSkipConfigure)
92 "Skip the boot and configure scripts (if you want to run them manually)."
93 , Option [] ["split-objects"] (NoArg readSplitObjects)
94 "Generate split objects (requires a full clean rebuild)." ]
95
96 -- | A type-indexed map containing Hadrian command line arguments to be passed
97 -- to Shake via 'shakeExtra'.
98 cmdLineArgsMap :: IO (Map.HashMap TypeRep Dynamic)
99 cmdLineArgsMap = do
100 (opts, _, _) <- getOpt Permute optDescrs <$> getArgs
101 let args = foldl (flip id) defaultCommandLineArgs (rights opts)
102 return $ insertExtra (progressColour args) -- Accessed by Hadrian.Utilities
103 $ insertExtra (progressInfo args) -- Accessed by Hadrian.Utilities
104 $ insertExtra args Map.empty
105
106 cmdLineArgs :: Action CommandLineArgs
107 cmdLineArgs = userSetting defaultCommandLineArgs
108
109 cmdBuildHaddock :: Action Bool
110 cmdBuildHaddock = buildHaddock <$> cmdLineArgs
111
112 cmdFlavour :: Action (Maybe String)
113 cmdFlavour = flavour <$> cmdLineArgs
114
115 cmdIntegerSimple :: Action Bool
116 cmdIntegerSimple = integerSimple <$> cmdLineArgs
117
118 cmdProgressColour :: Action UseColour
119 cmdProgressColour = progressColour <$> cmdLineArgs
120
121 cmdProgressInfo :: Action ProgressInfo
122 cmdProgressInfo = progressInfo <$> cmdLineArgs
123
124 cmdSkipConfigure :: Action Bool
125 cmdSkipConfigure = skipConfigure <$> cmdLineArgs
126
127 cmdSplitObjects :: Action Bool
128 cmdSplitObjects = splitObjects <$> cmdLineArgs
129