{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module Niv.Update where
import Control.Applicative
import Control.Arrow
import qualified Control.Category as Cat
import Data.Aeson (FromJSON, ToJSON, Value)
import qualified Data.Aeson as Aeson
import qualified Data.HashMap.Strict as HMS
import Data.String
import qualified Data.Text as T
import Niv.Logger
import UnliftIO
type Attrs = HMS.HashMap T.Text (Freedom, Value)
data Update b c where
Id :: Update a a
Compose :: (Compose b c) -> Update b c
Arr :: (b -> c) -> Update b c
First :: Update b c -> Update (b, d) (c, d)
Zero :: Update b c
Plus :: Update b c -> Update b c -> Update b c
Check :: (a -> Bool) -> Update (Box a) ()
Load :: T.Text -> Update () (Box Value)
UseOrSet :: T.Text -> Update (Box Value) (Box Value)
Update :: T.Text -> Update (Box Value) (Box Value)
Run :: (a -> IO b) -> Update (Box a) (Box b)
Template :: Update (Box T.Text) (Box T.Text)
instance ArrowZero Update where
zeroArrow :: Update b c
zeroArrow = Update b c
forall b c. Update b c
Zero
instance ArrowPlus Update where
<+> :: Update b c -> Update b c -> Update b c
(<+>) = Update b c -> Update b c -> Update b c
forall b c. Update b c -> Update b c -> Update b c
Plus
instance Arrow Update where
arr :: (b -> c) -> Update b c
arr = (b -> c) -> Update b c
forall b c. (b -> c) -> Update b c
Arr
first :: Update b c -> Update (b, d) (c, d)
first = Update b c -> Update (b, d) (c, d)
forall b c d. Update b c -> Update (b, d) (c, d)
First
instance Cat.Category Update where
id :: Update a a
id = Update a a
forall a. Update a a
Id
Update b c
f . :: Update b c -> Update a b -> Update a c
. Update a b
g = Compose a c -> Update a c
forall b c. Compose b c -> Update b c
Compose (Update b c -> Update a b -> Compose a c
forall a c b. Update b c -> Update a b -> Compose a c
Compose' Update b c
f Update a b
g)
instance Show (Update b c) where
show :: Update b c -> String
show = \case
Update b c
Id -> String
"Id"
Compose (Compose' Update b c
f Update b b
g) -> String
"(" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Update b c -> String
forall a. Show a => a -> String
show Update b c
f String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" . " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Update b b -> String
forall a. Show a => a -> String
show Update b b
g String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
Arr b -> c
_f -> String
"Arr"
First Update b c
a -> String
"First " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Update b c -> String
forall a. Show a => a -> String
show Update b c
a
Update b c
Zero -> String
"Zero"
Plus Update b c
l Update b c
r -> String
"(" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Update b c -> String
forall a. Show a => a -> String
show Update b c
l String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" + " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Update b c -> String
forall a. Show a => a -> String
show Update b c
r String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
Check a -> Bool
_ch -> String
"Check"
Load Text
k -> String
"Load " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
k
UseOrSet Text
k -> String
"UseOrSet " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
k
Update Text
k -> String
"Update " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
k
Run a -> IO b
_act -> String
"Io"
Update b c
Template -> String
"Template"
data Compose a c = forall b. Compose' (Update b c) (Update a b)
runUpdate :: Attrs -> Update () a -> IO (Attrs, a)
runUpdate :: Attrs -> Update () a -> IO (Attrs, a)
runUpdate (Attrs
attrs) Update () a
a = Attrs -> IO BoxedAttrs
boxAttrs Attrs
attrs IO BoxedAttrs
-> (BoxedAttrs -> IO (UpdateRes () a)) -> IO (UpdateRes () a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (BoxedAttrs -> Update () a -> IO (UpdateRes () a))
-> Update () a -> BoxedAttrs -> IO (UpdateRes () a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip BoxedAttrs -> Update () a -> IO (UpdateRes () a)
forall a b. BoxedAttrs -> Update a b -> IO (UpdateRes a b)
runUpdate' Update () a
a IO (UpdateRes () a)
-> (UpdateRes () a -> IO (Attrs, a)) -> IO (Attrs, a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UpdateRes () a -> IO (Attrs, a)
forall t. UpdateRes () t -> IO (Attrs, t)
feed
where
feed :: UpdateRes () t -> IO (Attrs, t)
feed = \case
UpdateReady UpdateReady t
res -> UpdateReady t -> IO (Attrs, t)
forall t. UpdateReady t -> IO (Attrs, t)
hndl UpdateReady t
res
UpdateNeedMore () -> IO (UpdateReady t)
next -> () -> IO (UpdateReady t)
next (()) IO (UpdateReady t)
-> (UpdateReady t -> IO (Attrs, t)) -> IO (Attrs, t)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UpdateReady t -> IO (Attrs, t)
forall t. UpdateReady t -> IO (Attrs, t)
hndl
hndl :: UpdateReady t -> IO (Attrs, t)
hndl = \case
UpdateSuccess BoxedAttrs
f t
v -> (,t
v) (Attrs -> (Attrs, t)) -> IO Attrs -> IO (Attrs, t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BoxedAttrs -> IO Attrs
unboxAttrs BoxedAttrs
f
UpdateFailed UpdateFailed
e -> String -> IO (Attrs, t)
forall a. HasCallStack => String -> a
error (String -> IO (Attrs, t)) -> String -> IO (Attrs, t)
forall a b. (a -> b) -> a -> b
$ String
"Update failed: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (UpdateFailed -> Text
prettyFail UpdateFailed
e)
prettyFail :: UpdateFailed -> T.Text
prettyFail :: UpdateFailed -> Text
prettyFail = \case
FailNoSuchKey Text
k -> Text
"Key could not be found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k
UpdateFailed
FailZero -> Text -> Text
bug Text
"A dead end was reached during evaluation."
UpdateFailed
FailCheck -> Text
"A check failed during update"
FailTemplate Text
tpl [Text]
keys ->
[Text] -> Text
T.unlines
[ Text
"Could not render template " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tpl,
Text
"with keys: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
keys
]
execUpdate :: Attrs -> Update () a -> IO a
execUpdate :: Attrs -> Update () a -> IO a
execUpdate Attrs
attrs Update () a
a = (Attrs, a) -> a
forall a b. (a, b) -> b
snd ((Attrs, a) -> a) -> IO (Attrs, a) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Attrs -> Update () a -> IO (Attrs, a)
forall a. Attrs -> Update () a -> IO (Attrs, a)
runUpdate Attrs
attrs Update () a
a
evalUpdate :: Attrs -> Update () a -> IO Attrs
evalUpdate :: Attrs -> Update () a -> IO Attrs
evalUpdate Attrs
attrs Update () a
a = (Attrs, a) -> Attrs
forall a b. (a, b) -> a
fst ((Attrs, a) -> Attrs) -> IO (Attrs, a) -> IO Attrs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Attrs -> Update () a -> IO (Attrs, a)
forall a. Attrs -> Update () a -> IO (Attrs, a)
runUpdate Attrs
attrs Update () a
a
tryEvalUpdate :: Attrs -> Update () a -> IO (Either SomeException Attrs)
tryEvalUpdate :: Attrs -> Update () a -> IO (Either SomeException Attrs)
tryEvalUpdate Attrs
attrs Update () a
upd = IO Attrs -> IO (Either SomeException Attrs)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (Attrs -> Update () a -> IO Attrs
forall a. Attrs -> Update () a -> IO Attrs
evalUpdate Attrs
attrs Update () a
upd)
type JSON a = (ToJSON a, FromJSON a)
data UpdateFailed
= FailNoSuchKey T.Text
| FailZero
| FailCheck
| FailTemplate T.Text [T.Text]
deriving (Int -> UpdateFailed -> ShowS
[UpdateFailed] -> ShowS
UpdateFailed -> String
(Int -> UpdateFailed -> ShowS)
-> (UpdateFailed -> String)
-> ([UpdateFailed] -> ShowS)
-> Show UpdateFailed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UpdateFailed] -> ShowS
$cshowList :: [UpdateFailed] -> ShowS
show :: UpdateFailed -> String
$cshow :: UpdateFailed -> String
showsPrec :: Int -> UpdateFailed -> ShowS
$cshowsPrec :: Int -> UpdateFailed -> ShowS
Show)
data UpdateRes a b
= UpdateReady (UpdateReady b)
| UpdateNeedMore (a -> IO (UpdateReady b))
deriving (a -> UpdateRes a b -> UpdateRes a a
(a -> b) -> UpdateRes a a -> UpdateRes a b
(forall a b. (a -> b) -> UpdateRes a a -> UpdateRes a b)
-> (forall a b. a -> UpdateRes a b -> UpdateRes a a)
-> Functor (UpdateRes a)
forall a b. a -> UpdateRes a b -> UpdateRes a a
forall a b. (a -> b) -> UpdateRes a a -> UpdateRes a b
forall a a b. a -> UpdateRes a b -> UpdateRes a a
forall a a b. (a -> b) -> UpdateRes a a -> UpdateRes a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> UpdateRes a b -> UpdateRes a a
$c<$ :: forall a a b. a -> UpdateRes a b -> UpdateRes a a
fmap :: (a -> b) -> UpdateRes a a -> UpdateRes a b
$cfmap :: forall a a b. (a -> b) -> UpdateRes a a -> UpdateRes a b
Functor)
data UpdateReady b
= UpdateSuccess BoxedAttrs b
| UpdateFailed UpdateFailed
deriving (a -> UpdateReady b -> UpdateReady a
(a -> b) -> UpdateReady a -> UpdateReady b
(forall a b. (a -> b) -> UpdateReady a -> UpdateReady b)
-> (forall a b. a -> UpdateReady b -> UpdateReady a)
-> Functor UpdateReady
forall a b. a -> UpdateReady b -> UpdateReady a
forall a b. (a -> b) -> UpdateReady a -> UpdateReady b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> UpdateReady b -> UpdateReady a
$c<$ :: forall a b. a -> UpdateReady b -> UpdateReady a
fmap :: (a -> b) -> UpdateReady a -> UpdateReady b
$cfmap :: forall a b. (a -> b) -> UpdateReady a -> UpdateReady b
Functor)
runBox :: Box a -> IO a
runBox :: Box a -> IO a
runBox = Box a -> IO a
forall a. Box a -> IO a
boxOp
data Box a = Box
{
Box a -> Bool
boxNew :: Bool,
Box a -> IO a
boxOp :: IO a
}
deriving (a -> Box b -> Box a
(a -> b) -> Box a -> Box b
(forall a b. (a -> b) -> Box a -> Box b)
-> (forall a b. a -> Box b -> Box a) -> Functor Box
forall a b. a -> Box b -> Box a
forall a b. (a -> b) -> Box a -> Box b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Box b -> Box a
$c<$ :: forall a b. a -> Box b -> Box a
fmap :: (a -> b) -> Box a -> Box b
$cfmap :: forall a b. (a -> b) -> Box a -> Box b
Functor)
mkBox :: Box a -> IO (Box a)
mkBox :: Box a -> IO (Box a)
mkBox Box a
b = do
MVar (Maybe a)
mvar <- Maybe a -> IO (MVar (Maybe a))
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Maybe a
forall a. Maybe a
Nothing
Box a -> IO (Box a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Box a
b {boxOp :: IO a
boxOp = MVar (Maybe a) -> IO a -> IO a
forall a. MVar (Maybe a) -> IO a -> IO a
singleton MVar (Maybe a)
mvar (Box a -> IO a
forall a. Box a -> IO a
boxOp Box a
b)}
singleton :: MVar (Maybe a) -> IO a -> IO a
singleton :: MVar (Maybe a) -> IO a -> IO a
singleton MVar (Maybe a)
mvar IO a
def = do
MVar (Maybe a) -> (Maybe a -> IO (Maybe a, a)) -> IO a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar MVar (Maybe a)
mvar ((Maybe a -> IO (Maybe a, a)) -> IO a)
-> (Maybe a -> IO (Maybe a, a)) -> IO a
forall a b. (a -> b) -> a -> b
$ \case
Just a
a -> (Maybe a, a) -> IO (Maybe a, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
a, a
a)
Maybe a
Nothing -> do
a
a <- IO a
def
(Maybe a, a) -> IO (Maybe a, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
a, a
a)
instance Applicative Box where
pure :: a -> Box a
pure a
x = Box :: forall a. Bool -> IO a -> Box a
Box {boxNew :: Bool
boxNew = Bool
False, boxOp :: IO a
boxOp = a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x}
Box (a -> b)
f <*> :: Box (a -> b) -> Box a -> Box b
<*> Box a
v =
Box :: forall a. Bool -> IO a -> Box a
Box
{ boxNew :: Bool
boxNew = Bool -> Bool -> Bool
(||) (Box (a -> b) -> Bool
forall a. Box a -> Bool
boxNew Box (a -> b)
f) (Box a -> Bool
forall a. Box a -> Bool
boxNew Box a
v),
boxOp :: IO b
boxOp = Box (a -> b) -> IO (a -> b)
forall a. Box a -> IO a
boxOp Box (a -> b)
f IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Box a -> IO a
forall a. Box a -> IO a
boxOp Box a
v
}
instance Semigroup a => Semigroup (Box a) where
<> :: Box a -> Box a -> Box a
(<>) = (a -> a -> a) -> Box a -> Box a -> Box a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)
instance IsString (Box T.Text) where
fromString :: String -> Box Text
fromString String
str = Box :: forall a. Bool -> IO a -> Box a
Box {boxNew :: Bool
boxNew = Bool
False, boxOp :: IO Text
boxOp = Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
str}
type BoxedAttrs = HMS.HashMap T.Text (Freedom, Box Value)
unboxAttrs :: BoxedAttrs -> IO Attrs
unboxAttrs :: BoxedAttrs -> IO Attrs
unboxAttrs = ((Freedom, Box Value) -> IO (Freedom, Value))
-> BoxedAttrs -> IO Attrs
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(Freedom
fr, Box Value
v) -> (Freedom
fr,) (Value -> (Freedom, Value)) -> IO Value -> IO (Freedom, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box Value -> IO Value
forall a. Box a -> IO a
runBox Box Value
v)
boxAttrs :: Attrs -> IO BoxedAttrs
boxAttrs :: Attrs -> IO BoxedAttrs
boxAttrs =
((Freedom, Value) -> IO (Freedom, Box Value))
-> Attrs -> IO BoxedAttrs
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
( \(Freedom
fr, Value
v) -> do
Box Value
box <- Box Value -> IO (Box Value)
forall a. Box a -> IO (Box a)
mkBox (Value -> Box Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v)
(Freedom, Box Value) -> IO (Freedom, Box Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( Freedom
fr,
case Freedom
fr of
Freedom
Locked -> Box Value
box {boxNew :: Bool
boxNew = Bool
True}
Freedom
Free -> Box Value
box
)
)
data Freedom
= Locked
| Free
deriving (Freedom -> Freedom -> Bool
(Freedom -> Freedom -> Bool)
-> (Freedom -> Freedom -> Bool) -> Eq Freedom
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Freedom -> Freedom -> Bool
$c/= :: Freedom -> Freedom -> Bool
== :: Freedom -> Freedom -> Bool
$c== :: Freedom -> Freedom -> Bool
Eq, Int -> Freedom -> ShowS
[Freedom] -> ShowS
Freedom -> String
(Int -> Freedom -> ShowS)
-> (Freedom -> String) -> ([Freedom] -> ShowS) -> Show Freedom
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Freedom] -> ShowS
$cshowList :: [Freedom] -> ShowS
show :: Freedom -> String
$cshow :: Freedom -> String
showsPrec :: Int -> Freedom -> ShowS
$cshowsPrec :: Int -> Freedom -> ShowS
Show)
runUpdate' :: BoxedAttrs -> Update a b -> IO (UpdateRes a b)
runUpdate' :: BoxedAttrs -> Update a b -> IO (UpdateRes a b)
runUpdate' BoxedAttrs
attrs = \case
Update a b
Id -> UpdateRes a a -> IO (UpdateRes a a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateRes a a -> IO (UpdateRes a a))
-> UpdateRes a a -> IO (UpdateRes a a)
forall a b. (a -> b) -> a -> b
$ (a -> IO (UpdateReady a)) -> UpdateRes a a
forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore ((a -> IO (UpdateReady a)) -> UpdateRes a a)
-> (a -> IO (UpdateReady a)) -> UpdateRes a a
forall a b. (a -> b) -> a -> b
$ UpdateReady a -> IO (UpdateReady a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateReady a -> IO (UpdateReady a))
-> (a -> UpdateReady a) -> a -> IO (UpdateReady a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoxedAttrs -> a -> UpdateReady a
forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs
Arr a -> b
f -> UpdateRes a b -> IO (UpdateRes a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateRes a b -> IO (UpdateRes a b))
-> UpdateRes a b -> IO (UpdateRes a b)
forall a b. (a -> b) -> a -> b
$ (a -> IO (UpdateReady b)) -> UpdateRes a b
forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore ((a -> IO (UpdateReady b)) -> UpdateRes a b)
-> (a -> IO (UpdateReady b)) -> UpdateRes a b
forall a b. (a -> b) -> a -> b
$ UpdateReady b -> IO (UpdateReady b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateReady b -> IO (UpdateReady b))
-> (a -> UpdateReady b) -> a -> IO (UpdateReady b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoxedAttrs -> b -> UpdateReady b
forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs (b -> UpdateReady b) -> (a -> b) -> a -> UpdateReady b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f
Update a b
Zero -> UpdateRes a b -> IO (UpdateRes a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateRes a b -> IO (UpdateRes a b))
-> UpdateRes a b -> IO (UpdateRes a b)
forall a b. (a -> b) -> a -> b
$ UpdateReady b -> UpdateRes a b
forall a b. UpdateReady b -> UpdateRes a b
UpdateReady (UpdateFailed -> UpdateReady b
forall b. UpdateFailed -> UpdateReady b
UpdateFailed UpdateFailed
FailZero)
Plus Update a b
l Update a b
r ->
BoxedAttrs -> Update a b -> IO (UpdateRes a b)
forall a b. BoxedAttrs -> Update a b -> IO (UpdateRes a b)
runUpdate' BoxedAttrs
attrs Update a b
l IO (UpdateRes a b)
-> (UpdateRes a b -> IO (UpdateRes a b)) -> IO (UpdateRes a b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
UpdateReady (UpdateFailed {}) -> BoxedAttrs -> Update a b -> IO (UpdateRes a b)
forall a b. BoxedAttrs -> Update a b -> IO (UpdateRes a b)
runUpdate' BoxedAttrs
attrs Update a b
r
UpdateReady (UpdateSuccess BoxedAttrs
f b
v) -> UpdateRes a b -> IO (UpdateRes a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateRes a b -> IO (UpdateRes a b))
-> UpdateRes a b -> IO (UpdateRes a b)
forall a b. (a -> b) -> a -> b
$ UpdateReady b -> UpdateRes a b
forall a b. UpdateReady b -> UpdateRes a b
UpdateReady (BoxedAttrs -> b -> UpdateReady b
forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
f b
v)
UpdateNeedMore a -> IO (UpdateReady b)
next -> UpdateRes a b -> IO (UpdateRes a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateRes a b -> IO (UpdateRes a b))
-> UpdateRes a b -> IO (UpdateRes a b)
forall a b. (a -> b) -> a -> b
$
(a -> IO (UpdateReady b)) -> UpdateRes a b
forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore ((a -> IO (UpdateReady b)) -> UpdateRes a b)
-> (a -> IO (UpdateReady b)) -> UpdateRes a b
forall a b. (a -> b) -> a -> b
$ \a
v ->
a -> IO (UpdateReady b)
next a
v IO (UpdateReady b)
-> (UpdateReady b -> IO (UpdateReady b)) -> IO (UpdateReady b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
UpdateSuccess BoxedAttrs
f b
res -> UpdateReady b -> IO (UpdateReady b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateReady b -> IO (UpdateReady b))
-> UpdateReady b -> IO (UpdateReady b)
forall a b. (a -> b) -> a -> b
$ BoxedAttrs -> b -> UpdateReady b
forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
f b
res
UpdateFailed {} ->
BoxedAttrs -> Update a b -> IO (UpdateRes a b)
forall a b. BoxedAttrs -> Update a b -> IO (UpdateRes a b)
runUpdate' BoxedAttrs
attrs Update a b
r IO (UpdateRes a b)
-> (UpdateRes a b -> IO (UpdateReady b)) -> IO (UpdateReady b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
UpdateReady UpdateReady b
res -> UpdateReady b -> IO (UpdateReady b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure UpdateReady b
res
UpdateNeedMore a -> IO (UpdateReady b)
next' -> a -> IO (UpdateReady b)
next' a
v
Load Text
k -> UpdateRes a (Box Value) -> IO (UpdateRes a (Box Value))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateRes a (Box Value) -> IO (UpdateRes a (Box Value)))
-> UpdateRes a (Box Value) -> IO (UpdateRes a (Box Value))
forall a b. (a -> b) -> a -> b
$
UpdateReady (Box Value) -> UpdateRes a (Box Value)
forall a b. UpdateReady b -> UpdateRes a b
UpdateReady (UpdateReady (Box Value) -> UpdateRes a (Box Value))
-> UpdateReady (Box Value) -> UpdateRes a (Box Value)
forall a b. (a -> b) -> a -> b
$ do
case Text -> BoxedAttrs -> Maybe (Freedom, Box Value)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMS.lookup Text
k BoxedAttrs
attrs of
Just (Freedom
_, Box Value
v') -> BoxedAttrs -> Box Value -> UpdateReady (Box Value)
forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs Box Value
v'
Maybe (Freedom, Box Value)
Nothing -> UpdateFailed -> UpdateReady (Box Value)
forall b. UpdateFailed -> UpdateReady b
UpdateFailed (UpdateFailed -> UpdateReady (Box Value))
-> UpdateFailed -> UpdateReady (Box Value)
forall a b. (a -> b) -> a -> b
$ Text -> UpdateFailed
FailNoSuchKey Text
k
First Update b c
a -> do
BoxedAttrs -> Update b c -> IO (UpdateRes b c)
forall a b. BoxedAttrs -> Update a b -> IO (UpdateRes a b)
runUpdate' BoxedAttrs
attrs Update b c
a IO (UpdateRes b c)
-> (UpdateRes b c -> IO (UpdateRes (b, d) (c, d)))
-> IO (UpdateRes (b, d) (c, d))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
UpdateReady (UpdateFailed UpdateFailed
e) -> UpdateRes (b, d) (c, d) -> IO (UpdateRes (b, d) (c, d))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateRes (b, d) (c, d) -> IO (UpdateRes (b, d) (c, d)))
-> UpdateRes (b, d) (c, d) -> IO (UpdateRes (b, d) (c, d))
forall a b. (a -> b) -> a -> b
$ UpdateReady (c, d) -> UpdateRes (b, d) (c, d)
forall a b. UpdateReady b -> UpdateRes a b
UpdateReady (UpdateReady (c, d) -> UpdateRes (b, d) (c, d))
-> UpdateReady (c, d) -> UpdateRes (b, d) (c, d)
forall a b. (a -> b) -> a -> b
$ UpdateFailed -> UpdateReady (c, d)
forall b. UpdateFailed -> UpdateReady b
UpdateFailed UpdateFailed
e
UpdateReady (UpdateSuccess BoxedAttrs
fo c
ba) -> UpdateRes (b, d) (c, d) -> IO (UpdateRes (b, d) (c, d))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateRes (b, d) (c, d) -> IO (UpdateRes (b, d) (c, d)))
-> UpdateRes (b, d) (c, d) -> IO (UpdateRes (b, d) (c, d))
forall a b. (a -> b) -> a -> b
$
((b, d) -> IO (UpdateReady (c, d))) -> UpdateRes (b, d) (c, d)
forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore (((b, d) -> IO (UpdateReady (c, d))) -> UpdateRes (b, d) (c, d))
-> ((b, d) -> IO (UpdateReady (c, d))) -> UpdateRes (b, d) (c, d)
forall a b. (a -> b) -> a -> b
$ \(b, d)
gtt -> do
UpdateReady (c, d) -> IO (UpdateReady (c, d))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateReady (c, d) -> IO (UpdateReady (c, d)))
-> UpdateReady (c, d) -> IO (UpdateReady (c, d))
forall a b. (a -> b) -> a -> b
$ BoxedAttrs -> (c, d) -> UpdateReady (c, d)
forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
fo (c
ba, (b, d) -> d
forall a b. (a, b) -> b
snd (b, d)
gtt)
UpdateNeedMore b -> IO (UpdateReady c)
next -> UpdateRes (b, d) (c, d) -> IO (UpdateRes (b, d) (c, d))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateRes (b, d) (c, d) -> IO (UpdateRes (b, d) (c, d)))
-> UpdateRes (b, d) (c, d) -> IO (UpdateRes (b, d) (c, d))
forall a b. (a -> b) -> a -> b
$
((b, d) -> IO (UpdateReady (c, d))) -> UpdateRes (b, d) (c, d)
forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore (((b, d) -> IO (UpdateReady (c, d))) -> UpdateRes (b, d) (c, d))
-> ((b, d) -> IO (UpdateReady (c, d))) -> UpdateRes (b, d) (c, d)
forall a b. (a -> b) -> a -> b
$ \(b, d)
gtt -> do
b -> IO (UpdateReady c)
next ((b, d) -> b
forall a b. (a, b) -> a
fst (b, d)
gtt) IO (UpdateReady c)
-> (UpdateReady c -> IO (UpdateReady (c, d)))
-> IO (UpdateReady (c, d))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
UpdateFailed UpdateFailed
e -> UpdateReady (c, d) -> IO (UpdateReady (c, d))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateReady (c, d) -> IO (UpdateReady (c, d)))
-> UpdateReady (c, d) -> IO (UpdateReady (c, d))
forall a b. (a -> b) -> a -> b
$ UpdateFailed -> UpdateReady (c, d)
forall b. UpdateFailed -> UpdateReady b
UpdateFailed UpdateFailed
e
UpdateSuccess BoxedAttrs
f c
res -> do
UpdateReady (c, d) -> IO (UpdateReady (c, d))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateReady (c, d) -> IO (UpdateReady (c, d)))
-> UpdateReady (c, d) -> IO (UpdateReady (c, d))
forall a b. (a -> b) -> a -> b
$ BoxedAttrs -> (c, d) -> UpdateReady (c, d)
forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
f (c
res, (b, d) -> d
forall a b. (a, b) -> b
snd (b, d)
gtt)
Run a -> IO b
act ->
UpdateRes (Box a) (Box b) -> IO (UpdateRes (Box a) (Box b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( (Box a -> IO (UpdateReady (Box b))) -> UpdateRes (Box a) (Box b)
forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore ((Box a -> IO (UpdateReady (Box b))) -> UpdateRes (Box a) (Box b))
-> (Box a -> IO (UpdateReady (Box b))) -> UpdateRes (Box a) (Box b)
forall a b. (a -> b) -> a -> b
$ \Box a
gtt -> do
Box b
box <- Box b -> IO (Box b)
forall a. Box a -> IO (Box a)
mkBox (Box b -> IO (Box b)) -> Box b -> IO (Box b)
forall a b. (a -> b) -> a -> b
$ Bool -> IO b -> Box b
forall a. Bool -> IO a -> Box a
Box (Box a -> Bool
forall a. Box a -> Bool
boxNew Box a
gtt) (a -> IO b
act (a -> IO b) -> IO a -> IO b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Box a -> IO a
forall a. Box a -> IO a
runBox Box a
gtt)
UpdateReady (Box b) -> IO (UpdateReady (Box b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateReady (Box b) -> IO (UpdateReady (Box b)))
-> UpdateReady (Box b) -> IO (UpdateReady (Box b))
forall a b. (a -> b) -> a -> b
$ BoxedAttrs -> Box b -> UpdateReady (Box b)
forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs Box b
box
)
Check a -> Bool
ch ->
UpdateRes (Box a) () -> IO (UpdateRes (Box a) ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( (Box a -> IO (UpdateReady ())) -> UpdateRes (Box a) ()
forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore ((Box a -> IO (UpdateReady ())) -> UpdateRes (Box a) ())
-> (Box a -> IO (UpdateReady ())) -> UpdateRes (Box a) ()
forall a b. (a -> b) -> a -> b
$ \Box a
gtt -> do
a
v <- Box a -> IO a
forall a. Box a -> IO a
runBox Box a
gtt
if a -> Bool
ch a
v
then UpdateReady () -> IO (UpdateReady ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateReady () -> IO (UpdateReady ()))
-> UpdateReady () -> IO (UpdateReady ())
forall a b. (a -> b) -> a -> b
$ BoxedAttrs -> () -> UpdateReady ()
forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs ()
else UpdateReady () -> IO (UpdateReady ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateReady () -> IO (UpdateReady ()))
-> UpdateReady () -> IO (UpdateReady ())
forall a b. (a -> b) -> a -> b
$ UpdateFailed -> UpdateReady ()
forall b. UpdateFailed -> UpdateReady b
UpdateFailed UpdateFailed
FailCheck
)
UseOrSet Text
k -> UpdateRes (Box Value) (Box Value)
-> IO (UpdateRes (Box Value) (Box Value))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateRes (Box Value) (Box Value)
-> IO (UpdateRes (Box Value) (Box Value)))
-> UpdateRes (Box Value) (Box Value)
-> IO (UpdateRes (Box Value) (Box Value))
forall a b. (a -> b) -> a -> b
$ case Text -> BoxedAttrs -> Maybe (Freedom, Box Value)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMS.lookup Text
k BoxedAttrs
attrs of
Just (Freedom
Locked, Box Value
v) -> UpdateReady (Box Value) -> UpdateRes (Box Value) (Box Value)
forall a b. UpdateReady b -> UpdateRes a b
UpdateReady (UpdateReady (Box Value) -> UpdateRes (Box Value) (Box Value))
-> UpdateReady (Box Value) -> UpdateRes (Box Value) (Box Value)
forall a b. (a -> b) -> a -> b
$ BoxedAttrs -> Box Value -> UpdateReady (Box Value)
forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs Box Value
v
Just (Freedom
Free, Box Value
v) -> UpdateReady (Box Value) -> UpdateRes (Box Value) (Box Value)
forall a b. UpdateReady b -> UpdateRes a b
UpdateReady (UpdateReady (Box Value) -> UpdateRes (Box Value) (Box Value))
-> UpdateReady (Box Value) -> UpdateRes (Box Value) (Box Value)
forall a b. (a -> b) -> a -> b
$ BoxedAttrs -> Box Value -> UpdateReady (Box Value)
forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs Box Value
v
Maybe (Freedom, Box Value)
Nothing -> (Box Value -> IO (UpdateReady (Box Value)))
-> UpdateRes (Box Value) (Box Value)
forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore ((Box Value -> IO (UpdateReady (Box Value)))
-> UpdateRes (Box Value) (Box Value))
-> (Box Value -> IO (UpdateReady (Box Value)))
-> UpdateRes (Box Value) (Box Value)
forall a b. (a -> b) -> a -> b
$ \Box Value
gtt -> do
let attrs' :: BoxedAttrs
attrs' = Text -> (Freedom, Box Value) -> BoxedAttrs
forall k v. Hashable k => k -> v -> HashMap k v
HMS.singleton Text
k (Freedom
Locked, Box Value
gtt) BoxedAttrs -> BoxedAttrs -> BoxedAttrs
forall a. Semigroup a => a -> a -> a
<> BoxedAttrs
attrs
UpdateReady (Box Value) -> IO (UpdateReady (Box Value))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateReady (Box Value) -> IO (UpdateReady (Box Value)))
-> UpdateReady (Box Value) -> IO (UpdateReady (Box Value))
forall a b. (a -> b) -> a -> b
$ BoxedAttrs -> Box Value -> UpdateReady (Box Value)
forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs' Box Value
gtt
Update Text
k -> UpdateRes (Box Value) (Box Value)
-> IO (UpdateRes (Box Value) (Box Value))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateRes (Box Value) (Box Value)
-> IO (UpdateRes (Box Value) (Box Value)))
-> UpdateRes (Box Value) (Box Value)
-> IO (UpdateRes (Box Value) (Box Value))
forall a b. (a -> b) -> a -> b
$ case Text -> BoxedAttrs -> Maybe (Freedom, Box Value)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMS.lookup Text
k BoxedAttrs
attrs of
Just (Freedom
Locked, Box Value
v) -> UpdateReady (Box Value) -> UpdateRes (Box Value) (Box Value)
forall a b. UpdateReady b -> UpdateRes a b
UpdateReady (UpdateReady (Box Value) -> UpdateRes (Box Value) (Box Value))
-> UpdateReady (Box Value) -> UpdateRes (Box Value) (Box Value)
forall a b. (a -> b) -> a -> b
$ BoxedAttrs -> Box Value -> UpdateReady (Box Value)
forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs Box Value
v
Just (Freedom
Free, Box Value
v) -> (Box Value -> IO (UpdateReady (Box Value)))
-> UpdateRes (Box Value) (Box Value)
forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore ((Box Value -> IO (UpdateReady (Box Value)))
-> UpdateRes (Box Value) (Box Value))
-> (Box Value -> IO (UpdateReady (Box Value)))
-> UpdateRes (Box Value) (Box Value)
forall a b. (a -> b) -> a -> b
$ \Box Value
gtt -> do
if (Box Value -> Bool
forall a. Box a -> Bool
boxNew Box Value
gtt)
then do
Value
v' <- Box Value -> IO Value
forall a. Box a -> IO a
boxOp Box Value
v
Value
gtt' <- Box Value -> IO Value
forall a. Box a -> IO a
boxOp Box Value
gtt
let gtt'' :: Box Value
gtt'' =
if Value
v' Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
gtt'
then Box Value
gtt {boxNew :: Bool
boxNew = Bool
True, boxOp :: IO Value
boxOp = Value -> IO Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
gtt'}
else Box Value
gtt {boxNew :: Bool
boxNew = Bool
False, boxOp :: IO Value
boxOp = Value -> IO Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
gtt'}
UpdateReady (Box Value) -> IO (UpdateReady (Box Value))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateReady (Box Value) -> IO (UpdateReady (Box Value)))
-> UpdateReady (Box Value) -> IO (UpdateReady (Box Value))
forall a b. (a -> b) -> a -> b
$ BoxedAttrs -> Box Value -> UpdateReady (Box Value)
forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess (Text -> (Freedom, Box Value) -> BoxedAttrs -> BoxedAttrs
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMS.insert Text
k (Freedom
Locked, Box Value
gtt'') BoxedAttrs
attrs) Box Value
gtt''
else do
UpdateReady (Box Value) -> IO (UpdateReady (Box Value))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateReady (Box Value) -> IO (UpdateReady (Box Value)))
-> UpdateReady (Box Value) -> IO (UpdateReady (Box Value))
forall a b. (a -> b) -> a -> b
$ BoxedAttrs -> Box Value -> UpdateReady (Box Value)
forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs Box Value
v
Maybe (Freedom, Box Value)
Nothing -> (Box Value -> IO (UpdateReady (Box Value)))
-> UpdateRes (Box Value) (Box Value)
forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore ((Box Value -> IO (UpdateReady (Box Value)))
-> UpdateRes (Box Value) (Box Value))
-> (Box Value -> IO (UpdateReady (Box Value)))
-> UpdateRes (Box Value) (Box Value)
forall a b. (a -> b) -> a -> b
$ \Box Value
gtt -> do
UpdateReady (Box Value) -> IO (UpdateReady (Box Value))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateReady (Box Value) -> IO (UpdateReady (Box Value)))
-> UpdateReady (Box Value) -> IO (UpdateReady (Box Value))
forall a b. (a -> b) -> a -> b
$ BoxedAttrs -> Box Value -> UpdateReady (Box Value)
forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess (Text -> (Freedom, Box Value) -> BoxedAttrs -> BoxedAttrs
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMS.insert Text
k (Freedom
Locked, Box Value
gtt) BoxedAttrs
attrs) Box Value
gtt
Compose (Compose' Update b b
f Update a b
g) ->
BoxedAttrs -> Update a b -> IO (UpdateRes a b)
forall a b. BoxedAttrs -> Update a b -> IO (UpdateRes a b)
runUpdate' BoxedAttrs
attrs Update a b
g IO (UpdateRes a b)
-> (UpdateRes a b -> IO (UpdateRes a b)) -> IO (UpdateRes a b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
UpdateReady (UpdateFailed UpdateFailed
e) -> UpdateRes a b -> IO (UpdateRes a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateRes a b -> IO (UpdateRes a b))
-> UpdateRes a b -> IO (UpdateRes a b)
forall a b. (a -> b) -> a -> b
$ UpdateReady b -> UpdateRes a b
forall a b. UpdateReady b -> UpdateRes a b
UpdateReady (UpdateReady b -> UpdateRes a b) -> UpdateReady b -> UpdateRes a b
forall a b. (a -> b) -> a -> b
$ UpdateFailed -> UpdateReady b
forall b. UpdateFailed -> UpdateReady b
UpdateFailed UpdateFailed
e
UpdateReady (UpdateSuccess BoxedAttrs
attrs' b
act) ->
BoxedAttrs -> Update b b -> IO (UpdateRes b b)
forall a b. BoxedAttrs -> Update a b -> IO (UpdateRes a b)
runUpdate' BoxedAttrs
attrs' Update b b
f IO (UpdateRes b b)
-> (UpdateRes b b -> IO (UpdateRes a b)) -> IO (UpdateRes a b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
UpdateReady (UpdateFailed UpdateFailed
e) -> UpdateRes a b -> IO (UpdateRes a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateRes a b -> IO (UpdateRes a b))
-> UpdateRes a b -> IO (UpdateRes a b)
forall a b. (a -> b) -> a -> b
$ UpdateReady b -> UpdateRes a b
forall a b. UpdateReady b -> UpdateRes a b
UpdateReady (UpdateReady b -> UpdateRes a b) -> UpdateReady b -> UpdateRes a b
forall a b. (a -> b) -> a -> b
$ UpdateFailed -> UpdateReady b
forall b. UpdateFailed -> UpdateReady b
UpdateFailed UpdateFailed
e
UpdateReady (UpdateSuccess BoxedAttrs
attrs'' b
act') -> UpdateRes a b -> IO (UpdateRes a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateRes a b -> IO (UpdateRes a b))
-> UpdateRes a b -> IO (UpdateRes a b)
forall a b. (a -> b) -> a -> b
$ UpdateReady b -> UpdateRes a b
forall a b. UpdateReady b -> UpdateRes a b
UpdateReady (UpdateReady b -> UpdateRes a b) -> UpdateReady b -> UpdateRes a b
forall a b. (a -> b) -> a -> b
$ BoxedAttrs -> b -> UpdateReady b
forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs'' b
act'
UpdateNeedMore b -> IO (UpdateReady b)
next -> UpdateReady b -> UpdateRes a b
forall a b. UpdateReady b -> UpdateRes a b
UpdateReady (UpdateReady b -> UpdateRes a b)
-> IO (UpdateReady b) -> IO (UpdateRes a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> IO (UpdateReady b)
next b
act
UpdateNeedMore a -> IO (UpdateReady b)
next -> UpdateRes a b -> IO (UpdateRes a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateRes a b -> IO (UpdateRes a b))
-> UpdateRes a b -> IO (UpdateRes a b)
forall a b. (a -> b) -> a -> b
$
(a -> IO (UpdateReady b)) -> UpdateRes a b
forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore ((a -> IO (UpdateReady b)) -> UpdateRes a b)
-> (a -> IO (UpdateReady b)) -> UpdateRes a b
forall a b. (a -> b) -> a -> b
$ \a
gtt -> do
a -> IO (UpdateReady b)
next a
gtt IO (UpdateReady b)
-> (UpdateReady b -> IO (UpdateReady b)) -> IO (UpdateReady b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
UpdateFailed UpdateFailed
e -> UpdateReady b -> IO (UpdateReady b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateReady b -> IO (UpdateReady b))
-> UpdateReady b -> IO (UpdateReady b)
forall a b. (a -> b) -> a -> b
$ UpdateFailed -> UpdateReady b
forall b. UpdateFailed -> UpdateReady b
UpdateFailed UpdateFailed
e
UpdateSuccess BoxedAttrs
attrs' b
act ->
BoxedAttrs -> Update b b -> IO (UpdateRes b b)
forall a b. BoxedAttrs -> Update a b -> IO (UpdateRes a b)
runUpdate' BoxedAttrs
attrs' Update b b
f IO (UpdateRes b b)
-> (UpdateRes b b -> IO (UpdateReady b)) -> IO (UpdateReady b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
UpdateReady UpdateReady b
ready -> UpdateReady b -> IO (UpdateReady b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure UpdateReady b
ready
UpdateNeedMore b -> IO (UpdateReady b)
next' -> b -> IO (UpdateReady b)
next' b
act
Update a b
Template -> UpdateRes (Box Text) (Box Text)
-> IO (UpdateRes (Box Text) (Box Text))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateRes (Box Text) (Box Text)
-> IO (UpdateRes (Box Text) (Box Text)))
-> UpdateRes (Box Text) (Box Text)
-> IO (UpdateRes (Box Text) (Box Text))
forall a b. (a -> b) -> a -> b
$
(Box Text -> IO (UpdateReady (Box Text)))
-> UpdateRes (Box Text) (Box Text)
forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore ((Box Text -> IO (UpdateReady (Box Text)))
-> UpdateRes (Box Text) (Box Text))
-> (Box Text -> IO (UpdateReady (Box Text)))
-> UpdateRes (Box Text) (Box Text)
forall a b. (a -> b) -> a -> b
$ \Box Text
v -> do
Text
v' <- Box Text -> IO Text
forall a. Box a -> IO a
runBox Box Text
v
case (Text -> Maybe (Box Text)) -> Text -> Maybe (Box Text)
renderTemplate
( \Text
k ->
((Text -> Box Value -> Box Text
forall a. FromJSON a => Text -> Box Value -> Box a
decodeBox (Text -> Box Value -> Box Text) -> Text -> Box Value -> Box Text
forall a b. (a -> b) -> a -> b
$ Text
"When rendering template " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v') (Box Value -> Box Text)
-> ((Freedom, Box Value) -> Box Value)
-> (Freedom, Box Value)
-> Box Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Freedom, Box Value) -> Box Value
forall a b. (a, b) -> b
snd)
((Freedom, Box Value) -> Box Text)
-> Maybe (Freedom, Box Value) -> Maybe (Box Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> BoxedAttrs -> Maybe (Freedom, Box Value)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMS.lookup Text
k BoxedAttrs
attrs
)
Text
v' of
Maybe (Box Text)
Nothing -> UpdateReady (Box Text) -> IO (UpdateReady (Box Text))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateReady (Box Text) -> IO (UpdateReady (Box Text)))
-> UpdateReady (Box Text) -> IO (UpdateReady (Box Text))
forall a b. (a -> b) -> a -> b
$ UpdateFailed -> UpdateReady (Box Text)
forall b. UpdateFailed -> UpdateReady b
UpdateFailed (UpdateFailed -> UpdateReady (Box Text))
-> UpdateFailed -> UpdateReady (Box Text)
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> UpdateFailed
FailTemplate Text
v' (BoxedAttrs -> [Text]
forall k v. HashMap k v -> [k]
HMS.keys BoxedAttrs
attrs)
Just Box Text
v'' -> UpdateReady (Box Text) -> IO (UpdateReady (Box Text))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateReady (Box Text) -> IO (UpdateReady (Box Text)))
-> UpdateReady (Box Text) -> IO (UpdateReady (Box Text))
forall a b. (a -> b) -> a -> b
$ BoxedAttrs -> Box Text -> UpdateReady (Box Text)
forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs (Box Text
v'' Box Text -> Box Text -> Box Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Box Text
v)
decodeBox :: FromJSON a => T.Text -> Box Value -> Box a
decodeBox :: Text -> Box Value -> Box a
decodeBox Text
msg Box Value
v = Box Value
v {boxOp :: IO a
boxOp = Box Value -> IO Value
forall a. Box a -> IO a
boxOp Box Value
v IO Value -> (Value -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Value -> IO a
forall a. FromJSON a => Text -> Value -> IO a
decodeValue Text
msg}
decodeValue :: FromJSON a => T.Text -> Value -> IO a
decodeValue :: Text -> Value -> IO a
decodeValue Text
msg Value
v = case Value -> Result a
forall a. FromJSON a => Value -> Result a
Aeson.fromJSON Value
v of
Aeson.Success a
x -> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
Aeson.Error String
str ->
String -> IO a
forall a. HasCallStack => String -> a
error (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
msg String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": Could not decode: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
v String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
str
renderTemplate :: (T.Text -> Maybe (Box T.Text)) -> T.Text -> Maybe (Box T.Text)
renderTemplate :: (Text -> Maybe (Box Text)) -> Text -> Maybe (Box Text)
renderTemplate Text -> Maybe (Box Text)
vals Text
tpl = case Text -> Maybe (Char, Text)
T.uncons Text
tpl of
Just (Char
'<', Text
str) -> do
case (Char -> Bool) -> Text -> (Text, Text)
T.span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'>') Text
str of
(Text
key, Text -> Maybe (Char, Text)
T.uncons -> Just (Char
'>', Text
rest)) -> do
let v :: Maybe (Box Text)
v = Text -> Maybe (Box Text)
vals Text
key
((Box Text -> Box Text -> Box Text)
-> Maybe (Box Text) -> Maybe (Box Text) -> Maybe (Box Text)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Box Text -> Box Text -> Box Text
forall a. Semigroup a => a -> a -> a
(<>) Maybe (Box Text)
v) ((Text -> Maybe (Box Text)) -> Text -> Maybe (Box Text)
renderTemplate Text -> Maybe (Box Text)
vals Text
rest)
(Text, Text)
_ -> Maybe (Box Text)
forall a. Maybe a
Nothing
Just (Char
c, Text
str) -> (Text -> Text) -> Box Text -> Box Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char -> Text -> Text
T.cons Char
c) (Box Text -> Box Text) -> Maybe (Box Text) -> Maybe (Box Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Maybe (Box Text)) -> Text -> Maybe (Box Text)
renderTemplate Text -> Maybe (Box Text)
vals Text
str
Maybe (Char, Text)
Nothing -> Box Text -> Maybe (Box Text)
forall a. a -> Maybe a
Just (Box Text -> Maybe (Box Text)) -> Box Text -> Maybe (Box Text)
forall a b. (a -> b) -> a -> b
$ Text -> Box Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
T.empty
template :: Update (Box T.Text) (Box T.Text)
template :: Update (Box Text) (Box Text)
template = Update (Box Text) (Box Text)
Template
check :: (a -> Bool) -> Update (Box a) ()
check :: (a -> Bool) -> Update (Box a) ()
check = (a -> Bool) -> Update (Box a) ()
forall a. (a -> Bool) -> Update (Box a) ()
Check
load :: FromJSON a => T.Text -> Update () (Box a)
load :: Text -> Update () (Box a)
load Text
k = Text -> Update () (Box Value)
Load Text
k Update () (Box Value)
-> Update (Box Value) (Box a) -> Update () (Box a)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Box Value -> Box a) -> Update (Box Value) (Box a)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Text -> Box Value -> Box a
forall a. FromJSON a => Text -> Box Value -> Box a
decodeBox (Text -> Box Value -> Box a) -> Text -> Box Value -> Box a
forall a b. (a -> b) -> a -> b
$ Text
"When loading key " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k)
useOrSet :: JSON a => T.Text -> Update (Box a) (Box a)
useOrSet :: Text -> Update (Box a) (Box a)
useOrSet Text
k =
(Box a -> Box Value) -> Update (Box a) (Box Value)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((a -> Value) -> Box a -> Box Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON)
Update (Box a) (Box Value)
-> Update (Box Value) (Box a) -> Update (Box a) (Box a)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Text -> Update (Box Value) (Box Value)
UseOrSet Text
k
Update (Box Value) (Box Value)
-> Update (Box Value) (Box a) -> Update (Box Value) (Box a)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Box Value -> Box a) -> Update (Box Value) (Box a)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Text -> Box Value -> Box a
forall a. FromJSON a => Text -> Box Value -> Box a
decodeBox (Text -> Box Value -> Box a) -> Text -> Box Value -> Box a
forall a b. (a -> b) -> a -> b
$ Text
"When trying to use or set key " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k)
update :: JSON a => T.Text -> Update (Box a) (Box a)
update :: Text -> Update (Box a) (Box a)
update Text
k =
(Box a -> Box Value) -> Update (Box a) (Box Value)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((a -> Value) -> Box a -> Box Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON)
Update (Box a) (Box Value)
-> Update (Box Value) (Box a) -> Update (Box a) (Box a)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Text -> Update (Box Value) (Box Value)
Update Text
k
Update (Box Value) (Box Value)
-> Update (Box Value) (Box a) -> Update (Box Value) (Box a)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Box Value -> Box a) -> Update (Box Value) (Box a)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Text -> Box Value -> Box a
forall a. FromJSON a => Text -> Box Value -> Box a
decodeBox (Text -> Box Value -> Box a) -> Text -> Box Value -> Box a
forall a b. (a -> b) -> a -> b
$ Text
"When updating key " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k)
run :: (a -> IO b) -> Update (Box a) (Box b)
run :: (a -> IO b) -> Update (Box a) (Box b)
run = (a -> IO b) -> Update (Box a) (Box b)
forall a b. (a -> IO b) -> Update (Box a) (Box b)
Run
run' :: (a -> IO b) -> Update (Box a) (Box b)
run' :: (a -> IO b) -> Update (Box a) (Box b)
run' a -> IO b
act = (a -> IO b) -> Update (Box a) (Box b)
forall a b. (a -> IO b) -> Update (Box a) (Box b)
Run a -> IO b
act Update (Box a) (Box b)
-> Update (Box b) (Box b) -> Update (Box a) (Box b)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Update (Box b) (Box b)
forall a. Update (Box a) (Box a)
dirty
dirty :: Update (Box a) (Box a)
dirty :: Update (Box a) (Box a)
dirty = (Box a -> Box a) -> Update (Box a) (Box a)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\Box a
v -> Box a
v {boxNew :: Bool
boxNew = Bool
True})