CmdLineFlag.hs 4.26 KB
Newer Older
Andrey Mokhov's avatar
Andrey Mokhov committed
1
module CmdLineFlag (
Andrey Mokhov's avatar
Andrey Mokhov committed
2
3
4
    putCmdLineFlags, cmdFlags, cmdBuildHaddock, cmdFlavour, cmdProgressColour,
    ProgressColour (..), cmdProgressInfo, ProgressInfo (..), cmdSkipConfigure,
    cmdSplitObjects
Andrey Mokhov's avatar
Andrey Mokhov committed
5
6
    ) where

7
import Data.IORef
8
import Data.List.Extra
Andrey Mokhov's avatar
Andrey Mokhov committed
9
import System.Console.GetOpt
10
import System.IO.Unsafe
Andrey Mokhov's avatar
Andrey Mokhov committed
11
12
13
14
15

-- | 'CmdLineFlag.Untracked' is a collection of flags that can be passed via the
-- command line. These flags are not tracked, that is they do not force any
-- build rules to be rurun.
data Untracked = Untracked
16
    { buildHaddock   :: Bool
Andrey Mokhov's avatar
Andrey Mokhov committed
17
    , flavour        :: Maybe String
18
19
20
21
    , progressColour :: ProgressColour
    , progressInfo   :: ProgressInfo
    , skipConfigure  :: Bool
    , splitObjects   :: Bool }
Andrey Mokhov's avatar
Andrey Mokhov committed
22
23
    deriving (Eq, Show)

24
25
data ProgressColour = Never | Auto | Always deriving (Eq, Show)
data ProgressInfo   = None | Brief | Normal | Unicorn deriving (Eq, Show)
26

Andrey Mokhov's avatar
Andrey Mokhov committed
27
28
29
-- | Default values for 'CmdLineFlag.Untracked'.
defaultUntracked :: Untracked
defaultUntracked = Untracked
30
    { buildHaddock   = False
Andrey Mokhov's avatar
Andrey Mokhov committed
31
    , flavour        = Nothing
32
33
34
35
    , progressColour = Auto
    , progressInfo   = Normal
    , skipConfigure  = False
    , splitObjects   = False }
36

37
38
39
readBuildHaddock :: Either String (Untracked -> Untracked)
readBuildHaddock = Right $ \flags -> flags { buildHaddock = True }

40
readFlavour :: Maybe String -> Either String (Untracked -> Untracked)
Andrey Mokhov's avatar
Andrey Mokhov committed
41
readFlavour ms = Right $ \flags -> flags { flavour = ms }
Andrey Mokhov's avatar
Andrey Mokhov committed
42

43
44
45
46
47
48
49
50
51
52
53
54
readProgressColour :: Maybe String -> Either String (Untracked -> Untracked)
readProgressColour ms =
    maybe (Left "Cannot parse progress-colour") (Right . set) (go =<< lower <$> ms)
  where
    go :: String -> Maybe ProgressColour
    go "never"   = Just Never
    go "auto"    = Just Auto
    go "always"  = Just Always
    go _         = Nothing
    set :: ProgressColour -> Untracked -> Untracked
    set flag flags = flags { progressColour = flag }

Andrey Mokhov's avatar
Andrey Mokhov committed
55
56
readProgressInfo :: Maybe String -> Either String (Untracked -> Untracked)
readProgressInfo ms =
57
    maybe (Left "Cannot parse progress-info") (Right . set) (go =<< lower <$> ms)
Andrey Mokhov's avatar
Andrey Mokhov committed
58
59
60
61
62
63
  where
    go :: String -> Maybe ProgressInfo
    go "none"    = Just None
    go "brief"   = Just Brief
    go "normal"  = Just Normal
    go "unicorn" = Just Unicorn
64
    go _         = Nothing
65
66
67
    set :: ProgressInfo -> Untracked -> Untracked
    set flag flags = flags { progressInfo = flag }

68
69
readSkipConfigure :: Either String (Untracked -> Untracked)
readSkipConfigure = Right $ \flags -> flags { skipConfigure = True }
70

71
72
readSplitObjects :: Either String (Untracked -> Untracked)
readSplitObjects = Right $ \flags -> flags { splitObjects = True }
Andrey Mokhov's avatar
Andrey Mokhov committed
73

74
75
cmdFlags :: [OptDescr (Either String (Untracked -> Untracked))]
cmdFlags =
76
    [ Option [] ["flavour"] (OptArg readFlavour "FLAVOUR")
77
      "Build flavour (default, quick or quickest)."
78
79
    , Option [] ["haddock"] (NoArg readBuildHaddock)
      "Generate Haddock documentation."
80
81
    , Option [] ["progress-colour"] (OptArg readProgressColour "MODE")
      "Use colours in progress info (Never, Auto or Always)."
82
    , Option [] ["progress-info"] (OptArg readProgressInfo "STYLE")
83
      "Progress info style (None, Brief, Normal or Unicorn)."
84
85
    , Option [] ["skip-configure"] (NoArg readSkipConfigure)
      "Skip the boot and configure scripts (if you want to run them manually)."
86
87
    , Option [] ["split-objects"] (NoArg readSplitObjects)
      "Generate split objects (requires a full clean rebuild)." ]
Andrey Mokhov's avatar
Andrey Mokhov committed
88

89
-- TODO: Avoid unsafePerformIO by using shakeExtra.
Andrey Mokhov's avatar
Andrey Mokhov committed
90
91
92
93
94
{-# NOINLINE cmdLineFlags #-}
cmdLineFlags :: IORef Untracked
cmdLineFlags = unsafePerformIO $ newIORef defaultUntracked

putCmdLineFlags :: [Untracked -> Untracked] -> IO ()
95
putCmdLineFlags flags = modifyIORef cmdLineFlags (\f -> foldl (flip id) f flags)
Andrey Mokhov's avatar
Andrey Mokhov committed
96

97
-- TODO: Avoid unsafePerformIO by using shakeExtra.
98
99
100
101
{-# NOINLINE getCmdLineFlags #-}
getCmdLineFlags :: Untracked
getCmdLineFlags = unsafePerformIO $ readIORef cmdLineFlags

102
103
104
cmdBuildHaddock :: Bool
cmdBuildHaddock = buildHaddock getCmdLineFlags

Andrey Mokhov's avatar
Andrey Mokhov committed
105
cmdFlavour :: Maybe String
106
107
cmdFlavour = flavour getCmdLineFlags

108
109
110
cmdProgressColour :: ProgressColour
cmdProgressColour = progressColour getCmdLineFlags

111
112
cmdProgressInfo :: ProgressInfo
cmdProgressInfo = progressInfo getCmdLineFlags
Andrey Mokhov's avatar
Andrey Mokhov committed
113

114
115
cmdSplitObjects :: Bool
cmdSplitObjects = splitObjects getCmdLineFlags
116
117
118

cmdSkipConfigure :: Bool
cmdSkipConfigure = skipConfigure getCmdLineFlags