Test.hs

{-# 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 =
  void $
    runUpdate attrs $ proc () -> do
      returnA -< ()
  where
    attrs = HMS.empty

picksFirst :: IO ()
picksFirst = do
  v <-
    execUpdate HMS.empty $
      let l = proc () -> do
            returnA -< 2
          r = proc () -> do
            returnA -< 3
       in l <+> r
  unless (v == (2 :: Int)) (error "bad value")

loads :: IO ()
loads = do
  v <- execUpdate attrs $ load "foo"
  v' <- runBox v
  unless (v' == ("bar" :: T.Text)) (error "bad value")
  where
    attrs = HMS.singleton "foo" (Locked, "bar")

survivesChecks :: IO ()
survivesChecks = do
  v <- execUpdate attrs $ proc () -> do
    (sawLeft <+> sawRight) -< ()
    load "res" -< ()
  v' <- runBox v
  unless (v' == ("I saw right" :: T.Text)) (error "bad value")
  where
    attrs = HMS.singleton "val" (Locked, "right")
    sawLeft :: Update () ()
    sawLeft = proc () -> do
      val <- load "val" -< ()
      check (== "left") -< (val :: Box T.Text)
      useOrSet "res" -< "I saw left" :: Box T.Text
      returnA -< ()
    sawRight :: Update () ()
    sawRight = proc () -> do
      val <- load "val" -< ()
      check (== "right") -< (val :: Box T.Text)
      useOrSet "res" -< "I saw right" :: Box T.Text
      returnA -< ()

isNotTooEager :: IO ()
isNotTooEager = do
  let f =
        constBox ()
          >>> run (const $ error "IO is too eager (f)")
          >>> useOrSet "foo"
  let f1 = proc () -> do
        run (const $ error "IO is too eager (f1)") -< pure ()
        useOrSet "foo" -< "foo"
  void $ (execUpdate attrs f :: IO (Box T.Text))
  void $ (execUpdate attrs f1 :: IO (Box T.Text))
  where
    attrs = HMS.singleton "foo" (Locked, "right")

dirtyForcesUpdate :: IO ()
dirtyForcesUpdate = do
  let f = constBox ("world" :: T.Text) >>> dirty >>> update "hello"
  attrs' <- evalUpdate attrs f
  unless ((snd <$> HMS.lookup "hello" attrs') == Just "world") $
    error $
      "bad value for hello: " <> show attrs'
  where
    attrs = HMS.singleton "hello" (Free, "foo")

shouldNotRunWhenNoChanges :: IO ()
shouldNotRunWhenNoChanges = do
  let f = proc () -> do
        update "hello" -< ("world" :: Box T.Text)
        run (\() -> error "io shouldn't be run") -< pure ()
  attrs <- evalUpdate HMS.empty f
  unless ((snd <$> HMS.lookup "hello" attrs) == Just "world") $
    error $
      "bad value for hello: " <> show attrs
  let f' = proc () -> do
        run (\() -> error "io shouldn't be run") -< pure ()
        update "hello" -< ("world" :: Box T.Text)
  attrs' <- evalUpdate HMS.empty f'
  unless ((snd <$> HMS.lookup "hello" attrs') == Just "world") $
    error $
      "bad value for hello: " <> show attrs'
  v3 <- execUpdate
    (HMS.fromList [("hello", (Free, "world")), ("bar", (Free, "baz"))])
    $ proc () -> do
      v1 <- update "hello" -< "world"
      v2 <- run (\_ -> error "io shouldn't be run") -< (v1 :: Box T.Text)
      v3 <- update "bar" -< (v2 :: Box T.Text)
      returnA -< v3
  v3' <- runBox v3
  unless (v3' == "baz") $ error "bad value"

templatesExpand :: IO ()
templatesExpand = do
  v3 <- execUpdate attrs $ proc () -> template -< "<v1>-<v2>"
  v3' <- runBox v3
  unless (v3' == "hello-world") $ error "bad value"
  where
    attrs = HMS.fromList [("v1", (Free, "hello")), ("v2", (Free, "world"))]

constBox :: a -> Update () (Box a)
constBox a = arr (const (pure a))