Commit f794e736 authored by Moritz Angermann's avatar Moritz Angermann
Browse files

Replace Oracle with IO Ref

parent 5dd8bbb0
{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- for Development.Shake.parallel
{-# LANGUAGE LambdaCase #-}
module Base (
-- * General utilities
......@@ -143,8 +142,8 @@ putError msg = do
error $ "GHC build system error: " ++ msg
-- | Render an action.
renderAction :: String -> String -> String -> Action String
renderAction what input output = buildInfo >>= return . \case
renderAction :: String -> String -> String -> String
renderAction what input output = case buildInfo of
Normal -> renderBox [ what
, " input:" ++ input
, " => output:" ++ output ]
......@@ -156,16 +155,16 @@ renderAction what input output = buildInfo >>= return . \case
None -> ""
-- | Render the successful build of a program
renderProgram :: String -> String -> String -> Action String
renderProgram name bin synopsis = return $ renderBox [ "Successfully built program " ++ name
, "Executable: " ++ bin
, "Program synopsis: " ++ synopsis ++ "."]
renderProgram :: String -> String -> String -> String
renderProgram name bin synopsis = renderBox [ "Successfully built program " ++ name
, "Executable: " ++ bin
, "Program synopsis: " ++ synopsis ++ "."]
-- | Render the successful built of a library
renderLibrary :: String -> String -> String -> Action String
renderLibrary name lib synopsis = return $ renderBox [ "Successfully built library " ++ name
, "Library: " ++ lib
, "Library synopsis: " ++ synopsis ++ "."]
renderLibrary :: String -> String -> String -> String
renderLibrary name lib synopsis = renderBox [ "Successfully built library " ++ name
, "Library: " ++ lib
, "Library synopsis: " ++ synopsis ++ "."]
-- | Render the given set of lines next to our favorit unicorn Robert.
renderPony :: [String] -> String
......
......@@ -12,12 +12,12 @@ import qualified Rules.Libffi
import qualified Rules.Oracles
import qualified Rules.Perl
import qualified Test
import Oracles.Config.CmdLineFlag (cmdLineOracle, flags)
import Oracles.Config.CmdLineFlag (putOptions, flags)
main :: IO ()
main = shakeArgsWith options flags $ \cmdLineFlags targets ->
return . Just $ cmdLineOracle cmdLineFlags
>> if null targets then rules else want targets
main = shakeArgsWith options flags $ \cmdLineFlags targets -> do
putOptions cmdLineFlags
return . Just $ if null targets then rules else want targets
>> withoutActions rules
where
rules :: Rules ()
......
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Oracles.Config.CmdLineFlag (buildInfo, cmdLineOracle, flags, BuildInfoFlag(..)) where
module Oracles.Config.CmdLineFlag (putOptions, buildInfo, flags, BuildInfoFlag(..)) where
import GHC.Generics (Generic)
import Development.Shake hiding (Normal)
import Development.Shake.Classes
import Data.Char (toLower)
import System.Console.GetOpt
-- Flags
import System.IO.Unsafe (unsafePerformIO)
import Data.IORef
data BuildInfoFlag = Normal | Brief | Pony | Dot | None deriving (Eq, Show, Generic)
-- Flags
instance Hashable BuildInfoFlag
instance NFData BuildInfoFlag
instance Binary BuildInfoFlag
data BuildInfoFlag = Normal | Brief | Pony | Dot | None deriving (Eq, Show)
data CmdLineOptions = CmdLineOptions {
flagBuildInfo :: BuildInfoFlag
} deriving (Eq, Show, Generic)
} deriving (Eq, Show)
defaultCmdLineOptions :: CmdLineOptions
defaultCmdLineOptions = CmdLineOptions {
flagBuildInfo = Normal
}
instance Hashable CmdLineOptions
instance NFData CmdLineOptions
instance Binary CmdLineOptions
readBuildInfoFlag :: Maybe String -> Either String (CmdLineOptions -> CmdLineOptions)
readBuildInfoFlag ms =
maybe (Left "no parse") (Right . mkClosure)
......@@ -47,18 +37,20 @@ readBuildInfoFlag ms =
flags :: [OptDescr (Either String (CmdLineOptions -> CmdLineOptions))]
flags = [Option [] ["build-info"] (OptArg readBuildInfoFlag "") "Build Info Style (Normal, Brief, Pony, Dot, or None)"]
-- Oracles
-- 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
newtype CmdLineFlags = CmdLineFlags ()
deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
putOptions :: [CmdLineOptions -> CmdLineOptions] -> IO ()
putOptions opts = modifyIORef cmdLineOpts (\o -> foldl (flip id) o opts)
buildInfo :: Action BuildInfoFlag
buildInfo = do
opts <- askOracle $ CmdLineFlags ()
return $ flagBuildInfo opts
{-# NOINLINE getOptions #-}
getOptions :: CmdLineOptions
getOptions = unsafePerformIO $ readIORef cmdLineOpts
cmdLineOracle :: [CmdLineOptions -> CmdLineOptions] -> Rules ()
cmdLineOracle opts = do
cache <- newCache $ \_ -> return $ foldl (flip id) defaultCmdLineOptions opts
_ <- addOracle $ \CmdLineFlags{} -> cache ()
return ()
buildInfo :: BuildInfoFlag
buildInfo = flagBuildInfo getOptions
......@@ -64,7 +64,7 @@ captureStdout target path argList = do
copyFile :: FilePath -> FilePath -> Action ()
copyFile source target = do
putBuild =<< renderAction "Copy file" source target
putBuild $ renderAction "Copy file" source target
copyFileChanged source target
createDirectory :: FilePath -> Action ()
......@@ -75,7 +75,7 @@ createDirectory dir = do
-- Note, the source directory is untracked
moveDirectory :: FilePath -> FilePath -> Action ()
moveDirectory source target = do
putBuild =<< renderAction "Move directory" source target
putBuild $ renderAction "Move directory" source target
liftIO $ IO.renameDirectory source target
-- Transform a given file by applying a function to its contents
......@@ -118,7 +118,7 @@ makeExecutable file = do
-- Print out key information about the command being executed
putInfo :: Target.Target -> Action ()
putInfo (Target.Target {..}) = putBuild =<< renderAction
putInfo Target.Target {..} = putBuild $ renderAction
("Run " ++ show builder ++ " (" ++ stageInfo
++ "package = " ++ pkgNameString package ++ wayInfo ++ ")")
(digest inputs)
......
......@@ -52,7 +52,7 @@ buildPackageLibrary _ target @ (PartialTarget stage pkg) = do
else build $ fullTarget target Ar objs [a]
synopsis <- interpretPartial target $ getPkgData Synopsis
unless isLib0 . putSuccess =<< renderLibrary
unless isLib0 . putSuccess $ renderLibrary
("'" ++ pkgNameString pkg ++ "' (" ++ show stage ++ ", way "++ show way ++ ").")
a
(dropWhileEnd isPunctuation synopsis)
......
......@@ -92,7 +92,7 @@ buildBinary target @ (PartialTarget stage pkg) bin = do
libFile <- pkgLibraryFile libStage dep compId way
lib0File <- pkgLibraryFile libStage dep (compId ++ "-0") way
dll0 <- needDll0 libStage dep
return $ [ libFile ] ++ [ lib0File | dll0 ]
return $ libFile : [ lib0File | dll0 ]
return $ libFiles ++ [ pkgGhciLibraryFile libStage dep compId | ghci ]
let binDeps = if pkg == ghcCabal && stage == Stage0
then [ pkgPath pkg -/- src <.> "hs" | src <- hSrcs ]
......@@ -100,7 +100,7 @@ buildBinary target @ (PartialTarget stage pkg) bin = do
need $ binDeps ++ libs
build $ fullTargetWithWay target (Ghc stage) vanilla binDeps [bin]
synopsis <- interpretPartial target $ getPkgData Synopsis
putSuccess =<< renderProgram
putSuccess $ renderProgram
("'" ++ pkgNameString pkg ++ "' (" ++ show stage ++ ").")
bin
(dropWhileEnd isPunctuation synopsis)
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