More library additions

library/classes.lisp

@@ -20,17 +20,17 @@
    #:Functor #:map
    #:Applicative #:pure #:liftA2
    #:Monad #:>>=
-   #:>>
+   #:>> #:join
    #:MonadFail #:fail
    #:Alternative #:alt #:empty
-   #:Foldable #:fold #:foldr #:mconcat
+   #:Foldable #:fold #:foldr #:mconcat #:mconcatmap #:mcommute?
    #:Traversable #:traverse
    #:Bifunctor #:bimap #:map-fst #:map-snd
    #:sequence
    #:Into
    #:TryInto
    #:Iso
-   #:Unwrappable #:unwrap-or-else #:with-default #:unwrap #:expect #:as-optional
+   #:Unwrappable #:unwrap-or-else #:with-default #:unwrap #:unwrap-into #:expect #:as-optional
    #:default #:defaulting-unwrap #:default?))
 
 (in-package #:coalton-library/classes)
@@ -211,8 +211,14 @@
 
   (declare >> (Monad :m => (:m :a) -> (:m :b) -> (:m :b)))
   (define (>> a b)
+    "Equivalent to `(>>= a (fn (_) b))`."
     (>>= a (fn (_) b)))
 
+  (declare join ((Monad :m) => :m (:m :a) -> :m :a))
+  (define (join m)
+    "Equivalent to `(>>= m id)`."
+    (>>= m (fn (x) x)))
+
   (define-class (Monad :m => MonadFail :m)
     (fail (String -> :m :a)))
 
@@ -231,6 +237,16 @@
     "Fold a container of monoids into a single element."
     (fold <> mempty))
 
+  (declare mconcatmap ((Foldable :f) (Monoid :a) => (:b -> :a) -> :f :b -> :a))
+  (define (mconcatmap f)
+    "Map a container to a container of monoids, and then fold that container into a single element."
+    (fold (fn (a b) (<> a (f b))) mempty))
+
+  (declare mcommute? ((Eq :a) (Monoid :a) => :a -> :a -> Boolean))
+  (define (mcommute? a b)
+    "Does `a <> b` `==' `b <> a`?"
+    (== (<> a b) (<> b a)))
+
   (define-class (Traversable :t)
     (traverse (Applicative :f => (:a -> :f :b) -> :t :a -> :f (:t :b))))
 
@@ -314,6 +330,11 @@ Typical `fail` continuations are:
                                                container))))
                     container))
 
+  (declare unwrap-into ((Unwrappable (Result :c)) (TryInto :a :b :c) => :a -> :b))
+  (define unwrap-into
+    "Same as `tryInto` followed by `unwrap`."
+    (fn (x) (unwrap (tryinto x))))
+
   (declare with-default ((Unwrappable :container) =>
                          :element
                          -> (:container :element)

library/functions.lisp

@@ -160,7 +160,14 @@
   ;;
 
   (define-instance (Functor (Arrow :a))
-    (define map compose)))
+    (define map compose))
+
+  (define-instance (Applicative (Arrow :a))
+    (define (pure x) (fn (_) x))
+    (define (liftA2 f g h) (fn (x) (f (g x) (h x)))))
+
+  (define-instance (Monad (Arrow :a))
+    (define (>>= f g) (fn (x) (g (f x) x)))))
 
 ;;;
 ;;; Bracket pattern
