Refactor CmdLineFlag.hs.

shaking-up-ghc.cabal

@@ -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

src/CmdLineFlag.hs

+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

src/Main.hs

@@ -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

src/Oracles/Config/CmdLineFlag.hs

-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

src/Rules/Actions.hs

@@ -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