{-# 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 =
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
    forall a. Attrs -> Update () a -> IO (Attrs, a)
runUpdate forall {k} {v}. HashMap k v
attrs forall a b. (a -> b) -> a -> b
$ proc () -> do
      forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ()
  where
    attrs :: HashMap k v
attrs = forall {k} {v}. HashMap k v
HMS.empty

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

loads :: IO ()
loads :: IO ()
loads = do
  Box Text
v <- forall a. Attrs -> Update () a -> IO a
execUpdate Attrs
attrs forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => Text -> Update () (Box a)
load Text
"foo"
  Text
v' <- forall a. Box a -> IO a
runBox Box Text
v
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
v' forall a. Eq a => a -> a -> Bool
== (Text
"bar" :: T.Text)) (forall a. HasCallStack => [Char] -> a
error [Char]
"bad value")
  where
    attrs :: Attrs
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 <- forall a. Attrs -> Update () a -> IO a
execUpdate Attrs
attrs forall a b. (a -> b) -> a -> b
$ proc () -> do
    (Update () ()
sawLeft forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> Update () ()
sawRight) -< ()
    forall a. FromJSON a => Text -> Update () (Box a)
load Text
"res" -< ()
  Text
v' <- forall a. Box a -> IO a
runBox Box Text
v
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
v' forall a. Eq a => a -> a -> Bool
== (Text
"I saw right" :: T.Text)) (forall a. HasCallStack => [Char] -> a
error [Char]
"bad value")
  where
    attrs :: Attrs
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 <- forall a. FromJSON a => Text -> Update () (Box a)
load Text
"val" -< ()
      forall a. (a -> Bool) -> Update (Box a) ()
check (forall a. Eq a => a -> a -> Bool
== Text
"left") -< (Box Text
val :: Box T.Text)
      forall a. JSON a => Text -> Update (Box a) (Box a)
useOrSet Text
"res" -< Box Text
"I saw left" :: Box T.Text
      forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ()
    sawRight :: Update () ()
    sawRight :: Update () ()
sawRight = proc () -> do
      Box Text
val <- forall a. FromJSON a => Text -> Update () (Box a)
load Text
"val" -< ()
      forall a. (a -> Bool) -> Update (Box a) ()
check (forall a. Eq a => a -> a -> Bool
== Text
"right") -< (Box Text
val :: Box T.Text)
      forall a. JSON a => Text -> Update (Box a) (Box a)
useOrSet Text
"res" -< Box Text
"I saw right" :: Box T.Text
      forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ()

isNotTooEager :: IO ()
isNotTooEager :: IO ()
isNotTooEager = do
  let f :: Update () (Box Text)
f =
        forall a. a -> Update () (Box a)
constBox ()
          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. (a -> IO b) -> Update (Box a) (Box b)
run (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [Char] -> a
error [Char]
"IO is too eager (f)")
          forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a. JSON a => Text -> Update (Box a) (Box a)
useOrSet Text
"foo"
  let f1 :: Update () (Box Text)
f1 = proc () -> do
        forall a b. (a -> IO b) -> Update (Box a) (Box b)
run (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [Char] -> a
error [Char]
"IO is too eager (f1)") -< forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        forall a. JSON a => Text -> Update (Box a) (Box a)
useOrSet Text
"foo" -< Box Text
"foo"
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ (forall a. Attrs -> Update () a -> IO a
execUpdate Attrs
attrs Update () (Box Text)
f :: IO (Box T.Text))
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ (forall a. Attrs -> Update () a -> IO a
execUpdate Attrs
attrs Update () (Box Text)
f1 :: IO (Box T.Text))
  where
    attrs :: Attrs
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 = forall a. a -> Update () (Box a)
constBox (Text
"world" :: T.Text) 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 forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a. JSON a => Text -> Update (Box a) (Box a)
update Text
"hello"
  Attrs
attrs' <- forall a. Attrs -> Update () a -> IO Attrs
evalUpdate Attrs
attrs Update () (Box Text)
f
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((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
"hello" Attrs
attrs') forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Value
"world") forall a b. (a -> b) -> a -> b
$
    forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
      [Char]
"bad value for hello: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Attrs
attrs'
  where
    attrs :: Attrs
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
        forall a. JSON a => Text -> Update (Box a) (Box a)
update Text
"hello" -< (Box Text
"world" :: Box T.Text)
        forall a b. (a -> IO b) -> Update (Box a) (Box b)
run (\() -> forall a. HasCallStack => [Char] -> a
error [Char]
"io shouldn't be run") -< forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Attrs
attrs <- forall a. Attrs -> Update () a -> IO Attrs
evalUpdate forall {k} {v}. HashMap k v
HMS.empty forall {b}. Update () (Box b)
f
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((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
"hello" Attrs
attrs) forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Value
"world") forall a b. (a -> b) -> a -> b
$
    forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
      [Char]
"bad value for hello: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Attrs
attrs
  let f' :: Update () (Box Text)
f' = proc () -> do
        forall a b. (a -> IO b) -> Update (Box a) (Box b)
run (\() -> forall a. HasCallStack => [Char] -> a
error [Char]
"io shouldn't be run") -< forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        forall a. JSON a => Text -> Update (Box a) (Box a)
update Text
"hello" -< (Box Text
"world" :: Box T.Text)
  Attrs
attrs' <- forall a. Attrs -> Update () a -> IO Attrs
evalUpdate forall {k} {v}. HashMap k v
HMS.empty Update () (Box Text)
f'
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((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
"hello" Attrs
attrs') forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Value
"world") forall a b. (a -> b) -> a -> b
$
    forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
      [Char]
"bad value for hello: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Attrs
attrs'
  Box Text
v3 <- forall a. Attrs -> Update () a -> IO a
execUpdate
    (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"))])
    forall a b. (a -> b) -> a -> b
$ proc () -> do
      Box Text
v1 <- forall a. JSON a => Text -> Update (Box a) (Box a)
update Text
"hello" -< Box Text
"world"
      Box Text
v2 <- forall a b. (a -> IO b) -> Update (Box a) (Box b)
run (\Text
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"io shouldn't be run") -< (Box Text
v1 :: Box T.Text)
      Box Text
v3 <- forall a. JSON a => Text -> Update (Box a) (Box a)
update Text
"bar" -< (Box Text
v2 :: Box T.Text)
      forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Box Text
v3
  Text
v3' <- forall a. Box a -> IO a
runBox Box Text
v3
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
v3' forall a. Eq a => a -> a -> Bool
== Text
"baz") forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [Char] -> a
error [Char]
"bad value"

templatesExpand :: IO ()
templatesExpand :: IO ()
templatesExpand = do
  Box Text
v3 <- forall a. Attrs -> Update () a -> IO a
execUpdate Attrs
attrs forall a b. (a -> b) -> a -> b
$ proc () -> Update (Box Text) (Box Text)
template -< Box Text
"<v1>-<v2>"
  Text
v3' <- forall a. Box a -> IO a
runBox Box Text
v3
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
v3' forall a. Eq a => a -> a -> Bool
== Text
"hello-world") forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [Char] -> a
error [Char]
"bad value"
  where
    attrs :: Attrs
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 :: forall a. a -> Update () (Box a)
constBox a
a = forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a))