@@ -171,7 +178,7 @@
   (cl:let ((output (cl:gensym "OUTPUT")))
     `(cl:let (,output)
        (cl:unwind-protect (cl:setq ,output (call-coalton-function ,thunk ,obj))
-          (call-coalton-function ,exit ,obj))
+         (call-coalton-function ,exit ,obj))
        ,output)))
 
 (coalton-toplevel

library/iterator.lisp

@@ -42,13 +42,16 @@
    #:take!
    #:flatten!
    #:flat-map!
+   #:mconcat!
+   #:mconcatmap!
    #:chain!
    #:remove-duplicates! ; defined in library/hashtable.lisp
    #:pair-with!
    #:sum!
    #:and!
    #:or!
    #:count!
+   #:countBy!
    #:for-each!
    #:find!
    #:find-map!
@@ -423,6 +426,15 @@ interleaving. (interleave empty ITER) is equivalent to (id ITER)."
     "Flatten! wrapped around map."
     (flatten! (map func iter)))
 
+  (declare mconcat! ((Monoid :a) => (Iterator :a) -> :a))
+  (define mconcat!
+    "Fold an iterator of monoids into a single element."
+    (fold! <> mempty))
+
+  (declare mconcatmap! ((Monoid :a) => (:b -> :a) -> (Iterator :b) -> :a))
+  (define (mconcatmap! f)
+    "Map an iterator to an iterator of monoids, and then fold that iterator into a single element."
+    (compose (fold! <> mempty) (map f)))
 
   (declare pair-with! ((:key -> :value) -> Iterator :key -> Iterator (Tuple :key :value)))
   (define (pair-with! func keys)
@@ -478,6 +490,11 @@ This operation could be called `length!`, but `count!` emphasizes the fact that
 afterwards, ITER will be exhausted."
     (sum! (map (const 1) iter)))
 
+  (declare countBy! ((:elt -> Boolean) -> Iterator :elt -> UFix))
+  (define (countBy! f iter)
+    "Count the number of items in `iter` that satisfy the predicate `f`."
+    (sum! (map (fn (elt) (if (f elt) 1 0)) iter)))
+
   (declare for-each! ((:elt -> Unit) -> Iterator :elt -> Unit))
   (define (for-each! thunk iter)
     "Call THUNK on each element of ITER in order for side effects.

library/list.lisp

@@ -34,6 +34,7 @@
    #:elemIndex
    #:findIndex
    #:range
+   #:enumerate
    #:append
    #:concat
    #:concatMap
@@ -43,8 +44,8 @@
    #:lookup
    #:remove-duplicates
    #:remove-if
-   #:remove
-   #:difference
+   #:remove #:without
+   #:difference #:sdifference
    #:zipWith
    #:zipWith3
    #:zipWith4
@@ -289,6 +290,11 @@
           (%reverse! (inner start end Nil))
           (inner end start Nil))))
 
+  (declare enumerate ((Num :int) (Ord :int) => List :a -> List (Tuple :int :a)))
+  (define (enumerate xs)
+    "Pair successive zero-based indices with elements from `xs`."
+    (iter:collect! (iter:enumerate! (iter:into-iter xs))))
+
   (define (append-rev list result)
     (match list
       ((Nil) result)
@@ -390,10 +396,23 @@
     "Return a new list with the first element equal to `x` removed."
     (remove-if (== x) ys))
 
+  (declare without (Eq :a => :a -> (List :a) -> (List :a)))
+  (define (without x)
+    "Return a new list without all elements equal to `x` removed"
+    (filter (/= x)))
+
   (declare difference (Eq :a => ((List :a) -> (List :a) -> (List :a))))
   (define (difference xs ys)
     "Returns a new list with the first occurence of each element in `ys` removed from `xs`."
-    (fold (fn (a b) (remove b a)) xs ys))
+    (fold (flip remove) xs ys))
+
+  (declare sdifference (Eq :a => (List :a) -> (List :a) -> (List :a)))
+  (define (sdifference xs ys)
+    "Symmetric difference.
+
+Returns a new list with only those elements of `xs` and `ys` which are not `==' to any elements in the other."
+    (append (difference xs ys)
+            (difference ys xs)))
 
   (declare zipWith ((:a -> :b -> :c) -> (List :a) -> (List :b) -> (List :c)))
   (define (zipWith f xs ys)

library/ord-map.lisp

@@ -12,18 +12,20 @@
   (:export
    #:Map
    #:empty
-   #:lookup
+   #:lookup #:contains?
    #:insert
    #:replace
    #:replace-or-insert #:insert-or-replace
-   #:remove
+   #:remove #:without
    #:keys
    #:values
    #:entries
    #:collect!
    #:collect
    #:update
-   #:merge))
+   #:merge #:union #:intersection #:difference #:sdifference
+   #:filter-by-key #:filter-by-value #:filter-by-entry
+   #:zip #:zip-with-default))
 
 (in-package :coalton-library/ord-map)
 
@@ -78,6 +80,13 @@
     (match mp
       ((%Map tre) (coalton-library/classes:map value (tree:lookup tre (JustKey k))))))
 
+  (declare contains? ((Ord :key) => :key -> (Map :key :value) -> Boolean))
+  (define (contains? k mp)
+    "Does `mp` contain a key `==' to `k`?"
+    (match (lookup mp k)
+      ((Some _) True)
+      ((None) False)))
+
   (declare insert ((Ord :key) => ((Map :key :value) -> :key -> :value -> (Optional (Map :key :value)))))
   (define (insert mp k v)
     "Associate K with V in MP. If MP already contains a mapping for K, return None."
@@ -124,6 +133,11 @@ Like `replace-or-insert', but prioritizing insertion as a use case."
                                  (match mp
                                    ((%Map tre) (tree:remove tre (JustKey k))))))
 
+  (declare without ((Ord :key) => :key -> (Map :key :value) -> (Map :key :value)))
+  (define (without k mp)
+    "If `mp` contains a mapping associated with a key `==' to `k`, construct a new Map without that mapping. Return `mp` if it contains no such mapping."
+    (with-default mp (remove mp k)))
+
   (declare entries ((Map :key :value) -> (iter:Iterator (Tuple :key :value))))
   (define (entries mp)
     "Iterate over the (key value) pairs in MP, sorted by the keys in least-to-greatest order."
@@ -163,6 +177,9 @@ If `iter` contains duplicate keys, later values will overwrite earlier values."
                 empty
                 iter))
 
