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