{-# 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 :: forall b c. Update b c
zeroArrow = forall b c. Update b c
Zero

instance ArrowPlus Update where
  <+> :: forall 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 :: forall b c. (b -> c) -> Update b c
arr = forall b c. (b -> c) -> Update b c
Arr
  first :: forall b c d. Update b c -> Update (b, d) (c, d)
first = forall b c d. Update b c -> Update (b, d) (c, d)
First

instance Cat.Category Update where
  id :: forall a. Update a a
id = forall a. Update a a
Id
  Update b c
f . :: forall b c a. Update b c -> Update a b -> Update a c
. Update a b
g = forall b c. Compose b c -> Update b c
Compose (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
"(" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Update b c
f forall a. Semigroup a => a -> a -> a
<> String
" . " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Update b b
g forall a. Semigroup a => a -> a -> a
<> String
")"
    Arr b -> c
_f -> String
"Arr"
    First Update b c
a -> String
"First " forall a. Semigroup a => a -> a -> a
<> 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
"(" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Update b c
l forall a. Semigroup a => a -> a -> a
<> String
" + " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Update b c
r forall a. Semigroup a => a -> a -> a
<> String
")"
    Check a -> Bool
_ch -> String
"Check"
    Load Text
k -> String
"Load " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
k
    UseOrSet Text
k -> String
"UseOrSet " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
k
    Update Text
k -> String
"Update " 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 :: forall a. Attrs -> Update () a -> IO (Attrs, a)
runUpdate (Attrs
attrs) Update () a
a = Attrs -> IO BoxedAttrs
boxAttrs Attrs
attrs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. BoxedAttrs -> Update a b -> IO (UpdateRes a b)
runUpdate' Update () a
a forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {t}. UpdateRes () t -> IO (Attrs, t)
feed
  where
    feed :: UpdateRes () t -> IO (Attrs, t)
feed = \case
      UpdateReady UpdateReady t
res -> forall {t}. UpdateReady t -> IO (Attrs, t)
hndl UpdateReady t
res
      UpdateNeedMore () -> IO (UpdateReady t)
next -> () -> IO (UpdateReady t)
next (()) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {t}. UpdateReady t -> IO (Attrs, t)
hndl
    hndl :: UpdateReady t -> IO (Attrs, t)
hndl = \case
      UpdateSuccess BoxedAttrs
f t
v -> (,t
v) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BoxedAttrs -> IO Attrs
unboxAttrs BoxedAttrs
f
      UpdateFailed UpdateFailed
e -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Update failed: " 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: " 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 " forall a. Semigroup a => a -> a -> a
<> Text
tpl,
            Text
"with keys: " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
keys
          ]

execUpdate :: Attrs -> Update () a -> IO a
execUpdate :: forall a. Attrs -> Update () a -> IO a
execUpdate Attrs
attrs Update () a
a = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Attrs -> Update () a -> IO (Attrs, a)
runUpdate Attrs
attrs Update () a
a

evalUpdate :: Attrs -> Update () a -> IO Attrs
evalUpdate :: forall a. Attrs -> Update () a -> IO Attrs
evalUpdate Attrs
attrs Update () a
a = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Attrs -> Update () a -> IO (Attrs, a)
runUpdate Attrs
attrs Update () a
a

tryEvalUpdate :: Attrs -> Update () a -> IO (Either SomeException Attrs)
tryEvalUpdate :: forall a. Attrs -> Update () a -> IO (Either SomeException Attrs)
tryEvalUpdate Attrs
attrs Update () a
upd = forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (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
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 (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
<$ :: forall a b. a -> UpdateRes a b -> UpdateRes a a
$c<$ :: forall a a b. a -> UpdateRes a b -> UpdateRes a a
fmap :: forall a b. (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 (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
<$ :: forall a b. a -> UpdateReady b -> UpdateReady a
$c<$ :: forall a b. a -> UpdateReady b -> UpdateReady a
fmap :: forall a b. (a -> b) -> UpdateReady a -> UpdateReady b
$cfmap :: forall a b. (a -> b) -> UpdateReady a -> UpdateReady b
Functor)

runBox :: Box a -> IO a
runBox :: forall a. Box a -> IO a
runBox = forall a. Box a -> IO a
boxOp

data Box a = Box
  { -- | Whether the value is new or was retrieved (or derived) from old
    -- attributes
    forall a. Box a -> Bool
boxNew :: Bool,
    forall a. Box a -> IO a
boxOp :: IO a
  }
  deriving (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
<$ :: forall a b. a -> Box b -> Box a
$c<$ :: forall a b. a -> Box b -> Box a
fmap :: forall a b. (a -> b) -> Box a -> Box b
$cfmap :: forall a b. (a -> b) -> Box a -> Box b
Functor)

mkBox :: Box a -> IO (Box a)
mkBox :: forall a. Box a -> IO (Box a)
mkBox Box a
b = do
  MVar (Maybe a)
mvar <- forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar forall a. Maybe a
Nothing
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Box a
b {boxOp :: IO a
boxOp = forall a. MVar (Maybe a) -> IO a -> IO a
singleton MVar (Maybe a)
mvar (forall a. Box a -> IO a
boxOp Box a
b)}

singleton :: MVar (Maybe a) -> IO a -> IO a
singleton :: forall a. MVar (Maybe a) -> IO a -> IO a
singleton MVar (Maybe a)
mvar IO a
def = do
  forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar MVar (Maybe a)
mvar forall a b. (a -> b) -> a -> b
$ \case
    Just a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just a
a, a
a)
    Maybe a
Nothing -> do
      a
a <- IO a
def
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just a
a, a
a)

instance Applicative Box where
  pure :: forall a. a -> Box a
pure a
x = Box {boxNew :: Bool
boxNew = Bool
False, boxOp :: IO a
boxOp = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x}
  Box (a -> b)
f <*> :: forall a b. Box (a -> b) -> Box a -> Box b
<*> Box a
v =
    Box
      { boxNew :: Bool
boxNew = Bool -> Bool -> Bool
(||) (forall a. Box a -> Bool
boxNew Box (a -> b)
f) (forall a. Box a -> Bool
boxNew Box a
v),
        boxOp :: IO b
boxOp = forall a. Box a -> IO a
boxOp Box (a -> b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Box a -> IO a
boxOp Box a
v
      }

instance Semigroup a => Semigroup (Box a) where
  <> :: Box a -> Box a -> Box a
(<>) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. Semigroup a => a -> a -> a
(<>)

instance IsString (Box T.Text) where
  fromString :: String -> Box Text
fromString String
str = Box {boxNew :: Bool
boxNew = Bool
False, boxOp :: IO Text
boxOp = forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 = 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,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Box a -> IO a
runBox Box Value
v)

boxAttrs :: Attrs -> IO BoxedAttrs
boxAttrs :: Attrs -> IO BoxedAttrs
boxAttrs =
  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 <- forall a. Box a -> IO (Box a)
mkBox (forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v)
        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
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
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' :: forall a b. BoxedAttrs -> Update a b -> IO (UpdateRes a b)
runUpdate' BoxedAttrs
attrs = \case
  Update a b
Id -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs
  Arr a -> b
f -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f
  Update a b
Zero -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. UpdateReady b -> UpdateRes a b
UpdateReady (forall b. UpdateFailed -> UpdateReady b
UpdateFailed UpdateFailed
FailZero)
  Plus Update a b
l Update a b
r ->
    forall a b. BoxedAttrs -> Update a b -> IO (UpdateRes a b)
runUpdate' BoxedAttrs
attrs Update a b
l forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      UpdateReady (UpdateFailed {}) -> forall a b. BoxedAttrs -> Update a b -> IO (UpdateRes a b)
runUpdate' BoxedAttrs
attrs Update a b
r
      UpdateReady (UpdateSuccess BoxedAttrs
f b
v) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. UpdateReady b -> UpdateRes a b
UpdateReady (forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
f b
v)
      UpdateNeedMore a -> IO (UpdateReady b)
next -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore forall a b. (a -> b) -> a -> b
$ \a
v ->
          a -> IO (UpdateReady b)
next a
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            UpdateSuccess BoxedAttrs
f b
res -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
f b
res
            UpdateFailed {} ->
              forall a b. BoxedAttrs -> Update a b -> IO (UpdateRes a b)
runUpdate' BoxedAttrs
attrs Update a b
r forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                UpdateReady UpdateReady b
res -> 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall a b. UpdateReady b -> UpdateRes a b
UpdateReady forall a b. (a -> b) -> a -> b
$ do
      case 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') -> forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs Box Value
v'
        Maybe (Freedom, Box Value)
Nothing -> forall b. UpdateFailed -> UpdateReady b
UpdateFailed forall a b. (a -> b) -> a -> b
$ Text -> UpdateFailed
FailNoSuchKey Text
k
  First Update b c
a -> do
    forall a b. BoxedAttrs -> Update a b -> IO (UpdateRes a b)
runUpdate' BoxedAttrs
attrs Update b c
a forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      UpdateReady (UpdateFailed UpdateFailed
e) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. UpdateReady b -> UpdateRes a b
UpdateReady forall a b. (a -> b) -> a -> b
$ forall b. UpdateFailed -> UpdateReady b
UpdateFailed UpdateFailed
e
      UpdateReady (UpdateSuccess BoxedAttrs
fo c
ba) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore forall a b. (a -> b) -> a -> b
$ \a
gtt -> do
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
fo (c
ba, forall a b. (a, b) -> b
snd a
gtt)
      UpdateNeedMore b -> IO (UpdateReady c)
next -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore forall a b. (a -> b) -> a -> b
$ \a
gtt -> do
          b -> IO (UpdateReady c)
next (forall a b. (a, b) -> a
fst a
gtt) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            UpdateFailed UpdateFailed
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. UpdateFailed -> UpdateReady b
UpdateFailed UpdateFailed
e
            UpdateSuccess BoxedAttrs
f c
res -> do
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
f (c
res, forall a b. (a, b) -> b
snd a
gtt)
  Run a -> IO b
act ->
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore forall a b. (a -> b) -> a -> b
$ \a
gtt -> do
          Box b
box <- forall a. Box a -> IO (Box a)
mkBox forall a b. (a -> b) -> a -> b
$ forall a. Bool -> IO a -> Box a
Box (forall a. Box a -> Bool
boxNew a
gtt) (a -> IO b
act forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Box a -> IO a
runBox a
gtt)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs Box b
box
      )
  Check a -> Bool
ch ->
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore forall a b. (a -> b) -> a -> b
$ \a
gtt -> do
          a
v <- forall a. Box a -> IO a
runBox a
gtt
          if a -> Bool
ch a
v
            then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs ()
            else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. UpdateFailed -> UpdateReady b
UpdateFailed UpdateFailed
FailCheck
      )
  UseOrSet Text
k -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case 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) -> forall a b. UpdateReady b -> UpdateRes a b
UpdateReady forall a b. (a -> b) -> a -> b
$ forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs Box Value
v
    Just (Freedom
Free, Box Value
v) -> forall a b. UpdateReady b -> UpdateRes a b
UpdateReady forall a b. (a -> b) -> a -> b
$ forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs Box Value
v
    Maybe (Freedom, Box Value)
