{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable, ViewPatterns #-} {-# LANGUAGE ExistentialQuantification, DeriveFunctor, RecordWildCards, FlexibleInstances #-} module Development.Shake.Internal.Core.Types( BuiltinRun, BuiltinLint, BuiltinIdentity, RunMode(..), RunResult(..), RunChanged(..), UserRule(..), UserRuleVersioned(..), userRuleSize, BuiltinRule(..), Global(..), Local(..), Action(..), runAction, addDiscount, newLocal, localClearMutable, localMergeMutable, Traces, newTrace, addTrace, flattenTraces, DependsList, flattenDepends, enumerateDepends, addDepends, addDepends1, newDepends, Stack, Step(..), Result(..), Database, DatabasePoly(..), Depends(..), Status(..), Trace(..), BS_Store, getResult, exceptionStack, statusType, addStack, addCallStack, incStep, emptyStack, topStack, showTopStack, stepKey, StepKey(..), rootKey, Root(..) ) where import Control.Monad.IO.Class import Control.DeepSeq import Foreign.Storable import Data.Word import Data.Typeable import General.Binary import Data.Maybe import Data.List import Control.Exception import General.Extra import Development.Shake.Internal.Core.Database import Development.Shake.Internal.History.Shared import Development.Shake.Internal.History.Cloud import Development.Shake.Internal.History.Types import Development.Shake.Internal.Errors import qualified General.TypeMap as TMap import Data.IORef import qualified Data.ByteString.Char8 as BS import Numeric.Extra import System.Time.Extra import General.Intern(Id) import qualified Data.HashSet as Set import qualified Data.HashMap.Strict as Map import Data.Tuple.Extra import General.Pool import Development.Shake.Internal.Core.Monad import Development.Shake.Internal.Value import Development.Shake.Internal.Options import Development.Shake.Classes import Data.Semigroup import General.Cleanup import Control.Monad.Fail import Prelude --------------------------------------------------------------------- -- UNDERLYING DATA TYPE -- | The 'Action' monad, use 'liftIO' to raise 'IO' actions into it, and 'Development.Shake.need' to execute files. -- Action values are used by 'addUserRule' and 'action'. The 'Action' monad tracks the dependencies of a rule. -- To raise an exception call 'error', 'fail' or @'liftIO' . 'throwIO'@. newtype Action a = Action {Action a -> RAW ([String], [Key]) [Value] Global Local a fromAction :: RAW ([String],[Key]) [Value] Global Local a} deriving (a -> Action b -> Action a (a -> b) -> Action a -> Action b (forall a b. (a -> b) -> Action a -> Action b) -> (forall a b. a -> Action b -> Action a) -> Functor Action forall a b. a -> Action b -> Action a forall a b. (a -> b) -> Action a -> Action b forall (f :: * -> *). (forall a b. (a -> b) -> f a -> f b) -> (forall a b. a -> f b -> f a) -> Functor f <$ :: a -> Action b -> Action a $c<$ :: forall a b. a -> Action b -> Action a fmap :: (a -> b) -> Action a -> Action b $cfmap :: forall a b. (a -> b) -> Action a -> Action b Functor, Functor Action a -> Action a Functor Action -> (forall a. a -> Action a) -> (forall a b. Action (a -> b) -> Action a -> Action b) -> (forall a b c. (a -> b -> c) -> Action a -> Action b -> Action c) -> (forall a b. Action a -> Action b -> Action b) -> (forall a b. Action a -> Action b -> Action a) -> Applicative Action Action a -> Action b -> Action b Action a -> Action b -> Action a Action (a -> b) -> Action a -> Action b (a -> b -> c) -> Action a -> Action b -> Action c forall a. a -> Action a forall a b. Action a -> Action b -> Action a forall a b. Action a -> Action b -> Action b forall a b. Action (a -> b) -> Action a -> Action b forall a b c. (a -> b -> c) -> Action a -> Action b -> Action c forall (f :: * -> *). Functor f -> (forall a. a -> f a) -> (forall a b. f (a -> b) -> f a -> f b) -> (forall a b c. (a -> b -> c) -> f a -> f b -> f c) -> (forall a b. f a -> f b -> f b) -> (forall a b. f a -> f b -> f a) -> Applicative f <* :: Action a -> Action b -> Action a $c<* :: forall a b. Action a -> Action b -> Action a *> :: Action a -> Action b -> Action b $c*> :: forall a b. Action a -> Action b -> Action b liftA2 :: (a -> b -> c) -> Action a -> Action b -> Action c $cliftA2 :: forall a b c. (a -> b -> c) -> Action a -> Action b -> Action c <*> :: Action (a -> b) -> Action a -> Action b $c<*> :: forall a b. Action (a -> b) -> Action a -> Action b pure :: a -> Action a $cpure :: forall a. a -> Action a $cp1Applicative :: Functor Action Applicative, Applicative Action a -> Action a Applicative Action -> (forall a b. Action a -> (a -> Action b) -> Action b) -> (forall a b. Action a -> Action b -> Action b) -> (forall a. a -> Action a) -> Monad Action Action a -> (a -> Action b) -> Action b Action a -> Action b -> Action b forall a. a -> Action a forall a b. Action a -> Action b -> Action b forall a b. Action a -> (a -> Action b) -> Action b forall (m :: * -> *). Applicative m -> (forall a b. m a -> (a -> m b) -> m b) -> (forall a b. m a -> m b -> m b) -> (forall a. a -> m a) -> Monad m return :: a -> Action a $creturn :: forall a. a -> Action a >> :: Action a -> Action b -> Action b $c>> :: forall a b. Action a -> Action b -> Action b >>= :: Action a -> (a -> Action b) -> Action b $c>>= :: forall a b. Action a -> (a -> Action b) -> Action b $cp1Monad :: Applicative Action Monad, Monad Action Monad Action -> (forall a. IO a -> Action a) -> MonadIO Action IO a -> Action a forall a. IO a -> Action a forall (m :: * -> *). Monad m -> (forall a. IO a -> m a) -> MonadIO m liftIO :: IO a -> Action a $cliftIO :: forall a. IO a -> Action a $cp1MonadIO :: Monad Action MonadIO, Typeable, b -> Action a -> Action a NonEmpty (Action a) -> Action a Action a -> Action a -> Action a (Action a -> Action a -> Action a) -> (NonEmpty (Action a) -> Action a) -> (forall b. Integral b => b -> Action a -> Action a) -> Semigroup (Action a) forall b. Integral b => b -> Action a -> Action a forall a. Semigroup a => NonEmpty (Action a) -> Action a forall a. Semigroup a => Action a -> Action a -> Action a forall a b. (Semigroup a, Integral b) => b -> Action a -> Action a forall a. (a -> a -> a) -> (NonEmpty a -> a) -> (forall b. Integral b => b -> a -> a) -> Semigroup a stimes :: b -> Action a -> Action a $cstimes :: forall a b. (Semigroup a, Integral b) => b -> Action a -> Action a sconcat :: NonEmpty (Action a) -> Action a $csconcat :: forall a. Semigroup a => NonEmpty (Action a) -> Action a <> :: Action a -> Action a -> Action a $c<> :: forall a. Semigroup a => Action a -> Action a -> Action a Semigroup, Semigroup (Action a) Action a Semigroup (Action a) -> Action a -> (Action a -> Action a -> Action a) -> ([Action a] -> Action a) -> Monoid (Action a) [Action a] -> Action a Action a -> Action a -> Action a forall a. Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a forall a. Monoid a => Semigroup (Action a) forall a. Monoid a => Action a forall a. Monoid a => [Action a] -> Action a forall a. Monoid a => Action a -> Action a -> Action a mconcat :: [Action a] -> Action a $cmconcat :: forall a. Monoid a => [Action a] -> Action a mappend :: Action a -> Action a -> Action a $cmappend :: forall a. Monoid a => Action a -> Action a -> Action a mempty :: Action a $cmempty :: forall a. Monoid a => Action a $cp1Monoid :: forall a. Monoid a => Semigroup (Action a) Monoid, Monad Action Monad Action -> (forall a. String -> Action a) -> MonadFail Action String -> Action a forall a. String -> Action a forall (m :: * -> *). Monad m -> (forall a. String -> m a) -> MonadFail m fail :: String -> Action a $cfail :: forall a. String -> Action a $cp1MonadFail :: Monad Action MonadFail) runAction :: Global -> Local -> Action a -> Capture (Either SomeException a) runAction :: Global -> Local -> Action a -> Capture (Either SomeException a) runAction Global g Local l (Action RAW ([String], [Key]) [Value] Global Local a x) = ([([String], [Key])] -> RAW ([String], [Key]) [Value] Global Local [[Value]]) -> Global -> Local -> RAW ([String], [Key]) [Value] Global Local a -> Capture (Either SomeException a) forall k v ro rw a. ([k] -> RAW k v ro rw [v]) -> ro -> rw -> RAW k v ro rw a -> Capture (Either SomeException a) runRAW (Action [[Value]] -> RAW ([String], [Key]) [Value] Global Local [[Value]] forall a. Action a -> RAW ([String], [Key]) [Value] Global Local a fromAction (Action [[Value]] -> RAW ([String], [Key]) [Value] Global Local [[Value]]) -> ([([String], [Key])] -> Action [[Value]]) -> [([String], [Key])] -> RAW ([String], [Key]) [Value] Global Local [[Value]] forall b c a. (b -> c) -> (a -> b) -> a -> c . [([String], [Key])] -> Action [[Value]] build) Global g Local l RAW ([String], [Key]) [Value] Global Local a x where -- first argument is a list of call stacks, since build only takes one we use the first -- they are very probably all identical... build :: [([String], [Key])] -> Action [[Value]] build :: [([String], [Key])] -> Action [[Value]] build [] = [[Value]] -> Action [[Value]] forall (f :: * -> *) a. Applicative f => a -> f a pure [] build ks :: [([String], [Key])] ks@(([String] callstack,[Key] _):[([String], [Key])] _) = do let kss :: [[Key]] kss = (([String], [Key]) -> [Key]) -> [([String], [Key])] -> [[Key]] forall a b. (a -> b) -> [a] -> [b] map ([String], [Key]) -> [Key] forall a b. (a, b) -> b snd [([String], [Key])] ks [[Key]] -> [Value] -> [[Value]] forall a b. [[a]] -> [b] -> [[b]] unconcat [[Key]] kss ([Value] -> [[Value]]) -> Action [Value] -> Action [[Value]] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Global -> [String] -> [Key] -> Action [Value] globalBuild Global g [String] callstack ([[Key]] -> [Key] forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [[Key]] kss) --------------------------------------------------------------------- -- PUBLIC TYPES -- | What mode a rule is running in, passed as an argument to 'BuiltinRun'. data RunMode = RunDependenciesSame -- ^ My dependencies have not changed. | RunDependenciesChanged -- ^ At least one of my dependencies from last time have changed, or I have no recorded dependencies. deriving (RunMode -> RunMode -> Bool (RunMode -> RunMode -> Bool) -> (RunMode -> RunMode -> Bool) -> Eq RunMode forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: RunMode -> RunMode -> Bool $c/= :: RunMode -> RunMode -> Bool == :: RunMode -> RunMode -> Bool $c== :: RunMode -> RunMode -> Bool Eq,Int -> RunMode -> ShowS [RunMode] -> ShowS RunMode -> String (Int -> RunMode -> ShowS) -> (RunMode -> String) -> ([RunMode] -> ShowS) -> Show RunMode forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [RunMode] -> ShowS $cshowList :: [RunMode] -> ShowS show :: RunMode -> String $cshow :: RunMode -> String showsPrec :: Int -> RunMode -> ShowS $cshowsPrec :: Int -> RunMode -> ShowS Show) instance NFData RunMode where rnf :: RunMode -> () rnf RunMode x = RunMode x RunMode -> () -> () `seq` () -- | How the output of a rule has changed. data RunChanged = ChangedNothing -- ^ Nothing has changed. | ChangedStore -- ^ The stored value has changed, but in a way that should be considered identical (used rarely). | ChangedRecomputeSame -- ^ I recomputed the value and it was the same. | ChangedRecomputeDiff -- ^ I recomputed the value and it was different. deriving (RunChanged -> RunChanged -> Bool (RunChanged -> RunChanged -> Bool) -> (RunChanged -> RunChanged -> Bool) -> Eq RunChanged forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: RunChanged -> RunChanged -> Bool $c/= :: RunChanged -> RunChanged -> Bool == :: RunChanged -> RunChanged -> Bool $c== :: RunChanged -> RunChanged -> Bool Eq,Int -> RunChanged -> ShowS [RunChanged] -> ShowS RunChanged -> String (Int -> RunChanged -> ShowS) -> (RunChanged -> String) -> ([RunChanged] -> ShowS) -> Show RunChanged forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [RunChanged] -> ShowS $cshowList :: [RunChanged] -> ShowS show :: RunChanged -> String $cshow :: RunChanged -> String showsPrec :: Int -> RunChanged -> ShowS $cshowsPrec :: Int -> RunChanged -> ShowS Show) instance NFData RunChanged where rnf :: RunChanged -> () rnf RunChanged x = RunChanged x RunChanged -> () -> () `seq` () -- | The result of 'BuiltinRun'. data RunResult value = RunResult {RunResult value -> RunChanged runChanged :: RunChanged -- ^ How has the 'RunResult' changed from what happened last time. ,RunResult value -> ByteString runStore :: BS.ByteString -- ^ The value to store in the Shake database. ,RunResult value -> value runValue :: value -- ^ The value to return from 'Development.Shake.Rule.apply'. } deriving a -> RunResult b -> RunResult a (a -> b) -> RunResult a -> RunResult b (forall a b. (a -> b) -> RunResult a -> RunResult b) -> (forall a b. a -> RunResult b -> RunResult a) -> Functor RunResult forall a b. a -> RunResult b -> RunResult a forall a b. (a -> b) -> RunResult a -> RunResult b forall (f :: * -> *). (forall a b. (a -> b) -> f a -> f b) -> (forall a b. a -> f b -> f a) -> Functor f <$ :: a -> RunResult b -> RunResult a $c<$ :: forall a b. a -> RunResult b -> RunResult a fmap :: (a -> b) -> RunResult a -> RunResult b $cfmap :: forall a b. (a -> b) -> RunResult a -> RunResult b Functor instance NFData value => NFData (RunResult value) where rnf :: RunResult value -> () rnf (RunResult RunChanged x1 ByteString x2 value x3) = RunChanged -> () forall a. NFData a => a -> () rnf RunChanged x1 () -> () -> () `seq` ByteString x2 ByteString -> () -> () `seq` value -> () forall a. NFData a => a -> () rnf value x3 --------------------------------------------------------------------- -- UTILITY TYPES newtype Step = Step Word32 deriving (Step -> Step -> Bool (Step -> Step -> Bool) -> (Step -> Step -> Bool) -> Eq Step forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Step -> Step -> Bool $c/= :: Step -> Step -> Bool == :: Step -> Step -> Bool $c== :: Step -> Step -> Bool Eq,Eq Step Eq Step -> (Step -> Step -> Ordering) -> (Step -> Step -> Bool) -> (Step -> Step -> Bool) -> (Step -> Step -> Bool) -> (Step -> Step -> Bool) -> (Step -> Step -> Step) -> (Step -> Step -> Step) -> Ord Step Step -> Step -> Bool Step -> Step -> Ordering Step -> Step -> Step forall a. Eq a -> (a -> a -> Ordering) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> a) -> (a -> a -> a) -> Ord a min :: Step -> Step -> Step $cmin :: Step -> Step -> Step max :: Step -> Step -> Step $cmax :: Step -> Step -> Step >= :: Step -> Step -> Bool $c>= :: Step -> Step -> Bool > :: Step -> Step -> Bool $c> :: Step -> Step -> Bool <= :: Step -> Step -> Bool $c<= :: Step -> Step -> Bool < :: Step -> Step -> Bool $c< :: Step -> Step -> Bool compare :: Step -> Step -> Ordering $ccompare :: Step -> Step -> Ordering $cp1Ord :: Eq Step Ord,Int -> Step -> ShowS [Step] -> ShowS Step -> String (Int -> Step -> ShowS) -> (Step -> String) -> ([Step] -> ShowS) -> Show Step forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Step] -> ShowS $cshowList :: [Step] -> ShowS show :: Step -> String $cshow :: Step -> String showsPrec :: Int -> Step -> ShowS $cshowsPrec :: Int -> Step -> ShowS Show,Ptr b -> Int -> IO Step Ptr b -> Int -> Step -> IO () Ptr Step -> IO Step Ptr Step -> Int -> IO Step Ptr Step -> Int -> Step -> IO () Ptr Step -> Step -> IO () Step -> Int (Step -> Int) -> (Step -> Int) -> (Ptr Step -> Int -> IO Step) -> (Ptr Step -> Int -> Step -> IO ()) -> (forall b. Ptr b -> Int -> IO Step) -> (forall b. Ptr b -> Int -> Step -> IO ()) -> (Ptr Step -> IO Step) -> (Ptr Step -> Step -> IO ()) -> Storable Step forall b. Ptr b -> Int -> IO Step forall b. Ptr b -> Int -> Step -> IO () forall a. (a -> Int) -> (a -> Int) -> (Ptr a -> Int -> IO a) -> (Ptr a -> Int -> a -> IO ()) -> (forall b. Ptr b -> Int -> IO a) -> (forall b. Ptr b -> Int -> a -> IO ()) -> (Ptr a -> IO a) -> (Ptr a -> a -> IO ()) -> Storable a poke :: Ptr Step -> Step -> IO () $cpoke :: Ptr Step -> Step -> IO () peek :: Ptr Step -> IO Step $cpeek :: Ptr Step -> IO Step pokeByteOff :: Ptr b -> Int -> Step -> IO () $cpokeByteOff :: forall b. Ptr b -> Int -> Step -> IO () peekByteOff :: Ptr b -> Int -> IO Step $cpeekByteOff :: forall b. Ptr b -> Int -> IO Step pokeElemOff :: Ptr Step -> Int -> Step -> IO () $cpokeElemOff :: Ptr Step -> Int -> Step -> IO () peekElemOff :: Ptr Step -> Int -> IO Step $cpeekElemOff :: Ptr Step -> Int -> IO Step alignment :: Step -> Int $calignment :: Step -> Int sizeOf :: Step -> Int $csizeOf :: Step -> Int Storable,ByteString -> Step Step -> Builder (Step -> Builder) -> (ByteString -> Step) -> BinaryEx Step forall a. (a -> Builder) -> (ByteString -> a) -> BinaryEx a getEx :: ByteString -> Step $cgetEx :: ByteString -> Step putEx :: Step -> Builder $cputEx :: Step -> Builder BinaryEx,Step -> () (Step -> ()) -> NFData Step forall a. (a -> ()) -> NFData a rnf :: Step -> () $crnf :: Step -> () NFData,Int -> Step -> Int Step -> Int (Int -> Step -> Int) -> (Step -> Int) -> Hashable Step forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a hash :: Step -> Int $chash :: Step -> Int hashWithSalt :: Int -> Step -> Int $chashWithSalt :: Int -> Step -> Int Hashable,Typeable) incStep :: Step -> Step incStep (Step Word32 i) = Word32 -> Step Step (Word32 -> Step) -> Word32 -> Step forall a b. (a -> b) -> a -> b $ Word32 i Word32 -> Word32 -> Word32 forall a. Num a => a -> a -> a + Word32 1 -- To simplify journaling etc we smuggle the Step in the database, with a special StepKey newtype StepKey = StepKey () deriving (Int -> StepKey -> ShowS [StepKey] -> ShowS StepKey -> String (Int -> StepKey -> ShowS) -> (StepKey -> String) -> ([StepKey] -> ShowS) -> Show StepKey forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [StepKey] -> ShowS $cshowList :: [StepKey] -> ShowS show :: StepKey -> String $cshow :: StepKey -> String showsPrec :: Int -> StepKey -> ShowS $cshowsPrec :: Int -> StepKey -> ShowS Show,StepKey -> StepKey -> Bool (StepKey -> StepKey -> Bool) -> (StepKey -> StepKey -> Bool) -> Eq StepKey forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: StepKey -> StepKey -> Bool $c/= :: StepKey -> StepKey -> Bool == :: StepKey -> StepKey -> Bool $c== :: StepKey -> StepKey -> Bool Eq,Typeable,Int -> StepKey -> Int StepKey -> Int (Int -> StepKey -> Int) -> (StepKey -> Int) -> Hashable StepKey forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a hash :: StepKey -> Int $chash :: StepKey -> Int hashWithSalt :: Int -> StepKey -> Int $chashWithSalt :: Int -> StepKey -> Int Hashable,Get StepKey [StepKey] -> Put StepKey -> Put (StepKey -> Put) -> Get StepKey -> ([StepKey] -> Put) -> Binary StepKey forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t putList :: [StepKey] -> Put $cputList :: [StepKey] -> Put get :: Get StepKey $cget :: Get StepKey put :: StepKey -> Put $cput :: StepKey -> Put Binary,ByteString -> StepKey StepKey -> Builder (StepKey -> Builder) -> (ByteString -> StepKey) -> BinaryEx StepKey forall a. (a -> Builder) -> (ByteString -> a) -> BinaryEx a getEx :: ByteString -> StepKey $cgetEx :: ByteString -> StepKey putEx :: StepKey -> Builder $cputEx :: StepKey -> Builder BinaryEx,StepKey -> () (StepKey -> ()) -> NFData StepKey forall a. (a -> ()) -> NFData a rnf :: StepKey -> () $crnf :: StepKey -> () NFData) stepKey :: Key stepKey :: Key stepKey = StepKey -> Key forall a. ShakeValue a => a -> Key newKey (StepKey -> Key) -> StepKey -> Key forall a b. (a -> b) -> a -> b $ () -> StepKey StepKey () -- To make sure profiling has a complete view of what was demanded and all top-level 'action' -- things we fake up a Root node representing everything that was demanded newtype Root = Root () deriving (Root -> Root -> Bool (Root -> Root -> Bool) -> (Root -> Root -> Bool) -> Eq Root forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Root -> Root -> Bool $c/= :: Root -> Root -> Bool == :: Root -> Root -> Bool $c== :: Root -> Root -> Bool Eq,Typeable,Int -> Root -> Int Root -> Int (Int -> Root -> Int) -> (Root -> Int) -> Hashable Root forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a hash :: Root -> Int $chash :: Root -> Int hashWithSalt :: Int -> Root -> Int $chashWithSalt :: Int -> Root -> Int Hashable,Get Root [Root] -> Put Root -> Put (Root -> Put) -> Get Root -> ([Root] -> Put) -> Binary Root forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t putList :: [Root] -> Put $cputList :: [Root] -> Put get :: Get Root $cget :: Get Root put :: Root -> Put $cput :: Root -> Put Binary,ByteString -> Root Root -> Builder (Root -> Builder) -> (ByteString -> Root) -> BinaryEx Root forall a. (a -> Builder) -> (ByteString -> a) -> BinaryEx a getEx :: ByteString -> Root $cgetEx :: ByteString -> Root putEx :: Root -> Builder $cputEx :: Root -> Builder BinaryEx,Root -> () (Root -> ()) -> NFData Root forall a. (a -> ()) -> NFData a rnf :: Root -> () $crnf :: Root -> () NFData) instance Show Root where show :: Root -> String show (Root ()) = String "Root" rootKey :: Key rootKey :: Key rootKey = Root -> Key forall a. ShakeValue a => a -> Key newKey (Root -> Key) -> Root -> Key forall a b. (a -> b) -> a -> b $ () -> Root Root () --------------------------------------------------------------------- -- CALL STACK -- Invariant: Every key must have its Id in the set data Stack = Stack (Maybe Key) [Either Key [String]] !(Set.HashSet Id) deriving Int -> Stack -> ShowS [Stack] -> ShowS Stack -> String (Int -> Stack -> ShowS) -> (Stack -> String) -> ([Stack] -> ShowS) -> Show Stack forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Stack] -> ShowS $cshowList :: [Stack] -> ShowS show :: Stack -> String $cshow :: Stack -> String showsPrec :: Int -> Stack -> ShowS $cshowsPrec :: Int -> Stack -> ShowS Show exceptionStack :: Stack -> SomeException -> ShakeException exceptionStack :: Stack -> SomeException -> ShakeException exceptionStack stack :: Stack stack@(Stack Maybe Key _ [Either Key [String]] xs1 HashSet Id _) (SomeException -> ([String], SomeException) callStackFromException -> ([String] xs2, SomeException e)) = String -> [String] -> SomeException -> ShakeException ShakeException (Stack -> String showTopStack Stack stack) ([String] xs [String] -> [String] -> [String] forall a. [a] -> [a] -> [a] ++ [String "* Raised the exception:" | Bool -> Bool not (Bool -> Bool) -> Bool -> Bool forall a b. (a -> b) -> a -> b $ [String] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [String] xs]) SomeException e where xs :: [String] xs = (Either Key [String] -> [String]) -> [Either Key [String]] -> [String] forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap Either Key [String] -> [String] forall a. Show a => Either a [String] -> [String] f ([Either Key [String]] -> [String]) -> [Either Key [String]] -> [String] forall a b. (a -> b) -> a -> b $ [Either Key [String]] -> [Either Key [String]] forall a. [a] -> [a] reverse [Either Key [String]] xs1 [Either Key [String]] -> [Either Key [String]] -> [Either Key [String]] forall a. [a] -> [a] -> [a] ++ [[String] -> Either Key [String] forall a b. b -> Either a b Right [String] xs2] f :: Either a [String] -> [String] f (Left a x) = [String "* Depends on: " String -> ShowS forall a. [a] -> [a] -> [a] ++ a -> String forall a. Show a => a -> String show a x] f (Right [String] x) = ShowS -> [String] -> [String] forall a b. (a -> b) -> [a] -> [b] map (String " at " String -> ShowS forall a. [a] -> [a] -> [a] ++) [String] x showTopStack :: Stack -> String showTopStack :: Stack -> String showTopStack = String -> (Key -> String) -> Maybe Key -> String forall b a. b -> (a -> b) -> Maybe a -> b maybe String "<unknown>" Key -> String forall a. Show a => a -> String show (Maybe Key -> String) -> (Stack -> Maybe Key) -> Stack -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . Stack -> Maybe Key topStack addStack :: Id -> Key -> Stack -> Either SomeException Stack addStack :: Id -> Key -> Stack -> Either SomeException Stack addStack Id i Key k (Stack Maybe Key _ [Either Key [String]] ks HashSet Id is) | Id i Id -> HashSet Id -> Bool forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool `Set.member` HashSet Id is = SomeException -> Either SomeException Stack forall a b. a -> Either a b Left (SomeException -> Either SomeException Stack) -> SomeException -> Either SomeException Stack forall a b. (a -> b) -> a -> b $ ShakeException -> SomeException forall e. Exception e => e -> SomeException toException (ShakeException -> SomeException) -> ShakeException -> SomeException forall a b. (a -> b) -> a -> b $ Stack -> SomeException -> ShakeException exceptionStack Stack stack2 (SomeException -> ShakeException) -> SomeException -> ShakeException forall a b. (a -> b) -> a -> b $ TypeRep -> String -> SomeException errorRuleRecursion (Key -> TypeRep typeKey Key k) (Key -> String forall a. Show a => a -> String show Key k) | Bool otherwise = Stack -> Either SomeException Stack forall a b. b -> Either a b Right Stack stack2 where stack2 :: Stack stack2 = Maybe Key -> [Either Key [String]] -> HashSet Id -> Stack Stack (Key -> Maybe Key forall a. a -> Maybe a Just Key k) (Key -> Either Key [String] forall a b. a -> Either a b Left Key kEither Key [String] -> [Either Key [String]] -> [Either Key [String]] forall a. a -> [a] -> [a] :[Either Key [String]] ks) (Id -> HashSet Id -> HashSet Id forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a Set.insert Id i HashSet Id is) addCallStack :: [String] -> Stack -> Stack -- use group/head to squash adjacent duplicates, e.g. a want does an action and a need, both of which get the same location addCallStack :: [String] -> Stack -> Stack addCallStack [String] xs (Stack Maybe Key t [Either Key [String]] a HashSet Id b) = Maybe Key -> [Either Key [String]] -> HashSet Id -> Stack Stack Maybe Key t ([String] -> Either Key [String] forall a b. b -> Either a b Right [String] xs Either Key [String] -> [Either Key [String]] -> [Either Key [String]] forall a. a -> [a] -> [a] : (Either Key [String] -> Bool) -> [Either Key [String]] -> [Either Key [String]] forall a. (a -> Bool) -> [a] -> [a] dropWhile (Either Key [String] -> Either Key [String] -> Bool forall a. Eq a => a -> a -> Bool == [String] -> Either Key [String] forall a b. b -> Either a b Right [String] xs) [Either Key [String]] a) HashSet Id b topStack :: Stack -> Maybe Key topStack :: Stack -> Maybe Key topStack (Stack Maybe Key t [Either Key [String]] _ HashSet Id _) = Maybe Key t emptyStack :: Stack emptyStack :: Stack emptyStack = Maybe Key -> [Either Key [String]] -> HashSet Id -> Stack Stack Maybe Key forall a. Maybe a Nothing [] HashSet Id forall a. HashSet a Set.empty --------------------------------------------------------------------- -- TRACE data Trace = Trace {Trace -> ByteString traceMessage :: {-# UNPACK #-} !BS.ByteString ,Trace -> Float traceStart :: {-# UNPACK #-} !Float ,Trace -> Float traceEnd :: {-# UNPACK #-} !Float } deriving Int -> Trace -> ShowS [Trace] -> ShowS Trace -> String (Int -> Trace -> ShowS) -> (Trace -> String) -> ([Trace] -> ShowS) -> Show Trace forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Trace] -> ShowS $cshowList :: [Trace] -> ShowS show :: Trace -> String $cshow :: Trace -> String showsPrec :: Int -> Trace -> ShowS $cshowsPrec :: Int -> Trace -> ShowS Show instance NFData Trace where rnf :: Trace -> () rnf Trace x = Trace x Trace -> () -> () `seq` () -- all strict atomic fields instance BinaryEx Trace where putEx :: Trace -> Builder putEx (Trace ByteString a Float b Float c) = Float -> Builder forall a. BinaryEx a => a -> Builder putEx Float b Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Float -> Builder forall a. BinaryEx a => a -> Builder putEx Float c Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> ByteString -> Builder forall a. BinaryEx a => a -> Builder putEx ByteString a getEx :: ByteString -> Trace getEx ByteString x | (Float b,Float c,ByteString a) <- ByteString -> (Float, Float, ByteString) forall a b. (Storable a, Storable b) => ByteString -> (a, b, ByteString) binarySplit2 ByteString x = ByteString -> Float -> Float -> Trace Trace ByteString a Float b Float c instance BinaryEx [Trace] where putEx :: [Trace] -> Builder putEx = [Builder] -> Builder putExList ([Builder] -> Builder) -> ([Trace] -> [Builder]) -> [Trace] -> Builder forall b c a. (b -> c) -> (a -> b) -> a -> c . (Trace -> Builder) -> [Trace] -> [Builder] forall a b. (a -> b) -> [a] -> [b] map Trace -> Builder forall a. BinaryEx a => a -> Builder putEx getEx :: ByteString -> [Trace] getEx = (ByteString -> Trace) -> [ByteString] -> [Trace] forall a b. (a -> b) -> [a] -> [b] map ByteString -> Trace forall a. BinaryEx a => ByteString -> a getEx ([ByteString] -> [Trace]) -> (ByteString -> [ByteString]) -> ByteString -> [Trace] forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> [ByteString] getExList newTrace :: String -> Seconds -> Seconds -> Trace newTrace :: String -> Seconds -> Seconds -> Trace newTrace String msg Seconds start Seconds stop = ByteString -> Float -> Float -> Trace Trace (String -> ByteString BS.pack String msg) (Seconds -> Float doubleToFloat Seconds start) (Seconds -> Float doubleToFloat Seconds stop) --------------------------------------------------------------------- -- CENTRAL TYPES -- Things stored under OneShot are not required if we only do one compilation, -- but are if we do multiple, as we have to reset the database each time. -- globalOneShot controls that, and gives us a small memory optimisation. type OneShot a = a data Status = Ready !(Result (Value, OneShot BS_Store)) -- ^ I have a value | Failed !SomeException !(OneShot (Maybe (Result BS_Store))) -- ^ I have been run and raised an error | Loaded !(Result BS_Store) -- ^ Loaded from the database | Running !(NoShow (Either SomeException (Result (Value, BS_Store)) -> Locked ())) (Maybe (Result BS_Store)) -- ^ Currently in the process of being checked or built | Missing -- ^ I am only here because I got into the Intern table deriving Int -> Status -> ShowS [Status] -> ShowS Status -> String (Int -> Status -> ShowS) -> (Status -> String) -> ([Status] -> ShowS) -> Show Status forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Status] -> ShowS $cshowList :: [Status] -> ShowS show :: Status -> String $cshow :: Status -> String showsPrec :: Int -> Status -> ShowS $cshowsPrec :: Int -> Status -> ShowS Show instance NFData Status where rnf :: Status -> () rnf Status x = case Status x of Ready Result (Value, ByteString) x -> Result (Value, ByteString) -> () forall a. NFData a => a -> () rnf Result (Value, ByteString) x Failed SomeException x OneShot (Maybe (Result ByteString)) y -> SomeException -> () rnfException SomeException x () -> () -> () `seq` OneShot (Maybe (Result ByteString)) -> () forall a. NFData a => a -> () rnf OneShot (Maybe (Result ByteString)) y Loaded Result ByteString x -> Result ByteString -> () forall a. NFData a => a -> () rnf Result ByteString x Running NoShow (Either SomeException (Result (Value, ByteString)) -> Locked ()) _ OneShot (Maybe (Result ByteString)) x -> OneShot (Maybe (Result ByteString)) -> () forall a. NFData a => a -> () rnf OneShot (Maybe (Result ByteString)) x -- Can't RNF a waiting, but also unnecessary Status Missing -> () where -- best we can do for an arbitrary exception rnfException :: SomeException -> () rnfException = String -> () forall a. NFData a => a -> () rnf (String -> ()) -> (SomeException -> String) -> SomeException -> () forall b c a. (b -> c) -> (a -> b) -> a -> c . SomeException -> String forall a. Show a => a -> String show data Result a = Result {Result a -> a result :: !a -- ^ the result associated with the Key ,Result a -> Step built :: {-# UNPACK #-} !Step -- ^ when it was actually run ,Result a -> Step changed :: {-# UNPACK #-} !Step -- ^ the step for deciding if it's valid ,Result a -> [Depends] depends :: ![Depends] -- ^ dependencies (don't run them early) ,Result a -> Float execution :: {-# UNPACK #-} !Float -- ^ how long it took when it was last run (seconds) ,Result a -> [Trace] traces :: ![Trace] -- ^ a trace of the expensive operations (start/end in seconds since beginning of run) } deriving (Int -> Result a -> ShowS [Result a] -> ShowS Result a -> String (Int -> Result a -> ShowS) -> (Result a -> String) -> ([Result a] -> ShowS) -> Show (Result a) forall a. Show a => Int -> Result a -> ShowS forall a. Show a => [Result a] -> ShowS forall a. Show a => Result a -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Result a] -> ShowS $cshowList :: forall a. Show a => [Result a] -> ShowS show :: Result a -> String $cshow :: forall a. Show a => Result a -> String showsPrec :: Int -> Result a -> ShowS $cshowsPrec :: forall a. Show a => Int -> Result a -> ShowS Show,a -> Result b -> Result a (a -> b) -> Result a -> Result b (forall a b. (a -> b) -> Result a -> Result b) -> (forall a b. a -> Result b -> Result a) -> Functor Result forall a b. a -> Result b -> Result a forall a b. (a -> b) -> Result a -> Result b forall (f :: * -> *). (forall a b. (a -> b) -> f a -> f b) -> (forall a b. a -> f b -> f a) -> Functor f <$ :: a -> Result b -> Result a $c<$ :: forall a b. a -> Result b -> Result a fmap :: (a -> b) -> Result a -> Result b $cfmap :: forall a b. (a -> b) -> Result a -> Result b Functor) instance NFData a => NFData (Result a) where -- ignore unpacked fields rnf :: Result a -> () rnf (Result a a Step _ Step _ [Depends] b Float _ [Trace] c) = a -> () forall a. NFData a => a -> () rnf a a () -> () -> () `seq` [Depends] -> () forall a. NFData a => a -> () rnf [Depends] b () -> () -> () `seq` [Trace] -> () forall a. NFData a => a -> () rnf [Trace] c statusType :: Status -> String statusType Ready{} = String "Ready" statusType Failed{} = String "Failed" statusType Loaded{} = String "Loaded" statusType Running{} = String "Running" statusType Missing{} = String "Missing" getResult :: Status -> Maybe (Result (Either BS_Store Value)) getResult :: Status -> Maybe (Result (Either ByteString Value)) getResult (Ready Result (Value, ByteString) r) = Result (Either ByteString Value) -> Maybe (Result (Either ByteString Value)) forall a. a -> Maybe a Just (Result (Either ByteString Value) -> Maybe (Result (Either ByteString Value))) -> Result (Either ByteString Value) -> Maybe (Result (Either ByteString Value)) forall a b. (a -> b) -> a -> b $ Value -> Either ByteString Value forall a b. b -> Either a b Right (Value -> Either ByteString Value) -> ((Value, ByteString) -> Value) -> (Value, ByteString) -> Either ByteString Value forall b c a. (b -> c) -> (a -> b) -> a -> c . (Value, ByteString) -> Value forall a b. (a, b) -> a fst ((Value, ByteString) -> Either ByteString Value) -> Result (Value, ByteString) -> Result (Either ByteString Value) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Result (Value, ByteString) r getResult (Loaded Result ByteString r) = Result (Either ByteString Value) -> Maybe (Result (Either ByteString Value)) forall a. a -> Maybe a Just (Result (Either ByteString Value) -> Maybe (Result (Either ByteString Value))) -> Result (Either ByteString Value) -> Maybe (Result (Either ByteString Value)) forall a b. (a -> b) -> a -> b $ ByteString -> Either ByteString Value forall a b. a -> Either a b Left (ByteString -> Either ByteString Value) -> Result ByteString -> Result (Either ByteString Value) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Result ByteString r getResult (Running NoShow (Either SomeException (Result (Value, ByteString)) -> Locked ()) _ OneShot (Maybe (Result ByteString)) r) = (ByteString -> Either ByteString Value) -> Result ByteString -> Result (Either ByteString Value) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ByteString -> Either ByteString Value forall a b. a -> Either a b Left (Result ByteString -> Result (Either ByteString Value)) -> OneShot (Maybe (Result ByteString)) -> Maybe (Result (Either ByteString Value)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> OneShot (Maybe (Result ByteString)) r getResult Status _ = Maybe (Result (Either ByteString Value)) forall a. Maybe a Nothing --------------------------------------------------------------------- -- OPERATIONS newtype Depends = Depends {Depends -> [Id] fromDepends :: [Id]} deriving (Depends -> () (Depends -> ()) -> NFData Depends forall a. (a -> ()) -> NFData a rnf :: Depends -> () $crnf :: Depends -> () NFData, b -> Depends -> Depends NonEmpty Depends -> Depends Depends -> Depends -> Depends (Depends -> Depends -> Depends) -> (NonEmpty Depends -> Depends) -> (forall b. Integral b => b -> Depends -> Depends) -> Semigroup Depends forall b. Integral b => b -> Depends -> Depends forall a. (a -> a -> a) -> (NonEmpty a -> a) -> (forall b. Integral b => b -> a -> a) -> Semigroup a stimes :: b -> Depends -> Depends $cstimes :: forall b. Integral b => b -> Depends -> Depends sconcat :: NonEmpty Depends -> Depends $csconcat :: NonEmpty Depends -> Depends <> :: Depends -> Depends -> Depends $c<> :: Depends -> Depends -> Depends Semigroup, Semigroup Depends Depends Semigroup Depends -> Depends -> (Depends -> Depends -> Depends) -> ([Depends] -> Depends) -> Monoid Depends [Depends] -> Depends Depends -> Depends -> Depends forall a. Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a mconcat :: [Depends] -> Depends $cmconcat :: [Depends] -> Depends mappend :: Depends -> Depends -> Depends $cmappend :: Depends -> Depends -> Depends mempty :: Depends $cmempty :: Depends $cp1Monoid :: Semigroup Depends Monoid) instance Show Depends where -- Appears in diagnostic output and the Depends ctor is just verbose show :: Depends -> String show = [Id] -> String forall a. Show a => a -> String show ([Id] -> String) -> (Depends -> [Id]) -> Depends -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . Depends -> [Id] fromDepends instance BinaryEx Depends where putEx :: Depends -> Builder putEx (Depends [Id] xs) = [Id] -> Builder forall a. Storable a => [a] -> Builder putExStorableList [Id] xs getEx :: ByteString -> Depends getEx = [Id] -> Depends Depends ([Id] -> Depends) -> (ByteString -> [Id]) -> ByteString -> Depends forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> [Id] forall a. Storable a => ByteString -> [a] getExStorableList instance BinaryEx [Depends] where putEx :: [Depends] -> Builder putEx = [Builder] -> Builder putExList ([Builder] -> Builder) -> ([Depends] -> [Builder]) -> [Depends] -> Builder forall b c a. (b -> c) -> (a -> b) -> a -> c . (Depends -> Builder) -> [Depends] -> [Builder] forall a b. (a -> b) -> [a] -> [b] map Depends -> Builder forall a. BinaryEx a => a -> Builder putEx getEx :: ByteString -> [Depends] getEx = (ByteString -> Depends) -> [ByteString] -> [Depends] forall a b. (a -> b) -> [a] -> [b] map ByteString -> Depends forall a. BinaryEx a => ByteString -> a getEx ([ByteString] -> [Depends]) -> (ByteString -> [ByteString]) -> ByteString -> [Depends] forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> [ByteString] getExList data DependsList = DependsNone | DependsDirect [Depends] | DependsSequence DependsList DependsList | DependsSequence1 DependsList Depends | DependsParallel [DependsList] -- Create a new set of depends, from a list in the right order newDepends :: [Depends] -> DependsList newDepends :: [Depends] -> DependsList newDepends = [Depends] -> DependsList DependsDirect -- Add two sequences of dependencies in order addDepends :: DependsList -> DependsList -> DependsList addDepends :: DependsList -> DependsList -> DependsList addDepends = DependsList -> DependsList -> DependsList DependsSequence addDepends1 :: DependsList -> Depends -> DependsList addDepends1 :: DependsList -> Depends -> DependsList addDepends1 = DependsList -> Depends -> DependsList DependsSequence1 -- Two goals here, merge parallel lists so they retain as much leading parallelism as possible -- Afterwards each Id must occur at most once and there are no empty Depends flattenDepends :: DependsList -> [Depends] flattenDepends :: DependsList -> [Depends] flattenDepends DependsList d = HashSet Id -> [Depends] -> [Depends] fMany HashSet Id forall a. HashSet a Set.empty ([Depends] -> [Depends]) -> [Depends] -> [Depends] forall a b. (a -> b) -> a -> b $ DependsList -> [Depends] -> [Depends] flat DependsList d [] where flat :: DependsList -> [Depends] -> [Depends] flat :: DependsList -> [Depends] -> [Depends] flat DependsList DependsNone [Depends] rest = [Depends] rest flat (DependsDirect [Depends] xs) [Depends] rest = [Depends] xs [Depends] -> [Depends] -> [Depends] forall a. [a] -> [a] -> [a] ++ [Depends] rest flat (DependsSequence DependsList xs DependsList ys) [Depends] rest = DependsList -> [Depends] -> [Depends] flat DependsList xs ([Depends] -> [Depends]) -> [Depends] -> [Depends] forall a b. (a -> b) -> a -> b $ DependsList -> [Depends] -> [Depends] flat DependsList ys [Depends] rest flat (DependsSequence1 DependsList xs Depends y) [Depends] rest = DependsList -> [Depends] -> [Depends] flat DependsList xs ([Depends] -> [Depends]) -> [Depends] -> [Depends] forall a b. (a -> b) -> a -> b $ Depends yDepends -> [Depends] -> [Depends] forall a. a -> [a] -> [a] :[Depends] rest -- for each element of xs, we want to pull off the things that must be done first -- and then the stuff that can be done later flat (DependsParallel [DependsList] xs) [Depends] rest = ([Depends] -> Depends) -> [[Depends]] -> [Depends] forall a b. (a -> b) -> [a] -> [b] map [Depends] -> Depends forall a. Monoid a => [a] -> a mconcat [[Depends]] xss [Depends] -> [Depends] -> [Depends] forall a. [a] -> [a] -> [a] ++ [Depends] rest where xss :: [[Depends]] xss = [[Depends]] -> [[Depends]] forall a. [[a]] -> [[a]] transpose ([[Depends]] -> [[Depends]]) -> [[Depends]] -> [[Depends]] forall a b. (a -> b) -> a -> b $ (DependsList -> [Depends]) -> [DependsList] -> [[Depends]] forall a b. (a -> b) -> [a] -> [b] map (DependsList -> [Depends] -> [Depends] `flat` []) [DependsList] xs fMany :: HashSet Id -> [Depends] -> [Depends] fMany HashSet Id _ [] = [] fMany HashSet Id seen (Depends [Id] d:[Depends] ds) = [[Id] -> Depends Depends [Id] d2 | [Id] d2 [Id] -> [Id] -> Bool forall a. Eq a => a -> a -> Bool /= []] [Depends] -> [Depends] -> [Depends] forall a. [a] -> [a] -> [a] ++ HashSet Id -> [Depends] -> [Depends] fMany HashSet Id seen2 [Depends] ds where ([Id] d2,HashSet Id seen2) = HashSet Id -> [Id] -> ([Id], HashSet Id) forall a. (Eq a, Hashable a) => HashSet a -> [a] -> ([a], HashSet a) fOne HashSet Id seen [Id] d fOne :: HashSet a -> [a] -> ([a], HashSet a) fOne HashSet a seen [] = ([], HashSet a seen) fOne HashSet a seen (a x:[a] xs) | a x a -> HashSet a -> Bool forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool `Set.member` HashSet a seen = HashSet a -> [a] -> ([a], HashSet a) fOne HashSet a seen [a] xs fOne HashSet a seen (a x:[a] xs) = ([a] -> [a]) -> ([a], HashSet a) -> ([a], HashSet a) forall a a' b. (a -> a') -> (a, b) -> (a', b) first (a xa -> [a] -> [a] forall a. a -> [a] -> [a] :) (([a], HashSet a) -> ([a], HashSet a)) -> ([a], HashSet a) -> ([a], HashSet a) forall a b. (a -> b) -> a -> b $ HashSet a -> [a] -> ([a], HashSet a) fOne (a -> HashSet a -> HashSet a forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a Set.insert a x HashSet a seen) [a] xs -- List all the dependencies in whatever order you wish, used for linting enumerateDepends :: DependsList -> [Depends] enumerateDepends :: DependsList -> [Depends] enumerateDepends DependsList d = DependsList -> [Depends] -> [Depends] f DependsList d [] where f :: DependsList -> [Depends] -> [Depends] f DependsList DependsNone [Depends] rest = [Depends] rest f (DependsDirect [Depends] xs) [Depends] rest = [Depends] xs [Depends] -> [Depends] -> [Depends] forall a. [a] -> [a] -> [a] ++ [Depends] rest f (DependsSequence DependsList xs DependsList ys) [Depends] rest = DependsList -> [Depends] -> [Depends] f DependsList xs ([Depends] -> [Depends]) -> [Depends] -> [Depends] forall a b. (a -> b) -> a -> b $ DependsList -> [Depends] -> [Depends] f DependsList ys [Depends] rest f (DependsSequence1 DependsList xs Depends y) [Depends] rest = DependsList -> [Depends] -> [Depends] f DependsList xs (Depends yDepends -> [Depends] -> [Depends] forall a. a -> [a] -> [a] :[Depends] rest) f (DependsParallel []) [Depends] rest = [Depends] rest f (DependsParallel (DependsList x:[DependsList] xs)) [Depends] rest = DependsList -> [Depends] -> [Depends] f DependsList x ([Depends] -> [Depends]) -> [Depends] -> [Depends] forall a b. (a -> b) -> a -> b $ DependsList -> [Depends] -> [Depends] f ([DependsList] -> DependsList DependsParallel [DependsList] xs) [Depends] rest -- | Define a rule between @key@ and @value@. As an example, a typical 'BuiltinRun' will look like: -- -- > run key oldStore mode = do -- > ... -- > pure $ RunResult change newStore newValue -- -- Where you have: -- -- * @key@, how to identify individual artifacts, e.g. with file names. -- -- * @oldStore@, the value stored in the database previously, e.g. the file modification time. -- -- * @mode@, either 'RunDependenciesSame' (none of your dependencies changed, you can probably not rebuild) or -- 'RunDependenciesChanged' (your dependencies changed, probably rebuild). -- -- * @change@, usually one of either 'ChangedNothing' (no work was required) or 'ChangedRecomputeDiff' -- (I reran the rule and it should be considered different). -- -- * @newStore@, the new value to store in the database, which will be passed in next time as @oldStore@. -- -- * @newValue@, the result that 'Development.Shake.Rule.apply' will return when asked for the given @key@. type BuiltinRun key value = key -> Maybe BS.ByteString -> RunMode -> Action (RunResult value) -- | The action performed by @--lint@ for a given @key@/@value@ pair. -- At the end of the build the lint action will be called for each @key@ that was built this run, -- passing the @value@ it produced. Return 'Nothing' to indicate the value has not changed and -- is acceptable, or 'Just' an error message to indicate failure. -- -- For builtin rules where the value is expected to change, or has no useful checks to perform. -- use 'Development.Shake.Rules.noLint'. type BuiltinLint key value = key -> value -> IO (Maybe String) -- | Produce an identity for a @value@ that can be used to do direct equality. If you have a custom -- notion of equality then the result should return only one member from each equivalence class, -- as values will be compared for literal equality. -- The result of the identity should be reasonably short (if it is excessively long, hash it). -- -- For rules where the value is never compatible use 'Development.Shake.Rules.noIdentity', which -- returns 'Nothing'. This will disable shared caches of anything that depends on it. type BuiltinIdentity key value = key -> value -> Maybe BS.ByteString data BuiltinRule = BuiltinRule {BuiltinRule -> BuiltinLint Key Value builtinLint :: BuiltinLint Key Value ,BuiltinRule -> BuiltinIdentity Key Value builtinIdentity :: BuiltinIdentity Key Value ,BuiltinRule -> BuiltinRun Key Value builtinRun :: BuiltinRun Key Value ,BuiltinRule -> BinaryOp Key builtinKey :: BinaryOp Key ,BuiltinRule -> Ver builtinVersion :: Ver ,BuiltinRule -> String builtinLocation :: String } -- | A 'UserRule' data type, representing user-defined rules associated with a particular type. -- As an example 'Development.Shake.?>' and 'Development.Shake.%>' will add entries to the 'UserRule' data type. data UserRule a -- > priority p1 (priority p2 x) == priority p1 x -- > priority p (x `ordered` y) = priority p x `ordered` priority p y -- > priority p (x `unordered` y) = priority p x `unordered` priority p y -- > ordered is associative -- > unordered is associative and commutative -- > alternative does not obey priorities, until picking the best one = UserRule a -- ^ Added to the state with @'addUserRule' :: Typeable a => a -> 'Rules' ()@. | Unordered [UserRule a] -- ^ Rules combined with the 'Monad' \/ 'Monoid'. | Priority Double (UserRule a) -- ^ Rules defined under 'priority'. | Alternative (UserRule a) -- ^ Rule defined under 'alternatives', matched in order. | Versioned Ver (UserRule a) -- ^ Rule defined under 'versioned', attaches a version. deriving (UserRule a -> UserRule a -> Bool (UserRule a -> UserRule a -> Bool) -> (UserRule a -> UserRule a -> Bool) -> Eq (UserRule a) forall a. Eq a => UserRule a -> UserRule a -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: UserRule a -> UserRule a -> Bool $c/= :: forall a. Eq a => UserRule a -> UserRule a -> Bool == :: UserRule a -> UserRule a -> Bool $c== :: forall a. Eq a => UserRule a -> UserRule a -> Bool Eq,Int -> UserRule a -> ShowS [UserRule a] -> ShowS UserRule a -> String (Int -> UserRule a -> ShowS) -> (UserRule a -> String) -> ([UserRule a] -> ShowS) -> Show (UserRule a) forall a. Show a => Int -> UserRule a -> ShowS forall a. Show a => [UserRule a] -> ShowS forall a. Show a => UserRule a -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [UserRule a] -> ShowS $cshowList :: forall a. Show a => [UserRule a] -> ShowS show :: UserRule a -> String $cshow :: forall a. Show a => UserRule a -> String showsPrec :: Int -> UserRule a -> ShowS $cshowsPrec :: forall a. Show a => Int -> UserRule a -> ShowS Show,a -> UserRule b -> UserRule a (a -> b) -> UserRule a -> UserRule b (forall a b. (a -> b) -> UserRule a -> UserRule b) -> (forall a b. a -> UserRule b -> UserRule a) -> Functor UserRule forall a b. a -> UserRule b -> UserRule a forall a b. (a -> b) -> UserRule a -> UserRule b forall (f :: * -> *). (forall a b. (a -> b) -> f a -> f b) -> (forall a b. a -> f b -> f a) -> Functor f <$ :: a -> UserRule b -> UserRule a $c<$ :: forall a b. a -> UserRule b -> UserRule a fmap :: (a -> b) -> UserRule a -> UserRule b $cfmap :: forall a b. (a -> b) -> UserRule a -> UserRule b Functor,Typeable) data UserRuleVersioned a = UserRuleVersioned {UserRuleVersioned a -> Bool userRuleVersioned :: Bool -- ^ Does Versioned exist anywhere within userRuleContents ,UserRuleVersioned a -> UserRule a userRuleContents :: UserRule a -- ^ The actual rules } instance Semigroup (UserRuleVersioned a) where UserRuleVersioned Bool b1 UserRule a x1 <> :: UserRuleVersioned a -> UserRuleVersioned a -> UserRuleVersioned a <> UserRuleVersioned Bool b2 UserRule a x2 = Bool -> UserRule a -> UserRuleVersioned a forall a. Bool -> UserRule a -> UserRuleVersioned a UserRuleVersioned (Bool b1 Bool -> Bool -> Bool || Bool b2) (UserRule a x1 UserRule a -> UserRule a -> UserRule a forall a. Semigroup a => a -> a -> a <> UserRule a x2) instance Monoid (UserRuleVersioned a) where mempty :: UserRuleVersioned a mempty = Bool -> UserRule a -> UserRuleVersioned a forall a. Bool -> UserRule a -> UserRuleVersioned a UserRuleVersioned Bool False UserRule a forall a. Monoid a => a mempty mappend :: UserRuleVersioned a -> UserRuleVersioned a -> UserRuleVersioned a mappend = UserRuleVersioned a -> UserRuleVersioned a -> UserRuleVersioned a forall a. Semigroup a => a -> a -> a (<>) instance Semigroup (UserRule a) where UserRule a x <> :: UserRule a -> UserRule a -> UserRule a <> UserRule a y = [UserRule a] -> UserRule a forall a. [UserRule a] -> UserRule a Unordered [UserRule a x,UserRule a y] instance Monoid (UserRule a) where mempty :: UserRule a mempty = [UserRule a] -> UserRule a forall a. [UserRule a] -> UserRule a Unordered [] mappend :: UserRule a -> UserRule a -> UserRule a mappend = UserRule a -> UserRule a -> UserRule a forall a. Semigroup a => a -> a -> a (<>) userRuleSize :: UserRule a -> Int userRuleSize :: UserRule a -> Int userRuleSize UserRule{} = Int 1 userRuleSize (Unordered [UserRule a] xs) = [Int] -> Int forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a sum ([Int] -> Int) -> [Int] -> Int forall a b. (a -> b) -> a -> b $ (UserRule a -> Int) -> [UserRule a] -> [Int] forall a b. (a -> b) -> [a] -> [b] map UserRule a -> Int forall a. UserRule a -> Int userRuleSize [UserRule a] xs userRuleSize (Priority Seconds _ UserRule a x) = UserRule a -> Int forall a. UserRule a -> Int userRuleSize UserRule a x userRuleSize (Alternative UserRule a x) = UserRule a -> Int forall a. UserRule a -> Int userRuleSize UserRule a x userRuleSize (Versioned Ver _ UserRule a x) = UserRule a -> Int forall a. UserRule a -> Int userRuleSize UserRule a x type Database = DatabasePoly Key Status -- global constants of Action data Global = Global {Global -> [String] -> [Key] -> Action [Value] globalBuild :: [String] -> [Key] -> Action [Value] ,Global -> Database globalDatabase :: Database -- ^ Database, contains knowledge of the state of each key ,Global -> Pool globalPool :: Pool -- ^ Pool, for queuing new elements ,Global -> Cleanup globalCleanup :: Cleanup -- ^ Cleanup operations ,Global -> IO Seconds globalTimestamp :: IO Seconds -- ^ Clock saying how many seconds through the build ,Global -> HashMap TypeRep BuiltinRule globalRules :: Map.HashMap TypeRep BuiltinRule -- ^ Rules for this build ,Global -> Verbosity -> String -> IO () globalOutput :: Verbosity -> String -> IO () -- ^ Output function ,Global -> ShakeOptions globalOptions :: ShakeOptions -- ^ Shake options ,Global -> IO String -> IO () globalDiagnostic :: IO String -> IO () -- ^ Debugging function ,Global -> Key -> Action () globalRuleFinished :: Key -> Action () -- ^ actions to run after each rule ,Global -> IORef [IO ()] globalAfter :: IORef [IO ()] -- ^ Operations to run on success, e.g. removeFilesAfter ,Global -> IORef [(Key, Key)] globalTrackAbsent :: IORef [(Key, Key)] -- ^ Tracked things, in rule fst, snd must be absent ,Global -> IO Progress globalProgress :: IO Progress -- ^ Request current progress state ,Global -> Map UserRuleVersioned globalUserRules :: TMap.Map UserRuleVersioned , :: Maybe Shared -- ^ The active shared state, if any ,Global -> Maybe Cloud globalCloud :: Maybe Cloud ,Global -> Step globalStep :: {-# UNPACK #-} !Step ,Global -> Bool globalOneShot :: Bool -- ^ I am running in one-shot mode so don't need to store BS's for Result/Failed } -- local variables of Action data Local = Local -- constants {Local -> Stack localStack :: Stack -- ^ The stack that ran to get here. ,Local -> Ver localBuiltinVersion :: Ver -- ^ The builtinVersion of the rule you are running -- stack scoped local variables ,Local -> Verbosity localVerbosity :: Verbosity -- ^ Verbosity, may be changed locally ,Local -> Maybe String localBlockApply :: Maybe String -- ^ Reason to block apply, or Nothing to allow -- mutable local variables ,Local -> DependsList localDepends :: DependsList -- ^ Dependencies that we rely on, morally a list of sets ,Local -> Seconds localDiscount :: !Seconds -- ^ Time spend building dependencies (may be negative for parallel) ,Local -> Traces localTraces :: Traces -- ^ Traces that have occurred ,Local -> [Key -> Bool] localTrackAllows :: [Key -> Bool] -- ^ Things that are allowed to be used ,Local -> [Key] localTrackRead :: [Key] -- ^ Calls to 'lintTrackRead' ,Local -> [Key] localTrackWrite :: [Key] -- ^ Calls to 'lintTrackWrite' ,Local -> [(Bool, String)] localProduces :: [(Bool, FilePath)] -- ^ Things this rule produces, True to check them ,Local -> Bool localHistory :: !Bool -- ^ Is it valid to cache the result } data Traces = TracesNone -- no traces | TracesSequence1 Traces Trace -- Like TracesSequence but with 1 element | TracesSequence Traces Traces -- first the Traces happened, then Traces that happened after | TracesParallel [Traces] -- these traces happened in parallel with each other flattenTraces :: Traces -> [Trace] flattenTraces :: Traces -> [Trace] flattenTraces Traces t = Traces -> [Trace] -> [Trace] f Traces t [] where f :: Traces -> [Trace] -> [Trace] f Traces TracesNone [Trace] rest = [Trace] rest f (TracesSequence1 Traces a Trace b) [Trace] rest = Traces -> [Trace] -> [Trace] f Traces a (Trace bTrace -> [Trace] -> [Trace] forall a. a -> [a] -> [a] :[Trace] rest) f (TracesSequence Traces a Traces b) [Trace] rest = Traces -> [Trace] -> [Trace] f Traces a ([Trace] -> [Trace]) -> [Trace] -> [Trace] forall a b. (a -> b) -> a -> b $ Traces -> [Trace] -> [Trace] f Traces b [Trace] rest f (TracesParallel []) [Trace] rest = [Trace] rest -- Might want to resort them by time started? f (TracesParallel (Traces x:[Traces] xs)) [Trace] rest = Traces -> [Trace] -> [Trace] f Traces x ([Trace] -> [Trace]) -> [Trace] -> [Trace] forall a b. (a -> b) -> a -> b $ Traces -> [Trace] -> [Trace] f ([Traces] -> Traces TracesParallel [Traces] xs) [Trace] rest addTrace :: Traces -> Trace -> Traces addTrace :: Traces -> Trace -> Traces addTrace Traces ts Trace t = Traces ts Traces -> Trace -> Traces `TracesSequence1` Trace t addDiscount :: Seconds -> Local -> Local addDiscount :: Seconds -> Local -> Local addDiscount Seconds s Local l = Local l{localDiscount :: Seconds localDiscount = Seconds s Seconds -> Seconds -> Seconds forall a. Num a => a -> a -> a + Local -> Seconds localDiscount Local l} newLocal :: Stack -> Verbosity -> Local newLocal :: Stack -> Verbosity -> Local newLocal Stack stack Verbosity verb = Stack -> Ver -> Verbosity -> Maybe String -> DependsList -> Seconds -> Traces -> [Key -> Bool] -> [Key] -> [Key] -> [(Bool, String)] -> Bool -> Local Local Stack stack (Int -> Ver Ver Int 0) Verbosity verb Maybe String forall a. Maybe a Nothing DependsList DependsNone Seconds 0 Traces TracesNone [] [] [] [] Bool True -- Clear all the local mutable variables localClearMutable :: Local -> Local localClearMutable :: Local -> Local localClearMutable Local{Bool Seconds [(Bool, String)] [Key] [Key -> Bool] Maybe String Ver Verbosity Traces DependsList Stack localHistory :: Bool localProduces :: [(Bool, String)] localTrackWrite :: [Key] localTrackRead :: [Key] localTrackAllows :: [Key -> Bool] localTraces :: Traces localDiscount :: Seconds localDepends :: DependsList localBlockApply :: Maybe String localVerbosity :: Verbosity localBuiltinVersion :: Ver localStack :: Stack localHistory :: Local -> Bool localProduces :: Local -> [(Bool, String)] localTrackWrite :: Local -> [Key] localTrackRead :: Local -> [Key] localTrackAllows :: Local -> [Key -> Bool] localTraces :: Local -> Traces localDiscount :: Local -> Seconds localDepends :: Local -> DependsList localBlockApply :: Local -> Maybe String localVerbosity :: Local -> Verbosity localBuiltinVersion :: Local -> Ver localStack :: Local -> Stack ..} = (Stack -> Verbosity -> Local newLocal Stack localStack Verbosity localVerbosity){localBlockApply :: Maybe String localBlockApply=Maybe String localBlockApply, localBuiltinVersion :: Ver localBuiltinVersion=Ver localBuiltinVersion} -- Merge, works well assuming you clear the variables first with localClearMutable. -- Assume the first was run sequentially, and the list in parallel. localMergeMutable :: Local -> [Local] -> Local -- don't construct with RecordWildCards so any new fields raise an error localMergeMutable :: Local -> [Local] -> Local localMergeMutable Local root [Local] xs = Local :: Stack -> Ver -> Verbosity -> Maybe String -> DependsList -> Seconds -> Traces -> [Key -> Bool] -> [Key] -> [Key] -> [(Bool, String)] -> Bool -> Local Local -- immutable/stack that need copying {localStack :: Stack localStack = Local -> Stack localStack Local root ,localBuiltinVersion :: Ver localBuiltinVersion = Local -> Ver localBuiltinVersion Local root ,localVerbosity :: Verbosity localVerbosity = Local -> Verbosity localVerbosity Local root ,localBlockApply :: Maybe String localBlockApply = Local -> Maybe String localBlockApply Local root -- mutable locals that need integrating -- note that a lot of the lists are stored in reverse, assume root happened first ,localDepends :: DependsList localDepends = [DependsList] -> DependsList DependsParallel ((Local -> DependsList) -> [Local] -> [DependsList] forall a b. (a -> b) -> [a] -> [b] map Local -> DependsList localDepends [Local] xs) DependsList -> DependsList -> DependsList `DependsSequence` Local -> DependsList localDepends Local root ,localDiscount :: Seconds localDiscount = [Seconds] -> Seconds forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a sum ([Seconds] -> Seconds) -> [Seconds] -> Seconds forall a b. (a -> b) -> a -> b $ (Local -> Seconds) -> [Local] -> [Seconds] forall a b. (a -> b) -> [a] -> [b] map Local -> Seconds localDiscount ([Local] -> [Seconds]) -> [Local] -> [Seconds] forall a b. (a -> b) -> a -> b $ Local root Local -> [Local] -> [Local] forall a. a -> [a] -> [a] : [Local] xs ,localTraces :: Traces localTraces = [Traces] -> Traces TracesParallel ((Local -> Traces) -> [Local] -> [Traces] forall a b. (a -> b) -> [a] -> [b] map Local -> Traces localTraces [Local] xs) Traces -> Traces -> Traces `TracesSequence` Local -> Traces localTraces Local root ,localTrackAllows :: [Key -> Bool] localTrackAllows = Local -> [Key -> Bool] localTrackAllows Local root [Key -> Bool] -> [Key -> Bool] -> [Key -> Bool] forall a. [a] -> [a] -> [a] ++ (Local -> [Key -> Bool]) -> [Local] -> [Key -> Bool] forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap Local -> [Key -> Bool] localTrackAllows [Local] xs ,localTrackRead :: [Key] localTrackRead = Local -> [Key] localTrackRead Local root [Key] -> [Key] -> [Key] forall a. [a] -> [a] -> [a] ++ (Local -> [Key]) -> [Local] -> [Key] forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap Local -> [Key] localTrackRead [Local] xs ,localTrackWrite :: [Key] localTrackWrite = Local -> [Key] localTrackWrite Local root [Key] -> [Key] -> [Key] forall a. [a] -> [a] -> [a] ++ (Local -> [Key]) -> [Local] -> [Key] forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap Local -> [Key] localTrackWrite [Local] xs ,localProduces :: [(Bool, String)] localProduces = (Local -> [(Bool, String)]) -> [Local] -> [(Bool, String)] forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap Local -> [(Bool, String)] localProduces [Local] xs [(Bool, String)] -> [(Bool, String)] -> [(Bool, String)] forall a. [a] -> [a] -> [a] ++ Local -> [(Bool, String)] localProduces Local root ,localHistory :: Bool localHistory = (Local -> Bool) -> [Local] -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all Local -> Bool localHistory ([Local] -> Bool) -> [Local] -> Bool forall a b. (a -> b) -> a -> b $ Local rootLocal -> [Local] -> [Local] forall a. a -> [a] -> [a] :[Local] xs }