{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE DerivingStrategies  #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeOperators       #-}
module Plutus.Contract.Checkpoint(
    -- * Checkpoints
    -- $checkpoints
    Checkpoint(..)
    , CheckpointError(..)
    , AsCheckpointError(..)
    , CheckpointStore(..)
    , CheckpointStoreItem(..)
    , CheckpointKey
    , CheckpointLogMsg(..)
    , jsonCheckpoint
    , jsonCheckpointLoop
    , handleCheckpoint
    , completedIntervals
    , maxKey
    ) where

import Control.Lens
import Control.Monad.Freer
import Control.Monad.Freer.Error (Error, throwError)
import Control.Monad.Freer.Extras.Log (LogMsg, logDebug, logError)
import Control.Monad.Freer.State (State, get, gets, modify, put)
import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey, Value)
import Data.Aeson.Types qualified as JSON
import Data.IntervalMap.Interval (Interval (ClosedInterval))
import Data.IntervalSet qualified as IS
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Text (Text)
import Data.Text qualified as Text
import GHC.Generics (Generic)
import Prettyprinter (Pretty (..), colon, vsep, (<+>))

-- $checkpoints
-- This module contains a checkpoints mechanism that can be used to store
-- intermediate results of 'Control.Monad.Freer.Eff' programs as JSON values
-- inside a 'CheckpointStore'. It works similar to the short-circuiting behavior
-- of 'Control.Monad.Freer.Error.Error': Before we execute an action
-- @Eff effs a@ whose result should be checkpointed, we check if the there is
-- already a value of @a@ for this checkpoint it in the store. If there is, we
-- return it /instead/ of running the action. If there isn't, we run the action
-- @a@ and then store the result.
--
-- * To create a checkpoint use 'jsonCheckpoint'.
-- * To handle the checkpoint effect use 'handleCheckpoint'.


newtype CheckpointKey = CheckpointKey Integer
    deriving stock (CheckpointKey -> CheckpointKey -> Bool
(CheckpointKey -> CheckpointKey -> Bool)
-> (CheckpointKey -> CheckpointKey -> Bool) -> Eq CheckpointKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CheckpointKey -> CheckpointKey -> Bool
$c/= :: CheckpointKey -> CheckpointKey -> Bool
== :: CheckpointKey -> CheckpointKey -> Bool
$c== :: CheckpointKey -> CheckpointKey -> Bool
Eq, Eq CheckpointKey
Eq CheckpointKey
-> (CheckpointKey -> CheckpointKey -> Ordering)
-> (CheckpointKey -> CheckpointKey -> Bool)
-> (CheckpointKey -> CheckpointKey -> Bool)
-> (CheckpointKey -> CheckpointKey -> Bool)
-> (CheckpointKey -> CheckpointKey -> Bool)
-> (CheckpointKey -> CheckpointKey -> CheckpointKey)
-> (CheckpointKey -> CheckpointKey -> CheckpointKey)
-> Ord CheckpointKey
CheckpointKey -> CheckpointKey -> Bool
CheckpointKey -> CheckpointKey -> Ordering
CheckpointKey -> CheckpointKey -> CheckpointKey
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 :: CheckpointKey -> CheckpointKey -> CheckpointKey
$cmin :: CheckpointKey -> CheckpointKey -> CheckpointKey
max :: CheckpointKey -> CheckpointKey -> CheckpointKey
$cmax :: CheckpointKey -> CheckpointKey -> CheckpointKey
>= :: CheckpointKey -> CheckpointKey -> Bool
$c>= :: CheckpointKey -> CheckpointKey -> Bool
> :: CheckpointKey -> CheckpointKey -> Bool
$c> :: CheckpointKey -> CheckpointKey -> Bool
<= :: CheckpointKey -> CheckpointKey -> Bool
$c<= :: CheckpointKey -> CheckpointKey -> Bool
< :: CheckpointKey -> CheckpointKey -> Bool
$c< :: CheckpointKey -> CheckpointKey -> Bool
compare :: CheckpointKey -> CheckpointKey -> Ordering
$ccompare :: CheckpointKey -> CheckpointKey -> Ordering
$cp1Ord :: Eq CheckpointKey
Ord, Int -> CheckpointKey -> ShowS
[CheckpointKey] -> ShowS
CheckpointKey -> String
(Int -> CheckpointKey -> ShowS)
-> (CheckpointKey -> String)
-> ([CheckpointKey] -> ShowS)
-> Show CheckpointKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CheckpointKey] -> ShowS
$cshowList :: [CheckpointKey] -> ShowS
show :: CheckpointKey -> String
$cshow :: CheckpointKey -> String
showsPrec :: Int -> CheckpointKey -> ShowS
$cshowsPrec :: Int -> CheckpointKey -> ShowS
Show, (forall x. CheckpointKey -> Rep CheckpointKey x)
-> (forall x. Rep CheckpointKey x -> CheckpointKey)
-> Generic CheckpointKey
forall x. Rep CheckpointKey x -> CheckpointKey
forall x. CheckpointKey -> Rep CheckpointKey x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CheckpointKey x -> CheckpointKey
$cfrom :: forall x. CheckpointKey -> Rep CheckpointKey x
Generic)
    deriving newtype (Value -> Parser [CheckpointKey]
Value -> Parser CheckpointKey
(Value -> Parser CheckpointKey)
-> (Value -> Parser [CheckpointKey]) -> FromJSON CheckpointKey
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [CheckpointKey]
$cparseJSONList :: Value -> Parser [CheckpointKey]
parseJSON :: Value -> Parser CheckpointKey
$cparseJSON :: Value -> Parser CheckpointKey
FromJSON, [CheckpointKey] -> Encoding
[CheckpointKey] -> Value
CheckpointKey -> Encoding
CheckpointKey -> Value
(CheckpointKey -> Value)
-> (CheckpointKey -> Encoding)
-> ([CheckpointKey] -> Value)
-> ([CheckpointKey] -> Encoding)
-> ToJSON CheckpointKey
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [CheckpointKey] -> Encoding
$ctoEncodingList :: [CheckpointKey] -> Encoding
toJSONList :: [CheckpointKey] -> Value
$ctoJSONList :: [CheckpointKey] -> Value
toEncoding :: CheckpointKey -> Encoding
$ctoEncoding :: CheckpointKey -> Encoding
toJSON :: CheckpointKey -> Value
$ctoJSON :: CheckpointKey -> Value
ToJSON, ToJSONKeyFunction [CheckpointKey]
ToJSONKeyFunction CheckpointKey
ToJSONKeyFunction CheckpointKey
-> ToJSONKeyFunction [CheckpointKey] -> ToJSONKey CheckpointKey
forall a.
ToJSONKeyFunction a -> ToJSONKeyFunction [a] -> ToJSONKey a
toJSONKeyList :: ToJSONKeyFunction [CheckpointKey]
$ctoJSONKeyList :: ToJSONKeyFunction [CheckpointKey]
toJSONKey :: ToJSONKeyFunction CheckpointKey
$ctoJSONKey :: ToJSONKeyFunction CheckpointKey
ToJSONKey, FromJSONKeyFunction [CheckpointKey]
FromJSONKeyFunction CheckpointKey
FromJSONKeyFunction CheckpointKey
-> FromJSONKeyFunction [CheckpointKey] -> FromJSONKey CheckpointKey
forall a.
FromJSONKeyFunction a -> FromJSONKeyFunction [a] -> FromJSONKey a
fromJSONKeyList :: FromJSONKeyFunction [CheckpointKey]
$cfromJSONKeyList :: FromJSONKeyFunction [CheckpointKey]
fromJSONKey :: FromJSONKeyFunction CheckpointKey
$cfromJSONKey :: FromJSONKeyFunction CheckpointKey
FromJSONKey, Integer -> CheckpointKey
CheckpointKey -> CheckpointKey
CheckpointKey -> CheckpointKey -> CheckpointKey
(CheckpointKey -> CheckpointKey -> CheckpointKey)
-> (CheckpointKey -> CheckpointKey -> CheckpointKey)
-> (CheckpointKey -> CheckpointKey -> CheckpointKey)
-> (CheckpointKey -> CheckpointKey)
-> (CheckpointKey -> CheckpointKey)
-> (CheckpointKey -> CheckpointKey)
-> (Integer -> CheckpointKey)
-> Num CheckpointKey
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> CheckpointKey
$cfromInteger :: Integer -> CheckpointKey
signum :: CheckpointKey -> CheckpointKey
$csignum :: CheckpointKey -> CheckpointKey
abs :: CheckpointKey -> CheckpointKey
$cabs :: CheckpointKey -> CheckpointKey
negate :: CheckpointKey -> CheckpointKey
$cnegate :: CheckpointKey -> CheckpointKey
* :: CheckpointKey -> CheckpointKey -> CheckpointKey
$c* :: CheckpointKey -> CheckpointKey -> CheckpointKey
- :: CheckpointKey -> CheckpointKey -> CheckpointKey
$c- :: CheckpointKey -> CheckpointKey -> CheckpointKey
+ :: CheckpointKey -> CheckpointKey -> CheckpointKey
$c+ :: CheckpointKey -> CheckpointKey -> CheckpointKey
Num, Int -> CheckpointKey
CheckpointKey -> Int
CheckpointKey -> [CheckpointKey]
CheckpointKey -> CheckpointKey
CheckpointKey -> CheckpointKey -> [CheckpointKey]
CheckpointKey -> CheckpointKey -> CheckpointKey -> [CheckpointKey]
(CheckpointKey -> CheckpointKey)
-> (CheckpointKey -> CheckpointKey)
-> (Int -> CheckpointKey)
-> (CheckpointKey -> Int)
-> (CheckpointKey -> [CheckpointKey])
-> (CheckpointKey -> CheckpointKey -> [CheckpointKey])
-> (CheckpointKey -> CheckpointKey -> [CheckpointKey])
-> (CheckpointKey
    -> CheckpointKey -> CheckpointKey -> [CheckpointKey])
-> Enum CheckpointKey
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: CheckpointKey -> CheckpointKey -> CheckpointKey -> [CheckpointKey]
$cenumFromThenTo :: CheckpointKey -> CheckpointKey -> CheckpointKey -> [CheckpointKey]
enumFromTo :: CheckpointKey -> CheckpointKey -> [CheckpointKey]
$cenumFromTo :: CheckpointKey -> CheckpointKey -> [CheckpointKey]
enumFromThen :: CheckpointKey -> CheckpointKey -> [CheckpointKey]
$cenumFromThen :: CheckpointKey -> CheckpointKey -> [CheckpointKey]
enumFrom :: CheckpointKey -> [CheckpointKey]
$cenumFrom :: CheckpointKey -> [CheckpointKey]
fromEnum :: CheckpointKey -> Int
$cfromEnum :: CheckpointKey -> Int
toEnum :: Int -> CheckpointKey
$ctoEnum :: Int -> CheckpointKey
pred :: CheckpointKey -> CheckpointKey
$cpred :: CheckpointKey -> CheckpointKey
succ :: CheckpointKey -> CheckpointKey
$csucc :: CheckpointKey -> CheckpointKey
Enum, [CheckpointKey] -> Doc ann
CheckpointKey -> Doc ann
(forall ann. CheckpointKey -> Doc ann)
-> (forall ann. [CheckpointKey] -> Doc ann) -> Pretty CheckpointKey
forall ann. [CheckpointKey] -> Doc ann
forall ann. CheckpointKey -> Doc ann
forall a.
(forall ann. a -> Doc ann)
-> (forall ann. [a] -> Doc ann) -> Pretty a
prettyList :: [CheckpointKey] -> Doc ann
$cprettyList :: forall ann. [CheckpointKey] -> Doc ann
pretty :: CheckpointKey -> Doc ann
$cpretty :: forall ann. CheckpointKey -> Doc ann
Pretty)

