{-# LANGUAGE Arrows #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Niv.Update.Test where

import Control.Arrow
import Control.Monad
import qualified Data.HashMap.Strict as HMS
import qualified Data.Text as T
import Niv.Update

simplyRuns :: IO ()
simplyRuns :: IO ()
simplyRuns =
  IO (Attrs, ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Attrs, ()) -> IO ()) -> IO (Attrs, ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
    Attrs -> Update () () -> IO (Attrs, ())
forall a. Attrs -> Update () a -> IO (Attrs, a)
runUpdate Attrs
forall k v. HashMap k v
attrs (Update () () -> IO (Attrs, ())) -> Update () () -> IO (Attrs, ())
forall a b. (a -> b) -> a -> b
$ proc () -> do
      Update () ()
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ()
  where
    attrs :: HashMap k v
attrs = HashMap k v
forall k v. HashMap k v
HMS.empty

picksFirst :: IO ()
picksFirst :: IO ()
picksFirst = do
  Int
v <-
    Attrs -> Update () Int -> IO Int
forall a. Attrs -> Update () a -> IO a
execUpdate Attrs
forall k v. HashMap k v
HMS.empty (Update () Int -> IO Int) -> Update () Int -> IO Int
forall a b. (a -> b) -> a -> b
$
      let l :: Update () Int
l = proc () -> do
            Update Int Int
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Int
2
          r :: Update () Int
r = proc () -> do
            Update Int Int
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Int
3
       in Update () Int
l Update () Int -> Update () Int -> Update () Int
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> Update () Int
r
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
v Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Int
2 :: Int)) ([Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"bad value")

loads :: IO ()
loads :: IO ()
loads = do
  Box Text
v <- Attrs -> Update () (Box Text) -> IO (Box Text)
forall a. Attrs -> Update () a -> IO a
execUpdate Attrs
attrs (Update () (Box Text) -> IO (Box Text))
-> Update () (Box Text) -> IO (Box Text)
forall a b. (a -> b) -> a -> b
$ Text -> Update () (Box Text)
forall a. FromJSON a => Text -> Update () (Box a)
load Text
"foo"
  Text
v' <- Box Text -> IO Text
forall a. Box a -> IO a
runBox Box Text
v
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
v' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== (Text
"bar" :: T.Text)) ([Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"bad value")
  where
    attrs :: Attrs
attrs = Text -> (Freedom, Value) -> Attrs
forall k v. Hashable k => k -> v -> HashMap k v
HMS.singleton Text
"foo" (Freedom
Locked, Value
"bar")

survivesChecks :: IO ()
survivesChecks :: IO ()
survivesChecks = do
  Box Text
v <- Attrs -> Update () (Box Text) -> IO (Box Text)
forall a. Attrs -> Update () a -> IO a
execUpdate Attrs
attrs (Update () (Box Text) -> IO (Box Text))
-> Update () (Box Text) -> IO (Box Text)
forall a b. (a -> b) -> a -> b
$ proc () -> do
    (Update () ()
sawLeft Update () () -> Update () () -> Update () ()
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> Update () ()
sawRight) -< ()
    Text -> Update () (Box Text)
forall a. FromJSON a => Text -> Update () (Box a)
load Text
"res" -< ()
  Text
v' <- Box Text -> IO Text
forall a. Box a -> IO a
runBox Box Text
v
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
v' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== (Text
"I saw right" :: T.Text)) ([Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"bad value")
  where
    attrs :: Attrs
attrs = Text -> (Freedom, Value) -> Attrs
forall k v. Hashable k => k -> v -> HashMap k v
HMS.singleton Text
"val" (Freedom
Locked, Value
"right")
    sawLeft :: Update () ()
    sawLeft :: Update () ()
sawLeft = proc () -> do
      Box Text
val <- Text -> Update () (Box Text)
forall a. FromJSON a => Text -> Update () (Box a)
load Text
"val" -< ()
      (Text -> Bool) -> Update (Box Text) ()
forall a. (a -> Bool) -> Update (Box a) ()
check (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"left") -< (Box Text
val :: Box T.Text)
      Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
useOrSet Text
"res" -< Box Text
"I saw left" :: Box T.Text
      Update () ()
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ()
    sawRight :: Update () ()
    sawRight :: Update () ()
sawRight = proc () -> do
      Box Text
val <- Text -> Update () (Box Text)
forall a. FromJSON a => Text -> Update () (Box a)
load Text
"val" -< ()
      (Text -> Bool) -> Update (Box Text) ()
forall a. (a -> Bool) -> Update (Box a) ()
check (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"right") -< (Box Text
val :: Box T.Text)
      Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
useOrSet Text
"res" -< Box Text
"I saw right" :: Box T.Text
      Update () ()
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ()

isNotTooEager :: IO ()
isNotTooEager :: IO ()
isNotTooEager = do
  let f :: Update () (Box Text)
f =
        () -> Update () (Box ())
forall a. a -> Update () (Box a)
constBox ()
          Update () (Box ())
-> Update (Box ()) (Box Text) -> Update () (Box Text)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (() -> IO Text) -> Update (Box ()) (Box Text)
forall a b. (a -> IO b) -> Update (Box a) (Box b)
run (IO Text -> () -> IO Text
forall a b. a -> b -> a
const (IO Text -> () -> IO Text) -> IO Text -> () -> IO Text
forall a b. (a -> b) -> a -> b
$ [Char] -> IO Text
forall a. HasCallStack => [Char] -> a
error [Char]
"IO is too eager (f)")
          Update (Box ()) (Box Text)
-> Update (Box Text) (Box Text) -> Update (Box ()) (Box Text)
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 Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
useOrSet Text
"foo"
  let f1 :: Update () (Box Text)
f1 = proc () -> do
        (() -> IO Any) -> Update (Box ()) (Box Any)
forall a b. (a -> IO b) -> Update (Box a) (Box b)
run (IO Any -> () -> IO Any
forall a b. a -> b -> a
const (IO Any -> () -> IO Any) -> IO Any -> () -> IO Any
forall a b. (a -> b) -> a -> b
$ [Char] -> IO Any
forall a. HasCallStack => [Char] -> a
error [Char]
"IO is too eager (f1)") -< () -> Box ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
useOrSet Text
"foo" -< Box Text
"foo"
  IO (Box Text) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Box Text) -> IO ()) -> IO (Box Text) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Attrs -> Update () (Box Text) -> IO (Box Text)
