diff --git a/scripts/build.clj b/scripts/build.clj index 0c9bbdd..a4dd1eb 100644 --- a/scripts/build.clj +++ b/scripts/build.clj @@ -8,7 +8,7 @@ {:main 'cats.runner :output-to "out/tests.js" :output-dir "out" - :optimizations :advanced + :optimizations :none :target :nodejs :verbose true}) (println "... done. Elapsed" (/ (- (System/nanoTime) start) 1e9) "seconds")) diff --git a/src/cats/builtin.cljc b/src/cats/builtin.cljc index 6fdd157..8fa5d98 100644 --- a/src/cats/builtin.cljc +++ b/src/cats/builtin.cljc @@ -44,10 +44,119 @@ (-extract [_] nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (Lazy) Sequence Monad +;; Sequence Monad i.e. PersistentList ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (def sequence-context + (reify + p/Context + (-get-level [_] ctx/+level-default+) + + p/Semigroup + (-mappend [_ sv sv'] + (into sv' (reverse sv))) + + p/Monoid + (-mempty [_] ()) + + p/Functor + (-fmap [_ f v] + (loop [[h & t :as c] v + result ()] + (if (empty? c) + (reverse result) + (recur t (cons (f h) result))))) + + p/Applicative + (-pure [_ v] (list v)) + + (-fapply [_ self av] + ;; Each function (outer loop) applied to each value (inner loop). + (->> (loop [[h & t :as c] self + result ()] + (if (empty? c) + result + (recur t + (cons (loop [[h' & t' :as c'] av + result' ()] + (if (empty? c') + result' + (recur t' (cons (h h') result')))) + result)))) + ;; Note that both `result` & `result'` above are + ;; in reverse order. + ;; Conjing elements of %2 into %1 below is done in + ;; in reverse order, so final result is correctly + ;; ordered. + (reduce #(into %1 %2) ()))) + + + p/Monad + (-mreturn [_ v] + (list v)) + + (-mbind [_ self f] + (->> (loop [[h & t :as c] self + result ()] + (if (empty? c) + result + (recur t (cons (f h) result)))) + ;; Note that `result` above is in reverse order. + ;; Conjing elements of %2 into %1 below is done in + ;; in reverse order, so final result is correctly + ;; ordered. + (reduce #(into %1 %2) ()))) + + p/MonadZero + (-mzero [_] ()) + + p/MonadPlus + (-mplus [_ mv mv'] + (into mv' (reverse mv))) + + p/Foldable + (-foldr [ctx f z xs] + (let [x (first xs)] + (if (nil? x) + z + (let [xs (rest xs)] + (f x (p/-foldr ctx f z xs)))))) + + (-foldl [ctx f z xs] + (reduce f z xs)) + + p/Traversable + (-traverse [ctx f tv] + (let [as (p/-fmap ctx f tv)] + (p/-foldr ctx + (fn [a acc] + (m/alet [x a + xs acc] + (cons x xs))) + (m/pure ()) + as))) + + p/Printable + (-repr [_] + "#"))) + +(util/make-printable (type sequence-context)) + +(extend-type #?(:clj clojure.lang.PersistentList + :cljs cljs.core.List) + p/Contextual + (-get-context [_] sequence-context)) + +(extend-type #?(:clj clojure.lang.PersistentList$EmptyList + :cljs cljs.core.EmptyList) + p/Contextual + (-get-context [_] sequence-context)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Lazy Sequence Monad +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(def lazy-sequence-context (reify p/Context (-get-level [_] ctx/+level-default+) @@ -112,14 +221,14 @@ p/Printable (-repr [_] - "#"))) + "#"))) -(util/make-printable (type sequence-context)) +(util/make-printable (type lazy-sequence-context)) (extend-type #?(:clj clojure.lang.LazySeq :cljs cljs.core.LazySeq) p/Contextual - (-get-context [_] sequence-context)) + (-get-context [_] lazy-sequence-context)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Range diff --git a/test/cats/builtin_spec.cljc b/test/cats/builtin_spec.cljc index 755dffe..e3d44a9 100644 --- a/test/cats/builtin_spec.cljc +++ b/test/cats/builtin_spec.cljc @@ -169,7 +169,7 @@ ;; Sequence (defn sequence-gen [g] - (gen/fmap #(lazy-seq %) (gen/vector g))) + (gen/list g)) (defspec sequence-semigroup 10 (lt/semigroup-associativity @@ -188,8 +188,8 @@ (defspec sequence-second-functor-law 10 (lt/second-functor-law {:gen (sequence-gen gen/any) - :f #(lazy-seq [%]) - :g #(lazy-seq [%])})) + :f #(list %) + :g #(list %)})) (defspec sequence-applicative-identity 10 (lt/applicative-identity-law @@ -206,14 +206,14 @@ (lt/applicative-interchange {:ctx b/sequence-context :gen gen/int - :appf (lazy-seq [inc])})) + :appf (list inc)})) (defspec sequence-applicative-composition 10 (lt/applicative-composition {:ctx b/sequence-context :gen gen/int - :appf (lazy-seq [inc]) - :appg (lazy-seq [dec])})) + :appf (list inc) + :appg (list dec)})) (defspec sequence-first-monad-law 10 (lt/first-monad-law @@ -229,6 +229,92 @@ :f (comp seq vector str) :g (comp seq vector count)})) +(t/deftest sequence-foldable + (t/testing "Foldl" + (t/is (= [3 2 1] + (m/foldl (fn [acc v] (into [v] acc)) [] (list 1 2 3)))) + (t/is (= 6 (m/foldl + 0 (list 1 2 3))))) + + (t/testing "Foldr" + (t/is (= [1 2 3] + (m/foldr (fn [v acc] (into [v] acc)) [] (list 1 2 3)))) + (t/is (= 6 (m/foldr + 0 (list 1 2 3)))))) + +(t/deftest sequence-traversable + (t/testing "Traverse" + (t/is (= (maybe/just []) + (ctx/with-context maybe/context + (m/traverse inc-if-even '())))) + (t/is (= (maybe/just [3 5]) + (ctx/with-context maybe/context + (m/traverse inc-if-even (list 2 4))))) + (t/is (= (maybe/nothing) + (ctx/with-context maybe/context + (m/traverse inc-if-even (list 1 2))))))) + +;; Lazy Sequence + +(defn lazy-sequence-gen [g] + (gen/fmap #(lazy-seq %) (gen/vector g))) + +(defspec lazy-sequence-semigroup 10 + (lt/semigroup-associativity + {:ctx b/lazy-sequence-context + :gen (gen/not-empty (lazy-sequence-gen gen/any))})) + +(defspec lazy-sequence-monoid 10 + (lt/monoid-identity-element + {:ctx b/lazy-sequence-context + :gen (lazy-sequence-gen gen/any)})) + +(defspec lazy-sequence-first-functor-law 10 + (lt/first-functor-law + {:gen (lazy-sequence-gen gen/any)})) + +(defspec lazy-sequence-second-functor-law 10 + (lt/second-functor-law + {:gen (lazy-sequence-gen gen/any) + :f #(lazy-seq [%]) + :g #(lazy-seq [%])})) + +(defspec lazy-sequence-applicative-identity 10 + (lt/applicative-identity-law + {:ctx b/lazy-sequence-context + :gen (lazy-sequence-gen gen/any)})) + +(defspec lazy-sequence-applicative-homomorphism 10 + (lt/applicative-homomorphism + {:ctx b/lazy-sequence-context + :gen gen/any + :f (constantly false)})) + +(defspec lazy-sequence-applicative-interchange 10 + (lt/applicative-interchange + {:ctx b/lazy-sequence-context + :gen gen/int + :appf (lazy-seq [inc])})) + +(defspec lazy-sequence-applicative-composition 10 + (lt/applicative-composition + {:ctx b/lazy-sequence-context + :gen gen/int + :appf (lazy-seq [inc]) + :appg (lazy-seq [dec])})) + +(defspec lazy-sequence-first-monad-law 10 + (lt/first-monad-law + {:ctx b/lazy-sequence-context + :mf #(if % (lazy-seq [%]) (lazy-seq []))})) + +(defspec lazy-sequence-second-monad-law 10 + (lt/second-monad-law {:ctx b/lazy-sequence-context})) + +(defspec lazy-sequence-third-monad-law 10 + (lt/third-monad-law + {:ctx b/lazy-sequence-context + :f (comp seq vector str) + :g (comp seq vector count)})) + (t/deftest lazyseq-foldable (t/testing "Foldl" (t/is (= [3 2 1] diff --git a/test/cats/core_spec.cljc b/test/cats/core_spec.cljc index 7cf9200..10199a1 100644 --- a/test/cats/core_spec.cljc +++ b/test/cats/core_spec.cljc @@ -160,7 +160,7 @@ ;; FIXME: uncomment when finishing funcool/cats#77 #_(t/testing "It can lift a function to a Monad Transformer" - (let [maybe-sequence-monad (maybe/maybe-t b/sequence-context)] + (let [maybe-sequence-monad (maybe/maybe-t b/lazy-sequence-context)] (t/is (= [(maybe/just 1) (maybe/just 2) (maybe/just 3) (maybe/just 4) (maybe/just 5) (maybe/just 6)] @@ -181,7 +181,7 @@ (monad+ (maybe/just 1) (maybe/nothing))))) (t/testing "It can lift a function to a Monad Transformer" - (let [maybe-sequence-monad (maybe/maybe-t b/sequence-context)] + (let [maybe-sequence-monad (maybe/maybe-t b/lazy-sequence-context)] (t/is (= [(maybe/just 1) (maybe/just 2) (maybe/just 3) (maybe/just 4) (maybe/just 5) (maybe/just 6)] @@ -209,7 +209,7 @@ ((curry-monad+ (maybe/just 1)) (maybe/just 5)))))) (t/testing "It can lift a function to a Monad Transformer" - (let [maybe-sequence-monad (maybe/maybe-t b/sequence-context) + (let [maybe-sequence-monad (maybe/maybe-t b/lazy-sequence-context) monad+ (m/lift-m 2 add2)] (t/is (= [(maybe/just 1) (maybe/just 2) (maybe/just 3) (maybe/just 4)