{-# LANGUAGE RecordWildCards, PatternGuards, DeriveFunctor #-}
{-# LANGUAGE Rank2Types, FlexibleInstances #-}
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Development.Shake.Internal.Core.Database(
Trace(..), newTrace,
Database, withDatabase, assertFinishedDatabase,
listDepends, lookupDependencies, lookupStatus,
BuildKey(..), build,
Depends, nubDepends,
Step, Result(..),
progress,
Stack, emptyStack, topStack, showStack, showTopStack,
toReport, checkValid, listLive
) where
import Development.Shake.Classes
import General.Binary
import Development.Shake.Internal.Core.Pool
import Development.Shake.Internal.Value
import Development.Shake.Internal.Errors
import Development.Shake.Internal.Core.Storage
import Development.Shake.Internal.Options
import Development.Shake.Internal.Profile
import Development.Shake.Internal.Core.Monad
import Development.Shake.Internal.Core.Rendezvous
import qualified Data.ByteString.Char8 as BS
import Data.Word
import General.Extra
import qualified General.Intern as Intern
import General.Intern(Id, Intern)
import Numeric.Extra
import Control.Applicative
import Control.Exception
import Control.Monad.Extra
import Control.Concurrent.Extra
import qualified Data.HashSet as Set
import qualified Data.HashMap.Strict as Map
import qualified General.Ids as Ids
import Foreign.Storable
import Data.Typeable.Extra
import Data.IORef.Extra
import Data.Maybe
import Data.List
import Data.Tuple.Extra
import Data.Either.Extra
import System.Time.Extra
import Data.Monoid
import Prelude
type Map = Map.HashMap
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 i :: 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
+ 1
data Stack = Stack [(Id,Key)] !(Set.HashSet Id)
showStack :: Stack -> [String]
showStack :: Stack -> [String]
showStack (Stack xs :: [(Id, Key)]
xs _) = [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ((Id, Key) -> String) -> [(Id, Key)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Key -> String
forall a. Show a => a -> String
show (Key -> String) -> ((Id, Key) -> Key) -> (Id, Key) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, Key) -> Key
forall a b. (a, b) -> b
snd) [(Id, Key)]
xs
showTopStack :: Stack -> String
showTopStack :: Stack -> String
showTopStack = String -> (Key -> String) -> Maybe Key -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "<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 -> Stack
addStack :: Id -> Key -> Stack -> Stack
addStack x :: Id
x key :: Key
key (Stack xs :: [(Id, Key)]
xs set :: HashSet Id
set) = [(Id, Key)] -> HashSet Id -> Stack
Stack ((Id
x,Key
key)(Id, Key) -> [(Id, Key)] -> [(Id, Key)]
forall a. a -> [a] -> [a]
:[(Id, Key)]
xs) (Id -> HashSet Id -> HashSet Id
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.insert Id
x HashSet Id
set)
topStack :: Stack -> Maybe Key
topStack :: Stack -> Maybe Key
topStack (Stack xs :: [(Id, Key)]
xs _) = (Id, Key) -> Key
forall a b. (a, b) -> b
snd ((Id, Key) -> Key) -> Maybe (Id, Key) -> Maybe Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Id, Key)] -> Maybe (Id, Key)
forall a. [a] -> Maybe a
listToMaybe [(Id, Key)]
xs
checkStack :: [Id] -> Stack -> Maybe (Id,Key)
checkStack :: [Id] -> Stack -> Maybe (Id, Key)
checkStack new :: [Id]
new (Stack xs :: [(Id, Key)]
xs set :: HashSet Id
set)
| bad :: Id
bad:_ <- (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter (Id -> HashSet Id -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`Set.member` HashSet Id
set) [Id]
new = (Id, Key) -> Maybe (Id, Key)
forall a. a -> Maybe a
Just (Id
bad, Maybe Key -> Key
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Key -> Key) -> Maybe Key -> Key
forall a b. (a -> b) -> a -> b
$ Id -> [(Id, Key)] -> Maybe Key
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Id
bad [(Id, Key)]
xs)
| Bool
otherwise = Maybe (Id, Key)
forall a. Maybe a
Nothing
emptyStack :: Stack
emptyStack :: Stack
emptyStack = [(Id, Key)] -> HashSet Id -> Stack
Stack [] HashSet Id
forall a. HashSet a
Set.empty
data Trace = Trace {-# UNPACK #-} !BS.ByteString {-# UNPACK #-} !Float {-# 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 x :: Trace
x = Trace
x Trace -> () -> ()
forall a b. a -> b -> b
`seq` ()
newTrace :: String -> Double -> Double -> Trace
newTrace :: String -> Double -> Double -> Trace
newTrace msg :: String
msg start :: Double
start stop :: Double
stop = ByteString -> Float -> Float -> Trace
Trace (String -> ByteString
BS.pack String
msg) (Double -> Float
doubleToFloat Double
start) (Double -> Float
doubleToFloat Double
stop)
type StatusDB = Ids.Ids (Key, Status)
type InternDB = IORef (Intern Key)
data Database = Database
{Database -> Lock
lock :: Lock
,Database -> InternDB
intern :: InternDB
,Database -> StatusDB
status :: StatusDB
,Database -> Step
step :: {-# UNPACK #-} !Step
,Database -> Id -> Key -> Result ByteString -> IO ()
journal :: Id -> Key -> Result BS.ByteString -> IO ()
,Database -> IO String -> IO ()
diagnostic :: IO String -> IO ()
}
data Status
= Ready (Result Value)
| Error SomeException
| Loaded (Result BS.ByteString)
| Waiting (Waiting Status) (Maybe (Result BS.ByteString))
| Missing
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 x :: Status
x = case Status
x of
Ready x :: Result Value
x -> (Value -> ()) -> Result Value -> ()
forall t t. (t -> t) -> Result t -> ()
rnfResult Value -> ()
forall a. NFData a => a -> ()
rnf Result Value
x
Error x :: SomeException
x -> String -> ()
forall a. NFData a => a -> ()
rnf (String -> ()) -> String -> ()
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
x
Loaded x :: Result ByteString
x -> (ByteString -> ByteString) -> Result ByteString -> ()
forall t t. (t -> t) -> Result t -> ()
rnfResult ByteString -> ByteString
forall a. a -> a
id Result ByteString
x
Waiting _ x :: Maybe (Result ByteString)
x -> () -> (Result ByteString -> ()) -> Maybe (Result ByteString) -> ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe () ((ByteString -> ByteString) -> Result ByteString -> ()
forall t t. (t -> t) -> Result t -> ()
rnfResult ByteString -> ByteString
forall a. a -> a
id) Maybe (Result ByteString)
x
Missing -> ()
where
rnfResult :: (t -> t) -> Result t -> ()
rnfResult by :: t -> t
by (Result a :: t
a _ _ b :: [Depends]
b _ c :: [Trace]
c) = t -> t
by t
a t -> () -> ()
forall a b. a -> b -> b
`seq` [Depends] -> ()
forall a. NFData a => a -> ()
rnf [Depends]
b () -> () -> ()
forall a b. a -> b -> b
`seq` [Trace] -> ()
forall a. NFData a => a -> ()
rnf [Trace]
c () -> () -> ()
forall a b. a -> b -> b
`seq` ()
{-# INLINE rnfResult #-}
data Result a = Result
{Result a -> a
result :: a
,Result a -> Step
built :: {-# UNPACK #-} !Step
,Result a -> Step
changed :: {-# UNPACK #-} !Step
,Result a -> [Depends]
depends :: [Depends]
,Result a -> Float
execution :: {-# UNPACK #-} !Float
,Result a -> [Trace]
traces :: [Trace]
} 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)
statusType :: Status -> String
statusType Ready{} = "Ready"
statusType Error{} = "Error"
statusType Loaded{} = "Loaded"
statusType Waiting{} = "Waiting"
statusType Missing{} = "Missing"
getResult :: Status -> Maybe (Result (Either BS.ByteString Value))
getResult :: Status -> Maybe (Result (Either ByteString Value))
getResult (Ready r :: Result Value
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)
-> Result Value -> Result (Either ByteString Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Result Value
r
getResult (Loaded r :: 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 (Waiting _ r :: 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))
-> Maybe (Result ByteString)
-> Maybe (Result (Either ByteString Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Result ByteString)
r
getResult _ = Maybe (Result (Either ByteString Value))
forall a. Maybe a
Nothing
newtype Depends = Depends {Depends -> [Id]
fromDepends :: [Id]}
deriving Depends -> ()
(Depends -> ()) -> NFData Depends
forall a. (a -> ()) -> NFData a
rnf :: Depends -> ()
$crnf :: Depends -> ()
NFData
instance Show Depends where
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
nubDepends :: [Depends] -> [Depends]
nubDepends :: [Depends] -> [Depends]
nubDepends = HashSet Id -> [Depends] -> [Depends]
fMany HashSet Id
forall a. HashSet a
Set.empty
where
fMany :: HashSet Id -> [Depends] -> [Depends]
fMany seen :: HashSet Id
seen [] = []
fMany seen :: HashSet Id
seen (Depends d :: [Id]
d:ds :: [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 (d2 :: [Id]
d2,seen2 :: 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 seen :: HashSet a
seen [] = ([], HashSet a
seen)
fOne seen :: HashSet a
seen (x :: a
x:xs :: [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 seen :: HashSet a
seen (x :: a
x:xs :: [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
newtype BuildKey = BuildKey
{BuildKey
-> Stack
-> Step
-> Key
-> Maybe (Result ByteString)
-> Bool
-> Capture (Either SomeException (Bool, ByteString, Result Value))
buildKey
:: Stack
-> Step
-> Key
-> Maybe (Result BS.ByteString)
-> Bool
-> Capture (Either SomeException (Bool, BS.ByteString, Result Value))
}
type Returns a = forall b . (a -> IO b) -> (Capture a -> IO b) -> IO b
internKey :: InternDB -> StatusDB -> Key -> IO Id
internKey :: InternDB -> StatusDB -> Key -> IO Id
internKey intern :: InternDB
intern status :: StatusDB
status k :: Key
k = do
Intern Key
is <- InternDB -> IO (Intern Key)
forall a. IORef a -> IO a
readIORef InternDB
intern
case Key -> Intern Key -> Maybe Id
forall a. (Eq a, Hashable a) => a -> Intern a -> Maybe Id
Intern.lookup Key
k Intern Key
is of
Just i :: Id
i -> Id -> IO Id
forall (m :: * -> *) a. Monad m => a -> m a
return Id
i
Nothing -> do
(is :: Intern Key
is, i :: Id
i) <- (Intern Key, Id) -> IO (Intern Key, Id)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Intern Key, Id) -> IO (Intern Key, Id))
-> (Intern Key, Id) -> IO (Intern Key, Id)
forall a b. (a -> b) -> a -> b
$ Key -> Intern Key -> (Intern Key, Id)
forall a. (Eq a, Hashable a) => a -> Intern a -> (Intern a, Id)
Intern.add Key
k Intern Key
is
InternDB -> Intern Key -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef' InternDB
intern Intern Key
is
StatusDB -> Id -> (Key, Status) -> IO ()
forall a. Ids a -> Id -> a -> IO ()
Ids.insert StatusDB
status Id
i (Key
k,Status
Missing)
Id -> IO Id
forall (m :: * -> *) a. Monad m => a -> m a
return Id
i
lookupStatus :: Database -> Key -> IO (Maybe (Either BS.ByteString Value))
lookupStatus :: Database -> Key -> IO (Maybe (Either ByteString Value))
lookupStatus Database{..} k :: Key
k = Lock
-> IO (Maybe (Either ByteString Value))
-> IO (Maybe (Either ByteString Value))
forall a. Lock -> IO a -> IO a
withLock Lock
lock (IO (Maybe (Either ByteString Value))
-> IO (Maybe (Either ByteString Value)))
-> IO (Maybe (Either ByteString Value))
-> IO (Maybe (Either ByteString Value))
forall a b. (a -> b) -> a -> b
$ do
Id
i <- InternDB -> StatusDB -> Key -> IO Id
internKey InternDB
intern StatusDB
status Key
k
Maybe (Either ByteString Value)
-> ((Key, Status) -> Maybe (Either ByteString Value))
-> Maybe (Key, Status)
-> Maybe (Either ByteString Value)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe (Either ByteString Value)
forall a. Maybe a
Nothing ((Result (Either ByteString Value) -> Either ByteString Value)
-> Maybe (Result (Either ByteString Value))
-> Maybe (Either ByteString Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Result (Either ByteString Value) -> Either ByteString Value
forall a. Result a -> a
result (Maybe (Result (Either ByteString Value))
-> Maybe (Either ByteString Value))
-> ((Key, Status) -> Maybe (Result (Either ByteString Value)))
-> (Key, Status)
-> Maybe (Either ByteString Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> Maybe (Result (Either ByteString Value))
getResult (Status -> Maybe (Result (Either ByteString Value)))
-> ((Key, Status) -> Status)
-> (Key, Status)
-> Maybe (Result (Either ByteString Value))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, Status) -> Status
forall a b. (a, b) -> b
snd) (Maybe (Key, Status) -> Maybe (Either ByteString Value))
-> IO (Maybe (Key, Status)) -> IO (Maybe (Either ByteString Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StatusDB -> Id -> IO (Maybe (Key, Status))
forall a. Ids a -> Id -> IO (Maybe a)
Ids.lookup StatusDB
status Id
i
build :: Pool -> Database -> BuildKey -> Stack -> [Key] -> Capture (Either SomeException (Seconds,Depends,[Value]))
build :: Pool
-> Database
-> BuildKey
-> Stack
-> [Key]
-> Capture (Either SomeException (Double, Depends, [Value]))
build pool :: Pool
pool Database{..} BuildKey{..} stack :: Stack
stack ks :: [Key]
ks continue :: Either SomeException (Double, Depends, [Value]) -> IO ()
continue =
IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Lock -> IO (IO ()) -> IO (IO ())
forall a. Lock -> IO a -> IO a
withLock Lock
lock (IO (IO ()) -> IO (IO ())) -> IO (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
[Id]
is <- [Key] -> (Key -> IO Id) -> IO [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Key]
ks ((Key -> IO Id) -> IO [Id]) -> (Key -> IO Id) -> IO [Id]
forall a b. (a -> b) -> a -> b
$ InternDB -> StatusDB -> Key -> IO Id
internKey InternDB
intern StatusDB
status
Stack
-> [Id]
-> (Status -> Maybe SomeException)
-> (Either SomeException [Result Value] -> IO (IO ()))
-> (Capture (Either SomeException [Result Value]) -> IO (IO ()))
-> IO (IO ())
forall a.
Stack
-> [Id] -> (Status -> Maybe a) -> Returns (Either a [Result Value])
buildMany Stack
stack [Id]
is
(\v :: Status
v -> case Status
v of Error e :: SomeException
e -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e; _ -> Maybe SomeException
forall a. Maybe a
Nothing)
(\v :: Either SomeException [Result Value]
v -> IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ Either SomeException (Double, Depends, [Value]) -> IO ()
continue (Either SomeException (Double, Depends, [Value]) -> IO ())
-> Either SomeException (Double, Depends, [Value]) -> IO ()
forall a b. (a -> b) -> a -> b
$ case Either SomeException [Result Value]
v of
Left e :: SomeException
e -> SomeException -> Either SomeException (Double, Depends, [Value])
forall a b. a -> Either a b
Left SomeException
e
Right rs :: [Result Value]
rs -> (Double, Depends, [Value])
-> Either SomeException (Double, Depends, [Value])
forall a b. b -> Either a b
Right (0, [Id] -> Depends
Depends [Id]
is, (Result Value -> Value) -> [Result Value] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Result Value -> Value
forall a. Result a -> a
result [Result Value]
rs)) ((Capture (Either SomeException [Result Value]) -> IO (IO ()))
-> IO (IO ()))
-> (Capture (Either SomeException [Result Value]) -> IO (IO ()))
-> IO (IO ())
forall a b. (a -> b) -> a -> b
$
\go :: Capture (Either SomeException [Result Value])
go -> do
Maybe (Id, Key) -> ((Id, Key) -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust ([Id] -> Stack -> Maybe (Id, Key)
checkStack [Id]
is Stack
stack) (((Id, Key) -> IO ()) -> IO ()) -> ((Id, Key) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(badId :: Id
badId, badKey :: Key
badKey) ->
[String] -> TypeRep -> String -> IO ()
forall a. [String] -> TypeRep -> String -> IO a
errorRuleRecursion (Stack -> [String]
showStack Stack
stack [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [Key -> String
forall a. Show a => a -> String
show Key
badKey]) (Key -> TypeRep
typeKey Key
badKey) (Key -> String
forall a. Show a => a -> String
show Key
badKey)
IO Double
time <- IO (IO Double)
offsetTime
Capture (Either SomeException [Result Value])
go Capture (Either SomeException [Result Value])
-> Capture (Either SomeException [Result Value])
forall a b. (a -> b) -> a -> b
$ \x :: Either SomeException [Result Value]
x -> case Either SomeException [Result Value]
x of
Left e :: SomeException
e -> Pool -> IO () -> IO ()
forall a. Pool -> IO a -> IO ()
addPoolException Pool
pool (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Either SomeException (Double, Depends, [Value]) -> IO ()
continue (Either SomeException (Double, Depends, [Value]) -> IO ())
-> Either SomeException (Double, Depends, [Value]) -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException (Double, Depends, [Value])
forall a b. a -> Either a b
Left SomeException
e
Right rs :: [Result Value]
rs -> Pool -> IO () -> IO ()
forall a. Pool -> IO a -> IO ()
addPoolResume Pool
pool (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do Double
dur <- IO Double
time; Either SomeException (Double, Depends, [Value]) -> IO ()
continue (Either SomeException (Double, Depends, [Value]) -> IO ())
-> Either SomeException (Double, Depends, [Value]) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Double, Depends, [Value])
-> Either SomeException (Double, Depends, [Value])
forall a b. b -> Either a b
Right (Double
dur, [Id] -> Depends
Depends [Id]
is, (Result Value -> Value) -> [Result Value] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Result Value -> Value
forall a. Result a -> a
result [Result Value]
rs)
IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
(#=) :: Id -> (Key, Status) -> IO Status
i :: Id
i #= :: Id -> (Key, Status) -> IO Status
#= (k :: Key
k,v :: Status
v) = do
IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Maybe (Key, Status)
old <- StatusDB -> Id -> IO (Maybe (Key, Status))
forall a. Ids a -> Id -> IO (Maybe a)
Ids.lookup StatusDB
status Id
i
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
-> ((Key, Status) -> String) -> Maybe (Key, Status) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "Missing" (Status -> String
statusType (Status -> String)
-> ((Key, Status) -> Status) -> (Key, Status) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, Status) -> Status
forall a b. (a, b) -> b
snd) Maybe (Key, Status)
old String -> ShowS
forall a. [a] -> [a] -> [a]
++ " -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Status -> String
statusType Status
v String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
-> ((Key, Status) -> String) -> Maybe (Key, Status) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "<unknown>" (Key -> String
forall a. Show a => a -> String
show (Key -> String)
-> ((Key, Status) -> Key) -> (Key, Status) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, Status) -> Key
forall a b. (a, b) -> a
fst) Maybe (Key, Status)
old
StatusDB -> Id -> (Key, Status) -> IO ()
forall a. Ids a -> Id -> a -> IO ()
Ids.insert StatusDB
status Id
i (Key
k,Status
v)
Status -> IO Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
v
buildMany :: Stack -> [Id] -> (Status -> Maybe a) -> Returns (Either a [Result Value])
buildMany :: Stack
-> [Id] -> (Status -> Maybe a) -> Returns (Either a [Result Value])
buildMany stack :: Stack
stack is :: [Id]
is test :: Status -> Maybe a
test fast :: Either a [Result Value] -> IO b
fast slow :: Capture (Either a [Result Value]) -> IO b
slow = do
let toAnswer :: Status -> Answer a (Result Value)
toAnswer v :: Status
v | Just v :: a
v <- Status -> Maybe a
test Status
v = a -> Answer a (Result Value)
forall a c. a -> Answer a c
Abort a
v
toAnswer (Ready v :: Result Value
v) = Result Value -> Answer a (Result Value)
forall a c. c -> Answer a c
Continue Result Value
v
let toCompute :: Status -> Compute (Answer a (Result Value))
toCompute (Waiting w :: Waiting Status
w _) = Waiting (Answer a (Result Value))
-> Compute (Answer a (Result Value))
forall a. Waiting a -> Compute a
Later (Waiting (Answer a (Result Value))
-> Compute (Answer a (Result Value)))
-> Waiting (Answer a (Result Value))
-> Compute (Answer a (Result Value))
forall a b. (a -> b) -> a -> b
$ Status -> Answer a (Result Value)
toAnswer (Status -> Answer a (Result Value))
-> Waiting Status -> Waiting (Answer a (Result Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Waiting Status
w
toCompute x :: Status
x = Answer a (Result Value) -> Compute (Answer a (Result Value))
forall a. a -> Compute a
Now (Answer a (Result Value) -> Compute (Answer a (Result Value)))
-> Answer a (Result Value) -> Compute (Answer a (Result Value))
forall a b. (a -> b) -> a -> b
$ Status -> Answer a (Result Value)
toAnswer Status
x
Compute (Either a [Result Value])
res <- [Compute (Answer a (Result Value))]
-> IO (Compute (Either a [Result Value]))
forall a c. [Compute (Answer a c)] -> IO (Compute (Either a [c]))
rendezvous ([Compute (Answer a (Result Value))]
-> IO (Compute (Either a [Result Value])))
-> IO [Compute (Answer a (Result Value))]
-> IO (Compute (Either a [Result Value]))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Id -> IO (Compute (Answer a (Result Value))))
-> [Id] -> IO [Compute (Answer a (Result Value))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Status -> Compute (Answer a (Result Value)))
-> IO Status -> IO (Compute (Answer a (Result Value)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Status -> Compute (Answer a (Result Value))
toCompute (IO Status -> IO (Compute (Answer a (Result Value))))
-> (Id -> IO Status)
-> Id
-> IO (Compute (Answer a (Result Value)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> Id -> IO Status
reduce Stack
stack) [Id]
is
case Compute (Either a [Result Value])
res of
Now v :: Either a [Result Value]
v -> Either a [Result Value] -> IO b
fast Either a [Result Value]
v
Later w :: Waiting (Either a [Result Value])
w -> Capture (Either a [Result Value]) -> IO b
slow (Capture (Either a [Result Value]) -> IO b)
-> Capture (Either a [Result Value]) -> IO b
forall a b. (a -> b) -> a -> b
$ \slow :: Either a [Result Value] -> IO ()
slow -> Waiting (Either a [Result Value])
-> Capture (Either a [Result Value])
forall a. Waiting a -> (a -> IO ()) -> IO ()
afterWaiting Waiting (Either a [Result Value])
w Either a [Result Value] -> IO ()
slow
reduce :: Stack -> Id -> IO Status
reduce :: Stack -> Id -> IO Status
reduce stack :: Stack
stack i :: Id
i = do
Maybe (Key, Status)
s <- StatusDB -> Id -> IO (Maybe (Key, Status))
forall a. Ids a -> Id -> IO (Maybe a)
Ids.lookup StatusDB
status Id
i
case Maybe (Key, Status)
s of
Nothing -> String -> IO Status
forall a. String -> a
errorInternal (String -> IO Status) -> String -> IO Status
forall a b. (a -> b) -> a -> b
$ "interned value missing from database, " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Id -> String
forall a. Show a => a -> String
show Id
i
Just (k :: Key
k, Missing) -> Bool
-> Stack -> Id -> Key -> Maybe (Result ByteString) -> IO Status
spawn Bool
True Stack
stack Id
i Key
k Maybe (Result ByteString)
forall a. Maybe a
Nothing
Just (k :: Key
k, Loaded r :: Result ByteString
r) -> Stack -> Id -> Key -> Result ByteString -> [Depends] -> IO Status
check Stack
stack Id
i Key
k Result ByteString
r (Result ByteString -> [Depends]
forall a. Result a -> [Depends]
depends Result ByteString
r)
Just (k :: Key
k, res :: Status
res) -> Status -> IO Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
res
check :: Stack -> Id -> Key -> Result BS.ByteString -> [Depends] -> IO Status
check :: Stack -> Id -> Key -> Result ByteString -> [Depends] -> IO Status
check stack :: Stack
stack i :: Id
i k :: Key
k r :: Result ByteString
r [] = Bool
-> Stack -> Id -> Key -> Maybe (Result ByteString) -> IO Status
spawn Bool
False Stack
stack Id
i Key
k (Maybe (Result ByteString) -> IO Status)
-> Maybe (Result ByteString) -> IO Status
forall a b. (a -> b) -> a -> b
$ Result ByteString -> Maybe (Result ByteString)
forall a. a -> Maybe a
Just Result ByteString
r
check stack :: Stack
stack i :: Id
i k :: Key
k r :: Result ByteString
r (Depends ds :: [Id]
ds:rest :: [Depends]
rest) = do
let cont :: Either a b -> IO Status
cont v :: Either a b
v = if Either a b -> Bool
forall a b. Either a b -> Bool
isLeft Either a b
v then Bool
-> Stack -> Id -> Key -> Maybe (Result ByteString) -> IO Status
spawn Bool
True Stack
stack Id
i Key
k (Maybe (Result ByteString) -> IO Status)
-> Maybe (Result ByteString) -> IO Status
forall a b. (a -> b) -> a -> b
$ Result ByteString -> Maybe (Result ByteString)
forall a. a -> Maybe a
Just Result ByteString
r else Stack -> Id -> Key -> Result ByteString -> [Depends] -> IO Status
check Stack
stack Id
i Key
k Result ByteString
r [Depends]
rest
Stack
-> [Id]
-> (Status -> Maybe ())
-> (Either () [Result Value] -> IO Status)
-> (Capture (Either () [Result Value]) -> IO Status)
-> IO Status
forall a.
Stack
-> [Id] -> (Status -> Maybe a) -> Returns (Either a [Result Value])
buildMany (Id -> Key -> Stack -> Stack
addStack Id
i Key
k Stack
stack) [Id]
ds
(\v :: Status
v -> case Status
v of
Error _ -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
Ready dep :: Result Value
dep | Result Value -> Step
forall a. Result a -> Step
changed Result Value
dep Step -> Step -> Bool
forall a. Ord a => a -> a -> Bool
> Result ByteString -> Step
forall a. Result a -> Step
built Result ByteString
r -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
_ -> Maybe ()
forall a. Maybe a
Nothing)
Either () [Result Value] -> IO Status
forall a b. Either a b -> IO Status
cont ((Capture (Either () [Result Value]) -> IO Status) -> IO Status)
-> (Capture (Either () [Result Value]) -> IO Status) -> IO Status
forall a b. (a -> b) -> a -> b
$
\go :: Capture (Either () [Result Value])
go -> do
(self :: Waiting Status
self, done :: Status -> IO ()
done) <- IO (Waiting Status, Status -> IO ())
forall a. IO (Waiting a, a -> IO ())
newWaiting
Capture (Either () [Result Value])
go Capture (Either () [Result Value])
-> Capture (Either () [Result Value])
forall a b. (a -> b) -> a -> b
$ \v :: Either () [Result Value]
v -> do
Status
res <- Either () [Result Value] -> IO Status
forall a b. Either a b -> IO Status
cont Either () [Result Value]
v
case Status
res of
Waiting w :: Waiting Status
w _ -> Waiting Status -> (Status -> IO ()) -> IO ()
forall a. Waiting a -> (a -> IO ()) -> IO ()
afterWaiting Waiting Status
w Status -> IO ()
done
_ -> Status -> IO ()
done Status
res
Id
i Id -> (Key, Status) -> IO Status
#= (Key
k, Waiting Status -> Maybe (Result ByteString) -> Status
Waiting Waiting Status
self (Maybe (Result ByteString) -> Status)
-> Maybe (Result ByteString) -> Status
forall a b. (a -> b) -> a -> b
$ Result ByteString -> Maybe (Result ByteString)
forall a. a -> Maybe a
Just Result ByteString
r)
spawn :: Bool -> Stack -> Id -> Key -> Maybe (Result BS.ByteString) -> IO Status
spawn :: Bool
-> Stack -> Id -> Key -> Maybe (Result ByteString) -> IO Status
spawn dirtyChildren :: Bool
dirtyChildren stack :: Stack
stack i :: Id
i k :: Key
k r :: Maybe (Result ByteString)
r = do
(w :: Waiting Status
w, done :: Status -> IO ()
done) <- IO (Waiting Status, Status -> IO ())
forall a. IO (Waiting a, a -> IO ())
newWaiting
Pool -> IO () -> IO ()
forall a. Pool -> IO a -> IO ()
addPoolStart Pool
pool (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Stack
-> Step
-> Key
-> Maybe (Result ByteString)
-> Bool
-> Capture (Either SomeException (Bool, ByteString, Result Value))
buildKey (Id -> Key -> Stack -> Stack
addStack Id
i Key
k Stack
stack) Step
step Key
k Maybe (Result ByteString)
r Bool
dirtyChildren Capture (Either SomeException (Bool, ByteString, Result Value))
-> Capture (Either SomeException (Bool, ByteString, Result Value))
forall a b. (a -> b) -> a -> b
$ \res :: Either SomeException (Bool, ByteString, Result Value)
res -> do
let status :: Status
status = (SomeException -> Status)
-> ((Bool, ByteString, Result Value) -> Status)
-> Either SomeException (Bool, ByteString, Result Value)
-> Status
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> Status
Error (Result Value -> Status
Ready (Result Value -> Status)
-> ((Bool, ByteString, Result Value) -> Result Value)
-> (Bool, ByteString, Result Value)
-> Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, ByteString, Result Value) -> Result Value
forall a b c. (a, b, c) -> c
thd3) Either SomeException (Bool, ByteString, Result Value)
res
Lock -> IO () -> IO ()
forall a. Lock -> IO a -> IO a
withLock Lock
lock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Id
i Id -> (Key, Status) -> IO Status
#= (Key
k, Status
status)
Status -> IO ()
done Status
status
case Either SomeException (Bool, ByteString, Result Value)
res of
Right (write :: Bool
write, bs :: ByteString
bs, r :: Result Value
r) -> do
IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$
"result " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Key -> String
forall a. Show a => a -> String
showBracket Key
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ " = "String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
showBracket (Result Value -> Value
forall a. Result a -> a
result Result Value
r) String -> ShowS
forall a. [a] -> [a] -> [a]
++
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if Result Value -> Step
forall a. Result a -> Step
built Result Value
r Step -> Step -> Bool
forall a. Eq a => a -> a -> Bool
== Result Value -> Step
forall a. Result a -> Step
changed Result Value
r then "(changed)" else "(unchanged)")
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
write (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Id -> Key -> Result ByteString -> IO ()
journal Id
i Key
k Result Value
r{result :: ByteString
result=ByteString
bs}
Left _ ->
IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ "result " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Key -> String
forall a. Show a => a -> String
showBracket Key
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ " = error"
Id
i Id -> (Key, Status) -> IO Status
#= (Key
k, Waiting Status -> Maybe (Result ByteString) -> Status
Waiting Waiting Status
w Maybe (Result ByteString)
r)
progress :: Database -> IO Progress
progress :: Database -> IO Progress
progress Database{..} = do
[(Id, (Key, Status))]
xs <- StatusDB -> IO [(Id, (Key, Status))]
forall a. Ids a -> IO [(Id, a)]
Ids.toList StatusDB
status
Progress -> IO Progress
forall (m :: * -> *) a. Monad m => a -> m a
return (Progress -> IO Progress) -> Progress -> IO Progress
forall a b. (a -> b) -> a -> b
$! (Progress -> Status -> Progress)
-> Progress -> [Status] -> Progress
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Progress -> Status -> Progress
f Progress
forall a. Monoid a => a
mempty ([Status] -> Progress) -> [Status] -> Progress
forall a b. (a -> b) -> a -> b
$ ((Id, (Key, Status)) -> Status)
-> [(Id, (Key, Status))] -> [Status]
forall a b. (a -> b) -> [a] -> [b]
map ((Key, Status) -> Status
forall a b. (a, b) -> b
snd ((Key, Status) -> Status)
-> ((Id, (Key, Status)) -> (Key, Status))
-> (Id, (Key, Status))
-> Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, (Key, Status)) -> (Key, Status)
forall a b. (a, b) -> b
snd) [(Id, (Key, Status))]
xs
where
g :: Float -> Double
g = Float -> Double
floatToDouble
f :: Progress -> Status -> Progress
f s :: Progress
s (Ready Result{..}) = if Step
step Step -> Step -> Bool
forall a. Eq a => a -> a -> Bool
== Step
built
then Progress
s{countBuilt :: Int
countBuilt = Progress -> Int
countBuilt Progress
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, timeBuilt :: Double
timeBuilt = Progress -> Double
timeBuilt Progress
s Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Float -> Double
g Float
execution}
else Progress
s{countSkipped :: Int
countSkipped = Progress -> Int
countSkipped Progress
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, timeSkipped :: Double
timeSkipped = Progress -> Double
timeSkipped Progress
s Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Float -> Double
g Float
execution}
f s :: Progress
s (Loaded Result{..}) = Progress
s{countUnknown :: Int
countUnknown = Progress -> Int
countUnknown Progress
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, timeUnknown :: Double
timeUnknown = Progress -> Double
timeUnknown Progress
s Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Float -> Double
g Float
execution}
f s :: Progress
s (Waiting _ r :: Maybe (Result ByteString)
r) =
let (d :: Double
d,c :: Int
c) = Progress -> (Double, Int)
timeTodo Progress
s
t :: (Double, Int)
t | Just Result{..} <- Maybe (Result ByteString)
r = let d2 :: Double
d2 = Double
d Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Float -> Double
g Float
execution in Double
d2 Double -> (Double, Int) -> (Double, Int)
forall a b. a -> b -> b
`seq` (Double
d2,Int
c)
| Bool
otherwise = let c2 :: Int
c2 = Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1 in Int
c2 Int -> (Double, Int) -> (Double, Int)
forall a b. a -> b -> b
`seq` (Double
d,Int
c2)
in Progress
s{countTodo :: Int
countTodo = Progress -> Int
countTodo Progress
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, timeTodo :: (Double, Int)
timeTodo = (Double, Int)
t}
f s :: Progress
s _ = Progress
s
assertFinishedDatabase :: Database -> IO ()
assertFinishedDatabase :: Database -> IO ()
assertFinishedDatabase Database{..} = do
[(Id, (Key, Status))]
status <- StatusDB -> IO [(Id, (Key, Status))]
forall a. Ids a -> IO [(Id, a)]
Ids.toList StatusDB
status
let bad :: [Key]
bad = [Key
key | (_, (key :: Key
key, Waiting{})) <- [(Id, (Key, Status))]
status]
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Key]
bad [Key] -> [Key] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
[String] -> IO ()
forall a. [String] -> IO a
errorComplexRecursion ((Key -> String) -> [Key] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Key -> String
forall a. Show a => a -> String
show [Key]
bad)
dependencyOrder :: (Eq a, Hashable a) => (a -> String) -> Map a [a] -> [a]
dependencyOrder :: (a -> String) -> Map a [a] -> [a]
dependencyOrder shw :: a -> String
shw status :: Map a [a]
status = [a] -> HashMap a (Maybe [(a, [a])]) -> [a]
f (((a, [a]) -> a) -> [(a, [a])] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, [a]) -> a
forall a b. (a, b) -> a
fst [(a, [a])]
noDeps) (HashMap a (Maybe [(a, [a])]) -> [a])
-> HashMap a (Maybe [(a, [a])]) -> [a]
forall a b. (a -> b) -> a -> b
$ ([(a, [a])] -> Maybe [(a, [a])])
-> HashMap a [(a, [a])] -> HashMap a (Maybe [(a, [a])])
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map [(a, [a])] -> Maybe [(a, [a])]
forall a. a -> Maybe a
Just (HashMap a [(a, [a])] -> HashMap a (Maybe [(a, [a])]))
-> HashMap a [(a, [a])] -> HashMap a (Maybe [(a, [a])])
forall a b. (a -> b) -> a -> b
$ ([(a, [a])] -> [(a, [a])] -> [(a, [a])])
-> [(a, [(a, [a])])] -> HashMap a [(a, [a])]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
Map.fromListWith [(a, [a])] -> [(a, [a])] -> [(a, [a])]
forall a. [a] -> [a] -> [a]
(++) [(a
d, [(a
k,[a]
ds)]) | (k :: a
k,d :: a
d:ds :: [a]
ds) <- [(a, [a])]
hasDeps]
where
(noDeps :: [(a, [a])]
noDeps, hasDeps :: [(a, [a])]
hasDeps) = ((a, [a]) -> Bool) -> [(a, [a])] -> ([(a, [a])], [(a, [a])])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> ((a, [a]) -> [a]) -> (a, [a]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, [a]) -> [a]
forall a b. (a, b) -> b
snd) ([(a, [a])] -> ([(a, [a])], [(a, [a])]))
-> [(a, [a])] -> ([(a, [a])], [(a, [a])])
forall a b. (a -> b) -> a -> b
$ Map a [a] -> [(a, [a])]
forall k v. HashMap k v -> [(k, v)]
Map.toList Map a [a]
status
f :: [a] -> HashMap a (Maybe [(a, [a])]) -> [a]
f [] mp :: HashMap a (Maybe [(a, [a])])
mp | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
bad = []
| Bool
otherwise = String -> [a]
forall a. HasCallStack => String -> a
error (String -> [a]) -> String -> [a]
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
"Internal invariant broken, database seems to be cyclic" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (" " String -> ShowS
forall a. [a] -> [a] -> [a]
++) [String]
bad [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
["... plus " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
badOverflow) String -> ShowS
forall a. [a] -> [a] -> [a]
++ " more ..." | 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]
badOverflow]
where (bad :: [String]
bad,badOverflow :: [String]
badOverflow) = Int -> [String] -> ([String], [String])
forall a. Int -> [a] -> ([a], [a])
splitAt 10 [a -> String
shw a
i | (i :: a
i, Just _) <- HashMap a (Maybe [(a, [a])]) -> [(a, Maybe [(a, [a])])]
forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap a (Maybe [(a, [a])])
mp]
f (x :: a
x:xs :: [a]
xs) mp :: HashMap a (Maybe [(a, [a])])
mp = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> HashMap a (Maybe [(a, [a])]) -> [a]
f ([a]
now[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[a]
xs) HashMap a (Maybe [(a, [a])])
later
where Just free :: [(a, [a])]
free = Maybe [(a, [a])]
-> a -> HashMap a (Maybe [(a, [a])]) -> Maybe [(a, [a])]
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
Map.lookupDefault ([(a, [a])] -> Maybe [(a, [a])]
forall a. a -> Maybe a
Just []) a
x HashMap a (Maybe [(a, [a])])
mp
(now :: [a]
now,later :: HashMap a (Maybe [(a, [a])])
later) = (([a], HashMap a (Maybe [(a, [a])]))
-> (a, [a]) -> ([a], HashMap a (Maybe [(a, [a])])))
-> ([a], HashMap a (Maybe [(a, [a])]))
-> [(a, [a])]
-> ([a], HashMap a (Maybe [(a, [a])]))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([a], HashMap a (Maybe [(a, [a])]))
-> (a, [a]) -> ([a], HashMap a (Maybe [(a, [a])]))
forall k a.
(Eq k, Hashable k) =>
([a], HashMap k (Maybe [(a, [k])]))
-> (a, [k]) -> ([a], HashMap k (Maybe [(a, [k])]))
g ([], a
-> Maybe [(a, [a])]
-> HashMap a (Maybe [(a, [a])])
-> HashMap a (Maybe [(a, [a])])
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert a
x Maybe [(a, [a])]
forall a. Maybe a
Nothing HashMap a (Maybe [(a, [a])])
mp) [(a, [a])]
free
g :: ([a], HashMap k (Maybe [(a, [k])]))
-> (a, [k]) -> ([a], HashMap k (Maybe [(a, [k])]))
g (free :: [a]
free, mp :: HashMap k (Maybe [(a, [k])])
mp) (k :: a
k, []) = (a
ka -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
free, HashMap k (Maybe [(a, [k])])
mp)
g (free :: [a]
free, mp :: HashMap k (Maybe [(a, [k])])
mp) (k :: a
k, d :: k
d:ds :: [k]
ds) = case Maybe [(a, [k])]
-> k -> HashMap k (Maybe [(a, [k])]) -> Maybe [(a, [k])]
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
Map.lookupDefault ([(a, [k])] -> Maybe [(a, [k])]
forall a. a -> Maybe a
Just []) k
d HashMap k (Maybe [(a, [k])])
mp of
Nothing -> ([a], HashMap k (Maybe [(a, [k])]))
-> (a, [k]) -> ([a], HashMap k (Maybe [(a, [k])]))
g ([a]
free, HashMap k (Maybe [(a, [k])])
mp) (a
k, [k]
ds)
Just todo :: [(a, [k])]
todo -> ([a]
free, k
-> Maybe [(a, [k])]
-> HashMap k (Maybe [(a, [k])])
-> HashMap k (Maybe [(a, [k])])
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert k
d ([(a, [k])] -> Maybe [(a, [k])]
forall a. a -> Maybe a
Just ([(a, [k])] -> Maybe [(a, [k])]) -> [(a, [k])] -> Maybe [(a, [k])]
forall a b. (a -> b) -> a -> b
$ (a
k,[k]
ds) (a, [k]) -> [(a, [k])] -> [(a, [k])]
forall a. a -> [a] -> [a]
: [(a, [k])]
todo) HashMap k (Maybe [(a, [k])])
mp)
resultsOnly :: Map Id (Key, Status) -> Map Id (Key, Result (Either BS.ByteString Value))
resultsOnly :: Map Id (Key, Status)
-> Map Id (Key, Result (Either ByteString Value))
resultsOnly mp :: Map Id (Key, Status)
mp = ((Key, Status) -> (Key, Result (Either ByteString Value)))
-> Map Id (Key, Status)
-> Map Id (Key, Result (Either ByteString Value))
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map (\(k :: Key
k, v :: Status
v) -> (Key
k, let Just r :: Result (Either ByteString Value)
r = Status -> Maybe (Result (Either ByteString Value))
getResult Status
v in Result (Either ByteString Value)
r{depends :: [Depends]
depends = (Depends -> Depends) -> [Depends] -> [Depends]
forall a b. (a -> b) -> [a] -> [b]
map ([Id] -> Depends
Depends ([Id] -> Depends) -> (Depends -> [Id]) -> Depends -> Depends
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe (Key, Status) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Key, Status) -> Bool)
-> (Id -> Maybe (Key, Status)) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id -> Map Id (Key, Status) -> Maybe (Key, Status))
-> Map Id (Key, Status) -> Id -> Maybe (Key, Status)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Id -> Map Id (Key, Status) -> Maybe (Key, Status)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Map Id (Key, Status)
keep) ([Id] -> [Id]) -> (Depends -> [Id]) -> Depends -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Depends -> [Id]
fromDepends) ([Depends] -> [Depends]) -> [Depends] -> [Depends]
forall a b. (a -> b) -> a -> b
$ Result (Either ByteString Value) -> [Depends]
forall a. Result a -> [Depends]
depends Result (Either ByteString Value)
r})) Map Id (Key, Status)
keep
where keep :: Map Id (Key, Status)
keep = ((Key, Status) -> Bool)
-> Map Id (Key, Status) -> Map Id (Key, Status)
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
Map.filter (Maybe (Result (Either ByteString Value)) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Result (Either ByteString Value)) -> Bool)
-> ((Key, Status) -> Maybe (Result (Either ByteString Value)))
-> (Key, Status)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> Maybe (Result (Either ByteString Value))
getResult (Status -> Maybe (Result (Either ByteString Value)))
-> ((Key, Status) -> Status)
-> (Key, Status)
-> Maybe (Result (Either ByteString Value))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, Status) -> Status
forall a b. (a, b) -> b
snd) Map Id (Key, Status)
mp
removeStep :: Map Id (Key, Result a) -> Map Id (Key, Result a)
removeStep :: Map Id (Key, Result a) -> Map Id (Key, Result a)
removeStep = ((Key, Result a) -> Bool)
-> Map Id (Key, Result a) -> Map Id (Key, Result a)
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
Map.filter (\(k :: Key
k,_) -> Key
k Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
/= Key
stepKey)
toReport :: Database -> IO [ProfileEntry]
toReport :: Database -> IO [ProfileEntry]
toReport Database{..} = do
Map Id (Key, Result (Either ByteString Value))
status <- Map Id (Key, Result (Either ByteString Value))
-> Map Id (Key, Result (Either ByteString Value))
forall a. Map Id (Key, Result a) -> Map Id (Key, Result a)
removeStep (Map Id (Key, Result (Either ByteString Value))
-> Map Id (Key, Result (Either ByteString Value)))
-> (Map Id (Key, Status)
-> Map Id (Key, Result (Either ByteString Value)))
-> Map Id (Key, Status)
-> Map Id (Key, Result (Either ByteString Value))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Id (Key, Status)
-> Map Id (Key, Result (Either ByteString Value))
resultsOnly (Map Id (Key, Status)
-> Map Id (Key, Result (Either ByteString Value)))
-> IO (Map Id (Key, Status))
-> IO (Map Id (Key, Result (Either ByteString Value)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StatusDB -> IO (Map Id (Key, Status))
forall a. Ids a -> IO (HashMap Id a)
Ids.toMap StatusDB
status
let order :: [Id]
order = let shw :: Id -> String
shw i :: Id
i = String
-> ((Key, Result (Either ByteString Value)) -> String)
-> Maybe (Key, Result (Either ByteString Value))
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "<unknown>" (Key -> String
forall a. Show a => a -> String
show (Key -> String)
-> ((Key, Result (Either ByteString Value)) -> Key)
-> (Key, Result (Either ByteString Value))
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, Result (Either ByteString Value)) -> Key
forall a b. (a, b) -> a
fst) (Maybe (Key, Result (Either ByteString Value)) -> String)
-> Maybe (Key, Result (Either ByteString Value)) -> String
forall a b. (a -> b) -> a -> b
$ Id
-> Map Id (Key, Result (Either ByteString Value))
-> Maybe (Key, Result (Either ByteString Value))
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Id
i Map Id (Key, Result (Either ByteString Value))
status
in (Id -> String) -> Map Id [Id] -> [Id]
forall a. (Eq a, Hashable a) => (a -> String) -> Map a [a] -> [a]
dependencyOrder Id -> String
shw (Map Id [Id] -> [Id]) -> Map Id [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ ((Key, Result (Either ByteString Value)) -> [Id])
-> Map Id (Key, Result (Either ByteString Value)) -> Map Id [Id]
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map ((Depends -> [Id]) -> [Depends] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Depends -> [Id]
fromDepends ([Depends] -> [Id])
-> ((Key, Result (Either ByteString Value)) -> [Depends])
-> (Key, Result (Either ByteString Value))
-> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result (Either ByteString Value) -> [Depends]
forall a. Result a -> [Depends]
depends (Result (Either ByteString Value) -> [Depends])
-> ((Key, Result (Either ByteString Value))
-> Result (Either ByteString Value))
-> (Key, Result (Either ByteString Value))
-> [Depends]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, Result (Either ByteString Value))
-> Result (Either ByteString Value)
forall a b. (a, b) -> b
snd) Map Id (Key, Result (Either ByteString Value))
status
ids :: HashMap Id Int
ids = [(Id, Int)] -> HashMap Id Int
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(Id, Int)] -> HashMap Id Int) -> [(Id, Int)] -> HashMap Id Int
forall a b. (a -> b) -> a -> b
$ [Id] -> [Int] -> [(Id, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
order [0..]
steps :: HashMap Step Int
steps = let xs :: [Step]
xs = HashSet Step -> [Step]
forall a. HashSet a -> [a]
Set.toList (HashSet Step -> [Step]) -> HashSet Step -> [Step]
forall a b. (a -> b) -> a -> b
$ [Step] -> HashSet Step
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList ([Step] -> HashSet Step) -> [Step] -> HashSet Step
forall a b. (a -> b) -> a -> b
$ [[Step]] -> [Step]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Step
changed, Step
built] | (_,Result{..}) <- Map Id (Key, Result (Either ByteString Value))
-> [(Key, Result (Either ByteString Value))]
forall k v. HashMap k v -> [v]
Map.elems Map Id (Key, Result (Either ByteString Value))
status]
in [(Step, Int)] -> HashMap Step Int
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(Step, Int)] -> HashMap Step Int)
-> [(Step, Int)] -> HashMap Step Int
forall a b. (a -> b) -> a -> b
$ [Step] -> [Int] -> [(Step, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Step -> Step -> Ordering) -> [Step] -> [Step]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Step -> Step -> Ordering) -> Step -> Step -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Step -> Step -> Ordering
forall a. Ord a => a -> a -> Ordering
compare) [Step]
xs) [0..]
f :: (a, Result a) -> ProfileEntry
f (k :: a
k, Result{..}) = ProfileEntry :: String
-> Int -> Int -> [Int] -> Double -> [ProfileTrace] -> ProfileEntry
ProfileEntry
{prfName :: String
prfName = a -> String
forall a. Show a => a -> String
show a
k
,prfBuilt :: Int
prfBuilt = Step -> Int
fromStep Step
built
,prfChanged :: Int
prfChanged = Step -> Int
fromStep Step
changed
,prfDepends :: [Int]
prfDepends = (Id -> Maybe Int) -> [Id] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Id -> HashMap Id Int -> Maybe Int
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`Map.lookup` HashMap Id Int
ids) ((Depends -> [Id]) -> [Depends] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Depends -> [Id]
fromDepends [Depends]
depends)
,prfExecution :: Double
prfExecution = Float -> Double
floatToDouble Float
execution
,prfTraces :: [ProfileTrace]
prfTraces = (Trace -> ProfileTrace) -> [Trace] -> [ProfileTrace]
forall a b. (a -> b) -> [a] -> [b]
map Trace -> ProfileTrace
fromTrace [Trace]
traces
}
where fromStep :: Step -> Int
fromStep i :: Step
i = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Step -> HashMap Step Int -> Maybe Int
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Step
i HashMap Step Int
steps
fromTrace :: Trace -> ProfileTrace
fromTrace (Trace a :: ByteString
a b :: Float
b c :: Float
c) = String -> Double -> Double -> ProfileTrace
ProfileTrace (ByteString -> String
BS.unpack ByteString
a) (Float -> Double
floatToDouble Float
b) (Float -> Double
floatToDouble Float
c)
[ProfileEntry] -> IO [ProfileEntry]
forall (m :: * -> *) a. Monad m => a -> m a
return [ProfileEntry
-> ((Key, Result (Either ByteString Value)) -> ProfileEntry)
-> Maybe (Key, Result (Either ByteString Value))
-> ProfileEntry
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ProfileEntry
forall a. String -> a
errorInternal "toReport") (Key, Result (Either ByteString Value)) -> ProfileEntry
forall a a. Show a => (a, Result a) -> ProfileEntry
f (Maybe (Key, Result (Either ByteString Value)) -> ProfileEntry)
-> Maybe (Key, Result (Either ByteString Value)) -> ProfileEntry
forall a b. (a -> b) -> a -> b
$ Id
-> Map Id (Key, Result (Either ByteString Value))
-> Maybe (Key, Result (Either ByteString Value))
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Id
i Map Id (Key, Result (Either ByteString Value))
status | Id
i <- [Id]
order]
checkValid :: Database -> (Key -> Value -> IO (Maybe String)) -> [(Key, Key)] -> IO ()
checkValid :: Database
-> (Key -> Value -> IO (Maybe String)) -> [(Key, Key)] -> IO ()
checkValid Database{..} check :: Key -> Value -> IO (Maybe String)
check missing :: [(Key, Key)]
missing = do
[(Id, (Key, Status))]
status <- StatusDB -> IO [(Id, (Key, Status))]
forall a. Ids a -> IO [(Id, a)]
Ids.toList StatusDB
status
Intern Key
intern <- InternDB -> IO (Intern Key)
forall a. IORef a -> IO a
readIORef InternDB
intern
IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return "Starting validity/lint checking"
[(Key, Value, String)]
bad <- (\f :: [(Key, Value, String)]
-> (Id, (Key, Status)) -> IO [(Key, Value, String)]
f -> ([(Key, Value, String)]
-> (Id, (Key, Status)) -> IO [(Key, Value, String)])
-> [(Key, Value, String)]
-> [(Id, (Key, Status))]
-> IO [(Key, Value, String)]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [(Key, Value, String)]
-> (Id, (Key, Status)) -> IO [(Key, Value, String)]
f [] [(Id, (Key, Status))]
status) (([(Key, Value, String)]
-> (Id, (Key, Status)) -> IO [(Key, Value, String)])
-> IO [(Key, Value, String)])
-> ([(Key, Value, String)]
-> (Id, (Key, Status)) -> IO [(Key, Value, String)])
-> IO [(Key, Value, String)]
forall a b. (a -> b) -> a -> b
$ \seen :: [(Key, Value, String)]
seen (i :: Id
i,v :: (Key, Status)
v) -> case (Key, Status)
v of
(key :: Key
key, Ready Result{..}) -> do
Maybe String
good <- Key -> Value -> IO (Maybe String)
check Key
key Value
result
IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ "Checking if " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Key -> String
forall a. Show a => a -> String
show Key
key String -> ShowS
forall a. [a] -> [a] -> [a]
++ " is " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
result String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ if Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing Maybe String
good then "passed" else "FAILED"
[(Key, Value, String)] -> IO [(Key, Value, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Key, Value, String)] -> IO [(Key, Value, String)])
-> [(Key, Value, String)] -> IO [(Key, Value, String)]
forall a b. (a -> b) -> a -> b
$ [(Key
key, Value
result, String
now) | Just now :: String
now <- [Maybe String
good]] [(Key, Value, String)]
-> [(Key, Value, String)] -> [(Key, Value, String)]
forall a. [a] -> [a] -> [a]
++ [(Key, Value, String)]
seen
_ -> [(Key, Value, String)] -> IO [(Key, Value, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Key, Value, String)]
seen
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Key, Value, String)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Key, Value, String)]
bad) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let n :: Int
n = [(Key, Value, String)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Key, Value, String)]
bad
String -> [(String, Maybe String)] -> String -> IO ()
forall a. String -> [(String, Maybe String)] -> String -> IO a
errorStructured
("Lint checking error - " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 then "value has" else Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ " values have") String -> ShowS
forall a. [a] -> [a] -> [a]
++ " changed since being depended upon")
([(String, Maybe String)]
-> [[(String, Maybe String)]] -> [(String, Maybe String)]
forall a. [a] -> [[a]] -> [a]
intercalate [("",String -> Maybe String
forall a. a -> Maybe a
Just "")] [ [("Key", String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Key -> String
forall a. Show a => a -> String
show Key
key),("Old", String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Value -> String
forall a. Show a => a -> String
show Value
result),("New", String -> Maybe String
forall a. a -> Maybe a
Just String
now)]
| (key :: Key
key, result :: Value
result, now :: String
now) <- [(Key, Value, String)]
bad])
""
[(Key, Key)]
bad <- [(Key, Key)] -> IO [(Key, Key)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Key
parent,Key
key) | (parent :: Key
parent, key :: Key
key) <- [(Key, Key)]
missing, Maybe Id -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Id -> Bool) -> Maybe Id -> Bool
forall a b. (a -> b) -> a -> b
$ Key -> Intern Key -> Maybe Id
forall a. (Eq a, Hashable a) => a -> Intern a -> Maybe Id
Intern.lookup Key
key Intern Key
intern]
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Key, Key)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Key, Key)]
bad) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let n :: Int
n = [(Key, Key)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Key, Key)]
bad
String -> [(String, Maybe String)] -> String -> IO ()
forall a. String -> [(String, Maybe String)] -> String -> IO a
errorStructured
("Lint checking error - " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 then "value" else Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ " values") String -> ShowS
forall a. [a] -> [a] -> [a]
++ " did not have " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 then "its" else "their") String -> ShowS
forall a. [a] -> [a] -> [a]
++ " creation tracked")
([(String, Maybe String)]
-> [[(String, Maybe String)]] -> [(String, Maybe String)]
forall a. [a] -> [[a]] -> [a]
intercalate [("",String -> Maybe String
forall a. a -> Maybe a
Just "")] [ [("Rule", String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Key -> String
forall a. Show a => a -> String
show Key
parent), ("Created", String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Key -> String
forall a. Show a => a -> String
show Key
key)] | (parent :: Key
parent,key :: Key
key) <- [(Key, Key)]
bad])
""
IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return "Validity/lint check passed"
listLive :: Database -> IO [Key]
listLive :: Database -> IO [Key]
listLive Database{..} = do
IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return "Listing live keys"
[(Id, (Key, Status))]
status <- StatusDB -> IO [(Id, (Key, Status))]
forall a. Ids a -> IO [(Id, a)]
Ids.toList StatusDB
status
[Key] -> IO [Key]
forall (m :: * -> *) a. Monad m => a -> m a
return [Key
k | (_, (k :: Key
k, Ready{})) <- [(Id, (Key, Status))]
status]
listDepends :: Database -> Depends -> IO [Key]
listDepends :: Database -> Depends -> IO [Key]
listDepends Database{..} (Depends xs :: [Id]
xs) =
Lock -> IO [Key] -> IO [Key]
forall a. Lock -> IO a -> IO a
withLock Lock
lock (IO [Key] -> IO [Key]) -> IO [Key] -> IO [Key]
forall a b. (a -> b) -> a -> b
$
[Id] -> (Id -> IO Key) -> IO [Key]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Id]
xs ((Id -> IO Key) -> IO [Key]) -> (Id -> IO Key) -> IO [Key]
forall a b. (a -> b) -> a -> b
$ \x :: Id
x ->
(Key, Status) -> Key
forall a b. (a, b) -> a
fst ((Key, Status) -> Key)
-> (Maybe (Key, Status) -> (Key, Status))
-> Maybe (Key, Status)
-> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Key, Status) -> (Key, Status)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Key, Status) -> Key) -> IO (Maybe (Key, Status)) -> IO Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StatusDB -> Id -> IO (Maybe (Key, Status))
forall a. Ids a -> Id -> IO (Maybe a)
Ids.lookup StatusDB
status Id
x
lookupDependencies :: Database -> Key -> IO [Key]
lookupDependencies :: Database -> Key -> IO [Key]
lookupDependencies Database{..} k :: Key
k =
Lock -> IO [Key] -> IO [Key]
forall a. Lock -> IO a -> IO a
withLock Lock
lock (IO [Key] -> IO [Key]) -> IO [Key] -> IO [Key]
forall a b. (a -> b) -> a -> b
$ do
Intern Key
intern <- InternDB -> IO (Intern Key)
forall a. IORef a -> IO a
readIORef InternDB
intern
let Just i :: Id
i = Key -> Intern Key -> Maybe Id
forall a. (Eq a, Hashable a) => a -> Intern a -> Maybe Id
Intern.lookup Key
k Intern Key
intern
Just (_, Ready r :: Result Value
r) <- StatusDB -> Id -> IO (Maybe (Key, Status))
forall a. Ids a -> Id -> IO (Maybe a)
Ids.lookup StatusDB
status Id
i
[Id] -> (Id -> IO Key) -> IO [Key]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ((Depends -> [Id]) -> [Depends] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Depends -> [Id]
fromDepends ([Depends] -> [Id]) -> [Depends] -> [Id]
forall a b. (a -> b) -> a -> b
$ Result Value -> [Depends]
forall a. Result a -> [Depends]
depends Result Value
r) ((Id -> IO Key) -> IO [Key]) -> (Id -> IO Key) -> IO [Key]
forall a b. (a -> b) -> a -> b
$ \x :: Id
x ->
(Key, Status) -> Key
forall a b. (a, b) -> a
fst ((Key, Status) -> Key)
-> (Maybe (Key, Status) -> (Key, Status))
-> Maybe (Key, Status)
-> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Key, Status) -> (Key, Status)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Key, Status) -> Key) -> IO (Maybe (Key, Status)) -> IO Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StatusDB -> Id -> IO (Maybe (Key, Status))
forall a. Ids a -> Id -> IO (Maybe a)
Ids.lookup StatusDB
status Id
x
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 ()
toStepResult :: Step -> Result BS.ByteString
toStepResult :: Step -> Result ByteString
toStepResult i :: Step
i = ByteString
-> Step
-> Step
-> [Depends]
-> Float
-> [Trace]
-> Result ByteString
forall a.
a -> Step -> Step -> [Depends] -> Float -> [Trace] -> Result a
Result (Builder -> ByteString
runBuilder (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Step -> Builder
forall a. BinaryEx a => a -> Builder
putEx Step
i) Step
i Step
i [] 0 []
fromStepResult :: Result BS.ByteString -> Step
fromStepResult :: Result ByteString -> Step
fromStepResult = ByteString -> Step
forall a. BinaryEx a => ByteString -> a
getEx (ByteString -> Step)
-> (Result ByteString -> ByteString) -> Result ByteString -> Step
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result ByteString -> ByteString
forall a. Result a -> a
result
withDatabase :: ShakeOptions -> (IO String -> IO ()) -> Map TypeRep (BinaryOp Key) -> (Database -> IO a) -> IO a
withDatabase :: ShakeOptions
-> (IO String -> IO ())
-> Map TypeRep (BinaryOp Key)
-> (Database -> IO a)
-> IO a
withDatabase opts :: ShakeOptions
opts diagnostic :: IO String -> IO ()
diagnostic witness :: Map TypeRep (BinaryOp Key)
witness act :: Database -> IO a
act = do
let step :: (TypeRep, BinaryOp Key)
step = (Proxy StepKey -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy StepKey
forall k (t :: k). Proxy t
Proxy :: Proxy StepKey), (Key -> Builder) -> (ByteString -> Key) -> BinaryOp Key
forall v. (v -> Builder) -> (ByteString -> v) -> BinaryOp v
BinaryOp (Builder -> Key -> Builder
forall a b. a -> b -> a
const Builder
forall a. Monoid a => a
mempty) (Key -> ByteString -> Key
forall a b. a -> b -> a
const Key
stepKey))
HashMap QTypeRep (BinaryOp (Key, Status))
witness <- HashMap QTypeRep (BinaryOp (Key, Status))
-> IO (HashMap QTypeRep (BinaryOp (Key, Status)))
forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap QTypeRep (BinaryOp (Key, Status))
-> IO (HashMap QTypeRep (BinaryOp (Key, Status))))
-> HashMap QTypeRep (BinaryOp (Key, Status))
-> IO (HashMap QTypeRep (BinaryOp (Key, Status)))
forall a b. (a -> b) -> a -> b
$ [(QTypeRep, BinaryOp (Key, Status))]
-> HashMap QTypeRep (BinaryOp (Key, Status))
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList
[ (TypeRep -> QTypeRep
QTypeRep TypeRep
t, ((Key, Status) -> Builder)
-> (ByteString -> (Key, Status)) -> BinaryOp (Key, Status)
forall v. (v -> Builder) -> (ByteString -> v) -> BinaryOp v
BinaryOp ((Key -> Builder) -> (Key, Status) -> Builder
putDatabase Key -> Builder
putOp) ((ByteString -> Key) -> ByteString -> (Key, Status)
getDatabase ByteString -> Key
getOp))
| (t :: TypeRep
t,BinaryOp{..}) <- (TypeRep, BinaryOp Key)
step (TypeRep, BinaryOp Key)
-> [(TypeRep, BinaryOp Key)] -> [(TypeRep, BinaryOp Key)]
forall a. a -> [a] -> [a]
: Map TypeRep (BinaryOp Key) -> [(TypeRep, BinaryOp Key)]
forall k v. HashMap k v -> [(k, v)]
Map.toList Map TypeRep (BinaryOp Key)
witness]
ShakeOptions
-> (IO String -> IO ())
-> HashMap QTypeRep (BinaryOp (Key, Status))
-> (StatusDB -> (QTypeRep -> Id -> (Key, Status) -> IO ()) -> IO a)
-> IO a
forall k v a.
(Show k, Eq k, Hashable k, NFData k, Show v, NFData v) =>
ShakeOptions
-> (IO String -> IO ())
-> HashMap k (BinaryOp v)
-> (Ids v -> (k -> Id -> v -> IO ()) -> IO a)
-> IO a
withStorage ShakeOptions
opts IO String -> IO ()
diagnostic HashMap QTypeRep (BinaryOp (Key, Status))
witness ((StatusDB -> (QTypeRep -> Id -> (Key, Status) -> IO ()) -> IO a)
-> IO a)
-> (StatusDB -> (QTypeRep -> Id -> (Key, Status) -> IO ()) -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$ \status :: StatusDB
status journal :: QTypeRep -> Id -> (Key, Status) -> IO ()
journal -> do
Id -> Key -> Result ByteString -> IO ()
journal <- (Id -> Key -> Result ByteString -> IO ())
-> IO (Id -> Key -> Result ByteString -> IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((Id -> Key -> Result ByteString -> IO ())
-> IO (Id -> Key -> Result ByteString -> IO ()))
-> (Id -> Key -> Result ByteString -> IO ())
-> IO (Id -> Key -> Result ByteString -> IO ())
forall a b. (a -> b) -> a -> b
$ \i :: Id
i k :: Key
k v :: Result ByteString
v -> QTypeRep -> Id -> (Key, Status) -> IO ()
journal (TypeRep -> QTypeRep
QTypeRep (TypeRep -> QTypeRep) -> TypeRep -> QTypeRep
forall a b. (a -> b) -> a -> b
$ Key -> TypeRep
typeKey Key
k) Id
i (Key
k, Result ByteString -> Status
Loaded Result ByteString
v)
[(Id, (Key, Status))]
xs <- StatusDB -> IO [(Id, (Key, Status))]
forall a. Ids a -> IO [(Id, a)]
Ids.toList StatusDB
status
let mp1 :: Intern Key
mp1 = [(Key, Id)] -> Intern Key
forall a. (Eq a, Hashable a) => [(a, Id)] -> Intern a
Intern.fromList [(Key
k, Id
i) | (i :: Id
i, (k :: Key
k,_)) <- [(Id, (Key, Status))]
xs]
(mp1 :: Intern Key
mp1, stepId :: Id
stepId) <- case Key -> Intern Key -> Maybe Id
forall a. (Eq a, Hashable a) => a -> Intern a -> Maybe Id
Intern.lookup Key
stepKey Intern Key
mp1 of
Just stepId :: Id
stepId -> (Intern Key, Id) -> IO (Intern Key, Id)
forall (m :: * -> *) a. Monad m => a -> m a
return (Intern Key
mp1, Id
stepId)
Nothing -> do
(mp1 :: Intern Key
mp1, stepId :: Id
stepId) <- (Intern Key, Id) -> IO (Intern Key, Id)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Intern Key, Id) -> IO (Intern Key, Id))
-> (Intern Key, Id) -> IO (Intern Key, Id)
forall a b. (a -> b) -> a -> b
$ Key -> Intern Key -> (Intern Key, Id)
forall a. (Eq a, Hashable a) => a -> Intern a -> (Intern a, Id)
Intern.add Key
stepKey Intern Key
mp1
(Intern Key, Id) -> IO (Intern Key, Id)
forall (m :: * -> *) a. Monad m => a -> m a
return (Intern Key
mp1, Id
stepId)
InternDB
intern <- Intern Key -> IO InternDB
forall a. a -> IO (IORef a)
newIORef Intern Key
mp1
Step
step <- do
Maybe (Key, Status)
v <- StatusDB -> Id -> IO (Maybe (Key, Status))
forall a. Ids a -> Id -> IO (Maybe a)
Ids.lookup StatusDB
status Id
stepId
Step -> IO Step
forall (m :: * -> *) a. Monad m => a -> m a
return (Step -> IO Step) -> Step -> IO Step
forall a b. (a -> b) -> a -> b
$ case Maybe (Key, Status)
v of
Just (_, Loaded r :: Result ByteString
r) -> Step -> Step
incStep (Step -> Step) -> Step -> Step
forall a b. (a -> b) -> a -> b
$ Result ByteString -> Step
fromStepResult Result ByteString
r
_ -> Word32 -> Step
Step 1
Id -> Key -> Result ByteString -> IO ()
journal Id
stepId Key
stepKey (Result ByteString -> IO ()) -> Result ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Step -> Result ByteString
toStepResult Step
step
Lock
lock <- IO Lock
newLock
Database -> IO a
act $WDatabase :: Lock
-> InternDB
-> StatusDB
-> Step
-> (Id -> Key -> Result ByteString -> IO ())
-> (IO String -> IO ())
-> Database
Database{..}
putDatabase :: (Key -> Builder) -> ((Key, Status) -> Builder)
putDatabase :: (Key -> Builder) -> (Key, Status) -> Builder
putDatabase putKey :: Key -> Builder
putKey (key :: Key
key, Loaded (Result x1 :: ByteString
x1 x2 :: Step
x2 x3 :: Step
x3 x4 :: [Depends]
x4 x5 :: Float
x5 x6 :: [Trace]
x6)) =
Builder -> Builder
putExN (Key -> Builder
putKey Key
key) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
putExN (ByteString -> Builder
forall a. BinaryEx a => a -> Builder
putEx ByteString
x1) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Step -> Builder
forall a. BinaryEx a => a -> Builder
putEx Step
x2 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Step -> Builder
forall a. BinaryEx a => a -> Builder
putEx Step
x3 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Float -> Builder
forall a. BinaryEx a => a -> Builder
putEx Float
x5 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
putExN ([Depends] -> Builder
forall a. BinaryEx a => a -> Builder
putEx [Depends]
x4) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Trace] -> Builder
forall a. BinaryEx a => a -> Builder
putEx [Trace]
x6
putDatabase _ (_, x :: Status
x) = String -> Builder
forall a. String -> a
errorInternal (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ "putWith, Cannot write Status with constructor " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Status -> String
statusType Status
x
getDatabase :: (BS.ByteString -> Key) -> BS.ByteString -> (Key, Status)
getDatabase :: (ByteString -> Key) -> ByteString -> (Key, Status)
getDatabase getKey :: ByteString -> Key
getKey bs :: ByteString
bs
| (key :: ByteString
key, bs :: ByteString
bs) <- ByteString -> (ByteString, ByteString)
getExN ByteString
bs
, (x1 :: ByteString
x1, bs :: ByteString
bs) <- ByteString -> (ByteString, ByteString)
getExN ByteString
bs
, (x2 :: Step
x2, x3 :: Step
x3, x5 :: Float
x5, bs :: ByteString
bs) <- ByteString -> (Step, Step, Float, ByteString)
forall a b c.
(Storable a, Storable b, Storable c) =>
ByteString -> (a, b, c, ByteString)
binarySplit3 ByteString
bs
, (x4 :: ByteString
x4, x6 :: ByteString
x6) <- ByteString -> (ByteString, ByteString)
getExN ByteString
bs
= (ByteString -> Key
getKey ByteString
key, Result ByteString -> Status
Loaded (ByteString
-> Step
-> Step
-> [Depends]
-> Float
-> [Trace]
-> Result ByteString
forall a.
a -> Step -> Step -> [Depends] -> Float -> [Trace] -> Result a
Result ByteString
x1 Step
x2 Step
x3 (ByteString -> [Depends]
forall a. BinaryEx a => ByteString -> a
getEx ByteString
x4) Float
x5 (ByteString -> [Trace]
forall a. BinaryEx a => ByteString -> a
getEx ByteString
x6)))
instance BinaryEx Depends where
putEx :: Depends -> Builder
putEx (Depends xs :: [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
instance BinaryEx Trace where
putEx :: Trace -> Builder
putEx (Trace a :: ByteString
a b :: Float
b c :: 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 x :: ByteString
x | (b :: Float
b,c :: Float
c,a :: 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