forall a. Attrs -> Update () a -> IO a
execUpdate Attrs
attrs Update () (Box Text)
f :: IO (Box T.Text))
  IO (Box Text) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Box Text) -> IO ()) -> IO (Box Text) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Attrs -> Update () (Box Text) -> IO (Box Text)
forall a. Attrs -> Update () a -> IO a
execUpdate Attrs
attrs Update () (Box Text)
f1 :: IO (Box T.Text))
  where
    attrs :: Attrs
attrs = Text -> (Freedom, Value) -> Attrs
forall k v. Hashable k => k -> v -> HashMap k v
HMS.singleton Text
"foo" (Freedom
Locked, Value
"right")

dirtyForcesUpdate :: IO ()
dirtyForcesUpdate :: IO ()
dirtyForcesUpdate = do
  let f :: Update () (Box Text)
f = Text -> Update () (Box Text)
forall a. a -> Update () (Box a)
constBox (Text
"world" :: T.Text) Update () (Box Text)
-> Update (Box Text) (Box Text) -> Update () (Box Text)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Update (Box Text) (Box Text)
forall a. Update (Box a) (Box a)
dirty Update (Box Text) (Box Text)
-> Update (Box Text) (Box Text) -> Update (Box Text) (Box Text)
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 Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
update Text
"hello"
  Attrs