data CheckpointError = JSONDecodeError Text
    deriving stock (CheckpointError -> CheckpointError -> Bool
(CheckpointError -> CheckpointError -> Bool)
-> (CheckpointError -> CheckpointError -> Bool)
-> Eq CheckpointError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CheckpointError -> CheckpointError -> Bool
$c/= :: CheckpointError -> CheckpointError -> Bool
== :: CheckpointError -> CheckpointError -> Bool
$c== :: CheckpointError -> CheckpointError -> Bool
Eq, Eq CheckpointError
Eq CheckpointError
-> (CheckpointError -> CheckpointError -> Ordering)
-> (CheckpointError -> CheckpointError -> Bool)
-> (CheckpointError -> CheckpointError -> Bool)
-> (CheckpointError -> CheckpointError -> Bool)
-> (CheckpointError -> CheckpointError -> Bool)
-> (CheckpointError -> CheckpointError -> CheckpointError)
-> (CheckpointError -> CheckpointError -> CheckpointError)
-> Ord CheckpointError
CheckpointError -> CheckpointError -> Bool
CheckpointError -> CheckpointError -> Ordering
CheckpointError -> CheckpointError -> CheckpointError
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 :: CheckpointError -> CheckpointError -> CheckpointError
$cmin :: CheckpointError -> CheckpointError -> CheckpointError
max :: CheckpointError -> CheckpointError -> CheckpointError
$cmax :: CheckpointError -> CheckpointError -> CheckpointError
>= :: CheckpointError -> CheckpointError -> Bool
$c>= :: CheckpointError -> CheckpointError -> Bool
> :: CheckpointError -> CheckpointError -> Bool
$c> :: CheckpointError -> CheckpointError -> Bool
<= :: CheckpointError -> CheckpointError -> Bool
$c<= :: CheckpointError -> CheckpointError -> Bool
< :: CheckpointError -> CheckpointError -> Bool
$c< :: CheckpointError -> CheckpointError -> Bool
compare :: CheckpointError -> CheckpointError -> Ordering
$ccompare :: CheckpointError -> CheckpointError -> Ordering
$cp1Ord :: Eq CheckpointError
Ord, Int -> CheckpointError -> ShowS
[CheckpointError] -> ShowS
CheckpointError -> String
(Int -> CheckpointError -> ShowS)
-> (CheckpointError -> String)
-> ([CheckpointError] -> ShowS)
-> Show CheckpointError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CheckpointError] -> ShowS
$cshowList :: [CheckpointError] -> ShowS
show :: CheckpointError -> String
$cshow :: CheckpointError -> String
showsPrec :: Int -> CheckpointError -> ShowS
$cshowsPrec :: Int -> CheckpointError -> ShowS
Show, (forall x. CheckpointError -> Rep CheckpointError x)
-> (forall x. Rep CheckpointError x -> CheckpointError)
-> Generic CheckpointError
forall x. Rep CheckpointError x -> CheckpointError
forall x. CheckpointError -> Rep CheckpointError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CheckpointError x -> CheckpointError
$cfrom :: forall x. CheckpointError -> Rep CheckpointError x
Generic)
    deriving anyclass (Value -> Parser [CheckpointError]
Value -> Parser CheckpointError
(Value -> Parser CheckpointError)
-> (Value -> Parser [CheckpointError]) -> FromJSON CheckpointError
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [CheckpointError]
$cparseJSONList :: Value -> Parser [CheckpointError]
parseJSON :: Value -> Parser CheckpointError
$cparseJSON :: Value -> Parser CheckpointError
FromJSON, [CheckpointError] -> Encoding
[CheckpointError] -> Value
CheckpointError -> Encoding
CheckpointError -> Value
(CheckpointError -> Value)
-> (CheckpointError -> Encoding)
-> ([CheckpointError] -> Value)
-> ([CheckpointError] -> Encoding)
-> ToJSON CheckpointError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [CheckpointError] -> Encoding
$ctoEncodingList :: [CheckpointError] -> Encoding
toJSONList :: [CheckpointError] -> Value
$ctoJSONList :: [CheckpointError] -> Value
toEncoding :: CheckpointError -> Encoding
$ctoEncoding :: CheckpointError -> Encoding
toJSON :: CheckpointError -> Value
$ctoJSON :: CheckpointError -> Value
ToJSON)

instance Pretty CheckpointError where
    pretty :: CheckpointError -> Doc ann
pretty = \case
        JSONDecodeError Text
t -> Doc ann
"JSON decoding error:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
t

makeClassyPrisms ''CheckpointError

