{-# 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)

-- | Run an 'Update' and return the new attributes and result.
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
  { -- | Whether the value is new or was retrieved (or derived) from old
    -- attributes
    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
              -- TODO: explain why hacky
              Freedom
Locked -> Box Value
box {boxNew :: Bool
boxNew = Bool
True} -- XXX: somewhat hacky
              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)

-- | Runs an update, trying to evaluate the 'Box'es as little as possible.
-- This is a hairy piece of code, apologies ¯\_(ツ)_/¯
-- In most cases I just picked the first implementation that compiled
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
          -- Here we compare the old and new values, flagging the new one as
          -- "boxNew" iff they differ.
          -- TODO: generalize this to all boxes
          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) -- carries over v's newness

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

-- | Renders the template. Returns 'Nothing' if some of the attributes are
-- missing.
--  renderTemplate ("foo" -> "bar") "<foo>" -> pure (Just "bar")
--  renderTemplate ("foo" -> "bar") "<baz>" -> pure Nothing
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)

-- TODO: should input really be Box?
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

-- | Like 'run' but forces evaluation
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})