CmdLineFlag.hs 2.29 KB
Newer Older
Andrey Mokhov's avatar
Andrey Mokhov committed
1
module CmdLineFlag (
2
    putCmdLineFlags, flags, cmdProgressInfo, ProgressInfo (..), cmdSplitObjects
Andrey Mokhov's avatar
Andrey Mokhov committed
3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18
    ) where

import Base
import Data.Char (toLower)
import System.Console.GetOpt

import Data.IORef
import System.IO.Unsafe (unsafePerformIO)

-- Command line flags
data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show)

-- | '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
19 20
    { progressInfo :: ProgressInfo
    , splitObjects :: Bool }
Andrey Mokhov's avatar
Andrey Mokhov committed
21 22 23 24 25
    deriving (Eq, Show)

-- | Default values for 'CmdLineFlag.Untracked'.
defaultUntracked :: Untracked
defaultUntracked = Untracked
26 27
    { progressInfo = Normal
    , splitObjects = False }
Andrey Mokhov's avatar
Andrey Mokhov committed
28 29 30 31 32 33 34 35 36 37 38 39

readProgressInfo :: Maybe String -> Either String (Untracked -> Untracked)
readProgressInfo ms =
    maybe (Left "no parse") (Right . mkClosure) (go =<< fmap (map toLower) ms)
  where
    go :: String -> Maybe ProgressInfo
    go "none"    = Just None
    go "brief"   = Just Brief
    go "normal"  = Just Normal
    go "unicorn" = Just Unicorn
    go _         = Nothing -- Left "no parse"
    mkClosure :: ProgressInfo -> Untracked -> Untracked
40 41 42 43
    mkClosure flag flags = flags { progressInfo = flag }

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

flags :: [OptDescr (Either String (Untracked -> Untracked))]
flags = [ Option [] ["progress-info"] (OptArg readProgressInfo "")
47 48 49
          "Progress Info Style (None, Brief, Normal, or Unicorn)"
        , Option [] ["split-objects"] (NoArg readSplitObjects)
          "Generate split objects (requires a full clean rebuild)." ]
Andrey Mokhov's avatar
Andrey Mokhov committed
50 51 52 53 54 55 56

-- TODO: Get rid of unsafePerformIO by using shakeExtra.
{-# NOINLINE cmdLineFlags #-}
cmdLineFlags :: IORef Untracked
cmdLineFlags = unsafePerformIO $ newIORef defaultUntracked

putCmdLineFlags :: [Untracked -> Untracked] -> IO ()
57
putCmdLineFlags flags = modifyIORef cmdLineFlags (\f -> foldl (flip id) f flags)
Andrey Mokhov's avatar
Andrey Mokhov committed
58 59 60 61 62 63

getCmdLineFlags :: Action Untracked
getCmdLineFlags = liftIO $ readIORef cmdLineFlags

cmdProgressInfo :: Action ProgressInfo
cmdProgressInfo = progressInfo <$> getCmdLineFlags
64 65 66

cmdSplitObjects :: Action Bool
cmdSplitObjects = splitObjects <$> getCmdLineFlags