newtype CheckpointStore = CheckpointStore { CheckpointStore -> Map CheckpointKey (CheckpointStoreItem Value)
unCheckpointStore :: Map CheckpointKey (CheckpointStoreItem Value) }
    deriving stock (CheckpointStore -> CheckpointStore -> Bool
(CheckpointStore -> CheckpointStore -> Bool)
-> (CheckpointStore -> CheckpointStore -> Bool)
-> Eq CheckpointStore
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CheckpointStore -> CheckpointStore -> Bool
$c/= :: CheckpointStore -> CheckpointStore -> Bool
== :: CheckpointStore -> CheckpointStore -> Bool
$c== :: CheckpointStore -> CheckpointStore -> Bool
Eq, Int -> CheckpointStore -> ShowS
[CheckpointStore] -> ShowS
CheckpointStore -> String
(Int -> CheckpointStore -> ShowS)
-> (CheckpointStore -> String)
-> ([CheckpointStore] -> ShowS)
-> Show CheckpointStore
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CheckpointStore] -> ShowS
$cshowList :: [CheckpointStore] -> ShowS
show :: CheckpointStore -> String
$cshow :: CheckpointStore -> String
showsPrec :: Int -> CheckpointStore -> ShowS
$cshowsPrec :: Int -> CheckpointStore -> ShowS
Show, (forall x. CheckpointStore -> Rep CheckpointStore x)
-> (forall x. Rep CheckpointStore x -> CheckpointStore)
-> Generic CheckpointStore
forall x. Rep CheckpointStore x -> CheckpointStore
forall x. CheckpointStore -> Rep CheckpointStore x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CheckpointStore x -> CheckpointStore
$cfrom :: forall x. CheckpointStore -> Rep CheckpointStore x
Generic)
    deriving anyclass ([CheckpointStore] -> Encoding
[CheckpointStore] -> Value
CheckpointStore -> Encoding
CheckpointStore -> Value
(CheckpointStore -> Value)
-> (CheckpointStore -> Encoding)
-> ([CheckpointStore] -> Value)
-> ([CheckpointStore] -> Encoding)
-> ToJSON CheckpointStore
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [CheckpointStore] -> Encoding
$ctoEncodingList :: [CheckpointStore] -> Encoding
toJSONList :: [CheckpointStore] -> Value
$ctoJSONList :: [CheckpointStore] -> Value
toEncoding :: CheckpointStore -> Encoding
$ctoEncoding :: CheckpointStore -> Encoding
toJSON :: CheckpointStore -> Value
$ctoJSON :: CheckpointStore -> Value
ToJSON, Value -> Parser [CheckpointStore]
Value -> Parser CheckpointStore
(Value -> Parser CheckpointStore)
-> (Value -> Parser [CheckpointStore]) -> FromJSON CheckpointStore
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [CheckpointStore]
$cparseJSONList :: Value -> Parser [CheckpointStore]
parseJSON :: Value -> Parser CheckpointStore
$cparseJSON :: Value -> Parser CheckpointStore
FromJSON)
    deriving newtype (b -> CheckpointStore -> CheckpointStore
NonEmpty CheckpointStore -> CheckpointStore
CheckpointStore -> CheckpointStore -> CheckpointStore
(CheckpointStore -> CheckpointStore -> CheckpointStore)
-> (NonEmpty CheckpointStore -> CheckpointStore)
-> (forall b.
    Integral b =>
    b -> CheckpointStore -> CheckpointStore)
-> Semigroup CheckpointStore
forall b. Integral b => b -> CheckpointStore -> CheckpointStore
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> CheckpointStore -> CheckpointStore
$cstimes :: forall b. Integral b => b -> CheckpointStore -> CheckpointStore
sconcat :: NonEmpty CheckpointStore -> CheckpointStore
$csconcat :: NonEmpty CheckpointStore -> CheckpointStore
<> :: CheckpointStore -> CheckpointStore -> CheckpointStore
$c<> :: CheckpointStore -> CheckpointStore -> CheckpointStore
Semigroup, Semigroup CheckpointStore
CheckpointStore
Semigroup CheckpointStore
-> CheckpointStore
-> (CheckpointStore -> CheckpointStore -> CheckpointStore)
-> ([CheckpointStore] -> CheckpointStore)
-> Monoid CheckpointStore
[CheckpointStore] -> CheckpointStore
CheckpointStore -> CheckpointStore -> CheckpointStore
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [CheckpointStore] -> CheckpointStore
$cmconcat :: [CheckpointStore] -> CheckpointStore
mappend :: CheckpointStore -> CheckpointStore -> CheckpointStore
$cmappend :: CheckpointStore -> CheckpointStore -> CheckpointStore
mempty :: CheckpointStore
$cmempty :: CheckpointStore
$cp1Monoid :: Semigroup CheckpointStore
Monoid)

instance Pretty CheckpointStore where
    pretty :: CheckpointStore -> Doc ann
pretty (CheckpointStore Map CheckpointKey (CheckpointStoreItem Value)
mp) =
        let p :: a -> a -> Doc ann
p a
k a
v = a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
k Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> (String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> (a -> String) -> a -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
100 ShowS -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show) a
v in
        [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ((CheckpointKey -> CheckpointStoreItem Value -> Doc ann)
-> (CheckpointKey, CheckpointStoreItem Value) -> Doc ann
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry CheckpointKey -> CheckpointStoreItem Value -> Doc ann
forall a a ann. (Pretty a, Show a) => a -> a -> Doc ann
p ((CheckpointKey, CheckpointStoreItem Value) -> Doc ann)
-> [(CheckpointKey, CheckpointStoreItem Value)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map CheckpointKey (CheckpointStoreItem Value)
-> [(CheckpointKey, CheckpointStoreItem Value)]
forall k a. Map k a -> [(k, a)]
Map.toList Map CheckpointKey (CheckpointStoreItem Value)
mp)

_CheckpointStore :: Iso' CheckpointStore (Map CheckpointKey (CheckpointStoreItem Value))
_CheckpointStore :: p (Map CheckpointKey (CheckpointStoreItem Value))
  (f (Map CheckpointKey (CheckpointStoreItem Value)))
-> p CheckpointStore (f CheckpointStore)
_CheckpointStore = (CheckpointStore -> Map CheckpointKey (CheckpointStoreItem Value))
-> (Map CheckpointKey (CheckpointStoreItem Value)
    -> CheckpointStore)
-> Iso
     CheckpointStore
     CheckpointStore
     (Map CheckpointKey (CheckpointStoreItem Value))
     (Map CheckpointKey (CheckpointStoreItem Value))
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso CheckpointStore -> Map CheckpointKey (CheckpointStoreItem Value)
unCheckpointStore Map CheckpointKey (CheckpointStoreItem Value) -> CheckpointStore
CheckpointStore

-- | Intervals of checkpoint keys that are completely covered by the
--   checkpoint store.
completedIntervals :: CheckpointStore -> IS.IntervalSet (Interval CheckpointKey)
completedIntervals :: CheckpointStore -> IntervalSet (Interval CheckpointKey)
completedIntervals = [Interval CheckpointKey] -> IntervalSet (Interval CheckpointKey)
forall k e. (Interval k e, Ord k) => [k] -> IntervalSet k
IS.fromList ([Interval CheckpointKey] -> IntervalSet (Interval CheckpointKey))
-> (CheckpointStore -> [Interval CheckpointKey])
-> CheckpointStore
-> IntervalSet (Interval CheckpointKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CheckpointKey, CheckpointStoreItem Value)
 -> Interval CheckpointKey)
-> [(CheckpointKey, CheckpointStoreItem Value)]
-> [Interval CheckpointKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CheckpointKey
 -> CheckpointStoreItem Value -> Interval CheckpointKey)
-> (CheckpointKey, CheckpointStoreItem Value)
-> Interval CheckpointKey
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry CheckpointKey
-> CheckpointStoreItem Value -> Interval CheckpointKey
forall a.
CheckpointKey -> CheckpointStoreItem a -> Interval CheckpointKey
f) ([(CheckpointKey, CheckpointStoreItem Value)]
 -> [Interval CheckpointKey])
-> (CheckpointStore
    -> [(CheckpointKey, CheckpointStoreItem Value)])
-> CheckpointStore
-> [Interval CheckpointKey]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map CheckpointKey (CheckpointStoreItem Value)
-> [(CheckpointKey, CheckpointStoreItem Value)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map CheckpointKey (CheckpointStoreItem Value)
 -> [(CheckpointKey, CheckpointStoreItem Value)])
-> (CheckpointStore
    -> Map CheckpointKey (CheckpointStoreItem Value))