Nothing -> forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore forall a b. (a -> b) -> a -> b
$ \a
gtt -> do
      let attrs' :: HashMap Text (Freedom, a)
attrs' = forall k v. Hashable k => k -> v -> HashMap k v
HMS.singleton Text
k (Freedom
Locked, a
gtt) forall a. Semigroup a => a -> a -> a
<> BoxedAttrs
attrs
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess HashMap Text (Freedom, a)
attrs' a
gtt
  Update Text
k -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case 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) -> forall a b. UpdateReady b -> UpdateRes a b
UpdateReady forall a b. (a -> b) -> a -> b
$ forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs Box Value
v
    Just (Freedom
Free, Box Value
v) -> forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore forall a b. (a -> b) -> a -> b
$ \a
gtt -> do
      if (forall a. Box a -> Bool
boxNew a
gtt)
        then do
          Value
v' <- forall a. Box a -> IO a
boxOp Box Value
v
          Value
gtt' <- forall a. Box a -> IO a
boxOp a
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' forall a. Eq a => a -> a -> Bool
/= Value
gtt'
                  then a
gtt {boxNew :: Bool
boxNew = Bool
True, boxOp :: IO Value
boxOp = forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
gtt'}
                  else a
gtt {boxNew :: Bool
boxNew = Bool
False, boxOp :: IO Value
boxOp = forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
gtt'}
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess (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
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs Box Value
v
    Maybe (Freedom, Box Value)
Nothing -> forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore forall a b. (a -> b) -> a -> b
$ \a
gtt -> do
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess (forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMS.insert Text
k (Freedom
Locked, a
gtt) BoxedAttrs
attrs) a
gtt
  Compose (Compose' Update b b
f Update a b
g) ->
    forall a b. BoxedAttrs -> Update a b -> IO (UpdateRes a b)
runUpdate' BoxedAttrs
attrs Update a b
g forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      UpdateReady (UpdateFailed UpdateFailed
e) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. UpdateReady b -> UpdateRes a b
UpdateReady forall a b. (a -> b) -> a -> b
$ forall b. UpdateFailed -> UpdateReady b
UpdateFailed UpdateFailed
e
      UpdateReady (UpdateSuccess BoxedAttrs
attrs' b
act) ->
        forall a b. BoxedAttrs -> Update a b -> IO (UpdateRes a b)
runUpdate' BoxedAttrs
attrs' Update b b
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          UpdateReady (UpdateFailed UpdateFailed
e) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. UpdateReady b -> UpdateRes a b
UpdateReady forall a b. (a -> b) -> a -> b
$ forall b. UpdateFailed -> UpdateReady b
UpdateFailed UpdateFailed
e
          UpdateReady (UpdateSuccess BoxedAttrs
attrs'' b
act') -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. UpdateReady b -> UpdateRes a b
UpdateReady forall a b. (a -> b) -> a -> b
$ forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs'' b
act'
          UpdateNeedMore b -> IO (UpdateReady b)
next -> forall a b. UpdateReady b -> UpdateRes a b
UpdateReady 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore forall a b. (a -> b) -> a -> b
$ \a
gtt -> do
          a -> IO (UpdateReady b)
next a
gtt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            UpdateFailed UpdateFailed
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. UpdateFailed -> UpdateReady b
UpdateFailed UpdateFailed
e
            UpdateSuccess BoxedAttrs
attrs' b
act ->
              forall a b. BoxedAttrs -> Update a b -> IO (UpdateRes a b)
runUpdate' BoxedAttrs
attrs' Update b b
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                UpdateReady UpdateReady b
ready -> 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> IO (UpdateReady b)) -> UpdateRes a b
UpdateNeedMore forall a b. (a -> b) -> a -> b
$ \a
v -> do
      Text
v' <- forall a. Box a -> IO a
runBox a
v
      case (Text -> Maybe (Box Text)) -> Text -> Maybe (Box Text)
renderTemplate
        ( \Text
k ->
            ((forall a. FromJSON a => Text -> Box Value -> Box a
decodeBox forall a b. (a -> b) -> a -> b
$ Text
"When rendering template " forall a. Semigroup a => a -> a -> a
<> Text
v') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. UpdateFailed -> UpdateReady b
UpdateFailed forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> UpdateFailed
FailTemplate Text
v' (forall k v. HashMap k v -> [k]
HMS.keys BoxedAttrs
attrs)
        Just Box Text
v'' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. BoxedAttrs -> b -> UpdateReady b
UpdateSuccess BoxedAttrs
attrs (Box Text
v'' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* a
v) -- carries over v's newness

decodeBox :: FromJSON a => T.Text -> Box Value -> Box a
decodeBox :: forall a. FromJSON a => Text -> Box Value -> Box a
decodeBox Text
msg Box Value
v = Box Value
v {boxOp :: IO a
boxOp = forall a. Box a -> IO a
boxOp Box Value
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FromJSON a => Text -> Value -> IO a
decodeValue Text
msg}

decodeValue :: FromJSON a => T.Text -> Value -> IO a
decodeValue :: forall a. FromJSON a => Text -> Value -> IO a
decodeValue Text
msg Value
v = case forall a. FromJSON a => Value -> Result a
Aeson.fromJSON Value
v of
  Aeson.Success a
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  Aeson.Error String
str ->
    forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
msg forall a. Semigroup a => a -> a -> a
<> String
": Could not decode: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Value
v forall a. Semigroup a => a -> a -> a
<> String
": " 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 (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
        (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 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)
_ -> forall a. Maybe a
Nothing
  Just (Char
c, Text
str) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char -> Text -> Text
T.cons Char
c) 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 -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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 :: forall a. (a -> Bool) -> Update (Box a) ()
check = forall a. (a -> Bool) -> Update (Box a) ()
Check

load :: FromJSON a => T.Text -> Update () (Box a)
load :: forall a. FromJSON a => Text -> Update () (Box a)
load Text
k = Text -> Update () (Box Value)
Load Text
k forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall a. FromJSON a => Text -> Box Value -> Box a
decodeBox forall a b. (a -> b) -> a -> b
$ Text
"When loading key " 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 :: forall a. JSON a => Text -> Update (Box a) (Box a)
useOrSet Text
k =
  forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToJSON a => a -> Value
Aeson.toJSON)
    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
    forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall a. FromJSON a => Text -> Box Value -> Box a
decodeBox forall a b. (a -> b) -> a -> b
$ Text
"When trying to use or set key " forall a. Semigroup a => a -> a -> a
<> Text
k)

update :: JSON a => T.Text -> Update (Box a) (Box a)
update :: forall a. JSON a => Text -> Update (Box a) (Box a)
update Text
k =
  forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToJSON a => a -> Value
Aeson.toJSON)
    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
    forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall a. FromJSON a => Text -> Box Value -> Box a
decodeBox forall a b. (a -> b) -> a -> b
$ Text
"When updating key " forall a. Semigroup a => a -> a -> a
<> Text
k)

run :: (a -> IO b) -> Update (Box a) (Box b)
run :: forall a b. (a -> IO b) -> Update (Box a) (Box b)
run = 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' :: forall a b. (a -> IO b) -> Update (Box a) (Box b)
run' a -> IO b
act = forall a b. (a -> IO b) -> Update (Box a) (Box b)
Run a -> IO b
act forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a. Update (Box a) (Box a)
dirty

dirty :: Update (Box a) (Box a)
dirty :: forall a. Update (Box a) (Box a)
dirty = forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\Box a
v -> Box a
v {boxNew :: Bool
boxNew = Bool
True})