attrs' <- Attrs -> Update () (Box Text) -> IO Attrs
forall a. Attrs -> Update () a -> IO Attrs
evalUpdate Attrs
attrs Update () (Box Text)
f
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (((Freedom, Value) -> Value
forall a b. (a, b) -> b
snd ((Freedom, Value) -> Value)
-> Maybe (Freedom, Value) -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Attrs -> Maybe (Freedom, Value)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMS.lookup Text
"hello" Attrs
attrs') Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just Value
"world") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
      [Char]
"bad value for hello: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Attrs -> [Char]
forall a. Show a => a -> [Char]
show Attrs
attrs'
  where
    attrs :: Attrs
attrs = Text -> (Freedom, Value) -> Attrs
forall k v. Hashable k => k -> v -> HashMap k v
HMS.singleton Text
"hello" (Freedom
Free, Value
"foo")

shouldNotRunWhenNoChanges :: IO ()
shouldNotRunWhenNoChanges :: IO ()
shouldNotRunWhenNoChanges = do
  let f :: Update () (Box b)
f = proc () -> do
        Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
update Text
"hello" -< (Box Text
"world" :: Box T.Text)
        (() -> IO b) -> Update (Box ()) (Box b)
forall a b. (a -> IO b) -> Update (Box a) (Box b)
run (\() -> [Char] -> IO b
forall a. HasCallStack => [Char] -> a
error [Char]
"io shouldn't be run") -< () -> Box ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Attrs
attrs <- Attrs -> Update () (Box Any) -> IO Attrs
forall a. Attrs -> Update () a -> IO Attrs
evalUpdate Attrs
forall k v. HashMap k v
HMS.empty Update () (Box Any)
forall b. Update () (Box b)
f
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (((Freedom, Value) -> Value
forall a b. (a, b) -> b
snd ((Freedom, Value) -> Value)
-> Maybe (Freedom, Value) -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Attrs -> Maybe (Freedom, Value)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMS.lookup Text
"hello" Attrs
attrs) Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just Value
"world") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
      [Char]
"bad value for hello: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Attrs -> [Char]
forall a. Show a => a -> [Char]
show Attrs
attrs
  let f' :: Update () (Box Text)
f' = proc () -> do
        (() -> IO Any) -> Update (Box ()) (Box Any)
forall a b. (a -> IO b) -> Update (Box a) (Box b)
run (\() -> [Char] -> IO Any
forall a. HasCallStack => [Char] -> a
error [Char]
"io shouldn't be run") -< () -> Box ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
update Text
"hello" -< (Box Text
"world" :: Box T.Text)
  Attrs
attrs' <- Attrs -> Update () (Box Text) -> IO Attrs
forall a. Attrs -> Update () a -> IO Attrs
evalUpdate Attrs
forall k v. HashMap k v
HMS.empty Update () (Box Text)
f'
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (((Freedom, Value) -> Value
forall a b. (a, b) -> b
snd ((Freedom, Value) -> Value)
-> Maybe (Freedom, Value) -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Attrs -> Maybe (Freedom, Value)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMS.lookup Text
"hello" Attrs
attrs') Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just Value
"world") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
      [Char]
"bad value for hello: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Attrs -> [Char]
forall a. Show a => a -> [Char]
show Attrs
attrs'
  Box Text
v3 <- Attrs -> Update () (Box Text) -> IO (Box Text)
forall a. Attrs -> Update () a -> IO a
execUpdate
    ([(Text, (Freedom, Value))] -> Attrs
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HMS.fromList [(Text
"hello", (Freedom
Free, Value
"world")), (Text
"bar", (Freedom
Free, Value
"baz"))])
    (Update () (Box Text) -> IO (Box Text))
-> Update () (Box Text) -> IO (Box Text)
forall a b. (a -> b) -> a -> b
$ proc () -> do
      Box Text
v1 <- Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
update Text
"hello" -< Box Text
"world"
      Box Text
v2 <- (Text -> IO Text) -> Update (Box Text) (Box Text)
forall a b. (a -> IO b) -> Update (Box a) (Box b)
run (\Text
_ -> [Char] -> IO Text
forall a. HasCallStack => [Char] -> a
error [Char]
"io shouldn't be run") -< (Box Text
v1 :: Box T.Text)
      Box Text
v3 <- Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
update Text
"bar" -< (Box Text
v2 :: Box T.Text)
      Update (Box Text) (Box Text)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Box Text
v3
  Text
v3' <- Box Text -> IO Text
forall a. Box a -> IO a
runBox Box Text
v3
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
v3' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"baz") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"bad value"

templatesExpand :: IO ()
templatesExpand :: IO ()
templatesExpand = do
  Box Text
v3 <- Attrs -> Update () (Box Text) -> IO (Box Text)
forall a. Attrs -> Update () a -> IO a
execUpdate Attrs
attrs (Update () (Box Text) -> IO (Box Text))
-> Update () (Box Text) -> IO (Box Text)
forall a b. (a -> b) -> a -> b
$ proc () -> Update (Box Text) (Box Text)
template -< Box Text
"<v1>-<v2>"
  Text
v3' <- Box Text -> IO Text
forall a. Box a -> IO a
runBox Box Text
v3
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
v3' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"hello-world") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"bad value"
  where
    attrs :: Attrs
attrs = [(Text, (Freedom, Value))] -> Attrs
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HMS.fromList [(Text
"v1", (Freedom
Free, Value
"hello")), (Text
"v2", (Freedom
Free, Value
"world"))]

constBox :: a -> Update () (Box a)
constBox :: a -> Update () (Box a)
constBox a
a = (() -> Box a) -> Update () (Box a)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Box a -> () -> Box a
forall a b. a -> b -> a
const (a -> Box a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a))