-> CheckpointStore
-> [(CheckpointKey, CheckpointStoreItem Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckpointStore -> Map CheckpointKey (CheckpointStoreItem Value)
unCheckpointStore where
    f :: CheckpointKey -> CheckpointStoreItem a -> Interval CheckpointKey
f (CheckpointKey
from_ :: CheckpointKey) CheckpointStoreItem{CheckpointKey
csNewKey :: forall a. CheckpointStoreItem a -> CheckpointKey
csNewKey :: CheckpointKey
csNewKey} = CheckpointKey -> CheckpointKey -> Interval CheckpointKey
forall a. a -> a -> Interval a
ClosedInterval CheckpointKey
from_ CheckpointKey
csNewKey

-- | The maximum key that is present in the store
maxKey :: CheckpointStore -> Maybe CheckpointKey
maxKey :: CheckpointStore -> Maybe CheckpointKey
maxKey = ((CheckpointKey, CheckpointStoreItem Value) -> CheckpointKey)
-> Maybe (CheckpointKey, CheckpointStoreItem Value)
-> Maybe CheckpointKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CheckpointKey, CheckpointStoreItem Value) -> CheckpointKey
forall a b. (a, b) -> a
fst (Maybe (CheckpointKey, CheckpointStoreItem Value)
 -> Maybe CheckpointKey)
-> (CheckpointStore
    -> Maybe (CheckpointKey, CheckpointStoreItem Value))
-> CheckpointStore
-> Maybe CheckpointKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map CheckpointKey (CheckpointStoreItem Value)
-> Maybe (CheckpointKey, CheckpointStoreItem Value)
forall k a. Map k a -> Maybe (k, a)
Map.lookupMax (Map CheckpointKey (CheckpointStoreItem Value)
 -> Maybe (CheckpointKey, CheckpointStoreItem Value))
-> (CheckpointStore
    -> Map CheckpointKey (CheckpointStoreItem Value))
-> CheckpointStore
-> Maybe (CheckpointKey, CheckpointStoreItem Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckpointStore -> Map CheckpointKey (CheckpointStoreItem Value)
unCheckpointStore

data CheckpointStoreItem a =
    CheckpointStoreItem
        { CheckpointStoreItem a -> a
csValue  :: a
        , CheckpointStoreItem a -> CheckpointKey
csNewKey :: CheckpointKey
        }
    deriving stock (CheckpointStoreItem a -> CheckpointStoreItem a -> Bool
(CheckpointStoreItem a -> CheckpointStoreItem a -> Bool)
-> (CheckpointStoreItem a -> CheckpointStoreItem a -> Bool)
-> Eq (CheckpointStoreItem a)
forall a.
Eq a =>
CheckpointStoreItem a -> CheckpointStoreItem a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CheckpointStoreItem a -> CheckpointStoreItem a -> Bool
$c/= :: forall a.
Eq a =>
CheckpointStoreItem a -> CheckpointStoreItem a -> Bool
== :: CheckpointStoreItem a -> CheckpointStoreItem a -> Bool
$c== :: forall a.
Eq a =>
CheckpointStoreItem a -> CheckpointStoreItem a -> Bool
Eq, Eq (CheckpointStoreItem a)
Eq (CheckpointStoreItem a)
-> (CheckpointStoreItem a -> CheckpointStoreItem a -> Ordering)
-> (CheckpointStoreItem a -> CheckpointStoreItem a -> Bool)
-> (CheckpointStoreItem a -> CheckpointStoreItem a -> Bool)
-> (CheckpointStoreItem a -> CheckpointStoreItem a -> Bool)
-> (CheckpointStoreItem a -> CheckpointStoreItem a -> Bool)
-> (CheckpointStoreItem a
    -> CheckpointStoreItem a -> CheckpointStoreItem a)
-> (CheckpointStoreItem a
    -> CheckpointStoreItem a -> CheckpointStoreItem a)
-> Ord (CheckpointStoreItem a)
CheckpointStoreItem a -> CheckpointStoreItem a -> Bool
CheckpointStoreItem a -> CheckpointStoreItem a -> Ordering
CheckpointStoreItem a
-> CheckpointStoreItem a -> CheckpointStoreItem a
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
forall a. Ord a => Eq (CheckpointStoreItem a)
forall a.
Ord a =>
CheckpointStoreItem a -> CheckpointStoreItem a -> Bool
forall a.
Ord a =>
CheckpointStoreItem a -> CheckpointStoreItem a -> Ordering
forall a.
Ord a =>
CheckpointStoreItem a
-> CheckpointStoreItem a -> CheckpointStoreItem a
min :: CheckpointStoreItem a
-> CheckpointStoreItem a -> CheckpointStoreItem a
$cmin :: forall a.
Ord a =>
CheckpointStoreItem a
-> CheckpointStoreItem a -> CheckpointStoreItem a
max :: CheckpointStoreItem a
-> CheckpointStoreItem a -> CheckpointStoreItem a
$cmax :: forall a.
Ord a =>
CheckpointStoreItem a
-> CheckpointStoreItem a -> CheckpointStoreItem a
>= :: CheckpointStoreItem a -> CheckpointStoreItem a -> Bool
$c>= :: forall a.
Ord a =>
CheckpointStoreItem a -> CheckpointStoreItem a -> Bool
> :: CheckpointStoreItem a -> CheckpointStoreItem a -> Bool
$c> :: forall a.
Ord a =>
CheckpointStoreItem a -> CheckpointStoreItem a -> Bool
<= :: CheckpointStoreItem a -> CheckpointStoreItem a -> Bool
$c<= :: forall a.
Ord a =>
CheckpointStoreItem a -> CheckpointStoreItem a -> Bool
< :: CheckpointStoreItem a -> CheckpointStoreItem a -> Bool
$c< :: forall a.
Ord a =>
CheckpointStoreItem a -> CheckpointStoreItem a -> Bool
compare :: CheckpointStoreItem a -> CheckpointStoreItem a -> Ordering
$ccompare :: forall a.
Ord a =>
CheckpointStoreItem a -> CheckpointStoreItem a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (CheckpointStoreItem a)
Ord, Int -> CheckpointStoreItem a -> ShowS
[CheckpointStoreItem a] -> ShowS
CheckpointStoreItem a -> String
(Int -> CheckpointStoreItem a -> ShowS)
-> (CheckpointStoreItem a -> String)
-> ([CheckpointStoreItem a] -> ShowS)
-> Show (CheckpointStoreItem a)
forall a. Show a => Int -> CheckpointStoreItem a -> ShowS
forall a. Show a => [CheckpointStoreItem a] -> ShowS
forall a. Show a => CheckpointStoreItem a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CheckpointStoreItem a] -> ShowS
$cshowList :: forall a. Show a => [CheckpointStoreItem a] -> ShowS
show :: CheckpointStoreItem a -> String
$cshow :: forall a. Show a => CheckpointStoreItem a -> String
showsPrec :: Int -> CheckpointStoreItem a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> CheckpointStoreItem a -> ShowS
Show, (forall x. CheckpointStoreItem a -> Rep (CheckpointStoreItem a) x)
-> (forall x.
    Rep (CheckpointStoreItem a) x -> CheckpointStoreItem a)
-> Generic (CheckpointStoreItem a)
forall x. Rep (CheckpointStoreItem a) x -> CheckpointStoreItem a
forall x. CheckpointStoreItem a -> Rep (CheckpointStoreItem a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (CheckpointStoreItem a) x -> CheckpointStoreItem a
forall a x. CheckpointStoreItem a -> Rep (CheckpointStoreItem a) x
$cto :: forall a x. Rep (CheckpointStoreItem a) x -> CheckpointStoreItem a
$cfrom :: forall a x. CheckpointStoreItem a -> Rep (CheckpointStoreItem a) x
Generic, a -> CheckpointStoreItem b -> CheckpointStoreItem a
(a -> b) -> CheckpointStoreItem a -> CheckpointStoreItem b
(forall a b.
 (a -> b) -> CheckpointStoreItem a -> CheckpointStoreItem b)
-> (forall a b.
    a -> CheckpointStoreItem b -> CheckpointStoreItem a)
-> Functor CheckpointStoreItem
forall a b. a -> CheckpointStoreItem b -> CheckpointStoreItem a
forall a b.
(a -> b) -> CheckpointStoreItem a -> CheckpointStoreItem b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> CheckpointStoreItem b -> CheckpointStoreItem a
$c<$ :: forall a b. a -> CheckpointStoreItem b -> CheckpointStoreItem a
fmap :: (a -> b) -> CheckpointStoreItem a -> CheckpointStoreItem b
$cfmap :: forall a b.
(a -> b) -> CheckpointStoreItem a -> CheckpointStoreItem b
Functor, CheckpointStoreItem a -> Bool
(a -> m) -> CheckpointStoreItem a -> m
(a -> b -> b) -> b -> CheckpointStoreItem a -> b
(forall m. Monoid m => CheckpointStoreItem m -> m)
-> (forall m a. Monoid m => (a -> m) -> CheckpointStoreItem a -> m)
-> (forall m a. Monoid m => (a -> m) -> CheckpointStoreItem a -> m)
-> (forall a b. (a -> b -> b) -> b -> CheckpointStoreItem a -> b)
-> (forall a b. (a -> b -> b) -> b -> CheckpointStoreItem a -> b)
-> (forall b a. (b -> a -> b) -> b -> CheckpointStoreItem a -> b)
-> (forall b a. (b -> a -> b) -> b -> CheckpointStoreItem a -> b)
-> (forall a. (a -> a -> a) -> CheckpointStoreItem a -> a)
-> (forall a. (a -> a -> a) -> CheckpointStoreItem a -> a)
-> (forall a. CheckpointStoreItem a -> [a])
-> (forall a. CheckpointStoreItem a -> Bool)
-> (forall a. CheckpointStoreItem a -> Int)
-> (forall a. Eq a => a -> CheckpointStoreItem a -> Bool)
-> (forall a. Ord a => CheckpointStoreItem a -> a)
-> (forall a. Ord a => CheckpointStoreItem a -> a)
-> (forall a. Num a => CheckpointStoreItem a -> a)
-> (forall a. Num a => CheckpointStoreItem a -> a)
-> Foldable CheckpointStoreItem
forall a. Eq a => a -> CheckpointStoreItem a -> Bool
forall a. Num a => CheckpointStoreItem a -> a
forall a. Ord a => CheckpointStoreItem a -> a
forall m. Monoid m => CheckpointStoreItem m -> m
forall a. CheckpointStoreItem a -> Bool
forall a. CheckpointStoreItem a -> Int
forall a. CheckpointStoreItem a -> [a]
forall a. (a -> a -> a) -> CheckpointStoreItem a -> a
forall m a. Monoid m => (a -> m) -> CheckpointStoreItem a -> m
forall b a. (b -> a -> b) -> b -> CheckpointStoreItem a -> b
forall a b. (a -> b -> b) -> b -> CheckpointStoreItem a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: CheckpointStoreItem a -> a
$cproduct :: forall a. Num a => CheckpointStoreItem a -> a
sum :: CheckpointStoreItem a -> a
$csum :: forall a. Num a => CheckpointStoreItem a -> a
minimum :: CheckpointStoreItem a -> a
$cminimum :: forall a. Ord a => CheckpointStoreItem a -> a
maximum :: CheckpointStoreItem a -> a
$cmaximum :: forall a. Ord a => CheckpointStoreItem a -> a
elem :: a -> CheckpointStoreItem a -> Bool
$celem :: forall a. Eq a => a -> CheckpointStoreItem a -> Bool
length :: CheckpointStoreItem a -> Int
$clength :: forall a. CheckpointStoreItem a -> Int
null :: CheckpointStoreItem a -> Bool
$cnull :: forall a. CheckpointStoreItem a -> Bool
toList :: CheckpointStoreItem a -> [a]
$ctoList :: forall a. CheckpointStoreItem a -> [a]
foldl1 :: (a -> a -> a) -> CheckpointStoreItem a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> CheckpointStoreItem a -> a
foldr1 :: (a -> a -> a) -> CheckpointStoreItem a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> CheckpointStoreItem a -> a
foldl' :: (b -> a -> b) -> b -> CheckpointStoreItem a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> CheckpointStoreItem a -> b
foldl :: (b -> a -> b) -> b -> CheckpointStoreItem a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> CheckpointStoreItem a -> b
foldr' :: (a -> b -> b) -> b -> CheckpointStoreItem a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> CheckpointStoreItem a -> b
foldr :: (a -> b -> b) -> b -> CheckpointStoreItem a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> CheckpointStoreItem a -> b
foldMap' :: (a -> m) -> CheckpointStoreItem a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> CheckpointStoreItem a -> m
foldMap :: (a -> m) -> CheckpointStoreItem a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> CheckpointStoreItem a -> m
fold :: CheckpointStoreItem m -> m
$cfold :: forall m. Monoid m => CheckpointStoreItem m -> m
Foldable, Functor CheckpointStoreItem
Foldable CheckpointStoreItem
Functor CheckpointStoreItem
-> Foldable CheckpointStoreItem
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> CheckpointStoreItem a -> f (CheckpointStoreItem b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    CheckpointStoreItem (f a) -> f (CheckpointStoreItem a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> CheckpointStoreItem a -> m (CheckpointStoreItem b))
-> (forall (m :: * -> *) a.
    Monad m =>
    CheckpointStoreItem (m a) -> m (CheckpointStoreItem a))
-> Traversable CheckpointStoreItem
(a -> f b) -> CheckpointStoreItem a -> f (CheckpointStoreItem b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
CheckpointStoreItem (m a) -> m (CheckpointStoreItem a)
forall (f :: * -> *) a.
Applicative f =>
CheckpointStoreItem (f a) -> f (CheckpointStoreItem a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> CheckpointStoreItem a -> m (CheckpointStoreItem b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> CheckpointStoreItem a -> f (CheckpointStoreItem b)
sequence :: CheckpointStoreItem (m a) -> m (CheckpointStoreItem a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
CheckpointStoreItem (m a) -> m (CheckpointStoreItem a)
mapM :: (a -> m b) -> CheckpointStoreItem a -> m (CheckpointStoreItem b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> CheckpointStoreItem a -> m (CheckpointStoreItem b)
sequenceA :: CheckpointStoreItem (f a) -> f (CheckpointStoreItem a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
CheckpointStoreItem (f a) -> f (CheckpointStoreItem a)
traverse :: (a -> f b) -> CheckpointStoreItem a -> f (CheckpointStoreItem b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> CheckpointStoreItem a -> f (CheckpointStoreItem b)
$cp2Traversable :: Foldable CheckpointStoreItem
$cp1Traversable :: Functor CheckpointStoreItem
Traversable)
    deriving anyclass ([CheckpointStoreItem a] -> Encoding
[CheckpointStoreItem a] -> Value
CheckpointStoreItem a -> Encoding
CheckpointStoreItem a -> Value
(CheckpointStoreItem a -> Value)
-> (CheckpointStoreItem a -> Encoding)
-> ([CheckpointStoreItem a] -> Value)
-> ([CheckpointStoreItem a] -> Encoding)
-> ToJSON (CheckpointStoreItem a)
forall a. ToJSON a => [CheckpointStoreItem a] -> Encoding
forall a. ToJSON a => [CheckpointStoreItem a] -> Value
forall a. ToJSON a => CheckpointStoreItem a -> Encoding
forall a. ToJSON a => CheckpointStoreItem a -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [CheckpointStoreItem a] -> Encoding
$ctoEncodingList :: forall a. ToJSON a => [CheckpointStoreItem a] -> Encoding
toJSONList :: [CheckpointStoreItem a] -> Value
$ctoJSONList :: forall a. ToJSON a => [CheckpointStoreItem a] -> Value
toEncoding :: CheckpointStoreItem a -> Encoding
$ctoEncoding :: forall a. ToJSON a => CheckpointStoreItem a -> Encoding
toJSON :: CheckpointStoreItem a -> Value
$ctoJSON :: forall a. ToJSON a => CheckpointStoreItem a -> Value
ToJSON, Value -> Parser [CheckpointStoreItem a]
Value -> Parser (CheckpointStoreItem a)
(Value -> Parser (CheckpointStoreItem a))
-> (Value -> Parser [CheckpointStoreItem a])
-> FromJSON (CheckpointStoreItem a)
forall a. FromJSON a => Value -> Parser [CheckpointStoreItem a]
forall a. FromJSON a => Value -> Parser (CheckpointStoreItem a)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [CheckpointStoreItem a]
$cparseJSONList :: forall a. FromJSON a => Value -> Parser [CheckpointStoreItem a]
parseJSON :: Value -> Parser (CheckpointStoreItem a)
$cparseJSON :: forall a. FromJSON a => Value -> Parser (CheckpointStoreItem a)
FromJSON)

data CheckpointLogMsg =
    LogFoundValueRestoringKey CheckpointKey
    | LogDecodingErrorAtKey CheckpointKey
    | LogNoValueForKey CheckpointKey
    | LogDoCheckpoint
    | LogAllocateKey
    | LogRetrieve CheckpointKey
    | LogStore CheckpointKey CheckpointKey
    | LogKeyUpdate CheckpointKey CheckpointKey
    deriving (CheckpointLogMsg -> CheckpointLogMsg -> Bool
(CheckpointLogMsg -> CheckpointLogMsg -> Bool)
-> (CheckpointLogMsg -> CheckpointLogMsg -> Bool)
-> Eq CheckpointLogMsg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CheckpointLogMsg -> CheckpointLogMsg -> Bool
$c/= :: CheckpointLogMsg -> CheckpointLogMsg -> Bool
== :: CheckpointLogMsg -> CheckpointLogMsg -> Bool
$c== :: CheckpointLogMsg -> CheckpointLogMsg -> Bool
Eq, Eq CheckpointLogMsg
Eq CheckpointLogMsg
-> (CheckpointLogMsg -> CheckpointLogMsg -> Ordering)
-> (CheckpointLogMsg -> CheckpointLogMsg -> Bool)
-> (CheckpointLogMsg -> CheckpointLogMsg -> Bool)
-> (CheckpointLogMsg -> CheckpointLogMsg -> Bool)
-> (CheckpointLogMsg -> CheckpointLogMsg -> Bool)
-> (CheckpointLogMsg -> CheckpointLogMsg -> CheckpointLogMsg)
-> (CheckpointLogMsg -> CheckpointLogMsg -> CheckpointLogMsg)
-> Ord CheckpointLogMsg
CheckpointLogMsg -> CheckpointLogMsg -> Bool
CheckpointLogMsg -> CheckpointLogMsg -> Ordering
CheckpointLogMsg -> CheckpointLogMsg -> CheckpointLogMsg
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 :: CheckpointLogMsg -> CheckpointLogMsg -> CheckpointLogMsg
$cmin :: CheckpointLogMsg -> CheckpointLogMsg -> CheckpointLogMsg
max :: CheckpointLogMsg -> CheckpointLogMsg -> CheckpointLogMsg
$cmax :: CheckpointLogMsg -> CheckpointLogMsg -> CheckpointLogMsg
>= :: CheckpointLogMsg -> CheckpointLogMsg -> Bool
$c>= :: CheckpointLogMsg -> CheckpointLogMsg -> Bool
> :: CheckpointLogMsg -> CheckpointLogMsg -> Bool
$c> :: CheckpointLogMsg -> CheckpointLogMsg -> Bool
<= :: CheckpointLogMsg -> CheckpointLogMsg -> Bool
$c<= :: CheckpointLogMsg -> CheckpointLogMsg -> Bool
< :: CheckpointLogMsg -> CheckpointLogMsg -> Bool
$c< :: CheckpointLogMsg -> CheckpointLogMsg -> Bool
compare :: CheckpointLogMsg -> CheckpointLogMsg -> Ordering
$ccompare :: CheckpointLogMsg -> CheckpointLogMsg -> Ordering
$cp1Ord :: Eq CheckpointLogMsg
Ord, Int -> CheckpointLogMsg -> ShowS
[CheckpointLogMsg] -> ShowS
CheckpointLogMsg -> String
(Int -> CheckpointLogMsg -> ShowS)
-> (CheckpointLogMsg -> String)
-> ([CheckpointLogMsg] -> ShowS)
-> Show CheckpointLogMsg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CheckpointLogMsg] -> ShowS
$cshowList :: [CheckpointLogMsg] -> ShowS
show :: CheckpointLogMsg -> String
$cshow :: CheckpointLogMsg -> String
showsPrec :: Int -> CheckpointLogMsg -> ShowS
$cshowsPrec :: Int -> CheckpointLogMsg -> ShowS
Show, (forall x. CheckpointLogMsg -> Rep CheckpointLogMsg x)
-> (forall x. Rep CheckpointLogMsg x -> CheckpointLogMsg)
-> Generic CheckpointLogMsg
forall x. Rep CheckpointLogMsg x -> CheckpointLogMsg
forall x. CheckpointLogMsg -> Rep CheckpointLogMsg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CheckpointLogMsg x -> CheckpointLogMsg
$cfrom :: forall x. CheckpointLogMsg -> Rep CheckpointLogMsg x
Generic)
    deriving anyclass ([CheckpointLogMsg] -> Encoding
[CheckpointLogMsg] -> Value
CheckpointLogMsg -> Encoding
CheckpointLogMsg -> Value
(CheckpointLogMsg -> Value)
-> (CheckpointLogMsg -> Encoding)
-> ([CheckpointLogMsg] -> Value)
-> ([CheckpointLogMsg] -> Encoding)
-> ToJSON CheckpointLogMsg
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [CheckpointLogMsg] -> Encoding
$ctoEncodingList :: [CheckpointLogMsg] -> Encoding
toJSONList :: [CheckpointLogMsg] -> Value
$ctoJSONList :: [CheckpointLogMsg] -> Value
toEncoding :: CheckpointLogMsg -> Encoding
$ctoEncoding :: CheckpointLogMsg -> Encoding
toJSON :: CheckpointLogMsg -> Value
$ctoJSON :: CheckpointLogMsg -> Value
ToJSON, Value -> Parser [CheckpointLogMsg]
Value -> Parser CheckpointLogMsg
(Value -> Parser CheckpointLogMsg)
-> (Value -> Parser [CheckpointLogMsg])
-> FromJSON CheckpointLogMsg
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [CheckpointLogMsg]
$cparseJSONList :: Value -> Parser [CheckpointLogMsg]
parseJSON :: Value -> Parser CheckpointLogMsg
$cparseJSON :: Value -> Parser CheckpointLogMsg
FromJSON)

instance Pretty CheckpointLogMsg where
    pretty :: CheckpointLogMsg -> Doc ann
pretty = \case
        LogFoundValueRestoringKey CheckpointKey
k -> Doc ann
"Found a value, restoring previous key" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> CheckpointKey -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty CheckpointKey
k
        LogDecodingErrorAtKey CheckpointKey
k     -> Doc ann
"Decoding error at key" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> CheckpointKey -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty CheckpointKey
k
        LogNoValueForKey CheckpointKey
k          -> Doc ann
"No value for key" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> CheckpointKey -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty CheckpointKey
k Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
". The action will be once."
        CheckpointLogMsg
LogDoCheckpoint             -> Doc ann
"doCheckpoint"
        CheckpointLogMsg
LogAllocateKey              -> Doc ann
"allocateKey"
        LogRetrieve CheckpointKey
k               -> Doc ann
"retrieve" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> CheckpointKey -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty CheckpointKey
k
        LogStore CheckpointKey
k1 CheckpointKey
k2              -> Doc ann
"Store; key1:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> CheckpointKey -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty CheckpointKey
k1 Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"; key2:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> CheckpointKey -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty CheckpointKey
k2
        LogKeyUpdate CheckpointKey
k1 CheckpointKey
k2          -> Doc ann
"Key update; key then:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> CheckpointKey -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty CheckpointKey
k1 Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"; key now:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> CheckpointKey -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty CheckpointKey
k2

{-| Insert a new value into the checkpoint store. The first 'CheckpointKey' is
    the checkpoint key *before* running the checkpointed action, the second
    'Checkpoint' key is the value *after* running it. When we restore the
    checkpoint from the state (in 'restore') we set the 'CheckpointKey' state
    to the second argument to prevent chaos.
-}
insert ::
    ( ToJSON a
    , Member (State CheckpointStore) effs
    )
    => CheckpointKey
    -> CheckpointKey
    -> a
    -> Eff effs ()
insert :: CheckpointKey -> CheckpointKey -> a -> Eff effs ()
insert CheckpointKey
k CheckpointKey
k' a
v =
    let vl :: CheckpointStoreItem Value
vl = CheckpointStoreItem :: forall a. a -> CheckpointKey -> CheckpointStoreItem a
CheckpointStoreItem{csValue :: Value
csValue = a -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON a
v, csNewKey :: CheckpointKey
csNewKey = CheckpointKey
k'}
    in (CheckpointStore -> CheckpointStore) -> Eff effs ()
forall s (effs :: [* -> *]).
Member (State s) effs =>
(s -> s) -> Eff effs ()
modify (ASetter
  CheckpointStore
  CheckpointStore
  (Map CheckpointKey (CheckpointStoreItem Value))
  (Map CheckpointKey (CheckpointStoreItem Value))
-> (Map CheckpointKey (CheckpointStoreItem Value)
    -> Map CheckpointKey (CheckpointStoreItem Value))
-> CheckpointStore
-> CheckpointStore
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  CheckpointStore
  CheckpointStore
  (Map CheckpointKey (CheckpointStoreItem Value))
  (Map CheckpointKey (CheckpointStoreItem Value))
Iso
  CheckpointStore
  CheckpointStore
  (Map CheckpointKey (CheckpointStoreItem Value))
  (Map CheckpointKey (CheckpointStoreItem Value))
_CheckpointStore (CheckpointKey
-> CheckpointStoreItem Value
-> Map CheckpointKey (CheckpointStoreItem Value)
-> Map CheckpointKey (CheckpointStoreItem Value)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CheckpointKey
k CheckpointStoreItem Value
vl))

{-| @restore k@ checks for an entry for @k@ in the checkpoint store,
    and parses the result if there is such an entry. It returns

    * @Right Nothing@ if no entry was found
    * @Left err@ if an entry was found but failed to parse with the
      'FromJSON' instance
    * @Right (Just a)@ if an entry was found and parsed succesfully.

-}
restore ::
    forall a effs.
    ( FromJSON a
    , Member (State CheckpointStore) effs
    , Member (State CheckpointKey) effs
    , Member (LogMsg CheckpointLogMsg) effs
    )
    => CheckpointKey
    -> Eff effs (Either CheckpointError (Maybe a))
restore :: CheckpointKey -> Eff effs (Either CheckpointError (Maybe a))
restore CheckpointKey
k = do
    Maybe (CheckpointStoreItem Value)
value <- (CheckpointStore -> Maybe (CheckpointStoreItem Value))
-> Eff effs (Maybe (CheckpointStoreItem Value))
forall s a (effs :: [* -> *]).
Member (State s) effs =>
(s -> a) -> Eff effs a
gets (Getting
  (Maybe (CheckpointStoreItem Value))
  CheckpointStore
  (Maybe (CheckpointStoreItem Value))
-> CheckpointStore -> Maybe (CheckpointStoreItem Value)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (Maybe (CheckpointStoreItem Value))
   CheckpointStore
   (Maybe (CheckpointStoreItem Value))
 -> CheckpointStore -> Maybe (CheckpointStoreItem Value))
-> Getting
     (Maybe (CheckpointStoreItem Value))
     CheckpointStore
     (Maybe (CheckpointStoreItem Value))
-> CheckpointStore
-> Maybe (CheckpointStoreItem Value)
forall a b. (a -> b) -> a -> b
$ (Map CheckpointKey (CheckpointStoreItem Value)
 -> Const
      (Maybe (CheckpointStoreItem Value))
      (Map CheckpointKey (CheckpointStoreItem Value)))
-> CheckpointStore
-> Const (Maybe (CheckpointStoreItem Value)) CheckpointStore
Iso
  CheckpointStore
  CheckpointStore
  (Map CheckpointKey (CheckpointStoreItem Value))
  (Map CheckpointKey (CheckpointStoreItem Value))
_CheckpointStore ((Map CheckpointKey (CheckpointStoreItem Value)
  -> Const
       (Maybe (CheckpointStoreItem Value))
       (Map CheckpointKey (CheckpointStoreItem Value)))
 -> CheckpointStore
 -> Const (Maybe (CheckpointStoreItem Value)) CheckpointStore)
-> ((Maybe (CheckpointStoreItem Value)
     -> Const
          (Maybe (CheckpointStoreItem Value))
          (Maybe (CheckpointStoreItem Value)))
    -> Map CheckpointKey (CheckpointStoreItem Value)
    -> Const
         (Maybe (CheckpointStoreItem Value))
         (Map CheckpointKey (CheckpointStoreItem Value)))
-> Getting
     (Maybe (CheckpointStoreItem Value))
     CheckpointStore
     (Maybe (CheckpointStoreItem Value))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map CheckpointKey (CheckpointStoreItem Value))
-> Lens'
     (Map CheckpointKey (CheckpointStoreItem Value))
     (Maybe (IxValue (Map CheckpointKey (CheckpointStoreItem Value))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map CheckpointKey (CheckpointStoreItem Value))
CheckpointKey
k)
    let (Maybe (Either String (CheckpointStoreItem a))
result :: Maybe (Either String (CheckpointStoreItem a))) = (CheckpointStoreItem Value
 -> Either String (CheckpointStoreItem a))
-> Maybe (CheckpointStoreItem Value)
-> Maybe (Either String (CheckpointStoreItem a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Value -> Either String a)
-> CheckpointStoreItem Value
-> Either String (CheckpointStoreItem a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Value -> Parser a) -> Value -> Either String a
forall a b. (a -> Parser b) -> a -> Either String b
JSON.parseEither Value -> Parser a
forall a. FromJSON a => Value -> Parser a
JSON.parseJSON)) Maybe (CheckpointStoreItem Value)
value
    case Maybe (Either String (CheckpointStoreItem a))
result of
        Maybe (Either String (CheckpointStoreItem a))
Nothing -> do
            CheckpointLogMsg -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logDebug (CheckpointKey -> CheckpointLogMsg
LogNoValueForKey CheckpointKey
k)
            Either CheckpointError (Maybe a)
-> Eff effs (Either CheckpointError (Maybe a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CheckpointError (Maybe a)
 -> Eff effs (Either CheckpointError (Maybe a)))
-> Either CheckpointError (Maybe a)
-> Eff effs (Either CheckpointError (Maybe a))
forall a b. (a -> b) -> a -> b
$ Maybe a -> Either CheckpointError (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
        Just (Left String
err) -> do
            CheckpointLogMsg -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logError (CheckpointKey -> CheckpointLogMsg
LogDecodingErrorAtKey CheckpointKey
k)
            Either CheckpointError (Maybe a)
-> Eff effs (Either CheckpointError (Maybe a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CheckpointError (Maybe a)
 -> Eff effs (Either CheckpointError (Maybe a)))
-> Either CheckpointError (Maybe a)
-> Eff effs (Either CheckpointError (Maybe a))
forall a b. (a -> b) -> a -> b
$ CheckpointError -> Either CheckpointError (Maybe a)
forall a b. a -> Either a b
Left (Text -> CheckpointError
JSONDecodeError (Text -> CheckpointError) -> Text -> CheckpointError
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
err)
        Just (Right CheckpointStoreItem{a
csValue :: a
csValue :: forall a. CheckpointStoreItem a -> a
csValue,CheckpointKey
csNewKey :: CheckpointKey
csNewKey :: forall a. CheckpointStoreItem a -> CheckpointKey
csNewKey}) -> do
            CheckpointLogMsg -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logDebug (CheckpointLogMsg -> Eff effs ())
-> CheckpointLogMsg -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ CheckpointKey -> CheckpointLogMsg
LogFoundValueRestoringKey CheckpointKey
csNewKey
            let nk :: CheckpointKey
nk = CheckpointKey -> CheckpointKey
forall a. Enum a => a -> a
succ CheckpointKey
csNewKey
            CheckpointKey -> Eff effs ()
forall s (effs :: [* -> *]).
Member (State s) effs =>
s -> Eff effs ()
put CheckpointKey
nk
            Either CheckpointError (Maybe a)
-> Eff effs (Either CheckpointError (Maybe a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> Either CheckpointError (Maybe a)
forall a b. b -> Either a b
Right (a -> Maybe a
forall a. a -> Maybe a
Just a
csValue))

data Checkpoint r where
    DoCheckpoint :: Checkpoint ()
    AllocateKey :: Checkpoint CheckpointKey
    Store :: (ToJSON a) => CheckpointKey -> CheckpointKey -> a -> Checkpoint ()
    Retrieve :: (FromJSON a) => CheckpointKey -> Checkpoint (Either CheckpointError (Maybe a))

doCheckpoint :: forall effs. Member Checkpoint effs => Eff effs ()
doCheckpoint :: Eff effs ()
doCheckpoint = Checkpoint () -> Eff effs ()
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send Checkpoint ()
DoCheckpoint

allocateKey :: forall effs. Member Checkpoint effs => Eff effs CheckpointKey
allocateKey :: Eff effs CheckpointKey
allocateKey = Checkpoint CheckpointKey -> Eff effs CheckpointKey
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send Checkpoint CheckpointKey
AllocateKey

store :: forall a effs. (Member Checkpoint effs, ToJSON a) => CheckpointKey -> CheckpointKey -> a -> Eff effs ()
store :: CheckpointKey -> CheckpointKey -> a -> Eff effs ()
store CheckpointKey
k1 CheckpointKey
k2 a
a = Checkpoint () -> Eff effs ()
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send @Checkpoint (CheckpointKey -> CheckpointKey -> a -> Checkpoint ()
forall a.
ToJSON a =>
CheckpointKey -> CheckpointKey -> a -> Checkpoint ()
Store CheckpointKey
k1 CheckpointKey
k2 a
a)

retrieve :: forall a effs. (Member Checkpoint effs, FromJSON a) => CheckpointKey -> Eff effs (Either CheckpointError (Maybe a))
retrieve :: CheckpointKey -> Eff effs (Either CheckpointError (Maybe a))
retrieve CheckpointKey
k = Checkpoint (Either CheckpointError (Maybe a))
-> Eff effs (Either CheckpointError (Maybe a))
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send @Checkpoint (CheckpointKey -> Checkpoint (Either CheckpointError (Maybe a))
forall a.
FromJSON a =>
CheckpointKey -> Checkpoint (Either CheckpointError (Maybe a))
Retrieve CheckpointKey
k)

-- | Handle the 'Checkpoint' effect in terms of 'CheckpointStore' and
--   'CheckpointKey' states.
handleCheckpoint ::
    forall effs.
    ( Member (State CheckpointStore) effs
    , Member (State CheckpointKey) effs
    , Member (LogMsg CheckpointLogMsg) effs
    )
    => Eff (Checkpoint ': effs)
    ~> Eff effs
handleCheckpoint :: Eff (Checkpoint : effs) ~> Eff effs
handleCheckpoint = (Checkpoint ~> Eff effs) -> Eff (Checkpoint : effs) ~> Eff effs
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret ((Checkpoint ~> Eff effs) -> Eff (Checkpoint : effs) ~> Eff effs)
-> (Checkpoint ~> Eff effs) -> Eff (Checkpoint : effs) ~> Eff effs
forall a b. (a -> b) -> a -> b
$ \case
    Checkpoint x
DoCheckpoint -> do
        CheckpointLogMsg -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logDebug CheckpointLogMsg
LogDoCheckpoint
        (CheckpointKey -> CheckpointKey) -> Eff effs ()
forall s (effs :: [* -> *]).
Member (State s) effs =>
(s -> s) -> Eff effs ()
modify @CheckpointKey CheckpointKey -> CheckpointKey
forall a. Enum a => a -> a
succ
    Checkpoint x
AllocateKey -> do
        CheckpointLogMsg -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logDebug CheckpointLogMsg
LogAllocateKey
        forall (effs :: [* -> *]).
Member (State CheckpointKey) effs =>
Eff effs CheckpointKey
forall s (effs :: [* -> *]). Member (State s) effs => Eff effs s
get @CheckpointKey
    Store k k' a -> do
        CheckpointLogMsg -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logDebug (CheckpointLogMsg -> Eff effs ())
-> CheckpointLogMsg -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ CheckpointKey -> CheckpointKey -> CheckpointLogMsg
LogStore CheckpointKey
k CheckpointKey
k'
        CheckpointKey -> CheckpointKey -> a -> Eff effs ()
forall a (effs :: [* -> *]).
(ToJSON a, Member (State CheckpointStore) effs) =>
CheckpointKey -> CheckpointKey -> a -> Eff effs ()
insert CheckpointKey
k CheckpointKey
k' a
a
    Retrieve k -> do
        CheckpointLogMsg -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logDebug (CheckpointLogMsg -> Eff effs ())
-> CheckpointLogMsg -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ CheckpointKey -> CheckpointLogMsg
LogRetrieve CheckpointKey
k
        Either CheckpointError (Maybe a)
result <- CheckpointKey -> Eff effs (Either CheckpointError (Maybe a))
forall a (effs :: [* -> *]).
(FromJSON a, Member (State CheckpointStore) effs,
 Member (State CheckpointKey) effs,
 Member (LogMsg CheckpointLogMsg) effs) =>
CheckpointKey -> Eff effs (Either CheckpointError (Maybe a))
restore @_ @effs CheckpointKey
k
        CheckpointKey
k' <- forall (effs :: [* -> *]).
Member (State CheckpointKey) effs =>
Eff effs CheckpointKey
forall s (effs :: [* -> *]). Member (State s) effs => Eff effs s
get @CheckpointKey
        CheckpointLogMsg -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logDebug (CheckpointLogMsg -> Eff effs ())
-> CheckpointLogMsg -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ CheckpointKey -> CheckpointKey -> CheckpointLogMsg
LogKeyUpdate CheckpointKey
k CheckpointKey
k'
        Either CheckpointError (Maybe a)
-> Eff effs (Either CheckpointError (Maybe a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either CheckpointError (Maybe a)
result

{-| Create a checkpoint for an action.
    @handleCheckpoint (jsonCheckpoint action)@ will

    * Obtain a 'CheckpointKey' that identifies the position of the current
      checkpoint in the program
    * Run @action@, convert its result to JSON and store it in the checkpoint
      store if there is no value at the key
    * Retrieve the result as a JSON value from the store, parse it, and return
      it *instead* of running @action@ if there is a value at the key.

-}
jsonCheckpoint ::
    forall err a effs.
    ( Member Checkpoint effs
    , Member (Error err) effs
    , ToJSON a
    , FromJSON a
    , AsCheckpointError err
    )
    => Eff effs a -- ^ The @action@ that is checkpointed
    -> Eff effs a
jsonCheckpoint :: Eff effs a -> Eff effs a
jsonCheckpoint Eff effs a
action = (() -> Eff effs (Either a ())) -> () -> Eff effs a
forall err a b (effs :: [* -> *]).
(Member Checkpoint effs, Member (Error err) effs, ToJSON a,
 FromJSON a, ToJSON b, FromJSON b, AsCheckpointError err) =>
(a -> Eff effs (Either b a)) -> a -> Eff effs b
jsonCheckpointLoop @err @() @a (\() -> a -> Either a ()
forall a b. a -> Either a b
Left (a -> Either a ()) -> Eff effs a -> Eff effs (Either a ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff effs a
action) ()

{-

Create a checkpoint for an action that is run repeatedly.

-}
jsonCheckpointLoop ::
    forall err a b effs.
    ( Member Checkpoint effs
    , Member (Error err) effs
    , ToJSON a
    , FromJSON a
    , ToJSON b
    , FromJSON b
    , AsCheckpointError err
    )
    => (a -> Eff effs (Either b a)) -- ^ The action that is repeated until it returns a 'Left'. Only the accumulated result of the action will be stored.
    -> a -- ^ Initial value
    -> Eff effs b
jsonCheckpointLoop :: (a -> Eff effs (Either b a)) -> a -> Eff effs b
jsonCheckpointLoop a -> Eff effs (Either b a)
action a
initial = do
    Eff effs ()
forall (effs :: [* -> *]). Member Checkpoint effs => Eff effs ()
doCheckpoint
    CheckpointKey
k <- Eff effs CheckpointKey
forall (effs :: [* -> *]).
Member Checkpoint effs =>
Eff effs CheckpointKey
allocateKey
    Either b a
current <- do
                Either CheckpointError (Maybe (Either b a))
vl <- CheckpointKey
-> Eff effs (Either CheckpointError (Maybe (Either b a)))
forall a (effs :: [* -> *]).
(Member Checkpoint effs, FromJSON a) =>
CheckpointKey -> Eff effs (Either CheckpointError (Maybe a))
retrieve @_ CheckpointKey
k
                case Either CheckpointError (Maybe (Either b a))
vl of
                    Left CheckpointError
err       -> do
                        err -> Eff effs (Either b a)
forall e (effs :: [* -> *]) a.
Member (Error e) effs =>
e -> Eff effs a
throwError @err (AReview err CheckpointError -> CheckpointError -> err
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview err CheckpointError
forall r. AsCheckpointError r => Prism' r CheckpointError
_CheckpointError CheckpointError
err)
                    Right (Just Either b a
a) -> do
                        Either b a -> Eff effs (Either b a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either b a
a
                    Right Maybe (Either b a)
Nothing  -> do
                        Either b a -> Eff effs (Either b a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either b a
forall a b. b -> Either a b
Right a
initial)
    let go :: Either b a -> Eff effs b
go (Left b
b) = b -> Eff effs b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b
        go (Right a
a) = do
                Either b a
actionResult <- a -> Eff effs (Either b a)
action a
a
                CheckpointKey
k' <- Eff effs CheckpointKey
forall (effs :: [* -> *]).
Member Checkpoint effs =>
Eff effs CheckpointKey
allocateKey
                CheckpointKey -> CheckpointKey -> Either b a -> Eff effs ()
forall a (effs :: [* -> *]).
(Member Checkpoint effs, ToJSON a) =>
CheckpointKey -> CheckpointKey -> a -> Eff effs ()
store @_ CheckpointKey
k CheckpointKey
k' Either b a
actionResult
                Eff effs ()
forall (effs :: [* -> *]). Member Checkpoint effs => Eff effs ()
doCheckpoint
                Either b a -> Eff effs b
go Either b a
actionResult
    Either b a -> Eff effs b
go Either b a
current