+  (define-instance (Ord :key => iter:FromIterator (Map :key :value) (Tuple :key :value))
+    (define iter:collect! collect!))
+
   (declare collect ((Ord :key) (Foldable :collection) => ((:collection (Tuple :key :value)) -> (Map :key :value))))
   (define (collect coll)
     "Construct a `Map` containing all the `(key value)` pairs in `coll`.
@@ -173,8 +190,8 @@ If `coll` contains duplicate keys, later values will overwrite earlier values."
           empty
           coll))
 
-  (define-instance (Ord :key => iter:FromIterator (Map :key :value) (Tuple :key :value))
-    (define iter:collect! collect!))
+  (define-instance ((Ord :key) (Foldable :collection) => (Into (:collection (Tuple :key :value)) (Map :key :value)))
+    (define into collect))
 
   (declare update ((Ord :key) => (:value -> :value) -> (Map :key :value) -> :key -> (Optional (Map :key :value))))
   (define (update func mp key)
@@ -211,9 +228,79 @@ operation, and therefore Map cannot implement Monoid."
     (let (%Map b) = b)
     (%Map (tree:merge a b)))
 
+  (declare union (Ord :key => Map :key :value -> Map :key :value -> Map :key :value))
+  (define union
+    "Same as `merge`."
+    merge)
+
+  (declare intersection (Ord :key => Map :key :value -> Map :key :value -> Map :key :value))
+  (define (intersection a b)
+    "Construct a Map containing only those mappings from `b` that contain a key `==' to at least one key in `a`."
+    (let (%Map a) = a)
+    (let (%Map b) = b)
+    (%Map (tree:intersection a b)))
+
+  (declare difference (Ord :key => Map :key :value -> Map :key :value -> Map :key :value))
+  (define (difference a b)
+    "Construct a Map containing only those mappings from `b` which contain a key not `==' to any key in `a`."
+    (let (%Map a) = a)
+    (let (%Map b) = b)
+    (%Map (tree:difference a b)))
+
+  (declare sdifference (Ord :key => Map :key :value -> Map :key :value -> Map :key :value))
+  (define (sdifference a b)
+    "Symmetric difference.
+
+Construct a Map containing only those mappings of `a` and `b` which do not associate keys `==' keys in the other."
+    (let (%Map a) = a)
+    (let (%Map b) = b)
+    (%Map (tree:sdifference a b)))
+
+  (declare filter-by-key (Ord :key => (:key -> Boolean) -> Map :key :value -> Map :key :value))
+  (define (filter-by-key keep? mp)
+    "Construct a Map containing only those entries of `mp` which contain keys which satisfy `keep?`."
+    (let (%Map mp) = mp)
+    (%Map (tree:filter (compose keep? key) mp)))
+
+  (declare filter-by-value (Ord :key => (:value -> Boolean) -> Map :key :value -> Map :key :value))
+  (define (filter-by-value keep? mp)
+    "Construct a Map containing only those entries of `mp` which contain values which satisfy `keep?`."
+    (let (%Map mp) = mp)
+    (%Map (tree:filter (compose keep? value) mp)))
+
+  (declare filter-by-entry (Ord :key => ((Tuple :key :value) -> Boolean) -> Map :key :value -> Map :key :value))
+  (define (filter-by-entry keep? mp)
+    "Construct a Map containing only those entries of `mp` which satisfy `keep?`."
+    (let (%Map mp) = mp)
+    (%Map (tree:filter (compose keep? into) mp)))
+
+  (declare zip (Ord :key => Map :key :value1 -> Map :key :value2 -> Map :key (Tuple :value1 :value2)))
+  (define (zip a b)
+    "Construct a Map associating only those keys included in both `a` and `b` to the Tuple containing their respective values."
+    (fold (fn (mp k)
+            (insert-or-replace mp k (Tuple (unwrap (lookup a k))
+                                           (unwrap (lookup b k)))))
+          Empty
+          (tree:intersection (tree:collect! (keys a))
+                             (tree:collect! (keys b)))))
+
+  (declare zip-with-default ((Ord :key) (Default :value1) (Default :value2)
+                             => Map :key :value1 -> Map :key :value2 -> Map :key (Tuple :value1 :value2)))
+  (define (zip-with-default a b)
+    "Construct a Map associating all keys `a` and `b` to the Tuple containing their respective values, using the default value of the respectie types where a key is not associated."
+    (fold (fn (mp k)
+            (insert-or-replace mp k (Tuple (defaulting-unwrap (lookup a k))
+                                           (defaulting-unwrap (lookup b k)))))
+          Empty
+          (tree:intersection (tree:collect! (keys a))
+                             (tree:collect! (keys b)))))
+
   (define-instance (Ord :key => Semigroup (Map :key :value))
     (define <> merge))
 
+  (define-instance (Ord :key => (Monoid (Map :key :value)))
+    (define mempty Empty))
+
   (define-instance (Functor (Map :key))
     (define (coalton-library/classes:map func mp)
       (let (%Map tre) = mp)