Commit c50e0dc4 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Refactor CmdLineFlag.hs.

parent 30883f8d
......@@ -19,12 +19,12 @@ executable ghc-shake
hs-source-dirs: src
other-modules: Base
, Builder
, CmdLineFlag
, Expression
, GHC
, Oracles
, Oracles.ArgsHash
, Oracles.Config
, Oracles.Config.CmdLineFlag
, Oracles.Config.Flag
, Oracles.Config.Setting
, Oracles.Dependencies
......
module CmdLineFlag (
putCmdLineFlags, flags, cmdProgressInfo, ProgressInfo (..)
) 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
{ progressInfo :: ProgressInfo }
deriving (Eq, Show)
-- | Default values for 'CmdLineFlag.Untracked'.
defaultUntracked :: Untracked
defaultUntracked = Untracked
{ progressInfo = Normal }
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
mkClosure flag opts = opts { progressInfo = flag }
flags :: [OptDescr (Either String (Untracked -> Untracked))]
flags = [ Option [] ["progress-info"] (OptArg readProgressInfo "")
"Progress Info Style (None, Brief, Normal, or Unicorn)" ]
-- TODO: Get rid of unsafePerformIO by using shakeExtra.
{-# NOINLINE cmdLineFlags #-}
cmdLineFlags :: IORef Untracked
cmdLineFlags = unsafePerformIO $ newIORef defaultUntracked
putCmdLineFlags :: [Untracked -> Untracked] -> IO ()
putCmdLineFlags opts = modifyIORef cmdLineFlags (\o -> foldl (flip id) o opts)
getCmdLineFlags :: Action Untracked
getCmdLineFlags = liftIO $ readIORef cmdLineFlags
cmdProgressInfo :: Action ProgressInfo
cmdProgressInfo = progressInfo <$> getCmdLineFlags
......@@ -3,6 +3,7 @@ module Main (main) where
import Development.Shake
import qualified Base
import CmdLineFlag
import qualified Rules
import qualified Rules.Cabal
import qualified Rules.Config
......@@ -12,13 +13,13 @@ import qualified Rules.Libffi
import qualified Rules.Oracles
import qualified Rules.Perl
import qualified Test
import Oracles.Config.CmdLineFlag (putOptions, flags)
main :: IO ()
main = shakeArgsWith options flags $ \cmdLineFlags targets -> do
putOptions cmdLineFlags
return . Just $ if null targets then rules else want targets
>> withoutActions rules
putCmdLineFlags cmdLineFlags
return . Just $ if null targets
then rules
else want targets >> withoutActions rules
where
rules :: Rules ()
rules = mconcat
......
module Oracles.Config.CmdLineFlag (putOptions, buildInfo, flags, BuildInfoFlag(..)) where
import Data.Char (toLower)
import System.Console.GetOpt
import System.IO.Unsafe (unsafePerformIO)
import Data.IORef
-- Flags
data BuildInfoFlag = None | Brief | Normal | Unicorn deriving (Eq, Show)
data CmdLineOptions = CmdLineOptions {
flagBuildInfo :: BuildInfoFlag
} deriving (Eq, Show)
defaultCmdLineOptions :: CmdLineOptions
defaultCmdLineOptions = CmdLineOptions {
flagBuildInfo = Normal
}
readBuildInfoFlag :: Maybe String -> Either String (CmdLineOptions -> CmdLineOptions)
readBuildInfoFlag ms =
maybe (Left "no parse") (Right . mkClosure)
(go =<< fmap (map toLower) ms)
where
go :: String -> Maybe BuildInfoFlag
go "none" = Just None
go "brief" = Just Brief
go "normal" = Just Normal
go "unicorn" = Just Unicorn
go _ = Nothing -- Left "no parse"
mkClosure :: BuildInfoFlag -> CmdLineOptions -> CmdLineOptions
mkClosure flag opts = opts { flagBuildInfo = flag }
flags :: [OptDescr (Either String (CmdLineOptions -> CmdLineOptions))]
flags = [Option [] ["progress-info"] (OptArg readBuildInfoFlag "") "Build Info Style (None, Brief, Normal, or Unicorn)"]
-- IO -- We use IO here instead of Oracles, as Oracles form part of shakes cache
-- hence, changing command line arguments, would cause a full rebuild. And we
-- likely do *not* want to rebuild everything if only the @--build-info@ flag
-- was changed.
{-# NOINLINE cmdLineOpts #-}
cmdLineOpts :: IORef CmdLineOptions
cmdLineOpts = unsafePerformIO $ newIORef defaultCmdLineOptions
putOptions :: [CmdLineOptions -> CmdLineOptions] -> IO ()
putOptions opts = modifyIORef cmdLineOpts (\o -> foldl (flip id) o opts)
{-# NOINLINE getOptions #-}
getOptions :: CmdLineOptions
getOptions = unsafePerformIO $ readIORef cmdLineOpts
buildInfo :: BuildInfoFlag
buildInfo = flagBuildInfo getOptions
......@@ -9,10 +9,10 @@ import qualified System.Directory as IO
import System.Console.ANSI
import Base
import CmdLineFlag
import Expression
import Oracles
import Oracles.ArgsHash
import Oracles.Config.CmdLineFlag (buildInfo, BuildInfoFlag(..))
import Settings
import Settings.Args
import Settings.Builders.Ar
......@@ -67,7 +67,7 @@ captureStdout target path argList = do
copyFile :: FilePath -> FilePath -> Action ()
copyFile source target = do
putProgressInfo $ renderAction "Copy file" source target
putProgressInfo =<< renderAction "Copy file" source target
copyFileChanged source target
createDirectory :: FilePath -> Action ()
......@@ -83,7 +83,7 @@ removeDirectory dir = do
-- Note, the source directory is untracked
moveDirectory :: FilePath -> FilePath -> Action ()
moveDirectory source target = do
putProgressInfo $ renderAction "Move directory" source target
putProgressInfo =<< renderAction "Move directory" source target
liftIO $ IO.renameDirectory source target
-- Transform a given file by applying a function to its contents
......@@ -145,7 +145,7 @@ makeExecutable file = do
-- Print out key information about the command being executed
putInfo :: Target.Target -> Action ()
putInfo Target.Target {..} = putProgressInfo $ renderAction
putInfo Target.Target {..} = putProgressInfo =<< renderAction
("Run " ++ show builder ++ " (" ++ stageInfo
++ "package = " ++ pkgNameString package ++ wayInfo ++ ")")
(digest inputs)
......@@ -157,22 +157,25 @@ putInfo Target.Target {..} = putProgressInfo $ renderAction
digest [x] = x
digest (x:xs) = x ++ " (and " ++ show (length xs) ++ " more)"
-- | Switch for @putBuild@ filtered through @buildInfo@
-- | Switch for @putBuild@ filtered through @progressInfo@
putProgressInfo :: String -> Action ()
putProgressInfo s | buildInfo /= None = putBuild s
putProgressInfo _ = pure ()
putProgressInfo msg = do
skip <- (None ==) <$> cmdProgressInfo
unless skip $ putBuild msg
-- | Render an action.
renderAction :: String -> String -> String -> String
renderAction what input output = case buildInfo of
Normal -> renderBox [ what
, " input: " ++ input
, " => output: " ++ output ]
Brief -> "> " ++ what ++ ": " ++ input ++ " => " ++ output
Unicorn -> renderUnicorn [ what
renderAction :: String -> String -> String -> Action String
renderAction what input output = do
style <- cmdProgressInfo
return $ case style of
Normal -> renderBox [ what
, " input: " ++ input
, " => output: " ++ output ]
None -> ""
Brief -> "| " ++ what ++ ": " ++ input ++ " => " ++ output
Unicorn -> renderUnicorn [ what
, " input: " ++ input
, " => output: " ++ output ]
None -> ""
-- | Render the successful build of a program
renderProgram :: String -> String -> String -> String
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment