diff options
-rw-r--r-- | algebraic-structures.egg | 18 | ||||
-rw-r--r-- | algebraic-structures.list.alternative.scm | 4 | ||||
-rw-r--r-- | algebraic-structures.list.applicative.scm | 4 | ||||
-rw-r--r-- | algebraic-structures.list.foldable.scm | 3 | ||||
-rw-r--r-- | algebraic-structures.list.functor.scm | 3 | ||||
-rw-r--r-- | algebraic-structures.list.monad.scm | 4 | ||||
-rw-r--r-- | algebraic-structures.list.monoid.scm | 3 | ||||
-rw-r--r-- | algebraic-structures.list.reducible.scm | 3 | ||||
-rw-r--r-- | algebraic-structures.list.semigroup.scm | 3 | ||||
-rw-r--r-- | algebraic-structures.list.zip.applicative.scm | 4 | ||||
-rw-r--r-- | algebraic-structures.private.list.alternative.scm | 9 | ||||
-rw-r--r-- | algebraic-structures.private.list.applicative.scm | 30 | ||||
-rw-r--r-- | algebraic-structures.private.list.monad.scm | 8 | ||||
-rw-r--r-- | algebraic-structures.private.list.scm | 19 | ||||
-rw-r--r-- | algebraic-structures.private.list.zip.applicative.scm | 14 | ||||
-rw-r--r-- | tests/run.scm | 114 |
16 files changed, 151 insertions, 92 deletions
diff --git a/algebraic-structures.egg b/algebraic-structures.egg index ba4fd46..5e7eba3 100644 --- a/algebraic-structures.egg +++ b/algebraic-structures.egg @@ -18,4 +18,20 @@ (extension algebraic-structures.functor) (extension algebraic-structures.applicative) (extension algebraic-structures.monad) - (extension algebraic-structures.alternative))) + (extension algebraic-structures.alternative) + + ;; List + (extension algebraic-structures.private.list) + (extension algebraic-structures.list.semigroup) + (extension algebraic-structures.list.monoid) + (extension algebraic-structures.list.foldable) + (extension algebraic-structures.list.reducible) + (extension algebraic-structures.list.functor) + (extension algebraic-structures.private.list.zip.applicative) + (extension algebraic-structures.list.zip.applicative) + (extension algebraic-structures.private.list.applicative) + (extension algebraic-structures.list.applicative) + (extension algebraic-structures.private.list.monad) + (extension algebraic-structures.list.monad) + (extension algebraic-structures.private.list.alternative) + (extension algebraic-structures.list.alternative))) diff --git a/algebraic-structures.list.alternative.scm b/algebraic-structures.list.alternative.scm new file mode 100644 index 0000000..2804d61 --- /dev/null +++ b/algebraic-structures.list.alternative.scm @@ -0,0 +1,4 @@ +(import (algebraic-structures alternative) + (only (algebraic-structures private list alternative))) +(module (algebraic-structures list alternative) = ((algebraic-structures alternative) + (algebraic-structures private list alternative))) diff --git a/algebraic-structures.list.applicative.scm b/algebraic-structures.list.applicative.scm new file mode 100644 index 0000000..5165e96 --- /dev/null +++ b/algebraic-structures.list.applicative.scm @@ -0,0 +1,4 @@ +(import (algebraic-structures applicative) + (only (algebraic-structures private list applicative))) +(module (algebraic-structures list applicative) = ((algebraic-structures applicative) + (algebraic-structures private list applicative))) diff --git a/algebraic-structures.list.foldable.scm b/algebraic-structures.list.foldable.scm new file mode 100644 index 0000000..5150f9b --- /dev/null +++ b/algebraic-structures.list.foldable.scm @@ -0,0 +1,3 @@ +(import (algebraic-structures foldable) + (only (algebraic-structures private list))) +(module (algebraic-structures list foldable) = ((algebraic-structures foldable) (algebraic-structures private list))) diff --git a/algebraic-structures.list.functor.scm b/algebraic-structures.list.functor.scm new file mode 100644 index 0000000..a9707f2 --- /dev/null +++ b/algebraic-structures.list.functor.scm @@ -0,0 +1,3 @@ +(import (algebraic-structures functor) + (only (algebraic-structures private list))) +(module (algebraic-structures list functor) = ((algebraic-structures functor) (algebraic-structures private list))) diff --git a/algebraic-structures.list.monad.scm b/algebraic-structures.list.monad.scm new file mode 100644 index 0000000..ebf142f --- /dev/null +++ b/algebraic-structures.list.monad.scm @@ -0,0 +1,4 @@ +(import (algebraic-structures monad) + (only (algebraic-structures private list monad))) +(module (algebraic-structures list monad) = ((algebraic-structures monad) + (algebraic-structures private list monad))) diff --git a/algebraic-structures.list.monoid.scm b/algebraic-structures.list.monoid.scm new file mode 100644 index 0000000..87e6119 --- /dev/null +++ b/algebraic-structures.list.monoid.scm @@ -0,0 +1,3 @@ +(import (algebraic-structures monoid) + (only (algebraic-structures private list))) +(module (algebraic-structures list monoid) = ((algebraic-structures monoid) (algebraic-structures private list))) diff --git a/algebraic-structures.list.reducible.scm b/algebraic-structures.list.reducible.scm new file mode 100644 index 0000000..b98cfd7 --- /dev/null +++ b/algebraic-structures.list.reducible.scm @@ -0,0 +1,3 @@ +(import (algebraic-structures reducible) + (only (algebraic-structures private list))) +(module (algebraic-structures list reducible) = ((algebraic-structures reducible) (algebraic-structures private list))) diff --git a/algebraic-structures.list.semigroup.scm b/algebraic-structures.list.semigroup.scm new file mode 100644 index 0000000..eac0c5e --- /dev/null +++ b/algebraic-structures.list.semigroup.scm @@ -0,0 +1,3 @@ +(import (algebraic-structures semigroup) + (only (algebraic-structures private list))) +(module (algebraic-structures list semigroup) = ((algebraic-structures semigroup) (algebraic-structures private list))) diff --git a/algebraic-structures.list.zip.applicative.scm b/algebraic-structures.list.zip.applicative.scm new file mode 100644 index 0000000..c72a8ec --- /dev/null +++ b/algebraic-structures.list.zip.applicative.scm @@ -0,0 +1,4 @@ +(import (algebraic-structures applicative) + (only (algebraic-structures private list zip applicative))) +(module (algebraic-structures list zip applicative) = ((algebraic-structures applicative) + (algebraic-structures private list zip applicative))) diff --git a/algebraic-structures.private.list.alternative.scm b/algebraic-structures.private.list.alternative.scm new file mode 100644 index 0000000..a386e81 --- /dev/null +++ b/algebraic-structures.private.list.alternative.scm @@ -0,0 +1,9 @@ +(module (algebraic-structures private list alternative) (alt empty) + (import (except scheme map apply) + (chicken module)) + (reexport (algebraic-structures list applicative)) + + (define empty '()) + + (define (alt xs ys) + (append xs ys))) diff --git a/algebraic-structures.private.list.applicative.scm b/algebraic-structures.private.list.applicative.scm new file mode 100644 index 0000000..6bbfad7 --- /dev/null +++ b/algebraic-structures.private.list.applicative.scm @@ -0,0 +1,30 @@ +(module (algebraic-structures private list applicative) () + (import scheme + (only (srfi 1) append! reverse!) + (only (chicken base) assert cut) + (only matchable match) + (chicken module)) + (export pure map2) + (reexport (algebraic-structures list functor)) + + (define (pure x) (list x)) + + (define (rev-map f lst) + (let loop ((lst lst) + (acc '())) + (match lst + [() acc] + [(h . t) + (loop t (cons (f h) acc))]))) + + (define (product op lst1 lst2) + (let loop ((lst lst1) + (acc '())) + (match lst + [() (reverse! acc)] + [(h . t) + (loop t + (append! (rev-map (cut op h <>) lst2) + acc))]))) + + (define map2 product)) diff --git a/algebraic-structures.private.list.monad.scm b/algebraic-structures.private.list.monad.scm new file mode 100644 index 0000000..96da332 --- /dev/null +++ b/algebraic-structures.private.list.monad.scm @@ -0,0 +1,8 @@ +(module (algebraic-structures private list monad) (>>=) + (import (except scheme map apply) + (chicken module) + (only (srfi 1) append-map)) + (reexport (algebraic-structures list applicative)) + + (define (>>= xs f) + (append-map f xs))) diff --git a/algebraic-structures.private.list.scm b/algebraic-structures.private.list.scm new file mode 100644 index 0000000..4710b40 --- /dev/null +++ b/algebraic-structures.private.list.scm @@ -0,0 +1,19 @@ +(module (algebraic-structures private list) (<> unit fold reduce map1) + (import scheme + (rename (only (srfi 1) fold reduce) + (fold srfi:fold) + (reduce srfi:reduce)) + (only (chicken base) assert)) + + (define <> append) + + (define unit '()) + + (define fold srfi:fold) + + (define (reduce f xs) + (assert (not (null? xs))) + (srfi:reduce f #f xs)) + + (define (map1 f xs) + (map f xs))) diff --git a/algebraic-structures.private.list.zip.applicative.scm b/algebraic-structures.private.list.zip.applicative.scm new file mode 100644 index 0000000..8713ef9 --- /dev/null +++ b/algebraic-structures.private.list.zip.applicative.scm @@ -0,0 +1,14 @@ +(module (algebraic-structures private list zip applicative) () + (import scheme + (rename (only (srfi 1) fold reduce) + (fold srfi:fold) + (reduce srfi:reduce)) + (only (chicken base) assert) + (chicken module)) + (export pure map2) + (reexport (algebraic-structures list functor)) + + (define (pure x) (list x)) + + (define (map2 f xs ys) + (map f xs ys))) diff --git a/tests/run.scm b/tests/run.scm index 8195ea8..eac7569 100644 --- a/tests/run.scm +++ b/tests/run.scm @@ -83,13 +83,7 @@ (test-begin "foldable") -(import (algebraic-structures foldable)) - -(module (data list foldable) = (algebraic-structures foldable) - (import (chicken module)) - (reexport (only (srfi 1) fold))) - -(import (prefix (data list foldable) list:)) +(import (prefix (algebraic-structures list foldable) list:)) (test '(e d c b a) (list:fold cons '() '(a b c d e))) @@ -116,20 +110,7 @@ (test-begin "reducible") -(module (data list reducible) = (algebraic-structures reducible) - (import scheme - (algebraic-structures reducible) - (rename (srfi 1) (reduce srfi:reduce)) - (only (chicken base) assert) - (chicken module)) - (export reduce) - - (define (reduce f xs) - (assert (list? xs)) - (assert (not (null? xs))) - (srfi:reduce f #f xs))) - -(import (prefix (data list reducible) list:)) +(import (prefix (algebraic-structures list reducible) list:)) (test 10 (list:reduce + '(1 2 3 4))) (test -3 (list:minimum '(1 8 -3 5 4) <)) @@ -149,7 +130,9 @@ (+ x y))) (import (algebraic-structures semigroup reduce)) -(module (sum reduce) = ((algebraic-structures semigroup reduce) (sum semigroup) (data list reducible))) +(module (sum reduce) = ((algebraic-structures semigroup reduce) + (sum semigroup) + (algebraic-structures list reducible))) (import (prefix (sum reduce) sum:)) @@ -182,7 +165,9 @@ (define unit 1)) (import (algebraic-structures monoid fold)) -(module (product fold) = ((algebraic-structures monoid fold) (product monoid) (data list foldable))) +(module (product fold) = ((algebraic-structures monoid fold) + (product monoid) + (algebraic-structures list foldable))) (import (prefix (product monoid) product:)) (import (prefix (product fold) product:)) @@ -196,12 +181,7 @@ (test-begin "functor") -(import (algebraic-structures functor)) -(module (data list functor) = (algebraic-structures functor) - (import (chicken module)) - (reexport (rename scheme (map map1)))) - -(import (prefix (data list functor) list:)) +(import (prefix (algebraic-structures list functor) list:)) (test '((a) (b) (c)) (list:map1 list '(a b c))) @@ -209,41 +189,7 @@ (test-begin "applicative") -(import (algebraic-structures applicative)) -(module (data list applicative) = (algebraic-structures applicative) - (import (except scheme map) - (chicken module) - (srfi 1) - matchable - (chicken base) - (data list functor)) - (reexport (data list functor)) - (export pure map2) - - (define (pure x) - (list x)) - - (define (rev-map f lst) - (let loop ((lst lst) - (acc '())) - (match lst - [() acc] - [(h . t) - (loop t (cons (f h) acc))]))) - - (define (product op lst1 lst2) - (let loop ((lst lst1) - (acc '())) - (match lst - [() (reverse! acc)] - [(h . t) - (loop t - (append! (rev-map (cut op h <>) lst2) - acc))]))) - - (define map2 product)) - -(import (prefix (data list applicative) list:)) +(import (prefix (algebraic-structures list applicative) list:)) (test '(a) (list:pure 'a)) @@ -253,22 +199,22 @@ (test '((a 1 z) (a 2 z) (b 1 z) (b 2 z) (c 1 z) (c 2 z)) (list:map list '(a b c) '(1 2) '(z))) -(test-end "applicative") +(test-begin "list.zip") -(test-begin "monad") +(import (prefix (algebraic-structures list zip applicative) list-zip:)) -(import (algebraic-structures monad)) -(module (data list monad) = (algebraic-structures monad) - (import scheme - (chicken module) - (srfi 1)) - (reexport (data list applicative)) - (export >>=) +(test '(a) (list:pure 'a)) + +(test '((a 1) (b 2)) + (list-zip:map2 list '(a b c) '(1 2))) + +(test-end "list.zip") + +(test-end "applicative") - (define (>>= lst f) - (append-map f lst))) +(test-begin "monad") -(import (prefix (data list monad) list:)) +(import (prefix (algebraic-structures list monad) list:)) (test '((1 a) (2 a)) (list:>>= (list:pure 'a) @@ -287,21 +233,7 @@ (test-begin "alternative") -(import (algebraic-structures alternative)) -(module (data list alternative) = (algebraic-structures alternative) - (import (except scheme map) - (chicken module) - (chicken base) - (data list applicative)) - (reexport (data list applicative)) - (export alt empty) - - (define (alt x y) - (append x y)) - - (define empty '())) - -(import (prefix (data list alternative) list:)) +(import (prefix (algebraic-structures list alternative) list:)) (test '(9 25) (list:do (x <- '(2 3 4 5)) |