Skip to content

Instantly share code, notes, and snippets.

@mccraigmccraig
Created November 1, 2018 18:42
Show Gist options
  • Save mccraigmccraig/6041ad45d6781c549fd07cdd6896ebe8 to your computer and use it in GitHub Desktop.
Save mccraigmccraig/6041ad45d6781c549fd07cdd6896ebe8 to your computer and use it in GitHub Desktop.
(ns prpr.cats.prws-test
(:require
#?(:clj [prpr.cats.prws :as sut :refer [prwsdo]]
:cljs [prpr.cats.prws :as sut :refer [PRWS_V_T] :refer-macros [prwsdo]])
[cats.core :as monad :refer [>>= return]]
[cats.context :refer [with-context]]
[cats.monad.state :as state]
#?(:clj [prpr.promise :as prpr :refer [ddo]]
:cljs [prpr.promise :as prpr :refer-macros [ddo]])
#?(:clj [prpr.test :refer [deftest test-async is testing]]
:cljs [prpr.test :refer-macros [deftest test-async is testing]])
[prpr.cats.reader :as reader]
[prpr.cats.writer :as writer])
#?(:clj
(:import
[prpr.cats.prws PRWS_V_T])))
(deftest wrap-result-test
(test-async
(ddo [r (sut/wrap-result
{::monad/val :val
::state/state :state
::writer/log :log})]
(return
(is (= r
(into (PRWS_V_T.)
{::monad/val :val
::state/state :state
::writer/log :log})))))))
(deftest lift-promise-test
(test-async
;; promise of a plain value
(ddo [:let [lv (sut/lift-promise (prpr/success-pr :foo))]
r (sut/run-prws lv {::state/state :state ::reader/env :env})]
(return
(is (= {::monad/val :foo ::state/state :state ::writer/log nil}
(into {} r)))))
;; promise of a PRWS_V - not sure about this
(ddo [:let [lv (sut/lift-promise (sut/wrap-result
{::monad/val :p-val
::state/state :p-state
::writer/log [:p-log]}))]
r (sut/run-prws lv {::state/state :state ::reader/env :env})]
(return
(is (= {::monad/val :p-val ::state/state :p-state ::writer/log [:p-log]}
(into {} r))))))
;; promise of a PRWS - not sure about this
(ddo [:let [lv (sut/lift-promise (prwsdo [r (reader/ask)
_ (state/swap #(assoc % :renv r))
_ (writer/tell [:blah])]
(return :foo)))]
r (sut/run-prws lv {::state/state {:foo 100} ::reader/env :env})]
(return
(is (= {::monad/val :foo ::state/state {:foo 100 :renv :env} ::writer/log [:blah]}
(into {} r)))))
)
(deftest lift-value-test
(test-async
(ddo [:let [lv (sut/lift-value :foo)]
r (sut/run-prws lv {::state/state :state ::reader/env :env})]
(return
(is (= {::monad/val :foo ::state/state :state ::writer/log nil}
(into {} r)))))))
(deftest lift-test
(test-async
;; lift a plain value
(ddo [:let [lv (sut/lift :foo)]
r (sut/run-prws lv {::state/state :state ::reader/env :env})]
(return
(is (= {::monad/val :foo ::state/state :state ::writer/log nil}
(into {} r))))))
;; lift a promise of a plain value
(ddo [:let [lv (sut/lift (prpr/success-pr :foo))]
r (sut/run-prws lv {::state/state :state ::reader/env :env})]
(return
(is (= {::monad/val :foo ::state/state :state ::writer/log nil}
(into {} r))))))
(deftest context-test
(test-async
(testing "return"
(ddo [:let [comp (with-context sut/context
(return :foo))]
r (sut/run-prws comp {::state/state :state ::reader/env :env})]
(return
(is (= {::monad/val :foo ::state/state :state ::writer/log nil}
(into {} r))))))
(testing "prwsdo"
(ddo [:let [comp (prwsdo [a (return :foo)]
(return a))]
r (sut/run-prws comp {::state/state :state ::reader/env :env})]
(return
(is (= {::monad/val :foo ::state/state :state ::writer/log nil}
(into {} r))))))
(testing "reader-ask"
(ddo [:let [comp (prwsdo [{a :a b :b} (reader/ask)]
(return (+ a b)))]
r (sut/run-prws comp {::state/state :state ::reader/env {:a 1 :b 2}})]
(return
(is (= {::monad/val 3 ::state/state :state ::writer/log nil}
(into {} r))))))
(testing "reader-local"
(ddo [:let [comp (prwsdo [{a :a b :b} (reader/ask)]
(return (+ a b)))
l-comp (reader/local (constantly {:a 3 :b 4}) comp)]
r (sut/run-prws l-comp {::state/state :state ::reader/env {:a 1 :b 2}})]
(return
(is (= {::monad/val 7 ::state/state :state ::writer/log nil}
(into {} r))))))
(testing "writer-tell"
(ddo [:let [comp (prwsdo [a (writer/tell [:foo])
b (writer/tell [:bar])]
(return [a b]))]
r (sut/run-prws comp {::state/state :state ::reader/env :env})]
(return
(is (= {::monad/val [nil nil] ::state/state :state ::writer/log [:foo :bar]}
(into {} r))))))
(testing "writer-listen"
(ddo [:let [comp (prwsdo [_ (writer/tell [:foo])
_ (writer/tell [:bar])]
(return :val))
comp-2 (prwsdo [v-l (writer/listen comp)]
(return v-l))]
r (sut/run-prws comp-2 {::state/state :state ::reader/env :env})]
(return
(is (= {::monad/val [:val [:foo :bar]]
::state/state :state
::writer/log [:foo :bar]}
(into {} r))))))
(testing "writer-pass"
(ddo [:let [comp (prwsdo [_ (writer/tell [:foo])
_ (writer/tell [:bar])]
(return [:val #(map name %)]))
comp-2 (writer/pass comp)]
r (sut/run-prws comp-2 {::state/state :state ::reader/env :env})]
(return
(is (= {::monad/val :val ::state/state :state ::writer/log ["foo" "bar"]}
(into {} r))))))
(testing "state-get-put"
(ddo [:let [comp (prwsdo [{a :a :as s} (state/get)
old (state/put (assoc s :b (inc a)))]
(return old))]
r (sut/run-prws comp {::state/state {:a 1} ::reader/env :env})]
(return
(is (= {::monad/val {:a 1} ::state/state {:a 1 :b 2} ::writer/log nil}
(into {} r))))))
(testing "state-swap"
(ddo [:let [comp (prwsdo [old (state/swap #(assoc % :b :bar))]
(return old))]
r (sut/run-prws comp {::state/state {:a 1} ::reader/env :env})]
(return
(is (= {::monad/val {:a 1} ::state/state {:a 1 :b :bar} ::writer/log nil}
(into {} r))))))
;; monad laws taken from https://wiki.haskell.org/Monad_laws
(testing "left identity"
(ddo [:let [f (fn [v]
;; exercise reader, writer and state
(prwsdo [r (reader/ask)
_ (state/swap #(assoc % :renv r))
_ (writer/tell [:blah])]
(return (inc v))))]
{l-v ::monad/val
l-s ::state/state
l-w ::writer/log
:as l} (sut/run-prws
(>>= (return sut/context 1) f)
{::state/state {:foo 1}
::reader/env 100})
{:as r} (sut/run-prws
(f 1)
{::state/state {:foo 1}
::reader/env 100})]
(return
[(is (= l-v 2))
(is (= l-s {:foo 1 :renv 100}))
(is (= l-w [:blah]))
(is (= l r))])))
(testing "right identity"
(ddo [;; exercise reader, writer and state
:let [mv (prwsdo [r (reader/ask)
_ (state/swap #(assoc % :renv r))
_ (writer/tell [:blah])]
(return sut/context :foo))]
{l-v ::monad/val
l-s ::state/state
l-w ::writer/log
:as l} (sut/run-prws
(prwsdo [v mv]
(return v))
{::state/state {:foo 1}
::reader/env 100})
{:as r} (sut/run-prws
mv
{::state/state {:foo 1}
::reader/env 100})]
(return
[(is (= l-v :foo))
(is (= l-s {:foo 1 :renv 100}))
(is (= l-w [:blah]))
(is (= l r))])))
(testing "associativity"
(ddo [:let [f #(return sut/context (inc %))
g #(return sut/context (* 10 %))
;; exercise reader, writer and state
mv (prwsdo [r (reader/ask)
_ (state/swap #(assoc % :renv r))
_ (writer/tell [:blah])]
(return sut/context 1))]
{l-v ::monad/val
l-s ::state/state
l-w ::writer/log
:as l} (sut/run-prws
(prwsdo [y (prwsdo [x mv]
(f x))]
(g y))
{::state/state {:foo 1}
::reader/env 100})
{:as r} (sut/run-prws
(prwsdo [x mv]
(prwsdo [y (f x)]
(g y)))
{::state/state {:foo 1}
::reader/env 100})]
(return
[(is (= l-v 20))
(is (= l-s {:foo 1 :renv 100}))
(is (= l-w [:blah]))
(is (= l r))])))))
(deftest run-prws-test
(let [comp (prwsdo [r (reader/ask)
_ (state/swap #(assoc % :renv r))
_ (writer/tell [:blah])]
(return :foo))]
(test-async
(ddo [{v ::monad/val
s ::state/state
w ::writer/log} (sut/run-prws comp {::state/state {:foo 1}
::reader/env 100})]
(is (= v :foo))
(is (= s {:foo 1 :renv 100}))
(is (= w [:blah]))))))
(deftest eval-prws-test
(let [comp (prwsdo [r (reader/ask)
_ (state/swap #(assoc % :renv r))
_ (writer/tell [:blah])]
(return :foo))]
(test-async
(ddo [v (sut/eval-prws comp {::state/state {:foo 1}
::reader/env 100})]
(is (= v :foo))))))
(deftest permissive-test
(let [comp (fn [v] (prwsdo [_ (writer/tell [v])
w (return (inc v))]
(return w)))]
(test-async
(ddo [r (sut/eval-prws (comp 10) {})]
(is (= r 11))))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment