diff options
Diffstat (limited to 'stdlib/source/lux/abstract')
| -rw-r--r-- | stdlib/source/lux/abstract/algebra.lux | 17 | ||||
| -rw-r--r-- | stdlib/source/lux/abstract/apply.lux | 36 | ||||
| -rw-r--r-- | stdlib/source/lux/abstract/codec.lux | 27 | ||||
| -rw-r--r-- | stdlib/source/lux/abstract/comonad.lux | 62 | ||||
| -rw-r--r-- | stdlib/source/lux/abstract/enum.lux | 21 | ||||
| -rw-r--r-- | stdlib/source/lux/abstract/equivalence.lux | 42 | ||||
| -rw-r--r-- | stdlib/source/lux/abstract/fold.lux | 18 | ||||
| -rw-r--r-- | stdlib/source/lux/abstract/functor.lux | 32 | ||||
| -rw-r--r-- | stdlib/source/lux/abstract/hash.lux | 13 | ||||
| -rw-r--r-- | stdlib/source/lux/abstract/interval.lux | 184 | ||||
| -rw-r--r-- | stdlib/source/lux/abstract/monad.lux | 168 | ||||
| -rw-r--r-- | stdlib/source/lux/abstract/monad/free.lux | 67 | ||||
| -rw-r--r-- | stdlib/source/lux/abstract/monad/indexed.lux | 64 | ||||
| -rw-r--r-- | stdlib/source/lux/abstract/monoid.lux | 19 | ||||
| -rw-r--r-- | stdlib/source/lux/abstract/number.lux | 14 | ||||
| -rw-r--r-- | stdlib/source/lux/abstract/order.lux | 59 | ||||
| -rw-r--r-- | stdlib/source/lux/abstract/predicate.lux | 57 |
17 files changed, 900 insertions, 0 deletions
diff --git a/stdlib/source/lux/abstract/algebra.lux b/stdlib/source/lux/abstract/algebra.lux new file mode 100644 index 000000000..2813ed0e7 --- /dev/null +++ b/stdlib/source/lux/abstract/algebra.lux @@ -0,0 +1,17 @@ +(.module: + [lux #* + [control + functor]]) + +## Types +(type: #export (Algebra f a) + (-> (f a) a)) + +(type: #export (CoAlgebra f a) + (-> a (f a))) + +(type: #export (RAlgebra f a) + (-> (f (& (Fix f) a)) a)) + +(type: #export (RCoAlgebra f a) + (-> a (f (| (Fix f) a)))) diff --git a/stdlib/source/lux/abstract/apply.lux b/stdlib/source/lux/abstract/apply.lux new file mode 100644 index 000000000..5eb42b63d --- /dev/null +++ b/stdlib/source/lux/abstract/apply.lux @@ -0,0 +1,36 @@ +(.module: + lux + [// + ["." functor (#+ Functor)] + [monad (#+ Monad)]]) + +(signature: #export (Apply f) + {#.doc "Applicative functors."} + (: (Functor f) + &functor) + (: (All [a b] + (-> (f (-> a b)) (f a) (f b))) + apply)) + +(structure: #export (compose f-monad f-apply g-apply) + {#.doc "Applicative functor composition."} + (All [F G] + (-> (Monad F) (Apply F) (Apply G) + ## TODO: Replace (All [a] (F (G a))) with (functor.Then F G) + (Apply (All [a] (F (G a)))))) + + (def: &functor (functor.compose (get@ #&functor f-apply) (get@ #&functor g-apply))) + + (def: (apply fgf fgx) + ## TODO: Switch from this version to the one below (in comments) ASAP. + (let [fgf' (:: f-apply apply + (:: f-monad wrap (:: g-apply apply)) + fgf)] + (:: f-apply apply fgf' fgx)) + ## (let [applyF (:: f-apply apply) + ## applyG (:: g-apply apply)] + ## ($_ applyF + ## (:: f-monad wrap applyG) + ## fgf + ## fgx)) + )) diff --git a/stdlib/source/lux/abstract/codec.lux b/stdlib/source/lux/abstract/codec.lux new file mode 100644 index 000000000..abe80ba4a --- /dev/null +++ b/stdlib/source/lux/abstract/codec.lux @@ -0,0 +1,27 @@ +(.module: + [lux #* + [data + ["." error (#+ Error)]]] + [// + monad]) + +(signature: #export (Codec m a) + {#.doc "A way to move back-and-forth between a type and an alternative representation for it."} + (: (-> a m) + encode) + (: (-> m (Error a)) + decode)) + +(structure: #export (compose cb-codec ba-codec) + {#.doc "Codec composition."} + (All [a b c] + (-> (Codec c b) (Codec b a) + (Codec c a))) + (def: encode + (|>> (:: ba-codec encode) + (:: cb-codec encode))) + + (def: (decode cy) + (do error.monad + [by (:: cb-codec decode cy)] + (:: ba-codec decode by)))) diff --git a/stdlib/source/lux/abstract/comonad.lux b/stdlib/source/lux/abstract/comonad.lux new file mode 100644 index 000000000..1d6ac49e5 --- /dev/null +++ b/stdlib/source/lux/abstract/comonad.lux @@ -0,0 +1,62 @@ +(.module: + [lux #* + [data + [collection + ["." list ("#;." fold)]]]] + [// + ["." functor (#+ Functor)]]) + +(signature: #export (CoMonad w) + {#.doc (doc "CoMonads are the opposite/complement to monads." + "CoMonadic structures are often infinite in size and built upon lazily-evaluated functions.")} + (: (Functor w) + &functor) + (: (All [a] + (-> (w a) a)) + unwrap) + (: (All [a] + (-> (w a) (w (w a)))) + split)) + +(type: #export (CoFree F a) + {#.doc "The CoFree CoMonad."} + [a (F (CoFree F a))]) + +(def: _cursor Cursor ["" 0 0]) + +(macro: #export (be tokens state) + {#.doc (doc "A co-monadic parallel to the 'do' macro." + (let [square (function (_ n) (i/* n n))] + (be comonad + [inputs (iterate inc +2)] + (square (head inputs)))))} + (case tokens + (#.Cons comonad (#.Cons [_ (#.Tuple bindings)] (#.Cons body #.Nil))) + (if (|> bindings list.size (n/% 2) (n/= 0)) + (let [g!_ (: Code [_cursor (#.Identifier ["" " _ "])]) + g!map (: Code [_cursor (#.Identifier ["" " map "])]) + g!split (: Code [_cursor (#.Identifier ["" " split "])]) + body' (list;fold (: (-> [Code Code] Code Code) + (function (_ binding body') + (let [[var value] binding] + (case var + [_ (#.Tag ["" "let"])] + (` (let (~ value) (~ body'))) + + _ + (` (|> (~ value) (~ g!split) ((~ g!map) (function ((~ g!_) (~ var)) (~ body'))))) + )))) + body + (list.reverse (list.as-pairs bindings)))] + (#.Right [state (#.Cons (` ({(~' @) + ({{#&functor {#functor.map (~ g!map)} + #unwrap (~' unwrap) + #split (~ g!split)} + (~ body')} + (~' @))} + (~ comonad))) + #.Nil)])) + (#.Left "'be' bindings must have an even number of parts.")) + + _ + (#.Left "Wrong syntax for 'be'"))) diff --git a/stdlib/source/lux/abstract/enum.lux b/stdlib/source/lux/abstract/enum.lux new file mode 100644 index 000000000..5bbb7df38 --- /dev/null +++ b/stdlib/source/lux/abstract/enum.lux @@ -0,0 +1,21 @@ +(.module: + [lux #*] + [// + ["." order]]) + +(signature: #export (Enum e) + {#.doc "Enumerable types, with a notion of moving forward and backwards through a type's instances."} + (: (order.Order e) &order) + (: (-> e e) succ) + (: (-> e e) pred)) + +(def: (range' <= succ from to) + (All [a] (-> (-> a a Bit) (-> a a) a a (List a))) + (if (<= to from) + (#.Cons from (range' <= succ (succ from) to)) + #.Nil)) + +(def: #export (range (^open ".") from to) + {#.doc "An inclusive [from, to] range of values."} + (All [a] (-> (Enum a) a a (List a))) + (range' <= succ from to)) diff --git a/stdlib/source/lux/abstract/equivalence.lux b/stdlib/source/lux/abstract/equivalence.lux new file mode 100644 index 000000000..b773505de --- /dev/null +++ b/stdlib/source/lux/abstract/equivalence.lux @@ -0,0 +1,42 @@ +(.module: + [lux #*] + [// + [functor (#+ Contravariant)]]) + +(signature: #export (Equivalence a) + {#.doc "Equivalence for a type's instances."} + (: (-> a a Bit) + =)) + +(def: #export (product left right) + (All [l r] (-> (Equivalence l) (Equivalence r) (Equivalence [l r]))) + (structure + (def: (= [a b] [x y]) + (and (:: left = a x) + (:: right = b y))))) + +(def: #export (sum left right) + (All [l r] (-> (Equivalence l) (Equivalence r) (Equivalence (| l r)))) + (structure + (def: (= a|b x|y) + (case [a|b x|y] + [(0 a) (0 x)] + (:: left = a x) + + [(1 b) (1 y)] + (:: right = b y) + + _ + #0)))) + +(def: #export (rec sub) + (All [a] (-> (-> (Equivalence a) (Equivalence a)) (Equivalence a))) + (structure + (def: (= left right) + (sub (rec sub) left right)))) + +(structure: #export contravariant (Contravariant Equivalence) + (def: (map-1 f equivalence) + (structure + (def: (= reference sample) + (:: equivalence = (f reference) (f sample)))))) diff --git a/stdlib/source/lux/abstract/fold.lux b/stdlib/source/lux/abstract/fold.lux new file mode 100644 index 000000000..504f41f58 --- /dev/null +++ b/stdlib/source/lux/abstract/fold.lux @@ -0,0 +1,18 @@ +(.module: + [lux #*] + [// + [monoid (#+ Monoid)]]) + +(signature: #export (Fold F) + {#.doc "Iterate over a structure's values to build a summary value."} + (: (All [a b] + (-> (-> b a a) a (F b) a)) + fold)) + +(def: #export (with-monoid monoid fold value) + (All [F a] + (-> (Monoid a) (Fold F) (F a) a)) + (let [(^open "monoid;.") monoid] + (fold monoid;compose + monoid;identity + value))) diff --git a/stdlib/source/lux/abstract/functor.lux b/stdlib/source/lux/abstract/functor.lux new file mode 100644 index 000000000..1ade0a45b --- /dev/null +++ b/stdlib/source/lux/abstract/functor.lux @@ -0,0 +1,32 @@ +(.module: lux) + +(signature: #export (Functor f) + (: (All [a b] + (-> (-> a b) + (-> (f a) (f b)))) + map)) + +(type: #export (Fix f) + (f (Fix f))) + +(type: #export (And f g) + (All [a] (& (f a) (g a)))) + +(type: #export (Or f g) + (All [a] (| (f a) (g a)))) + +(type: #export (Then f g) + (All [a] (f (g a)))) + +(def: #export (compose f-functor g-functor) + {#.doc "Functor composition."} + (All [F G] (-> (Functor F) (Functor G) (Functor (..Then F G)))) + (structure + (def: (map f fga) + (:: f-functor map (:: g-functor map f) fga)))) + +(signature: #export (Contravariant f) + (: (All [a b] + (-> (-> b a) + (-> (f a) (f b)))) + map-1)) diff --git a/stdlib/source/lux/abstract/hash.lux b/stdlib/source/lux/abstract/hash.lux new file mode 100644 index 000000000..d2dee3bcb --- /dev/null +++ b/stdlib/source/lux/abstract/hash.lux @@ -0,0 +1,13 @@ +(.module: + lux + [// + [equivalence (#+ Equivalence)]]) + +## [Signatures] +(signature: #export (Hash a) + {#.doc (doc "A way to produce hash-codes for a type's instances." + "A necessity when working with some data-structures, such as dictionaries or sets.")} + (: (Equivalence a) + &equivalence) + (: (-> a Nat) + hash)) diff --git a/stdlib/source/lux/abstract/interval.lux b/stdlib/source/lux/abstract/interval.lux new file mode 100644 index 000000000..efb131843 --- /dev/null +++ b/stdlib/source/lux/abstract/interval.lux @@ -0,0 +1,184 @@ +(.module: + [lux #*] + [// + [equivalence (#+ Equivalence)] + ["." order] + [enum (#+ Enum)]]) + +(signature: #export (Interval a) + {#.doc "A representation of top and bottom boundaries for an ordered type."} + (: (Enum a) + &enum) + + (: a + bottom) + + (: a + top)) + +(def: #export (between enum bottom top) + (All [a] (-> (Enum a) a a (Interval a))) + (structure (def: &enum enum) + (def: bottom bottom) + (def: top top))) + +(def: #export (singleton enum elem) + (All [a] (-> (Enum a) a (Interval a))) + (structure (def: &enum enum) + (def: bottom elem) + (def: top elem))) + +(template [<name> <comp>] + [(def: #export (<name> interval) + (All [a] (-> (Interval a) Bit)) + (let [(^open ".") interval] + (<comp> bottom top)))] + + [inner? >] + [outer? <] + [singleton? =] + ) + +(def: #export (within? interval elem) + (All [a] (-> (Interval a) a Bit)) + (let [(^open ".") interval] + (cond (inner? interval) + (and (>= bottom elem) + (<= top elem)) + + (outer? interval) + (or (>= bottom elem) + (<= top elem)) + + ## singleton + (and (= bottom elem) + (= top elem))))) + +(template [<name> <limit>] + [(def: #export (<name> elem interval) + (All [a] (-> a (Interval a) Bit)) + (let [(^open ".") interval] + (= <limit> elem)))] + + [starts-with? bottom] + [ends-with? top] + ) + +(def: #export (borders? interval elem) + (All [a] (-> (Interval a) a Bit)) + (or (starts-with? elem interval) + (ends-with? elem interval))) + +(def: #export (union left right) + (All [a] (-> (Interval a) (Interval a) (Interval a))) + (structure (def: &enum (get@ #&enum right)) + (def: bottom (order.min (:: right &order) (:: left bottom) (:: right bottom))) + (def: top (order.max (:: right &order) (:: left top) (:: right top))))) + +(def: #export (intersection left right) + (All [a] (-> (Interval a) (Interval a) (Interval a))) + (structure (def: &enum (get@ #&enum right)) + (def: bottom (order.max (:: right &order) (:: left bottom) (:: right bottom))) + (def: top (order.min (:: right &order) (:: left top) (:: right top))))) + +(def: #export (complement interval) + (All [a] (-> (Interval a) (Interval a))) + (let [(^open ".") interval] + (structure (def: &enum (get@ #&enum interval)) + (def: bottom (succ top)) + (def: top (pred bottom))))) + +(def: #export (precedes? reference sample) + (All [a] (-> (Interval a) (Interval a) Bit)) + (let [(^open ".") reference + limit (:: reference bottom)] + (and (< limit (:: sample bottom)) + (< limit (:: sample top))))) + +(def: #export (succeeds? reference sample) + (All [a] (-> (Interval a) (Interval a) Bit)) + (precedes? sample reference)) + +(def: #export (meets? reference sample) + (All [a] (-> (Interval a) (Interval a) Bit)) + (let [(^open ".") reference + limit (:: reference bottom)] + (and (<= limit (:: sample bottom)) + (= limit (:: sample top))))) + +(def: #export (touches? reference sample) + (All [a] (-> (Interval a) (Interval a) Bit)) + (or (meets? reference sample) + (meets? sample reference))) + +(template [<name> <eq-side> <ineq> <ineq-side>] + [(def: #export (<name> reference sample) + (All [a] (-> (Interval a) (Interval a) Bit)) + (let [(^open ".") reference] + (and (= (:: reference <eq-side>) (:: sample <eq-side>)) + (<ineq> (:: reference <ineq-side>) (:: sample <ineq-side>)))))] + + [starts? bottom <= top] + [finishes? top >= bottom] + ) + +(template [<name> <comp>] + [(def: #export (<name> reference sample) + (All [a] (-> a (Interval a) Bit)) + (let [(^open ".") sample] + (and (<comp> reference bottom) + (<comp> reference top))))] + + [before? <] + [after? >] + ) + +(structure: #export equivalence (All [a] (Equivalence (Interval a))) + (def: (= reference sample) + (let [(^open "_;.") reference] + (and (_;= _;bottom (:: sample bottom)) + (_;= _;top (:: sample top)))))) + +(def: #export (nested? reference sample) + (All [a] (-> (Interval a) (Interval a) Bit)) + (cond (or (singleton? sample) + (and (inner? reference) (inner? sample)) + (and (outer? reference) (outer? sample))) + (let [(^open ".") reference] + (and (>= (:: reference bottom) (:: sample bottom)) + (<= (:: reference top) (:: sample top)))) + + (or (singleton? reference) + (and (inner? reference) (outer? sample))) + #0 + + ## (and (outer? reference) (inner? sample)) + (let [(^open ".") reference] + (or (and (>= (:: reference bottom) (:: sample bottom)) + (> (:: reference bottom) (:: sample top))) + (and (< (:: reference top) (:: sample bottom)) + (<= (:: reference top) (:: sample top))))) + )) + +(def: #export (overlaps? reference sample) + (All [a] (-> (Interval a) (Interval a) Bit)) + (let [(^open ".") reference] + (and (not (:: ..equivalence = reference sample)) + (cond (singleton? sample) + #0 + + (singleton? reference) + (nested? sample reference) + + (or (and (inner? sample) (outer? reference)) + (and (outer? sample) (inner? reference))) + (or (>= (:: reference bottom) (:: sample top)) + (<= (:: reference top) (:: sample bottom))) + + ## both inner + (inner? sample) + (inner? (intersection reference sample)) + + ## both outer + (not (nested? reference sample)) + )))) diff --git a/stdlib/source/lux/abstract/monad.lux b/stdlib/source/lux/abstract/monad.lux new file mode 100644 index 000000000..0e509c64e --- /dev/null +++ b/stdlib/source/lux/abstract/monad.lux @@ -0,0 +1,168 @@ +(.module: + [lux #*] + [// + ["." functor (#+ Functor)]]) + +(def: (list;fold f init xs) + (All [a b] + (-> (-> b a a) a (List b) a)) + (case xs + #.Nil + init + + (#.Cons x xs') + (list;fold f (f x init) xs'))) + +(def: (list;size xs) + (All [a] (-> (List a) Nat)) + (loop [counter 0 + xs xs] + (case xs + #.Nil + counter + + (#.Cons _ xs') + (recur (inc counter) xs')))) + +(def: (reverse xs) + (All [a] + (-> (List a) (List a))) + (list;fold (function (_ head tail) (#.Cons head tail)) + #.Nil + xs)) + +(def: (as-pairs xs) + (All [a] (-> (List a) (List [a a]))) + (case xs + (#.Cons x1 (#.Cons x2 xs')) + (#.Cons [x1 x2] (as-pairs xs')) + + _ + #.Nil)) + +(signature: #export (Monad m) + (: (Functor m) + &functor) + (: (All [a] + (-> a (m a))) + wrap) + (: (All [a] + (-> (m (m a)) (m a))) + join)) + +(def: _cursor Cursor ["" 0 0]) + +(macro: #export (do tokens state) + {#.doc (doc "Macro for easy concatenation of monadic operations." + (do monad + [y (f1 x) + z (f2 z)] + (wrap (f3 z))))} + (case tokens + (#.Cons monad (#.Cons [_ (#.Tuple bindings)] (#.Cons body #.Nil))) + (if (|> bindings list;size (n/% 2) (n/= 0)) + (let [g!_ (: Code [_cursor (#.Identifier ["" " _ "])]) + g!map (: Code [_cursor (#.Identifier ["" " map "])]) + g!join (: Code [_cursor (#.Identifier ["" " join "])]) + body' (list;fold (: (-> [Code Code] Code Code) + (function (_ binding body') + (let [[var value] binding] + (case var + [_ (#.Tag ["" "let"])] + (` (let (~ value) (~ body'))) + + _ + (` (|> (~ value) ((~ g!map) (function ((~ g!_) (~ var)) (~ body'))) (~ g!join))) + )))) + body + (reverse (as-pairs bindings)))] + (#.Right [state (#.Cons (` ({(~' @) + ({{#..&functor {#functor.map (~ g!map)} + #..wrap (~' wrap) + #..join (~ g!join)} + (~ body')} + (~' @))} + (~ monad))) + #.Nil)])) + (#.Left "'do' bindings must have an even number of parts.")) + + _ + (#.Left "Wrong syntax for 'do'"))) + +(def: #export (seq monad) + {#.doc "Run all the monadic values in the list and produce a list of the base values."} + (All [M a] + (-> (Monad M) (List (M a)) + (M (List a)))) + (let [(^open "!;.") monad] + (function (recur xs) + (case xs + #.Nil + (!;wrap #.Nil) + + (#.Cons x xs') + (|> x + (!;map (function (_ _x) + (!;map (|>> (#.Cons _x)) (recur xs')))) + !;join))))) + +(def: #export (map monad f) + {#.doc "Apply a monadic function to all values in a list."} + (All [M a b] + (-> (Monad M) (-> a (M b)) (List a) + (M (List b)))) + (let [(^open "!;.") monad] + (function (recur xs) + (case xs + #.Nil + (!;wrap #.Nil) + + (#.Cons x xs') + (|> (f x) + (!;map (function (_ _x) + (!;map (|>> (#.Cons _x)) (recur xs')))) + !;join))))) + +(def: #export (filter Monad<!> f) + {#.doc "Filter the values in a list with a monadic function."} + (All [! a b] + (-> (Monad !) (-> a (! Bit)) (List a) + (! (List a)))) + (let [(^open "!;.") Monad<!>] + (function (recur xs) + (case xs + #.Nil + (!;wrap #.Nil) + + (#.Cons head xs') + (|> (f head) + (!;map (function (_ verdict) + (!;map (function (_ tail) + (if verdict + (#.Cons head tail) + tail)) + (recur xs')))) + !;join))))) + +(def: #export (fold monad f init xs) + {#.doc "Fold a list with a monadic function."} + (All [M a b] + (-> (Monad M) (-> b a (M a)) a (List b) + (M a))) + (case xs + #.Nil + (:: monad wrap init) + + (#.Cons x xs') + (do monad + [init' (f x init)] + (fold monad f init' xs')))) + +(def: #export (lift monad f) + {#.doc "Lift a normal function into the space of monads."} + (All [M a b] + (-> (Monad M) (-> a b) (-> (M a) (M b)))) + (function (_ ma) + (do monad + [a ma] + (wrap (f a))))) diff --git a/stdlib/source/lux/abstract/monad/free.lux b/stdlib/source/lux/abstract/monad/free.lux new file mode 100644 index 000000000..214261450 --- /dev/null +++ b/stdlib/source/lux/abstract/monad/free.lux @@ -0,0 +1,67 @@ +(.module: + lux + [/// + [functor (#+ Functor)] + [apply (#+ Apply)] + [monad (#+ Monad)]]) + +(type: #export (Free F a) + {#.doc "The Free Monad."} + (#Pure a) + (#Effect (F (Free F a)))) + +(structure: #export (functor dsl) + (All [F] (-> (Functor F) (Functor (Free F)))) + + (def: (map f ea) + (case ea + (#Pure a) + (#Pure (f a)) + + (#Effect value) + (#Effect (:: dsl map (map f) value))))) + +(structure: #export (apply dsl) + (All [F] (-> (Functor F) (Apply (Free F)))) + + (def: &functor (..functor dsl)) + + (def: (apply ef ea) + (case [ef ea] + [(#Pure f) (#Pure a)] + (#Pure (f a)) + + [(#Pure f) (#Effect fa)] + (#Effect (:: dsl map + (:: (..functor dsl) map f) + fa)) + + [(#Effect ff) _] + (#Effect (:: dsl map + (function (_ f) (apply f ea)) + ff)) + ))) + +(structure: #export (monad dsl) + (All [F] (-> (Functor F) (Monad (Free F)))) + + (def: &functor (..functor dsl)) + + (def: (wrap a) + (#Pure a)) + + (def: (join efefa) + (case efefa + (#Pure efa) + (case efa + (#Pure a) + (#Pure a) + + (#Effect fa) + (#Effect fa)) + + (#Effect fefa) + (#Effect (:: dsl map + (:: (monad dsl) join) + fefa)) + ))) diff --git a/stdlib/source/lux/abstract/monad/indexed.lux b/stdlib/source/lux/abstract/monad/indexed.lux new file mode 100644 index 000000000..57a18c109 --- /dev/null +++ b/stdlib/source/lux/abstract/monad/indexed.lux @@ -0,0 +1,64 @@ +(.module: + [lux #* + [control + [monad] + ["p" parser]] + [data + [collection + ["." list ("#;." functor fold)]]] + ["." macro + ["s" syntax (#+ Syntax syntax:)]]]) + +(signature: #export (IxMonad m) + (: (All [p a] + (-> a (m p p a))) + wrap) + + (: (All [ii it io vi vo] + (-> (-> vi (m it io vo)) + (m ii it vi) + (m ii io vo))) + bind)) + +(type: Binding [Code Code]) + +(def: binding + (Syntax Binding) + (p.and s.any s.any)) + +(type: Context + (#Let (List Binding)) + (#Bind Binding)) + +(def: context + (Syntax Context) + (p.or (p.after (s.this (' #let)) + (s.tuple (p.some binding))) + binding)) + +(def: (pair-list [binding value]) + (All [a] (-> [a a] (List a))) + (list binding value)) + +(syntax: #export (do monad + {context (s.tuple (p.some context))} + expression) + (macro.with-gensyms [g!_ g!bind] + (wrap (list (` (let [(~' @) (~ monad) + {#..wrap (~' wrap) + #..bind (~ g!bind)} (~' @)] + (~ (list;fold (function (_ context next) + (case context + (#Let bindings) + (` (let [(~+ (|> bindings + (list;map pair-list) + list.concat))] + (~ next))) + + (#Bind [binding value]) + (` ((~ g!bind) + (.function ((~ g!_) (~ binding)) + (~ next)) + (~ value))))) + expression + (list.reverse context))))))))) diff --git a/stdlib/source/lux/abstract/monoid.lux b/stdlib/source/lux/abstract/monoid.lux new file mode 100644 index 000000000..33d082020 --- /dev/null +++ b/stdlib/source/lux/abstract/monoid.lux @@ -0,0 +1,19 @@ +(.module: + [lux #*]) + +(signature: #export (Monoid a) + {#.doc (doc "A way to compose values." + "Includes an identity value which does not alter any other value when combined with.")} + (: a + identity) + (: (-> a a a) + compose)) + +(def: #export (compose Monoid<l> Monoid<r>) + (All [l r] (-> (Monoid l) (Monoid r) (Monoid [l r]))) + (structure (def: identity + [(:: Monoid<l> identity) (:: Monoid<r> identity)]) + + (def: (compose [lL rL] [lR rR]) + [(:: Monoid<l> compose lL lR) + (:: Monoid<r> compose rL rR)]))) diff --git a/stdlib/source/lux/abstract/number.lux b/stdlib/source/lux/abstract/number.lux new file mode 100644 index 000000000..b3a314ba5 --- /dev/null +++ b/stdlib/source/lux/abstract/number.lux @@ -0,0 +1,14 @@ +(.module: + lux) + +(`` (signature: #export (Number n) + {#.doc "Everything that should be expected of a number type."} + + (~~ (template [<name>] + [(: (-> n n n) <name>)] + [+] [-] [*] [/] [%])) + + (~~ (template [<name>] + [(: (-> n n) <name>)] + [negate] [signum] [abs])) + )) diff --git a/stdlib/source/lux/abstract/order.lux b/stdlib/source/lux/abstract/order.lux new file mode 100644 index 000000000..85b33fa18 --- /dev/null +++ b/stdlib/source/lux/abstract/order.lux @@ -0,0 +1,59 @@ +(.module: + [lux #* + function] + [// + [functor (#+ Contravariant)] + ["." equivalence (#+ Equivalence)]]) + +(`` (signature: #export (Order a) + {#.doc "A signature for types that possess some sense of ordering among their elements."} + + (: (Equivalence a) + &equivalence) + + (~~ (template [<name>] + [(: (-> a a Bit) <name>)] + + [<] [<=] [>] [>=] + )) + )) + +(def: #export (order equivalence <) + (All [a] + (-> (Equivalence a) (-> a a Bit) (Order a))) + (let [> (flip <)] + (structure (def: &equivalence equivalence) + + (def: < <) + + (def: (<= test subject) + (or (< test subject) + (:: equivalence = test subject))) + + (def: > >) + + (def: (>= test subject) + (or (> test subject) + (:: equivalence = test subject)))))) + +(template [<name> <op>] + [(def: #export (<name> order x y) + (All [a] + (-> (Order a) a a a)) + (if (:: order <op> y x) x y))] + + [min <] + [max >] + ) + +(`` (structure: #export contravariant (Contravariant Order) + (def: (map-1 f order) + (structure + (def: &equivalence (:: equivalence.contravariant map-1 f (:: order &equivalence))) + + (~~ (template [<name>] + [(def: (<name> reference sample) + (:: order <name> (f reference) (f sample)))] + + [<] [<=] [>] [>=] + )))))) diff --git a/stdlib/source/lux/abstract/predicate.lux b/stdlib/source/lux/abstract/predicate.lux new file mode 100644 index 000000000..faa1859b9 --- /dev/null +++ b/stdlib/source/lux/abstract/predicate.lux @@ -0,0 +1,57 @@ +(.module: + [lux #* + ["." function]] + [// + [monoid (#+ Monoid)] + [functor (#+ Contravariant)]]) + +(type: #export (Predicate a) + (-> a Bit)) + +(template [<identity-name> <identity-value> <composition-name> <composition>] + [(def: #export <identity-name> + (All [a] (Predicate a)) + (function.constant <identity-value>)) + + (def: #export (<composition-name> left right) + (All [a] (-> (Predicate a) (Predicate a) (Predicate a))) + (function (_ value) + (<composition> (left value) + (right value))))] + + [none #0 union or] + [all #1 intersection and] + ) + +(template [<name> <identity> <composition>] + [(structure: #export <name> + (All [a] (Monoid (Predicate a))) + + (def: identity <identity>) + (def: compose <composition>))] + + [Union@Monoid none union] + [Intersection@Monoid all intersection] + ) + +(def: #export (complement predicate) + (All [a] (-> (Predicate a) (Predicate a))) + (|>> predicate not)) + +(def: #export (difference sub base) + (All [a] (-> (Predicate a) (Predicate a) (Predicate a))) + (function (_ value) + (and (base value) + (not (sub value))))) + +(def: #export (rec predicate) + (All [a] + (-> (-> (Predicate a) (Predicate a)) + (Predicate a))) + (|>> (predicate (rec predicate)))) + +(structure: #export _ + (Contravariant Predicate) + + (def: (map-1 f fb) + (|>> f fb))) |