diff options
Diffstat (limited to 'stdlib/source/lux')
444 files changed, 0 insertions, 83296 deletions
diff --git a/stdlib/source/lux/abstract/algebra.lux b/stdlib/source/lux/abstract/algebra.lux deleted file mode 100644 index 14d29bf16..000000000 --- a/stdlib/source/lux/abstract/algebra.lux +++ /dev/null @@ -1,16 +0,0 @@ -(.module: - [lux #* - [control - [functor (#+ Fix)]]]) - -(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 deleted file mode 100644 index 6f0e61ba8..000000000 --- a/stdlib/source/lux/abstract/apply.lux +++ /dev/null @@ -1,36 +0,0 @@ -(.module: - [lux #*] - [// - [monad (#+ Monad)] - ["." functor (#+ Functor)]]) - -(interface: #export (Apply f) - {#.doc "Applicative functors."} - (: (Functor f) - &functor) - (: (All [a b] - (-> (f (-> a b)) (f a) (f b))) - apply)) - -(implementation: #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 deleted file mode 100644 index 454b64cb5..000000000 --- a/stdlib/source/lux/abstract/codec.lux +++ /dev/null @@ -1,28 +0,0 @@ -(.module: - [lux #* - [control - ["." try (#+ Try)]]] - [// - [monad (#+ do)] - ["." functor]]) - -(interface: #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 (Try a)) - decode)) - -(implementation: #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 try.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 deleted file mode 100644 index 63565bd3a..000000000 --- a/stdlib/source/lux/abstract/comonad.lux +++ /dev/null @@ -1,78 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." list ("#\." fold)]]] - [math - [number - ["n" nat]]] - [meta - ["." location]]] - [// - [functor (#+ Functor)]]) - -(interface: #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)) - -(macro: #export (be tokens state) - {#.doc (doc "A co-monadic parallel to the 'do' macro." - (let [square (function (_ n) (* n n))] - (be comonad - [inputs (iterate inc +2)] - (square (head inputs)))))} - (case (: (Maybe [(Maybe Text) Code (List Code) Code]) - (case tokens - (^ (list [_ (#.Record (list [[_ (#.Identifier ["" name])] comonad]))] [_ (#.Tuple bindings)] body)) - (#.Some [(#.Some name) comonad bindings body]) - - (^ (list comonad [_ (#.Tuple bindings)] body)) - (#.Some [#.None comonad bindings body]) - - _ - #.None)) - (#.Some [?name comonad bindings body]) - (if (|> bindings list.size (n.% 2) (n.= 0)) - (let [[module short] (name_of ..be) - gensym (: (-> Text Code) - (|>> ($_ "lux text concat" module " " short " ") [""] #.Identifier [location.dummy])) - g!_ (gensym "_") - g!map (gensym "map") - g!split (gensym "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 (list (case ?name - (#.Some name) - (let [name [location.dummy (#.Identifier ["" name])]] - (` ({(~ name) - ({[(~ g!map) (~' unwrap) (~ g!split)] - (~ body')} - (~ name))} - (~ comonad)))) - - #.None - (` ({[(~ g!map) (~' unwrap) (~ g!split)] - (~ body')} - (~ comonad)))))])) - (#.Left "'be' bindings must have an even number of parts.")) - - #.None - (#.Left "Wrong syntax for 'be'"))) diff --git a/stdlib/source/lux/abstract/comonad/cofree.lux b/stdlib/source/lux/abstract/comonad/cofree.lux deleted file mode 100644 index 64413f1ce..000000000 --- a/stdlib/source/lux/abstract/comonad/cofree.lux +++ /dev/null @@ -1,27 +0,0 @@ -(.module: - [lux #*] - [// (#+ CoMonad) - [// - [functor (#+ Functor)]]]) - -(type: #export (CoFree F a) - {#.doc "The CoFree CoMonad."} - [a (F (CoFree F a))]) - -(implementation: #export (functor dsl) - (All [F] (-> (Functor F) (Functor (CoFree F)))) - - (def: (map f [head tail]) - [(f head) (\ dsl map (map f) tail)])) - -(implementation: #export (comonad dsl) - (All [F] (-> (Functor F) (CoMonad (CoFree F)))) - - (def: &functor (..functor dsl)) - - (def: (unwrap [head tail]) - head) - - (def: (split [head tail]) - [[head tail] - (\ dsl map split tail)])) diff --git a/stdlib/source/lux/abstract/enum.lux b/stdlib/source/lux/abstract/enum.lux deleted file mode 100644 index d98848f78..000000000 --- a/stdlib/source/lux/abstract/enum.lux +++ /dev/null @@ -1,25 +0,0 @@ -(.module: - [lux #*] - [// - ["." order (#+ Order)]]) - -(interface: #export (Enum e) - {#.doc "Enumerable types, with a notion of moving forward and backwards through a type's instances."} - (: (Order e) &order) - (: (-> e e) succ) - (: (-> e e) pred)) - -(def: #export (range enum from to) - {#.doc "An inclusive [from, to] range of values."} - (All [a] (-> (Enum a) a a (List a))) - (let [(^open "/\.") enum] - (loop [end to - output #.Nil] - (cond (/\< end from) - (recur (/\pred end) (#.Cons end output)) - - (/\< from end) - (recur (/\succ end) (#.Cons end output)) - - ## (/\= end from) - (#.Cons end output))))) diff --git a/stdlib/source/lux/abstract/equivalence.lux b/stdlib/source/lux/abstract/equivalence.lux deleted file mode 100644 index 58d644c9b..000000000 --- a/stdlib/source/lux/abstract/equivalence.lux +++ /dev/null @@ -1,24 +0,0 @@ -(.module: - [lux #*] - [// - [functor - ["." contravariant]]]) - -(interface: #export (Equivalence a) - {#.doc "Equivalence for a type's instances."} - (: (-> a a Bit) - =)) - -(def: #export (rec sub) - (All [a] (-> (-> (Equivalence a) (Equivalence a)) (Equivalence a))) - (implementation - (def: (= left right) - (sub = left right)))) - -(implementation: #export functor - (contravariant.Functor Equivalence) - - (def: (map f equivalence) - (implementation - (def: (= reference sample) - (\ equivalence = (f reference) (f sample)))))) diff --git a/stdlib/source/lux/abstract/fold.lux b/stdlib/source/lux/abstract/fold.lux deleted file mode 100644 index 3f957bb55..000000000 --- a/stdlib/source/lux/abstract/fold.lux +++ /dev/null @@ -1,16 +0,0 @@ -(.module: - [lux #*] - [// - [monoid (#+ Monoid)]]) - -(interface: #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] - (fold /\compose /\identity value))) diff --git a/stdlib/source/lux/abstract/functor.lux b/stdlib/source/lux/abstract/functor.lux deleted file mode 100644 index d3012b686..000000000 --- a/stdlib/source/lux/abstract/functor.lux +++ /dev/null @@ -1,44 +0,0 @@ -(.module: lux) - -(interface: #export (Functor f) - (: (All [a b] - (-> (-> a b) - (-> (f a) (f b)))) - map)) - -(type: #export (Fix f) - (f (Fix f))) - -(type: #export (Or f g) - (All [a] (| (f a) (g a)))) - -(def: #export (sum (^open "f\.") (^open "g\.")) - (All [F G] (-> (Functor F) (Functor G) (Functor (..Or F G)))) - (implementation - (def: (map f fa|ga) - (case fa|ga - (#.Left fa) - (#.Left (f\map f fa)) - - (#.Right ga) - (#.Right (g\map f ga)))))) - -(type: #export (And f g) - (All [a] (& (f a) (g a)))) - -(def: #export (product (^open "f\.") (^open "g\.")) - (All [F G] (-> (Functor F) (Functor G) (Functor (..And F G)))) - (implementation - (def: (map f [fa ga]) - [(f\map f fa) - (g\map f ga)]))) - -(type: #export (Then f g) - (All [a] (f (g a)))) - -(def: #export (compose (^open "f\.") (^open "g\.")) - {#.doc "Functor composition."} - (All [F G] (-> (Functor F) (Functor G) (Functor (..Then F G)))) - (implementation - (def: (map f fga) - (f\map (g\map f) fga)))) diff --git a/stdlib/source/lux/abstract/functor/contravariant.lux b/stdlib/source/lux/abstract/functor/contravariant.lux deleted file mode 100644 index d91813e1f..000000000 --- a/stdlib/source/lux/abstract/functor/contravariant.lux +++ /dev/null @@ -1,8 +0,0 @@ -(.module: - [lux #*]) - -(interface: #export (Functor f) - (: (All [a b] - (-> (-> b a) - (-> (f a) (f b)))) - map)) diff --git a/stdlib/source/lux/abstract/hash.lux b/stdlib/source/lux/abstract/hash.lux deleted file mode 100644 index 14857ef18..000000000 --- a/stdlib/source/lux/abstract/hash.lux +++ /dev/null @@ -1,26 +0,0 @@ -(.module: - [lux #*] - [// - ["." equivalence (#+ Equivalence)] - [functor - ["." contravariant]]]) - -(interface: #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)) - -(implementation: #export functor - (contravariant.Functor Hash) - - (def: (map f super) - (implementation - (def: &equivalence - (\ equivalence.functor map f - (\ super &equivalence))) - - (def: hash - (|>> f (\ super hash)))))) diff --git a/stdlib/source/lux/abstract/interval.lux b/stdlib/source/lux/abstract/interval.lux deleted file mode 100644 index e43529890..000000000 --- a/stdlib/source/lux/abstract/interval.lux +++ /dev/null @@ -1,193 +0,0 @@ -## https://en.wikipedia.org/wiki/Interval_(mathematics) -(.module: - [lux #*] - [// - [equivalence (#+ Equivalence)] - ["." order] - [enum (#+ Enum)]]) - -(interface: #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))) - (implementation - (def: &enum enum) - (def: bottom bottom) - (def: top top))) - -(def: #export (singleton enum elem) - (All [a] (-> (Enum a) a (Interval a))) - (implementation - (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? (order.> ,\&order)] - [outer? ,\<] - [singleton? ,\=] - ) - -(def: #export (within? interval elem) - (All [a] (-> (Interval a) a Bit)) - (let [(^open ",\.") interval] - (cond (inner? interval) - (and (order.>= ,\&order ,\bottom elem) - (order.<= ,\&order ,\top elem)) - - (outer? interval) - (or (order.>= ,\&order ,\bottom elem) - (order.<= ,\&order ,\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))) - (implementation - (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))) - (implementation - (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] - (implementation - (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)) - -(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? (order.> ,\&order)] - ) - -(def: #export (meets? reference sample) - (All [a] (-> (Interval a) (Interval a) Bit)) - (let [(^open ",\.") reference - limit (\ reference bottom)] - (and (,\= limit (\ sample top)) - (order.<= ,\&order limit (\ sample bottom))))) - -(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> ,\&order - (\ reference <ineq_side>) - (\ sample <ineq_side>)))))] - - [starts? ,\bottom order.<= ,\top] - [finishes? ,\top order.>= ,\bottom] - ) - -(implementation: #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 (order.>= ,\&order (\ reference bottom) (\ sample bottom)) - (order.<= ,\&order (\ reference top) (\ sample top)))) - - (or (singleton? reference) - (and (inner? reference) (outer? sample))) - #0 - - ## (and (outer? reference) (inner? sample)) - (let [(^open ",\.") reference] - (or (and (order.>= ,\&order (\ reference bottom) (\ sample bottom)) - (order.> ,\&order (\ reference bottom) (\ sample top))) - (and (,\< (\ reference top) (\ sample bottom)) - (order.<= ,\&order (\ 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 (order.>= ,\&order (\ reference bottom) (\ sample top)) - (order.<= ,\&order (\ 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 deleted file mode 100644 index d32bdacbb..000000000 --- a/stdlib/source/lux/abstract/monad.lux +++ /dev/null @@ -1,183 +0,0 @@ -(.module: - [lux #* - [meta - ["." location]]] - [// - [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)) - -(interface: #export (Monad m) - (: (Functor m) - &functor) - (: (All [a] - (-> a (m a))) - wrap) - (: (All [a] - (-> (m (m a)) (m a))) - join)) - -(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 (: (Maybe [(Maybe Text) Code (List Code) Code]) - (case tokens - (^ (list [_ (#.Record (list [[_ (#.Identifier ["" name])] monad]))] [_ (#.Tuple bindings)] body)) - (#.Some [(#.Some name) monad bindings body]) - - (^ (list monad [_ (#.Tuple bindings)] body)) - (#.Some [#.None monad bindings body]) - - _ - #.None)) - (#.Some [?name monad bindings body]) - (if (|> bindings list\size .int ("lux i64 %" +2) ("lux i64 =" +0)) - (let [[module short] (name_of ..do) - gensym (: (-> Text Code) - (|>> ($_ "lux text concat" module " " short " ") [""] #.Identifier [location.dummy])) - g!_ (gensym "_") - g!map (gensym "map") - g!join (gensym "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 (list (case ?name - (#.Some name) - (let [name [location.dummy (#.Identifier ["" name])]] - (` ({(~ name) - ({[(~ g!map) (~' wrap) (~ g!join)] - (~ body')} - (~ name))} - (~ monad)))) - - #.None - (` ({[(~ g!map) (~' wrap) (~ g!join)] - (~ body')} - (~ monad)))))])) - (#.Left "'do' bindings must have an even number of parts.")) - - #.None - (#.Left "Wrong syntax for 'do'"))) - -(def: #export (bind monad f) - (All [! a b] - (-> (Monad !) (-> a (! b)) - (-> (! a) (! b)))) - (|>> (\ monad map f) - (\ monad join))) - -(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')))) diff --git a/stdlib/source/lux/abstract/monad/free.lux b/stdlib/source/lux/abstract/monad/free.lux deleted file mode 100644 index 7a9efbeea..000000000 --- a/stdlib/source/lux/abstract/monad/free.lux +++ /dev/null @@ -1,67 +0,0 @@ -(.module: - [lux #*] - [/// - [functor (#+ Functor)] - [apply (#+ Apply)] - [monad (#+ Monad)]]) - -(type: #export (Free F a) - {#.doc "The Free Monad."} - (#Pure a) - (#Effect (F (Free F a)))) - -(implementation: #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))))) - -(implementation: #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)) - ))) - -(implementation: #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 deleted file mode 100644 index 5a5a63b27..000000000 --- a/stdlib/source/lux/abstract/monad/indexed.lux +++ /dev/null @@ -1,83 +0,0 @@ -(.module: - [lux #* - [control - [monad] - ["p" parser - ["s" code (#+ Parser)]]] - [data - [collection - ["." list ("#\." functor fold)]]] - ["." macro - [syntax (#+ syntax:)] - ["." code]]]) - -(interface: #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 - (Parser Binding) - (p.and s.any s.any)) - -(type: Context - (#Let (List Binding)) - (#Bind Binding)) - -(def: context - (Parser 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)) - -(def: named_monad - (Parser [(Maybe Text) Code]) - (p.either (s.record (p.and (\ p.monad map (|>> #.Some) - s.local_identifier) - s.any)) - (\ p.monad map (|>> [#.None]) - s.any))) - -(syntax: #export (do {[?name monad] ..named_monad} - {context (s.tuple (p.some context))} - expression) - (macro.with_gensyms [g!_ g!bind] - (let [body (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))] - (wrap (list (case ?name - (#.Some name) - (let [name (code.local_identifier name)] - (` (let [(~ name) (~ monad) - {#..wrap (~' wrap) - #..bind (~ g!bind)} (~ name)] - (~ body)))) - - #.None - (` (let [{#..wrap (~' wrap) - #..bind (~ g!bind)} (~ monad)] - (~ body))))))))) diff --git a/stdlib/source/lux/abstract/monoid.lux b/stdlib/source/lux/abstract/monoid.lux deleted file mode 100644 index 2b5560421..000000000 --- a/stdlib/source/lux/abstract/monoid.lux +++ /dev/null @@ -1,20 +0,0 @@ -(.module: - [lux #*]) - -(interface: #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 left right) - (All [l r] (-> (Monoid l) (Monoid r) (Monoid [l r]))) - (implementation - (def: identity - [(\ left identity) (\ right identity)]) - - (def: (compose [lL rL] [lR rR]) - [(\ left compose lL lR) - (\ right compose rL rR)]))) diff --git a/stdlib/source/lux/abstract/order.lux b/stdlib/source/lux/abstract/order.lux deleted file mode 100644 index 9d031bca2..000000000 --- a/stdlib/source/lux/abstract/order.lux +++ /dev/null @@ -1,57 +0,0 @@ -(.module: - [lux #* - [control - ["." function]]] - [// - ["." equivalence (#+ Equivalence)] - [functor - ["." contravariant]]]) - -(interface: #export (Order a) - {#.doc "A signature for types that possess some sense of ordering among their elements."} - - (: (Equivalence a) - &equivalence) - - (: (-> a a Bit) - <) - ) - -(type: #export (Comparison a) - (-> (Order a) a a Bit)) - -(def: #export (<= order parameter subject) - Comparison - (or (\ order < parameter subject) - (\ order = parameter subject))) - -(def: #export (> order parameter subject) - Comparison - (\ order < subject parameter)) - -(def: #export (>= order parameter subject) - Comparison - (or (\ order < subject parameter) - (\ order = subject parameter))) - -(type: #export (Choice a) - (-> (Order a) a a a)) - -(def: #export (min order x y) - Choice - (if (\ order < y x) x y)) - -(def: #export (max order x y) - Choice - (if (\ order < y x) y x)) - -(implementation: #export functor - (contravariant.Functor Order) - - (def: (map f order) - (implementation - (def: &equivalence - (\ equivalence.functor map f (\ order &equivalence))) - - (def: (< reference sample) - (\ order < (f reference) (f sample)))))) diff --git a/stdlib/source/lux/abstract/predicate.lux b/stdlib/source/lux/abstract/predicate.lux deleted file mode 100644 index 841865c10..000000000 --- a/stdlib/source/lux/abstract/predicate.lux +++ /dev/null @@ -1,60 +0,0 @@ -(.module: - [lux #* - [control - ["." function]]] - [// - [monoid (#+ Monoid)] - [functor - ["." contravariant]]]) - -(type: #export (Predicate a) - (-> a Bit)) - -(template [<identity_name> <identity_value> <composition_name> <composition>] - [(def: #export <identity_name> - Predicate - (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 unite or] - [all #1 intersect and] - ) - -(template [<name> <identity> <composition>] - [(implementation: #export <name> - (All [a] (Monoid (Predicate a))) - - (def: identity <identity>) - (def: compose <composition>))] - - [union ..none ..unite] - [intersection ..all ..intersect] - ) - -(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))) - (function (recur input) - (predicate recur input))) - -(implementation: #export functor - (contravariant.Functor Predicate) - - (def: (map f fb) - (|>> f fb))) diff --git a/stdlib/source/lux/control/concatenative.lux b/stdlib/source/lux/control/concatenative.lux deleted file mode 100644 index 51c2604b6..000000000 --- a/stdlib/source/lux/control/concatenative.lux +++ /dev/null @@ -1,330 +0,0 @@ -(.module: - [lux (#- Alias if loop) - ["." meta] - [abstract - ["." monad]] - [data - ["." maybe ("#\." monad)] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." fold functor)]]] - ["." macro (#+ with_gensyms) - ["." code] - [syntax (#+ syntax:) - ["|.|" export] - ["|.|" annotations]]] - [math - [number - ["n" nat] - ["i" int] - ["r" rev] - ["f" frac]]]] - [// - ["<>" parser ("#\." monad) - ["<c>" code (#+ Parser)]]]) - -(type: Alias [Text Code]) - -(type: Stack - {#bottom (Maybe Nat) - #top (List Code)}) - -(def: aliases^ - (Parser (List Alias)) - (|> (<>.and <c>.local_identifier <c>.any) - <>.some - <c>.record - (<>.default (list)))) - -(def: bottom^ - (Parser Nat) - (<c>.form (<>.after (<c>.this! (` #.Parameter)) <c>.nat))) - -(def: stack^ - (Parser Stack) - (<>.either (<>.and (<>.maybe bottom^) - (<c>.tuple (<>.some <c>.any))) - (<>.and (|> bottom^ (<>\map (|>> #.Some))) - (<>\wrap (list))))) - -(def: (stack_fold tops bottom) - (-> (List Code) Code Code) - (list\fold (function (_ top bottom) - (` [(~ bottom) (~ top)])) - bottom - tops)) - -(def: (singleton expander) - (-> (Meta (List Code)) (Meta Code)) - (monad.do meta.monad - [expansion expander] - (case expansion - (#.Cons singleton #.Nil) - (wrap singleton) - - _ - (meta.fail (format "Cannot expand to more than a single AST/Code node:" text.new_line - (|> expansion (list\map %.code) (text.join_with " "))))))) - -(syntax: #export (=> {aliases aliases^} - {inputs stack^} - {outputs stack^}) - (let [de_alias (function (_ aliased) - (list\fold (function (_ [from to] pre) - (code.replace (code.local_identifier from) to pre)) - aliased - aliases))] - (case [(|> inputs (get@ #bottom) (maybe\map (|>> code.nat (~) #.Parameter (`)))) - (|> outputs (get@ #bottom) (maybe\map (|>> code.nat (~) #.Parameter (`))))] - [(#.Some bottomI) (#.Some bottomO)] - (monad.do meta.monad - [inputC (singleton (macro.expand_all (stack_fold (get@ #top inputs) bottomI))) - outputC (singleton (macro.expand_all (stack_fold (get@ #top outputs) bottomO)))] - (wrap (list (` (-> (~ (de_alias inputC)) - (~ (de_alias outputC))))))) - - [?bottomI ?bottomO] - (with_gensyms [g!stack] - (monad.do meta.monad - [inputC (singleton (macro.expand_all (stack_fold (get@ #top inputs) (maybe.default g!stack ?bottomI)))) - outputC (singleton (macro.expand_all (stack_fold (get@ #top outputs) (maybe.default g!stack ?bottomO))))] - (wrap (list (` (All [(~ g!stack)] - (-> (~ (de_alias inputC)) - (~ (de_alias outputC)))))))))))) - -(def: begin! Any []) - -(def: end! - (All [a] (-> [Any a] a)) - (function (_ [_ top]) - top)) - -(syntax: #export (||> {commands (<>.some <c>.any)}) - (wrap (list (` (|> (~! ..begin!) (~+ commands) ((~! ..end!))))))) - -(syntax: #export (word: - {export |export|.parser} - {name <c>.local_identifier} - {annotations (<>.default |annotations|.empty |annotations|.parser)} - type - {commands (<>.some <c>.any)}) - (wrap (list (` (def: (~+ (|export|.format export)) (~ (code.local_identifier name)) - (~ (|annotations|.format annotations)) - (~ type) - (|>> (~+ commands))))))) - -(syntax: #export (apply {arity (|> <c>.nat (<>.filter (n.> 0)))}) - (with_gensyms [g! g!func g!stack g!output] - (monad.do {! meta.monad} - [g!inputs (|> (macro.gensym "input") (list.repeat arity) (monad.seq !))] - (wrap (list (` (: (All [(~+ g!inputs) (~ g!output)] - (-> (-> (~+ g!inputs) (~ g!output)) - (=> [(~+ g!inputs)] [(~ g!output)]))) - (function ((~ g!) (~ g!func)) - (function ((~ g!) (~ (stack_fold g!inputs g!stack))) - [(~ g!stack) ((~ g!func) (~+ g!inputs))]))))))))) - -(def: #export apply/1 (apply 1)) -(def: #export apply/2 (apply 2)) -(def: #export apply/3 (apply 3)) -(def: #export apply/4 (apply 4)) -(def: #export apply/5 (apply 5)) -(def: #export apply/6 (apply 6)) -(def: #export apply/7 (apply 7)) -(def: #export apply/8 (apply 8)) - -(def: #export (push x) - (All [a] (-> a (=> [] [a]))) - (function (_ stack) - [stack x])) - -(def: #export drop - (All [t] (=> [t] [])) - (function (_ [stack top]) - stack)) - -(def: #export nip - (All [_ a] (=> [_ a] [a])) - (function (_ [[stack _] top]) - [stack top])) - -(def: #export dup - (All [a] (=> [a] [a a])) - (function (_ [stack top]) - [[stack top] top])) - -(def: #export swap - (All [a b] (=> [a b] [b a])) - (function (_ [[stack l] r]) - [[stack r] l])) - -(def: #export rotL - (All [a b c] (=> [a b c] [b c a])) - (function (_ [[[stack a] b] c]) - [[[stack b] c] a])) - -(def: #export rotR - (All [a b c] (=> [a b c] [c a b])) - (function (_ [[[stack a] b] c]) - [[[stack c] a] b])) - -(def: #export && - (All [a b] (=> [a b] [(& a b)])) - (function (_ [[stack l] r]) - [stack [l r]])) - -(def: #export ||L - (All [a b] (=> [a] [(| a b)])) - (function (_ [stack l]) - [stack (0 #0 l)])) - -(def: #export ||R - (All [a b] (=> [b] [(| a b)])) - (function (_ [stack r]) - [stack (0 #1 r)])) - -(template [<input> <output> <word> <func>] - [(def: #export <word> - (=> [<input> <input>] [<output>]) - (function (_ [[stack subject] param]) - [stack (<func> param subject)]))] - - [Nat Nat n/+ n.+] - [Nat Nat n/- n.-] - [Nat Nat n/* n.*] - [Nat Nat n// n./] - [Nat Nat n/% n.%] - [Nat Bit n/= n.=] - [Nat Bit n/< n.<] - [Nat Bit n/<= n.<=] - [Nat Bit n/> n.>] - [Nat Bit n/>= n.>=] - - [Int Int i/+ i.+] - [Int Int i/- i.-] - [Int Int i/* i.*] - [Int Int i// i./] - [Int Int i/% i.%] - [Int Bit i/= i.=] - [Int Bit i/< i.<] - [Int Bit i/<= i.<=] - [Int Bit i/> i.>] - [Int Bit i/>= i.>=] - - [Rev Rev r/+ r.+] - [Rev Rev r/- r.-] - [Rev Rev r/* r.*] - [Rev Rev r// r./] - [Rev Rev r/% r.%] - [Rev Bit r/= r.=] - [Rev Bit r/< r.<] - [Rev Bit r/<= r.<=] - [Rev Bit r/> r.>] - [Rev Bit r/>= r.>=] - - [Frac Frac f/+ f.+] - [Frac Frac f/- f.-] - [Frac Frac f/* f.*] - [Frac Frac f// f./] - [Frac Frac f/% f.%] - [Frac Bit f/= f.=] - [Frac Bit f/< f.<] - [Frac Bit f/<= f.<=] - [Frac Bit f/> f.>] - [Frac Bit f/>= f.>=] - ) - -(def: #export if - (All [___a ___z] - (=> {then (=> ___a ___z) - else (=> ___a ___z)} - ___a [Bit then else] ___z)) - (function (_ [[[stack test] then] else]) - (.if test - (then stack) - (else stack)))) - -(def: #export call - (All [___a ___z] - (=> {quote (=> ___a ___z)} - ___a [quote] ___z)) - (function (_ [stack quote]) - (quote stack))) - -(def: #export loop - (All [___] - (=> {test (=> ___ ___ [Bit])} - ___ [test] ___)) - (function (loop [stack pred]) - (let [[stack' verdict] (pred stack)] - (.if verdict - (loop [stack' pred]) - stack')))) - -(def: #export dip - (All [___ a] - (=> ___ [a (=> ___ ___)] - ___ [a])) - (function (_ [[stack a] quote]) - [(quote stack) a])) - -(def: #export dip/2 - (All [___ a b] - (=> ___ [a b (=> ___ ___)] - ___ [a b])) - (function (_ [[[stack a] b] quote]) - [[(quote stack) a] b])) - -(def: #export do - (All [___a ___z] - (=> {body (=> ___a ___z) - pred (=> ___z ___a [Bit])} - ___a [pred body] - ___z [pred body])) - (function (_ [[stack pred] body]) - [[(body stack) pred] body])) - -(def: #export while - (All [___a ___z] - (=> {body (=> ___z ___a) - pred (=> ___a ___z [Bit])} - ___a [pred body] - ___z)) - (function (while [[stack pred] body]) - (let [[stack' verdict] (pred stack)] - (.if verdict - (while [[(body stack') pred] body]) - stack')))) - -(def: #export compose - (All [___a ___ ___z] - (=> [(=> ___a ___) (=> ___ ___z)] - [(=> ___a ___z)])) - (function (_ [[stack f] g]) - [stack (|>> f g)])) - -(def: #export curry - (All [___a ___z a] - (=> ___a [a (=> ___a [a] ___z)] - ___a [(=> ___a ___z)])) - (function (_ [[stack arg] quote]) - [stack (|>> (push arg) quote)])) - -(word: #export when - (All [___] - (=> {body (=> ___ ___)} - ___ [Bit body] - ___)) - swap - (push (|>> call)) - (push (|>> drop)) - if) - -(word: #export ? - (All [a] - (=> [Bit a a] [a])) - rotL - (push (|>> drop)) - (push (|>> nip)) - if) diff --git a/stdlib/source/lux/control/concurrency/actor.lux b/stdlib/source/lux/control/concurrency/actor.lux deleted file mode 100644 index 9e17193b2..000000000 --- a/stdlib/source/lux/control/concurrency/actor.lux +++ /dev/null @@ -1,389 +0,0 @@ -(.module: {#.doc "The actor model of concurrency."} - [lux #* - [abstract - monad] - [control - [pipe (#+ case>)] - ["." function] - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["." io (#+ IO io)] - ["<>" parser - ["<.>" code (#+ Parser)]]] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." monoid monad fold)]]] - ["." macro (#+ with_gensyms) - ["." code] - [syntax (#+ syntax:) - ["|.|" input] - ["|.|" export] - ["|.|" annotations]]] - [math - [number - ["n" nat]]] - ["." meta (#+ monad) - ["." annotation]] - [type (#+ :share) - ["." abstract (#+ abstract: :representation :abstraction)]]] - [// - ["." atom (#+ Atom atom)] - ["." promise (#+ Promise Resolver) ("#\." monad)] - ["." frp (#+ Channel)]]) - -(exception: #export poisoned) -(exception: #export dead) - -(with_expansions - [<Mail> (as_is (-> s (Actor s) (Promise (Try s)))) - <Obituary> (as_is [Text s (List <Mail>)]) - <Mailbox> (as_is (Rec Mailbox - [(Promise [<Mail> Mailbox]) - (Resolver [<Mail> Mailbox])]))] - - (def: (pending [read write]) - (All [a] - (-> (Rec Mailbox - [(Promise [a Mailbox]) - (Resolver [a Mailbox])]) - (IO (List a)))) - (do {! io.monad} - [current (promise.poll read)] - (case current - (#.Some [head tail]) - (\ ! map (|>> (#.Cons head)) - (pending tail)) - - #.None - (wrap #.Nil)))) - - (abstract: #export (Actor s) - {#obituary [(Promise <Obituary>) - (Resolver <Obituary>)] - #mailbox (Atom <Mailbox>)} - - (type: #export (Mail s) - <Mail>) - - (type: #export (Obituary s) - <Obituary>) - - (type: #export (Behavior o s) - {#.doc "An actor's behavior when mail is received and when a fatal error occurs."} - {#on_init (-> o s) - #on_mail (-> (Mail s) s (Actor s) (Promise (Try s)))}) - - (def: #export (spawn! behavior init) - {#.doc "Given a behavior and initial state, spawns an actor and returns it."} - (All [o s] (-> (Behavior o s) o (IO (Actor s)))) - (io (let [[on_init on_mail] behavior - self (:share [o s] - (Behavior o s) - behavior - - (Actor s) - (:abstraction {#obituary (promise.promise []) - #mailbox (atom (promise.promise []))})) - process (loop [state (on_init init) - [|mailbox| _] (io.run (atom.read (get@ #mailbox (:representation self))))] - (do {! promise.monad} - [[head tail] |mailbox| - ?state' (on_mail head state self)] - (case ?state' - (#try.Failure error) - (let [[_ resolve] (get@ #obituary (:representation self))] - (exec (io.run - (do io.monad - [pending (..pending tail)] - (resolve [error state (#.Cons head pending)]))) - (wrap []))) - - (#try.Success state') - (recur state' tail))))] - self))) - - (def: #export (alive? actor) - (All [s] (-> (Actor s) (IO Bit))) - (let [[obituary _] (get@ #obituary (:representation actor))] - (|> obituary - promise.poll - (\ io.functor map - (|>> (case> #.None - yes - - _ - no)))))) - - (def: #export (obituary actor) - (All [s] (-> (Actor s) (IO (Maybe (Obituary s))))) - (let [[obituary _] (get@ #obituary (:representation actor))] - (promise.poll obituary))) - - (def: #export await - (All [s] (-> (Actor s) (Promise (Obituary s)))) - (|>> :representation - (get@ #obituary) - product.left)) - - (def: #export (mail! mail actor) - {#.doc "Send mail to an actor.."} - (All [s] (-> (Mail s) (Actor s) (IO (Try Any)))) - (do {! io.monad} - [alive? (..alive? actor)] - (if alive? - (let [entry [mail (promise.promise [])]] - (do ! - [|mailbox|&resolve (atom.read (get@ #mailbox (:representation actor)))] - (loop [[|mailbox| resolve] |mailbox|&resolve] - (do ! - [|mailbox| (promise.poll |mailbox|)] - (case |mailbox| - #.None - (do ! - [resolved? (resolve entry)] - (if resolved? - (do ! - [_ (atom.write (product.right entry) (get@ #mailbox (:representation actor)))] - (wrap (exception.return []))) - (recur |mailbox|&resolve))) - - (#.Some [_ |mailbox|']) - (recur |mailbox|')))))) - (wrap (exception.throw ..dead []))))) - - (type: #export (Message s o) - (-> s (Actor s) (Promise (Try [s o])))) - - (def: (mail message) - (All [s o] (-> (Message s o) [(Promise (Try o)) (Mail s)])) - (let [[promise resolve] (:share [s o] - (Message s o) - message - - [(Promise (Try o)) - (Resolver (Try o))] - (promise.promise []))] - [promise - (function (_ state self) - (do {! promise.monad} - [outcome (message state self)] - (case outcome - (#try.Success [state' return]) - (exec (io.run (resolve (#try.Success return))) - (promise.resolved (#try.Success state'))) - - (#try.Failure error) - (exec (io.run (resolve (#try.Failure error))) - (promise.resolved (#try.Failure error))))))])) - - (def: #export (tell! message actor) - {#.doc "Communicate with an actor through message passing."} - (All [s o] (-> (Message s o) (Actor s) (Promise (Try o)))) - (let [[promise mail] (..mail message)] - (do promise.monad - [outcome (promise.future (..mail! mail actor))] - (case outcome - (#try.Success) - promise - - (#try.Failure error) - (wrap (#try.Failure error)))))) - ) - ) - -(def: (default_on_mail mail state self) - (All [s] (-> (Mail s) s (Actor s) (Promise (Try s)))) - (mail state self)) - -(def: #export default - (All [s] (Behavior s s)) - {#on_init function.identity - #on_mail ..default_on_mail}) - -(def: #export (poison! actor) - {#.doc (doc "Kills the actor by sending mail that will kill it upon processing," - "but allows the actor to handle previous mail.")} - (All [s] (-> (Actor s) (IO (Try Any)))) - (..mail! (function (_ state self) - (promise.resolved (exception.throw ..poisoned []))) - actor)) - -(def: actor_decl^ - (Parser [Text (List Text)]) - (<>.either (<code>.form (<>.and <code>.local_identifier (<>.some <code>.local_identifier))) - (<>.and <code>.local_identifier (\ <>.monad wrap (list))))) - -(type: On_MailC - [[Text Text Text] Code]) - -(type: BehaviorC - [(Maybe On_MailC) (List Code)]) - -(def: argument - (Parser Text) - <code>.local_identifier) - -(def: behavior^ - (Parser BehaviorC) - (let [on_mail_args ($_ <>.and ..argument ..argument ..argument)] - ($_ <>.and - (<>.maybe (<code>.form (<>.and (<code>.form (<>.after (<code>.this! (' on_mail)) on_mail_args)) - <code>.any))) - (<>.some <code>.any)))) - -(def: (on_mail g!_ ?on_mail) - (-> Code (Maybe On_MailC) Code) - (case ?on_mail - #.None - (` (~! ..default_on_mail)) - - (#.Some [[mailN stateN selfN] bodyC]) - (` (function ((~ g!_) - (~ (code.local_identifier mailN)) - (~ (code.local_identifier stateN)) - (~ (code.local_identifier selfN))) - (~ bodyC))))) - -(with_expansions [<examples> (as_is (actor: #export (Stack a) - (List a) - - ((on_mail mail state self) - (do (try.with promise.monad) - [#let [_ (log! "BEFORE")] - output (mail state self) - #let [_ (log! "AFTER")]] - (wrap output))) - - (message: #export (push {value a} state self (List a)) - (let [state' (#.Cons value state)] - (promise.resolved (#try.Success [state' state']))))) - - (actor: #export Counter - Nat - - (message: #export (count! {increment Nat} state self Any) - (let [state' (n.+ increment state)] - (promise.resolved (#try.Success [state' state'])))) - - (message: #export (read! state self Nat) - (promise.resolved (#try.Success [state state])))))] - (syntax: #export (actor: - {export |export|.parser} - {[name vars] actor_decl^} - {annotations (<>.default |annotations|.empty |annotations|.parser)} - state_type - {[?on_mail messages] behavior^}) - {#.doc (doc "Defines an actor, with its behavior and internal state." - "Messages for the actor must be defined after the on_mail handler." - <examples>)} - (with_gensyms [g!_] - (do meta.monad - [g!type (macro.gensym (format name "_abstract_type")) - #let [g!actor (code.local_identifier name) - g!vars (list\map code.local_identifier vars)]] - (wrap (list (` ((~! abstract:) (~+ (|export|.format export)) ((~ g!type) (~+ g!vars)) - (~ state_type) - - (def: (~+ (|export|.format export)) (~ g!actor) - (All [(~+ g!vars)] - (..Behavior (~ state_type) ((~ g!type) (~+ g!vars)))) - {#..on_init (|>> ((~! abstract.:abstraction) (~ g!type))) - #..on_mail (~ (..on_mail g!_ ?on_mail))}) - - (~+ messages)))))))) - - (syntax: #export (actor {[state_type init] (<code>.record (<>.and <code>.any <code>.any))} - {[?on_mail messages] behavior^}) - (with_gensyms [g!_] - (wrap (list (` (: ((~! io.IO) (..Actor (~ state_type))) - (..spawn! (: (..Behavior (~ state_type) (~ state_type)) - {#..on_init (|>>) - #..on_mail (~ (..on_mail g!_ ?on_mail))}) - (: (~ state_type) - (~ init))))))))) - - (type: Signature - {#vars (List Text) - #name Text - #inputs (List |input|.Input) - #state Text - #self Text - #output Code}) - - (def: signature^ - (Parser Signature) - (<code>.form ($_ <>.and - (<>.default (list) (<code>.tuple (<>.some <code>.local_identifier))) - <code>.local_identifier - (<>.some |input|.parser) - <code>.local_identifier - <code>.local_identifier - <code>.any))) - - (def: reference^ - (Parser [Name (List Text)]) - (<>.either (<code>.form (<>.and <code>.identifier (<>.some <code>.local_identifier))) - (<>.and <code>.identifier (\ <>.monad wrap (list))))) - - (syntax: #export (message: - {export |export|.parser} - {signature signature^} - {annotations (<>.default |annotations|.empty |annotations|.parser)} - body) - {#.doc (doc "A message can access the actor's state through the state parameter." - "A message can also access the actor itself through the self parameter." - "A message's output must be a promise containing a 2-tuple with the updated state and a return value." - "A message may succeed or fail (in case of failure, the actor dies)." - - <examples>)} - (with_gensyms [g!_ g!return] - (do meta.monad - [actor_scope abstract.current - #let [g!type (code.local_identifier (get@ #abstract.name actor_scope)) - g!message (code.local_identifier (get@ #name signature)) - g!actor_vars (get@ #abstract.type_vars actor_scope) - g!all_vars (|> signature (get@ #vars) (list\map code.local_identifier) (list\compose g!actor_vars)) - g!inputsC (|> signature (get@ #inputs) (list\map product.left)) - g!inputsT (|> signature (get@ #inputs) (list\map product.right)) - g!state (|> signature (get@ #state) code.local_identifier) - g!self (|> signature (get@ #self) code.local_identifier)]] - (wrap (list (` (def: (~+ (|export|.format export)) ((~ g!message) (~+ g!inputsC)) - (~ (|annotations|.format annotations)) - (All [(~+ g!all_vars)] - (-> (~+ g!inputsT) - (..Message (~ (get@ #abstract.abstraction actor_scope)) - (~ (get@ #output signature))))) - (function ((~ g!_) (~ g!state) (~ g!self)) - (let [(~ g!state) (:as (~ (get@ #abstract.representation actor_scope)) - (~ g!state))] - (|> (~ body) - (: ((~! promise.Promise) ((~! try.Try) [(~ (get@ #abstract.representation actor_scope)) - (~ (get@ #output signature))]))) - (:as ((~! promise.Promise) ((~! try.Try) [(~ (get@ #abstract.abstraction actor_scope)) - (~ (get@ #output signature))])))))))) - )))))) - -(type: #export Stop - (IO Any)) - -(def: continue! true) -(def: stop! false) - -(def: #export (observe action channel actor) - (All [e s] (-> (-> e Stop (Mail s)) (Channel e) (Actor s) (IO Any))) - (let [signal (: (Atom Bit) - (atom.atom ..continue!)) - stop (: Stop - (atom.write ..stop! signal))] - (frp.subscribe (function (_ event) - (do {! io.monad} - [continue? (atom.read signal)] - (if continue? - (do ! - [outcome (..mail! (action event stop) actor)] - (wrap (try.to_maybe outcome))) - (wrap #.None)))) - channel))) diff --git a/stdlib/source/lux/control/concurrency/atom.lux b/stdlib/source/lux/control/concurrency/atom.lux deleted file mode 100644 index e3b711785..000000000 --- a/stdlib/source/lux/control/concurrency/atom.lux +++ /dev/null @@ -1,102 +0,0 @@ -(.module: - [lux #* - ["." ffi] - ["@" target] - [abstract - [monad (#+ do)]] - [control - ["." function] - ["." io (#- run) ("#\." functor)]] - [data - ["." product] - [collection - ["." array]]] - [type - abstract]]) - -(with_expansions [<jvm> (as_is (ffi.import: (java/util/concurrent/atomic/AtomicReference a) - ["#::." - (new [a]) - (get [] a) - (compareAndSet [a a] boolean)]))] - (for {@.old <jvm> - @.jvm <jvm>} - (as_is))) - -(with_expansions [<new> (for {@.js "js array new" - @.python "python array new" - @.lua "lua array new" - @.ruby "ruby array new" - @.php "php array new" - @.scheme "scheme array new"} - (as_is)) - <write> (for {@.js "js array write" - @.python "python array write" - @.lua "lua array write" - @.ruby "ruby array write" - @.php "php array write" - @.scheme "scheme array write"} - (as_is)) - - <read> (for {@.js "js array read" - @.python "python array read" - @.lua "lua array read" - @.ruby "ruby array read" - @.php "php array read" - @.scheme "scheme array read"} - (as_is))] - (abstract: #export (Atom a) - (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference a)] - (for {@.old <jvm> - @.jvm <jvm>} - (array.Array a))) - - {#.doc "Atomic references that are safe to mutate concurrently."} - - (def: #export (atom value) - (All [a] (-> a (Atom a))) - (:abstraction (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference::new value)] - (for {@.old <jvm> - @.jvm <jvm>} - (<write> 0 value (<new> 1)))))) - - (def: #export (read atom) - (All [a] (-> (Atom a) (IO a))) - (io (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference::get (:representation atom))] - (for {@.old <jvm> - @.jvm <jvm>} - (<read> 0 (:representation atom)))))) - - (def: #export (compare_and_swap current new atom) - {#.doc (doc "Only mutates an atom if you can present its current value." - "That guarantees that atom was not updated since you last read from it.")} - (All [a] (-> a a (Atom a) (IO Bit))) - (io (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference::compareAndSet current new (:representation atom))] - (for {@.old <jvm> - @.jvm <jvm>} - (let [old (<read> 0 (:representation atom))] - (if (is? old current) - (exec (<write> 0 new (:representation atom)) - true) - false)))))) - )) - -(def: #export (update f atom) - {#.doc (doc "Updates an atom by applying a function to its current value." - "If it fails to update it (because some other process wrote to it first), it will retry until it succeeds." - "The retries will be done with the new values of the atom, as they show up.")} - (All [a] (-> (-> a a) (Atom a) (IO [a a]))) - (loop [_ []] - (do io.monad - [old (read atom) - #let [new (f old)] - swapped? (..compare_and_swap old new atom)] - (if swapped? - (wrap [old new]) - (recur []))))) - -(def: #export (write value atom) - (All [a] (-> a (Atom a) (IO a))) - (|> atom - (..update (function.constant value)) - (io\map product.left))) diff --git a/stdlib/source/lux/control/concurrency/frp.lux b/stdlib/source/lux/control/concurrency/frp.lux deleted file mode 100644 index 452c153f1..000000000 --- a/stdlib/source/lux/control/concurrency/frp.lux +++ /dev/null @@ -1,295 +0,0 @@ -(.module: - [lux #* - [abstract - [predicate (#+ Predicate)] - [equivalence (#+ Equivalence)] - [functor (#+ Functor)] - [apply (#+ Apply)] - ["." monad (#+ Monad do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["." io (#+ IO io)]] - [data - ["." maybe ("#\." functor)]] - [type (#+ :share) - abstract]] - [// - ["." atom (#+ Atom)] - ["." promise (#+ Promise) ("#\." functor)]]) - -(type: #export (Channel a) - {#.doc "An asynchronous channel to distribute values."} - (Promise (Maybe [a (Channel a)]))) - -(exception: #export channel_is_already_closed) - -(interface: #export (Sink a) - (: (IO (Try Any)) - close) - (: (-> a (IO (Try Any))) - feed)) - -(def: (sink resolve) - (All [a] - (-> (promise.Resolver (Maybe [a (Channel a)])) - (Sink a))) - (let [sink (atom.atom resolve)] - (implementation - (def: close - (loop [_ []] - (do {! io.monad} - [current (atom.read sink) - stopped? (current #.None)] - (if stopped? - ## I closed the sink. - (wrap (exception.return [])) - ## Someone else interacted with the sink. - (do ! - [latter (atom.read sink)] - (if (is? current latter) - ## Someone else closed the sink. - (wrap (exception.throw ..channel_is_already_closed [])) - ## Someone else fed the sink while I was closing it. - (recur []))))))) - - (def: (feed value) - (loop [_ []] - (do {! io.monad} - [current (atom.read sink) - #let [[next resolve_next] (:share [a] - (promise.Resolver (Maybe [a (Channel a)])) - current - - [(Promise (Maybe [a (Channel a)])) - (promise.Resolver (Maybe [a (Channel a)]))] - (promise.promise []))] - fed? (current (#.Some [value next]))] - (if fed? - ## I fed the sink. - (do ! - [_ (atom.compare_and_swap current resolve_next sink)] - (wrap (exception.return []))) - ## Someone else interacted with the sink. - (do ! - [latter (atom.read sink)] - (if (is? current latter) - ## Someone else closed the sink while I was feeding it. - (wrap (exception.throw ..channel_is_already_closed [])) - ## Someone else fed the sink. - (recur [])))))))))) - -(def: #export (channel _) - (All [a] (-> Any [(Channel a) (Sink a)])) - (let [[promise resolve] (promise.promise [])] - [promise (..sink resolve)])) - -(implementation: #export functor - (Functor Channel) - - (def: (map f) - (promise\map - (maybe\map - (function (_ [head tail]) - [(f head) (map f tail)]))))) - -(implementation: #export apply - (Apply Channel) - - (def: &functor ..functor) - - (def: (apply ff fa) - (do promise.monad - [cons_f ff - cons_a fa] - (case [cons_f cons_a] - [(#.Some [head_f tail_f]) (#.Some [head_a tail_a])] - (wrap (#.Some [(head_f head_a) (apply tail_f tail_a)])) - - _ - (wrap #.None))))) - -(def: empty - Channel - (promise.resolved #.None)) - -(implementation: #export monad - (Monad Channel) - - (def: &functor ..functor) - - (def: (wrap a) - (promise.resolved (#.Some [a ..empty]))) - - (def: (join mma) - (let [[output sink] (channel [])] - (exec (: (Promise Any) - (loop [mma mma] - (do {! promise.monad} - [?mma mma] - (case ?mma - (#.Some [ma mma']) - (do ! - [_ (loop [ma ma] - (do ! - [?ma ma] - (case ?ma - (#.Some [a ma']) - (exec (io.run (\ sink feed a)) - (recur ma')) - - #.None - (wrap []))))] - (recur mma')) - - #.None - (wrap (: Any (io.run (\ sink close)))))))) - output)))) - -(type: #export (Subscriber a) - (-> a (IO (Maybe Any)))) - -(def: #export (subscribe subscriber channel) - (All [a] (-> (Subscriber a) (Channel a) (IO Any))) - (io (exec (: (Promise Any) - (loop [channel channel] - (do promise.monad - [cons channel] - (case cons - (#.Some [head tail]) - (case (io.run (subscriber head)) - (#.Some _) - (recur tail) - - #.None - (wrap [])) - - #.None - (wrap []))))) - []))) - -(def: #export (filter pass? channel) - (All [a] (-> (Predicate a) (Channel a) (Channel a))) - (do promise.monad - [cons channel] - (case cons - (#.Some [head tail]) - (let [tail' (filter pass? tail)] - (if (pass? head) - (wrap (#.Some [head tail'])) - tail')) - - #.None - (wrap #.None)))) - -(def: #export (from_promise promise) - (All [a] (-> (Promise a) (Channel a))) - (promise\map (function (_ value) - (#.Some [value ..empty])) - promise)) - -(def: #export (fold f init channel) - {#.doc "Asynchronous fold over channels."} - (All [a b] - (-> (-> b a (Promise a)) a (Channel b) - (Promise a))) - (do {! promise.monad} - [cons channel] - (case cons - #.None - (wrap init) - - (#.Some [head tail]) - (do ! - [init' (f head init)] - (fold f init' tail))))) - -(def: #export (folds f init channel) - {#.doc "A channel of folds."} - (All [a b] - (-> (-> b a (Promise a)) a (Channel b) - (Channel a))) - (do {! promise.monad} - [cons channel] - (case cons - #.None - (wrap (#.Some [init (wrap #.None)])) - - (#.Some [head tail]) - (do ! - [init' (f head init)] - (wrap (#.Some [init (folds f init' tail)])))))) - -(def: #export (poll milli_seconds action) - (All [a] - (-> Nat (IO a) [(Channel a) (Sink a)])) - (let [[output sink] (channel [])] - (exec (io.run (loop [_ []] - (do io.monad - [value action - _ (\ sink feed value)] - (promise.await recur (promise.wait milli_seconds))))) - [output sink]))) - -(def: #export (periodic milli_seconds) - (-> Nat [(Channel Any) (Sink Any)]) - (..poll milli_seconds (io []))) - -(def: #export (iterate f init) - (All [s o] (-> (-> s (Promise (Maybe [s o]))) s (Channel o))) - (do promise.monad - [?next (f init)] - (case ?next - (#.Some [state output]) - (wrap (#.Some [output (iterate f state)])) - - #.None - (wrap #.None)))) - -(def: (distinct' equivalence previous channel) - (All [a] (-> (Equivalence a) a (Channel a) (Channel a))) - (do promise.monad - [cons channel] - (case cons - (#.Some [head tail]) - (if (\ equivalence = previous head) - (distinct' equivalence previous tail) - (wrap (#.Some [head (distinct' equivalence head tail)]))) - - #.None - (wrap #.None)))) - -(def: #export (distinct equivalence channel) - (All [a] (-> (Equivalence a) (Channel a) (Channel a))) - (do promise.monad - [cons channel] - (case cons - (#.Some [head tail]) - (wrap (#.Some [head (distinct' equivalence head tail)])) - - #.None - (wrap #.None)))) - -(def: #export (consume channel) - {#.doc "Reads the entirety of a channel's content and returns it as a list."} - (All [a] (-> (Channel a) (Promise (List a)))) - (do {! promise.monad} - [cons channel] - (case cons - (#.Some [head tail]) - (\ ! map (|>> (#.Cons head)) - (consume tail)) - - #.None - (wrap #.Nil)))) - -(def: #export (sequential milli_seconds values) - (All [a] (-> Nat (List a) (Channel a))) - (case values - #.Nil - ..empty - - (#.Cons head tail) - (promise.resolved (#.Some [head (do promise.monad - [_ (promise.wait milli_seconds)] - (sequential milli_seconds tail))])))) diff --git a/stdlib/source/lux/control/concurrency/promise.lux b/stdlib/source/lux/control/concurrency/promise.lux deleted file mode 100644 index 8e0acf8b9..000000000 --- a/stdlib/source/lux/control/concurrency/promise.lux +++ /dev/null @@ -1,199 +0,0 @@ -(.module: - [lux (#- and or) - [abstract - [functor (#+ Functor)] - [apply (#+ Apply)] - ["." monad (#+ Monad do)]] - [control - [pipe (#+ case>)] - ["." function] - ["." io (#+ IO io)]] - [data - ["." product]] - [type (#+ :share) - abstract]] - [// - ["." thread] - ["." atom (#+ Atom atom)]]) - -(abstract: #export (Promise a) - (Atom [(Maybe a) (List (-> a (IO Any)))]) - - {#.doc "Represents values produced by asynchronous computations (unlike IO, which is synchronous)."} - - (type: #export (Resolver a) - (-> a (IO Bit))) - - (def: (resolver promise) - {#.doc "Sets an promise's value if it has not been done yet."} - (All [a] (-> (Promise a) (Resolver a))) - (function (resolve value) - (let [promise (:representation promise)] - (do {! io.monad} - [(^@ old [_value _observers]) (atom.read promise)] - (case _value - (#.Some _) - (wrap #0) - - #.None - (do ! - [#let [new [(#.Some value) #.None]] - succeeded? (atom.compare_and_swap old new promise)] - (if succeeded? - (do ! - [_ (monad.map ! (function (_ f) (f value)) - _observers)] - (wrap #1)) - (resolve value)))))))) - - (def: #export (resolved value) - (All [a] (-> a (Promise a))) - (:abstraction (atom [(#.Some value) (list)]))) - - (def: #export (promise _) - (All [a] (-> Any [(Promise a) (Resolver a)])) - (let [promise (:abstraction (atom [#.None (list)]))] - [promise (..resolver promise)])) - - (def: #export poll - {#.doc "Polls a promise's value."} - (All [a] (-> (Promise a) (IO (Maybe a)))) - (|>> :representation - atom.read - (\ io.functor map product.left))) - - (def: #export (await f promise) - (All [a] (-> (-> a (IO Any)) (Promise a) (IO Any))) - (do {! io.monad} - [#let [promise (:representation promise)] - (^@ old [_value _observers]) (atom.read promise)] - (case _value - (#.Some value) - (f value) - - #.None - (let [new [_value (#.Cons f _observers)]] - (do ! - [swapped? (atom.compare_and_swap old new promise)] - (if swapped? - (wrap []) - (await f (:abstraction promise)))))))) - ) - -(def: #export resolved? - {#.doc "Checks whether a promise's value has already been resolved."} - (All [a] (-> (Promise a) (IO Bit))) - (|>> ..poll - (\ io.functor map - (|>> (case> #.None - #0 - - (#.Some _) - #1))))) - -(implementation: #export functor - (Functor Promise) - - (def: (map f fa) - (let [[fb resolve] (..promise [])] - (exec (io.run (..await (|>> f resolve) fa)) - fb)))) - -(implementation: #export apply - (Apply Promise) - - (def: &functor ..functor) - - (def: (apply ff fa) - (let [[fb resolve] (..promise [])] - (exec (io.run (..await (function (_ f) - (..await (|>> f resolve) fa)) - ff)) - fb)))) - -(implementation: #export monad - (Monad Promise) - - (def: &functor ..functor) - - (def: wrap ..resolved) - - (def: (join mma) - (let [[ma resolve] (promise [])] - (exec (io.run (..await (..await resolve) mma)) - ma)))) - -(def: #export (and left right) - {#.doc "Sequencing combinator."} - (All [a b] (-> (Promise a) (Promise b) (Promise [a b]))) - (let [[read! write!] (:share [a b] - [(Promise a) (Promise b)] - [left right] - - [(Promise [a b]) - (Resolver [a b])] - (..promise [])) - _ (io.run (..await (function (_ left) - (..await (function (_ right) - (write! [left right])) - right)) - left))] - read!)) - -(def: #export (or left right) - {#.doc "Heterogeneous alternative combinator."} - (All [a b] (-> (Promise a) (Promise b) (Promise (| a b)))) - (let [[a|b resolve] (..promise [])] - (with_expansions - [<sides> (template [<promise> <tag>] - [(io.run (await (|>> <tag> resolve) <promise>))] - - [left #.Left] - [right #.Right] - )] - (exec <sides> - a|b)))) - -(def: #export (either left right) - {#.doc "Homogeneous alternative combinator."} - (All [a] (-> (Promise a) (Promise a) (Promise a))) - (let [[left||right resolve] (..promise [])] - (`` (exec (~~ (template [<promise>] - [(io.run (await resolve <promise>))] - - [left] - [right])) - left||right)))) - -(def: #export (schedule millis_delay computation) - {#.doc (doc "Runs an I/O computation on its own thread (after a specified delay)." - "Returns a Promise that will eventually host its result.")} - (All [a] (-> Nat (IO a) (Promise a))) - (let [[!out resolve] (..promise [])] - (exec (|> (do io.monad - [value computation] - (resolve value)) - (thread.schedule millis_delay) - io.run) - !out))) - -(def: #export future - {#.doc (doc "Runs an I/O computation on its own thread." - "Returns a Promise that will eventually host its result.")} - (All [a] (-> (IO a) (Promise a))) - (..schedule 0)) - -(def: #export (delay time_millis value) - {#.doc "Delivers a value after a certain period has passed."} - (All [a] (-> Nat a (Promise a))) - (..schedule time_millis (io value))) - -(def: #export (wait time_millis) - {#.doc "Returns a promise that will be resolved after the specified amount of milliseconds."} - (-> Nat (Promise Any)) - (..delay time_millis [])) - -(def: #export (time_out time_millis promise) - {#.doc "Wait for a promise to be resolved within the specified amount of milliseconds."} - (All [a] (-> Nat (Promise a) (Promise (Maybe a)))) - (..or (wait time_millis) promise)) diff --git a/stdlib/source/lux/control/concurrency/semaphore.lux b/stdlib/source/lux/control/concurrency/semaphore.lux deleted file mode 100644 index 0e8fa2b94..000000000 --- a/stdlib/source/lux/control/concurrency/semaphore.lux +++ /dev/null @@ -1,173 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - [pipe (#+ if>)] - ["." io (#+ IO)] - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - [text - ["%" format (#+ format)]] - [collection - ["." queue (#+ Queue)]]] - [math - [number - ["n" nat] - ["i" int]]] - [type - abstract - ["." refinement]]] - [// - ["." atom (#+ Atom)] - ["." promise (#+ Promise Resolver)]]) - -(type: State - {#max_positions Nat - #open_positions Int - #waiting_list (Queue (Resolver Any))}) - -(abstract: #export Semaphore - (Atom State) - - {#.doc "A tool for controlling access to resources by multiple concurrent processes."} - - (def: most_positions_possible - (.nat (\ i.interval top))) - - (def: #export (semaphore initial_open_positions) - (-> Nat Semaphore) - (let [max_positions (n.min initial_open_positions - ..most_positions_possible)] - (:abstraction (atom.atom {#max_positions max_positions - #open_positions (.int max_positions) - #waiting_list queue.empty})))) - - (def: #export (wait semaphore) - (Ex [k] (-> Semaphore (Promise Any))) - (let [semaphore (:representation semaphore) - [signal sink] (: [(Promise Any) (Resolver Any)] - (promise.promise []))] - (exec (io.run - (with_expansions [<had_open_position?> (as_is (get@ #open_positions) (i.> -1))] - (do io.monad - [[_ state'] (atom.update (|>> (update@ #open_positions dec) - (if> [<had_open_position?>] - [] - [(update@ #waiting_list (queue.push sink))])) - semaphore)] - (with_expansions [<go_ahead> (sink []) - <get_in_line> (wrap false)] - (if (|> state' <had_open_position?>) - <go_ahead> - <get_in_line>))))) - signal))) - - (exception: #export (semaphore_is_maxed_out {max_positions Nat}) - (exception.report - ["Max Positions" (%.nat max_positions)])) - - (def: #export (signal semaphore) - (Ex [k] (-> Semaphore (Promise (Try Int)))) - (let [semaphore (:representation semaphore)] - (promise.future - (do {! io.monad} - [[pre post] (atom.update (function (_ state) - (if (i.= (.int (get@ #max_positions state)) - (get@ #open_positions state)) - state - (|> state - (update@ #open_positions inc) - (update@ #waiting_list queue.pop)))) - semaphore)] - (if (is? pre post) - (wrap (exception.throw ..semaphore_is_maxed_out [(get@ #max_positions pre)])) - (do ! - [_ (case (queue.peek (get@ #waiting_list pre)) - #.None - (wrap true) - - (#.Some sink) - (sink []))] - (wrap (#try.Success (get@ #open_positions post))))))))) - ) - -(abstract: #export Mutex - Semaphore - - {#.doc "A mutual-exclusion lock that can only be acquired by one process at a time."} - - (def: #export (mutex _) - (-> Any Mutex) - (:abstraction (semaphore 1))) - - (def: acquire - (-> Mutex (Promise Any)) - (|>> :representation ..wait)) - - (def: release - (-> Mutex (Promise Any)) - (|>> :representation ..signal)) - - (def: #export (synchronize mutex procedure) - (All [a] (-> Mutex (IO (Promise a)) (Promise a))) - (do promise.monad - [_ (..acquire mutex) - output (io.run procedure) - _ (..release mutex)] - (wrap output))) - ) - -(def: #export limit - (refinement.refinement (n.> 0))) - -(type: #export Limit - (:~ (refinement.type limit))) - -(abstract: #export Barrier - {#limit Limit - #count (Atom Nat) - #start_turnstile Semaphore - #end_turnstile Semaphore} - - {#.doc "A barrier that blocks all processes from proceeding until a given number of processes are parked at the barrier."} - - (def: #export (barrier limit) - (-> Limit Barrier) - (:abstraction {#limit limit - #count (atom.atom 0) - #start_turnstile (..semaphore 0) - #end_turnstile (..semaphore 0)})) - - (def: (un_block times turnstile) - (-> Nat Semaphore (Promise Any)) - (loop [step 0] - (if (n.< times step) - (do promise.monad - [outcome (..signal turnstile)] - (recur (inc step))) - (\ promise.monad wrap [])))) - - (template [<phase> <update> <goal> <turnstile>] - [(def: (<phase> (^:representation barrier)) - (-> Barrier (Promise Any)) - (do promise.monad - [#let [limit (refinement.un_refine (get@ #limit barrier)) - goal <goal> - [_ count] (io.run (atom.update <update> (get@ #count barrier))) - reached? (n.= goal count)]] - (if reached? - (..un_block (dec limit) (get@ <turnstile> barrier)) - (..wait (get@ <turnstile> barrier)))))] - - [start inc limit #start_turnstile] - [end dec 0 #end_turnstile] - ) - - (def: #export (block barrier) - (-> Barrier (Promise Any)) - (do promise.monad - [_ (..start barrier)] - (..end barrier))) - ) diff --git a/stdlib/source/lux/control/concurrency/stm.lux b/stdlib/source/lux/control/concurrency/stm.lux deleted file mode 100644 index d375059a4..000000000 --- a/stdlib/source/lux/control/concurrency/stm.lux +++ /dev/null @@ -1,273 +0,0 @@ -(.module: - [lux #* - [abstract - [functor (#+ Functor)] - [apply (#+ Apply)] - ["." monad (#+ Monad do)]] - [control - ["." io (#+ IO io)] - ["." try]] - [data - ["." product] - ["." maybe] - [collection - ["." list]]] - [type - abstract]] - [// - ["." atom (#+ Atom atom)] - ["." promise (#+ Promise Resolver)] - ["." frp (#+ Channel Sink)]]) - -(type: (Observer a) - (-> a (IO Any))) - -(abstract: #export (Var a) - (Atom [a (List (Sink a))]) - - {#.doc "A mutable cell containing a value, and observers that will be alerted of any change to it."} - - (def: #export (var value) - {#.doc "Creates a new STM var, with a default value."} - (All [a] (-> a (Var a))) - (:abstraction (atom.atom [value (list)]))) - - (def: read! - (All [a] (-> (Var a) a)) - (|>> :representation atom.read io.run product.left)) - - (def: (un_follow sink var) - (All [a] (-> (Sink a) (Var a) (IO Any))) - (do io.monad - [_ (atom.update (function (_ [value observers]) - [value (list.filter (|>> (is? sink) not) observers)]) - (:representation var))] - (wrap []))) - - (def: (write! new_value var) - (All [a] (-> a (Var a) (IO Any))) - (do {! io.monad} - [#let [var' (:representation var)] - (^@ old [old_value observers]) (atom.read var') - succeeded? (atom.compare_and_swap old [new_value observers] var')] - (if succeeded? - (do ! - [_ (monad.map ! (function (_ sink) - (do ! - [result (\ sink feed new_value)] - (case result - (#try.Success _) - (wrap []) - - (#try.Failure _) - (un_follow sink var)))) - observers)] - (wrap [])) - (write! new_value var)))) - - (def: #export (follow target) - {#.doc "Creates a channel that will receive all changes to the value of the given var."} - (All [a] (-> (Var a) (IO [(Channel a) (Sink a)]))) - (do io.monad - [#let [[channel sink] (frp.channel [])] - _ (atom.update (function (_ [value observers]) - [value (#.Cons sink observers)]) - (:representation target))] - (wrap [channel sink]))) - ) - -(type: (Tx_Frame a) - {#var (Var a) - #original a - #current a}) - -(type: Tx - (List (Ex [a] (Tx_Frame a)))) - -(type: #export (STM a) - {#.doc "A computation which updates a transaction and produces a value."} - (-> Tx [Tx a])) - -(def: (find_var_value var tx) - (All [a] (-> (Var a) Tx (Maybe a))) - (|> tx - (list.find (function (_ [_var _original _current]) - (is? (:as (Var Any) var) - (:as (Var Any) _var)))) - (\ maybe.monad map (function (_ [_var _original _current]) - _current)) - (:assume) - )) - -(def: #export (read var) - (All [a] (-> (Var a) (STM a))) - (function (_ tx) - (case (find_var_value var tx) - (#.Some value) - [tx value] - - #.None - (let [value (..read! var)] - [(#.Cons [var value value] tx) - value])))) - -(def: (update_tx_value var value tx) - (All [a] (-> (Var a) a Tx Tx)) - (case tx - #.Nil - #.Nil - - (#.Cons [_var _original _current] tx') - (if (is? (:as (Var Any) var) - (:as (Var Any) _var)) - (#.Cons {#var (:as (Var Any) _var) - #original (:as Any _original) - #current (:as Any value)} - tx') - (#.Cons {#var _var - #original _original - #current _current} - (update_tx_value var value tx'))))) - -(def: #export (write value var) - {#.doc "Writes value to var."} - (All [a] (-> a (Var a) (STM Any))) - (function (_ tx) - (case (find_var_value var tx) - (#.Some _) - [(update_tx_value var value tx) - []] - - #.None - [(#.Cons [var (..read! var) value] tx) - []]))) - -(implementation: #export functor - (Functor STM) - - (def: (map f fa) - (function (_ tx) - (let [[tx' a] (fa tx)] - [tx' (f a)])))) - -(implementation: #export apply - (Apply STM) - - (def: &functor ..functor) - - (def: (apply ff fa) - (function (_ tx) - (let [[tx' f] (ff tx) - [tx'' a] (fa tx')] - [tx'' (f a)])))) - -(implementation: #export monad - (Monad STM) - - (def: &functor ..functor) - - (def: (wrap a) - (function (_ tx) - [tx a])) - - (def: (join mma) - (function (_ tx) - (let [[tx' ma] (mma tx)] - (ma tx'))))) - -(def: #export (update f var) - {#.doc "Will update a Var's value, and return a tuple with the old and the new values."} - (All [a] (-> (-> a a) (Var a) (STM [a a]))) - (do ..monad - [a (..read var) - #let [a' (f a)] - _ (..write a' var)] - (wrap [a a']))) - -(def: (can_commit? tx) - (-> Tx Bit) - (list.every? (function (_ [_var _original _current]) - (is? _original (..read! _var))) - tx)) - -(def: (commit_var! [_var _original _current]) - (-> (Ex [a] (Tx_Frame a)) (IO Any)) - (if (is? _original _current) - (io []) - (..write! _current _var))) - -(def: fresh_tx Tx (list)) - -(type: (Commit a) - [(STM a) - (Promise a) - (Resolver a)]) - -(def: pending_commits - (Atom (Rec Commits - [(Promise [(Ex [a] (Commit a)) Commits]) - (Resolver [(Ex [a] (Commit a)) Commits])])) - (atom (promise.promise []))) - -(def: commit_processor_flag - (Atom Bit) - (atom #0)) - -(def: (issue_commit commit) - (All [a] (-> (Commit a) (IO Any))) - (let [entry [commit (promise.promise [])]] - (do {! io.monad} - [|commits|&resolve (atom.read pending_commits)] - (loop [[|commits| resolve] |commits|&resolve] - (do ! - [|commits| (promise.poll |commits|)] - (case |commits| - #.None - (do io.monad - [resolved? (resolve entry)] - (if resolved? - (atom.write (product.right entry) pending_commits) - (recur |commits|&resolve))) - - (#.Some [head tail]) - (recur tail))))))) - -(def: (process_commit commit) - (All [a] (-> (Commit a) (IO Any))) - (let [[stm_proc output resolve] commit - [finished_tx value] (stm_proc fresh_tx)] - (if (can_commit? finished_tx) - (do {! io.monad} - [_ (monad.map ! commit_var! finished_tx)] - (resolve value)) - (issue_commit commit)))) - -(def: init_processor! - (IO Any) - (do {! io.monad} - [flag (atom.read commit_processor_flag)] - (if flag - (wrap []) - (do ! - [was_first? (atom.compare_and_swap flag #1 commit_processor_flag)] - (if was_first? - (do ! - [[promise resolve] (atom.read pending_commits)] - (promise.await (function (recur [head [tail _resolve]]) - (do ! - [_ (process_commit head)] - (promise.await recur tail))) - promise)) - (wrap []))) - ))) - -(def: #export (commit stm_proc) - {#.doc (doc "Commits a transaction and returns its result (asynchronously)." - "Note that a transaction may be re-run an indeterminate number of times if other transactions involving the same variables successfully commit first." - "For this reason, it's important to note that transactions must be free from side-effects, such as I/O.")} - (All [a] (-> (STM a) (Promise a))) - (let [[output resolver] (promise.promise [])] - (exec (io.run (do io.monad - [_ init_processor!] - (issue_commit [stm_proc output resolver]))) - output))) diff --git a/stdlib/source/lux/control/concurrency/thread.lux b/stdlib/source/lux/control/concurrency/thread.lux deleted file mode 100644 index d6dc71c37..000000000 --- a/stdlib/source/lux/control/concurrency/thread.lux +++ /dev/null @@ -1,169 +0,0 @@ -(.module: - [lux #* - ["@" target] - ["." ffi] - [abstract - ["." monad (#+ do)]] - [control - ["." try] - ["." exception (#+ exception:)] - ["." io (#+ IO io)]] - [data - ["." text] - [collection - ["." list]]] - [math - [number - ["n" nat] - ["f" frac]]] - [time - ["." instant]]] - [// - ["." atom (#+ Atom)]]) - -(with_expansions [<jvm> (as_is (ffi.import: java/lang/Object) - - (ffi.import: java/lang/Runtime - ["#::." - (#static getRuntime [] java/lang/Runtime) - (availableProcessors [] int)]) - - (ffi.import: java/lang/Runnable) - - (ffi.import: java/util/concurrent/TimeUnit - ["#::." - (#enum MILLISECONDS)]) - - (ffi.import: java/util/concurrent/Executor - ["#::." - (execute [java/lang/Runnable] #io void)]) - - (ffi.import: (java/util/concurrent/ScheduledFuture a)) - - (ffi.import: java/util/concurrent/ScheduledThreadPoolExecutor - ["#::." - (new [int]) - (schedule [java/lang/Runnable long java/util/concurrent/TimeUnit] #io (java/util/concurrent/ScheduledFuture java/lang/Object))]))] - (for {@.old (as_is <jvm>) - @.jvm (as_is <jvm>) - - @.js - (as_is (ffi.import: (setTimeout [ffi.Function ffi.Number] #io Any))) - - @.python - (ffi.import: threading/Timer - ["#::." - (new [ffi.Float ffi.Function]) - (start [] #io #? Any)])} - - ## Default - (type: Thread - {#creation Nat - #delay Nat - #action (IO Any)}) - )) - -(def: #export parallelism - Nat - (with_expansions [<jvm> (|> (java/lang/Runtime::getRuntime) - (java/lang/Runtime::availableProcessors) - .nat)] - (for {@.old <jvm> - @.jvm <jvm>} - ## Default - 1))) - -(with_expansions [<jvm> (as_is (def: runner - java/util/concurrent/ScheduledThreadPoolExecutor - (java/util/concurrent/ScheduledThreadPoolExecutor::new (.int ..parallelism))))] - (for {@.old <jvm> - @.jvm <jvm> - @.js (as_is) - @.python (as_is)} - - ## Default - (def: runner - (Atom (List Thread)) - (atom.atom (list))))) - -(def: (execute! action) - (-> (IO Any) Any) - (case (try (io.run action)) - (#try.Failure error) - (exec - ("lux io log" ($_ "lux text concat" - "ERROR DURING THREAD EXECUTION:" text.new_line - error)) - []) - - (#try.Success _) - [])) - -(def: #export (schedule milli_seconds action) - (-> Nat (IO Any) (IO Any)) - (with_expansions [<jvm> (as_is (let [runnable (ffi.object [] [java/lang/Runnable] - [] - (java/lang/Runnable [] (run self) void - (..execute! action)))] - (case milli_seconds - 0 (java/util/concurrent/Executor::execute runnable runner) - _ (java/util/concurrent/ScheduledThreadPoolExecutor::schedule runnable (.int milli_seconds) java/util/concurrent/TimeUnit::MILLISECONDS - runner))))] - (for {@.old <jvm> - @.jvm <jvm> - - @.js - (..setTimeout [(ffi.closure [] (..execute! action)) - (n.frac milli_seconds)]) - - @.python - (do io.monad - [_ (|> (ffi.lambda [] (..execute! action)) - [(|> milli_seconds n.frac (f./ +1,000.0))] - threading/Timer::new - (threading/Timer::start []))] - (wrap []))} - - ## Default - (do {! io.monad} - [now (\ ! map (|>> instant.to_millis .nat) instant.now) - _ (atom.update (|>> (#.Cons {#creation now - #delay milli_seconds - #action action})) - ..runner)] - (wrap []))))) - -(for {@.old (as_is) - @.jvm (as_is) - @.js (as_is) - @.python (as_is)} - - ## Default - (as_is (exception: #export cannot_continue_running_threads) - - (def: #export run! - (IO Any) - (loop [_ []] - (do {! io.monad} - [threads (atom.read ..runner)] - (case threads - ## And... we're done! - #.Nil - (wrap []) - - _ - (do ! - [now (\ ! map (|>> instant.to_millis .nat) instant.now) - #let [[ready pending] (list.partition (function (_ thread) - (|> (get@ #creation thread) - (n.+ (get@ #delay thread)) - (n.<= now))) - threads)] - swapped? (atom.compare_and_swap threads pending ..runner)] - (if swapped? - (do ! - [_ (monad.map ! (|>> (get@ #action) ..execute! io.io) ready)] - (recur [])) - (error! (exception.construct ..cannot_continue_running_threads [])))) - )))) - )) diff --git a/stdlib/source/lux/control/continuation.lux b/stdlib/source/lux/control/continuation.lux deleted file mode 100644 index 03a9607ce..000000000 --- a/stdlib/source/lux/control/continuation.lux +++ /dev/null @@ -1,99 +0,0 @@ -(.module: - [lux #* - [abstract - [functor (#+ Functor)] - [apply (#+ Apply)] - [monad (#+ Monad do)]] - [control - ["." function] - [parser - ["s" code]]] - [macro (#+ with_gensyms) - [syntax (#+ syntax:)] - ["." code]]]) - -(type: #export (Cont i o) - {#.doc "Continuations."} - (-> (-> i o) o)) - -(def: #export (continue next cont) - {#.doc "Continues a continuation thunk."} - (All [i o] (-> (-> i o) (Cont i o) o)) - (cont next)) - -(def: #export (run cont) - {#.doc "Forces a continuation thunk to be evaluated."} - (All [a] (-> (Cont a a) a)) - (cont function.identity)) - -(def: #export (call/cc f) - {#.doc "Call with current continuation."} - (All [a b z] - (-> (-> (-> a (Cont b z)) - (Cont a z)) - (Cont a z))) - (function (_ k) - (f (function (_ a) (function (_ _) (k a))) - k))) - -(syntax: #export (pending expr) - {#.doc (doc "Turns any expression into a function that is pending a continuation." - (pending (some_function some_input)))} - (with_gensyms [g!_ g!k] - (wrap (list (` (.function ((~ g!_) (~ g!k)) ((~ g!k) (~ expr)))))))) - -(def: #export (reset scope) - (All [i o] (-> (Cont i i) (Cont i o))) - (function (_ k) - (k (run scope)))) - -(def: #export (shift f) - (All [a] - (-> (-> (-> a (Cont a a)) - (Cont a a)) - (Cont a a))) - (function (_ oc) - (f (function (_ a) (function (_ ic) (ic (oc a)))) - function.identity))) - -(implementation: #export functor - (All [o] (Functor (All [i] (Cont i o)))) - - (def: (map f fv) - (function (_ k) (fv (function.compose k f))))) - -(implementation: #export apply - (All [o] (Apply (All [i] (Cont i o)))) - - (def: &functor ..functor) - - (def: (apply ff fv) - (function (_ k) - (|> (k (f v)) - (function (_ v)) fv - (function (_ f)) ff)))) - -(implementation: #export monad - (All [o] (Monad (All [i] (Cont i o)))) - - (def: &functor ..functor) - - (def: (wrap value) - (function (_ k) (k value))) - - (def: (join ffa) - (function (_ k) - (ffa (continue k))))) - -(def: #export (portal init) - (All [i o z] - (-> i - (Cont [(-> i (Cont o z)) - i] - z))) - (call/cc (function (_ k) - (do ..monad - [#let [nexus (function (nexus val) - (k [nexus val]))] - _ (k [nexus init])] - (wrap (undefined)))))) diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux deleted file mode 100644 index 0f5f62aa3..000000000 --- a/stdlib/source/lux/control/exception.lux +++ /dev/null @@ -1,183 +0,0 @@ -(.module: {#.doc "Exception-handling functionality."} - [lux #* - ["." macro] - ["." meta] - [abstract - [monad (#+ do)]] - [control - ["p" parser - ["s" code (#+ Parser)]]] - [data - ["." maybe] - ["." product] - ["." text ("#\." monoid)] - [collection - ["." list ("#\." functor fold)]]] - [macro - ["." code] - [syntax (#+ syntax:) - ["|.|" export] - ["|.|" input] - ["." type #_ - ["|#_.|" variable]]]] - [math - [number - ["n" nat ("#\." decimal)]]]] - [// - ["//" try (#+ Try)]]) - -(type: #export (Exception a) - {#.doc "An exception provides a way to decorate error messages."} - {#label Text - #constructor (-> a Text)}) - -(def: #export (match? exception error) - (All [e] (-> (Exception e) Text Bit)) - (text.starts_with? (get@ #label exception) error)) - -(def: #export (catch exception then try) - {#.doc (doc "If a particular exception is detected on a possibly-erroneous value, handle it." - "If no exception was detected, or a different one from the one being checked, then pass along the original value.")} - (All [e a] - (-> (Exception e) (-> Text a) (Try a) - (Try a))) - (case try - (#//.Success output) - (#//.Success output) - - (#//.Failure error) - (let [reference (get@ #label exception)] - (if (text.starts_with? reference error) - (#//.Success (|> error - (text.clip' (text.size reference)) - maybe.assume - then)) - (#//.Failure error))))) - -(def: #export (otherwise to_do try) - {#.doc "If no handler could be found to catch the exception, then run a function as a last-resort measure."} - (All [a] - (-> (-> Text a) (Try a) a)) - (case try - (#//.Success output) - output - - (#//.Failure error) - (to_do error))) - -(def: #export (return value) - {#.doc "A way to lift normal values into the error-handling context."} - (All [a] (-> a (Try a))) - (#//.Success value)) - -(def: #export (construct exception message) - {#.doc "Constructs an exception."} - (All [e] (-> (Exception e) e Text)) - ((get@ #..constructor exception) message)) - -(def: #export (throw exception message) - {#.doc "Decorate an error message with an Exception and lift it into the error-handling context."} - (All [e a] (-> (Exception e) e (Try a))) - (#//.Failure (..construct exception message))) - -(def: #export (assert exception message test) - (All [e] (-> (Exception e) e Bit (Try Any))) - (if test - (#//.Success []) - (..throw exception message))) - -(syntax: #export (exception: {export |export|.parser} - {t_vars (p.default (list) (s.tuple (p.some |type_variable|.parser)))} - {[name inputs] (p.either (p.and s.local_identifier (wrap (list))) - (s.form (p.and s.local_identifier (p.some |input|.parser))))} - {body (p.maybe s.any)}) - {#.doc (doc "Define a new exception type." - "It mostly just serves as a way to tag error messages for later catching." - "" - "Simple case:" - (exception: #export some_exception) - "" - "Complex case:" - (exception: #export [optional type variables] (some_exception {optional Text} {arguments Int}) - optional_body))} - (macro.with_gensyms [g!descriptor] - (do meta.monad - [current_module meta.current_module_name - #let [descriptor ($_ text\compose "{" current_module "." name "}" text.new_line) - g!self (code.local_identifier name)]] - (wrap (list (` (def: (~+ (|export|.format export)) - (~ g!self) - (All [(~+ (list\map |type_variable|.format t_vars))] - (..Exception [(~+ (list\map (get@ #|input|.type) inputs))])) - (let [(~ g!descriptor) (~ (code.text descriptor))] - {#..label (~ g!descriptor) - #..constructor (function ((~ g!self) [(~+ (list\map (get@ #|input|.binding) inputs))]) - ((~! text\compose) (~ g!descriptor) - (~ (maybe.default (' "") body))))}))))) - ))) - -(def: (report' entries) - (-> (List [Text Text]) Text) - (let [header_separator ": " - largest_header_size (list\fold (function (_ [header _] max) - (n.max (text.size header) max)) - 0 - entries) - on_new_line (|> " " - (list.repeat (n.+ (text.size header_separator) - largest_header_size)) - (text.join_with "") - (text\compose text.new_line))] - (|> entries - (list\map (function (_ [header message]) - (let [padding (|> " " - (list.repeat (n.- (text.size header) - largest_header_size)) - (text.join_with ""))] - (|> message - (text.replace_all text.new_line on_new_line) - ($_ text\compose padding header header_separator))))) - (text.join_with text.new_line)))) - -(syntax: #export (report {entries (p.many (s.tuple (p.and s.any s.any)))}) - (wrap (list (` ((~! report') (list (~+ (|> entries - (list\map (function (_ [header message]) - (` [(~ header) (~ message)]))))))))))) - -(def: #export (enumerate format entries) - (All [a] - (-> (-> a Text) (List a) Text)) - (|> entries - list.enumeration - (list\map (function (_ [index entry]) - [(n\encode index) (format entry)])) - report')) - -(def: separator - (let [gap ($_ "lux text concat" text.new_line text.new_line) - horizontal_line (|> "-" (list.repeat 64) (text.join_with ""))] - ($_ "lux text concat" - gap - horizontal_line - gap))) - -(def: (decorate prelude error) - (-> Text Text Text) - ($_ "lux text concat" - prelude - ..separator - error)) - -(def: #export (with exception message computation) - (All [e a] (-> (Exception e) e (Try a) (Try a))) - (case computation - (#//.Failure error) - (#//.Failure (case error - "" - (..construct exception message) - - _ - (..decorate (..construct exception message) error))) - - success - success)) diff --git a/stdlib/source/lux/control/function.lux b/stdlib/source/lux/control/function.lux deleted file mode 100644 index 56e54509c..000000000 --- a/stdlib/source/lux/control/function.lux +++ /dev/null @@ -1,46 +0,0 @@ -(.module: - [lux #* - [abstract - [monoid (#+ Monoid)]]]) - -(def: #export identity - {#.doc (doc "Identity function." - "Does nothing to its argument and just returns it." - (is? (identity value) - value))} - (All [a] (-> a a)) - (|>>)) - -(def: #export (compose f g) - {#.doc (doc "Function composition." - (= ((compose f g) "foo") - (f (g "foo"))))} - (All [a b c] - (-> (-> b c) (-> a b) (-> a c))) - (|>> g f)) - -(def: #export (constant value) - {#.doc (doc "Create constant functions." - (= ((constant "foo") "bar") - "foo"))} - (All [o] (-> o (All [i] (-> i o)))) - (function (_ _) value)) - -(def: #export (flip f) - {#.doc (doc "Flips the order of the arguments of a function." - (= ((flip f) "foo" "bar") - (f "bar" "foo")))} - (All [a b c] - (-> (-> a b c) (-> b a c))) - (function (_ x y) (f y x))) - -(def: #export (apply input function) - (All [i o] - (-> i (-> i o) o)) - (function input)) - -(implementation: #export monoid - (All [a] (Monoid (-> a a))) - - (def: identity ..identity) - (def: compose ..compose)) diff --git a/stdlib/source/lux/control/function/contract.lux b/stdlib/source/lux/control/function/contract.lux deleted file mode 100644 index fef0280c7..000000000 --- a/stdlib/source/lux/control/function/contract.lux +++ /dev/null @@ -1,51 +0,0 @@ -(.module: - [lux #* - [control - ["." exception (#+ exception:)]] - [data - [text - ["%" format (#+ format)]]] - [macro (#+ with_gensyms) - [syntax (#+ syntax:)] - ["." code]] - [math - [number - ["i" int]]]]) - -(template [<name>] - [(exception: (<name> {condition Code}) - (exception.report - ["Condition" (%.code condition)]))] - - [pre_condition_failed] - [post_condition_failed] - ) - -(def: (assert! message test) - (-> Text Bit []) - (if test - [] - (error! message))) - -(syntax: #export (pre test expr) - {#.doc (doc "Pre-conditions." - "Given a test and an expression to run, only runs the expression if the test passes." - "Otherwise, an error is raised." - (pre (i.= +4 (i.+ +2 +2)) - (foo +123 +456 +789)))} - (wrap (list (` (exec ((~! ..assert!) (~ (code.text (exception.construct ..pre_condition_failed test))) - (~ test)) - (~ expr)))))) - -(syntax: #export (post test expr) - {#.doc (doc "Post-conditions." - "Given a predicate and an expression to run, evaluates the expression and then tests the output with the predicate." - "If the predicate returns #1, returns the value of the expression." - "Otherwise, an error is raised." - (post i.even? - (i.+ +2 +2)))} - (with_gensyms [g!output] - (wrap (list (` (let [(~ g!output) (~ expr)] - (exec ((~! ..assert!) (~ (code.text (exception.construct ..post_condition_failed test))) - ((~ test) (~ g!output))) - (~ g!output)))))))) diff --git a/stdlib/source/lux/control/function/memo.lux b/stdlib/source/lux/control/function/memo.lux deleted file mode 100644 index 324fae7d1..000000000 --- a/stdlib/source/lux/control/function/memo.lux +++ /dev/null @@ -1,63 +0,0 @@ -## Inspired by; -## "The Different Aspects of Monads and Mixins" by Bruno C. d. S. Oliveira - -(.module: - [lux #* - [abstract - [hash (#+ Hash)] - [monad (#+ do)]] - [control - ["." state (#+ State)]] - [data - ["." product] - [collection - ["." dictionary (#+ Dictionary)]]]] - ["." // #_ - ["#" mixin (#+ Mixin Recursive)]]) - -(def: #export memoization - (All [i o] - (Mixin i (State (Dictionary i o) o))) - (function (_ delegate recur) - (function (_ input) - (do {! state.monad} - [memory state.get] - (case (dictionary.get input memory) - (#.Some output) - (wrap output) - - #.None - (do ! - [output (delegate input) - _ (state.update (dictionary.put input output))] - (wrap output))))))) - -(type: #export (Memo i o) - (Recursive i (State (Dictionary i o) o))) - -(def: #export (open memo) - {#.doc (doc "Memoization where the memoized results can be re-used accross invocations.")} - (All [i o] - (:let [Memory (Dictionary i o)] - (-> (Memo i o) (-> [Memory i] [Memory o])))) - (let [memo (//.mixin (//.inherit ..memoization (//.from-recursive memo)))] - (function (_ [memory input]) - (|> input memo (state.run memory))))) - -(def: #export (closed hash memo) - {#.doc (doc "Memoization confined to a single invocation to the function (not counting any subsequent recursive invocations)." - "Memoized results will be re-used during recursive invocations, but cannot be accessed after the main invocation has ended.")} - (All [i o] - (-> (Hash i) (Memo i o) (-> i o))) - (let [memo (//.mixin (//.inherit ..memoization (//.from-recursive memo))) - empty (dictionary.new hash)] - (|>> memo (state.run empty) product.right))) - -(def: #export (none hash memo) - {#.doc (doc "No memoization at all." - "This is useful as a test control when measuring the effect of using memoization.")} - (All [i o] - (-> (Hash i) (Memo i o) (-> i o))) - (let [memo (//.mixin (//.from-recursive memo)) - empty (dictionary.new hash)] - (|>> memo (state.run empty) product.right))) diff --git a/stdlib/source/lux/control/function/mixin.lux b/stdlib/source/lux/control/function/mixin.lux deleted file mode 100644 index 4d1c9fcb8..000000000 --- a/stdlib/source/lux/control/function/mixin.lux +++ /dev/null @@ -1,63 +0,0 @@ -## Inspired by; -## "The Different Aspects of Monads and Mixins" by Bruno C. d. S. Oliveira - -(.module: - [lux #* - [abstract - [monoid (#+ Monoid)] - [predicate (#+ Predicate)] - [monad (#+ Monad do)]]]) - -(type: #export (Mixin i o) - (-> (-> i o) (-> i o) (-> i o))) - -(def: #export (mixin f) - (All [i o] (-> (Mixin i o) (-> i o))) - (function (mix input) - ((f mix mix) input))) - -(def: #export nothing - Mixin - (function (_ delegate recur) - delegate)) - -(def: #export (inherit parent child) - (All [i o] (-> (Mixin i o) (Mixin i o) (Mixin i o))) - (function (_ delegate recur) - (parent (child delegate recur) recur))) - -(implementation: #export monoid - (All [i o] (Monoid (Mixin i o))) - - (def: identity ..nothing) - (def: compose ..inherit)) - -(def: #export (advice when then) - (All [i o] (-> (Predicate i) (Mixin i o) (Mixin i o))) - (function (_ delegate recur input) - (if (when input) - ((then delegate recur) input) - (delegate input)))) - -(def: #export (before monad action) - (All [! i o] (-> (Monad !) (-> i (! Any)) (Mixin i (! o)))) - (function (_ delegate recur input) - (do monad - [_ (action input)] - (delegate input)))) - -(def: #export (after monad action) - (All [! i o] (-> (Monad !) (-> i o (! Any)) (Mixin i (! o)))) - (function (_ delegate recur input) - (do monad - [output (delegate input) - _ (action input output)] - (wrap output)))) - -(type: #export (Recursive i o) - (-> (-> i o) (-> i o))) - -(def: #export (from-recursive recursive) - (All [i o] (-> (Recursive i o) (Mixin i o))) - (function (_ delegate recur) - (recursive recur))) diff --git a/stdlib/source/lux/control/function/mutual.lux b/stdlib/source/lux/control/function/mutual.lux deleted file mode 100644 index c1960253a..000000000 --- a/stdlib/source/lux/control/function/mutual.lux +++ /dev/null @@ -1,157 +0,0 @@ -(.module: - [lux (#- Definition let def:) - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["<>" parser ("#\." monad) - ["<.>" code (#+ Parser)]]] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)] - [dictionary - ["." plist (#+ PList)]]]] - ["." macro - ["." local] - ["." code] - [syntax (#+ syntax:) - ["." export] - ["." declaration (#+ Declaration)]]]] - ["." //]) - -(type: Mutual - {#declaration Declaration - #type Code - #body Code}) - -(.def: mutual - (Parser [Declaration Code Code]) - ($_ <>.and - declaration.parser - <code>.any - <code>.any - )) - -(.def: (mutual_definition context g!context [g!name mutual]) - (-> (List Code) Code [Code Mutual] Code) - (` (function ((~ g!name) (~ g!context)) - (.let [[(~+ context)] (~ g!context)] - (function (~ (declaration.format (get@ #declaration mutual))) - (~ (get@ #body mutual))))))) - -(.def: (macro g!context g!self) - (-> Code Code Macro) - (<| (:as Macro) - (: Macro') - (function (_ parameters) - (\ meta.monad wrap (list (` (((~ g!self) (~ g!context)) (~+ parameters)))))))) - -(syntax: #export (let {functions (<code>.tuple (<>.some ..mutual))} - body) - (case functions - #.Nil - (wrap (list body)) - - (#.Cons mutual #.Nil) - (.let [g!name (|> mutual (get@ [#declaration #declaration.name]) code.local_identifier)] - (wrap (list (` (.let [(~ g!name) (: (~ (get@ #type mutual)) - (function (~ (declaration.format (get@ #declaration mutual))) - (~ (get@ #body mutual))))] - (~ body)))))) - - _ - (macro.with_gensyms [g!context g!output] - (do {! meta.monad} - [here_name meta.current_module_name - hidden_names (monad.map ! (//.constant (macro.gensym "mutual_function#")) - functions) - #let [definitions (list\map (..mutual_definition hidden_names g!context) - (list.zip/2 hidden_names - functions)) - context_types (list\map (function (_ mutual) - (` (-> (~ g!context) (~ (get@ #type mutual))))) - functions) - user_names (list\map (|>> (get@ [#declaration #declaration.name]) code.local_identifier) - functions)] - g!pop (local.push (list\map (function (_ [g!name mutual]) - [[here_name (get@ [#declaration #declaration.name] mutual)] - (..macro g!context g!name)]) - (list.zip/2 hidden_names - functions)))] - (wrap (list (` (.let [(~ g!context) (: (Rec (~ g!context) - [(~+ context_types)]) - [(~+ definitions)]) - [(~+ user_names)] (.let [[(~+ user_names)] (~ g!context)] - [(~+ (list\map (function (_ g!name) - (` ((~ g!name) (~ g!context)))) - user_names))]) - (~ g!output) (~ body)] - (exec (~ g!pop) - (~ g!output)))))))))) - -(type: Definition - {#exported? Bit - #mutual Mutual}) - -(.def: definition - (Parser Definition) - (<code>.tuple (<>.and export.parser - ..mutual))) - -(syntax: #export (def: {functions (<>.many ..definition)}) - (case functions - #.Nil - (wrap (list)) - - (#.Cons definition #.Nil) - (.let [(^slots [#exported? #mutual]) definition - (^slots [#declaration #type #body]) mutual] - (wrap (list (` (.def: - (~+ (export.format exported?)) - (~ (declaration.format declaration)) - (~ type) - (~ body)))))) - - _ - (macro.with_gensyms [g!context g!output] - (do {! meta.monad} - [here_name meta.current_module_name - hidden_names (monad.map ! (//.constant (macro.gensym "mutual_function#")) - functions) - #let [definitions (list\map (..mutual_definition hidden_names g!context) - (list.zip/2 hidden_names - (list\map (get@ #mutual) functions))) - context_types (list\map (function (_ mutual) - (` (-> (~ g!context) (~ (get@ [#mutual #type] mutual))))) - functions) - user_names (list\map (|>> (get@ [#mutual #declaration #declaration.name]) code.local_identifier) - functions)] - g!pop (local.push (list\map (function (_ [g!name mutual]) - [[here_name (get@ [#mutual #declaration #declaration.name] mutual)] - (..macro g!context g!name)]) - (list.zip/2 hidden_names - functions)))] - (wrap (list& (` (.def: (~ g!context) - [(~+ (list\map (get@ [#mutual #type]) functions))] - (.let [(~ g!context) (: (Rec (~ g!context) - [(~+ context_types)]) - [(~+ definitions)]) - [(~+ user_names)] (~ g!context)] - [(~+ (list\map (function (_ g!name) - (` ((~ g!name) (~ g!context)))) - user_names))]))) - g!pop - (list\map (function (_ mutual) - (.let [g!name (|> mutual (get@ [#mutual #declaration #declaration.name]) code.local_identifier)] - (` (.def: - (~+ (export.format (get@ #exported? mutual))) - (~ g!name) - (~ (get@ [#mutual #type] mutual)) - (.let [[(~+ user_names)] (~ g!context)] - (~ g!name)))))) - functions))))))) diff --git a/stdlib/source/lux/control/io.lux b/stdlib/source/lux/control/io.lux deleted file mode 100644 index fea9083ec..000000000 --- a/stdlib/source/lux/control/io.lux +++ /dev/null @@ -1,71 +0,0 @@ -(.module: {#.doc "A method for abstracting I/O and effectful computations to make it safe while writing pure functional code."} - [lux #* - [abstract - [functor (#+ Functor)] - [apply (#+ Apply)] - [monad (#+ Monad do)]] - [control - [parser - ["s" code]]] - [type - abstract] - [macro (#+ with_gensyms) - [syntax (#+ syntax:)] - ["." template]]]) - -(abstract: #export (IO a) - (-> Any a) - - {#.doc "A type that represents synchronous, effectful computations that may interact with the outside world."} - - (def: label - (All [a] (-> (-> Any a) (IO a))) - (|>> :abstraction)) - - (template: (!io computation) - (:abstraction (template.with_locals [g!func g!arg] - (function (g!func g!arg) - computation)))) - - (template: (!run io) - ## creatio ex nihilo - ((:representation io) [])) - - (syntax: #export (io computation) - {#.doc (doc "Delays the evaluation of an expression, by wrapping it in an IO 'thunk'." - "Great for wrapping effectful computations (which will not be performed until the IO is 'run')." - (io (exec - (log! msg) - "Some value...")))} - (with_gensyms [g!func g!arg] - (wrap (list (` ((~! ..label) (function ((~ g!func) (~ g!arg)) - (~ computation)))))))) - - (def: #export run - {#.doc "A way to execute IO computations and perform their side-effects."} - (All [a] (-> (IO a) a)) - (|>> !run)) - - (implementation: #export functor - (Functor IO) - - (def: (map f) - (|>> !run f !io))) - - (implementation: #export apply - (Apply IO) - - (def: &functor ..functor) - - (def: (apply ff fa) - (!io ((!run ff) (!run fa))))) - - (implementation: #export monad - (Monad IO) - - (def: &functor ..functor) - - (def: wrap (|>> !io)) - - (def: join (|>> !run !run !io))) - ) diff --git a/stdlib/source/lux/control/parser.lux b/stdlib/source/lux/control/parser.lux deleted file mode 100644 index fb8e856ae..000000000 --- a/stdlib/source/lux/control/parser.lux +++ /dev/null @@ -1,323 +0,0 @@ -(.module: - [lux (#- or and not) - [abstract - [functor (#+ Functor)] - [apply (#+ Apply)] - [monad (#+ Monad do)] - [codec (#+ Codec)]] - [control - ["." try (#+ Try)]] - [data - ["." product] - [collection - ["." list ("#\." functor monoid)]]] - [math - [number - ["n" nat]]]]) - -(type: #export (Parser s a) - {#.doc "A generic parser."} - (-> s (Try [s a]))) - -(implementation: #export functor - (All [s] (Functor (Parser s))) - - (def: (map f ma) - (function (_ input) - (case (ma input) - (#try.Failure msg) - (#try.Failure msg) - - (#try.Success [input' a]) - (#try.Success [input' (f a)]))))) - -(implementation: #export apply - (All [s] (Apply (Parser s))) - - (def: &functor ..functor) - - (def: (apply ff fa) - (function (_ input) - (case (ff input) - (#try.Success [input' f]) - (case (fa input') - (#try.Success [input'' a]) - (#try.Success [input'' (f a)]) - - (#try.Failure msg) - (#try.Failure msg)) - - (#try.Failure msg) - (#try.Failure msg))))) - -(implementation: #export monad - (All [s] (Monad (Parser s))) - - (def: &functor ..functor) - - (def: (wrap x) - (function (_ input) - (#try.Success [input x]))) - - (def: (join mma) - (function (_ input) - (case (mma input) - (#try.Failure msg) - (#try.Failure msg) - - (#try.Success [input' ma]) - (ma input'))))) - -(def: #export (assert message test) - {#.doc "Fails with the given message if the test is #0."} - (All [s] (-> Text Bit (Parser s Any))) - (function (_ input) - (if test - (#try.Success [input []]) - (#try.Failure message)))) - -(def: #export (maybe parser) - {#.doc "Optionality combinator."} - (All [s a] - (-> (Parser s a) (Parser s (Maybe a)))) - (function (_ input) - (case (parser input) - (#try.Failure _) - (#try.Success [input #.None]) - - (#try.Success [input' x]) - (#try.Success [input' (#.Some x)])))) - -(def: #export (run parser input) - (All [s a] - (-> (Parser s a) s (Try [s a]))) - (parser input)) - -(def: #export (and first second) - {#.doc "Sequencing combinator."} - (All [s a b] - (-> (Parser s a) (Parser s b) (Parser s [a b]))) - (do {! ..monad} - [head first] - (\ ! map (|>> [head]) second))) - -(def: #export (or left right) - {#.doc "Heterogeneous alternative combinator."} - (All [s a b] - (-> (Parser s a) (Parser s b) (Parser s (| a b)))) - (function (_ tokens) - (case (left tokens) - (#try.Success [tokens' output]) - (#try.Success [tokens' (0 #0 output)]) - - (#try.Failure _) - (case (right tokens) - (#try.Success [tokens' output]) - (#try.Success [tokens' (0 #1 output)]) - - (#try.Failure error) - (#try.Failure error))))) - -(def: #export (either this that) - {#.doc "Homogeneous alternative combinator."} - (All [s a] - (-> (Parser s a) (Parser s a) (Parser s a))) - (function (_ tokens) - (case (this tokens) - (#try.Failure _) - (that tokens) - - output - output))) - -(def: #export (some parser) - {#.doc "0-or-more combinator."} - (All [s a] - (-> (Parser s a) (Parser s (List a)))) - (function (_ input) - (case (parser input) - (#try.Failure _) - (#try.Success [input (list)]) - - (#try.Success [input' head]) - (..run (\ ..monad map (|>> (list& head)) - (some parser)) - input')))) - -(def: #export (many parser) - {#.doc "1-or-more combinator."} - (All [s a] - (-> (Parser s a) (Parser s (List a)))) - (|> (..some parser) - (..and parser) - (\ ..monad map (|>> #.Cons)))) - -(def: #export (exactly amount parser) - {#.doc "Parse exactly N times."} - (All [s a] (-> Nat (Parser s a) (Parser s (List a)))) - (case amount - 0 (\ ..monad wrap (list)) - _ (do {! ..monad} - [x parser] - (|> parser - (exactly (dec amount)) - (\ ! map (|>> (#.Cons x))))))) - -(def: #export (at_least amount parser) - {#.doc "Parse at least N times."} - (All [s a] (-> Nat (Parser s a) (Parser s (List a)))) - (do {! ..monad} - [minimum (..exactly amount parser)] - (\ ! map (list\compose minimum) (..some parser)))) - -(def: #export (at_most amount parser) - {#.doc "Parse at most N times."} - (All [s a] (-> Nat (Parser s a) (Parser s (List a)))) - (case amount - 0 (\ ..monad wrap (list)) - _ (function (_ input) - (case (parser input) - (#try.Failure msg) - (#try.Success [input (list)]) - - (#try.Success [input' x]) - (..run (\ ..monad map (|>> (#.Cons x)) - (at_most (dec amount) parser)) - input'))))) - -(def: #export (between from to parser) - {#.doc "Parse between N and M times."} - (All [s a] (-> Nat Nat (Parser s a) (Parser s (List a)))) - (do {! ..monad} - [minimum (..exactly from parser)] - (if (n.< to from) - (\ ! map (list\compose minimum) - (..at_most (n.- from to) parser)) - (wrap minimum)))) - -(def: #export (separated_by separator parser) - {#.doc "Parsers instances of 'parser' that are separated by instances of 'separator'."} - (All [s a b] (-> (Parser s b) (Parser s a) (Parser s (List a)))) - (do {! ..monad} - [?x (..maybe parser)] - (case ?x - #.None - (wrap #.Nil) - - (#.Some x) - (|> parser - (..and separator) - ..some - (\ ! map (|>> (list\map product.right) (#.Cons x))))))) - -(def: #export (not parser) - (All [s a] (-> (Parser s a) (Parser s Any))) - (function (_ input) - (case (parser input) - (#try.Failure msg) - (#try.Success [input []]) - - _ - (#try.Failure "Expected to fail; yet succeeded.")))) - -(def: #export (fail message) - (All [s a] (-> Text (Parser s a))) - (function (_ input) - (#try.Failure message))) - -(def: #export (lift operation) - (All [s a] (-> (Try a) (Parser s a))) - (function (_ input) - (case operation - (#try.Success output) - (#try.Success [input output]) - - (#try.Failure error) - (#try.Failure error)))) - -(def: #export (default value parser) - {#.doc "If the given parser fails, returns the default value."} - (All [s a] (-> a (Parser s a) (Parser s a))) - (function (_ input) - (case (parser input) - (#try.Failure error) - (#try.Success [input value]) - - (#try.Success [input' output]) - (#try.Success [input' output])))) - -(def: #export remaining - (All [s] (Parser s s)) - (function (_ inputs) - (#try.Success [inputs inputs]))) - -(def: #export (rec parser) - {#.doc "Combinator for recursive parser."} - (All [s a] (-> (-> (Parser s a) (Parser s a)) (Parser s a))) - (function (_ inputs) - (..run (parser (rec parser)) inputs))) - -(def: #export (after param subject) - (All [s _ a] (-> (Parser s _) (Parser s a) (Parser s a))) - (do ..monad - [_ param] - subject)) - -(def: #export (before param subject) - (All [s _ a] (-> (Parser s _) (Parser s a) (Parser s a))) - (do ..monad - [output subject - _ param] - (wrap output))) - -(def: #export (filter test parser) - (All [s a] (-> (-> a Bit) (Parser s a) (Parser s a))) - (do ..monad - [output parser - _ (..assert "Constraint failed." (test output))] - (wrap output))) - -(def: #export (parses? parser) - (All [s a] (-> (Parser s a) (Parser s Bit))) - (function (_ input) - (case (parser input) - (#try.Failure error) - (#try.Success [input false]) - - (#try.Success [input' _]) - (#try.Success [input' true])))) - -(def: #export (parses parser) - (All [s a] (-> (Parser s a) (Parser s Any))) - (function (_ input) - (case (parser input) - (#try.Failure error) - (#try.Failure error) - - (#try.Success [input' _]) - (#try.Success [input' []])))) - -(def: #export (speculative parser) - (All [s a] (-> (Parser s a) (Parser s a))) - (function (_ input) - (case (parser input) - (#try.Success [input' output]) - (#try.Success [input output]) - - output - output))) - -(def: #export (codec codec parser) - (All [s a z] (-> (Codec a z) (Parser s a) (Parser s z))) - (function (_ input) - (case (parser input) - (#try.Failure error) - (#try.Failure error) - - (#try.Success [input' to_decode]) - (case (\ codec decode to_decode) - (#try.Failure error) - (#try.Failure error) - - (#try.Success value) - (#try.Success [input' value]))))) diff --git a/stdlib/source/lux/control/parser/analysis.lux b/stdlib/source/lux/control/parser/analysis.lux deleted file mode 100644 index b825354c1..000000000 --- a/stdlib/source/lux/control/parser/analysis.lux +++ /dev/null @@ -1,134 +0,0 @@ -(.module: - [lux (#- nat int rev) - [abstract - [monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["." bit] - ["." name] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)]]] - [math - [number - ["." i64] - ["." nat] - ["." int] - ["." rev] - ["." frac]]] - [tool - [compiler - [arity (#+ Arity)] - [reference (#+) - [variable (#+)]] - [language - [lux - ["/" analysis (#+ Variant Tuple Environment Analysis)]]]]]] - ["." //]) - -(def: (remaining_inputs asts) - (-> (List Analysis) Text) - (format text.new_line "Remaining input: " - (|> asts - (list\map /.%analysis) - (list.interpose " ") - (text.join_with "")))) - -(exception: #export (cannot_parse {input (List Analysis)}) - (exception.report - ["Input" (exception.enumerate /.%analysis input)])) - -(exception: #export (unconsumed_input {input (List Analysis)}) - (exception.report - ["Input" (exception.enumerate /.%analysis input)])) - -(type: #export Parser - (//.Parser (List Analysis))) - -(def: #export (run parser input) - (All [a] (-> (Parser a) (List Analysis) (Try a))) - (case (parser input) - (#try.Failure error) - (#try.Failure error) - - (#try.Success [#.Nil value]) - (#try.Success value) - - (#try.Success [unconsumed _]) - (exception.throw ..unconsumed_input unconsumed))) - -(def: #export any - (Parser Analysis) - (function (_ input) - (case input - #.Nil - (exception.throw ..cannot_parse input) - - (#.Cons [head tail]) - (#try.Success [tail head])))) - -(def: #export end! - {#.doc "Ensures there are no more inputs."} - (Parser Any) - (function (_ tokens) - (case tokens - #.Nil (#try.Success [tokens []]) - _ (#try.Failure (format "Expected list of tokens to be empty!" - (remaining_inputs tokens)))))) - -(def: #export end? - {#.doc "Checks whether there are no more inputs."} - (Parser Bit) - (function (_ tokens) - (#try.Success [tokens (case tokens - #.Nil true - _ false)]))) - -(template [<query> <assertion> <tag> <type> <eq>] - [(def: #export <query> - (Parser <type>) - (function (_ input) - (case input - (^ (list& (<tag> x) input')) - (#try.Success [input' x]) - - _ - (exception.throw ..cannot_parse input)))) - - (def: #export (<assertion> expected) - (-> <type> (Parser Any)) - (function (_ input) - (case input - (^ (list& (<tag> actual) input')) - (if (\ <eq> = expected actual) - (#try.Success [input' []]) - (exception.throw ..cannot_parse input)) - - _ - (exception.throw ..cannot_parse input))))] - - [bit bit! /.bit Bit bit.equivalence] - [nat nat! /.nat Nat nat.equivalence] - [int int! /.int Int int.equivalence] - [rev rev! /.rev Rev rev.equivalence] - [frac frac! /.frac Frac frac.equivalence] - [text text! /.text Text text.equivalence] - [local local! /.variable/local Nat nat.equivalence] - [foreign foreign! /.variable/foreign Nat nat.equivalence] - [constant constant! /.constant Name name.equivalence] - ) - -(def: #export (tuple parser) - (All [a] (-> (Parser a) (Parser a))) - (function (_ input) - (case input - (^ (list& (/.tuple head) tail)) - (do try.monad - [output (..run parser head)] - (#try.Success [tail output])) - - _ - (exception.throw ..cannot_parse input)))) diff --git a/stdlib/source/lux/control/parser/binary.lux b/stdlib/source/lux/control/parser/binary.lux deleted file mode 100644 index 37423b091..000000000 --- a/stdlib/source/lux/control/parser/binary.lux +++ /dev/null @@ -1,274 +0,0 @@ -(.module: - [lux (#- and or nat int rev list type) - [type (#+ :share)] - [abstract - [hash (#+ Hash)] - [monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["/" binary (#+ Binary)] - [text - ["%" format (#+ format)] - [encoding - ["." utf8]]] - [collection - ["." list] - ["." row (#+ Row)] - ["." set (#+ Set)]]] - [macro - ["." template]] - [math - [number - ["n" nat] - ["." frac]]]] - ["." // ("#\." monad)]) - -(type: #export Offset Nat) - -(type: #export Parser - (//.Parser [Offset Binary])) - -(exception: #export (binary_was_not_fully_read {binary_length Nat} {bytes_read Nat}) - (exception.report - ["Binary length" (%.nat binary_length)] - ["Bytes read" (%.nat bytes_read)])) - -(def: #export (run parser input) - (All [a] (-> (Parser a) Binary (Try a))) - (case (parser [0 input]) - (#try.Failure msg) - (#try.Failure msg) - - (#try.Success [[end _] output]) - (let [length (/.size input)] - (if (n.= end length) - (#try.Success output) - (exception.throw ..binary_was_not_fully_read [length end]))))) - -(def: #export end? - (Parser Bit) - (function (_ (^@ input [offset data])) - (#try.Success [input (n.= offset (/.size data))]))) - -(def: #export offset - (Parser Offset) - (function (_ (^@ input [offset data])) - (#try.Success [input offset]))) - -(def: #export remaining - (Parser Nat) - (function (_ (^@ input [offset data])) - (#try.Success [input (n.- offset (/.size data))]))) - -(type: #export Size Nat) - -(def: #export size/8 Size 1) -(def: #export size/16 Size (n.* 2 size/8)) -(def: #export size/32 Size (n.* 2 size/16)) -(def: #export size/64 Size (n.* 2 size/32)) - -(template [<name> <size> <read>] - [(def: #export <name> - (Parser I64) - (function (_ [offset binary]) - (case (<read> offset binary) - (#try.Success data) - (#try.Success [(n.+ <size> offset) binary] data) - - (#try.Failure error) - (#try.Failure error))))] - - [bits/8 ..size/8 /.read/8] - [bits/16 ..size/16 /.read/16] - [bits/32 ..size/32 /.read/32] - [bits/64 ..size/64 /.read/64] - ) - -(template [<name> <type>] - [(def: #export <name> (Parser <type>) ..bits/64)] - - [nat Nat] - [int Int] - [rev Rev] - ) - -(def: #export frac - (Parser Frac) - (//\map frac.from_bits ..bits/64)) - -(exception: #export (invalid_tag {range Nat} {byte Nat}) - (exception.report - ["Tag range" (%.nat range)] - ["Tag value" (%.nat byte)])) - -(template: (!variant <case>+) - (do {! //.monad} - [flag (: (Parser Nat) - ..bits/8)] - (`` (case flag - (^template [<number> <tag> <parser>] - [<number> (\ ! map (|>> <tag>) <parser>)]) - ((~~ (template.splice <case>+))) - _ (//.lift (exception.throw ..invalid_tag [(~~ (template.count <case>+)) flag])))))) - -(def: #export (or left right) - (All [l r] (-> (Parser l) (Parser r) (Parser (| l r)))) - (!variant [[0 #.Left left] - [1 #.Right right]])) - -(def: #export (rec body) - (All [a] (-> (-> (Parser a) (Parser a)) (Parser a))) - (function (_ input) - (let [parser (body (rec body))] - (parser input)))) - -(def: #export any - (Parser Any) - (//\wrap [])) - -(exception: #export (not_a_bit {value Nat}) - (exception.report - ["Expected values" "either 0 or 1"] - ["Actual value" (%.nat value)])) - -(def: #export bit - (Parser Bit) - (do //.monad - [value (: (Parser Nat) - ..bits/8)] - (case value - 0 (wrap #0) - 1 (wrap #1) - _ (//.lift (exception.throw ..not_a_bit [value]))))) - -(def: #export (segment size) - (-> Nat (Parser Binary)) - (function (_ [offset binary]) - (case size - 0 (#try.Success [[offset binary] (/.create 0)]) - _ (|> binary - (/.slice offset size) - (\ try.monad map (|>> [[(n.+ size offset) binary]])))))) - -(template [<name> <bits>] - [(def: #export <name> - (Parser Binary) - (do //.monad - [size (//\map .nat <bits>)] - (..segment size)))] - - [binary/8 ..bits/8] - [binary/16 ..bits/16] - [binary/32 ..bits/32] - [binary/64 ..bits/64] - ) - -(template [<name> <binary>] - [(def: #export <name> - (Parser Text) - (do //.monad - [utf8 <binary>] - (//.lift (\ utf8.codec decode utf8))))] - - [utf8/8 ..binary/8] - [utf8/16 ..binary/16] - [utf8/32 ..binary/32] - [utf8/64 ..binary/64] - ) - -(def: #export text ..utf8/64) - -(template [<name> <bits>] - [(def: #export (<name> valueP) - (All [v] (-> (Parser v) (Parser (Row v)))) - (do //.monad - [count (: (Parser Nat) - <bits>)] - (loop [index 0 - output (:share [v] - (Parser v) - valueP - - (Row v) - row.empty)] - (if (n.< count index) - (do //.monad - [value valueP] - (recur (.inc index) - (row.add value output))) - (//\wrap output)))))] - - [row/8 ..bits/8] - [row/16 ..bits/16] - [row/32 ..bits/32] - [row/64 ..bits/64] - ) - -(def: #export maybe - (All [a] (-> (Parser a) (Parser (Maybe a)))) - (..or ..any)) - -(def: #export (list value) - (All [a] (-> (Parser a) (Parser (List a)))) - (..rec - (|>> (//.and value) - (..or ..any)))) - -(exception: #export set_elements_are_not_unique) - -(def: #export (set hash value) - (All [a] (-> (Hash a) (Parser a) (Parser (Set a)))) - (do //.monad - [raw (..list value) - #let [output (set.from_list hash raw)] - _ (//.assert (exception.construct ..set_elements_are_not_unique []) - (n.= (list.size raw) - (set.size output)))] - (wrap output))) - -(def: #export name - (Parser Name) - (//.and ..text ..text)) - -(def: #export type - (Parser Type) - (..rec - (function (_ type) - (let [pair (//.and type type) - indexed ..nat - quantified (//.and (..list type) type)] - (!variant [[0 #.Primitive (//.and ..text (..list type))] - [1 #.Sum pair] - [2 #.Product pair] - [3 #.Function pair] - [4 #.Parameter indexed] - [5 #.Var indexed] - [6 #.Ex indexed] - [7 #.UnivQ quantified] - [8 #.ExQ quantified] - [9 #.Apply pair] - [10 #.Named (//.and ..name type)]]))))) - -(def: #export location - (Parser Location) - ($_ //.and ..text ..nat ..nat)) - -(def: #export code - (Parser Code) - (..rec - (function (_ recur) - (let [sequence (..list recur)] - (//.and ..location - (!variant [[0 #.Bit ..bit] - [1 #.Nat ..nat] - [2 #.Int ..int] - [3 #.Rev ..rev] - [4 #.Frac ..frac] - [5 #.Text ..text] - [6 #.Identifier ..name] - [7 #.Tag ..name] - [8 #.Form sequence] - [9 #.Tuple sequence] - [10 #.Record (..list (//.and recur recur))]])))))) diff --git a/stdlib/source/lux/control/parser/cli.lux b/stdlib/source/lux/control/parser/cli.lux deleted file mode 100644 index b39b4234c..000000000 --- a/stdlib/source/lux/control/parser/cli.lux +++ /dev/null @@ -1,98 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." try (#+ Try)]] - [data - ["." text ("#\." equivalence) - ["%" format (#+ format)]]]] - ["." //]) - -(type: #export (Parser a) - {#.doc "A command-line interface parser."} - (//.Parser (List Text) a)) - -(def: #export (run parser inputs) - (All [a] (-> (Parser a) (List Text) (Try a))) - (case (//.run parser inputs) - (#try.Success [remaining output]) - (case remaining - #.Nil - (#try.Success output) - - _ - (#try.Failure (format "Remaining CLI inputs: " (text.join_with " " remaining)))) - - (#try.Failure try) - (#try.Failure try))) - -(def: #export any - {#.doc "Just returns the next input without applying any logic."} - (Parser Text) - (function (_ inputs) - (case inputs - (#.Cons arg inputs') - (#try.Success [inputs' arg]) - - _ - (#try.Failure "Cannot parse empty arguments.")))) - -(def: #export (parse parser) - {#.doc "Parses the next input with a parsing function."} - (All [a] (-> (-> Text (Try a)) (Parser a))) - (function (_ inputs) - (do try.monad - [[remaining raw] (any inputs) - output (parser raw)] - (wrap [remaining output])))) - -(def: #export (this reference) - {#.doc "Checks that a token is in the inputs."} - (-> Text (Parser Any)) - (function (_ inputs) - (do try.monad - [[remaining raw] (any inputs)] - (if (text\= reference raw) - (wrap [remaining []]) - (try.fail (format "Missing token: '" reference "'")))))) - -(def: #export (somewhere cli) - {#.doc "Given a parser, tries to parse it somewhere in the inputs (i.e. not necessarily parsing the immediate inputs)."} - (All [a] (-> (Parser a) (Parser a))) - (function (_ inputs) - (loop [immediate inputs] - (case (//.run cli immediate) - (#try.Success [remaining output]) - (#try.Success [remaining output]) - - (#try.Failure try) - (case immediate - #.Nil - (#try.Failure try) - - (#.Cons to_omit immediate') - (do try.monad - [[remaining output] (recur immediate')] - (wrap [(#.Cons to_omit remaining) - output]))))))) - -(def: #export end - {#.doc "Ensures there are no more inputs."} - (Parser Any) - (function (_ inputs) - (case inputs - #.Nil (#try.Success [inputs []]) - _ (#try.Failure (format "Unknown parameters: " (text.join_with " " inputs)))))) - -(def: #export (named name value) - (All [a] (-> Text (Parser a) (Parser a))) - (|> value - (//.after (..this name)) - ..somewhere)) - -(def: #export (parameter [short long] value) - (All [a] (-> [Text Text] (Parser a) (Parser a))) - (|> value - (//.after (//.either (..this short) (..this long))) - ..somewhere)) diff --git a/stdlib/source/lux/control/parser/code.lux b/stdlib/source/lux/control/parser/code.lux deleted file mode 100644 index 86ee0a1d8..000000000 --- a/stdlib/source/lux/control/parser/code.lux +++ /dev/null @@ -1,198 +0,0 @@ -(.module: - [lux (#- nat int rev) - [abstract - ["." monad (#+ do)]] - [control - ["." try (#+ Try)]] - [data - ["." bit] - ["." text ("#\." monoid)] - ["." name] - [collection - ["." list ("#\." functor)]]] - [macro - ["." code ("#\." equivalence)]] - [math - [number - ["." nat] - ["." int] - ["." rev] - ["." frac]]]] - ["." //]) - -(def: (join_pairs pairs) - (All [a] (-> (List [a a]) (List a))) - (case pairs - #.Nil #.Nil - (#.Cons [[x y] pairs']) (list& x y (join_pairs pairs')))) - -(type: #export Parser - {#.doc "A Lux syntax parser."} - (//.Parser (List Code))) - -(def: (remaining_inputs asts) - (-> (List Code) Text) - ($_ text\compose text.new_line "Remaining input: " - (|> asts (list\map code.format) (list.interpose " ") (text.join_with "")))) - -(def: #export any - {#.doc "Just returns the next input without applying any logic."} - (Parser Code) - (function (_ tokens) - (case tokens - #.Nil - (#try.Failure "There are no tokens to parse!") - - (#.Cons [t tokens']) - (#try.Success [tokens' t])))) - -(template [<query> <check> <type> <tag> <eq> <desc>] - [(with_expansions [<failure> (as_is (#try.Failure ($_ text\compose "Cannot parse " <desc> (remaining_inputs tokens))))] - (def: #export <query> - {#.doc (code.text ($_ text\compose "Parses the next " <desc> " input."))} - (Parser <type>) - (function (_ tokens) - (case tokens - (#.Cons [[_ (<tag> x)] tokens']) - (#try.Success [tokens' x]) - - _ - <failure>))) - - (def: #export (<check> expected) - (-> <type> (Parser Any)) - (function (_ tokens) - (case tokens - (#.Cons [[_ (<tag> actual)] tokens']) - (if (\ <eq> = expected actual) - (#try.Success [tokens' []]) - <failure>) - - _ - <failure>))))] - - [bit bit! Bit #.Bit bit.equivalence "bit"] - [nat nat! Nat #.Nat nat.equivalence "nat"] - [int int! Int #.Int int.equivalence "int"] - [rev rev! Rev #.Rev rev.equivalence "rev"] - [frac frac! Frac #.Frac frac.equivalence "frac"] - [text text! Text #.Text text.equivalence "text"] - [identifier identifier! Name #.Identifier name.equivalence "identifier"] - [tag tag! Name #.Tag name.equivalence "tag"] - ) - -(def: #export (this! ast) - {#.doc "Ensures the given Code is the next input."} - (-> Code (Parser Any)) - (function (_ tokens) - (case tokens - (#.Cons [token tokens']) - (if (code\= ast token) - (#try.Success [tokens' []]) - (#try.Failure ($_ text\compose "Expected a " (code.format ast) " but instead got " (code.format token) - (remaining_inputs tokens)))) - - _ - (#try.Failure "There are no tokens to parse!")))) - -(template [<query> <check> <tag> <eq> <desc>] - [(with_expansions [<failure> (as_is (#try.Failure ($_ text\compose "Cannot parse " <desc> (remaining_inputs tokens))))] - (def: #export <query> - {#.doc (code.text ($_ text\compose "Parse a local " <desc> " (a " <desc> " that has no module prefix)."))} - (Parser Text) - (function (_ tokens) - (case tokens - (#.Cons [[_ (<tag> ["" x])] tokens']) - (#try.Success [tokens' x]) - - _ - <failure>))) - - (def: #export (<check> expected) - (-> Text (Parser Any)) - (function (_ tokens) - (case tokens - (#.Cons [[_ (<tag> ["" actual])] tokens']) - (if (\ <eq> = expected actual) - (#try.Success [tokens' []]) - <failure>) - - _ - <failure>))))] - - [local_identifier local_identifier! #.Identifier text.equivalence "local identifier"] - [ local_tag local_tag! #.Tag text.equivalence "local tag"] - ) - -(template [<name> <tag> <desc>] - [(def: #export (<name> p) - {#.doc (code.text ($_ text\compose "Parse inside the contents of a " <desc> " as if they were the input Codes."))} - (All [a] - (-> (Parser a) (Parser a))) - (function (_ tokens) - (case tokens - (#.Cons [[_ (<tag> members)] tokens']) - (case (p members) - (#try.Success [#.Nil x]) (#try.Success [tokens' x]) - _ (#try.Failure ($_ text\compose "Parser was expected to fully consume " <desc> (remaining_inputs tokens)))) - - _ - (#try.Failure ($_ text\compose "Cannot parse " <desc> (remaining_inputs tokens))))))] - - [ form #.Form "form"] - [tuple #.Tuple "tuple"] - ) - -(def: #export (record p) - {#.doc (code.text ($_ text\compose "Parse inside the contents of a record as if they were the input Codes."))} - (All [a] - (-> (Parser a) (Parser a))) - (function (_ tokens) - (case tokens - (#.Cons [[_ (#.Record pairs)] tokens']) - (case (p (join_pairs pairs)) - (#try.Success [#.Nil x]) (#try.Success [tokens' x]) - _ (#try.Failure ($_ text\compose "Parser was expected to fully consume record" (remaining_inputs tokens)))) - - _ - (#try.Failure ($_ text\compose "Cannot parse record" (remaining_inputs tokens)))))) - -(def: #export end! - {#.doc "Ensures there are no more inputs."} - (Parser Any) - (function (_ tokens) - (case tokens - #.Nil (#try.Success [tokens []]) - _ (#try.Failure ($_ text\compose "Expected list of tokens to be empty!" (remaining_inputs tokens)))))) - -(def: #export end? - {#.doc "Checks whether there are no more inputs."} - (Parser Bit) - (function (_ tokens) - (#try.Success [tokens (case tokens - #.Nil true - _ false)]))) - -(def: #export (run syntax inputs) - (All [a] (-> (Parser a) (List Code) (Try a))) - (case (syntax inputs) - (#try.Failure error) - (#try.Failure error) - - (#try.Success [unconsumed value]) - (case unconsumed - #.Nil - (#try.Success value) - - _ - (#try.Failure (text\compose "Unconsumed inputs: " - (|> (list\map code.format unconsumed) - (text.join_with ", "))))))) - -(def: #export (local inputs syntax) - {#.doc "Run a syntax parser with the given list of inputs, instead of the real ones."} - (All [a] (-> (List Code) (Parser a) (Parser a))) - (function (_ real) - (do try.monad - [value (..run syntax inputs)] - (wrap [real value])))) diff --git a/stdlib/source/lux/control/parser/environment.lux b/stdlib/source/lux/control/parser/environment.lux deleted file mode 100644 index 509369d68..000000000 --- a/stdlib/source/lux/control/parser/environment.lux +++ /dev/null @@ -1,43 +0,0 @@ -(.module: - [lux #* - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." dictionary (#+ Dictionary)]]]] - ["." //]) - -(type: #export Property - Text) - -(type: #export Environment - (Dictionary Property Text)) - -(exception: #export (unknown {property Property}) - (exception.report - ["Property" (%.text property)])) - -(type: #export (Parser a) - (//.Parser Environment a)) - -(def: #export empty - Environment - (dictionary.new text.hash)) - -(def: #export (property name) - (-> Text (Parser Text)) - (function (_ environment) - (case (dictionary.get name environment) - (#.Some value) - (exception.return [environment value]) - - #.None - (exception.throw ..unknown name)))) - -(def: #export (run parser environment) - (All [a] (-> (Parser a) Environment (Try a))) - (\ try.monad map product.right (parser environment))) diff --git a/stdlib/source/lux/control/parser/json.lux b/stdlib/source/lux/control/parser/json.lux deleted file mode 100644 index abc3ded7c..000000000 --- a/stdlib/source/lux/control/parser/json.lux +++ /dev/null @@ -1,206 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["." bit] - ["." text ("#\." equivalence monoid)] - [collection - ["." list ("#\." functor)] - ["." row] - ["." dictionary (#+ Dictionary)]] - [format - ["/" json (#+ JSON)]]] - [macro - ["." code]] - [math - [number - ["." frac]]]] - ["." // ("#\." functor)]) - -(type: #export (Parser a) - {#.doc "JSON parser."} - (//.Parser (List JSON) a)) - -(exception: #export (unconsumed_input {input (List JSON)}) - (exception.report - ["Input" (exception.enumerate /.format input)])) - -(exception: #export empty_input) - -(def: #export (run parser json) - (All [a] (-> (Parser a) JSON (Try a))) - (case (//.run parser (list json)) - (#try.Success [remainder output]) - (case remainder - #.Nil - (#try.Success output) - - _ - (exception.throw ..unconsumed_input remainder)) - - (#try.Failure error) - (#try.Failure error))) - -(def: #export any - {#.doc "Just returns the JSON input without applying any logic."} - (Parser JSON) - (<| (function (_ inputs)) - (case inputs - #.Nil - (exception.throw ..empty_input []) - - (#.Cons head tail) - (#try.Success [tail head])))) - -(exception: #export (unexpected_value {value JSON}) - (exception.report - ["Value" (/.format value)])) - -(template [<name> <type> <tag> <desc>] - [(def: #export <name> - {#.doc (code.text ($_ text\compose "Reads a JSON value as " <desc> "."))} - (Parser <type>) - (do //.monad - [head ..any] - (case head - (<tag> value) - (wrap value) - - _ - (//.fail (exception.construct ..unexpected_value [head])))))] - - [null /.Null #/.Null "null"] - [boolean /.Boolean #/.Boolean "boolean"] - [number /.Number #/.Number "number"] - [string /.String #/.String "string"] - ) - -(exception: #export [a] (value_mismatch {reference JSON} {sample JSON}) - (exception.report - ["Reference" (/.format reference)] - ["Sample" (/.format sample)])) - -(template [<test> <check> <type> <equivalence> <tag> <desc>] - [(def: #export (<test> test) - {#.doc (code.text ($_ text\compose "Asks whether a JSON value is a " <desc> "."))} - (-> <type> (Parser Bit)) - (do //.monad - [head ..any] - (case head - (<tag> value) - (wrap (\ <equivalence> = test value)) - - _ - (//.fail (exception.construct ..unexpected_value [head]))))) - - (def: #export (<check> test) - {#.doc (code.text ($_ text\compose "Ensures a JSON value is a " <desc> "."))} - (-> <type> (Parser Any)) - (do //.monad - [head ..any] - (case head - (<tag> value) - (if (\ <equivalence> = test value) - (wrap []) - (//.fail (exception.construct ..value_mismatch [(<tag> test) (<tag> value)]))) - - _ - (//.fail (exception.construct ..unexpected_value [head])))))] - - [boolean? boolean! /.Boolean bit.equivalence #/.Boolean "boolean"] - [number? number! /.Number frac.equivalence #/.Number "number"] - [string? string! /.String text.equivalence #/.String "string"] - ) - -(def: #export (nullable parser) - (All [a] (-> (Parser a) (Parser (Maybe a)))) - (//.or ..null - parser)) - -(def: #export (array parser) - {#.doc "Parses a JSON array."} - (All [a] (-> (Parser a) (Parser a))) - (do //.monad - [head ..any] - (case head - (#/.Array values) - (case (//.run parser (row.to_list values)) - (#try.Failure error) - (//.fail error) - - (#try.Success [remainder output]) - (case remainder - #.Nil - (wrap output) - - _ - (//.fail (exception.construct ..unconsumed_input remainder)))) - - _ - (//.fail (exception.construct ..unexpected_value [head]))))) - -(def: #export (object parser) - {#.doc "Parses a JSON object. Use this with the 'field' combinator."} - (All [a] (-> (Parser a) (Parser a))) - (do //.monad - [head ..any] - (case head - (#/.Object kvs) - (case (|> kvs - dictionary.entries - (list\map (function (_ [key value]) - (list (#/.String key) value))) - list.concat - (//.run parser)) - (#try.Failure error) - (//.fail error) - - (#try.Success [remainder output]) - (case remainder - #.Nil - (wrap output) - - _ - (//.fail (exception.construct ..unconsumed_input remainder)))) - - _ - (//.fail (exception.construct ..unexpected_value [head]))))) - -(def: #export (field field_name parser) - {#.doc "Parses a field inside a JSON object. Use this inside the 'object' combinator."} - (All [a] (-> Text (Parser a) (Parser a))) - (function (recur inputs) - (case inputs - (^ (list& (#/.String key) value inputs')) - (if (text\= key field_name) - (case (//.run parser (list value)) - (#try.Success [#.Nil output]) - (#try.Success [inputs' output]) - - (#try.Success [inputs'' _]) - (exception.throw ..unconsumed_input inputs'') - - (#try.Failure error) - (#try.Failure error)) - (do try.monad - [[inputs'' output] (recur inputs')] - (wrap [(list& (#/.String key) value inputs'') - output]))) - - #.Nil - (exception.throw ..empty_input []) - - _ - (exception.throw ..unconsumed_input inputs)))) - -(def: #export dictionary - {#.doc "Parses a dictionary-like JSON object."} - (All [a] (-> (Parser a) (Parser (Dictionary Text a)))) - (|>> (//.and ..string) - //.some - ..object - (//\map (dictionary.from_list text.hash)))) diff --git a/stdlib/source/lux/control/parser/synthesis.lux b/stdlib/source/lux/control/parser/synthesis.lux deleted file mode 100644 index f6ae1c1ae..000000000 --- a/stdlib/source/lux/control/parser/synthesis.lux +++ /dev/null @@ -1,163 +0,0 @@ -(.module: - [lux (#- function loop i64) - [abstract - [monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["." bit] - ["." name] - ["." text - ["%" format (#+ format)]]] - [math - [number - ["n" nat] - ["." i64] - ["." frac]]] - [tool - [compiler - [reference (#+) - [variable (#+ Register)]] - [arity (#+ Arity)] - [language - [lux - [analysis (#+ Variant Tuple Environment)] - ["/" synthesis (#+ Synthesis Abstraction)]]]]]] - ["." //]) - -## TODO: Use "type:" ASAP. -(def: Input - Type - (type (List Synthesis))) - -(exception: #export (cannot_parse {input ..Input}) - (exception.report - ["Input" (exception.enumerate /.%synthesis input)])) - -(exception: #export (unconsumed_input {input ..Input}) - (exception.report - ["Input" (exception.enumerate /.%synthesis input)])) - -(exception: #export (expected_empty_input {input ..Input}) - (exception.report - ["Input" (exception.enumerate /.%synthesis input)])) - -(exception: #export (wrong_arity {expected Arity} {actual Arity}) - (exception.report - ["Expected" (%.nat expected)] - ["Actual" (%.nat actual)])) - -(exception: #export empty_input) - -(type: #export Parser - (//.Parser ..Input)) - -(def: #export (run parser input) - (All [a] (-> (Parser a) ..Input (Try a))) - (case (parser input) - (#try.Failure error) - (#try.Failure error) - - (#try.Success [#.Nil value]) - (#try.Success value) - - (#try.Success [unconsumed _]) - (exception.throw ..unconsumed_input unconsumed))) - -(def: #export any - (Parser Synthesis) - (.function (_ input) - (case input - #.Nil - (exception.throw ..empty_input []) - - (#.Cons [head tail]) - (#try.Success [tail head])))) - -(def: #export end! - {#.doc "Ensures there are no more inputs."} - (Parser Any) - (.function (_ tokens) - (case tokens - #.Nil (#try.Success [tokens []]) - _ (exception.throw ..expected_empty_input [tokens])))) - -(def: #export end? - {#.doc "Checks whether there are no more inputs."} - (Parser Bit) - (.function (_ tokens) - (#try.Success [tokens (case tokens - #.Nil true - _ false)]))) - -(template [<query> <assertion> <tag> <type> <eq>] - [(def: #export <query> - (Parser <type>) - (.function (_ input) - (case input - (^ (list& (<tag> x) input')) - (#try.Success [input' x]) - - _ - (exception.throw ..cannot_parse input)))) - - (def: #export (<assertion> expected) - (-> <type> (Parser Any)) - (.function (_ input) - (case input - (^ (list& (<tag> actual) input')) - (if (\ <eq> = expected actual) - (#try.Success [input' []]) - (exception.throw ..cannot_parse input)) - - _ - (exception.throw ..cannot_parse input))))] - - [bit bit! /.bit Bit bit.equivalence] - [i64 i64! /.i64 (I64 Any) i64.equivalence] - [f64 f64! /.f64 Frac frac.equivalence] - [text text! /.text Text text.equivalence] - [local local! /.variable/local Nat n.equivalence] - [foreign foreign! /.variable/foreign Nat n.equivalence] - [constant constant! /.constant Name name.equivalence] - ) - -(def: #export (tuple parser) - (All [a] (-> (Parser a) (Parser a))) - (.function (_ input) - (case input - (^ (list& (/.tuple head) tail)) - (do try.monad - [output (..run parser head)] - (#try.Success [tail output])) - - _ - (exception.throw ..cannot_parse input)))) - -(def: #export (function expected parser) - (All [a] (-> Arity (Parser a) (Parser [(Environment Synthesis) a]))) - (.function (_ input) - (case input - (^ (list& (/.function/abstraction [environment actual body]) tail)) - (if (n.= expected actual) - (do try.monad - [output (..run parser (list body))] - (#try.Success [tail [environment output]])) - (exception.throw ..wrong_arity [expected actual])) - - _ - (exception.throw ..cannot_parse input)))) - -(def: #export (loop init_parsers iteration_parser) - (All [a b] (-> (Parser a) (Parser b) (Parser [Register a b]))) - (.function (_ input) - (case input - (^ (list& (/.loop/scope [start inits iteration]) tail)) - (do try.monad - [inits (..run init_parsers inits) - iteration (..run iteration_parser (list iteration))] - (#try.Success [tail [start inits iteration]])) - - _ - (exception.throw ..cannot_parse input)))) diff --git a/stdlib/source/lux/control/parser/text.lux b/stdlib/source/lux/control/parser/text.lux deleted file mode 100644 index 7dc6001b5..000000000 --- a/stdlib/source/lux/control/parser/text.lux +++ /dev/null @@ -1,376 +0,0 @@ -(.module: - [lux (#- or and not) - [abstract - [monad (#+ Monad do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["/" text (#+ Char) ("#\." monoid)] - ["." product] - ["." maybe] - [collection - ["." list ("#\." fold)]]] - [macro - ["." code]] - [math - [number - ["n" nat ("#\." decimal)]]]] - ["." //]) - -(type: #export Offset Nat) - -(def: start_offset Offset 0) - -(type: #export Parser - (//.Parser [Offset Text])) - -(type: #export Slice - {#basis Offset - #distance Offset}) - -(def: (remaining offset tape) - (-> Offset Text Text) - (|> tape (/.split offset) maybe.assume product.right)) - -(exception: #export (unconsumed_input {offset Offset} {tape Text}) - (exception.report - ["Offset" (n\encode offset)] - ["Input size" (n\encode (/.size tape))] - ["Remaining input" (remaining offset tape)])) - -(exception: #export (expected_to_fail {offset Offset} {tape Text}) - (exception.report - ["Offset" (n\encode offset)] - ["Input" (remaining offset tape)])) - -(exception: #export cannot_parse) -(exception: #export cannot_slice) - -(def: #export (run parser input) - (All [a] (-> (Parser a) Text (Try a))) - (case (parser [start_offset input]) - (#try.Failure msg) - (#try.Failure msg) - - (#try.Success [[end_offset _] output]) - (if (n.= end_offset (/.size input)) - (#try.Success output) - (exception.throw ..unconsumed_input [end_offset input])))) - -(def: #export offset - (Parser Offset) - (function (_ (^@ input [offset tape])) - (#try.Success [input offset]))) - -(def: (with_slices parser) - (-> (Parser (List Slice)) (Parser Slice)) - (do //.monad - [offset ..offset - slices parser] - (wrap (list\fold (function (_ [slice::basis slice::distance] - [total::basis total::distance]) - [total::basis ("lux i64 +" slice::distance total::distance)]) - {#basis offset - #distance 0} - slices)))) - -(def: #export any - {#.doc "Just returns the next character without applying any logic."} - (Parser Text) - (function (_ [offset tape]) - (case (/.nth offset tape) - (#.Some output) - (#try.Success [[("lux i64 +" 1 offset) tape] (/.from_code output)]) - - _ - (exception.throw ..cannot_parse [])))) - -(def: #export any! - {#.doc "Just returns the next character without applying any logic."} - (Parser Slice) - (function (_ [offset tape]) - (case (/.nth offset tape) - (#.Some _) - (#try.Success [[("lux i64 +" 1 offset) tape] - {#basis offset - #distance 1}]) - - _ - (exception.throw ..cannot_slice [])))) - -(template [<name> <type> <any>] - [(def: #export (<name> p) - {#.doc "Produce a character if the parser fails."} - (All [a] (-> (Parser a) (Parser <type>))) - (function (_ input) - (case (p input) - (#try.Failure msg) - (<any> input) - - _ - (exception.throw ..expected_to_fail input))))] - - [not Text ..any] - [not! Slice ..any!] - ) - -(exception: #export (cannot_match {reference Text}) - (exception.report - ["Reference" (/.format reference)])) - -(def: #export (this reference) - {#.doc "Lex a text if it matches the given sample."} - (-> Text (Parser Any)) - (function (_ [offset tape]) - (case (/.index_of' reference offset tape) - (#.Some where) - (if (n.= offset where) - (#try.Success [[("lux i64 +" (/.size reference) offset) tape] - []]) - (exception.throw ..cannot_match [reference])) - - _ - (exception.throw ..cannot_match [reference])))) - -(def: #export end! - {#.doc "Ensure the parser's input is empty."} - (Parser Any) - (function (_ (^@ input [offset tape])) - (if (n.= offset (/.size tape)) - (#try.Success [input []]) - (exception.throw ..unconsumed_input input)))) - -(def: #export peek - {#.doc "Lex the next character (without consuming it from the input)."} - (Parser Text) - (function (_ (^@ input [offset tape])) - (case (/.nth offset tape) - (#.Some output) - (#try.Success [input (/.from_code output)]) - - _ - (exception.throw ..cannot_parse [])))) - -(def: #export get_input - {#.doc "Get all of the remaining input (without consuming it)."} - (Parser Text) - (function (_ (^@ input [offset tape])) - (#try.Success [input (remaining offset tape)]))) - -(def: #export (range bottom top) - {#.doc "Only lex characters within a range."} - (-> Nat Nat (Parser Text)) - (do //.monad - [char any - #let [char' (maybe.assume (/.nth 0 char))] - _ (//.assert ($_ /\compose "Character is not within range: " (/.from_code bottom) "-" (/.from_code top)) - (.and (n.>= bottom char') - (n.<= top char')))] - (wrap char))) - -(template [<name> <bottom> <top> <desc>] - [(def: #export <name> - {#.doc (code.text ($_ /\compose "Only lex " <desc> " characters."))} - (Parser Text) - (..range (char <bottom>) (char <top>)))] - - [upper "A" "Z" "uppercase"] - [lower "a" "z" "lowercase"] - [decimal "0" "9" "decimal"] - [octal "0" "7" "octal"] - ) - -(def: #export alpha - {#.doc "Only lex alphabetic characters."} - (Parser Text) - (//.either lower upper)) - -(def: #export alpha_num - {#.doc "Only lex alphanumeric characters."} - (Parser Text) - (//.either alpha decimal)) - -(def: #export hexadecimal - {#.doc "Only lex hexadecimal digits."} - (Parser Text) - ($_ //.either - decimal - (range (char "a") (char "f")) - (range (char "A") (char "F")))) - -(template [<name>] - [(exception: #export (<name> {options Text} {character Char}) - (exception.report - ["Options" (/.format options)] - ["Character" (/.format (/.from_code character))]))] - - [character_should_be] - [character_should_not_be] - ) - -(template [<name> <modifier> <exception> <description_modifier>] - [(def: #export (<name> options) - {#.doc (code.text ($_ /\compose "Only lex characters that are" <description_modifier> " part of a piece of text."))} - (-> Text (Parser Text)) - (function (_ [offset tape]) - (case (/.nth offset tape) - (#.Some output) - (let [output' (/.from_code output)] - (if (<modifier> (/.contains? output' options)) - (#try.Success [[("lux i64 +" 1 offset) tape] output']) - (exception.throw <exception> [options output]))) - - _ - (exception.throw ..cannot_parse []))))] - - [one_of |> ..character_should_be ""] - [none_of .not ..character_should_not_be " not"] - ) - -(template [<name> <modifier> <exception> <description_modifier>] - [(def: #export (<name> options) - {#.doc (code.text ($_ /\compose "Only lex characters that are" <description_modifier> " part of a piece of text."))} - (-> Text (Parser Slice)) - (function (_ [offset tape]) - (case (/.nth offset tape) - (#.Some output) - (let [output' (/.from_code output)] - (if (<modifier> (/.contains? output' options)) - (#try.Success [[("lux i64 +" 1 offset) tape] - {#basis offset - #distance 1}]) - (exception.throw <exception> [options output]))) - - _ - (exception.throw ..cannot_slice []))))] - - [one_of! |> ..character_should_be ""] - [none_of! .not ..character_should_not_be " not"] - ) - -(exception: #export (character_does_not_satisfy_predicate {character Char}) - (exception.report - ["Character" (/.format (/.from_code character))])) - -(def: #export (satisfies p) - {#.doc "Only lex characters that satisfy a predicate."} - (-> (-> Char Bit) (Parser Text)) - (function (_ [offset tape]) - (case (/.nth offset tape) - (#.Some output) - (if (p output) - (#try.Success [[("lux i64 +" 1 offset) tape] (/.from_code output)]) - (exception.throw ..character_does_not_satisfy_predicate [output])) - - _ - (exception.throw ..cannot_parse [])))) - -(def: #export space - {#.doc "Only lex white-space."} - (Parser Text) - (..satisfies /.space?)) - -(def: #export (and left right) - (-> (Parser Text) (Parser Text) (Parser Text)) - (do //.monad - [=left left - =right right] - (wrap ($_ /\compose =left =right)))) - -(def: #export (and! left right) - (-> (Parser Slice) (Parser Slice) (Parser Slice)) - (do //.monad - [[left::basis left::distance] left - [right::basis right::distance] right] - (wrap [left::basis ("lux i64 +" left::distance right::distance)]))) - -(template [<name> <base> <doc_modifier>] - [(def: #export (<name> parser) - {#.doc (code.text ($_ /\compose "Lex " <doc_modifier> " characters as a single continuous text."))} - (-> (Parser Text) (Parser Text)) - (|> parser <base> (\ //.monad map /.concat)))] - - [some //.some "some"] - [many //.many "many"] - ) - -(template [<name> <base> <doc_modifier>] - [(def: #export (<name> parser) - {#.doc (code.text ($_ /\compose "Lex " <doc_modifier> " characters as a single continuous text."))} - (-> (Parser Slice) (Parser Slice)) - (with_slices (<base> parser)))] - - [some! //.some "some"] - [many! //.many "many"] - ) - -(template [<name> <base> <doc_modifier>] - [(def: #export (<name> amount parser) - {#.doc (code.text ($_ /\compose "Lex " <doc_modifier> " N characters."))} - (-> Nat (Parser Text) (Parser Text)) - (|> parser (<base> amount) (\ //.monad map /.concat)))] - - [exactly //.exactly "exactly"] - [at_most //.at_most "at most"] - [at_least //.at_least "at least"] - ) - -(template [<name> <base> <doc_modifier>] - [(def: #export (<name> amount parser) - {#.doc (code.text ($_ /\compose "Lex " <doc_modifier> " N characters."))} - (-> Nat (Parser Slice) (Parser Slice)) - (with_slices (<base> amount parser)))] - - [exactly! //.exactly "exactly"] - [at_most! //.at_most "at most"] - [at_least! //.at_least "at least"] - ) - -(def: #export (between from to parser) - {#.doc "Lex between N and M characters."} - (-> Nat Nat (Parser Text) (Parser Text)) - (|> parser (//.between from to) (\ //.monad map /.concat))) - -(def: #export (between! from to parser) - {#.doc "Lex between N and M characters."} - (-> Nat Nat (Parser Slice) (Parser Slice)) - (with_slices (//.between from to parser))) - -(def: #export (enclosed [start end] parser) - (All [a] (-> [Text Text] (Parser a) (Parser a))) - (|> parser - (//.before (this end)) - (//.after (this start)))) - -(def: #export (local local_input parser) - {#.doc "Run a parser with the given input, instead of the real one."} - (All [a] (-> Text (Parser a) (Parser a))) - (function (_ real_input) - (case (..run parser local_input) - (#try.Failure error) - (#try.Failure error) - - (#try.Success value) - (#try.Success [real_input value])))) - -(def: #export (slice parser) - (-> (Parser Slice) (Parser Text)) - (do //.monad - [[basis distance] parser] - (function (_ (^@ input [offset tape])) - (case (/.clip basis distance tape) - (#.Some output) - (#try.Success [input output]) - - #.None - (exception.throw ..cannot_slice []))))) - -(def: #export (embed structured text) - (All [s a] - (-> (Parser a) - (//.Parser s Text) - (//.Parser s a))) - (do //.monad - [raw text] - (//.lift (..run structured raw)))) diff --git a/stdlib/source/lux/control/parser/tree.lux b/stdlib/source/lux/control/parser/tree.lux deleted file mode 100644 index ac824638a..000000000 --- a/stdlib/source/lux/control/parser/tree.lux +++ /dev/null @@ -1,59 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - [collection - [tree (#+ Tree) - ["." zipper (#+ Zipper)]]]]] - ["." //]) - -(type: #export (Parser t a) - (//.Parser (Zipper t) a)) - -(def: #export (run' parser zipper) - (All [t a] (-> (Parser t a) (Zipper t) (Try a))) - (do try.monad - [[zipper output] (//.run parser zipper)] - (wrap output))) - -(def: #export (run parser tree) - (All [t a] (-> (Parser t a) (Tree t) (Try a))) - (run' parser (zipper.zip tree))) - -(def: #export value - (All [t] (Parser t t)) - (function (_ zipper) - (#try.Success [zipper (zipper.value zipper)]))) - -(exception: #export cannot-move-further) - -(template [<name> <direction>] - [(def: #export <name> - (All [t] (Parser t [])) - (function (_ zipper) - (case (<direction> zipper) - #.None - (exception.throw ..cannot-move-further []) - - (#.Some next) - (#try.Success [next []]))))] - - [down zipper.down] - [up zipper.up] - - [right zipper.right] - [rightmost zipper.rightmost] - - [left zipper.left] - [leftmost zipper.leftmost] - - [next zipper.next] - [end zipper.end] - - [previous zipper.previous] - [start zipper.start] - ) diff --git a/stdlib/source/lux/control/parser/type.lux b/stdlib/source/lux/control/parser/type.lux deleted file mode 100644 index ce58c5ce3..000000000 --- a/stdlib/source/lux/control/parser/type.lux +++ /dev/null @@ -1,348 +0,0 @@ -(.module: - [lux (#- function) - [abstract - ["." monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["." function]] - [data - ["." text ("#\." monoid) - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)] - ["." dictionary (#+ Dictionary)]]] - [macro - ["." code]] - [math - [number - ["n" nat ("#\." decimal)]]] - ["." type ("#\." equivalence) - ["." check]]] - ["." //]) - -(template [<name>] - [(exception: #export (<name> {type Type}) - (exception.report - ["Type" (%.type type)]))] - - [not_existential] - [not_recursive] - [not_named] - [not_parameter] - [unknown_parameter] - [not_function] - [not_application] - [not_polymorphic] - [not_variant] - [not_tuple] - ) - -(template [<name>] - [(exception: #export (<name> {expected Type} {actual Type}) - (exception.report - ["Expected" (%.type expected)] - ["Actual" (%.type actual)]))] - - [types_do_not_match] - [wrong_parameter] - ) - -(exception: #export empty_input) - -(exception: #export (unconsumed_input {remaining (List Type)}) - (exception.report - ["Types" (|> remaining - (list\map (|>> %.type (format text.new_line "* "))) - (text.join_with ""))])) - -(type: #export Env - (Dictionary Nat [Type Code])) - -(type: #export (Parser a) - (//.Parser [Env (List Type)] a)) - -(def: #export fresh - Env - (dictionary.new n.hash)) - -(def: (run' env poly types) - (All [a] (-> Env (Parser a) (List Type) (Try a))) - (case (//.run poly [env types]) - (#try.Failure error) - (#try.Failure error) - - (#try.Success [[env' remaining] output]) - (case remaining - #.Nil - (#try.Success output) - - _ - (exception.throw ..unconsumed_input remaining)))) - -(def: #export (run poly type) - (All [a] (-> (Parser a) Type (Try a))) - (run' ..fresh poly (list type))) - -(def: #export env - (Parser Env) - (.function (_ [env inputs]) - (#try.Success [[env inputs] env]))) - -(def: (with_env temp poly) - (All [a] (-> Env (Parser a) (Parser a))) - (.function (_ [env inputs]) - (case (//.run poly [temp inputs]) - (#try.Failure error) - (#try.Failure error) - - (#try.Success [[_ remaining] output]) - (#try.Success [[env remaining] output])))) - -(def: #export peek - (Parser Type) - (.function (_ [env inputs]) - (case inputs - #.Nil - (exception.throw ..empty_input []) - - (#.Cons headT tail) - (#try.Success [[env inputs] headT])))) - -(def: #export any - (Parser Type) - (.function (_ [env inputs]) - (case inputs - #.Nil - (exception.throw ..empty_input []) - - (#.Cons headT tail) - (#try.Success [[env tail] headT])))) - -(def: #export (local types poly) - (All [a] (-> (List Type) (Parser a) (Parser a))) - (.function (_ [env pass_through]) - (case (run' env poly types) - (#try.Failure error) - (#try.Failure error) - - (#try.Success output) - (#try.Success [[env pass_through] output])))) - -(def: (label idx) - (-> Nat Code) - (code.local_identifier ($_ text\compose "label" text.tab (n\encode idx)))) - -(def: #export (with_extension type poly) - (All [a] (-> Type (Parser a) (Parser [Code a]))) - (.function (_ [env inputs]) - (let [current_id (dictionary.size env) - g!var (label current_id)] - (case (//.run poly - [(dictionary.put current_id [type g!var] env) - inputs]) - (#try.Failure error) - (#try.Failure error) - - (#try.Success [[_ inputs'] output]) - (#try.Success [[env inputs'] [g!var output]]))))) - -(template [<name> <flattener> <tag> <exception>] - [(def: #export (<name> poly) - (All [a] (-> (Parser a) (Parser a))) - (do //.monad - [headT ..any] - (let [members (<flattener> (type.un_name headT))] - (if (n.> 1 (list.size members)) - (local members poly) - (//.fail (exception.construct <exception> headT))))))] - - [variant type.flatten_variant #.Sum ..not_variant] - [tuple type.flatten_tuple #.Product ..not_tuple] - ) - -(def: polymorphic' - (Parser [Nat Type]) - (do //.monad - [headT any - #let [[num_arg bodyT] (type.flatten_univ_q (type.un_name headT))]] - (if (n.= 0 num_arg) - (//.fail (exception.construct ..not_polymorphic headT)) - (wrap [num_arg bodyT])))) - -(def: #export (polymorphic poly) - (All [a] (-> (Parser a) (Parser [Code (List Code) a]))) - (do {! //.monad} - [headT any - funcI (\ ! map dictionary.size ..env) - [num_args non_poly] (local (list headT) ..polymorphic') - env ..env - #let [funcL (label funcI) - [all_varsL env'] (loop [current_arg 0 - env' env - all_varsL (: (List Code) (list))] - (if (n.< num_args current_arg) - (if (n.= 0 current_arg) - (let [varL (label (inc funcI))] - (recur (inc current_arg) - (|> env' - (dictionary.put funcI [headT funcL]) - (dictionary.put (inc funcI) [(#.Parameter (inc funcI)) varL])) - (#.Cons varL all_varsL))) - (let [partialI (|> current_arg (n.* 2) (n.+ funcI)) - partial_varI (inc partialI) - partial_varL (label partial_varI) - partialC (` ((~ funcL) (~+ (|> (list.indices num_args) - (list\map (|>> (n.* 2) inc (n.+ funcI) label)) - list.reverse))))] - (recur (inc current_arg) - (|> env' - (dictionary.put partialI [.Nothing partialC]) - (dictionary.put partial_varI [(#.Parameter partial_varI) partial_varL])) - (#.Cons partial_varL all_varsL)))) - [all_varsL env']))]] - (<| (with_env env') - (local (list non_poly)) - (do ! - [output poly] - (wrap [funcL all_varsL output]))))) - -(def: #export (function in_poly out_poly) - (All [i o] (-> (Parser i) (Parser o) (Parser [i o]))) - (do //.monad - [headT any - #let [[inputsT outputT] (type.flatten_function (type.un_name headT))]] - (if (n.> 0 (list.size inputsT)) - (//.and (local inputsT in_poly) - (local (list outputT) out_poly)) - (//.fail (exception.construct ..not_function headT))))) - -(def: #export (apply poly) - (All [a] (-> (Parser a) (Parser a))) - (do //.monad - [headT any - #let [[funcT paramsT] (type.flatten_application (type.un_name headT))]] - (if (n.= 0 (list.size paramsT)) - (//.fail (exception.construct ..not_application headT)) - (..local (#.Cons funcT paramsT) poly)))) - -(template [<name> <test>] - [(def: #export (<name> expected) - (-> Type (Parser Any)) - (do //.monad - [actual any] - (if (<test> expected actual) - (wrap []) - (//.fail (exception.construct ..types_do_not_match [expected actual])))))] - - [exactly type\=] - [sub check.checks?] - [super (function.flip check.checks?)] - ) - -(def: #export (adjusted_idx env idx) - (-> Env Nat Nat) - (let [env_level (n./ 2 (dictionary.size env)) - parameter_level (n./ 2 idx) - parameter_idx (n.% 2 idx)] - (|> env_level dec (n.- parameter_level) (n.* 2) (n.+ parameter_idx)))) - -(def: #export parameter - (Parser Code) - (do //.monad - [env ..env - headT any] - (case headT - (#.Parameter idx) - (case (dictionary.get (adjusted_idx env idx) env) - (#.Some [poly_type poly_code]) - (wrap poly_code) - - #.None - (//.fail (exception.construct ..unknown_parameter headT))) - - _ - (//.fail (exception.construct ..not_parameter headT))))) - -(def: #export (parameter! id) - (-> Nat (Parser Any)) - (do //.monad - [env ..env - headT any] - (case headT - (#.Parameter idx) - (if (n.= id (adjusted_idx env idx)) - (wrap []) - (//.fail (exception.construct ..wrong_parameter [(#.Parameter id) headT]))) - - _ - (//.fail (exception.construct ..not_parameter headT))))) - -(def: #export existential - (Parser Nat) - (do //.monad - [headT any] - (case headT - (#.Ex ex_id) - (wrap ex_id) - - _ - (//.fail (exception.construct ..not_existential headT))))) - -(def: #export named - (Parser [Name Type]) - (do //.monad - [inputT any] - (case inputT - (#.Named name anonymousT) - (wrap [name anonymousT]) - - _ - (//.fail (exception.construct ..not_named inputT))))) - -(template: (|nothing|) - (#.Named ["lux" "Nothing"] - (#.UnivQ #.Nil - (#.Parameter 1)))) - -(def: #export (recursive poly) - (All [a] (-> (Parser a) (Parser [Code a]))) - (do {! //.monad} - [headT any] - (case (type.un_name headT) - (^ (#.Apply (|nothing|) (#.UnivQ _ headT'))) - (do ! - [[recT _ output] (|> poly - (with_extension .Nothing) - (with_extension headT) - (local (list headT')))] - (wrap [recT output])) - - _ - (//.fail (exception.construct ..not_recursive headT))))) - -(def: #export recursive_self - (Parser Code) - (do //.monad - [env ..env - headT any] - (case (type.un_name headT) - (^multi (^ (#.Apply (|nothing|) (#.Parameter funcT_idx))) - (n.= 0 (adjusted_idx env funcT_idx)) - [(dictionary.get 0 env) (#.Some [self_type self_call])]) - (wrap self_call) - - _ - (//.fail (exception.construct ..not_recursive headT))))) - -(def: #export recursive_call - (Parser Code) - (do {! //.monad} - [env ..env - [funcT argsT] (..apply (//.and any (//.many any))) - _ (local (list funcT) (..parameter! 0)) - allC (let [allT (list& funcT argsT)] - (|> allT - (monad.map ! (function.constant ..parameter)) - (local allT)))] - (wrap (` ((~+ allC)))))) diff --git a/stdlib/source/lux/control/parser/xml.lux b/stdlib/source/lux/control/parser/xml.lux deleted file mode 100644 index 9eb794c2d..000000000 --- a/stdlib/source/lux/control/parser/xml.lux +++ /dev/null @@ -1,141 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." try (#+ Try) ("#\." functor)] - ["." exception (#+ exception:)]] - [data - ["." name ("#\." equivalence codec)] - ["." text - ["%" format (#+ format)]] - [collection - ["." list] - ["." dictionary]] - [format - ["/" xml (#+ Attribute Attrs Tag XML)]]]] - ["." //]) - -(type: #export (Parser a) - (//.Parser [Attrs (List XML)] a)) - -(exception: #export empty_input) -(exception: #export unexpected_input) - -(exception: #export (wrong_tag {expected Tag} {actual Tag}) - (exception.report - ["Expected" (%.text (/.tag expected))] - ["Actual" (%.text (/.tag actual))])) - -(exception: #export (unknown_attribute {expected Attribute} {available (List Attribute)}) - (exception.report - ["Expected" (%.text (/.attribute expected))] - ["Available" (exception.enumerate (|>> /.attribute %.text) available)])) - -(exception: #export (unconsumed_inputs {inputs (List XML)}) - (exception.report - ["Inputs" (exception.enumerate (\ /.codec encode) inputs)])) - -(def: (run' parser attrs documents) - (All [a] (-> (Parser a) Attrs (List XML) (Try a))) - (case (//.run parser [attrs documents]) - (#try.Success [[attrs' remaining] output]) - (if (list.empty? remaining) - (#try.Success output) - (exception.throw ..unconsumed_inputs remaining)) - - (#try.Failure error) - (#try.Failure error))) - -(def: #export (run parser documents) - (All [a] (-> (Parser a) (List XML) (Try a))) - (..run' parser /.attributes documents)) - -(def: #export text - (Parser Text) - (function (_ [attrs documents]) - (case documents - #.Nil - (exception.throw ..empty_input []) - - (#.Cons head tail) - (case head - (#/.Text value) - (#try.Success [[attrs tail] value]) - - (#/.Node _) - (exception.throw ..unexpected_input []))))) - -(def: #export tag - (Parser Tag) - (function (_ [attrs documents]) - (case documents - #.Nil - (exception.throw ..empty_input []) - - (#.Cons head _) - (case head - (#/.Text _) - (exception.throw ..unexpected_input []) - - (#/.Node tag _ _) - (#try.Success [[attrs documents] tag]))))) - -(def: #export (attribute name) - (-> Attribute (Parser Text)) - (function (_ [attrs documents]) - (case (dictionary.get name attrs) - #.None - (exception.throw ..unknown_attribute [name (dictionary.keys attrs)]) - - (#.Some value) - (#try.Success [[attrs documents] value])))) - -(def: #export (node expected parser) - (All [a] (-> Tag (Parser a) (Parser a))) - (function (_ [attrs documents]) - (case documents - #.Nil - (exception.throw ..empty_input []) - - (#.Cons head tail) - (case head - (#/.Text _) - (exception.throw ..unexpected_input []) - - (#/.Node actual attrs' children) - (if (name\= expected actual) - (|> children - (..run' parser attrs') - (try\map (|>> [[attrs tail]]))) - (exception.throw ..wrong_tag [expected actual])))))) - -(def: #export ignore - (Parser Any) - (function (_ [attrs documents]) - (case documents - #.Nil - (exception.throw ..empty_input []) - - (#.Cons head tail) - (#try.Success [[attrs tail] []])))) - -(exception: #export nowhere) - -(def: #export (somewhere parser) - (All [a] (-> (Parser a) (Parser a))) - (function (recur [attrs input]) - (case (//.run parser [attrs input]) - (#try.Success [[attrs remaining] output]) - (#try.Success [[attrs remaining] output]) - - (#try.Failure error) - (case input - #.Nil - (exception.throw ..nowhere []) - - (#.Cons head tail) - (do try.monad - [[[attrs tail'] output] (recur [attrs tail])] - (wrap [[attrs (#.Cons head tail')] - output])))))) diff --git a/stdlib/source/lux/control/pipe.lux b/stdlib/source/lux/control/pipe.lux deleted file mode 100644 index 3453b1779..000000000 --- a/stdlib/source/lux/control/pipe.lux +++ /dev/null @@ -1,160 +0,0 @@ -(.module: {#.doc "Composable extensions to the piping macros (|> and <|) that enhance them with various abilities."} - [lux #* - [abstract - [monad (#+ do)]] - [control - ["e" try] - ["p" parser - ["s" code (#+ Parser)]]] - [data - ["." identity] - [collection - ["." list ("#\." fold monad)]]] - [macro (#+ with_gensyms) - [syntax (#+ syntax:)] - ["." code]] - [math - [number - ["n" nat] - ["i" int]]]]) - -(def: body^ - (Parser (List Code)) - (s.tuple (p.some s.any))) - -(syntax: #export (new> start - {body body^} - prev) - {#.doc (doc "Ignores the piped argument, and begins a new pipe." - (n.= 1 - (|> 20 - (n.* 3) - (n.+ 4) - (new> 0 [inc]))))} - (wrap (list (` (|> (~ start) (~+ body)))))) - -(syntax: #export (let> binding body prev) - {#.doc (doc "Gives a name to the piped-argument, within the given expression." - (n.= 10 - (|> 5 - (let> x (n.+ x x)))))} - (wrap (list (` (let [(~ binding) (~ prev)] - (~ body)))))) - -(def: _reverse_ - (Parser Any) - (function (_ tokens) - (#e.Success [(list.reverse tokens) []]))) - -(syntax: #export (cond> {_ _reverse_} - prev - {else body^} - {_ _reverse_} - {branches (p.some (p.and body^ body^))}) - {#.doc (doc "Branching for pipes." - "Both the tests and the bodies are piped-code, and must be given inside a tuple." - (|> +5 - (cond> [i.even?] [(i.* +2)] - [i.odd?] [(i.* +3)] - [(new> -1 [])])))} - (with_gensyms [g!temp] - (wrap (list (` (let [(~ g!temp) (~ prev)] - (cond (~+ (do list.monad - [[test then] branches] - (list (` (|> (~ g!temp) (~+ test))) - (` (|> (~ g!temp) (~+ then)))))) - (|> (~ g!temp) (~+ else))))))))) - -(syntax: #export (if> {test body^} {then body^} {else body^} prev) - (wrap (list (` (cond> [(~+ test)] [(~+ then)] - [(~+ else)] - (~ prev)))))) - -(syntax: #export (when> {test body^} {then body^} prev) - (wrap (list (` (cond> [(~+ test)] [(~+ then)] - [] - (~ prev)))))) - -(syntax: #export (loop> {test body^} - {then body^} - prev) - {#.doc (doc "Loops for pipes." - "Both the testing and calculating steps are pipes and must be given inside tuples." - (|> +1 - (loop> [(i.< +10)] - [inc])))} - (with_gensyms [g!temp] - (wrap (list (` (loop [(~ g!temp) (~ prev)] - (if (|> (~ g!temp) (~+ test)) - ((~' recur) (|> (~ g!temp) (~+ then))) - (~ g!temp)))))))) - -(syntax: #export (do> monad - {steps (p.some body^)} - prev) - {#.doc (doc "Monadic pipes." - "Each steps in the monadic computation is a pipe and must be given inside a tuple." - (|> +5 - (do> identity.monad - [(i.* +3)] - [(i.+ +4)] - [inc])))} - (with_gensyms [g!temp] - (case (list.reverse steps) - (^ (list& last_step prev_steps)) - (let [step_bindings (do list.monad - [step (list.reverse prev_steps)] - (list g!temp (` (|> (~ g!temp) (~+ step)))))] - (wrap (list (` ((~! do) (~ monad) - [(~' #let) [(~ g!temp) (~ prev)] - (~+ step_bindings)] - (|> (~ g!temp) (~+ last_step))))))) - - _ - (wrap (list prev))))) - -(syntax: #export (exec> {body body^} - prev) - {#.doc (doc "Non-updating pipes." - "Will generate piped computations, but their results will not be used in the larger scope." - (|> +5 - (exec> [.nat %n log!]) - (i.* +10)))} - (with_gensyms [g!temp] - (wrap (list (` (let [(~ g!temp) (~ prev)] - (exec (|> (~ g!temp) (~+ body)) - (~ g!temp)))))))) - -(syntax: #export (tuple> {paths (p.many body^)} - prev) - {#.doc (doc "Parallel branching for pipes." - "Allows to run multiple pipelines for a value and gives you a tuple of the outputs." - (|> +5 - (tuple> [(i.* +10)] - [dec (i./ +2)] - [Int/encode])) - "Will become: [+50 +2 '+5']")} - (with_gensyms [g!temp] - (wrap (list (` (let [(~ g!temp) (~ prev)] - [(~+ (list\map (function (_ body) (` (|> (~ g!temp) (~+ body)))) - paths))])))))) - -(syntax: #export (case> {branches (p.many (p.and s.any s.any))} - prev) - {#.doc (doc "Pattern-matching for pipes." - "The bodies of each branch are NOT pipes; just regular values." - (|> +5 - (case> +0 "zero" - +1 "one" - +2 "two" - +3 "three" - +4 "four" - +5 "five" - +6 "six" - +7 "seven" - +8 "eight" - +9 "nine" - _ "???")))} - (wrap (list (` (case (~ prev) - (~+ (list\join (list\map (function (_ [pattern body]) (list pattern body)) - branches)))))))) diff --git a/stdlib/source/lux/control/reader.lux b/stdlib/source/lux/control/reader.lux deleted file mode 100644 index 615bdfe80..000000000 --- a/stdlib/source/lux/control/reader.lux +++ /dev/null @@ -1,71 +0,0 @@ -(.module: - [lux #* - [abstract - ["." functor (#+ Functor)] - [apply (#+ Apply)] - ["." monad (#+ Monad do)]]]) - -(type: #export (Reader r a) - {#.doc "Computations that have access to some environmental value."} - (-> r a)) - -(def: #export ask - {#.doc "Get the environment."} - (All [r] (Reader r r)) - (function (_ env) env)) - -(def: #export (local change proc) - {#.doc "Run computation with a locally-modified environment."} - (All [r a] (-> (-> r r) (Reader r a) (Reader r a))) - (|>> change proc)) - -(def: #export (run env proc) - (All [r a] (-> r (Reader r a) a)) - (proc env)) - -(implementation: #export functor - (All [r] (Functor (Reader r))) - - (def: (map f fa) - (function (_ env) - (f (fa env))))) - -(implementation: #export apply - (All [r] (Apply (Reader r))) - - (def: &functor ..functor) - - (def: (apply ff fa) - (function (_ env) - ((ff env) (fa env))))) - -(implementation: #export monad - (All [r] (Monad (Reader r))) - - (def: &functor ..functor) - - (def: (wrap x) - (function (_ env) x)) - - (def: (join mma) - (function (_ env) - (mma env env)))) - -(implementation: #export (with monad) - {#.doc "Monad transformer for Reader."} - (All [M] (-> (Monad M) (All [e] (Monad (All [a] (Reader e (M a))))))) - - (def: &functor (functor.compose ..functor (get@ #monad.&functor monad))) - - (def: wrap (|>> (\ monad wrap) (\ ..monad wrap))) - - (def: (join eMeMa) - (function (_ env) - (do monad - [eMa (run env eMeMa)] - (run env eMa))))) - -(def: #export lift - {#.doc "Lift monadic values to the Reader wrapper."} - (All [M e a] (-> (M a) (Reader e (M a)))) - (\ ..monad wrap)) diff --git a/stdlib/source/lux/control/region.lux b/stdlib/source/lux/control/region.lux deleted file mode 100644 index 5b2a6fef1..000000000 --- a/stdlib/source/lux/control/region.lux +++ /dev/null @@ -1,157 +0,0 @@ -(.module: - [lux #* - [abstract - [functor (#+ Functor)] - [apply (#+ Apply)] - ["." monad (#+ Monad do)]] - [control - ["." try (#+ Try)]] - [data - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." fold)]]]] - [// - ["." exception (#+ Exception exception:)]]) - -(type: (Cleaner r !) - (-> r (! (Try Any)))) - -(type: #export (Region r ! a) - (-> [r (List (Cleaner r !))] - (! [(List (Cleaner r !)) - (Try a)]))) - -(def: separator - Text - (format text.new_line - "-----------------------------------------" text.new_line - "-----------------------------------------" text.new_line - "-----------------------------------------" text.new_line - text.new_line)) - -(exception: #export [a] (clean_up_error {error Text} - {output (Try a)}) - (format error - (case output - (#try.Success _) - "" - - (#try.Failure error|output) - (format separator - error|output)))) - -(def: (combine_outcomes clean_up output) - (All [a] (-> (Try Any) (Try a) (Try a))) - (case clean_up - (#try.Success _) - output - - (#try.Failure error) - (exception.throw ..clean_up_error [error output]))) - -(def: #export (run monad computation) - (All [! a] - (-> (Monad !) (All [r] (Region r ! a)) - (! (Try a)))) - (do {! monad} - [[cleaners output] (computation [[] (list)]) - results (monad.map ! (function (_ cleaner) (cleaner [])) - cleaners)] - (wrap (list\fold combine_outcomes output results)))) - -(def: #export (acquire monad cleaner value) - (All [! a] (-> (Monad !) (-> a (! (Try Any))) a - (All [r] (Region r ! a)))) - (function (_ [region cleaners]) - (\ monad wrap [(#.Cons (function (_ region) (cleaner value)) - cleaners) - (#try.Success value)]))) - -(implementation: #export (functor super) - (All [!] - (-> (Functor !) - (All [r] (Functor (Region r !))))) - - (def: (map f) - (function (_ fa) - (function (_ region+cleaners) - (\ super map - (function (_ [cleaners' temp]) - [cleaners' (case temp - (#try.Success value) - (#try.Success (f value)) - - (#try.Failure error) - (#try.Failure error))]) - (fa region+cleaners)))))) - -(implementation: #export (apply super) - (All [!] - (-> (Monad !) - (All [r] (Apply (Region r !))))) - - (def: &functor - (..functor (get@ #monad.&functor super))) - - (def: (apply ff fa) - (function (_ [region cleaners]) - (do super - [[cleaners ef] (ff [region cleaners]) - [cleaners ea] (fa [region cleaners])] - (case ef - (#try.Success f) - (case ea - (#try.Success a) - (wrap [cleaners (#try.Success (f a))]) - - (#try.Failure error) - (wrap [cleaners (#try.Failure error)])) - - (#try.Failure error) - (wrap [cleaners (#try.Failure error)])))))) - -(implementation: #export (monad super) - (All [!] - (-> (Monad !) - (All [r] (Monad (Region r !))))) - - (def: &functor - (..functor (get@ #monad.&functor super))) - - (def: (wrap value) - (function (_ [region cleaners]) - (\ super wrap [cleaners (#try.Success value)]))) - - (def: (join ffa) - (function (_ [region cleaners]) - (do super - [[cleaners efa] (ffa [region cleaners])] - (case efa - (#try.Success fa) - (fa [region cleaners]) - - (#try.Failure error) - (wrap [cleaners (#try.Failure error)])))))) - -(def: #export (fail monad error) - (All [! a] - (-> (Monad !) Text - (All [r] (Region r ! a)))) - (function (_ [region cleaners]) - (\ monad wrap [cleaners (#try.Failure error)]))) - -(def: #export (throw monad exception message) - (All [! e a] - (-> (Monad !) (Exception e) e - (All [r] (Region r ! a)))) - (fail monad (exception.construct exception message))) - -(def: #export (lift monad operation) - (All [! a] - (-> (Monad !) (! a) - (All [r] (Region r ! a)))) - (function (_ [region cleaners]) - (do monad - [output operation] - (wrap [cleaners (#try.Success output)])))) diff --git a/stdlib/source/lux/control/remember.lux b/stdlib/source/lux/control/remember.lux deleted file mode 100644 index aeda22262..000000000 --- a/stdlib/source/lux/control/remember.lux +++ /dev/null @@ -1,73 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." io] - ["." try] - ["." exception (#+ exception:)] - ["<>" parser ("#\." functor) - ["<c>" code (#+ Parser)]]] - [data - ["." text - ["%" format (#+ format)]]] - [time - ["." instant] - ["." date (#+ Date) ("#\." order)]] - ["." meta] - [macro - ["." code] - [syntax (#+ syntax:)]]]) - -(exception: #export (must_remember {deadline Date} {today Date} {message Text} {focus (Maybe Code)}) - (exception.report - ["Deadline" (%.date deadline)] - ["Today" (%.date today)] - ["Message" message] - ["Code" (case focus - (#.Some focus) - (%.code focus) - - #.None - "")])) - -(def: deadline - (Parser Date) - ($_ <>.either - (<>\map (|>> instant.from_millis instant.date) - <c>.int) - (do <>.monad - [raw <c>.text] - (case (\ date.codec decode raw) - (#try.Success date) - (wrap date) - - (#try.Failure message) - (<>.fail message))))) - -(syntax: #export (remember {deadline ..deadline} {message <c>.text} {focus (<>.maybe <c>.any)}) - (let [now (io.run instant.now) - today (instant.date now)] - (if (date\< deadline today) - (wrap (case focus - (#.Some focus) - (list focus) - - #.None - (list))) - (meta.fail (exception.construct ..must_remember [deadline today message focus]))))) - -(template [<name> <message>] - [(syntax: #export (<name> {deadline ..deadline} {message <c>.text} {focus (<>.maybe <c>.any)}) - (wrap (list (` (..remember (~ (code.text (%.date deadline))) - (~ (code.text (format <message> " " message))) - (~+ (case focus - (#.Some focus) - (list focus) - - #.None - (list))))))))] - - [to_do "TODO"] - [fix_me "FIXME"] - ) diff --git a/stdlib/source/lux/control/security/capability.lux b/stdlib/source/lux/control/security/capability.lux deleted file mode 100644 index db3e38c26..000000000 --- a/stdlib/source/lux/control/security/capability.lux +++ /dev/null @@ -1,70 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["<>" parser - ["<c>" code]] - ["." io (#+ IO)] - [concurrency - ["." promise (#+ Promise)]]] - [data - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)]]] - [type - abstract] - ["." meta] - ["." macro - ["." code] - [syntax (#+ syntax:) - ["|.|" export] - ["|.|" declaration] - ["|.|" annotations]]]]) - -(abstract: #export (Capability brand input output) - (-> input output) - - {#.doc (doc "Represents the capability to perform an operation." - "This operation is assumed to have security implications.")} - - (def: forge - (All [brand input output] - (-> (-> input output) - (Capability brand input output))) - (|>> :abstraction)) - - (def: #export (use capability input) - (All [brand input output] - (-> (Capability brand input output) - input - output)) - ((:representation capability) input)) - - (syntax: #export (capability: {export |export|.parser} - {declaration |declaration|.parser} - {annotations (<>.maybe |annotations|.parser)} - {[forge input output] (<c>.form ($_ <>.and <c>.local_identifier <c>.any <c>.any))}) - (do {! meta.monad} - [this_module meta.current_module_name - #let [[name vars] declaration] - g!brand (\ ! map (|>> %.code code.text) - (macro.gensym (format (%.name [this_module name])))) - #let [capability (` (..Capability (.primitive (~ g!brand)) (~ input) (~ output)))]] - (wrap (list (` (type: (~+ (|export|.format export)) - (~ (|declaration|.format declaration)) - (~ capability))) - (` (def: (~ (code.local_identifier forge)) - (All [(~+ (list\map code.local_identifier vars))] - (-> (-> (~ input) (~ output)) - (~ capability))) - (~! ..forge))) - )))) - - (def: #export (async capability) - (All [brand input output] - (-> (Capability brand input (IO output)) - (Capability brand input (Promise output)))) - (..forge (|>> ((:representation capability)) promise.future))) - ) diff --git a/stdlib/source/lux/control/security/policy.lux b/stdlib/source/lux/control/security/policy.lux deleted file mode 100644 index 1d3c0e43e..000000000 --- a/stdlib/source/lux/control/security/policy.lux +++ /dev/null @@ -1,92 +0,0 @@ -(.module: - [lux #* - [abstract - [functor (#+ Functor)] - [apply (#+ Apply)] - [monad (#+ Monad)]] - [type - abstract]]) - -(abstract: #export (Policy brand value label) - value - - (type: #export (Can_Upgrade brand label value) - {#.doc (doc "Represents the capacity to 'upgrade' a value.")} - (-> value (Policy brand value label))) - - (type: #export (Can_Downgrade brand label value) - {#.doc (doc "Represents the capacity to 'downgrade' a value.")} - (-> (Policy brand value label) value)) - - (type: #export (Privilege brand label) - {#.doc (doc "Represents the privilege to both 'upgrade' and 'downgrade' a value.")} - {#can_upgrade (Can_Upgrade brand label) - #can_downgrade (Can_Downgrade brand label)}) - - (def: privilege - Privilege - {#can_upgrade (|>> :abstraction) - #can_downgrade (|>> :representation)}) - - (type: #export (Delegation brand from to) - {#.doc (doc "Represents the act of delegating policy capacities.")} - (All [value] - (-> (Policy brand value from) - (Policy brand value to)))) - - (def: #export (delegation downgrade upgrade) - {#.doc (doc "Delegating policy capacities.")} - (All [brand from to] - (-> (Can_Downgrade brand from) (Can_Upgrade brand to) - (Delegation brand from to))) - (|>> downgrade upgrade)) - - (type: #export (Context brand scope label) - {#.doc (doc "A computational context with an associated policy privilege.")} - (-> (Privilege brand label) - (scope label))) - - (def: #export (with_policy context) - (All [brand scope] - (Ex [label] - (-> (Context brand scope label) - (scope label)))) - (context ..privilege)) - - (def: (decorate constructor) - (-> Type Type) - (type (All [brand label] (constructor (All [value] (Policy brand value label)))))) - - (implementation: #export functor - (:~ (decorate Functor)) - - (def: (map f fa) - (|> fa :representation f :abstraction))) - - (implementation: #export apply - (:~ (decorate Apply)) - - (def: &functor ..functor) - (def: (apply ff fa) - (:abstraction ((:representation ff) (:representation fa))))) - - (implementation: #export monad - (:~ (decorate Monad)) - - (def: &functor ..functor) - (def: wrap (|>> :abstraction)) - (def: join (|>> :representation))) - ) - -(template [<brand> <value> <upgrade> <downgrade>] - [(abstract: #export <brand> - Any - - (type: #export <value> (Policy <brand>)) - (type: #export <upgrade> (Can_Upgrade <brand>)) - (type: #export <downgrade> (Can_Downgrade <brand>)) - )] - - [Privacy Private Can_Conceal Can_Reveal] - [Safety Safe Can_Trust Can_Distrust] - ) diff --git a/stdlib/source/lux/control/state.lux b/stdlib/source/lux/control/state.lux deleted file mode 100644 index 0914f5dde..000000000 --- a/stdlib/source/lux/control/state.lux +++ /dev/null @@ -1,148 +0,0 @@ -(.module: - [lux #* - [abstract - [functor (#+ Functor)] - [apply (#+ Apply)] - [monad (#+ Monad do)]]]) - -(type: #export (State s a) - {#.doc "Stateful computations."} - (-> s [s a])) - -(def: #export get - {#.doc "Read the current state."} - (All [s] (State s s)) - (function (_ state) - [state state])) - -(def: #export (put new-state) - {#.doc "Set the new state."} - (All [s] (-> s (State s Any))) - (function (_ state) - [new-state []])) - -(def: #export (update change) - {#.doc "Compute the new state."} - (All [s] (-> (-> s s) (State s Any))) - (function (_ state) - [(change state) []])) - -(def: #export (use user) - {#.doc "Run function on current state."} - (All [s a] (-> (-> s a) (State s a))) - (function (_ state) - [state (user state)])) - -(def: #export (local change action) - {#.doc "Run computation with a locally-modified state."} - (All [s a] (-> (-> s s) (State s a) (State s a))) - (function (_ state) - (let [[state' output] (action (change state))] - [state output]))) - -(def: #export (run state action) - {#.doc "Run a stateful computation."} - (All [s a] (-> s (State s a) [s a])) - (action state)) - -(implementation: #export functor - (All [s] (Functor (State s))) - - (def: (map f ma) - (function (_ state) - (let [[state' a] (ma state)] - [state' (f a)])))) - -(implementation: #export apply - (All [s] (Apply (State s))) - - (def: &functor ..functor) - - (def: (apply ff fa) - (function (_ state) - (let [[state' f] (ff state) - [state'' a] (fa state')] - [state'' (f a)])))) - -(implementation: #export monad - (All [s] (Monad (State s))) - - (def: &functor ..functor) - - (def: (wrap a) - (function (_ state) - [state a])) - - (def: (join mma) - (function (_ state) - (let [[state' ma] (mma state)] - (ma state'))))) - -(def: #export (while condition body) - (All [s] (-> (State s Bit) (State s Any) (State s Any))) - (do {! ..monad} - [execute? condition] - (if execute? - (do ! - [_ body] - (while condition body)) - (wrap [])))) - -(def: #export (do-while condition body) - (All [s] (-> (State s Bit) (State s Any) (State s Any))) - (do ..monad - [_ body] - (while condition body))) - -(implementation: (with//functor functor) - (All [M s] (-> (Functor M) (Functor (All [a] (-> s (M [s a])))))) - - (def: (map f sfa) - (function (_ state) - (\ functor map (function (_ [s a]) [s (f a)]) - (sfa state))))) - -(implementation: (with//apply monad) - (All [M s] (-> (Monad M) (Apply (All [a] (-> s (M [s a])))))) - - (def: &functor (with//functor (\ monad &functor))) - - (def: (apply sFf sFa) - (function (_ state) - (do monad - [[state f] (sFf state) - [state a] (sFa state)] - (wrap [state (f a)]))))) - -(type: #export (State' M s a) - {#.doc "Stateful computations decorated by a monad."} - (-> s (M [s a]))) - -(def: #export (run' state action) - {#.doc "Run a stateful computation decorated by a monad."} - (All [M s a] (-> s (State' M s a) (M [s a]))) - (action state)) - -(implementation: #export (with monad) - {#.doc "A monad transformer to create composite stateful computations."} - (All [M s] (-> (Monad M) (Monad (State' M s)))) - - (def: &functor (with//functor (\ monad &functor))) - - (def: (wrap a) - (function (_ state) - (\ monad wrap [state a]))) - - (def: (join sMsMa) - (function (_ state) - (do monad - [[state' sMa] (sMsMa state)] - (sMa state'))))) - -(def: #export (lift monad ma) - {#.doc "Lift monadic values to the State' wrapper."} - (All [M s a] (-> (Monad M) (M a) (State' M s a))) - (function (_ state) - (do monad - [a ma] - (wrap [state a])))) diff --git a/stdlib/source/lux/control/thread.lux b/stdlib/source/lux/control/thread.lux deleted file mode 100644 index 153fdc0ba..000000000 --- a/stdlib/source/lux/control/thread.lux +++ /dev/null @@ -1,105 +0,0 @@ -(.module: - [lux #* - ["@" target] - [abstract - [functor (#+ Functor)] - [apply (#+ Apply)] - [monad (#+ Monad do)]] - [control - ["." io (#+ IO)]] - [data - [collection - ["." array (#+ Array)]]] - [type - abstract]]) - -(type: #export (Thread ! a) - (-> ! a)) - -(abstract: #export (Box t v) - (Array v) - - {#.doc "A mutable box holding a value."} - - (def: #export (box init) - (All [a] (-> a (All [!] (Thread ! (Box ! a))))) - (function (_ !) - (|> (array.new 1) - (array.write! 0 init) - :abstraction))) - - (def: #export (read box) - (All [! a] (-> (Box ! a) (Thread ! a))) - (function (_ !) - (for {@.old - ("jvm aaload" (:representation box) 0) - - @.jvm - ("jvm array read object" - (|> 0 - (:as (primitive "java.lang.Long")) - "jvm object cast" - "jvm conversion long-to-int") - (:representation box)) - - @.js ("js array read" 0 (:representation box)) - @.python ("python array read" 0 (:representation box)) - @.lua ("lua array read" 0 (:representation box)) - @.ruby ("ruby array read" 0 (:representation box)) - @.php ("php array read" 0 (:representation box)) - @.scheme ("scheme array read" 0 (:representation box))}))) - - (def: #export (write value box) - (All [a] (-> a (All [!] (-> (Box ! a) (Thread ! Any))))) - (function (_ !) - (|> box :representation (array.write! 0 value) :abstraction))) - ) - -(def: #export (run thread) - (All [a] - (-> (All [!] (Thread ! a)) - a)) - (thread [])) - -(def: #export io - (All [a] - (-> (All [!] (Thread ! a)) - (IO a))) - (|>> ..run io.io)) - -(implementation: #export functor - (All [!] (Functor (Thread !))) - - (def: (map f) - (function (_ fa) - (function (_ !) - (f (fa !)))))) - -(implementation: #export apply - (All [!] (Apply (Thread !))) - - (def: &functor ..functor) - - (def: (apply ff fa) - (function (_ !) - ((ff !) (fa !))))) - -(implementation: #export monad - (All [!] (Monad (Thread !))) - - (def: &functor ..functor) - - (def: (wrap value) - (function (_ !) - value)) - - (def: (join ffa) - (function (_ !) - ((ffa !) !)))) - -(def: #export (update f box) - (All [a] (-> (-> a a) (All [!] (-> (Box ! a) (Thread ! a))))) - (do ..monad - [old (read box) - _ (write (f old) box)] - (wrap old))) diff --git a/stdlib/source/lux/control/try.lux b/stdlib/source/lux/control/try.lux deleted file mode 100644 index e60068cb1..000000000 --- a/stdlib/source/lux/control/try.lux +++ /dev/null @@ -1,151 +0,0 @@ -(.module: - [lux #* - [abstract - [apply (#+ Apply)] - [equivalence (#+ Equivalence)] - ["." functor (#+ Functor)] - ["." monad (#+ Monad do)]] - [meta - ["." location]]]) - -(type: #export (Try a) - (#Failure Text) - (#Success a)) - -(implementation: #export functor - (Functor Try) - - (def: (map f ma) - (case ma - (#Failure msg) - (#Failure msg) - - (#Success datum) - (#Success (f datum))))) - -(implementation: #export apply - (Apply Try) - - (def: &functor ..functor) - - (def: (apply ff fa) - (case ff - (#Success f) - (case fa - (#Success a) - (#Success (f a)) - - (#Failure msg) - (#Failure msg)) - - (#Failure msg) - (#Failure msg)) - )) - -(implementation: #export monad - (Monad Try) - - (def: &functor ..functor) - - (def: (wrap a) - (#Success a)) - - (def: (join mma) - (case mma - (#Failure msg) - (#Failure msg) - - (#Success ma) - ma))) - -(implementation: #export (with monad) - ## TODO: Replace (All [a] (M (Try a))) with (functor.Then M Try) - (All [M] (-> (Monad M) (Monad (All [a] (M (Try a)))))) - - (def: &functor (functor.compose (get@ #monad.&functor monad) ..functor)) - - (def: wrap (|>> (\ ..monad wrap) (\ monad wrap))) - - (def: (join MeMea) - (do monad - [eMea MeMea] - (case eMea - (#Failure try) - (wrap (#Failure try)) - - (#Success Mea) - Mea)))) - -(def: #export (lift monad) - (All [M a] (-> (Monad M) (-> (M a) (M (Try a))))) - (\ monad map (\ ..monad wrap))) - -(implementation: #export (equivalence (^open "_\.")) - (All [a] (-> (Equivalence a) (Equivalence (Try a)))) - - (def: (= reference sample) - (case [reference sample] - [(#Success reference) (#Success sample)] - (_\= reference sample) - - [(#Failure reference) (#Failure sample)] - ("lux text =" reference sample) - - _ - false - ))) - -(def: #export (succeed value) - (All [a] (-> a (Try a))) - (#Success value)) - -(def: #export (fail message) - (-> Text Try) - (#Failure message)) - -(def: #export (assume try) - (All [a] (-> (Try a) a)) - (case try - (#Success value) - value - - (#Failure message) - (error! message))) - -(def: #export (to_maybe try) - (All [a] (-> (Try a) (Maybe a))) - (case try - (#Success value) - (#.Some value) - - (#Failure message) - #.None)) - -(def: #export (from_maybe maybe) - (All [a] (-> (Maybe a) (Try a))) - (case maybe - (#.Some value) - (#Success value) - - #.None - (#Failure (("lux in-module" "lux" .name\encode) (name_of ..from_maybe))))) - -(macro: #export (default tokens compiler) - {#.doc (doc "Allows you to provide a default value that will be used" - "if a (Try x) value turns out to be #Failure." - "Note: the expression for the default value will not be computed if the base computation succeeds." - (= "bar" - (default "foo" (#..Success "bar"))) - (= "foo" - (default "foo" (#..Failure "KABOOM!"))))} - (case tokens - (^ (list else try)) - (#Success [compiler (list (` (case (~ try) - (#..Success (~' g!temp)) - (~' g!temp) - - (#..Failure (~ [location.dummy (#.Identifier ["" ""])])) - (~ else))))]) - - _ - (#Failure "Wrong syntax for default"))) diff --git a/stdlib/source/lux/control/writer.lux b/stdlib/source/lux/control/writer.lux deleted file mode 100644 index 92ab8f751..000000000 --- a/stdlib/source/lux/control/writer.lux +++ /dev/null @@ -1,77 +0,0 @@ -(.module: - [lux #* - ["@" target] - [abstract - monoid - [apply (#+ Apply)] - ["." functor (#+ Functor)] - ["." monad (#+ Monad do)]]]) - -(type: #export (Writer l a) - {#.doc "Represents a value with an associated 'log' value to record arbitrary information."} - {#log l - #value a}) - -(def: #export (write l) - {#.doc "Set the log to a particular value."} - (All [l] (-> l (Writer l Any))) - [l []]) - -(implementation: #export functor - (All [l] - (Functor (Writer l))) - - (def: (map f fa) - (let [[log datum] fa] - [log (f datum)]))) - -(implementation: #export (apply monoid) - (All [l] - (-> (Monoid l) (Apply (Writer l)))) - - (def: &functor ..functor) - - (def: (apply ff fa) - (let [[log1 f] ff - [log2 a] fa] - [(\ monoid compose log1 log2) (f a)]))) - -(implementation: #export (monad monoid) - (All [l] - (-> (Monoid l) (Monad (Writer l)))) - - (def: &functor ..functor) - - (def: wrap - (|>> [(\ monoid identity)])) - - (def: (join mma) - (let [[log1 [log2 a]] mma] - [(\ monoid compose log1 log2) a]))) - -(implementation: #export (with monoid monad) - (All [l M] (-> (Monoid l) (Monad M) (Monad (All [a] (M (Writer l a)))))) - - (def: &functor - (functor.compose (get@ #monad.&functor monad) - ..functor)) - - (def: wrap - (let [writer (..monad monoid)] - (|>> (\ writer wrap) (\ monad wrap)))) - - (def: (join MlMla) - (do monad - [[l1 Mla] (for {@.old - (: (($ 1) (Writer ($ 0) (($ 1) (Writer ($ 0) ($ 2))))) - MlMla)} - ## On new compiler - MlMla) - [l2 a] Mla] - (wrap [(\ monoid compose l1 l2) a])))) - -(def: #export (lift monoid monad) - (All [l M a] - (-> (Monoid l) (Monad M) - (-> (M a) (M (Writer l a))))) - (\ monad map (|>> [(\ monoid identity)]))) diff --git a/stdlib/source/lux/data/binary.lux b/stdlib/source/lux/data/binary.lux deleted file mode 100644 index a6f11ff5b..000000000 --- a/stdlib/source/lux/data/binary.lux +++ /dev/null @@ -1,366 +0,0 @@ -(.module: - [lux (#- i64) - ["@" target] - ["." ffi] - [abstract - [monad (#+ do)] - [equivalence (#+ Equivalence)] - [monoid (#+ Monoid)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["." maybe] - [text - ["%" format (#+ format)]] - [collection - ["." array]]] - [math - [number (#+ hex) - ["n" nat] - ["f" frac] - ["." i64]]]]) - -(exception: #export (index_out_of_bounds {size Nat} {index Nat}) - (exception.report - ["Size" (%.nat size)] - ["Index" (%.nat index)])) - -(exception: #export (slice_out_of_bounds {size Nat} {offset Nat} {length Nat}) - (exception.report - ["Size" (%.nat size)] - ["Offset" (%.nat offset)] - ["Length" (%.nat length)])) - -(with_expansions [<jvm> (as_is (type: #export Binary (ffi.type [byte])) - - (ffi.import: java/lang/Object) - - (ffi.import: java/lang/System - ["#::." - (#static arraycopy [java/lang/Object int java/lang/Object int int] #try void)]) - - (ffi.import: java/util/Arrays - ["#::." - (#static copyOfRange [[byte] int int] [byte]) - (#static equals [[byte] [byte]] boolean)]) - - (def: byte_mask - I64 - (|> i64.bits_per_byte i64.mask .i64)) - - (def: i64 - (-> (primitive "java.lang.Byte") I64) - (|>> ffi.byte_to_long (:as I64) (i64.and ..byte_mask))) - - (def: byte - (-> (I64 Any) (primitive "java.lang.Byte")) - (for {@.old - (|>> .int ffi.long_to_byte) - - @.jvm - (|>> .int (:as (primitive "java.lang.Long")) ffi.long_to_byte)})))] - (for {@.old (as_is <jvm>) - @.jvm (as_is <jvm>) - - @.js - (as_is (ffi.import: ArrayBuffer - ["#::." - (new [ffi.Number])]) - - (ffi.import: Uint8Array - ["#::." - (new [ArrayBuffer]) - (length ffi.Number)]) - - (type: #export Binary - Uint8Array)) - - @.python - (type: #export Binary - (primitive "bytearray")) - - @.scheme - (as_is (type: #export Binary - (primitive "bytevector")) - - (ffi.import: (make-bytevector [Nat] Binary)) - (ffi.import: (bytevector-u8-ref [Binary Nat] I64)) - (ffi.import: (bytevector-u8-set! [Binary Nat (I64 Any)] Any)) - (ffi.import: (bytevector-length [Binary] Nat)))} - - ## Default - (type: #export Binary - (array.Array (I64 Any))))) - -(template: (!size binary) - (for {@.old (ffi.array_length binary) - @.jvm (ffi.array_length binary) - - @.js - (|> binary - Uint8Array::length - f.nat) - - @.python - (|> binary - (:as (array.Array (I64 Any))) - "python array length") - - @.scheme - (..bytevector-length [binary])} - - ## Default - (array.size binary))) - -(template: (!read idx binary) - (for {@.old (..i64 (ffi.array_read idx binary)) - @.jvm (..i64 (ffi.array_read idx binary)) - - @.js - (|> binary - (: ..Binary) - (:as (array.Array .Frac)) - ("js array read" idx) - f.nat - .i64) - - @.python - (|> binary - (:as (array.Array .I64)) - ("python array read" idx)) - - @.scheme - (..bytevector-u8-ref [binary idx])} - - ## Default - (|> binary - (array.read idx) - (maybe.default (: (I64 Any) 0)) - (:as I64)))) - -(template: (!!write <byte_type> <post> <write> idx value binary) - (|> binary - (: ..Binary) - (:as (array.Array <byte_type>)) - (<write> idx (|> value .nat (n.% (hex "100")) <post>)) - (:as ..Binary))) - -(template: (!write idx value binary) - (for {@.old (ffi.array_write idx (..byte value) binary) - @.jvm (ffi.array_write idx (..byte value) binary) - - @.js (!!write .Frac n.frac "js array write" idx value binary) - @.python (!!write (I64 Any) (:as (I64 Any)) "python array write" idx value binary) - @.scheme (exec (..bytevector-u8-set! [binary idx value]) - binary)} - - ## Default - (array.write! idx (|> value .nat (n.% (hex "100"))) binary))) - -(def: #export size - (-> Binary Nat) - (|>> !size)) - -(def: #export create - (-> Nat Binary) - (for {@.old (|>> (ffi.array byte)) - @.jvm (|>> (ffi.array byte)) - - @.js - (|>> n.frac ArrayBuffer::new Uint8Array::new) - - @.python - (|>> ("python apply" (:as ffi.Function ("python constant" "bytearray"))) - (:as Binary)) - - @.scheme - (|>> ..make-bytevector)} - - ## Default - array.new)) - -(def: #export (fold f init binary) - (All [a] (-> (-> I64 a a) a Binary a)) - (let [size (..!size binary)] - (loop [idx 0 - output init] - (if (n.< size idx) - (recur (inc idx) (f (!read idx binary) output)) - output)))) - -(def: #export (read/8 idx binary) - (-> Nat Binary (Try I64)) - (if (n.< (..!size binary) idx) - (#try.Success (!read idx binary)) - (exception.throw ..index_out_of_bounds [(..!size binary) idx]))) - -(def: #export (read/16 idx binary) - (-> Nat Binary (Try I64)) - (if (n.< (..!size binary) (n.+ 1 idx)) - (#try.Success ($_ i64.or - (i64.left_shift 8 (!read idx binary)) - (!read (n.+ 1 idx) binary))) - (exception.throw ..index_out_of_bounds [(..!size binary) idx]))) - -(def: #export (read/32 idx binary) - (-> Nat Binary (Try I64)) - (if (n.< (..!size binary) (n.+ 3 idx)) - (#try.Success ($_ i64.or - (i64.left_shift 24 (!read idx binary)) - (i64.left_shift 16 (!read (n.+ 1 idx) binary)) - (i64.left_shift 8 (!read (n.+ 2 idx) binary)) - (!read (n.+ 3 idx) binary))) - (exception.throw ..index_out_of_bounds [(..!size binary) idx]))) - -(def: #export (read/64 idx binary) - (-> Nat Binary (Try I64)) - (if (n.< (..!size binary) (n.+ 7 idx)) - (#try.Success ($_ i64.or - (i64.left_shift 56 (!read idx binary)) - (i64.left_shift 48 (!read (n.+ 1 idx) binary)) - (i64.left_shift 40 (!read (n.+ 2 idx) binary)) - (i64.left_shift 32 (!read (n.+ 3 idx) binary)) - (i64.left_shift 24 (!read (n.+ 4 idx) binary)) - (i64.left_shift 16 (!read (n.+ 5 idx) binary)) - (i64.left_shift 8 (!read (n.+ 6 idx) binary)) - (!read (n.+ 7 idx) binary))) - (exception.throw ..index_out_of_bounds [(..!size binary) idx]))) - -(def: #export (write/8 idx value binary) - (-> Nat (I64 Any) Binary (Try Binary)) - (if (n.< (..!size binary) idx) - (#try.Success (|> binary - (!write idx value))) - (exception.throw ..index_out_of_bounds [(..!size binary) idx]))) - -(def: #export (write/16 idx value binary) - (-> Nat (I64 Any) Binary (Try Binary)) - (if (n.< (..!size binary) (n.+ 1 idx)) - (#try.Success (|> binary - (!write idx (i64.right_shift 8 value)) - (!write (n.+ 1 idx) value))) - (exception.throw ..index_out_of_bounds [(..!size binary) idx]))) - -(def: #export (write/32 idx value binary) - (-> Nat (I64 Any) Binary (Try Binary)) - (if (n.< (..!size binary) (n.+ 3 idx)) - (#try.Success (|> binary - (!write idx (i64.right_shift 24 value)) - (!write (n.+ 1 idx) (i64.right_shift 16 value)) - (!write (n.+ 2 idx) (i64.right_shift 8 value)) - (!write (n.+ 3 idx) value))) - (exception.throw ..index_out_of_bounds [(..!size binary) idx]))) - -(def: #export (write/64 idx value binary) - (-> Nat (I64 Any) Binary (Try Binary)) - (if (n.< (..!size binary) (n.+ 7 idx)) - (for {@.scheme (let [write_high (|>> (!write idx (i64.right_shift 56 value)) - (!write (n.+ 1 idx) (i64.right_shift 48 value)) - (!write (n.+ 2 idx) (i64.right_shift 40 value)) - (!write (n.+ 3 idx) (i64.right_shift 32 value))) - write_low (|>> (!write (n.+ 4 idx) (i64.right_shift 24 value)) - (!write (n.+ 5 idx) (i64.right_shift 16 value)) - (!write (n.+ 6 idx) (i64.right_shift 8 value)) - (!write (n.+ 7 idx) value))] - (|> binary write_high write_low #try.Success))} - (#try.Success (|> binary - (!write idx (i64.right_shift 56 value)) - (!write (n.+ 1 idx) (i64.right_shift 48 value)) - (!write (n.+ 2 idx) (i64.right_shift 40 value)) - (!write (n.+ 3 idx) (i64.right_shift 32 value)) - (!write (n.+ 4 idx) (i64.right_shift 24 value)) - (!write (n.+ 5 idx) (i64.right_shift 16 value)) - (!write (n.+ 6 idx) (i64.right_shift 8 value)) - (!write (n.+ 7 idx) value)))) - (exception.throw ..index_out_of_bounds [(..!size binary) idx]))) - -(implementation: #export equivalence - (Equivalence Binary) - - (def: (= reference sample) - (with_expansions [<jvm> (java/util/Arrays::equals reference sample)] - (for {@.old <jvm> - @.jvm <jvm>} - (let [limit (!size reference)] - (and (n.= limit - (!size sample)) - (loop [idx 0] - (if (n.< limit idx) - (and (n.= (!read idx reference) - (!read idx sample)) - (recur (inc idx))) - true)))))))) - -(for {@.old (as_is) - @.jvm (as_is)} - - ## Default - (exception: #export (cannot_copy_bytes {bytes Nat} - {source_input Nat} - {target_output Nat}) - (exception.report - ["Bytes" (%.nat bytes)] - ["Source input space" (%.nat source_input)] - ["Target output space" (%.nat target_output)]))) - -(def: #export (copy bytes source_offset source target_offset target) - (-> Nat Nat Binary Nat Binary (Try Binary)) - (with_expansions [<jvm> (as_is (do try.monad - [_ (java/lang/System::arraycopy source (.int source_offset) target (.int target_offset) (.int bytes))] - (wrap target)))] - (for {@.old <jvm> - @.jvm <jvm>} - - ## Default - (let [source_input (n.- source_offset (!size source)) - target_output (n.- target_offset (!size target))] - (if (n.<= source_input bytes) - (loop [idx 0] - (if (n.< bytes idx) - (exec (!write (n.+ target_offset idx) - (!read (n.+ source_offset idx) source) - target) - (recur (inc idx))) - (#try.Success target))) - (exception.throw ..cannot_copy_bytes [bytes source_input target_output])))))) - -(def: #export (slice offset length binary) - (-> Nat Nat Binary (Try Binary)) - (let [size (..!size binary) - limit (n.+ length offset)] - (if (n.<= size limit) - (with_expansions [<jvm> (as_is (#try.Success (java/util/Arrays::copyOfRange binary (.int offset) (.int limit))))] - (for {@.old <jvm> - @.jvm <jvm>} - - ## Default - (..copy length offset binary 0 (..create length)))) - (exception.throw ..slice_out_of_bounds [size offset length])))) - -(def: #export (drop offset binary) - (-> Nat Binary Binary) - (case offset - 0 binary - _ (let [distance (n.- offset (..!size binary))] - (case (..slice offset distance binary) - (#try.Success slice) - slice - - (#try.Failure _) - (..create 0))))) - -(implementation: #export monoid - (Monoid Binary) - - (def: identity - (..create 0)) - - (def: (compose left right) - (let [sizeL (!size left) - sizeR (!size right) - output (..create (n.+ sizeL sizeR))] - (exec - (..copy sizeL 0 left 0 output) - (..copy sizeR 0 right sizeL output) - output)))) diff --git a/stdlib/source/lux/data/bit.lux b/stdlib/source/lux/data/bit.lux deleted file mode 100644 index 88c9b4bd7..000000000 --- a/stdlib/source/lux/data/bit.lux +++ /dev/null @@ -1,58 +0,0 @@ -(.module: - [lux #* - [abstract - [monoid (#+ Monoid)] - [equivalence (#+ Equivalence)] - hash - [codec (#+ Codec)]] - [control - ["." function]]]) - -(implementation: #export equivalence - (Equivalence Bit) - - (def: (= x y) - (if x - y - (not y)))) - -(implementation: #export hash - (Hash Bit) - - (def: &equivalence ..equivalence) - - (def: (hash value) - (case value - #0 2 - #1 3))) - -(template [<name> <identity> <op>] - [(implementation: #export <name> - (Monoid Bit) - - (def: identity <identity>) - (def: (compose x y) (<op> x y)))] - - [disjunction #0 or] - [conjunction #1 and] - ) - -(implementation: #export codec - (Codec Text Bit) - - (def: (encode x) - (if x - "#1" - "#0")) - - (def: (decode input) - (case input - "#1" (#.Right #1) - "#0" (#.Right #0) - _ (#.Left "Wrong syntax for Bit.")))) - -(def: #export complement - {#.doc (doc "Generates the complement of a predicate." - "That is a predicate that returns the oposite of the original predicate.")} - (All [a] (-> (-> a Bit) (-> a Bit))) - (function.compose not)) diff --git a/stdlib/source/lux/data/collection/array.lux b/stdlib/source/lux/data/collection/array.lux deleted file mode 100644 index 0b2911c3e..000000000 --- a/stdlib/source/lux/data/collection/array.lux +++ /dev/null @@ -1,387 +0,0 @@ -(.module: - [lux #* - ["@" target] - [abstract - [monoid (#+ Monoid)] - [functor (#+ Functor)] - [equivalence (#+ Equivalence)] - [fold (#+ Fold)] - [predicate (#+ Predicate)]] - [data - ["." product] - ["." maybe] - [collection - ["." list ("#\." fold)]]] - [math - [number - ["n" nat]]]]) - -(def: #export type_name - "#Array") - -(type: #export (Array a) - {#.doc "Mutable arrays."} - (#.Primitive ..type_name (#.Cons a #.Nil))) - -(with_expansions [<index_type> (primitive "java.lang.Long") - <elem_type> (primitive "java.lang.Object") - <array_type> (type (Array <elem_type>))] - (for {@.jvm - (template: (!int value) - (|> value - (:as <index_type>) - "jvm object cast" - "jvm conversion long-to-int"))} - (as_is)) - - (def: #export (new size) - (All [a] (-> Nat (Array a))) - (for {@.old - (:assume ("jvm anewarray" "(java.lang.Object )" size)) - - @.jvm - (|> size - !int - "jvm array new object" - (: <array_type>) - :assume) - - @.js ("js array new" size) - @.python ("python array new" size) - @.lua ("lua array new" size) - @.ruby ("ruby array new" size) - @.php ("php array new" size) - @.scheme ("scheme array new" size)})) - - (def: #export (size array) - (All [a] (-> (Array a) Nat)) - (for {@.old - ("jvm arraylength" array) - - @.jvm - (|> array - (:as <array_type>) - "jvm array length object" - "jvm conversion int-to-long" - "jvm object cast" - (: <index_type>) - (:as Nat)) - - @.js ("js array length" array) - @.python ("python array length" array) - @.lua ("lua array length" array) - @.ruby ("ruby array length" array) - @.php ("php array length" array) - @.scheme ("scheme array length" array)})) - - (template: (!read <read> <null?>) - (let [output (<read> index array)] - (if (<null?> output) - #.None - (#.Some output)))) - - (def: #export (read index array) - (All [a] - (-> Nat (Array a) (Maybe a))) - (if (n.< (size array) index) - (for {@.old - (let [value ("jvm aaload" array index)] - (if ("jvm object null?" value) - #.None - (#.Some value))) - - @.jvm - (let [value (|> array - (:as <array_type>) - ("jvm array read object" (!int index)))] - (if ("jvm object null?" value) - #.None - (#.Some (:assume value)))) - - @.js (!read "js array read" "js object undefined?") - @.python (!read "python array read" "python object none?") - @.lua (!read "lua array read" "lua object nil?") - @.ruby (!read "ruby array read" "ruby object nil?") - @.php (!read "php array read" "php object null?") - @.scheme (!read "scheme array read" "scheme object nil?")}) - #.None)) - - (def: #export (write! index value array) - (All [a] - (-> Nat a (Array a) (Array a))) - (for {@.old - ("jvm aastore" array index value) - - @.jvm - (|> array - (:as <array_type>) - ("jvm array write object" (!int index) (:as <elem_type> value)) - :assume) - - @.js ("js array write" index value array) - @.python ("python array write" index value array) - @.lua ("lua array write" index value array) - @.ruby ("ruby array write" index value array) - @.php ("php array write" index value array) - @.scheme ("scheme array write" index value array)})) - - (def: #export (delete! index array) - (All [a] - (-> Nat (Array a) (Array a))) - (if (n.< (size array) index) - (for {@.old - (write! index (:assume ("jvm object null")) array) - - @.jvm - (write! index (:assume (: <elem_type> ("jvm object null"))) array) - - @.js ("js array delete" index array) - @.python ("python array delete" index array) - @.lua ("lua array delete" index array) - @.ruby ("ruby array delete" index array) - @.php ("php array delete" index array) - @.scheme ("scheme array delete" index array)}) - array)) - ) - -(def: #export (contains? index array) - (All [a] - (-> Nat (Array a) Bit)) - (case (..read index array) - (#.Some _) - true - - _ - false)) - -(def: #export (update! index transform array) - (All [a] - (-> Nat (-> a a) (Array a) (Array a))) - (case (read index array) - #.None - array - - (#.Some value) - (write! index (transform value) array))) - -(def: #export (upsert! index default transform array) - (All [a] - (-> Nat a (-> a a) (Array a) (Array a))) - (write! index - (|> array (read index) (maybe.default default) transform) - array)) - -(def: #export (copy! length src_start src_array dest_start dest_array) - (All [a] - (-> Nat Nat (Array a) Nat (Array a) - (Array a))) - (if (n.= 0 length) - dest_array - (list\fold (function (_ offset target) - (case (read (n.+ offset src_start) src_array) - #.None - target - - (#.Some value) - (write! (n.+ offset dest_start) value target))) - dest_array - (list.indices length)))) - -(def: #export (occupancy array) - {#.doc "Finds out how many cells in an array are occupied."} - (All [a] (-> (Array a) Nat)) - (list\fold (function (_ idx count) - (case (read idx array) - #.None - count - - (#.Some _) - (inc count))) - 0 - (list.indices (size array)))) - -(def: #export (vacancy array) - {#.doc "Finds out how many cells in an array are vacant."} - (All [a] (-> (Array a) Nat)) - (n.- (..occupancy array) (..size array))) - -(def: #export (filter! p xs) - (All [a] - (-> (Predicate a) (Array a) (Array a))) - (list\fold (function (_ idx xs') - (case (read idx xs) - #.None - xs' - - (#.Some x) - (if (p x) - xs' - (delete! idx xs')))) - xs - (list.indices (size xs)))) - -(def: #export (find p xs) - (All [a] - (-> (Predicate a) (Array a) (Maybe a))) - (let [arr_size (size xs)] - (loop [idx 0] - (if (n.< arr_size idx) - (case (read idx xs) - #.None - (recur (inc idx)) - - (#.Some x) - (if (p x) - (#.Some x) - (recur (inc idx)))) - #.None)))) - -(def: #export (find+ p xs) - {#.doc "Just like 'find', but with access to the index of each value."} - (All [a] - (-> (-> Nat a Bit) (Array a) (Maybe [Nat a]))) - (let [arr_size (size xs)] - (loop [idx 0] - (if (n.< arr_size idx) - (case (read idx xs) - #.None - (recur (inc idx)) - - (#.Some x) - (if (p idx x) - (#.Some [idx x]) - (recur (inc idx)))) - #.None)))) - -(def: #export (clone xs) - (All [a] (-> (Array a) (Array a))) - (let [arr_size (size xs)] - (list\fold (function (_ idx ys) - (case (read idx xs) - #.None - ys - - (#.Some x) - (write! idx x ys))) - (new arr_size) - (list.indices arr_size)))) - -(def: #export (from_list xs) - (All [a] (-> (List a) (Array a))) - (product.right (list\fold (function (_ x [idx arr]) - [(inc idx) (write! idx x arr)]) - [0 (new (list.size xs))] - xs))) - -(def: underflow Nat (dec 0)) - -(def: #export (to_list array) - (All [a] (-> (Array a) (List a))) - (loop [idx (dec (size array)) - output #.Nil] - (if (n.= ..underflow idx) - output - (recur (dec idx) - (case (read idx array) - (#.Some head) - (#.Cons head output) - - #.None - output))))) - -(def: #export (to_list' default array) - (All [a] (-> a (Array a) (List a))) - (loop [idx (dec (size array)) - output #.Nil] - (if (n.= ..underflow idx) - output - (recur (dec idx) - (#.Cons (maybe.default default (read idx array)) - output))))) - -(implementation: #export (equivalence (^open ",\.")) - (All [a] (-> (Equivalence a) (Equivalence (Array a)))) - - (def: (= xs ys) - (let [sxs (size xs) - sxy (size ys)] - (and (n.= sxy sxs) - (list\fold (function (_ idx prev) - (and prev - (case [(read idx xs) (read idx ys)] - [#.None #.None] - true - - [(#.Some x) (#.Some y)] - (,\= x y) - - _ - false))) - true - (list.indices sxs)))))) - -(implementation: #export monoid - (All [a] (Monoid (Array a))) - - (def: identity (new 0)) - - (def: (compose xs ys) - (let [sxs (size xs) - sxy (size ys)] - (|> (new (n.+ sxy sxs)) - (copy! sxs 0 xs 0) - (copy! sxy 0 ys sxs))))) - -(implementation: #export functor - (Functor Array) - - (def: (map f ma) - (let [arr_size (size ma)] - (if (n.= 0 arr_size) - (new arr_size) - (list\fold (function (_ idx mb) - (case (read idx ma) - #.None - mb - - (#.Some x) - (write! idx (f x) mb))) - (new arr_size) - (list.indices arr_size)) - )))) - -(implementation: #export fold - (Fold Array) - - (def: (fold f init xs) - (let [arr_size (size xs)] - (loop [so_far init - idx 0] - (if (n.< arr_size idx) - (case (read idx xs) - #.None - (recur so_far (inc idx)) - - (#.Some value) - (recur (f value so_far) (inc idx))) - so_far))))) - -(template [<name> <init> <op>] - [(def: #export (<name> predicate array) - (All [a] - (-> (Predicate a) (Predicate (Array a)))) - (let [size (..size array)] - (loop [idx 0] - (if (n.< size idx) - (case (..read idx array) - (#.Some value) - (<op> (predicate value) - (recur (inc idx))) - - #.None - (recur (inc idx))) - <init>))))] - - [every? true and] - [any? false or] - ) diff --git a/stdlib/source/lux/data/collection/bits.lux b/stdlib/source/lux/data/collection/bits.lux deleted file mode 100644 index 78d7df988..000000000 --- a/stdlib/source/lux/data/collection/bits.lux +++ /dev/null @@ -1,176 +0,0 @@ -(.module: - [lux (#- not and or) - [abstract - [equivalence (#+ Equivalence)]] - [control - pipe] - [data - ["." maybe] - [collection - ["." array (#+ Array) ("#\." fold)]]] - [math - [number - ["n" nat] - ["." i64]]]]) - -(type: #export Chunk - I64) - -(def: #export chunk-size - i64.width) - -(type: #export Bits - (Array Chunk)) - -(def: empty-chunk - Chunk - (.i64 0)) - -(def: #export empty - Bits - (array.new 0)) - -(def: #export (size bits) - (-> Bits Nat) - (array\fold (function (_ chunk total) - (|> chunk i64.count (n.+ total))) - 0 - bits)) - -(def: #export (capacity bits) - (-> Bits Nat) - (|> bits array.size (n.* chunk-size))) - -(def: #export empty? - (-> Bits Bit) - (|>> size (n.= 0))) - -(def: #export (get index bits) - (-> Nat Bits Bit) - (let [[chunk-index bit-index] (n./% chunk-size index)] - (.and (n.< (array.size bits) chunk-index) - (|> (array.read chunk-index bits) - (maybe.default empty-chunk) - (i64.set? bit-index))))) - -(def: (chunk idx bits) - (-> Nat Bits Chunk) - (if (n.< (array.size bits) idx) - (|> bits (array.read idx) (maybe.default empty-chunk)) - empty-chunk)) - -(template [<name> <op>] - [(def: #export (<name> index input) - (-> Nat Bits Bits) - (let [[chunk-index bit-index] (n./% chunk-size index)] - (loop [size|output (n.max (inc chunk-index) - (array.size input)) - output ..empty] - (let [idx|output (dec size|output)] - (if (n.> 0 size|output) - (case (|> (..chunk idx|output input) - (cond> [(new> (n.= chunk-index idx|output) [])] - [(<op> bit-index)] - - ## else - []) - .nat) - 0 - ## TODO: Remove 'no-op' once new-luxc is the official compiler. - (let [no-op (recur (dec size|output) output)] - no-op) - - chunk - (|> (if (is? ..empty output) - (: Bits (array.new size|output)) - output) - (array.write! idx|output (.i64 chunk)) - (recur (dec size|output)))) - output)))))] - - [set i64.set] - [clear i64.clear] - [flip i64.flip] - ) - -(def: #export (intersects? reference sample) - (-> Bits Bits Bit) - (let [chunks (n.min (array.size reference) - (array.size sample))] - (loop [idx 0] - (if (n.< chunks idx) - (.or (|> (..chunk idx sample) - (i64.and (..chunk idx reference)) - ("lux i64 =" empty-chunk) - .not) - (recur (inc idx))) - #0)))) - -(def: #export (not input) - (-> Bits Bits) - (case (array.size input) - 0 - ..empty - - size|output - (loop [size|output size|output - output ..empty] - (let [idx (dec size|output)] - (case (|> input (..chunk idx) i64.not .nat) - 0 - (recur (dec size|output) output) - - chunk - (if (n.> 0 size|output) - (|> (if (is? ..empty output) - (: Bits (array.new size|output)) - output) - (array.write! idx (.i64 chunk)) - (recur (dec size|output))) - output)))))) - -(template [<name> <op>] - [(def: #export (<name> param subject) - (-> Bits Bits Bits) - (case (n.max (array.size param) - (array.size subject)) - 0 - ..empty - - size|output - (loop [size|output size|output - output ..empty] - (let [idx (dec size|output)] - (if (n.> 0 size|output) - (case (|> (..chunk idx subject) - (<op> (..chunk idx param)) - .nat) - 0 - (recur (dec size|output) output) - - chunk - (|> (if (is? ..empty output) - (: Bits (array.new size|output)) - output) - (array.write! idx (.i64 chunk)) - (recur (dec size|output)))) - output)))))] - - [and i64.and] - [or i64.or] - [xor i64.xor] - ) - -(implementation: #export equivalence - (Equivalence Bits) - - (def: (= reference sample) - (let [size (n.max (array.size reference) - (array.size sample))] - (loop [idx 0] - (if (n.< size idx) - (.and ("lux i64 =" - (..chunk idx reference) - (..chunk idx sample)) - (recur (inc idx))) - #1))))) diff --git a/stdlib/source/lux/data/collection/dictionary.lux b/stdlib/source/lux/data/collection/dictionary.lux deleted file mode 100644 index 4aa50c9a7..000000000 --- a/stdlib/source/lux/data/collection/dictionary.lux +++ /dev/null @@ -1,731 +0,0 @@ -(.module: - [lux #* - [abstract - [hash (#+ Hash)] - [equivalence (#+ Equivalence)] - [functor (#+ Functor)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["." maybe] - ["." product] - [collection - ["." list ("#\." fold functor monoid)] - ["." array (#+ Array) ("#\." functor fold)]]] - [math - ["." number - ["n" nat] - ["." i64]]]]) - -## This implementation of Hash Array Mapped Trie (HAMT) is based on -## Clojure's PersistentHashMap implementation. -## That one is further based on Phil Bagwell's Hash Array Mapped Trie. - -## Bitmaps are used to figure out which branches on a #Base node are -## populated. The number of bits that are 1s in a bitmap signal the -## size of the #Base node. -(type: BitMap - Nat) - -## Represents the position of a node in a BitMap. -## It's meant to be a single bit set on a 32-bit word. -## The position of the bit reflects whether an entry in an analogous -## position exists within a #Base, as reflected in its BitMap. -(type: BitPosition - Nat) - -## An index into an array. -(type: Index - Nat) - -## A hash-code derived from a key during tree-traversal. -(type: Hash_Code - Nat) - -## Represents the nesting level of a leaf or node, when looking-it-up -## while exploring the tree. -## Changes in levels are done by right-shifting the hashes of keys by -## the appropriate multiple of the branching-exponent. -## A shift of 0 means root level. -## A shift of (* branching_exponent 1) means level 2. -## A shift of (* branching_exponent N) means level N+1. -(type: Level - Nat) - -## Nodes for the tree data-structure that organizes the data inside -## Dictionaries. -(type: (Node k v) - (#Hierarchy Nat (Array (Node k v))) - (#Base BitMap - (Array (Either (Node k v) - [k v]))) - (#Collisions Hash_Code (Array [k v]))) - -## #Hierarchy nodes are meant to point down only to lower-level nodes. -(type: (Hierarchy k v) - [Nat (Array (Node k v))]) - -## #Base nodes may point down to other nodes, but also to leaves, -## which are KV-pairs. -(type: (Base k v) - (Array (Either (Node k v) - [k v]))) - -## #Collisions are collections of KV-pairs for which the key is -## different on each case, but their hashes are all the same (thus -## causing a collision). -(type: (Collisions k v) - (Array [k v])) - -## That bitmap for an empty #Base is 0. -## Which is the same as 0000 0000 0000 0000 0000 0000 0000 0000. -## Or 0x00000000. -## Which is 32 zeroes, since the branching factor is 32. -(def: clean_bitmap - BitMap - 0) - -## Bitmap position (while looking inside #Base nodes) is determined by -## getting 5 bits from a hash of the key being looked up and using -## them as an index into the array inside #Base. -## Since the data-structure can have multiple levels (and the hash has -## more than 5 bits), the binary-representation of the hash is shifted -## by 5 positions on each step (2^5 = 32, which is the branching -## factor). -## The initial shifting level, though, is 0 (which corresponds to the -## shift in the shallowest node on the tree, which is the root node). -(def: root_level - Level - 0) - -## The exponent to which 2 must be elevated, to reach the branching -## factor of the data-structure. -(def: branching_exponent - Nat - 5) - -## The threshold on which #Hierarchy nodes are demoted to #Base nodes, -## which is 1/4 of the branching factor (or a left-shift 2). -(def: demotion_threshold - Nat - (i64.left_shift (n.- 2 branching_exponent) 1)) - -## The threshold on which #Base nodes are promoted to #Hierarchy nodes, -## which is 1/2 of the branching factor (or a left-shift 1). -(def: promotion_threshold - Nat - (i64.left_shift (n.- 1 branching_exponent) 1)) - -## The size of hierarchy-nodes, which is 2^(branching-exponent). -(def: hierarchy_nodes_size - Nat - (i64.left_shift branching_exponent 1)) - -## The cannonical empty node, which is just an empty #Base node. -(def: empty - Node - (#Base clean_bitmap (array.new 0))) - -## Expands a copy of the array, to have 1 extra slot, which is used -## for storing the value. -(def: (insert! idx value old_array) - (All [a] (-> Index a (Array a) (Array a))) - (let [old_size (array.size old_array)] - (|> (array.new (inc old_size)) - (array.copy! idx 0 old_array 0) - (array.write! idx value) - (array.copy! (n.- idx old_size) idx old_array (inc idx))))) - -## Creates a copy of an array with an index set to a particular value. -(def: (update! idx value array) - (All [a] (-> Index a (Array a) (Array a))) - (|> array array.clone (array.write! idx value))) - -## Creates a clone of the array, with an empty position at index. -(def: (vacant! idx array) - (All [a] (-> Index (Array a) (Array a))) - (|> array array.clone (array.delete! idx))) - -## Shrinks a copy of the array by removing the space at index. -(def: (remove! idx array) - (All [a] (-> Index (Array a) (Array a))) - (let [new_size (dec (array.size array))] - (|> (array.new new_size) - (array.copy! idx 0 array 0) - (array.copy! (n.- idx new_size) (inc idx) array idx)))) - -## Increases the level-shift by the branching-exponent, to explore -## levels further down the tree. -(def: level_up - (-> Level Level) - (n.+ branching_exponent)) - -(def: hierarchy_mask - BitMap - (dec hierarchy_nodes_size)) - -## Gets the branching-factor sized section of the hash corresponding -## to a particular level, and uses that as an index into the array. -(def: (level_index level hash) - (-> Level Hash_Code Index) - (i64.and ..hierarchy_mask - (i64.right_shift level hash))) - -## A mechanism to go from indices to bit-positions. -(def: (->bit_position index) - (-> Index BitPosition) - (i64.left_shift index 1)) - -## The bit-position within a base that a given hash-code would have. -(def: (bit_position level hash) - (-> Level Hash_Code BitPosition) - (->bit_position (level_index level hash))) - -(def: (bit_position_is_set? bit bitmap) - (-> BitPosition BitMap Bit) - (|> bitmap - (i64.and bit) - (n.= clean_bitmap) - not)) - -## Figures out whether a bitmap only contains a single bit-position. -(def: only_bit_position? - (-> BitPosition BitMap Bit) - n.=) - -(def: (set_bit_position bit bitmap) - (-> BitPosition BitMap BitMap) - (i64.or bit bitmap)) - -(def: unset_bit_position - (-> BitPosition BitMap BitMap) - i64.xor) - -## Figures out the size of a bitmap-indexed array by counting all the -## 1s within the bitmap. -(def: bitmap_size - (-> BitMap Nat) - i64.count) - -## A mask that, for a given bit position, only allows all the 1s prior -## to it, which would indicate the bitmap-size (and, thus, index) -## associated with it. -(def: bit_position_mask - (-> BitPosition BitMap) - dec) - -## The index on the base array, based on its bit-position. -(def: (base_index bit_position bitmap) - (-> BitPosition BitMap Index) - (bitmap_size (i64.and (bit_position_mask bit_position) - bitmap))) - -## Produces the index of a KV-pair within a #Collisions node. -(def: (collision_index Hash<k> key colls) - (All [k v] (-> (Hash k) k (Collisions k v) (Maybe Index))) - (\ maybe.monad map product.left - (array.find+ (function (_ idx [key' val']) - (\ Hash<k> = key key')) - colls))) - -## When #Hierarchy nodes grow too small, they're demoted to #Base -## nodes to save space. -(def: (demote_hierarchy except_idx [h_size h_array]) - (All [k v] (-> Index (Hierarchy k v) [BitMap (Base k v)])) - (product.right (list\fold (function (_ idx [insertion_idx node]) - (let [[bitmap base] node] - (case (array.read idx h_array) - #.None [insertion_idx node] - (#.Some sub_node) (if (n.= except_idx idx) - [insertion_idx node] - [(inc insertion_idx) - [(set_bit_position (->bit_position idx) bitmap) - (array.write! insertion_idx (#.Left sub_node) base)]]) - ))) - [0 [clean_bitmap - (array.new (dec h_size))]] - (list.indices (array.size h_array))))) - -## When #Base nodes grow too large, they're promoted to #Hierarchy to -## add some depth to the tree and help keep its balance. -(def: hierarchy_indices (List Index) (list.indices hierarchy_nodes_size)) - -(def: (promote_base put' Hash<k> level bitmap base) - (All [k v] - (-> (-> Level Hash_Code k v (Hash k) (Node k v) (Node k v)) - (Hash k) Level - BitMap (Base k v) - (Array (Node k v)))) - (product.right (list\fold (function (_ hierarchy_idx (^@ default [base_idx h_array])) - (if (bit_position_is_set? (->bit_position hierarchy_idx) - bitmap) - [(inc base_idx) - (case (array.read base_idx base) - (#.Some (#.Left sub_node)) - (array.write! hierarchy_idx sub_node h_array) - - (#.Some (#.Right [key' val'])) - (array.write! hierarchy_idx - (put' (level_up level) (\ Hash<k> hash key') key' val' Hash<k> empty) - h_array) - - #.None - (undefined))] - default)) - [0 - (array.new hierarchy_nodes_size)] - hierarchy_indices))) - -## All empty nodes look the same (a #Base node with clean bitmap is -## used). -## So, this test is introduced to detect them. -(def: (empty?' node) - (All [k v] (-> (Node k v) Bit)) - (`` (case node - (#Base (~~ (static ..clean_bitmap)) _) - #1 - - _ - #0))) - -(def: (put' level hash key val Hash<k> node) - (All [k v] (-> Level Hash_Code k v (Hash k) (Node k v) (Node k v))) - (case node - ## For #Hierarchy nodes, check whether one can add the element to - ## a sub-node. If impossible, introduce a new singleton sub-node. - (#Hierarchy _size hierarchy) - (let [idx (level_index level hash) - [_size' sub_node] (case (array.read idx hierarchy) - (#.Some sub_node) - [_size sub_node] - - _ - [(inc _size) empty])] - (#Hierarchy _size' - (update! idx (put' (level_up level) hash key val Hash<k> sub_node) - hierarchy))) - - ## For #Base nodes, check if the corresponding BitPosition has - ## already been used. - (#Base bitmap base) - (let [bit (bit_position level hash)] - (if (bit_position_is_set? bit bitmap) - ## If so... - (let [idx (base_index bit bitmap)] - (case (array.read idx base) - ## If it's being used by a node, add the KV to it. - (#.Some (#.Left sub_node)) - (let [sub_node' (put' (level_up level) hash key val Hash<k> sub_node)] - (#Base bitmap (update! idx (#.Left sub_node') base))) - - ## Otherwise, if it's being used by a KV, compare the keys. - (#.Some (#.Right key' val')) - (if (\ Hash<k> = key key') - ## If the same key is found, replace the value. - (#Base bitmap (update! idx (#.Right key val) base)) - ## Otherwise, compare the hashes of the keys. - (#Base bitmap (update! idx - (#.Left (let [hash' (\ Hash<k> hash key')] - (if (n.= hash hash') - ## If the hashes are - ## the same, a new - ## #Collisions node - ## is added. - (#Collisions hash (|> (array.new 2) - (array.write! 0 [key' val']) - (array.write! 1 [key val]))) - ## Otherwise, one can - ## just keep using - ## #Base nodes, so - ## add both KV-pairs - ## to the empty one. - (let [next_level (level_up level)] - (|> empty - (put' next_level hash' key' val' Hash<k>) - (put' next_level hash key val Hash<k>)))))) - base))) - - #.None - (undefined))) - ## However, if the BitPosition has not been used yet, check - ## whether this #Base node is ready for a promotion. - (let [base_count (bitmap_size bitmap)] - (if (n.>= ..promotion_threshold base_count) - ## If so, promote it to a #Hierarchy node, and add the new - ## KV-pair as a singleton node to it. - (#Hierarchy (inc base_count) - (|> (promote_base put' Hash<k> level bitmap base) - (array.write! (level_index level hash) - (put' (level_up level) hash key val Hash<k> empty)))) - ## Otherwise, just resize the #Base node to accommodate the - ## new KV-pair. - (#Base (set_bit_position bit bitmap) - (insert! (base_index bit bitmap) (#.Right [key val]) base)))))) - - ## For #Collisions nodes, compare the hashes. - (#Collisions _hash _colls) - (if (n.= hash _hash) - ## If they're equal, that means the new KV contributes to the - ## collisions. - (case (collision_index Hash<k> key _colls) - ## If the key was already present in the collisions-list, its - ## value gets updated. - (#.Some coll_idx) - (#Collisions _hash (update! coll_idx [key val] _colls)) - - ## Otherwise, the KV-pair is added to the collisions-list. - #.None - (#Collisions _hash (insert! (array.size _colls) [key val] _colls))) - ## If the hashes are not equal, create a new #Base node that - ## contains the old #Collisions node, plus the new KV-pair. - (|> (#Base (bit_position level _hash) - (|> (array.new 1) - (array.write! 0 (#.Left node)))) - (put' level hash key val Hash<k>))) - )) - -(def: (remove' level hash key Hash<k> node) - (All [k v] (-> Level Hash_Code k (Hash k) (Node k v) (Node k v))) - (case node - ## For #Hierarchy nodes, find out if there's a valid sub-node for - ## the Hash-Code. - (#Hierarchy h_size h_array) - (let [idx (level_index level hash)] - (case (array.read idx h_array) - ## If not, there's nothing to remove. - #.None - node - - ## But if there is, try to remove the key from the sub-node. - (#.Some sub_node) - (let [sub_node' (remove' (level_up level) hash key Hash<k> sub_node)] - ## Then check if a removal was actually done. - (if (is? sub_node sub_node') - ## If not, then there's nothing to change here either. - node - ## But if the sub_removal yielded an empty sub_node... - (if (empty?' sub_node') - ## Check if it's due time for a demotion. - (if (n.<= demotion_threshold h_size) - ## If so, perform it. - (#Base (demote_hierarchy idx [h_size h_array])) - ## Otherwise, just clear the space. - (#Hierarchy (dec h_size) (vacant! idx h_array))) - ## But if the sub_removal yielded a non_empty node, then - ## just update the hiearchy branch. - (#Hierarchy h_size (update! idx sub_node' h_array))))))) - - ## For #Base nodes, check whether the BitPosition is set. - (#Base bitmap base) - (let [bit (bit_position level hash)] - (if (bit_position_is_set? bit bitmap) - (let [idx (base_index bit bitmap)] - (case (array.read idx base) - ## If set, check if it's a sub_node, and remove the KV - ## from it. - (#.Some (#.Left sub_node)) - (let [sub_node' (remove' (level_up level) hash key Hash<k> sub_node)] - ## Verify that it was removed. - (if (is? sub_node sub_node') - ## If not, there's also nothing to change here. - node - ## But if it came out empty... - (if (empty?' sub_node') - ### ... figure out whether that's the only position left. - (if (only_bit_position? bit bitmap) - ## If so, removing it leaves this node empty too. - empty - ## But if not, then just unset the position and - ## remove the node. - (#Base (unset_bit_position bit bitmap) - (remove! idx base))) - ## But, if it did not come out empty, then the - ## position is kept, and the node gets updated. - (#Base bitmap - (update! idx (#.Left sub_node') base))))) - - ## If, however, there was a KV-pair instead of a sub-node. - (#.Some (#.Right [key' val'])) - ## Check if the keys match. - (if (\ Hash<k> = key key') - ## If so, remove the KV-pair and unset the BitPosition. - (#Base (unset_bit_position bit bitmap) - (remove! idx base)) - ## Otherwise, there's nothing to remove. - node) - - #.None - (undefined))) - ## If the BitPosition is not set, there's nothing to remove. - node)) - - ## For #Collisions nodes, It need to find out if the key already existst. - (#Collisions _hash _colls) - (case (collision_index Hash<k> key _colls) - ## If not, then there's nothing to remove. - #.None - node - - ## But if so, then check the size of the collisions list. - (#.Some idx) - (if (n.= 1 (array.size _colls)) - ## If there's only one left, then removing it leaves us with - ## an empty node. - empty - ## Otherwise, just shrink the array by removing the KV-pair. - (#Collisions _hash (remove! idx _colls)))) - )) - -(def: (get' level hash key Hash<k> node) - (All [k v] (-> Level Hash_Code k (Hash k) (Node k v) (Maybe v))) - (case node - ## For #Hierarchy nodes, just look-up the key on its children. - (#Hierarchy _size hierarchy) - (case (array.read (level_index level hash) hierarchy) - #.None #.None - (#.Some sub_node) (get' (level_up level) hash key Hash<k> sub_node)) - - ## For #Base nodes, check the leaves, and recursively check the branches. - (#Base bitmap base) - (let [bit (bit_position level hash)] - (if (bit_position_is_set? bit bitmap) - (case (array.read (base_index bit bitmap) base) - (#.Some (#.Left sub_node)) - (get' (level_up level) hash key Hash<k> sub_node) - - (#.Some (#.Right [key' val'])) - (if (\ Hash<k> = key key') - (#.Some val') - #.None) - - #.None - (undefined)) - #.None)) - - ## For #Collisions nodes, do a linear scan of all the known KV-pairs. - (#Collisions _hash _colls) - (\ maybe.monad map product.right - (array.find (|>> product.left (\ Hash<k> = key)) - _colls)) - )) - -(def: (size' node) - (All [k v] (-> (Node k v) Nat)) - (case node - (#Hierarchy _size hierarchy) - (array\fold n.+ 0 (array\map size' hierarchy)) - - (#Base _ base) - (array\fold n.+ 0 (array\map (function (_ sub_node') - (case sub_node' - (#.Left sub_node) (size' sub_node) - (#.Right _) 1)) - base)) - - (#Collisions hash colls) - (array.size colls) - )) - -(def: (entries' node) - (All [k v] (-> (Node k v) (List [k v]))) - (case node - (#Hierarchy _size hierarchy) - (array\fold (function (_ sub_node tail) (list\compose (entries' sub_node) tail)) - #.Nil - hierarchy) - - (#Base bitmap base) - (array\fold (function (_ branch tail) - (case branch - (#.Left sub_node) - (list\compose (entries' sub_node) tail) - - (#.Right [key' val']) - (#.Cons [key' val'] tail))) - #.Nil - base) - - (#Collisions hash colls) - (array\fold (function (_ [key' val'] tail) (#.Cons [key' val'] tail)) - #.Nil - colls))) - -(type: #export (Dictionary k v) - {#.doc "A dictionary implemented as a Hash-Array Mapped Trie (HAMT)."} - {#hash (Hash k) - #root (Node k v)}) - -(def: #export key_hash - (All [k v] (-> (Dictionary k v) (Hash k))) - (get@ #..hash)) - -(def: #export (new Hash<k>) - (All [k v] (-> (Hash k) (Dictionary k v))) - {#hash Hash<k> - #root empty}) - -(def: #export (put key val dict) - (All [k v] (-> k v (Dictionary k v) (Dictionary k v))) - (let [[Hash<k> node] dict] - [Hash<k> (put' root_level (\ Hash<k> hash key) key val Hash<k> node)])) - -(def: #export (remove key dict) - (All [k v] (-> k (Dictionary k v) (Dictionary k v))) - (let [[Hash<k> node] dict] - [Hash<k> (remove' root_level (\ Hash<k> hash key) key Hash<k> node)])) - -(def: #export (get key dict) - (All [k v] (-> k (Dictionary k v) (Maybe v))) - (let [[Hash<k> node] dict] - (get' root_level (\ Hash<k> hash key) key Hash<k> node))) - -(def: #export (key? dict key) - (All [k v] (-> (Dictionary k v) k Bit)) - (case (get key dict) - #.None #0 - (#.Some _) #1)) - -(exception: #export key_already_exists) - -(def: #export (try_put key val dict) - {#.doc "Only puts the KV-pair if the key is not already present."} - (All [k v] (-> k v (Dictionary k v) (Try (Dictionary k v)))) - (case (get key dict) - #.None (#try.Success (put key val dict)) - (#.Some _) (exception.throw ..key_already_exists []))) - -(def: #export (update key f dict) - {#.doc "Transforms the value located at key (if available), using the given function."} - (All [k v] (-> k (-> v v) (Dictionary k v) (Dictionary k v))) - (case (get key dict) - #.None - dict - - (#.Some val) - (put key (f val) dict))) - -(def: #export (upsert key default f dict) - {#.doc (doc "Updates the value at the key; if it exists." - "Otherwise, puts a value by applying the function to a default.")} - (All [k v] (-> k v (-> v v) (Dictionary k v) (Dictionary k v))) - (..put key - (f (maybe.default default - (..get key dict))) - dict)) - -(def: #export size - (All [k v] (-> (Dictionary k v) Nat)) - (|>> product.right ..size')) - -(def: #export empty? - (All [k v] (-> (Dictionary k v) Bit)) - (|>> size (n.= 0))) - -(def: #export (entries dict) - (All [k v] (-> (Dictionary k v) (List [k v]))) - (entries' (product.right dict))) - -(def: #export (from_list Hash<k> kvs) - (All [k v] (-> (Hash k) (List [k v]) (Dictionary k v))) - (list\fold (function (_ [k v] dict) - (put k v dict)) - (new Hash<k>) - kvs)) - -(template [<name> <elem_type> <side>] - [(def: #export (<name> dict) - (All [k v] (-> (Dictionary k v) (List <elem_type>))) - (|> dict entries (list\map <side>)))] - - [keys k product.left] - [values v product.right] - ) - -(def: #export (merge dict2 dict1) - {#.doc (doc "Merges 2 dictionaries." - "If any collisions with keys occur, the values of dict2 will overwrite those of dict1.")} - (All [k v] (-> (Dictionary k v) (Dictionary k v) (Dictionary k v))) - (list\fold (function (_ [key val] dict) (put key val dict)) - dict1 - (entries dict2))) - -(def: #export (merge_with f dict2 dict1) - {#.doc (doc "Merges 2 dictionaries." - "If any collisions with keys occur, a new value will be computed by applying 'f' to the values of dict2 and dict1.")} - (All [k v] (-> (-> v v v) (Dictionary k v) (Dictionary k v) (Dictionary k v))) - (list\fold (function (_ [key val2] dict) - (case (get key dict) - #.None - (put key val2 dict) - - (#.Some val1) - (put key (f val2 val1) dict))) - dict1 - (entries dict2))) - -(def: #export (re_bind from_key to_key dict) - (All [k v] (-> k k (Dictionary k v) (Dictionary k v))) - (case (get from_key dict) - #.None - dict - - (#.Some val) - (|> dict - (remove from_key) - (put to_key val)))) - -(def: #export (select keys dict) - {#.doc "Creates a sub-set of the given dict, with only the specified keys."} - (All [k v] (-> (List k) (Dictionary k v) (Dictionary k v))) - (let [[Hash<k> _] dict] - (list\fold (function (_ key new_dict) - (case (get key dict) - #.None new_dict - (#.Some val) (put key val new_dict))) - (new Hash<k>) - keys))) - -(implementation: #export (equivalence (^open ",\.")) - (All [k v] (-> (Equivalence v) (Equivalence (Dictionary k v)))) - - (def: (= reference subject) - (and (n.= (..size reference) - (..size subject)) - (list.every? (function (_ [k rv]) - (case (..get k subject) - (#.Some sv) - (,\= rv sv) - - _ - #0)) - (..entries reference))))) - -(implementation: functor' - (All [k] (Functor (Node k))) - - (def: (map f fa) - (case fa - (#Hierarchy size hierarchy) - (#Hierarchy size (array\map (map f) hierarchy)) - - (#Base bitmap base) - (#Base bitmap (array\map (function (_ either) - (case either - (#.Left fa') - (#.Left (map f fa')) - - (#.Right [k v]) - (#.Right [k (f v)]))) - base)) - - (#Collisions hash collisions) - (#Collisions hash (array\map (function (_ [k v]) - [k (f v)]) - collisions))))) - -(implementation: #export functor - (All [k] (Functor (Dictionary k))) - - (def: (map f fa) - (update@ #root (\ ..functor' map f) fa))) diff --git a/stdlib/source/lux/data/collection/dictionary/ordered.lux b/stdlib/source/lux/data/collection/dictionary/ordered.lux deleted file mode 100644 index 618c5ccf6..000000000 --- a/stdlib/source/lux/data/collection/dictionary/ordered.lux +++ /dev/null @@ -1,583 +0,0 @@ -(.module: - [lux #* - [abstract - equivalence - [monad (#+ Monad do)] - ["." order (#+ Order)]] - [data - ["p" product] - ["." maybe] - [collection - ["." list ("#\." monoid fold)]]] - [macro - ["." code]] - [math - [number - ["n" nat]]]]) - -(def: error_message - "Invariant violation") - -(type: Color - #Red - #Black) - -(type: (Node k v) - {#color Color - #key k - #value v - #left (Maybe (Node k v)) - #right (Maybe (Node k v))}) - -(template [<create> <color>] - [(def: (<create> key value left right) - (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) - {#color <color> - #key key - #value value - #left left - #right right})] - - [red #Red] - [black #Black] - ) - -(type: #export (Dictionary k v) - {#&order (Order k) - #root (Maybe (Node k v))}) - -(def: #export (new order) - (All [k v] (-> (Order k) (Dictionary k v))) - {#&order order - #root #.None}) - -## TODO: Doing inneficient access of Order functions due to compiler bug. -## TODO: Must improve it as soon as bug is fixed. -(def: #export (get key dict) - (All [k v] (-> k (Dictionary k v) (Maybe v))) - (let [## (^open "_\.") (get@ #&order dict) - ] - (loop [node (get@ #root dict)] - (case node - #.None - #.None - - (#.Some node) - (let [node_key (get@ #key node)] - (cond (\ dict = node_key key) - ## (_\= node_key key) - (#.Some (get@ #value node)) - - (\ dict < node_key key) - ## (_\< node_key key) - (recur (get@ #left node)) - - ## (_\> (get@ #key node) key) - (recur (get@ #right node)))) - )))) - -## TODO: Doing inneficient access of Order functions due to compiler bug. -## TODO: Must improve it as soon as bug is fixed. -(def: #export (key? dict key) - (All [k v] (-> (Dictionary k v) k Bit)) - (let [## (^open "_\.") (get@ #&order dict) - ] - (loop [node (get@ #root dict)] - (case node - #.None - #0 - - (#.Some node) - (let [node_key (get@ #key node)] - (or (\ dict = node_key key) - ## (_\= node_key key) - (if (\ dict < node_key key) - ## (_\< node_key key) - (recur (get@ #left node)) - (recur (get@ #right node))))))))) - -(template [<name> <side>] - [(def: #export (<name> dict) - (All [k v] (-> (Dictionary k v) (Maybe v))) - (case (get@ #root dict) - #.None - #.None - - (#.Some node) - (loop [node node] - (case (get@ <side> node) - #.None - (#.Some (get@ #value node)) - - (#.Some side) - (recur side)))))] - - [min #left] - [max #right] - ) - -(def: #export (size dict) - (All [k v] (-> (Dictionary k v) Nat)) - (loop [node (get@ #root dict)] - (case node - #.None - 0 - - (#.Some node) - (inc (n.+ (recur (get@ #left node)) - (recur (get@ #right node))))))) - -(def: #export empty? - (All [k v] (-> (Dictionary k v) Bit)) - (|>> ..size (n.= 0))) - -(template [<name> <other_color> <self_color> <no_change>] - [(def: (<name> self) - (All [k v] (-> (Node k v) (Node k v))) - (case (get@ #color self) - <other_color> - (set@ #color <self_color> self) - - <self_color> - <no_change> - ))] - - [blacken #Red #Black self] - [redden #Black #Red (error! error_message)] - ) - -(def: (balance_left_add parent self) - (All [k v] (-> (Node k v) (Node k v) (Node k v))) - (with_expansions - [<default_behavior> (as_is (black (get@ #key parent) - (get@ #value parent) - (#.Some self) - (get@ #right parent)))] - (case (get@ #color self) - #Red - (case (get@ #left self) - (^multi (#.Some left) - [(get@ #color left) #Red]) - (red (get@ #key self) - (get@ #value self) - (#.Some (blacken left)) - (#.Some (black (get@ #key parent) - (get@ #value parent) - (get@ #right self) - (get@ #right parent)))) - - _ - (case (get@ #right self) - (^multi (#.Some right) - [(get@ #color right) #Red]) - (red (get@ #key right) - (get@ #value right) - (#.Some (black (get@ #key self) - (get@ #value self) - (get@ #left self) - (get@ #left right))) - (#.Some (black (get@ #key parent) - (get@ #value parent) - (get@ #right right) - (get@ #right parent)))) - - _ - <default_behavior>)) - - #Black - <default_behavior> - ))) - -(def: (balance_right_add parent self) - (All [k v] (-> (Node k v) (Node k v) (Node k v))) - (with_expansions - [<default_behavior> (as_is (black (get@ #key parent) - (get@ #value parent) - (get@ #left parent) - (#.Some self)))] - (case (get@ #color self) - #Red - (case (get@ #right self) - (^multi (#.Some right) - [(get@ #color right) #Red]) - (red (get@ #key self) - (get@ #value self) - (#.Some (black (get@ #key parent) - (get@ #value parent) - (get@ #left parent) - (get@ #left self))) - (#.Some (blacken right))) - - _ - (case (get@ #left self) - (^multi (#.Some left) - [(get@ #color left) #Red]) - (red (get@ #key left) - (get@ #value left) - (#.Some (black (get@ #key parent) - (get@ #value parent) - (get@ #left parent) - (get@ #left left))) - (#.Some (black (get@ #key self) - (get@ #value self) - (get@ #right left) - (get@ #right self)))) - - _ - <default_behavior>)) - - #Black - <default_behavior> - ))) - -(def: (add_left addition center) - (All [k v] (-> (Node k v) (Node k v) (Node k v))) - (case (get@ #color center) - #Red - (red (get@ #key center) (get@ #value center) (#.Some addition) (get@ #right center)) - - #Black - (balance_left_add center addition) - )) - -(def: (add_right addition center) - (All [k v] (-> (Node k v) (Node k v) (Node k v))) - (case (get@ #color center) - #Red - (red (get@ #key center) (get@ #value center) (get@ #left center) (#.Some addition)) - - #Black - (balance_right_add center addition) - )) - -(def: #export (put key value dict) - (All [k v] (-> k v (Dictionary k v) (Dictionary k v))) - (let [(^open "_\.") (get@ #&order dict) - root' (loop [?root (get@ #root dict)] - (case ?root - #.None - (#.Some (red key value #.None #.None)) - - (#.Some root) - (let [reference (get@ #key root)] - (`` (cond (~~ (template [<comp> <tag> <add>] - [(<comp> reference key) - (let [side_root (get@ <tag> root) - outcome (recur side_root)] - (if (is? side_root outcome) - ?root - (#.Some (<add> (maybe.assume outcome) - root))))] - - [_\< #left add_left] - [(order.> (get@ #&order dict)) #right add_right] - )) - - ## (_\= reference key) - (#.Some (set@ #value value root)) - ))) - ))] - (set@ #root root' dict))) - -(def: (left_balance key value ?left ?right) - (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) - (case ?left - (^multi (#.Some left) - [(get@ #color left) #Red] - [(get@ #left left) (#.Some left>>left)] - [(get@ #color left>>left) #Red]) - (red (get@ #key left) - (get@ #value left) - (#.Some (blacken left>>left)) - (#.Some (black key value (get@ #right left) ?right))) - - (^multi (#.Some left) - [(get@ #color left) #Red] - [(get@ #right left) (#.Some left>>right)] - [(get@ #color left>>right) #Red]) - (red (get@ #key left>>right) - (get@ #value left>>right) - (#.Some (black (get@ #key left) - (get@ #value left) - (get@ #left left) - (get@ #left left>>right))) - (#.Some (black key value - (get@ #right left>>right) - ?right))) - - _ - (black key value ?left ?right))) - -(def: (right_balance key value ?left ?right) - (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) - (case ?right - (^multi (#.Some right) - [(get@ #color right) #Red] - [(get@ #right right) (#.Some right>>right)] - [(get@ #color right>>right) #Red]) - (red (get@ #key right) - (get@ #value right) - (#.Some (black key value ?left (get@ #left right))) - (#.Some (blacken right>>right))) - - (^multi (#.Some right) - [(get@ #color right) #Red] - [(get@ #left right) (#.Some right>>left)] - [(get@ #color right>>left) #Red]) - (red (get@ #key right>>left) - (get@ #value right>>left) - (#.Some (black key value ?left (get@ #left right>>left))) - (#.Some (black (get@ #key right) - (get@ #value right) - (get@ #right right>>left) - (get@ #right right)))) - - _ - (black key value ?left ?right))) - -(def: (balance_left_remove key value ?left ?right) - (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) - (case ?left - (^multi (#.Some left) - [(get@ #color left) #Red]) - (red key value (#.Some (blacken left)) ?right) - - _ - (case ?right - (^multi (#.Some right) - [(get@ #color right) #Black]) - (right_balance key value ?left (#.Some (redden right))) - - (^multi (#.Some right) - [(get@ #color right) #Red] - [(get@ #left right) (#.Some right>>left)] - [(get@ #color right>>left) #Black]) - (red (get@ #key right>>left) - (get@ #value right>>left) - (#.Some (black key value ?left (get@ #left right>>left))) - (#.Some (right_balance (get@ #key right) - (get@ #value right) - (get@ #right right>>left) - (\ maybe.functor map redden (get@ #right right))))) - - _ - (error! error_message)) - )) - -(def: (balance_right_remove key value ?left ?right) - (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) - (case ?right - (^multi (#.Some right) - [(get@ #color right) #Red]) - (red key value ?left (#.Some (blacken right))) - - _ - (case ?left - (^multi (#.Some left) - [(get@ #color left) #Black]) - (left_balance key value (#.Some (redden left)) ?right) - - (^multi (#.Some left) - [(get@ #color left) #Red] - [(get@ #right left) (#.Some left>>right)] - [(get@ #color left>>right) #Black]) - (red (get@ #key left>>right) - (get@ #value left>>right) - (#.Some (left_balance (get@ #key left) - (get@ #value left) - (\ maybe.functor map redden (get@ #left left)) - (get@ #left left>>right))) - (#.Some (black key value (get@ #right left>>right) ?right))) - - _ - (error! error_message) - ))) - -(def: (prepend ?left ?right) - (All [k v] (-> (Maybe (Node k v)) (Maybe (Node k v)) (Maybe (Node k v)))) - (case [?left ?right] - [#.None _] - ?right - - [_ #.None] - ?left - - [(#.Some left) (#.Some right)] - (case [(get@ #color left) (get@ #color right)] - [#Red #Red] - (do maybe.monad - [fused (prepend (get@ #right left) (get@ #right right))] - (case (get@ #color fused) - #Red - (wrap (red (get@ #key fused) - (get@ #value fused) - (#.Some (red (get@ #key left) - (get@ #value left) - (get@ #left left) - (get@ #left fused))) - (#.Some (red (get@ #key right) - (get@ #value right) - (get@ #right fused) - (get@ #right right))))) - - #Black - (wrap (red (get@ #key left) - (get@ #value left) - (get@ #left left) - (#.Some (red (get@ #key right) - (get@ #value right) - (#.Some fused) - (get@ #right right))))))) - - [#Red #Black] - (#.Some (red (get@ #key left) - (get@ #value left) - (get@ #left left) - (prepend (get@ #right left) - ?right))) - - [#Black #Red] - (#.Some (red (get@ #key right) - (get@ #value right) - (prepend ?left - (get@ #left right)) - (get@ #right right))) - - [#Black #Black] - (do maybe.monad - [fused (prepend (get@ #right left) (get@ #left right))] - (case (get@ #color fused) - #Red - (wrap (red (get@ #key fused) - (get@ #value fused) - (#.Some (black (get@ #key left) - (get@ #value left) - (get@ #left left) - (get@ #left fused))) - (#.Some (black (get@ #key right) - (get@ #value right) - (get@ #right fused) - (get@ #right right))))) - - #Black - (wrap (balance_left_remove (get@ #key left) - (get@ #value left) - (get@ #left left) - (#.Some (black (get@ #key right) - (get@ #value right) - (#.Some fused) - (get@ #right right))))) - )) - ) - - _ - (undefined))) - -(def: #export (remove key dict) - (All [k v] (-> k (Dictionary k v) (Dictionary k v))) - (let [(^open "_\.") (get@ #&order dict) - [?root found?] (loop [?root (get@ #root dict)] - (case ?root - #.None - [#.None #0] - - (#.Some root) - (let [root_key (get@ #key root) - root_val (get@ #value root)] - (if (_\= root_key key) - [(prepend (get@ #left root) - (get@ #right root)) - #1] - (let [go_left? (_\< root_key key)] - (case (recur (if go_left? - (get@ #left root) - (get@ #right root))) - [#.None #0] - [#.None #0] - - [side_outcome _] - (if go_left? - (case (get@ #left root) - (^multi (#.Some left) - [(get@ #color left) #Black]) - [(#.Some (balance_left_remove root_key root_val side_outcome (get@ #right root))) - #0] - - _ - [(#.Some (red root_key root_val side_outcome (get@ #right root))) - #0]) - (case (get@ #right root) - (^multi (#.Some right) - [(get@ #color right) #Black]) - [(#.Some (balance_right_remove root_key root_val (get@ #left root) side_outcome)) - #0] - - _ - [(#.Some (red root_key root_val (get@ #left root) side_outcome)) - #0]) - ))) - )) - ))] - (case ?root - #.None - (if found? - (set@ #root ?root dict) - dict) - - (#.Some root) - (set@ #root (#.Some (blacken root)) dict) - ))) - -(def: #export (update key transform dict) - (All [k v] (-> k (-> v v) (Dictionary k v) (Dictionary k v))) - (case (..get key dict) - (#.Some old) - (..put key (transform old) dict) - - #.None - dict)) - -(def: #export (from_list Order<l> list) - (All [k v] (-> (Order k) (List [k v]) (Dictionary k v))) - (list\fold (function (_ [key value] dict) - (put key value dict)) - (new Order<l>) - list)) - -(template [<name> <type> <output>] - [(def: #export (<name> dict) - (All [k v] (-> (Dictionary k v) (List <type>))) - (loop [node (get@ #root dict)] - (case node - #.None - (list) - - (#.Some node') - ($_ list\compose - (recur (get@ #left node')) - (list <output>) - (recur (get@ #right node'))))))] - - [entries [k v] [(get@ #key node') (get@ #value node')]] - [keys k (get@ #key node')] - [values v (get@ #value node')] - ) - -(implementation: #export (equivalence (^open ",\.")) - (All [k v] (-> (Equivalence v) (Equivalence (Dictionary k v)))) - - (def: (= reference sample) - (let [(^open "/\.") (get@ #&order reference)] - (loop [entriesR (entries reference) - entriesS (entries sample)] - (case [entriesR entriesS] - [#.Nil #.Nil] - #1 - - [(#.Cons [keyR valueR] entriesR') (#.Cons [keyS valueS] entriesS')] - (and (/\= keyR keyS) - (,\= valueR valueS) - (recur entriesR' entriesS')) - - _ - #0))))) diff --git a/stdlib/source/lux/data/collection/dictionary/plist.lux b/stdlib/source/lux/data/collection/dictionary/plist.lux deleted file mode 100644 index 320bf2f51..000000000 --- a/stdlib/source/lux/data/collection/dictionary/plist.lux +++ /dev/null @@ -1,97 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)]] - [data - ["." product] - ["." text ("#\." equivalence)] - [collection - ["." list ("#\." functor)]]] - [math - [number - ["n" nat]]]]) - -(type: #export (PList a) - (List [Text a])) - -(def: #export empty - PList - #.Nil) - -(def: #export size - (All [a] (-> (PList a) Nat)) - list.size) - -(def: #export empty? - (All [a] (-> (PList a) Bit)) - (|>> ..size (n.= 0))) - -(def: #export (get key properties) - (All [a] (-> Text (PList a) (Maybe a))) - (case properties - #.Nil - #.None - - (#.Cons [k' v'] properties') - (if (text\= key k') - (#.Some v') - (get key properties')))) - -(template [<name> <type> <access>] - [(def: #export <name> - (All [a] (-> (PList a) (List <type>))) - (list\map <access>))] - - [keys Text product.left] - [values a product.right] - ) - -(def: #export (contains? key properties) - (All [a] (-> Text (PList a) Bit)) - (case (..get key properties) - (#.Some _) - true - - #.None - false)) - -(def: #export (put key val properties) - (All [a] (-> Text a (PList a) (PList a))) - (case properties - #.Nil - (list [key val]) - - (#.Cons [k' v'] properties') - (if (text\= key k') - (#.Cons [key val] - properties') - (#.Cons [k' v'] - (put key val properties'))))) - -(def: #export (update key f properties) - (All [a] (-> Text (-> a a) (PList a) (PList a))) - (case properties - #.Nil - #.Nil - - (#.Cons [k' v'] properties') - (if (text\= key k') - (#.Cons [k' (f v')] properties') - (#.Cons [k' v'] (update key f properties'))))) - -(def: #export (remove key properties) - (All [a] (-> Text (PList a) (PList a))) - (case properties - #.Nil - properties - - (#.Cons [k' v'] properties') - (if (text\= key k') - properties' - (#.Cons [k' v'] - (remove key properties'))))) - -(def: #export equivalence - (All [a] (-> (Equivalence a) (Equivalence (PList a)))) - (|>> (product.equivalence text.equivalence) - list.equivalence)) diff --git a/stdlib/source/lux/data/collection/list.lux b/stdlib/source/lux/data/collection/list.lux deleted file mode 100644 index 7bb2d4468..000000000 --- a/stdlib/source/lux/data/collection/list.lux +++ /dev/null @@ -1,615 +0,0 @@ -(.module: - [lux #* - ["@" target] - [abstract - [monoid (#+ Monoid)] - [apply (#+ Apply)] - [equivalence (#+ Equivalence)] - [hash (#+ Hash)] - [fold (#+ Fold)] - [predicate (#+ Predicate)] - ["." functor (#+ Functor)] - ["." monad (#+ do Monad)] - ["." enum]] - [data - ["." bit] - ["." product]] - [math - [number - ["n" nat]]]]) - -## (type: (List a) -## #Nil -## (#Cons a (List a))) - -(implementation: #export fold - (Fold List) - - (def: (fold f init xs) - (case xs - #.Nil - init - - (#.Cons x xs') - (fold f (f x init) xs')))) - -(def: #export (folds f init inputs) - (All [a b] (-> (-> a b b) b (List a) (List b))) - (case inputs - #.Nil - (list init) - - (#.Cons [head tail]) - (#.Cons [init (folds f (f head init) tail)]))) - -(def: #export (reverse xs) - (All [a] - (-> (List a) (List a))) - (fold (function (_ head tail) (#.Cons head tail)) - #.Nil - xs)) - -(def: #export (filter keep? xs) - (All [a] - (-> (Predicate a) (List a) (List a))) - (case xs - #.Nil - #.Nil - - (#.Cons x xs') - (if (keep? x) - (#.Cons x (filter keep? xs')) - (filter keep? xs')))) - -(def: #export (partition satisfies? list) - {#.doc "Divide the list into all elements that satisfy a predicate, and all elements that do not."} - (All [a] (-> (Predicate a) (List a) [(List a) (List a)])) - (case list - #.Nil - [#.Nil #.Nil] - - (#.Cons head tail) - (let [[in out] (partition satisfies? tail)] - (if (satisfies? head) - [(#.Cons head in) out] - [in (#.Cons head out)])))) - -(def: #export (as_pairs xs) - {#.doc (doc "Cut the list into pairs of 2." - "Caveat emptor: If the list has an uneven number of elements, the last one will be skipped.")} - (All [a] (-> (List a) (List [a a]))) - (case xs - (^ (list& x1 x2 xs')) - (#.Cons [x1 x2] (as_pairs xs')) - - _ - #.Nil)) - -(template [<name> <then> <else>] - [(def: #export (<name> n xs) - (All [a] - (-> Nat (List a) (List a))) - (if (n.> 0 n) - (case xs - #.Nil - #.Nil - - (#.Cons x xs') - <then>) - <else>))] - - [take (#.Cons x (take (dec n) xs')) #.Nil] - [drop (drop (dec n) xs') xs] - ) - -(template [<name> <then> <else>] - [(def: #export (<name> predicate xs) - (All [a] - (-> (Predicate a) (List a) (List a))) - (case xs - #.Nil - #.Nil - - (#.Cons x xs') - (if (predicate x) - <then> - <else>)))] - - [take_while (#.Cons x (take_while predicate xs')) #.Nil] - [drop_while (drop_while predicate xs') xs] - ) - -(def: #export (split n xs) - (All [a] - (-> Nat (List a) [(List a) (List a)])) - (if (n.> 0 n) - (case xs - #.Nil - [#.Nil #.Nil] - - (#.Cons x xs') - (let [[tail rest] (split (dec n) xs')] - [(#.Cons x tail) rest])) - [#.Nil xs])) - -(def: (split_with' predicate ys xs) - (All [a] - (-> (Predicate a) (List a) (List a) [(List a) (List a)])) - (case xs - #.Nil - [ys xs] - - (#.Cons x xs') - (if (predicate x) - (split_with' predicate (#.Cons x ys) xs') - [ys xs]))) - -(def: #export (split_with predicate xs) - {#.doc "Segment the list by using a predicate to tell when to cut."} - (All [a] - (-> (Predicate a) (List a) [(List a) (List a)])) - (let [[ys' xs'] (split_with' predicate #.Nil xs)] - [(reverse ys') xs'])) - -(def: #export (chunk n xs) - {#.doc "Segment the list in chunks of size N."} - (All [a] (-> Nat (List a) (List (List a)))) - (case xs - #.Nil - (list) - - _ - (let [[pre post] (split n xs)] - (#.Cons pre (chunk n post))))) - -(def: #export (repeat n x) - {#.doc "A list of the value x, repeated n times."} - (All [a] - (-> Nat a (List a))) - (if (n.> 0 n) - (#.Cons x (repeat (dec n) x)) - #.Nil)) - -(def: (iterate' f x) - (All [a] - (-> (-> a (Maybe a)) a (List a))) - (case (f x) - (#.Some x') - (#.Cons x (iterate' f x')) - - #.None - (list))) - -(def: #export (iterate f x) - {#.doc "Generates a list element by element until the function returns #.None."} - (All [a] - (-> (-> a (Maybe a)) a (List a))) - (case (f x) - (#.Some x') - (#.Cons x (iterate' f x')) - - #.None - (list x))) - -(def: #export (one check xs) - (All [a b] - (-> (-> a (Maybe b)) (List a) (Maybe b))) - (case xs - #.Nil - #.None - - (#.Cons x xs') - (case (check x) - (#.Some output) - (#.Some output) - - #.None - (one check xs')))) - -(def: #export (all check xs) - (All [a b] - (-> (-> a (Maybe b)) (List a) (List b))) - (for {## TODO: Stop relying on this ASAP. - @.js - (fold (function (_ head tail) - (case (check head) - (#.Some head) - (#.Cons head tail) - - #.None - tail)) - #.Nil - (reverse xs))} - (case xs - #.Nil - #.Nil - - (#.Cons x xs') - (case (check x) - (#.Some output) - (#.Cons output (all check xs')) - - #.None - (all check xs'))))) - -(def: #export (find predicate xs) - {#.doc "Returns the first value in the list for which the predicate is #1."} - (All [a] - (-> (Predicate a) (List a) (Maybe a))) - (..one (function (_ value) - (if (predicate value) - (#.Some value) - #.None)) - xs)) - -(def: #export (interpose sep xs) - {#.doc "Puts a value between every two elements in the list."} - (All [a] - (-> a (List a) (List a))) - (case xs - #.Nil - xs - - (#.Cons x #.Nil) - xs - - (#.Cons x xs') - (list& x sep (interpose sep xs')))) - -(def: #export (size list) - (All [a] (-> (List a) Nat)) - (fold (function (_ _ acc) (n.+ 1 acc)) 0 list)) - -(template [<name> <init> <op>] - [(def: #export (<name> predicate xs) - (All [a] - (-> (Predicate a) (List a) Bit)) - (loop [xs xs] - (case xs - #.Nil - <init> - - (#.Cons x xs') - (case (predicate x) - <init> - (recur xs') - - output - output))))] - - [every? #1 and] - [any? #0 or] - ) - -(def: #export (nth i xs) - {#.doc "Fetches the element at the specified index."} - (All [a] - (-> Nat (List a) (Maybe a))) - (case xs - #.Nil - #.None - - (#.Cons x xs') - (if (n.= 0 i) - (#.Some x) - (nth (dec i) xs')))) - -(implementation: #export (equivalence Equivalence<a>) - (All [a] (-> (Equivalence a) (Equivalence (List a)))) - - (def: (= xs ys) - (case [xs ys] - [#.Nil #.Nil] - #1 - - [(#.Cons x xs') (#.Cons y ys')] - (and (\ Equivalence<a> = x y) - (= xs' ys')) - - [_ _] - #0 - ))) - -(implementation: #export (hash super) - (All [a] (-> (Hash a) (Hash (List a)))) - - (def: &equivalence - (..equivalence (\ super &equivalence))) - - (def: hash - (\ ..fold fold - (function (_ member hash) - (n.+ (\ super hash member) hash)) - 0))) - -(implementation: #export monoid - (All [a] (Monoid (List a))) - - (def: identity #.Nil) - (def: (compose xs ys) - (case xs - #.Nil - ys - - (#.Cons x xs') - (#.Cons x (compose xs' ys))))) - -(open: "." ..monoid) - -(implementation: #export functor - (Functor List) - - (def: (map f ma) - (case ma - #.Nil - #.Nil - - (#.Cons a ma') - (#.Cons (f a) (map f ma'))))) - -(open: "." ..functor) - -(implementation: #export apply - (Apply List) - - (def: &functor ..functor) - - (def: (apply ff fa) - (case ff - #.Nil - #.Nil - - (#.Cons f ff') - (compose (map f fa) (apply ff' fa))))) - -(implementation: #export monad - (Monad List) - - (def: &functor ..functor) - - (def: (wrap a) - (#.Cons a #.Nil)) - - (def: join (|>> reverse (fold compose identity)))) - -(def: #export (sort < xs) - (All [a] (-> (-> a a Bit) (List a) (List a))) - (case xs - #.Nil - (list) - - (#.Cons x xs') - (let [[pre post] (fold (function (_ x' [pre post]) - (if (< x x') - [(#.Cons x' pre) post] - [pre (#.Cons x' post)])) - [(list) (list)] - xs')] - ($_ compose (sort < pre) (list x) (sort < post))))) - -(def: #export (empty? xs) - (All [a] (Predicate (List a))) - (case xs - #.Nil - true - - _ - false)) - -(def: #export (member? eq xs x) - (All [a] (-> (Equivalence a) (List a) a Bit)) - (case xs - #.Nil - #0 - - (#.Cons x' xs') - (or (\ eq = x x') - (member? eq xs' x)))) - -(template [<name> <output> <side> <doc>] - [(def: #export (<name> xs) - {#.doc <doc>} - (All [a] (-> (List a) (Maybe <output>))) - (case xs - #.Nil - #.None - - (#.Cons x xs') - (#.Some <side>)))] - - [head a x "Returns the first element of a list."] - [tail (List a) xs' "For a list of size N, returns the N-1 elements after the first one."] - ) - -(def: #export (indices size) - {#.doc "Produces all the valid indices for a given size."} - (All [a] (-> Nat (List Nat))) - (if (n.= 0 size) - (list) - (|> size dec (enum.range n.enum 0)))) - -(def: (identifier$ name) - (-> Text Code) - [["" 0 0] (#.Identifier "" name)]) - -(def: (nat@encode value) - (-> Nat Text) - (loop [input value - output ""] - (let [digit (case (n.% 10 input) - 0 "0" - 1 "1" - 2 "2" - 3 "3" - 4 "4" - 5 "5" - 6 "6" - 7 "7" - 8 "8" - 9 "9" - _ (undefined)) - output' ("lux text concat" digit output) - input' (n./ 10 input)] - (if (n.= 0 input') - output' - (recur input' output'))))) - -(macro: #export (zip tokens state) - {#.doc (doc "Create list zippers with the specified number of input lists." - (def: #export zip/2 (zip 2)) - (def: #export zip/3 (zip 3)) - ((zip 3) xs ys zs))} - (case tokens - (^ (list [_ (#.Nat num_lists)])) - (if (n.> 0 num_lists) - (let [(^open ".") ..functor - indices (..indices num_lists) - type_vars (: (List Code) (map (|>> nat@encode identifier$) indices)) - zip_type (` (All [(~+ type_vars)] - (-> (~+ (map (: (-> Code Code) (function (_ var) (` (List (~ var))))) - type_vars)) - (List [(~+ type_vars)])))) - vars+lists (|> indices - (map inc) - (map (function (_ idx) - (let [base (nat@encode idx)] - [(identifier$ base) - (identifier$ ("lux text concat" base "'"))])))) - pattern (` [(~+ (map (function (_ [v vs]) (` (#.Cons (~ v) (~ vs)))) - vars+lists))]) - g!step (identifier$ "0step0") - g!blank (identifier$ "0,0") - list_vars (map product.right vars+lists) - code (` (: (~ zip_type) - (function ((~ g!step) (~+ list_vars)) - (case [(~+ list_vars)] - (~ pattern) - (#.Cons [(~+ (map product.left vars+lists))] - ((~ g!step) (~+ list_vars))) - - (~ g!blank) - #.Nil))))] - (#.Right [state (list code)])) - (#.Left "Cannot zip 0 lists.")) - - _ - (#.Left "Wrong syntax for zip"))) - -(def: #export zip/2 (zip 2)) -(def: #export zip/3 (zip 3)) - -(macro: #export (zip_with tokens state) - {#.doc (doc "Create list zippers with the specified number of input lists." - (def: #export zip_with/2 (zip_with 2)) - (def: #export zip_with/3 (zip_with 3)) - ((zip_with 2) + xs ys))} - (case tokens - (^ (list [_ (#.Nat num_lists)])) - (if (n.> 0 num_lists) - (let [(^open ".") ..functor - indices (..indices num_lists) - g!return_type (identifier$ "0return_type0") - g!func (identifier$ "0func0") - type_vars (: (List Code) (map (|>> nat@encode identifier$) indices)) - zip_type (` (All [(~+ type_vars) (~ g!return_type)] - (-> (-> (~+ type_vars) (~ g!return_type)) - (~+ (map (: (-> Code Code) (function (_ var) (` (List (~ var))))) - type_vars)) - (List (~ g!return_type))))) - vars+lists (|> indices - (map inc) - (map (function (_ idx) - (let [base (nat@encode idx)] - [(identifier$ base) - (identifier$ ("lux text concat" base "'"))])))) - pattern (` [(~+ (map (function (_ [v vs]) (` (#.Cons (~ v) (~ vs)))) - vars+lists))]) - g!step (identifier$ "0step0") - g!blank (identifier$ "0,0") - list_vars (map product.right vars+lists) - code (` (: (~ zip_type) - (function ((~ g!step) (~ g!func) (~+ list_vars)) - (case [(~+ list_vars)] - (~ pattern) - (#.Cons ((~ g!func) (~+ (map product.left vars+lists))) - ((~ g!step) (~ g!func) (~+ list_vars))) - - (~ g!blank) - #.Nil))))] - (#.Right [state (list code)])) - (#.Left "Cannot zip_with 0 lists.")) - - _ - (#.Left "Wrong syntax for zip_with"))) - -(def: #export zip_with/2 (zip_with 2)) -(def: #export zip_with/3 (zip_with 3)) - -(def: #export (last xs) - (All [a] (-> (List a) (Maybe a))) - (case xs - #.Nil - #.None - - (#.Cons x #.Nil) - (#.Some x) - - (#.Cons x xs') - (last xs'))) - -(def: #export (inits xs) - {#.doc (doc "For a list of size N, returns the first N-1 elements." - "Empty lists will result in a #.None value being returned instead.")} - (All [a] (-> (List a) (Maybe (List a)))) - (case xs - #.Nil - #.None - - (#.Cons x #.Nil) - (#.Some #.Nil) - - (#.Cons x xs') - (case (inits xs') - #.None - (undefined) - - (#.Some tail) - (#.Some (#.Cons x tail))) - )) - -(def: #export (concat xss) - (All [a] (-> (List (List a)) (List a))) - (\ ..monad join xss)) - -(implementation: #export (with monad) - (All [M] (-> (Monad M) (Monad (All [a] (M (List a)))))) - - (def: &functor (functor.compose (get@ #monad.&functor monad) ..functor)) - - (def: wrap (|>> (\ ..monad wrap) (\ monad wrap))) - - (def: (join MlMla) - (do {! monad} - [lMla MlMla - ## TODO: Remove this version ASAP and use one below. - lla (for {@.old - (: (($ 0) (List (List ($ 1)))) - (monad.seq ! lMla))} - (monad.seq ! lMla))] - (wrap (concat lla))))) - -(def: #export (lift monad) - (All [M a] (-> (Monad M) (-> (M a) (M (List a))))) - (\ monad map (\ ..monad wrap))) - -(def: #export (enumeration xs) - {#.doc "Pairs every element in the list with its index, starting at 0."} - (All [a] (-> (List a) (List [Nat a]))) - (loop [idx 0 - xs xs] - (case xs - #.Nil - #.Nil - - (#.Cons x xs') - (#.Cons [idx x] (recur (inc idx) xs'))))) diff --git a/stdlib/source/lux/data/collection/queue.lux b/stdlib/source/lux/data/collection/queue.lux deleted file mode 100644 index 32ed05c64..000000000 --- a/stdlib/source/lux/data/collection/queue.lux +++ /dev/null @@ -1,92 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [functor (#+ Functor)]] - [data - [collection - ["." list ("#\." monoid functor)]]] - [math - [number - ["n" nat]]]]) - -(type: #export (Queue a) - {#front (List a) - #rear (List a)}) - -(def: #export empty - Queue - {#front (list) - #rear (list)}) - -(def: #export (from_list entries) - (All [a] (-> (List a) (Queue a))) - {#front entries - #rear (list)}) - -(def: #export (to_list queue) - (All [a] (-> (Queue a) (List a))) - (let [(^slots [#front #rear]) queue] - (list\compose front (list.reverse rear)))) - -(def: #export peek - (All [a] (-> (Queue a) (Maybe a))) - (|>> (get@ #front) list.head)) - -(def: #export (size queue) - (All [a] (-> (Queue a) Nat)) - (let [(^slots [#front #rear]) queue] - (n.+ (list.size front) - (list.size rear)))) - -(def: #export empty? - (All [a] (-> (Queue a) Bit)) - (|>> (get@ #front) list.empty?)) - -(def: #export (member? equivalence queue member) - (All [a] (-> (Equivalence a) (Queue a) a Bit)) - (let [(^slots [#front #rear]) queue] - (or (list.member? equivalence front member) - (list.member? equivalence rear member)))) - -(def: #export (pop queue) - (All [a] (-> (Queue a) (Queue a))) - (case (get@ #front queue) - ## Empty... - (^ (list)) - queue - - ## Front has dried up... - (^ (list _)) - (|> queue - (set@ #front (list.reverse (get@ #rear queue))) - (set@ #rear (list))) - - ## Consume front! - (^ (list& _ front')) - (|> queue - (set@ #front front')))) - -(def: #export (push val queue) - (All [a] (-> a (Queue a) (Queue a))) - (case (get@ #front queue) - #.Nil - (set@ #front (list val) queue) - - _ - (update@ #rear (|>> (#.Cons val)) queue))) - -(implementation: #export (equivalence super) - (All [a] (-> (Equivalence a) (Equivalence (Queue a)))) - - (def: (= reference subject) - (\ (list.equivalence super) = - (..to_list reference) - (..to_list subject)))) - -(implementation: #export functor - (Functor Queue) - - (def: (map f fa) - {#front (|> fa (get@ #front) (list\map f)) - #rear (|> fa (get@ #rear) (list\map f))})) diff --git a/stdlib/source/lux/data/collection/queue/priority.lux b/stdlib/source/lux/data/collection/queue/priority.lux deleted file mode 100644 index b7f971dd2..000000000 --- a/stdlib/source/lux/data/collection/queue/priority.lux +++ /dev/null @@ -1,120 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [monad (#+ do Monad)]] - [data - ["." maybe] - [collection - ["." tree #_ - ["#" finger (#+ Tree)]]]] - [math - [number - ["n" nat ("#\." interval)]]] - [type (#+ :by_example) - [abstract (#+ abstract: :abstraction :representation)]]]) - -(type: #export Priority - Nat) - -(def: #export max Priority n\top) -(def: #export min Priority n\bottom) - -(def: builder - (tree.builder n.maximum)) - -(def: :@: - (:by_example [@] - (tree.Builder @ Priority) - ..builder - - @)) - -(abstract: #export (Queue a) - (Maybe (Tree :@: Priority a)) - - (def: #export empty - Queue - (:abstraction #.None)) - - (def: #export (peek queue) - (All [a] (-> (Queue a) (Maybe a))) - (do maybe.monad - [tree (:representation queue)] - (tree.search (n.= (tree.tag tree)) - tree))) - - (def: #export (size queue) - (All [a] (-> (Queue a) Nat)) - (case (:representation queue) - #.None - 0 - - (#.Some tree) - (loop [node tree] - (case (tree.root node) - (0 #0 _) - 1 - - (0 #1 [left right]) - (n.+ (recur left) (recur right)))))) - - (def: #export (member? equivalence queue member) - (All [a] (-> (Equivalence a) (Queue a) a Bit)) - (case (:representation queue) - #.None - false - - (#.Some tree) - (loop [node tree] - (case (tree.root node) - (0 #0 reference) - (\ equivalence = reference member) - - (0 #1 [left right]) - (or (recur left) - (recur right)))))) - - (def: #export (pop queue) - (All [a] (-> (Queue a) (Queue a))) - (:abstraction - (do maybe.monad - [tree (:representation queue) - #let [highest_priority (tree.tag tree)]] - (loop [node tree] - (case (tree.root node) - (0 #0 reference) - (if (n.= highest_priority (tree.tag node)) - #.None - (#.Some node)) - - (0 #1 left right) - (if (n.= highest_priority (tree.tag left)) - (case (recur left) - #.None - (#.Some right) - - (#.Some =left) - (#.Some (\ ..builder branch =left right))) - (case (recur right) - #.None - (#.Some left) - - (#.Some =right) - (#.Some (\ ..builder branch left =right))))))))) - - (def: #export (push priority value queue) - (All [a] (-> Priority a (Queue a) (Queue a))) - (let [addition (\ ..builder leaf priority value)] - (:abstraction - (case (:representation queue) - #.None - (#.Some addition) - - (#.Some tree) - (#.Some (\ ..builder branch tree addition)))))) - ) - -(def: #export empty? - (All [a] (-> (Queue a) Bit)) - (|>> ..size (n.= 0))) diff --git a/stdlib/source/lux/data/collection/row.lux b/stdlib/source/lux/data/collection/row.lux deleted file mode 100644 index abadcfd7a..000000000 --- a/stdlib/source/lux/data/collection/row.lux +++ /dev/null @@ -1,489 +0,0 @@ -## https://hypirion.com/musings/understanding-persistent-vector-pt-1 -## https://hypirion.com/musings/understanding-persistent-vector-pt-2 -## https://hypirion.com/musings/understanding-persistent-vector-pt-3 -(.module: - [lux #* - ["@" target] - [abstract - [functor (#+ Functor)] - [apply (#+ Apply)] - [monad (#+ Monad do)] - [equivalence (#+ Equivalence)] - [monoid (#+ Monoid)] - [fold (#+ Fold)] - [predicate (#+ Predicate)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["p" parser - ["s" code (#+ Parser)]]] - [data - ["." maybe] - ["." product] - [collection - ["." list ("#\." fold functor monoid)] - ["." array (#+ Array) ("#\." functor fold)]]] - [macro (#+ with_gensyms) - [syntax (#+ syntax:)] - ["." code]] - [math - [number - ["." i64] - ["n" nat]]]]) - -(type: (Node a) - (#Base (Array a)) - (#Hierarchy (Array (Node a)))) - -(type: (Base a) (Array a)) -(type: (Hierarchy a) (Array (Node a))) - -(type: Level Nat) - -(type: Index Nat) - -(def: branching_exponent - Nat - 5) - -(def: root_level - Level - 0) - -(template [<name> <op>] - [(def: <name> - (-> Level Level) - (<op> branching_exponent))] - - [level_up n.+] - [level_down n.-] - ) - -(def: full_node_size - Nat - (i64.left_shift branching_exponent 1)) - -(def: branch_idx_mask - Nat - (dec full_node_size)) - -(def: branch_idx - (-> Index Index) - (i64.and branch_idx_mask)) - -(def: (new_hierarchy _) - (All [a] (-> Any (Hierarchy a))) - (array.new full_node_size)) - -(def: (tail_off row_size) - (-> Nat Nat) - (if (n.< full_node_size row_size) - 0 - (|> (dec row_size) - (i64.right_shift branching_exponent) - (i64.left_shift branching_exponent)))) - -(def: (new_path level tail) - (All [a] (-> Level (Base a) (Node a))) - (if (n.= 0 level) - (#Base tail) - (|> (new_hierarchy []) - (array.write! 0 (new_path (level_down level) tail)) - #Hierarchy))) - -(def: (new_tail singleton) - (All [a] (-> a (Base a))) - (|> (array.new 1) - (array.write! 0 singleton))) - -(def: (push_tail size level tail parent) - (All [a] (-> Nat Level (Base a) (Hierarchy a) (Hierarchy a))) - (let [sub_idx (branch_idx (i64.right_shift level (dec size))) - ## If we're currently on a bottom node - sub_node (if (n.= branching_exponent level) - ## Just add the tail to it - (#Base tail) - ## Otherwise, check whether there's a vacant spot - (case (array.read sub_idx parent) - ## If so, set the path to the tail - #.None - (new_path (level_down level) tail) - ## If not, push the tail onto the sub_node. - (#.Some (#Hierarchy sub_node)) - (#Hierarchy (push_tail size (level_down level) tail sub_node)) - - _ - (undefined)) - )] - (|> (array.clone parent) - (array.write! sub_idx sub_node)))) - -(def: (expand_tail val tail) - (All [a] (-> a (Base a) (Base a))) - (let [tail_size (array.size tail)] - (|> (array.new (inc tail_size)) - (array.copy! tail_size 0 tail 0) - (array.write! tail_size val)))) - -(def: (put' level idx val hierarchy) - (All [a] (-> Level Index a (Hierarchy a) (Hierarchy a))) - (let [sub_idx (branch_idx (i64.right_shift level idx))] - (case (array.read sub_idx hierarchy) - (#.Some (#Hierarchy sub_node)) - (|> (array.clone hierarchy) - (array.write! sub_idx (#Hierarchy (put' (level_down level) idx val sub_node)))) - - (^multi (#.Some (#Base base)) - (n.= 0 (level_down level))) - (|> (array.clone hierarchy) - (array.write! sub_idx (|> (array.clone base) - (array.write! (branch_idx idx) val) - #Base))) - - _ - (undefined)))) - -(def: (pop_tail size level hierarchy) - (All [a] (-> Nat Level (Hierarchy a) (Maybe (Hierarchy a)))) - (let [sub_idx (branch_idx (i64.right_shift level (n.- 2 size)))] - (cond (n.= 0 sub_idx) - #.None - - (n.> branching_exponent level) - (do maybe.monad - [base|hierarchy (array.read sub_idx hierarchy) - sub (case base|hierarchy - (#Hierarchy sub) - (pop_tail size (level_down level) sub) - - (#Base _) - (undefined))] - (|> (array.clone hierarchy) - (array.write! sub_idx (#Hierarchy sub)) - #.Some)) - - ## Else... - (|> (array.clone hierarchy) - (array.delete! sub_idx) - #.Some) - ))) - -(def: (to_list' node) - (All [a] (-> (Node a) (List a))) - (case node - (#Base base) - (array.to_list base) - - (#Hierarchy hierarchy) - (|> hierarchy - array.to_list - list.reverse - (list\fold (function (_ sub acc) (list\compose (to_list' sub) acc)) - #.Nil)))) - -(type: #export (Row a) - {#level Level - #size Nat - #root (Hierarchy a) - #tail (Base a)}) - -(def: #export empty - Row - {#level (level_up root_level) - #size 0 - #root (array.new full_node_size) - #tail (array.new 0)}) - -(def: #export (size row) - (All [a] (-> (Row a) Nat)) - (get@ #size row)) - -(def: #export (add val row) - (All [a] (-> a (Row a) (Row a))) - ## Check if there is room in the tail. - (let [row_size (get@ #size row)] - (if (|> row_size (n.- (tail_off row_size)) (n.< full_node_size)) - ## If so, append to it. - (|> row - (update@ #size inc) - (update@ #tail (expand_tail val))) - ## Otherwise, push tail into the tree - ## -------------------------------------------------------- - ## Will the root experience an overflow with this addition? - (|> (if (n.> (i64.left_shift (get@ #level row) 1) - (i64.right_shift branching_exponent row_size)) - ## If so, a brand-new root must be established, that is - ## 1-level taller. - (|> row - (set@ #root (|> (for {@.old - (: (Hierarchy ($ 0)) - (new_hierarchy []))} - (new_hierarchy [])) - (array.write! 0 (#Hierarchy (get@ #root row))) - (array.write! 1 (new_path (get@ #level row) (get@ #tail row))))) - (update@ #level level_up)) - ## Otherwise, just push the current tail onto the root. - (|> row - (update@ #root (push_tail row_size (get@ #level row) (get@ #tail row))))) - ## Finally, update the size of the row and grow a new - ## tail with the new element as it's sole member. - (update@ #size inc) - (set@ #tail (new_tail val))) - ))) - -(exception: incorrect_row_structure) - -(exception: #export [a] (index_out_of_bounds {row (Row a)} {index Nat}) - (exception.report ["Size" (\ n.decimal encode (get@ #size row))] - ["Index" (\ n.decimal encode index)])) - -(exception: base_was_not_found) - -(def: #export (within_bounds? row idx) - (All [a] (-> (Row a) Nat Bit)) - (n.< (get@ #size row) idx)) - -(def: (base_for idx row) - (All [a] (-> Index (Row a) (Try (Base a)))) - (if (within_bounds? row idx) - (if (n.>= (tail_off (get@ #size row)) idx) - (#try.Success (get@ #tail row)) - (loop [level (get@ #level row) - hierarchy (get@ #root row)] - (case [(n.> branching_exponent level) - (array.read (branch_idx (i64.right_shift level idx)) hierarchy)] - [#1 (#.Some (#Hierarchy sub))] - (recur (level_down level) sub) - - [#0 (#.Some (#Base base))] - (#try.Success base) - - [_ #.None] - (exception.throw ..base_was_not_found []) - - _ - (exception.throw ..incorrect_row_structure [])))) - (exception.throw ..index_out_of_bounds [row idx]))) - -(def: #export (nth idx row) - (All [a] (-> Nat (Row a) (Try a))) - (do try.monad - [base (base_for idx row)] - (case (array.read (branch_idx idx) base) - (#.Some value) - (#try.Success value) - - #.None - (exception.throw ..incorrect_row_structure [])))) - -(def: #export (put idx val row) - (All [a] (-> Nat a (Row a) (Try (Row a)))) - (let [row_size (get@ #size row)] - (if (within_bounds? row idx) - (#try.Success (if (n.>= (tail_off row_size) idx) - (update@ #tail (for {@.old - (: (-> (Base ($ 0)) (Base ($ 0))) - (|>> array.clone (array.write! (branch_idx idx) val)))} - (|>> array.clone (array.write! (branch_idx idx) val))) - row) - (update@ #root (put' (get@ #level row) idx val) - row))) - (exception.throw ..index_out_of_bounds [row idx])))) - -(def: #export (update idx f row) - (All [a] (-> Nat (-> a a) (Row a) (Try (Row a)))) - (do try.monad - [val (..nth idx row)] - (..put idx (f val) row))) - -(def: #export (pop row) - (All [a] (-> (Row a) (Row a))) - (case (get@ #size row) - 0 - empty - - 1 - empty - - row_size - (if (|> row_size (n.- (tail_off row_size)) (n.> 1)) - (let [old_tail (get@ #tail row) - new_tail_size (dec (array.size old_tail))] - (|> row - (update@ #size dec) - (set@ #tail (|> (array.new new_tail_size) - (array.copy! new_tail_size 0 old_tail 0))))) - (maybe.assume - (do maybe.monad - [new_tail (base_for (n.- 2 row_size) row) - #let [[level' root'] (let [init_level (get@ #level row)] - (loop [level init_level - root (maybe.default (new_hierarchy []) - (pop_tail row_size init_level (get@ #root row)))] - (if (n.> branching_exponent level) - (case [(array.read 1 root) (array.read 0 root)] - [#.None (#.Some (#Hierarchy sub_node))] - (recur (level_down level) sub_node) - - ## [#.None (#.Some (#Base _))] - ## (undefined) - - _ - [level root]) - [level root])))]] - (wrap (|> row - (update@ #size dec) - (set@ #level level') - (set@ #root root') - (set@ #tail new_tail)))))) - )) - -(def: #export (to_list row) - (All [a] (-> (Row a) (List a))) - (list\compose (to_list' (#Hierarchy (get@ #root row))) - (to_list' (#Base (get@ #tail row))))) - -(def: #export from_list - (All [a] (-> (List a) (Row a))) - (list\fold ..add ..empty)) - -(def: #export (member? a/Equivalence row val) - (All [a] (-> (Equivalence a) (Row a) a Bit)) - (list.member? a/Equivalence (to_list row) val)) - -(def: #export empty? - (All [a] (-> (Row a) Bit)) - (|>> (get@ #size) (n.= 0))) - -(syntax: #export (row {elems (p.some s.any)}) - {#.doc (doc "Row literals." - (row +10 +20 +30 +40))} - (wrap (list (` (..from_list (list (~+ elems))))))) - -(implementation: (node_equivalence Equivalence<a>) - (All [a] (-> (Equivalence a) (Equivalence (Node a)))) - - (def: (= v1 v2) - (case [v1 v2] - [(#Base b1) (#Base b2)] - (\ (array.equivalence Equivalence<a>) = b1 b2) - - [(#Hierarchy h1) (#Hierarchy h2)] - (\ (array.equivalence (node_equivalence Equivalence<a>)) = h1 h2) - - _ - #0))) - -(implementation: #export (equivalence Equivalence<a>) - (All [a] (-> (Equivalence a) (Equivalence (Row a)))) - - (def: (= v1 v2) - (and (n.= (get@ #size v1) (get@ #size v2)) - (let [(^open "node\.") (node_equivalence Equivalence<a>)] - (and (node\= (#Base (get@ #tail v1)) - (#Base (get@ #tail v2))) - (node\= (#Hierarchy (get@ #root v1)) - (#Hierarchy (get@ #root v2)))))))) - -(implementation: node_fold - (Fold Node) - - (def: (fold f init xs) - (case xs - (#Base base) - (array\fold f init base) - - (#Hierarchy hierarchy) - (array\fold (function (_ node init') (fold f init' node)) - init - hierarchy)))) - -(implementation: #export fold - (Fold Row) - - (def: (fold f init xs) - (let [(^open ".") node_fold] - (fold f - (fold f - init - (#Hierarchy (get@ #root xs))) - (#Base (get@ #tail xs)))))) - -(implementation: #export monoid - (All [a] (Monoid (Row a))) - - (def: identity ..empty) - - (def: (compose xs ys) - (list\fold add xs (..to_list ys)))) - -(implementation: node_functor - (Functor Node) - - (def: (map f xs) - (case xs - (#Base base) - (#Base (array\map f base)) - - (#Hierarchy hierarchy) - (#Hierarchy (array\map (map f) hierarchy))))) - -(implementation: #export functor - (Functor Row) - - (def: (map f xs) - {#level (get@ #level xs) - #size (get@ #size xs) - #root (|> xs (get@ #root) (array\map (\ node_functor map f))) - #tail (|> xs (get@ #tail) (array\map f))})) - -(implementation: #export apply - (Apply Row) - - (def: &functor ..functor) - - (def: (apply ff fa) - (let [(^open ".") ..functor - (^open ".") ..fold - (^open ".") ..monoid - results (map (function (_ f) (map f fa)) - ff)] - (fold compose identity results)))) - -(implementation: #export monad - (Monad Row) - - (def: &functor ..functor) - - (def: wrap (|>> row)) - - (def: join - (let [(^open ".") ..fold - (^open ".") ..monoid] - (fold (function (_ post pre) (compose pre post)) identity)))) - -(def: #export reverse - (All [a] (-> (Row a) (Row a))) - (|>> ..to_list list.reverse (list\fold add ..empty))) - -(template [<name> <array> <init> <op>] - [(def: #export <name> - (All [a] - (-> (Predicate a) (Row a) Bit)) - (let [help (: (All [a] - (-> (Predicate a) (Node a) Bit)) - (function (help predicate node) - (case node - (#Base base) - (<array> predicate base) - - (#Hierarchy hierarchy) - (<array> (help predicate) hierarchy))))] - (function (<name> predicate row) - (let [(^slots [#root #tail]) row] - (<op> (help predicate (#Hierarchy root)) - (help predicate (#Base tail)))))))] - - [every? array.every? #1 and] - [any? array.any? #0 or] - ) diff --git a/stdlib/source/lux/data/collection/sequence.lux b/stdlib/source/lux/data/collection/sequence.lux deleted file mode 100644 index c3d2a5e33..000000000 --- a/stdlib/source/lux/data/collection/sequence.lux +++ /dev/null @@ -1,150 +0,0 @@ -(.module: - [lux #* - [abstract - [functor (#+ Functor)] - [comonad (#+ CoMonad)]] - [control - ["//" continuation (#+ Cont)] - ["<>" parser - ["<.>" code (#+ Parser)]]] - [macro (#+ with_gensyms) - [syntax (#+ syntax:)] - ["." code]] - [data - ["." bit] - [collection - ["." list ("#\." monad)]]] - [math - [number - ["n" nat]]]]) - -(type: #export (Sequence a) - {#.doc "An infinite sequence of values."} - (Cont [a (Sequence a)])) - -(def: #export (iterate f x) - {#.doc "Create a sequence by applying a function to a value, and to its result, on and on..."} - (All [a] - (-> (-> a a) a (Sequence a))) - (//.pending [x (iterate f (f x))])) - -(def: #export (repeat x) - {#.doc "Repeat a value forever."} - (All [a] - (-> a (Sequence a))) - (//.pending [x (repeat x)])) - -(def: #export (cycle [start next]) - {#.doc (doc "Go over the elements of a list forever." - "The list should not be empty.")} - (All [a] - (-> [a (List a)] (Sequence a))) - (loop [head start - tail next] - (//.pending [head (case tail - #.Nil - (recur start next) - - (#.Cons head' tail') - (recur head' tail'))]))) - -(template [<name> <return>] - [(def: #export (<name> sequence) - (All [a] (-> (Sequence a) <return>)) - (let [[head tail] (//.run sequence)] - <name>))] - - [head a] - [tail (Sequence a)] - ) - -(def: #export (nth idx sequence) - (All [a] (-> Nat (Sequence a) a)) - (let [[head tail] (//.run sequence)] - (case idx - 0 head - _ (nth (dec idx) tail)))) - -(template [<taker> <dropper> <splitter> <pred_type> <pred_test> <pred_step>] - [(def: #export (<taker> pred xs) - (All [a] - (-> <pred_type> (Sequence a) (List a))) - (let [[x xs'] (//.run xs)] - (if <pred_test> - (list& x (<taker> <pred_step> xs')) - (list)))) - - (def: #export (<dropper> pred xs) - (All [a] - (-> <pred_type> (Sequence a) (Sequence a))) - (let [[x xs'] (//.run xs)] - (if <pred_test> - (<dropper> <pred_step> xs') - xs))) - - (def: #export (<splitter> pred xs) - (All [a] - (-> <pred_type> (Sequence a) [(List a) (Sequence a)])) - (let [[x xs'] (//.run xs)] - (if <pred_test> - (let [[tail next] (<splitter> <pred_step> xs')] - [(#.Cons [x tail]) next]) - [(list) xs])))] - - [take_while drop_while split_while (-> a Bit) (pred x) pred] - [take drop split Nat (n.> 0 pred) (dec pred)] - ) - -(def: #export (unfold step init) - {#.doc "A stateful way of infinitely calculating the values of a sequence."} - (All [a b] - (-> (-> a [a b]) a (Sequence b))) - (let [[next x] (step init)] - (//.pending [x (unfold step next)]))) - -(def: #export (filter predicate sequence) - (All [a] (-> (-> a Bit) (Sequence a) (Sequence a))) - (let [[head tail] (//.run sequence)] - (if (predicate head) - (//.pending [head (filter predicate tail)]) - (filter predicate tail)))) - -(def: #export (partition left? xs) - {#.doc (doc "Split a sequence in two based on a predicate." - "The left side contains all entries for which the predicate is #1." - "The right side contains all entries for which the predicate is #0.")} - (All [a] (-> (-> a Bit) (Sequence a) [(Sequence a) (Sequence a)])) - [(filter left? xs) (filter (bit.complement left?) xs)]) - -(implementation: #export functor - (Functor Sequence) - - (def: (map f fa) - (let [[head tail] (//.run fa)] - (//.pending [(f head) (map f tail)])))) - -(implementation: #export comonad - (CoMonad Sequence) - - (def: &functor ..functor) - - (def: unwrap head) - - (def: (split wa) - (let [[head tail] (//.run wa)] - (//.pending [wa (split tail)])))) - -(syntax: #export (^sequence& {patterns (<code>.form (<>.many <code>.any))} - body - {branches (<>.some <code>.any)}) - {#.doc (doc "Allows destructuring of sequences in pattern-matching expressions." - "Caveat emptor: Only use it for destructuring, and not for testing values within the sequences." - (let [(^sequence& x y z _tail) (some_sequence_func +1 +2 +3)] - (func x y z)))} - (with_gensyms [g!sequence] - (let [body+ (` (let [(~+ (list\join (list\map (function (_ pattern) - (list (` [(~ pattern) (~ g!sequence)]) - (` ((~! //.run) (~ g!sequence))))) - patterns)))] - (~ body)))] - (wrap (list& g!sequence body+ branches))))) diff --git a/stdlib/source/lux/data/collection/set.lux b/stdlib/source/lux/data/collection/set.lux deleted file mode 100644 index 4c1fabde0..000000000 --- a/stdlib/source/lux/data/collection/set.lux +++ /dev/null @@ -1,104 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)] - [predicate (#+ Predicate)] - [monoid (#+ Monoid)]] - [data - [collection - ["." list ("#\." fold)]]] - [math - [number - ["n" nat]]]] - ["." // #_ - ["#" dictionary (#+ Dictionary)]]) - -(type: #export (Set a) - (Dictionary a Any)) - -(def: #export member_hash - (All [a] (-> (Set a) (Hash a))) - //.key_hash) - -(def: #export new - (All [a] (-> (Hash a) (Set a))) - //.new) - -(def: #export size - (All [a] (-> (Set a) Nat)) - //.size) - -(def: #export (add elem set) - (All [a] (-> a (Set a) (Set a))) - (|> set (//.put elem []))) - -(def: #export remove - (All [a] (-> a (Set a) (Set a))) - //.remove) - -(def: #export member? - (All [a] (-> (Set a) a Bit)) - //.key?) - -(def: #export to_list - (All [a] (-> (Set a) (List a))) - //.keys) - -(def: #export union - (All [a] (-> (Set a) (Set a) (Set a))) - //.merge) - -(def: #export (difference sub base) - (All [a] (-> (Set a) (Set a) (Set a))) - (list\fold ..remove base (..to_list sub))) - -(def: #export (intersection filter base) - (All [a] (-> (Set a) (Set a) (Set a))) - (//.select (//.keys filter) - base)) - -(implementation: #export equivalence - (All [a] (Equivalence (Set a))) - - (def: (= (^@ reference [hash _]) sample) - (and (n.= (..size reference) - (..size sample)) - (list.every? (..member? reference) - (..to_list sample))))) - -(implementation: #export hash - (All [a] (Hash (Set a))) - - (def: &equivalence ..equivalence) - - (def: (hash set) - (|> set - ..to_list - (\ (list.hash (..member_hash set)) hash)))) - -(implementation: #export (monoid hash) - (All [a] (-> (Hash a) (Monoid (Set a)))) - - (def: identity (..new hash)) - (def: compose ..union)) - -(def: #export empty? - (All [a] (-> (Set a) Bit)) - (|>> ..size (n.= 0))) - -(def: #export (from_list hash elements) - (All [a] (-> (Hash a) (List a) (Set a))) - (list\fold ..add (..new hash) elements)) - -(def: #export (sub? super sub) - (All [a] (-> (Set a) (Set a) Bit)) - (list.every? (..member? super) (..to_list sub))) - -(def: #export (super? sub super) - (All [a] (-> (Set a) (Set a) Bit)) - (..sub? super sub)) - -(def: #export predicate - (All [a] (-> (Set a) (Predicate a))) - ..member?) diff --git a/stdlib/source/lux/data/collection/set/multi.lux b/stdlib/source/lux/data/collection/set/multi.lux deleted file mode 100644 index 9e494608e..000000000 --- a/stdlib/source/lux/data/collection/set/multi.lux +++ /dev/null @@ -1,157 +0,0 @@ -## https://en.wikipedia.org/wiki/Multiset -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)]] - [control - ["." function]] - [math - [number - ["n" nat]]] - [type - [abstract (#+ abstract: :abstraction :representation ^:representation)]]] - ["." // - [// - ["." list ("#\." fold monoid)] - ["." dictionary (#+ Dictionary)] - [// - ["." maybe]]]]) - -(abstract: #export (Set a) - (Dictionary a Nat) - - (def: #export new - (All [a] (-> (Hash a) (Set a))) - (|>> dictionary.new :abstraction)) - - (def: #export size - (All [a] (-> (Set a) Nat)) - (|>> :representation dictionary.values (list\fold n.+ 0))) - - (def: #export (add multiplicity elem set) - (All [a] (-> Nat a (Set a) (Set a))) - (case multiplicity - 0 set - _ (|> set - :representation - (dictionary.upsert elem 0 (n.+ multiplicity)) - :abstraction))) - - (def: #export (remove multiplicity elem set) - (All [a] (-> Nat a (Set a) (Set a))) - (case multiplicity - 0 set - _ (case (dictionary.get elem (:representation set)) - (#.Some current) - (:abstraction - (if (n.> multiplicity current) - (dictionary.update elem (n.- multiplicity) (:representation set)) - (dictionary.remove elem (:representation set)))) - - #.None - set))) - - (def: #export (multiplicity set elem) - (All [a] (-> (Set a) a Nat)) - (|> set :representation (dictionary.get elem) (maybe.default 0))) - - (def: #export to_list - (All [a] (-> (Set a) (List a))) - (|>> :representation - dictionary.entries - (list\fold (function (_ [elem multiplicity] output) - (list\compose (list.repeat multiplicity elem) output)) - #.Nil))) - - (template [<name> <compose>] - [(def: #export (<name> parameter subject) - (All [a] (-> (Set a) (Set a) (Set a))) - (:abstraction (dictionary.merge_with <compose> (:representation parameter) (:representation subject))))] - - [union n.max] - [sum n.+] - ) - - (def: #export (intersection parameter (^:representation subject)) - (All [a] (-> (Set a) (Set a) (Set a))) - (list\fold (function (_ [elem multiplicity] output) - (..add (n.min (..multiplicity parameter elem) - multiplicity) - elem - output)) - (..new (dictionary.key_hash subject)) - (dictionary.entries subject))) - - (def: #export (difference parameter subject) - (All [a] (-> (Set a) (Set a) (Set a))) - (|> parameter - :representation - dictionary.entries - (list\fold (function (_ [elem multiplicity] output) - (..remove multiplicity elem output)) - subject))) - - (def: #export (sub? reference subject) - (All [a] (-> (Set a) (Set a) Bit)) - (|> subject - :representation - dictionary.entries - (list.every? (function (_ [elem multiplicity]) - (|> elem - (..multiplicity reference) - (n.>= multiplicity)))))) - - (def: #export (support set) - (All [a] (-> (Set a) (//.Set a))) - (let [(^@ set [hash _]) (:representation set)] - (|> set - dictionary.keys - (//.from_list hash)))) - - (implementation: #export equivalence - (All [a] (Equivalence (Set a))) - - (def: (= (^:representation reference) sample) - (and (n.= (dictionary.size reference) - (dictionary.size (:representation sample))) - (|> reference - dictionary.entries - (list.every? (function (_ [elem multiplicity]) - (|> elem - (..multiplicity sample) - (n.= multiplicity)))))))) - - (implementation: #export hash - (All [a] (Hash (Set a))) - - (def: &equivalence ..equivalence) - - (def: (hash (^:representation set)) - (let [[hash _] set] - (list\fold (function (_ [elem multiplicity] acc) - (|> elem (\ hash hash) (n.* multiplicity) (n.+ acc))) - 0 - (dictionary.entries set))))) - ) - -(def: #export (member? set elem) - (All [a] (-> (Set a) a Bit)) - (|> elem (..multiplicity set) (n.> 0))) - -(def: #export empty? - (All [a] (-> (Set a) Bit)) - (|>> ..size (n.= 0))) - -(def: #export (from_list hash subject) - (All [a] (-> (Hash a) (List a) (Set a))) - (list\fold (..add 1) (..new hash) subject)) - -(def: #export (from_set subject) - (All [a] (-> (//.Set a) (Set a))) - (..from_list (//.member_hash subject) - (//.to_list subject))) - -(def: #export super? - (All [a] (-> (Set a) (Set a) Bit)) - (function.flip sub?)) diff --git a/stdlib/source/lux/data/collection/set/ordered.lux b/stdlib/source/lux/data/collection/set/ordered.lux deleted file mode 100644 index 1b57ac87d..000000000 --- a/stdlib/source/lux/data/collection/set/ordered.lux +++ /dev/null @@ -1,84 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [order (#+ Order)]] - [data - [collection - ["." list ("#\." fold)] - [dictionary - ["/" ordered]]]] - [type - abstract]]) - -(abstract: #export (Set a) - (/.Dictionary a a) - - (def: #export new - (All [a] (-> (Order a) (Set a))) - (|>> /.new :abstraction)) - - (def: #export (member? set elem) - (All [a] (-> (Set a) a Bit)) - (/.key? (:representation set) elem)) - - (template [<type> <name> <alias>] - [(def: #export <name> - (All [a] (-> (Set a) <type>)) - (|>> :representation <alias>))] - - [(Maybe a) min /.min] - [(Maybe a) max /.max] - [Nat size /.size] - [Bit empty? /.empty?] - ) - - (def: #export (add elem set) - (All [a] (-> a (Set a) (Set a))) - (|> set :representation (/.put elem elem) :abstraction)) - - (def: #export (remove elem set) - (All [a] (-> a (Set a) (Set a))) - (|> set :representation (/.remove elem) :abstraction)) - - (def: #export to_list - (All [a] (-> (Set a) (List a))) - (|>> :representation /.keys)) - - (def: #export (from_list &order list) - (All [a] (-> (Order a) (List a) (Set a))) - (list\fold add (..new &order) list)) - - (def: #export (union left right) - (All [a] (-> (Set a) (Set a) (Set a))) - (list\fold ..add right (..to_list left))) - - (def: #export (intersection left right) - (All [a] (-> (Set a) (Set a) (Set a))) - (|> (..to_list right) - (list.filter (..member? left)) - (..from_list (get@ #/.&order (:representation right))))) - - (def: #export (difference param subject) - (All [a] (-> (Set a) (Set a) (Set a))) - (|> (..to_list subject) - (list.filter (|>> (..member? param) not)) - (..from_list (get@ #/.&order (:representation subject))))) - - (implementation: #export equivalence - (All [a] (Equivalence (Set a))) - - (def: (= reference sample) - (\ (list.equivalence (\ (:representation reference) &equivalence)) - = (..to_list reference) (..to_list sample)))) - ) - -(def: #export (sub? super sub) - (All [a] (-> (Set a) (Set a) Bit)) - (|> sub - ..to_list - (list.every? (..member? super)))) - -(def: #export (super? sub super) - (All [a] (-> (Set a) (Set a) Bit)) - (sub? super sub)) diff --git a/stdlib/source/lux/data/collection/stack.lux b/stdlib/source/lux/data/collection/stack.lux deleted file mode 100644 index 68d514331..000000000 --- a/stdlib/source/lux/data/collection/stack.lux +++ /dev/null @@ -1,65 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [functor (#+ Functor)]] - [data - [collection - ["//" list]]] - [type - abstract]]) - -(abstract: #export (Stack a) - (List a) - - (def: #export empty - Stack - (:abstraction (list))) - - (def: #export size - (All [a] (-> (Stack a) Nat)) - (|>> :representation //.size)) - - (def: #export empty? - (All [a] (-> (Stack a) Bit)) - (|>> :representation //.empty?)) - - (def: #export (peek stack) - (All [a] (-> (Stack a) (Maybe a))) - (case (:representation stack) - #.Nil - #.None - - (#.Cons value _) - (#.Some value))) - - (def: #export (pop stack) - (All [a] (-> (Stack a) (Maybe [a (Stack a)]))) - (case (:representation stack) - #.Nil - #.None - - (#.Cons top stack') - (#.Some [top (:abstraction stack')]))) - - (def: #export (push value stack) - (All [a] (-> a (Stack a) (Stack a))) - (:abstraction (#.Cons value (:representation stack)))) - - (implementation: #export (equivalence super) - (All [a] - (-> (Equivalence a) - (Equivalence (Stack a)))) - - (def: (= reference subject) - (\ (//.equivalence super) = (:representation reference) (:representation subject)))) - - (implementation: #export functor - (Functor Stack) - - (def: (map f value) - (|> value - :representation - (\ //.functor map f) - :abstraction))) - ) diff --git a/stdlib/source/lux/data/collection/tree.lux b/stdlib/source/lux/data/collection/tree.lux deleted file mode 100644 index 5aa6f9c36..000000000 --- a/stdlib/source/lux/data/collection/tree.lux +++ /dev/null @@ -1,84 +0,0 @@ -(.module: - [lux #* - [abstract - [functor (#+ Functor)] - [equivalence (#+ Equivalence)] - [fold (#+ Fold)] - [monad (#+ do)]] - [control - ["<>" parser - ["<c>" code (#+ Parser)]]] - [data - [collection - ["." list ("#\." monad fold)]]] - [macro - [syntax (#+ syntax:)] - ["." code]]]) - -(type: #export (Tree a) - {#value a - #children (List (Tree a))}) - -(def: #export (flatten tree) - (All [a] (-> (Tree a) (List a))) - (#.Cons (get@ #value tree) - (list\join (list\map flatten (get@ #children tree))))) - -(def: #export (leaf value) - (All [a] (-> a (Tree a))) - {#value value - #children (list)}) - -(def: #export (branch value children) - (All [a] (-> a (List (Tree a)) (Tree a))) - {#value value - #children children}) - -(type: #rec Tree-Code - [Code (List Tree-Code)]) - -(def: tree^ - (Parser Tree-Code) - (|> (|>> <>.some - <c>.record - (<>.and <c>.any)) - <>.rec - <>.some - <c>.record - (<>.default (list)) - (<>.and <c>.any))) - -(syntax: #export (tree {root tree^}) - {#.doc (doc "Tree literals." - (: (Tree Nat) - (tree 10 - {20 {} - 30 {} - 40 {}})))} - (wrap (list (` (~ (loop [[value children] root] - (` {#value (~ value) - #children (list (~+ (list\map recur children)))}))))))) - -(implementation: #export (equivalence super) - (All [a] (-> (Equivalence a) (Equivalence (Tree a)))) - - (def: (= tx ty) - (and (\ super = (get@ #value tx) (get@ #value ty)) - (\ (list.equivalence (equivalence super)) = (get@ #children tx) (get@ #children ty))))) - -(implementation: #export functor - (Functor Tree) - - (def: (map f fa) - {#value (f (get@ #value fa)) - #children (list\map (map f) - (get@ #children fa))})) - -(implementation: #export fold - (Fold Tree) - - (def: (fold f init tree) - (list\fold (function (_ tree' init') (fold f init' tree')) - (f (get@ #value tree) - init) - (get@ #children tree)))) diff --git a/stdlib/source/lux/data/collection/tree/finger.lux b/stdlib/source/lux/data/collection/tree/finger.lux deleted file mode 100644 index d28e69a3c..000000000 --- a/stdlib/source/lux/data/collection/tree/finger.lux +++ /dev/null @@ -1,107 +0,0 @@ -(.module: - [lux #* - [abstract - [predicate (#+ Predicate)] - ["." monoid (#+ Monoid)]] - [data - [collection - ["." list ("#\." monoid)]]] - [type - [abstract (#+ abstract: :abstraction :representation)]]]) - -(abstract: #export (Tree @ t v) - {#monoid (Monoid t) - #tag t - #root (| v - [(Tree @ t v) (Tree @ t v)])} - - (interface: #export (Builder @ t) - (: (All [v] - (-> t v (Tree @ t v))) - leaf) - (: (All [v] - (-> (Tree @ t v) - (Tree @ t v) - (Tree @ t v))) - branch)) - - (template [<name> <tag> <output>] - [(def: #export <name> - (All [@ t v] (-> (Tree @ t v) <output>)) - (|>> :representation (get@ <tag>)))] - - [tag #tag t] - [root #root (Either v [(Tree @ t v) (Tree @ t v)])] - ) - - (implementation: #export (builder monoid) - (All [t] (Ex [@] (-> (Monoid t) (Builder @ t)))) - - (def: (leaf tag value) - (:abstraction - {#monoid monoid - #tag tag - #root (0 #0 value)})) - - (def: (branch left right) - (:abstraction - {#monoid monoid - #tag (\ monoid compose (..tag left) (..tag right)) - #root (0 #1 [left right])}))) - - (def: #export (value tree) - (All [@ t v] (-> (Tree @ t v) v)) - (case (get@ #root (:representation tree)) - (0 #0 value) - value - - (0 #1 [left right]) - (value left))) - - (def: #export (tags tree) - (All [@ t v] (-> (Tree @ t v) (List t))) - (case (get@ #root (:representation tree)) - (0 #0 value) - (list (get@ #tag (:representation tree))) - - (0 #1 [left right]) - (list\compose (tags left) - (tags right)))) - - (def: #export (values tree) - (All [@ t v] (-> (Tree @ t v) (List v))) - (case (get@ #root (:representation tree)) - (0 #0 value) - (list value) - - (0 #1 [left right]) - (list\compose (values left) - (values right)))) - - (def: #export (search predicate tree) - (All [@ t v] (-> (Predicate t) (Tree @ t v) (Maybe v))) - (let [[monoid tag root] (:representation tree)] - (if (predicate tag) - (let [(^open "tag//.") monoid] - (loop [_tag tag//identity - _node root] - (case _node - (0 #0 value) - (#.Some value) - - (0 #1 [left right]) - (let [shifted_tag (tag//compose _tag (..tag left))] - (if (predicate shifted_tag) - (recur _tag (get@ #root (:representation left))) - (recur shifted_tag (get@ #root (:representation right)))))))) - #.None))) - ) - -(def: #export (found? predicate tree) - (All [@ t v] (-> (Predicate t) (Tree @ t v) Bit)) - (case (..search predicate tree) - (#.Some _) - true - - #.None - false)) diff --git a/stdlib/source/lux/data/collection/tree/zipper.lux b/stdlib/source/lux/data/collection/tree/zipper.lux deleted file mode 100644 index be2f7b4bd..000000000 --- a/stdlib/source/lux/data/collection/tree/zipper.lux +++ /dev/null @@ -1,317 +0,0 @@ -(.module: - [lux #* - ["@" target] - [abstract - [functor (#+ Functor)] - [comonad (#+ CoMonad)] - [monad (#+ do)] - [equivalence (#+ Equivalence)]] - [data - ["." product] - ["." maybe ("#\." monad)] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold monoid)]]]] - ["." // (#+ Tree) ("#\." functor)]) - -(type: (Family Zipper a) - {#parent (Zipper a) - #lefts (List (Tree a)) - #rights (List (Tree a))}) - -(type: #export (Zipper a) - {#.doc "Tree zippers, for easy navigation and editing of trees."} - {#family (Maybe (Family Zipper a)) - #node (Tree a)}) - -(implementation: #export (equivalence super) - (All [a] - (-> (Equivalence a) - (Equivalence (Zipper a)))) - - (def: (= reference sample) - (let [== ($_ product.equivalence - (maybe.equivalence - ($_ product.equivalence - = - (list.equivalence (//.equivalence super)) - (list.equivalence (//.equivalence super)))) - (//.equivalence super))] - (== reference sample)))) - -(def: #export (zip tree) - (All [a] (-> (Tree a) (Zipper a))) - {#family #.None - #node tree}) - -(def: #export unzip - (All [a] (-> (Zipper a) (Tree a))) - (get@ #node)) - -(def: #export value - (All [a] (-> (Zipper a) a)) - (get@ [#node #//.value])) - -(def: #export set - (All [a] (-> a (Zipper a) (Zipper a))) - (set@ [#node #//.value])) - -(def: #export update - (All [a] (-> (-> a a) (Zipper a) (Zipper a))) - (update@ [#node #//.value])) - -(def: children - (All [a] (-> (Zipper a) (List (Tree a)))) - (get@ [#node #//.children])) - -(def: #export leaf? - (All [a] (-> (Zipper a) Bit)) - (|>> ..children list.empty?)) - -(def: #export branch? - (All [a] (-> (Zipper a) Bit)) - (|>> ..leaf? not)) - -(def: #export (start? zipper) - (All [a] (-> (Zipper a) Bit)) - (case (get@ #family zipper) - #.None - true - - _ - false)) - -(def: #export (down zipper) - (All [a] (-> (Zipper a) (Maybe (Zipper a)))) - (case (..children zipper) - #.Nil - #.None - - (#.Cons head tail) - (#.Some {#family (#.Some {#parent (set@ [#node #//.children] (list) zipper) - #lefts #.Nil - #rights tail}) - #node head}))) - -(def: #export (up zipper) - (All [a] (-> (Zipper a) (Maybe (Zipper a)))) - (do maybe.monad - [family (get@ #family zipper)] - (wrap (let [(^slots [#parent #lefts #rights]) family] - (for {@.old - (update@ #node (: (-> (Tree ($ 0)) (Tree ($ 0))) - (set@ #//.children (list\compose (list.reverse lefts) - (#.Cons (get@ #node zipper) - rights)))) - parent)} - (set@ [#node #//.children] - (list\compose (list.reverse lefts) - (#.Cons (get@ #node zipper) - rights)) - parent)))))) - -(template [<one> <all> <side> <op-side>] - [(def: #export (<one> zipper) - (All [a] (-> (Zipper a) (Maybe (Zipper a)))) - (case (get@ #family zipper) - (#.Some family) - (case (get@ <side> family) - (#.Cons next side') - (#.Some (for {@.old - {#family (#.Some (|> family - (set@ <side> side') - (update@ <op-side> (|>> (#.Cons (get@ #node zipper)))))) - #node next}} - (let [move (: (All [a] (-> (List (Tree a)) (Zipper a) (Family Zipper a) (Family Zipper a))) - (function (_ side' zipper) - (|>> (set@ <side> side') - (update@ <op-side> (|>> (#.Cons (get@ #node zipper)))))))] - {#family (#.Some (move side' zipper family)) - #node next}))) - - #.Nil - #.None) - - #.None - #.None)) - - (def: #export (<all> zipper) - (All [a] (-> (Zipper a) (Maybe (Zipper a)))) - (case (get@ #family zipper) - #.None - #.None - - (#.Some family) - (case (list.reverse (get@ <side> family)) - #.Nil - #.None - - (#.Cons last prevs) - (#.Some (for {@.old {#family (#.Some (|> family - (set@ <side> #.Nil) - (update@ <op-side> (|>> (#.Cons (get@ #node zipper)) - (list\compose prevs))))) - #node last}} - (let [move (: (All [a] (-> (List (Tree a)) (Zipper a) (Family Zipper a) (Family Zipper a))) - (function (_ prevs zipper) - (|>> (set@ <side> #.Nil) - (update@ <op-side> (|>> (#.Cons (get@ #node zipper)) - (list\compose prevs))))))] - {#family (#.Some (move prevs zipper family)) - #node last}))))))] - - [right rightmost #rights #lefts] - [left leftmost #lefts #rights] - ) - -(def: #export (next zipper) - (All [a] (-> (Zipper a) (Maybe (Zipper a)))) - (case (..down zipper) - (#.Some forward) - (#.Some forward) - - #.None - (loop [@ zipper] - (case (..right @) - (#.Some forward) - (#.Some forward) - - #.None - (do maybe.monad - [@ (..up @)] - (recur @)))))) - -(def: (bottom zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (case (..right zipper) - (#.Some forward) - (bottom forward) - - #.None - (case (..down zipper) - (#.Some forward) - (bottom forward) - - #.None - zipper))) - -(def: #export (previous zipper) - (All [a] (-> (Zipper a) (Maybe (Zipper a)))) - (case (..left zipper) - #.None - (..up zipper) - - (#.Some backward) - (#.Some (case (..down backward) - (#.Some then) - (..bottom then) - - #.None - backward)))) - -(template [<name> <move>] - [(def: #export (<name> zipper) - (All [a] (-> (Zipper a) (Maybe (Zipper a)))) - (case (<move> zipper) - #.None - #.None - - (#.Some @) - (loop [@ @] - (case (<move> @) - #.None - (#.Some @) - - (#.Some @) - (recur @)))))] - - [end ..next] - [start ..previous] - ) - -(def: #export (end? zipper) - (All [a] (-> (Zipper a) Bit)) - (case (..end zipper) - #.None - true - - (#.Some _) - false)) - -(def: #export (interpose value zipper) - (All [a] (-> a (Zipper a) (Zipper a))) - (update@ [#node #//.children] - (|>> (//.branch value) list) - zipper)) - -(def: #export (adopt value zipper) - (All [a] (-> a (Zipper a) (Zipper a))) - (update@ [#node #//.children] - (|>> (#.Cons (//.leaf value))) - zipper)) - -(def: #export (remove zipper) - (All [a] (-> (Zipper a) (Maybe (Zipper a)))) - (do maybe.monad - [family (get@ #family zipper)] - (case (get@ #lefts family) - #.Nil - (wrap (set@ [#node #//.children] - (get@ #rights family) - (get@ #parent family))) - - (#.Cons next side) - (wrap (|> zipper - (set@ #family (|> family - (set@ #lefts side) - #.Some)) - (set@ #node next)))))) - -(template [<name> <side>] - [(def: #export (<name> value zipper) - (All [a] (-> a (Zipper a) (Maybe (Zipper a)))) - (case (get@ #family zipper) - #.None - #.None - - (#.Some family) - (#.Some (set@ #family - (#.Some (update@ <side> (|>> (#.Cons (//.leaf value))) family)) - zipper))))] - - [insert-left #lefts] - [insert-right #rights] - ) - -(implementation: #export functor - (Functor Zipper) - - (def: (map f (^slots [#family #node])) - {#family (maybe\map (function (_ (^slots [#parent #lefts #rights])) - {#parent (map f parent) - #lefts (list\map (//\map f) lefts) - #rights (list\map (//\map f) rights)}) - family) - #node (//\map f node)})) - -(implementation: #export comonad - (CoMonad Zipper) - - (def: &functor ..functor) - - (def: unwrap (get@ [#node #//.value])) - - (def: (split (^slots [#family #node])) - (let [tree-splitter (: (All [a] (-> (Tree a) (Tree (Zipper a)))) - (function (tree-splitter tree) - {#//.value (..zip tree) - #//.children (|> tree - (get@ #//.children) - (list\map tree-splitter))}))] - {#family (maybe\map (function (_ (^slots [#parent #lefts #rights])) - {#parent (split parent) - #lefts (list\map tree-splitter lefts) - #rights (list\map tree-splitter rights)}) - family) - #node (tree-splitter node)}))) diff --git a/stdlib/source/lux/data/color.lux b/stdlib/source/lux/data/color.lux deleted file mode 100644 index 921137d9a..000000000 --- a/stdlib/source/lux/data/color.lux +++ /dev/null @@ -1,424 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [monoid (#+ Monoid)] - ["." hash (#+ Hash)]] - [data - [collection - ["." list ("#\." functor)]]] - ["." math - [number - ["n" nat] - ["f" frac] - ["." int] - ["." rev ("#\." interval)] - ["." i64]]] - [type - abstract]]) - -(def: rgb 256) -(def: top (dec rgb)) - -(def: rgb_factor (|> top .int int.frac)) - -(def: down - (-> Nat Frac) - (|>> .int int.frac (f./ rgb_factor))) - -(def: up - (-> Frac Nat) - (|>> (f.* rgb_factor) f.int .nat)) - -(type: #export RGB - {#red Nat - #green Nat - #blue Nat}) - -(type: #export HSL - [Frac Frac Frac]) - -(type: #export CMYK - {#cyan Frac - #magenta Frac - #yellow Frac - #key Frac}) - -(type: #export HSB - [Frac Frac Frac]) - -(abstract: #export Color - RGB - - (def: #export (from_rgb [red green blue]) - (-> RGB Color) - (:abstraction {#red (n.% ..rgb red) - #green (n.% ..rgb green) - #blue (n.% ..rgb blue)})) - - (def: #export to_rgb - (-> Color RGB) - (|>> :representation)) - - (implementation: #export equivalence - (Equivalence Color) - - (def: (= reference sample) - (let [[rR gR bR] (:representation reference) - [rS gS bS] (:representation sample)] - (and (n.= rR rS) - (n.= gR gS) - (n.= bR bS))))) - - (implementation: #export hash - (Hash Color) - - (def: &equivalence ..equivalence) - - (def: (hash value) - (let [[r g b] (:representation value)] - ($_ i64.or - (i64.left_shift 16 r) - (i64.left_shift 8 g) - b)))) - - (def: #export black - (..from_rgb {#red 0 - #green 0 - #blue 0})) - - (def: #export white - (..from_rgb {#red ..top - #green ..top - #blue ..top})) - - (implementation: #export addition - (Monoid Color) - - (def: identity ..black) - - (def: (compose left right) - (let [[lR lG lB] (:representation left) - [rR rG rB] (:representation right)] - (:abstraction {#red (n.max lR rR) - #green (n.max lG rG) - #blue (n.max lB rB)})))) - - (def: (complement' value) - (-> Nat Nat) - (|> ..top (n.- value))) - - (def: #export (complement color) - (-> Color Color) - (let [[red green blue] (:representation color)] - (:abstraction {#red (complement' red) - #green (complement' green) - #blue (complement' blue)}))) - - (implementation: #export subtraction - (Monoid Color) - - (def: identity ..white) - - (def: (compose left right) - (let [[lR lG lB] (:representation (..complement left)) - [rR rG rB] (:representation right)] - (:abstraction {#red (n.min lR rR) - #green (n.min lG rG) - #blue (n.min lB rB)})))) - ) - -(def: #export (to_hsl color) - (-> Color HSL) - (let [[red green blue] (to_rgb color) - red (..down red) - green (..down green) - blue (..down blue) - max ($_ f.max red green blue) - min ($_ f.min red green blue) - luminance (|> (f.+ max min) (f./ +2.0))] - (if (f.= max min) - ## Achromatic - [+0.0 - +0.0 - luminance] - ## Chromatic - (let [diff (|> max (f.- min)) - saturation (|> diff - (f./ (if (f.> +0.5 luminance) - (|> +2.0 (f.- max) (f.- min)) - (|> max (f.+ min))))) - hue' (cond (f.= red max) - (|> green (f.- blue) (f./ diff) - (f.+ (if (f.< blue green) +6.0 +0.0))) - - (f.= green max) - (|> blue (f.- red) (f./ diff) - (f.+ +2.0)) - - ## (f.= blue max) - (|> red (f.- green) (f./ diff) - (f.+ +4.0)))] - [(|> hue' (f./ +6.0)) - saturation - luminance])))) - -(def: (hue_to_rgb p q t) - (-> Frac Frac Frac Frac) - (let [t (cond (f.< +0.0 t) (f.+ +1.0 t) - (f.> +1.0 t) (f.- +1.0 t) - ## else - t) - f2/3 (f./ +3.0 +2.0)] - (cond (f.< (f./ +6.0 +1.0) t) - (|> q (f.- p) (f.* +6.0) (f.* t) (f.+ p)) - - (f.< (f./ +2.0 +1.0) t) - q - - (f.< f2/3 t) - (|> q (f.- p) (f.* (|> f2/3 (f.- t))) (f.* +6.0) (f.+ p)) - - ## else - p))) - -(def: #export (from_hsl [hue saturation luminance]) - (-> HSL Color) - (if (f.= +0.0 saturation) - ## Achromatic - (let [intensity (..up luminance)] - (from_rgb {#red intensity - #green intensity - #blue intensity})) - ## Chromatic - (let [q (if (f.< +0.5 luminance) - (|> saturation (f.+ +1.0) (f.* luminance)) - (|> luminance (f.+ saturation) (f.- (f.* saturation luminance)))) - p (|> luminance (f.* +2.0) (f.- q)) - third (|> +1.0 (f./ +3.0))] - (from_rgb {#red (..up (|> hue (f.+ third) (hue_to_rgb p q))) - #green (..up (|> hue (hue_to_rgb p q))) - #blue (..up (|> hue (f.- third) (hue_to_rgb p q)))})))) - -(def: #export (to_hsb color) - (-> Color HSB) - (let [[red green blue] (to_rgb color) - red (..down red) - green (..down green) - blue (..down blue) - max ($_ f.max red green blue) - min ($_ f.min red green blue) - brightness max - diff (|> max (f.- min)) - saturation (if (f.= +0.0 max) - +0.0 - (|> diff (f./ max)))] - (if (f.= max min) - ## Achromatic - [+0.0 saturation brightness] - ## Chromatic - (let [hue (cond (f.= red max) - (|> green (f.- blue) (f./ diff) - (f.+ (if (f.< blue green) +6.0 +0.0))) - - (f.= green max) - (|> blue (f.- red) (f./ diff) - (f.+ +2.0)) - - ## (f.= blue max) - (|> red (f.- green) (f./ diff) - (f.+ +4.0)))] - [(|> hue (f./ +6.0)) - saturation - brightness])))) - -(def: #export (from_hsb [hue saturation brightness]) - (-> HSB Color) - (let [hue (|> hue (f.* +6.0)) - i (math.floor hue) - f (|> hue (f.- i)) - p (|> +1.0 (f.- saturation) (f.* brightness)) - q (|> +1.0 (f.- (f.* f saturation)) (f.* brightness)) - t (|> +1.0 (f.- (|> +1.0 (f.- f) (f.* saturation))) (f.* brightness)) - v brightness - mod (|> i (f.% +6.0) f.int .nat) - red (case mod 0 v 1 q 2 p 3 p 4 t 5 v _ (undefined)) - green (case mod 0 t 1 v 2 v 3 q 4 p 5 p _ (undefined)) - blue (case mod 0 p 1 p 2 t 3 v 4 v 5 q _ (undefined))] - (from_rgb {#red (..up red) - #green (..up green) - #blue (..up blue)}))) - -(def: #export (to_cmyk color) - (-> Color CMYK) - (let [[red green blue] (to_rgb color) - red (..down red) - green (..down green) - blue (..down blue) - key (|> +1.0 (f.- ($_ f.max red green blue))) - f (if (f.< +1.0 key) - (|> +1.0 (f./ (|> +1.0 (f.- key)))) - +0.0) - cyan (|> +1.0 (f.- red) (f.- key) (f.* f)) - magenta (|> +1.0 (f.- green) (f.- key) (f.* f)) - yellow (|> +1.0 (f.- blue) (f.- key) (f.* f))] - {#cyan cyan - #magenta magenta - #yellow yellow - #key key})) - -(def: #export (from_cmyk [cyan magenta yellow key]) - (-> CMYK Color) - (if (f.= +1.0 key) - (from_rgb {#red 0 - #green 0 - #blue 0}) - (let [red (|> (|> +1.0 (f.- cyan)) - (f.* (|> +1.0 (f.- key)))) - green (|> (|> +1.0 (f.- magenta)) - (f.* (|> +1.0 (f.- key)))) - blue (|> (|> +1.0 (f.- yellow)) - (f.* (|> +1.0 (f.- key))))] - (from_rgb {#red (..up red) - #green (..up green) - #blue (..up blue)})))) - -(def: (normalize ratio) - (-> Frac Frac) - (cond (f.> +1.0 ratio) - (f.% +1.0 ratio) - - (f.< +0.0 ratio) - (|> ratio (f.% +1.0) (f.+ +1.0)) - - ## else - ratio)) - -(def: #export (interpolate ratio end start) - (-> Frac Color Color Color) - (let [dS (..normalize ratio) - dE (|> +1.0 (f.- dS)) - interpolate' (: (-> Nat Nat Nat) - (function (_ end start) - (|> (|> start .int int.frac (f.* dS)) - (f.+ (|> end .int int.frac (f.* dE))) - f.int - .nat))) - [redS greenS blueS] (to_rgb start) - [redE greenE blueE] (to_rgb end)] - (from_rgb {#red (interpolate' redE redS) - #green (interpolate' greenE greenS) - #blue (interpolate' blueE blueS)}))) - -(template [<name> <target>] - [(def: #export (<name> ratio color) - (-> Frac Color Color) - (..interpolate ratio <target> color))] - - [darker black] - [brighter white] - ) - -(template [<name> <op>] - [(def: #export (<name> ratio color) - (-> Frac Color Color) - (let [[hue saturation luminance] (to_hsl color)] - (from_hsl [hue - (|> saturation - (f.* (|> +1.0 (<op> (..normalize ratio)))) - (f.min +1.0)) - luminance])))] - - [saturate f.+] - [de_saturate f.-] - ) - -(def: #export (gray_scale color) - (-> Color Color) - (let [[_ _ luminance] (to_hsl color)] - (from_hsl [+0.0 - +0.0 - luminance]))) - -(template [<name> <1> <2>] - [(def: #export (<name> color) - (-> Color [Color Color Color]) - (let [[hue saturation luminance] (to_hsl color)] - [color - (from_hsl [(|> hue (f.+ <1>) ..normalize) - saturation - luminance]) - (from_hsl [(|> hue (f.+ <2>) ..normalize) - saturation - luminance])]))] - - [triad (|> +1.0 (f./ +3.0)) (|> +2.0 (f./ +3.0))] - [clash (|> +1.0 (f./ +4.0)) (|> +3.0 (f./ +4.0))] - [split_complement (|> +1.0 (f./ +5.0)) (|> +3.0 (f./ +5.0))] - ) - -(template [<name> <1> <2> <3>] - [(def: #export (<name> color) - (-> Color [Color Color Color Color]) - (let [[hue saturation luminance] (to_hsb color)] - [color - (from_hsb [(|> hue (f.+ <1>) ..normalize) - saturation - luminance]) - (from_hsb [(|> hue (f.+ <2>) ..normalize) - saturation - luminance]) - (from_hsb [(|> hue (f.+ <3>) ..normalize) - saturation - luminance])]))] - - [square (|> +1.0 (f./ +4.0)) (|> +2.0 (f./ +4.0)) (|> +3.0 (f./ +4.0))] - [tetradic (|> +2.0 (f./ +12.0)) (|> +6.0 (f./ +12.0)) (|> +8.0 (f./ +12.0))] - ) - -(type: #export Spread - Frac) - -(type: #export Palette - (-> Spread Nat Color (List Color))) - -(def: #export (analogous spread variations color) - (-> Spread Nat Color (List Color)) - (let [[hue saturation brightness] (to_hsb color) - spread (..normalize spread)] - (list\map (function (_ idx) - (from_hsb [(|> idx inc .int int.frac (f.* spread) (f.+ hue) ..normalize) - saturation - brightness])) - (list.indices variations)))) - -(def: #export (monochromatic spread variations color) - (-> Spread Nat Color (List Color)) - (let [[hue saturation brightness] (to_hsb color) - spread (..normalize spread)] - (|> (list.indices variations) - (list\map (|>> inc .int int.frac - (f.* spread) - (f.+ brightness) - ..normalize - [hue saturation] - from_hsb))))) - -(type: #export Alpha - Rev) - -(def: #export transparent - Alpha - rev\bottom) - -(def: #export translucent - Alpha - .5) - -(def: #export opaque - Alpha - rev\top) - -(type: #export Pigment - {#color Color - #alpha Alpha}) diff --git a/stdlib/source/lux/data/color/named.lux b/stdlib/source/lux/data/color/named.lux deleted file mode 100644 index 54c9a4563..000000000 --- a/stdlib/source/lux/data/color/named.lux +++ /dev/null @@ -1,155 +0,0 @@ -(.module: - [lux #* - [math - [number (#+ hex)]]] - ["." // (#+ Color)]) - -(template [<red> <green> <blue> <name>] - [(def: #export <name> - Color - (//.from_rgb {#//.red (hex <red>) - #//.green (hex <green>) - #//.blue (hex <blue>)}))] - - ["F0" "F8" "FF" alice_blue] - ["FA" "EB" "D7" antique_white] - ["00" "FF" "FF" aqua] - ["7F" "FF" "D4" aquamarine] - ["F0" "FF" "FF" azure] - ["F5" "F5" "DC" beige] - ["FF" "E4" "C4" bisque] - ["00" "00" "00" black] - ["FF" "EB" "CD" blanched_almond] - ["00" "00" "FF" blue] - ["8A" "2B" "E2" blue_violet] - ["A5" "2A" "2A" brown] - ["DE" "B8" "87" burly_wood] - ["5F" "9E" "A0" cadet_blue] - ["7F" "FF" "00" chartreuse] - ["D2" "69" "1E" chocolate] - ["FF" "7F" "50" coral] - ["64" "95" "ED" cornflower_blue] - ["FF" "F8" "DC" cornsilk] - ["DC" "14" "3C" crimson] - ["00" "FF" "FF" cyan] - ["00" "00" "8B" dark_blue] - ["00" "8B" "8B" dark_cyan] - ["B8" "86" "0B" dark_goldenrod] - ["A9" "A9" "A9" dark_gray] - ["00" "64" "00" dark_green] - ["BD" "B7" "6B" dark_khaki] - ["8B" "00" "8B" dark_magenta] - ["55" "6B" "2F" dark_olive_green] - ["FF" "8C" "00" dark_orange] - ["99" "32" "CC" dark_orchid] - ["8B" "00" "00" dark_red] - ["E9" "96" "7A" dark_salmon] - ["8F" "BC" "8F" dark_sea_green] - ["48" "3D" "8B" dark_slate_blue] - ["2F" "4F" "4F" dark_slate_gray] - ["00" "CE" "D1" dark_turquoise] - ["94" "00" "D3" dark_violet] - ["FF" "14" "93" deep_pink] - ["00" "BF" "FF" deep_sky_blue] - ["69" "69" "69" dim_gray] - ["1E" "90" "FF" dodger_blue] - ["B2" "22" "22" fire_brick] - ["FF" "FA" "F0" floral_white] - ["22" "8B" "22" forest_green] - ["FF" "00" "FF" fuchsia] - ["DC" "DC" "DC" gainsboro] - ["F8" "F8" "FF" ghost_white] - ["FF" "D7" "00" gold] - ["DA" "A5" "20" goldenrod] - ["80" "80" "80" gray] - ["00" "80" "00" green] - ["AD" "FF" "2F" green_yellow] - ["F0" "FF" "F0" honey_dew] - ["FF" "69" "B4" hot_pink] - ["CD" "5C" "5C" indian_red] - ["4B" "00" "82" indigo] - ["FF" "FF" "F0" ivory] - ["F0" "E6" "8C" khaki] - ["E6" "E6" "FA" lavender] - ["FF" "F0" "F5" lavender_blush] - ["7C" "FC" "00" lawn_green] - ["FF" "FA" "CD" lemon_chiffon] - ["AD" "D8" "E6" light_blue] - ["F0" "80" "80" light_coral] - ["E0" "FF" "FF" light_cyan] - ["FA" "FA" "D2" light_goldenrod_yellow] - ["D3" "D3" "D3" light_gray] - ["90" "EE" "90" light_green] - ["FF" "B6" "C1" light_pink] - ["FF" "A0" "7A" light_salmon] - ["20" "B2" "AA" light_sea_green] - ["87" "CE" "FA" light_sky_blue] - ["77" "88" "99" light_slate_gray] - ["B0" "C4" "DE" light_steel_blue] - ["FF" "FF" "E0" light_yellow] - ["00" "FF" "00" lime] - ["32" "CD" "32" lime_green] - ["FA" "F0" "E6" linen] - ["FF" "00" "FF" magenta] - ["80" "00" "00" maroon] - ["66" "CD" "AA" medium_aquamarine] - ["00" "00" "CD" medium_blue] - ["BA" "55" "D3" medium_orchid] - ["93" "70" "DB" medium_purple] - ["3C" "B3" "71" medium_sea_green] - ["7B" "68" "EE" medium_slate_blue] - ["00" "FA" "9A" medium_spring_green] - ["48" "D1" "CC" medium_turquoise] - ["C7" "15" "85" medium_violet_red] - ["19" "19" "70" midnight_blue] - ["F5" "FF" "FA" mint_cream] - ["FF" "E4" "E1" misty_rose] - ["FF" "E4" "B5" moccasin] - ["FF" "DE" "AD" navajo_white] - ["00" "00" "80" navy] - ["FD" "F5" "E6" old_lace] - ["80" "80" "00" olive] - ["6B" "8E" "23" olive_drab] - ["FF" "A5" "00" orange] - ["FF" "45" "00" orange_red] - ["DA" "70" "D6" orchid] - ["EE" "E8" "AA" pale_goldenrod] - ["98" "FB" "98" pale_green] - ["AF" "EE" "EE" pale_turquoise] - ["DB" "70" "93" pale_violet_red] - ["FF" "EF" "D5" papaya_whip] - ["FF" "DA" "B9" peach_puff] - ["CD" "85" "3F" peru] - ["FF" "C0" "CB" pink] - ["DD" "A0" "DD" plum] - ["B0" "E0" "E6" powder_blue] - ["80" "00" "80" purple] - ["66" "33" "99" rebecca_purple] - ["FF" "00" "00" red] - ["BC" "8F" "8F" rosy_brown] - ["41" "69" "E1" royal_blue] - ["8B" "45" "13" saddle_brown] - ["FA" "80" "72" salmon] - ["F4" "A4" "60" sandy_brown] - ["2E" "8B" "57" sea_green] - ["FF" "F5" "EE" sea_shell] - ["A0" "52" "2D" sienna] - ["C0" "C0" "C0" silver] - ["87" "CE" "EB" sky_blue] - ["6A" "5A" "CD" slate_blue] - ["70" "80" "90" slate_gray] - ["FF" "FA" "FA" snow] - ["00" "FF" "7F" spring_green] - ["46" "82" "B4" steel_blue] - ["D2" "B4" "8C" tan] - ["00" "80" "80" teal] - ["D8" "BF" "D8" thistle] - ["FF" "63" "47" tomato] - ["40" "E0" "D0" turquoise] - ["EE" "82" "EE" violet] - ["F5" "DE" "B3" wheat] - ["FF" "FF" "FF" white] - ["F5" "F5" "F5" white_smoke] - ["FF" "FF" "00" yellow] - ["9A" "CD" "32" yellow_green] - ) diff --git a/stdlib/source/lux/data/format/binary.lux b/stdlib/source/lux/data/format/binary.lux deleted file mode 100644 index 25b7b69e5..000000000 --- a/stdlib/source/lux/data/format/binary.lux +++ /dev/null @@ -1,291 +0,0 @@ -(.module: - [lux (#- and or nat int rev list type) - [type (#+ :share)] - [abstract - [monoid (#+ Monoid)] - [monad (#+ Monad do)] - [equivalence (#+ Equivalence)]] - [control - [pipe (#+ case>)] - ["." function] - ["." try (#+ Try)] - ["<>" parser ("#\." monad) - ["/" binary (#+ Offset Size Parser)]]] - [data - ["." product] - ["." binary (#+ Binary)] - [text - ["%" format (#+ format)] - [encoding - ["." utf8]]] - [collection - ["." list] - ["." row (#+ Row) ("#\." functor)] - ["." set (#+ Set)]]] - [math - [number - ["." i64] - ["n" nat] - ["." frac]]]]) - -(def: mask - (-> Size (I64 Any)) - (|>> (n.* i64.bits_per_byte) i64.mask)) - -(type: #export Mutation - (-> [Offset Binary] [Offset Binary])) - -(type: #export Specification - [Size Mutation]) - -(def: #export no_op - Specification - [0 function.identity]) - -(def: #export (instance [size mutation]) - (-> Specification Binary) - (|> size binary.create [0] mutation product.right)) - -(implementation: #export monoid - (Monoid Specification) - - (def: identity - ..no_op) - - (def: (compose [sizeL mutL] [sizeR mutR]) - [(n.+ sizeL sizeR) - (|>> mutL mutR)])) - -(type: #export (Writer a) - (-> a Specification)) - -(def: #export (run writer value) - (All [a] (-> (Writer a) a Binary)) - (..instance (writer value))) - -(template [<name> <size> <write>] - [(def: #export <name> - (Writer (I64 Any)) - (function (_ value) - [<size> - (function (_ [offset binary]) - [(n.+ <size> offset) - (|> binary - (<write> offset value) - try.assume)])]))] - - [bits/8 /.size/8 binary.write/8] - [bits/16 /.size/16 binary.write/16] - [bits/32 /.size/32 binary.write/32] - [bits/64 /.size/64 binary.write/64] - ) - -(def: #export (or left right) - (All [l r] (-> (Writer l) (Writer r) (Writer (| l r)))) - (function (_ altV) - (case altV - (^template [<number> <tag> <writer>] - [(<tag> caseV) - (let [[caseS caseT] (<writer> caseV)] - [(.inc caseS) - (function (_ [offset binary]) - (|> binary - (binary.write/8 offset <number>) - try.assume - [(.inc offset)] - caseT))])]) - ([0 #.Left left] - [1 #.Right right]) - ))) - -(def: #export (and pre post) - (All [a b] (-> (Writer a) (Writer b) (Writer [a b]))) - (function (_ [preV postV]) - (\ ..monoid compose (pre preV) (post postV)))) - -(def: #export (rec body) - (All [a] (-> (-> (Writer a) (Writer a)) (Writer a))) - (function (recur value) - (body recur value))) - -(def: #export any - (Writer Any) - (function.constant ..no_op)) - -(def: #export bit - (Writer Bit) - (|>> (case> #0 0 #1 1) ..bits/8)) - -(template [<name> <type>] - [(def: #export <name> (Writer <type>) ..bits/64)] - - [nat Nat] - [int Int] - [rev Rev] - ) - -(def: #export frac - (Writer Frac) - (|>> frac.to_bits ..bits/64)) - -(def: #export (segment size) - (-> Nat (Writer Binary)) - (function (_ value) - [size - (function (_ [offset binary]) - [(n.+ size offset) - (try.assume - (binary.copy (n.min size (binary.size value)) - 0 - value - offset - binary))])])) - -(template [<name> <bits> <size> <write>] - [(def: #export <name> - (Writer Binary) - (let [mask (..mask <size>)] - (function (_ value) - (let [size (|> value binary.size (i64.and mask)) - size' (n.+ <size> size)] - [size' - (function (_ [offset binary]) - [(n.+ size' offset) - (try.assume - (do try.monad - [_ (<write> offset size binary)] - (binary.copy size 0 value (n.+ <size> offset) binary)))])]))))] - - [binary/8 ..bits/8 /.size/8 binary.write/8] - [binary/16 ..bits/16 /.size/16 binary.write/16] - [binary/32 ..bits/32 /.size/32 binary.write/32] - [binary/64 ..bits/64 /.size/64 binary.write/64] - ) - -(template [<name> <binary>] - [(def: #export <name> - (Writer Text) - (|>> (\ utf8.codec encode) <binary>))] - - [utf8/8 ..binary/8] - [utf8/16 ..binary/16] - [utf8/32 ..binary/32] - [utf8/64 ..binary/64] - ) - -(def: #export text ..utf8/64) - -(template [<name> <size> <write>] - [(def: #export (<name> valueW) - (All [v] (-> (Writer v) (Writer (Row v)))) - (function (_ value) - (let [original_count (row.size value) - capped_count (i64.and (..mask <size>) - original_count) - value (if (n.= original_count capped_count) - value - (|> value row.to_list (list.take capped_count) row.from_list)) - (^open "specification\.") ..monoid - [size mutation] (|> value - (row\map valueW) - (\ row.fold fold - (function (_ post pre) - (specification\compose pre post)) - specification\identity))] - [(n.+ <size> size) - (function (_ [offset binary]) - (try.assume - (do try.monad - [_ (<write> offset capped_count binary)] - (wrap (mutation [(n.+ <size> offset) binary])))))])))] - - [row/8 /.size/8 binary.write/8] - [row/16 /.size/16 binary.write/16] - [row/32 /.size/32 binary.write/32] - [row/64 /.size/64 binary.write/64] - ) - -(def: #export maybe - (All [a] (-> (Writer a) (Writer (Maybe a)))) - (..or ..any)) - -(def: #export (list value) - (All [a] (-> (Writer a) (Writer (List a)))) - (..rec - (|>> (..and value) - (..or ..any)))) - -(def: #export (set value) - (All [a] (-> (Writer a) (Writer (Set a)))) - (|>> set.to_list (..list value))) - -(def: #export name - (Writer Name) - (..and ..text ..text)) - -(def: #export type - (Writer Type) - (..rec - (function (_ recur) - (let [pair (..and recur recur) - indexed ..nat - quantified (..and (..list recur) recur)] - (function (_ altV) - (case altV - (^template [<number> <tag> <writer>] - [(<tag> caseV) - (let [[caseS caseT] (<writer> caseV)] - [(.inc caseS) - (function (_ [offset binary]) - (|> binary - (binary.write/8 offset <number>) - try.assume - [(.inc offset)] - caseT))])]) - ([0 #.Primitive (..and ..text (..list recur))] - [1 #.Sum pair] - [2 #.Product pair] - [3 #.Function pair] - [4 #.Parameter indexed] - [5 #.Var indexed] - [6 #.Ex indexed] - [7 #.UnivQ quantified] - [8 #.ExQ quantified] - [9 #.Apply pair] - [10 #.Named (..and ..name recur)]) - )))))) - -(def: #export location - (Writer Location) - ($_ ..and ..text ..nat ..nat)) - -(def: #export code - (Writer Code) - (..rec - (function (_ recur) - (let [sequence (..list recur)] - (..and ..location - (function (_ altV) - (case altV - (^template [<number> <tag> <writer>] - [(<tag> caseV) - (let [[caseS caseT] (<writer> caseV)] - [(.inc caseS) - (function (_ [offset binary]) - (|> binary - (binary.write/8 offset <number>) - try.assume - [(.inc offset)] - caseT))])]) - ([0 #.Bit ..bit] - [1 #.Nat ..nat] - [2 #.Int ..int] - [3 #.Rev ..rev] - [4 #.Frac ..frac] - [5 #.Text ..text] - [6 #.Identifier ..name] - [7 #.Tag ..name] - [8 #.Form sequence] - [9 #.Tuple sequence] - [10 #.Record (..list (..and recur recur))]) - ))))))) diff --git a/stdlib/source/lux/data/format/css.lux b/stdlib/source/lux/data/format/css.lux deleted file mode 100644 index d172c7742..000000000 --- a/stdlib/source/lux/data/format/css.lux +++ /dev/null @@ -1,125 +0,0 @@ -(.module: - [lux (#- and) - [data - ["." maybe] - [number - ["." nat]] - ["." text - ["%" format (#+ format)] - ["." encoding (#+ Encoding)]] - [collection - ["." list ("#\." functor)]]] - [type - abstract] - [world - [net (#+ URL)]]] - ["." / #_ - ["#." selector (#+ Selector Combinator)] - ["#." value (#+ Value Animation Percentage)] - ["#." font (#+ Font)] - ["#." style (#+ Style)] - ["#." query (#+ Query)]]) - -(abstract: #export Common Any) -(abstract: #export Special Any) - -(abstract: #export (CSS brand) - Text - - (def: #export css (-> (CSS Any) Text) (|>> :representation)) - - (def: #export empty (CSS Common) (:abstraction "")) - - (def: #export (rule selector style) - (-> (Selector Any) Style (CSS Common)) - (:abstraction (format (/selector.selector selector) "{" (/style.inline style) "}"))) - - (def: #export char-set - (-> Encoding (CSS Special)) - (|>> encoding.name - %.text - (text.enclose ["@charset " ";"]) - :abstraction)) - - (def: #export (font font) - (-> Font (CSS Special)) - (let [with-unicode (case (get@ #/font.unicode-range font) - (#.Some unicode-range) - (let [unicode-range' (format "U+" (\ nat.hex encode (get@ #/font.start unicode-range)) - "-" (\ nat.hex encode (get@ #/font.end unicode-range)))] - (list ["unicode-range" unicode-range'])) - - #.None - (list))] - (|> (list& ["font-family" (get@ #/font.family font)] - ["src" (format "url(" (get@ #/font.source font) ")")] - ["font-stretch" (|> font (get@ #/font.stretch) (maybe.default /value.normal-stretch) /value.value)] - ["font-style" (|> font (get@ #/font.style) (maybe.default /value.normal-style) /value.value)] - ["font-weight" (|> font (get@ #/font.weight) (maybe.default /value.normal-weight) /value.value)] - with-unicode) - (list\map (function (_ [property value]) - (format property ": " value ";"))) - (text.join-with /style.separator) - (text.enclose ["{" "}"]) - (format "@font-face") - :abstraction))) - - (def: #export (import url query) - (-> URL (Maybe Query) (CSS Special)) - (:abstraction (format (format "@import url(" (%.text url) ")") - (case query - (#.Some query) - (format " " (/query.query query)) - - #.None - "") - ";"))) - - (def: css-separator text.new-line) - - (type: #export Frame - {#when Percentage - #what Style}) - - (def: #export (key-frames animation frames) - (-> (Value Animation) (List Frame) (CSS Special)) - (:abstraction (format "@keyframes " (/value.value animation) " {" - (|> frames - (list\map (function (_ frame) - (format (/value.percentage (get@ #when frame)) " {" - (/style.inline (get@ #what frame)) - "}"))) - (text.join-with ..css-separator)) - "}"))) - - (template: (!compose <pre> <post>) - (:abstraction (format (:representation <pre>) ..css-separator - (:representation <post>)))) - - (def: #export (and pre post) - (-> (CSS Any) (CSS Any) (CSS Any)) - (!compose pre post)) - - (def: #export (alter combinator selector css) - (-> Combinator (Selector Any) (CSS Common) (CSS Common)) - (|> css - :representation - (text.split-all-with ..css-separator) - (list\map (|>> (format (/selector.selector (|> selector (combinator (/selector.tag ""))))))) - (text.join-with ..css-separator) - :abstraction)) - - (def: #export (dependent combinator selector style inner) - (-> Combinator (Selector Any) Style (CSS Common) (CSS Common)) - (!compose (..rule selector style) - (..alter combinator selector inner))) - - (template [<name> <combinator>] - [(def: #export <name> - (-> (Selector Any) Style (CSS Common) (CSS Common)) - (..dependent <combinator>))] - - [with-descendants /selector.in] - [with-children /selector.sub] - ) - ) diff --git a/stdlib/source/lux/data/format/css/font.lux b/stdlib/source/lux/data/format/css/font.lux deleted file mode 100644 index b809f45e6..000000000 --- a/stdlib/source/lux/data/format/css/font.lux +++ /dev/null @@ -1,25 +0,0 @@ -(.module: - [lux #* - [type - abstract] - [control - [parser - ["s" code]]] - ["." macro - [syntax (#+ syntax:)]] - [world - [net (#+ URL)]]] - ["." // #_ - ["#." value (#+ Value Font-Stretch Font-Style Font-Weight)]]) - -(type: #export Unicode-Range - {#start Nat - #end Nat}) - -(type: #export Font - {#family Text - #source URL - #stretch (Maybe (Value Font-Stretch)) - #style (Maybe (Value Font-Style)) - #weight (Maybe (Value Font-Weight)) - #unicode-range (Maybe Unicode-Range)}) diff --git a/stdlib/source/lux/data/format/css/property.lux b/stdlib/source/lux/data/format/css/property.lux deleted file mode 100644 index bbfdd1930..000000000 --- a/stdlib/source/lux/data/format/css/property.lux +++ /dev/null @@ -1,502 +0,0 @@ -(.module: - [lux (#- All Cursor) - [control - [parser - ["s" code]]] - [type - abstract] - [macro - ["." template] - ["." code] - [syntax (#+ syntax:)]]] - [// - [value (#+ All - Number - Length Thickness Time - Color - Location Fit - Slice - Alignment Animation-Direction - Animation Animation-Fill - Column-Fill Column-Span - Iteration Count - Play - Timing Visibility Attachment - Blend Span Image - Angle Repeat Border - Collapse Box-Decoration-Break Caption - Float Clear - Content - Cursor - Shadow Clip - Text-Direction - Display Empty - Filter - Flex-Direction Flex-Wrap - Font Font-Kerning Font-Size Font-Variant - Grid Grid-Content Grid-Flow Grid-Span Grid-Template - Hanging-Punctuation Hyphens Isolation - List-Style-Position List-Style-Type - Overflow Page-Break Pointer-Events - Position - Quotes - Resize Scroll-Behavior Table-Layout - Text-Align Text-Align-Last - Text-Decoration-Line Text-Decoration-Style - Text-Justification Text-Overflow Text-Transform - Transform Transform-Origin Transform-Style - Transition - Bidi User-Select - Vertical-Align - White-Space Word-Break Word-Wrap Writing-Mode - Z-Index)]]) - -(syntax: (text-identifier {identifier s.text}) - (wrap (list (code.local-identifier identifier)))) - -(abstract: #export (Property brand) - Text - - (def: #export name - (-> (Property Any) Text) - (|>> :representation)) - - (template [<brand> <alias>+ <property>+] - [(`` (template [<alias> <property>] - [(def: #export <alias> - (Property <brand>) - (:abstraction <property>))] - - (~~ (template.splice <alias>+)))) - - (with-expansions [<rows> (template.splice <property>+)] - (template [<property>] - [(`` (def: #export (~~ (text-identifier <property>)) - (Property <brand>) - (:abstraction <property>)))] - - <rows>))] - - [All - [] - [["all"]]] - - [Length - [] - [["border-image-outset"] - ["border-image-width"] - ["bottom"] - ["column-gap"] - ["column-width"] - ["flex-basis"] - ["grid-column-gap"] - ["grid-gap"] - ["grid-row-gap"] - ["height"] - ["left"] - ["letter-spacing"] - ["line-height"] - ["margin"] - ["margin-bottom"] - ["margin-left"] - ["margin-right"] - ["margin-top"] - ["max-height"] - ["max-width"] - ["min-height"] - ["min-width"] - ["outline-offset"] - ["padding"] - ["padding-bottom"] - ["padding-left"] - ["padding-right"] - ["padding-top"] - ["perspective"] - ["right"] - ["text-indent"] - ["top"] - ["width"] - ["word-spacing"]]] - - [Time - [] - [["animation-delay"] - ["animation-duration"] - ["transition-delay"] - ["transition-duration"]]] - - [Slice - [] - [["border-image-slice"]]] - - [Color - [[text-color "color"]] - [["background-color"] - ["border-color"] - ["border-bottom-color"] - ["border-left-color"] - ["border-right-color"] - ["border-top-color"] - ["caret-color"] - ["column-rule-color"] - ["outline-color"] - ["text-decoration-color"]]] - - [Alignment - [] - [["align-content"] - ["align-items"] - ["align-self"] - ["justify-content"]]] - - [Animation - [] - [["animation-name"]]] - - [Animation-Direction - [] - [["animation-direction"]]] - - [Animation-Fill - [] - [["animation-fill-mode"]]] - - [Column-Fill - [] - [["column-fill"]]] - - [Column-Span - [] - [["column-span"]]] - - [Iteration - [] - [["animation-iteration-count"]]] - - [Count - [] - [["column-count"] - ["flex-grow"] - ["flex-shrink"] - ["order"] - ["tab-size"]]] - - [Play - [] - [["animation-play-state"]]] - - [Timing - [] - [["animation-timing-function"] - ["transition-timing-function"]]] - - [Visibility - [] - [["backface-visibility"] - ["visibility"]]] - - [Attachment - [] - [["background-attachment"]]] - - [Blend - [] - [["background-blend-mode"] - ["mix-blend-mode"]]] - - [Image - [] - [["background-image"] - ["border-image-source"] - ["list-style-image"]]] - - [Span - [] - [["background-clip"] - ["background-origin"] - ["box-sizing"]]] - - [Location - [] - [["background-position"] - ["object-position"] - ["perspective-origin"]]] - - [Repeat - [] - [["background-repeat"] - ["border-image-repeat"]]] - - [Fit - [] - [["background-size"] - ["border-radius"] - ["border-bottom-left-radius"] - ["border-bottom-right-radius"] - ["border-top-left-radius"] - ["border-top-right-radius"] - ["border-spacing"] - ["object-fit"]]] - - [Border - [] - [["border-style"] - ["border-bottom-style"] - ["border-left-style"] - ["border-right-style"] - ["border-top-style"] - ["column-rule-style"] - ["outline-style"]]] - - [Thickness - [] - [["border-width"] - ["border-bottom-width"] - ["border-left-width"] - ["border-right-width"] - ["border-top-width"] - ["column-rule-width"] - ["outline-width"]]] - - [Collapse - [] - [["border-collapse"]]] - - [Box-Decoration-Break - [] - [["box-decoration-break"]]] - - [Caption - [] - [["caption-side"]]] - - [Clear - [] - [["clear"]]] - - [Shadow - [] - [["box-shadow"] - ["text-shadow"]]] - - [Clip - [] - [["clip"]]] - - [Content - [] - [["counter-reset"] - ["counter-increment"]]] - - [Cursor - [] - [["cursor"]]] - - [Text-Direction - [[text-direction "direction"]] - []] - - [Display - [] - [["display"]]] - - [Empty - [] - [["empty-cells"]]] - - [Filter - [] - [["filter"]]] - - [Flex-Direction - [] - [["flex-direction"]]] - - [Flex-Wrap - [] - [["flex-wrap"]]] - - [Float - [] - [["float"]]] - - [Font - [] - [["font-family"]]] - - [Font-Kerning - [] - [["font-kerning"]]] - - [Font-Size - [] - [["font-size"]]] - - [Number - [] - [["font-size-adjust"] - ["opacity"]]] - - [Font-Variant - [] - [["font-variant"]]] - - [Grid - [] - [["grid-area"]]] - - [Grid-Content - [] - [["grid-auto-columns"] - ["grid-auto-rows"] - ["grid-template-columns"] - ["grid-template-rows"]]] - - [Grid-Flow - [] - [["grid-auto-flow"]]] - - [Grid-Span - [] - [["grid-column-end"] - ["grid-column-start"] - ["grid-row-end"] - ["grid-row-start"]]] - - [Grid-Template - [] - [["grid-template-areas"]]] - - [Hanging-Punctuation - [] - [["hanging-punctuation"]]] - - [Hyphens - [] - [["hyphens"]]] - - [Isolation - [] - [["isolation"]]] - - [List-Style-Position - [] - [["list-style-position"]]] - - [List-Style-Type - [] - [["list-style-type"]]] - - [Overflow - [] - [["overflow"] - ["overflow-x"] - ["overflow-y"]]] - - [Page-Break - [] - [["page-break-after"] - ["page-break-before"] - ["page-break-inside"]]] - - [Pointer-Events - [] - [["pointer-events"]]] - - [Position - [] - [["position"]]] - - [Quotes - [] - [["quotes"]]] - - [Resize - [] - [["resize"]]] - - [Scroll-Behavior - [] - [["scroll-behavior"]]] - - [Table-Layout - [] - [["table-layout"]]] - - [Text-Align - [] - [["text-align"]]] - - [Text-Align-Last - [] - [["text-align-last"]]] - - [Text-Decoration-Line - [] - [["text-decoration-line"]]] - - [Text-Decoration-Style - [] - [["text-decoration-style"]]] - - [Text-Justification - [] - [["text-justify"]]] - - [Text-Overflow - [] - [["text-overflow"]]] - - [Text-Transform - [] - [["text-transform"]]] - - [Transform - [] - [["transform"]]] - - [Transform-Origin - [] - [["transform-origin"]]] - - [Transform-Style - [] - [["transform-style"]]] - - [Transition - [] - [["transition-property"]]] - - [Bidi - [] - [["unicode-bidi"]]] - - [User-Select - [] - [["user-select"]]] - - [Vertical-Align - [] - [["vertical-align"]]] - - [White-Space - [] - [["white-space"]]] - - [Word-Break - [] - [["word-break"]]] - - [Word-Wrap - [] - [["word-wrap"]]] - - [Writing-Mode - [] - [["writing-mode"]]] - - [Z-Index - [] - [["z-index"]]] - ) - ) diff --git a/stdlib/source/lux/data/format/css/query.lux b/stdlib/source/lux/data/format/css/query.lux deleted file mode 100644 index 6b1e57554..000000000 --- a/stdlib/source/lux/data/format/css/query.lux +++ /dev/null @@ -1,134 +0,0 @@ -(.module: - [lux (#- and or not) - [control - [parser - ["s" code]]] - [data - [text - ["%" format (#+ format)]]] - [macro - ["." template] - ["." code] - [syntax (#+ syntax:)]] - [type - abstract]] - ["." // #_ - ["#." value (#+ Value Length Count Resolution Ratio - Orientation Scan Boolean Update - Block-Overflow Inline-Overflow - Display-Mode Color-Gamut Inverted-Colors - Pointer Hover - Light Scripting Motion Color-Scheme)]]) - -(syntax: (text-identifier {identifier s.text}) - (wrap (list (code.local-identifier identifier)))) - -(abstract: #export Media - Text - - (def: #export media - (-> Media Text) - (|>> :representation)) - - (template [<media>] - [(`` (def: #export (~~ (text-identifier <media>)) - Media - (:abstraction <media>)))] - - ["all"] - ["print"] - ["screen"] - ["speech"] - )) - -(abstract: #export Feature - Text - - (def: #export feature - (-> Feature Text) - (|>> :representation)) - - (template [<feature> <brand>] - [(`` (def: #export ((~~ (text-identifier <feature>)) input) - (-> (Value <brand>) Feature) - (:abstraction (format "(" <feature> ": " (//value.value input) ")"))))] - - ["min-color" Count] - ["color" Count] - ["max-color" Count] - - ["min-color-index" Count] - ["color-index" Count] - ["max-color-index" Count] - - ["min-monochrome" Count] - ["monochrome" Count] - ["max-monochrome" Count] - - ["min-height" Length] - ["height" Length] - ["max-height" Length] - - ["min-width" Length] - ["width" Length] - ["max-width" Length] - - ["min-resolution" Resolution] - ["resolution" Resolution] - ["max-resolution" Resolution] - - ["aspect-ratio" Ratio] - ["max-aspect-ratio" Ratio] - ["min-aspect-ratio" Ratio] - - ["display-mode" Display-Mode] - ["color-gamut" Color-Gamut] - ["grid" Boolean] - ["orientation" Orientation] - ["overflow-block" Block-Overflow] - ["overflow-inline" Inline-Overflow] - ["scan" Scan] - ["update" Update] - ["inverted-colors" Inverted-Colors] - ["pointer" Pointer] - ["any-pointer" Pointer] - ["hover" Hover] - ["any-hover" Hover] - ["light-level" Light] - ["scripting" Scripting] - ["prefers-reduced-motion" Motion] - ["prefers-color-scheme" Color-Scheme] - ) - ) - -(abstract: #export Query - Text - - (def: #export query - (-> Query Text) - (|>> :representation)) - - (template [<name> <operator>] - [(def: #export <name> - (-> Media Query) - (|>> ..media (format <operator>) :abstraction))] - - [except "not "] - [only "only "] - ) - - (def: #export not - (-> Feature Query) - (|>> ..feature (format "not ") :abstraction)) - - (template [<name> <operator>] - [(def: #export (<name> left right) - (-> Query Query Query) - (:abstraction (format (:representation left) - <operator> - (:representation right))))] - - [and " and "] - [or " or "] - ) - ) diff --git a/stdlib/source/lux/data/format/css/selector.lux b/stdlib/source/lux/data/format/css/selector.lux deleted file mode 100644 index 1c0f4b566..000000000 --- a/stdlib/source/lux/data/format/css/selector.lux +++ /dev/null @@ -1,204 +0,0 @@ -(.module: - [lux (#- or and for is? not) - [data - ["." text - ["%" format (#+ format)]] - [number - ["i" int]]] - [type - abstract] - [macro - ["." template]] - ["." locale (#+ Locale)]]) - -(type: #export Label Text) - -(type: #export Tag Label) -(type: #export ID Label) -(type: #export Class Label) -(type: #export Attribute Label) - -(abstract: #export (Generic brand) Any) - -(template [<generic> <brand>] - [(abstract: <brand> Any) - (type: #export <generic> (Generic <brand>))] - - [Can-Chain Can-Chain'] - [Cannot-Chain Cannot-Chain'] - ) - -(abstract: #export Unique Any) -(abstract: #export Specific Any) -(abstract: #export Composite Any) - -(abstract: #export (Selector kind) - Text - - (def: #export selector - (-> (Selector Any) Text) - (|>> :representation)) - - (def: #export any - (Selector Cannot-Chain) - (:abstraction "*")) - - (def: #export tag - (-> Tag (Selector Cannot-Chain)) - (|>> :abstraction)) - - (template [<name> <type> <prefix> <kind>] - [(def: #export <name> - (-> <type> (Selector <kind>)) - (|>> (format <prefix>) :abstraction))] - - [id ID "#" Unique] - [class Class "." Can-Chain] - ) - - (template [<right> <left> <combo> <combinator>+] - [(`` (template [<combinator> <name>] - [(def: #export (<name> right left) - (-> (Selector <right>) (Selector <left>) (Selector <combo>)) - (:abstraction (format (:representation left) - <combinator> - (:representation right))))] - - (~~ (template.splice <combinator>+))))] - - [Can-Chain (Generic Any) Can-Chain - [["" and]]] - [Unique (Generic Any) Composite - [["" for]]] - [Specific (Generic Any) Composite - [["" at]]] - [Any Any Composite - [["," or] - [" " in] - [">" sub] - ["+" next] - ["~" later]]] - ) - - (type: #export Combinator - (-> (Selector Any) (Selector Any) (Selector Composite))) - - (def: #export (with? attribute) - (-> Attribute (Selector Can-Chain)) - (:abstraction (format "[" attribute "]"))) - - (template [<check> <name>] - [(def: #export (<name> attribute value) - (-> Attribute Text (Selector Can-Chain)) - (:abstraction (format "[" attribute <check> value "]")))] - - ["=" is?] - ["~=" has?] - ["|=" has-start?] - ["^=" starts?] - ["$=" ends?] - ["*=" contains?] - ) - - (template [<kind> <pseudo>+] - [(`` (template [<name> <pseudo>] - [(def: #export <name> - (Selector Can-Chain) - (:abstraction <pseudo>))] - - (~~ (template.splice <pseudo>+))))] - - [Can-Chain - [[active ":active"] - [checked ":checked"] - [default ":default"] - [disabled ":disabled"] - [empty ":empty"] - [enabled ":enabled"] - [first-child ":first-child"] - [first-of-type ":first-of-type"] - [focused ":focus"] - [hovered ":hover"] - [in-range ":in-range"] - [indeterminate ":indeterminate"] - [invalid ":invalid"] - [last-child ":last-child"] - [last-of-type ":last-of-type"] - [link ":link"] - [only-of-type ":only-of-type"] - [only-child ":only-child"] - [optional ":optional"] - [out-of-range ":out-of-range"] - [read-only ":read-only"] - [read-write ":read-write"] - [required ":required"] - [root ":root"] - [target ":target"] - [valid ":valid"] - [visited ":visited"]]] - - [Specific - [[after "::after"] - [before "::before"] - [first-letter "::first-letter"] - [first-line "::first-line"] - [placeholder "::placeholder"] - [selection "::selection"]]] - ) - - (def: #export (language locale) - (-> Locale (Selector Can-Chain)) - (|> locale - locale.code - (text.enclose ["(" ")"]) - (format ":lang") - :abstraction)) - - (def: #export not - (-> (Selector Any) (Selector Can-Chain)) - (|>> :representation - (text.enclose ["(" ")"]) - (format ":not") - :abstraction)) - - (abstract: #export Index - Text - - (def: #export index - (-> Nat Index) - (|>> %.nat :abstraction)) - - (template [<name> <index>] - [(def: #export <name> Index (:abstraction <index>))] - - [odd "odd"] - [even "even"] - ) - - (type: #export Formula - {#constant Int - #variable Int}) - - (def: #export (formula input) - (-> Formula Index) - (let [(^slots [#constant #variable]) input] - (:abstraction (format (if (i.< +0 variable) - (%.int variable) - (%.nat (.nat variable))) - (%.int constant))))) - - (template [<name> <pseudo>] - [(def: #export (<name> index) - (-> Index (Selector Can-Chain)) - (|> (:representation index) - (text.enclose ["(" ")"]) - (format <pseudo>) - (:abstraction Selector)))] - - [nth-child ":nth-child"] - [nth-last-child ":nth-last-child"] - [nth-last-of-type ":nth-last-of-type"] - [nth-of-type ":nth-of-type"] - ) - ) - ) diff --git a/stdlib/source/lux/data/format/css/style.lux b/stdlib/source/lux/data/format/css/style.lux deleted file mode 100644 index 487ad5e9d..000000000 --- a/stdlib/source/lux/data/format/css/style.lux +++ /dev/null @@ -1,35 +0,0 @@ -(.module: - [lux #* - [data - [text - ["%" format (#+ format)]]] - [type - abstract]] - ["." // #_ - ["#." value (#+ Value)] - ["#." property (#+ Property)]]) - -(abstract: #export Style - Text - - {#.doc "The style associated with a CSS selector."} - - (def: #export empty - Style - (:abstraction "")) - - (def: #export separator - " ") - - (def: #export (with [property value]) - (All [brand] - (-> [(Property brand) (Value brand)] - (-> Style Style))) - (|>> :representation - (format (//property.name property) ": " (//value.value value) ";" ..separator) - :abstraction)) - - (def: #export inline - (-> Style Text) - (|>> :representation)) - ) diff --git a/stdlib/source/lux/data/format/css/value.lux b/stdlib/source/lux/data/format/css/value.lux deleted file mode 100644 index 3691bb2e4..000000000 --- a/stdlib/source/lux/data/format/css/value.lux +++ /dev/null @@ -1,1328 +0,0 @@ -(.module: - [lux (#- All Cursor and static false true) - [control - [parser - ["s" code]]] - [data - ["." color] - ["." product] - ["." maybe] - [number - ["n" nat] - ["i" int] - ["r" rev] - ["f" frac]] - ["." text - ["%" format (#+ Format format)]] - [collection - ["." list ("#\." functor)]]] - [type - abstract] - [macro - ["." template] - ["." code] - [syntax (#+ syntax:)]] - [world - [net (#+ URL)]]] - [// - [selector (#+ Label)]]) - -(syntax: (text-identifier {identifier s.text}) - (wrap (list (code.local-identifier identifier)))) - -(template: (enumeration: <abstraction> <representation> <out> <sample>+ <definition>+) - (abstract: #export <abstraction> - <representation> - - (def: #export <out> - (-> <abstraction> <representation>) - (|>> :representation)) - - (`` (template [<name> <value>] - [(def: #export <name> <abstraction> (:abstraction <value>))] - - (~~ (template.splice <sample>+)) - )) - - (template.splice <definition>+))) - -(template: (multi: <multi> <type> <separator>) - (def: #export (<multi> pre post) - (-> (Value <type>) (Value <type>) (Value <type>)) - (:abstraction (format (:representation pre) - <separator> - (:representation post))))) - -(def: (%number value) - (Format Frac) - (let [raw (%.frac value)] - (if (f.< +0.0 value) - raw - (|> raw (text.split 1) maybe.assume product.right)))) - -(abstract: #export (Value brand) - Text - - (def: #export value - (-> (Value Any) Text) - (|>> :representation)) - - (template [<name> <value>] - [(def: #export <name> Value (:abstraction <value>))] - - [initial "initial"] - [inherit "inherit"] - [unset "unset"] - ) - - (template [<brand> <alias>+ <value>+] - [(abstract: #export <brand> Any) - - (`` (template [<name> <value>] - [(def: #export <name> - (Value <brand>) - (:abstraction <value>))] - - (~~ (template.splice <alias>+)))) - - (with-expansions [<rows> (template.splice <value>+)] - (template [<value>] - [(`` (def: #export (~~ (text-identifier <value>)) - (Value <brand>) - (:abstraction <value>)))] - - <rows>))] - - [All - [] - []] - - [Number - [] - []] - - [Length - [] - []] - - [Time - [] - []] - - [Thickness - [] - [["medium"] - ["thin"] - ["thick"]]] - - [Slice - [[full-slice "fill"]] - []] - - [Alignment - [[auto-alignment "auto"]] - [["stretch"] - ["center"] - ["flex-start"] - ["flex-end"] - ["baseline"] - ["space-between"] - ["space-around"]]] - - [Animation - [] - []] - - [Animation-Direction - [[normal-direction "normal"]] - [["reverse"] - ["alternate"] - ["alternate-reverse"]]] - - [Animation-Fill - [[fill-forwards "forwards"] - [fill-backwards "backwards"] - [fill-both "both"]] - []] - - [Column-Fill - [] - [["balance"] - ["auto"]]] - - [Column-Span - [] - [["all"]]] - - [Iteration - [] - [["infinite"]]] - - [Count - [] - []] - - [Play - [] - [["paused"] - ["running"]]] - - [Timing - [] - [["linear"] - ["ease"] - ["ease-in"] - ["ease-out"] - ["ease-in-out"] - ["step-start"] - ["step-end"]]] - - [Visibility - [[invisible "hidden"] - [collapse-visibility "collapse"]] - [["visible"]]] - - [Attachment - [[scroll-attachment "scroll"] - [fixed-attachment "fixed"] - [local-attachment "local"]] - []] - - [Blend - [[normal-blend "normal"]] - [["multiply"] - ["screen"] - ["overlay"] - ["darken"] - ["lighten"] - ["color-dodge"] - ["color-burn"] - ["difference"] - ["exclusion"] - ["hue"] - ["saturation"] - ["color"] - ["luminosity"]]] - - [Span - [] - [["border-box"] - ["padding-box"] - ["content-box"]]] - - [Image - [[no-image "none"]] - []] - - [Repeat - [[stretch-repeat "stretch"]] - [["repeat"] - ["repeat-x"] - ["repeat-y"] - ["no-repeat"] - ["space"] - ["round"]]] - - [Location - [[left-top "left top"] - [left-center "left center"] - [left-bottom "left bottom"] - [right-top "right top"] - [right-center "right center"] - [right-bottom "right bottom"] - [center-top "center top"] - [center-center "center center"] - [center-bottom "center bottom"]] - []] - - [Fit - [[no-fit "none"]] - [["fill"] - ["cover"] - ["contain"] - ["scale-down"]]] - - [Border - [] - [["hidden"] - ["dotted"] - ["dashed"] - ["solid"] - ["double"] - ["groove"] - ["ridge"] - ["inset"] - ["outset"]]] - - [Collapse - [] - [["separate"] - ["collapse"]]] - - [Box-Decoration-Break - [] - [["slice"] - ["clone"]]] - - [Caption - [] - [["top"] - ["bottom"]]] - - [Float - [[float-left "left"] - [float-right "right"]] - []] - - [Clear - [[clear-left "left"] - [clear-right "right"] - [clear-both "both"]] - []] - - [Counter - [] - []] - - [Content - [] - [["open-quote"] - ["close-quote"] - ["no-open-quote"] - ["no-close-quote"]]] - - [Cursor - [[horizontal-text "text"] - [no-cursor "none"]] - [["alias"] - ["all-scroll"] - ["cell"] - ["context-menu"] - ["col-resize"] - ["copy"] - ["crosshair"] - ["default"] - ["e-resize"] - ["ew-resize"] - ["grab"] - ["grabbing"] - ["help"] - ["move"] - ["n-resize"] - ["ne-resize"] - ["nesw-resize"] - ["ns-resize"] - ["nw-resize"] - ["nwse-resize"] - ["no-drop"] - ["not-allowed"] - ["pointer"] - ["progress"] - ["row-resize"] - ["s-resize"] - ["se-resize"] - ["sw-resize"] - ["vertical-text"] - ["w-resize"] - ["wait"] - ["zoom-in"] - ["zoom-out"]]] - - [Shadow - [] - []] - - [Clip - [] - []] - - [Text-Direction - [[left-to-right "ltr"] - [right-to-left "rtl"]] - []] - - [Display - [[grid-display "grid"] - [no-display "none"]] - [["inline"] - ["block"] - ["contents"] - ["flex"] - ["inline-block"] - ["inline-flex"] - ["inline-grid"] - ["inline-table"] - ["list-item"] - ["run-in"] - ["table"] - ["table-caption"] - ["table-column-group"] - ["table-header-group"] - ["table-footer-group"] - ["table-row-group"] - ["table-cell"] - ["table-column"] - ["table-row"]]] - - [Empty - [] - [["show"] - ["hide"]]] - - [Filter - [] - []] - - [Flex-Direction - [] - [["row"] - ["row-reverse"] - ["column"] - ["column-reverse"]]] - - [Flex-Wrap - [[no-wrap "nowrap"]] - [["wrap"] - ["wrap-reverse"]]] - - [Font-Kerning - [[auto-kerning "auto"] - [normal-kerning "normal"] - [no-kerning "none"]] - []] - - [Font-Size - [[medium-size "medium"] - [xx-small-size "xx-small"] - [x-small-size "x-small"] - [small-size "small"] - [large-size "large"] - [x-large-size "x-large"] - [xx-large-size "xx-large"] - [smaller-size "smaller"] - [larger-size "larger"]] - []] - - [Font-Stretch - [[normal-stretch "normal"]] - [["condensed"] - ["ultra-condensed"] - ["extra-condensed"] - ["semi-condensed"] - ["expanded"] - ["semi-expanded"] - ["extra-expanded"] - ["ultra-expanded"]]] - - [Font-Style - [[normal-style "normal"]] - [["italic"] - ["oblique"]]] - - [Font-Weight - [[normal-weight "normal"] - [weight-100 "100"] - [weight-200 "200"] - [weight-300 "300"] - [weight-400 "400"] - [weight-500 "500"] - [weight-600 "600"] - [weight-700 "700"] - [weight-800 "800"] - [weight-900 "900"]] - [["bold"]]] - - [Font-Variant - [[normal-font "normal"]] - [["small-caps"]]] - - [Grid - [] - []] - - [Grid-Content - [[auto-content "auto"]] - [["max-content"] - ["min-content"]]] - - [Grid-Flow - [[row-flow "row"] - [column-flow "column"] - [dense-flow "dense"] - [row-dense-flow "row dense"] - [column-dense-flow "column dense"]] - []] - - [Grid-Span - [[auto-span "auto"]] - []] - - [Grid-Template - [] - []] - - [Hanging-Punctuation - [[no-hanging-punctuation "none"]] - [["first"] - ["last"] - ["allow-end"] - ["force-end"]]] - - [Hyphens - [[no-hyphens "none"] - [manual-hyphens "manual"] - [auto-hyphens "auto"]] - []] - - [Orientation - [] - [["portrait"] - ["landscape"]]] - - [Resolution - [] - []] - - [Scan - [] - [["interlace"] - ["progressive"]]] - - [Boolean - [[false "0"] - [true "1"]] - []] - - [Update - [[no-update "none"] - [slow-update "slow"] - [fast-update "fast"]] - []] - - [Block-Overflow - [[no-block-overflow "none"] - [scroll-block-overflow "scroll"] - [optional-paged-block-overflow "optional-paged"] - [paged-block-overflow "paged"]] - []] - - [Inline-Overflow - [[no-inline-overflow "none"] - [scroll-inline-overflow "scroll"]] - []] - - [Display-Mode - [] - [["fullscreen"] - ["standalone"] - ["minimal-ui"] - ["browser"]]] - - [Color-Gamut - [] - [["srgb"] - ["p3"] - ["rec2020"]]] - - [Inverted-Colors - [[no-inverted-colors "none"] - [inverted-colors "inverted"]] - []] - - [Pointer - [[no-pointer "none"] - [coarse-pointer "coarse"] - [fine-pointer "fine"]] - []] - - [Hover - [[no-hover "none"]] - [["hover"]]] - - [Light - [[dim-light "dim"] - [normal-light "normal"] - [washed-light "washed"]] - []] - - [Ratio - [] - []] - - [Scripting - [[no-scripting "none"] - [initial-scripting-only "initial-only"] - [scripting-enabled "enabled"]] - []] - - [Motion - [[no-motion-preference "no-preference"] - [reduced-motion "reduce"]] - []] - - [Color-Scheme - [[no-color-scheme-preference "no-preference"] - [light-color-scheme "light"] - [dark-color-scheme "dark"]] - []] - - [Isolation - [[auto-isolation "auto"]] - [["isolate"]]] - - [List-Style-Position - [] - [["inside"] - ["outside"]]] - - [List-Style-Type - [[no-list-style "none"]] - [["disc"] - ["armenian"] - ["circle"] - ["cjk-ideographic"] - ["decimal"] - ["decimal-leading-zero"] - ["georgian"] - ["hebrew"] - ["hiragana"] - ["hiragana-iroha"] - ["katakana"] - ["katakana-iroha"] - ["lower-alpha"] - ["lower-greek"] - ["lower-latin"] - ["lower-roman"] - ["square"] - ["upper-alpha"] - ["upper-greek"] - ["upper-latin"] - ["upper-roman"]]] - - [Color - [] - []] - - [Overflow - [[visible-overflow "visible"] - [hidden-overflow "hidden"] - [scroll-overflow "scroll"] - [auto-overflow "auto"]] - []] - - [Page-Break - [[auto-page-break "auto"] - [always-page-break "always"] - [avoid-page-break "avoid"] - [left-page-break "left"] - [right-page-break "right"]] - []] - - [Pointer-Events - [[auto-pointer-events "auto"] - [no-pointer-events "none"]] - []] - - [Position - [] - [["static"] - ["absolute"] - ["fixed"] - ["relative"] - ["sticky"]]] - - [Quotes - [[no-quotes "none"]] - []] - - [Resize - [[resize-none "none"] - [resize-both "both"] - [resize-horizontal "horizontal"] - [resize-vertical "vertical"]] - []] - - [Scroll-Behavior - [[auto-scroll-behavior "auto"] - [smooth-scroll-behavior "smooth"]] - []] - - [Table-Layout - [[auto-table-layout "auto"] - [fixed-table-layout "fixed"]] - []] - - [Text-Align - [[left-text-align "left"] - [right-text-align "right"] - [center-text-align "center"] - [justify-text-align "justify"]] - []] - - [Text-Align-Last - [[auto-text-align-last "auto"] - [left-text-align-last "left"] - [right-text-align-last "right"] - [center-text-align-last "center"] - [justify-text-align-last "justify"] - [start-text-align-last "start"] - [end-text-align-last "end"]] - []] - - [Text-Decoration-Line - [[no-text-decoration-line "none"] - [underline-text-decoration-line "underline"] - [overline-text-decoration-line "overline"] - [line-through-text-decoration-line "line-through"]] - []] - - [Text-Decoration-Style - [[solid-text-decoration-style "solid"] - [double-text-decoration-style "double"] - [dotted-text-decoration-style "dotted"] - [dashed-text-decoration-style "dashed"] - [wavy-text-decoration-style "wavy"]] - []] - - [Text-Justification - [[auto-text-justification "auto"] - [inter-word-text-justification "inter-word"] - [inter-character-text-justification "inter-character"] - [no-text-justification "none"]] - []] - - [Text-Overflow - [[clip-text-overflow "clip"] - [ellipsis-text-overflow "ellipsis"]] - []] - - [Text-Transform - [[no-text-transform "none"]] - [["capitalize"] - ["uppercase"] - ["lowercase"]]] - - [Transform - [[no-transform "none"]] - []] - - [Transform-Origin - [] - []] - - [Transform-Style - [] - [["flat"] - ["preserve-3d"]]] - - [Transition - [[transition-none "none"] - [transition-all "all"]] - []] - - [Bidi - [[bidi-normal "normal"] - [bidi-embed "embed"] - [bidi-isolate "isolate"] - [bidi-isolate-override "isolate-override"] - [bidi-plaintext "plaintext"]] - [["bidi-override"]]] - - [User-Select - [[user-select-auto "auto"] - [user-select-none "none"] - [user-select-text "text"] - [user-select-all "all"]] - []] - - [Vertical-Align - [[vertical-align-baseline "baseline"] - [vertical-align-sub "sub"] - [vertical-align-super "super"] - [vertical-align-top "top"] - [vertical-align-text-top "text-top"] - [vertical-align-middle "middle"] - [vertical-align-bottom "bottom"] - [vertical-align-text-bottom "text-bottom"]] - []] - - [White-Space - [[normal-white-space "normal"] - [no-wrap-white-space "nowrap"] - [pre-white-space "pre"] - [pre-line-white-space "pre-line"] - [pre-wrap-white-space "pre-wrap"]] - []] - - [Word-Break - [[normal-word-break "normal"]] - [["break-all"] - ["keep-all"] - ["break-word"]]] - - [Word-Wrap - [[normal-word-wrap "normal"] - [break-word-word-wrap "break-word"]] - []] - - [Writing-Mode - [[top-to-bottom-writing-mode "horizontal-tb"] - [left-to-right-writing-mode "vertical-rl"] - [right-to-left-writing-mode "vertical-lr"]] - []] - - [Z-Index - [] - []] - ) - - (def: value-separator ",") - - (def: (apply name inputs) - (-> Text (List Text) Value) - (|> inputs - (text.join-with ..value-separator) - (text.enclose ["(" ")"]) - (format name) - :abstraction)) - - (enumeration: Step Text - step - [[start "start"] - [end "end"]] - []) - - (def: #export (steps intervals step) - (-> Nat Step (Value Timing)) - (..apply "steps" (list (%.nat intervals) (..step step)))) - - (def: #export (cubic-bezier p0 p1 p2 p3) - (-> Frac Frac Frac Frac (Value Timing)) - (|> (list p0 p1 p2 p3) - (list\map %number) - (..apply "cubic-bezier"))) - - (template [<name> <brand>] - [(def: #export <name> - (-> Nat (Value <brand>)) - (|>> %.nat :abstraction))] - - [iteration Iteration] - [count Count] - [slice-number/1 Slice] - [span-line Grid-Span] - ) - - (def: #export animation - (-> Label (Value Animation)) - (|>> :abstraction)) - - (def: #export (rgb color) - (-> color.Color (Value Color)) - (let [[red green blue] (color.to-rgb color)] - (..apply "rgb" (list (%.nat red) - (%.nat green) - (%.nat blue))))) - - (def: #export (rgba pigment) - (-> color.Pigment (Value Color)) - (let [(^slots [#color.color #color.alpha]) pigment - [red green blue] (color.to-rgb color)] - (..apply "rgba" (list (%.nat red) - (%.nat green) - (%.nat blue) - (if (r.= (\ r.interval top) alpha) - "1.0" - (format "0" (%.rev alpha))))))) - - (template [<name> <suffix>] - [(def: #export (<name> value) - (-> Frac (Value Length)) - (:abstraction (format (%number value) <suffix>)))] - - [em "em"] - [ex "ex"] - [rem "rem"] - [ch "ch"] - [vw "vw"] - [vh "vh"] - [vmin "vmin"] - [vmax "vmax"] - [% "%"] - [cm "cm"] - [mm "mm"] - [in "in"] - [px "px"] - [pt "pt"] - [pc "pc"] - [fr "fr"] - ) - - (def: (%int value) - (Format Int) - (if (i.< +0 value) - (%.int value) - (%.nat (.nat value)))) - - (template [<name> <suffix>] - [(def: #export (<name> value) - (-> Int (Value Time)) - (:abstraction (format (if (i.< +0 value) - (%.int value) - (%.nat (.nat value))) - <suffix>)))] - - - [seconds "s"] - [milli-seconds "ms"] - ) - - (def: #export thickness - (-> (Value Length) (Value Thickness)) - (|>> :transmutation)) - - (def: slice-separator " ") - - (def: #export (slice-number/2 horizontal vertical) - (-> Nat Nat (Value Slice)) - (:abstraction (format (%.nat horizontal) ..slice-separator - (%.nat vertical)))) - - (abstract: #export Stop - Text - - (def: #export stop - (-> (Value Color) Stop) - (|>> (:representation Value) (:abstraction Stop))) - - (def: stop-separator " ") - - (def: #export (single-stop length color) - (-> (Value Length) (Value Color) Stop) - (:abstraction (format (:representation Value color) ..stop-separator - (:representation Value length)))) - - (def: #export (double-stop start end color) - (-> (Value Length) (Value Length) (Value Color) Stop) - (:abstraction (format (:representation Value color) ..stop-separator - (:representation Value start) ..stop-separator - (:representation Value end)))) - - (abstract: #export Hint - Text - - (def: #export hint - (-> (Value Length) Hint) - (|>> (:representation Value) (:abstraction Hint))) - - (def: (with-hint [hint stop]) - (-> [(Maybe Hint) Stop] Text) - (case hint - #.None - (:representation Stop stop) - - (#.Some hint) - (format (:representation Hint hint) ..value-separator (:representation Stop stop)))))) - - (type: #export (List/1 a) - [a (List a)]) - - (abstract: #export Angle - Text - - (def: #export angle - (-> Angle Text) - (|>> :representation)) - - (def: #export (turn value) - (-> Rev Angle) - (:abstraction (format (%.rev value) "turn"))) - - (def: degree-limit Nat 360) - - (def: #export (degree value) - (-> Nat Angle) - (:abstraction (format (%.nat (n.% ..degree-limit value)) "deg"))) - - (template [<degree> <name>] - [(def: #export <name> Angle (..degree <degree>))] - - [000 to-top] - [090 to-right] - [180 to-bottom] - [270 to-left] - ) - - (template [<name> <function>] - [(def: #export (<name> angle start next) - (-> Angle Stop (List/1 [(Maybe Hint) Stop]) (Value Image)) - (let [[now after] next] - (..apply <function> (list& (:representation Angle angle) - (with-hint now) - (list\map with-hint after)))))] - - [linear-gradient "linear-gradient"] - [repeating-linear-gradient "repeating-linear-gradient"] - ) - ) - - (abstract: #export Percentage - Text - - (def: #export percentage - (-> Percentage Text) - (|>> :representation)) - - (def: percentage-limit Nat (.inc 100)) - - (def: #export (%% value) - (-> Nat Percentage) - (:abstraction (format (%.nat (n.% percentage-limit value)) "%"))) - - (def: #export slice-percent/1 - (-> Percentage (Value Slice)) - (|>> :representation (:abstraction Value))) - - (def: #export (slice-percent/2 horizontal vertical) - (-> Percentage Percentage (Value Slice)) - (:abstraction Value (format (:representation horizontal) ..slice-separator - (:representation vertical)))) - - (template [<input> <pre> <function>+] - [(`` (template [<name> <function>] - [(def: #export <name> - (-> <input> (Value Filter)) - (|>> <pre> (list) (..apply <function>)))] - - (~~ (template.splice <function>+))))] - - [Nat (<| (:representation Value) ..px n.frac) - [[blur "blur"]]] - [Nat (<| ..angle ..degree) - [[hue-rotate "hue-rotate"]]] - [Percentage (:representation Percentage) - [[brightness "brightness"] - [contrast "contrast"] - [grayscale "grayscale"] - [invert "invert"] - [opacity "opacity"] - [saturate "saturate"] - [sepia "sepia"]]] - ) - ) - - (def: #export svg-filter - (-> URL (Value Filter)) - (|>> (list) (..apply "url"))) - - (def: default-shadow-length (px +0.0)) - - (def: #export (drop-shadow horizontal vertical blur spread color) - (-> (Value Length) (Value Length) - (Maybe (Value Length)) (Maybe (Value Length)) - (Value Color) - (Value Filter)) - (|> (list (:representation horizontal) - (:representation vertical) - (|> blur (maybe.default ..default-shadow-length) :representation) - (|> spread (maybe.default ..default-shadow-length) :representation) - (:representation color)) - (text.join-with " ") - (list) - (..apply "drop-shadow"))) - - (def: length-separator " ") - - (template [<name> <type>] - [(def: #export (<name> horizontal vertical) - (-> (Value Length) (Value Length) (Value <type>)) - (:abstraction (format (:representation horizontal) - ..length-separator - (:representation vertical))))] - - [location Location] - [fit Fit] - ) - - (def: #export (fit/1 length) - (-> (Value Length) (Value Fit)) - (..fit length length)) - - (def: #export image - (-> URL (Value Image)) - (|>> %.text - (list) - (..apply "url"))) - - (enumeration: Shape Text - shape - [[ellipse-shape "ellipse"] - [circle-shape "circle"]] - []) - - (enumeration: Extent Text - extent - [[closest-side "closest-side"] - [closest-corner "closest-corner"] - [farthest-side "farthest-side"] - [farthest-corner "farthest-corner"]] - []) - - (template [<name> <function>] - [(def: #export (<name> shape extent location start next) - (-> Shape (Maybe Extent) (Value Location) - Stop (List/1 [(Maybe Hint) Stop]) - (Value Image)) - (let [after-extent (format "at " (:representation location)) - with-extent (case extent - (#.Some extent) - (format (..extent extent) " " after-extent) - - #.None - after-extent) - where (format (..shape shape) " " with-extent) - [now after] next] - (..apply <function> (list& (..shape shape) - (with-hint now) - (list\map with-hint after)))))] - - [radial-gradient "radial-gradient"] - [repeating-radial-gradient "repeating-radial-gradient"] - ) - - (def: #export (shadow horizontal vertical blur spread color inset?) - (-> (Value Length) (Value Length) - (Maybe (Value Length)) (Maybe (Value Length)) - (Value Color) Bit - (Value Shadow)) - (let [with-inset (if inset? - (list "inset") - (list))] - (|> (list& (:representation horizontal) - (:representation vertical) - (|> blur (maybe.default ..default-shadow-length) :representation) - (|> spread (maybe.default ..default-shadow-length) :representation) - (:representation color) - with-inset) - (text.join-with " ") - :abstraction))) - - (type: #export Rectangle - {#top (Value Length) - #right (Value Length) - #bottom (Value Length) - #left (Value Length)}) - - (def: #export (clip rectangle) - (-> Rectangle (Value Clip)) - (`` (..apply "rect" (list (~~ (template [<side>] - [(:representation (get@ <side> rectangle))] - - [#top] [#right] [#bottom] [#left])))))) - - (def: #export counter - (-> Label (Value Counter)) - (|>> :abstraction)) - - (def: #export current-count - (-> (Value Counter) (Value Content)) - (|>> :representation (list) (..apply "counter"))) - - (def: #export text - (-> Text (Value Content)) - (|>> %.text :abstraction)) - - (def: #export attribute - (-> Label (Value Content)) - (|>> (list) (..apply "attr"))) - - (def: #export media - (-> URL (Value Content)) - (|>> (list) (..apply "url"))) - - (enumeration: Font Text - font-name - [[serif "serif"] - [sans-serif "sans-serif"] - [cursive "cursive"] - [fantasy "fantasy"] - [monospace "monospace"]] - [(def: #export font - (-> Text Font) - (|>> %.text :abstraction)) - - (def: #export (font-family options) - (-> (List Font) (Value Font)) - (case options - (#.Cons _) - (|> options - (list\map ..font-name) - (text.join-with ",") - (:abstraction Value)) - - #.Nil - ..initial))]) - - (def: #export font-size - (-> (Value Length) (Value Font-Size)) - (|>> :transmutation)) - - (def: #export number - (-> Frac (Value Number)) - (|>> %number :abstraction)) - - (def: #export grid - (-> Label (Value Grid)) - (|>> :abstraction)) - - (def: #export fit-content - (-> (Value Length) (Value Grid-Content)) - (|>> :representation (list) (..apply "fit-content"))) - - (def: #export (min-max min max) - (-> (Value Grid-Content) (Value Grid-Content) (Value Grid-Content)) - (..apply "minmax" (list (:representation min) - (:representation max)))) - - (def: #export grid-span - (-> Nat (Value Grid-Span)) - (|>> %.nat (format "span ") :abstraction)) - - (def: grid-column-separator " ") - (def: grid-row-separator " ") - - (def: #export grid-template - (-> (List (List (Maybe (Value Grid)))) (Value Grid-Template)) - (let [empty (: (Value Grid) - (:abstraction "."))] - (|>> (list\map (|>> (list\map (|>> (maybe.default empty) - :representation)) - (text.join-with ..grid-column-separator) - (text.enclose ["'" "'"]))) - (text.join-with ..grid-row-separator) - :abstraction))) - - (def: #export (resolution dpi) - (-> Nat (Value Resolution)) - (:abstraction (format (%.nat dpi) "dpi"))) - - (def: #export (ratio numerator denominator) - (-> Nat Nat (Value Ratio)) - (:abstraction (format (%.nat numerator) "/" (%.nat denominator)))) - - (enumeration: Quote Text - quote-text - [[double-quote "\0022"] - [single-quote "\0027"] - [single-left-angle-quote "\2039"] - [single-right-angle-quote "\203A"] - [double-left-angle-quote "\00AB"] - [double-right-angle-quote "\00BB"] - [single-left-quote "\2018"] - [single-right-quote "\2019"] - [double-left-quote "\201C"] - [double-right-quote "\201D"] - [low-double-quote "\201E"]] - [(def: #export quote - (-> Text Quote) - (|>> :abstraction))]) - - (def: quote-separator " ") - - (def: #export (quotes [left0 right0] [left1 right1]) - (-> [Quote Quote] [Quote Quote] (Value Quotes)) - (|> (list left0 right0 left1 right1) - (list\map (|>> ..quote-text %.text)) - (text.join-with ..quote-separator) - :abstraction)) - - (def: #export (matrix-2d [a b] [c d] [tx ty]) - (-> [Frac Frac] - [Frac Frac] - [Frac Frac] - (Value Transform)) - (|> (list a b c d tx ty) - (list\map %number) - (..apply "matrix"))) - - (def: #export (matrix-3d [a0 b0 c0 d0] [a1 b1 c1 d1] [a2 b2 c2 d2] [a3 b3 c3 d3]) - (-> [Frac Frac Frac Frac] - [Frac Frac Frac Frac] - [Frac Frac Frac Frac] - [Frac Frac Frac Frac] - (Value Transform)) - (|> (list a0 b0 c0 d0 a1 b1 c1 d1 a2 b2 c2 d2 a3 b3 c3 d3) - (list\map %number) - (..apply "matrix3d"))) - - (template [<name> <function> <input-types> <input-values>] - [(`` (def: #export (<name> [(~~ (template.splice <input-values>))]) - (-> [(~~ (template.splice <input-types>))] (Value Transform)) - (|> (list (~~ (template.splice <input-values>))) - (list\map %number) - (..apply <function>))))] - - [translate-2d "translate" [Frac Frac] [x y]] - [translate-3d "translate3d" [Frac Frac Frac] [x y z]] - [translate-x "translateX" [Frac] [value]] - [translate-y "translateY" [Frac] [value]] - [translate-z "translateZ" [Frac] [value]] - - [scale-2d "scale" [Frac Frac] [x y]] - [scale-3d "scale3d" [Frac Frac Frac] [x y z]] - [scale-x "scaleX" [Frac] [value]] - [scale-y "scaleY" [Frac] [value]] - [scale-z "scaleZ" [Frac] [value]] - - [perspective "perspective" [Frac] [value]] - ) - - (template [<name> <function> <input-types> <input-values>] - [(`` (def: #export (<name> [(~~ (template.splice <input-values>))]) - (-> [(~~ (template.splice <input-types>))] (Value Transform)) - (|> (list (~~ (template.splice <input-values>))) - (list\map ..angle) - (..apply <function>))))] - - [rotate-2d "rotate" [Angle] [angle]] - [rotate-x "rotateX" [Angle] [angle]] - [rotate-y "rotateY" [Angle] [angle]] - [rotate-z "rotateZ" [Angle] [angle]] - - [skew "skew" [Angle Angle] [x-angle y-angle]] - [skew-x "skewX" [Angle] [angle]] - [skew-y "skewY" [Angle] [angle]] - ) - - (def: #export (rotate-3d [x y z angle]) - (-> [Frac Frac Frac Angle] (Value Transform)) - (..apply "rotate3d" - (list (%number x) (%number y) (%number z) (..angle angle)))) - - (def: origin-separator " ") - - (def: #export (origin-2d x y) - (-> (Value Length) (Value Length) (Value Transform-Origin)) - (:abstraction (format (:representation x) ..origin-separator - (:representation y)))) - - (def: #export (origin-3d x y z) - (-> (Value Length) (Value Length) (Value Length) (Value Transform-Origin)) - (:abstraction (format (:representation x) ..origin-separator - (:representation y) ..origin-separator - (:representation z)))) - - (def: #export vertical-align - (-> (Value Length) (Value Vertical-Align)) - (|>> :transmutation)) - - (def: #export (z-index index) - (-> Int (Value Z-Index)) - (:abstraction (if (i.< +0 index) - (%.int index) - (%.nat (.nat index))))) - - (multi: multi-image Image ",") - (multi: multi-shadow Shadow ",") - (multi: multi-content Content " ") - ) diff --git a/stdlib/source/lux/data/format/html.lux b/stdlib/source/lux/data/format/html.lux deleted file mode 100644 index a33182f19..000000000 --- a/stdlib/source/lux/data/format/html.lux +++ /dev/null @@ -1,562 +0,0 @@ -(.module: - [lux (#- Meta Source comment and) - ["." function] - [data - ["." product] - ["." maybe ("#\." functor)] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [type - abstract] - [host - ["." js]] - [macro - ["." template]] - [world - [net (#+ URL)]]] - [// - [css - ["." selector] - ["." style (#+ Style)]] - ["." xml (#+ XML)]]) - -(type: #export Tag selector.Tag) -(type: #export ID selector.ID) -(type: #export Class selector.Class) - -(type: #export Attributes - {#.doc "Attributes for an HTML tag."} - (List [Text Text])) - -(type: #export Script js.Statement) - -(type: #export Target - #Blank - #Parent - #Self - #Top - (#Frame Text)) - -(def: (target value) - (-> Target Text) - (case value - #Blank "_blank" - #Parent "_parent" - #Self "_self" - #Top "_top" - (#Frame name) name)) - -(def: sanitize - {#.doc "Properly formats text to ensure no injection can happen on the HTML."} - (-> Text Text) - (|>> (text.replace-all "&" "&") - (text.replace-all "<" "<") - (text.replace-all ">" ">") - (text.replace-all text.double-quote """) - (text.replace-all "'" "'") - (text.replace-all "/" "/"))) - -(def: attributes - (-> Attributes Text) - (|>> (list\map (function (_ [key val]) - (format key "=" text.double-quote (..sanitize val) text.double-quote))) - (text.join-with " "))) - -(def: (open tag attributes) - (-> Tag Attributes Text) - (|> attributes - ..attributes - (format tag " ") - (text.enclose ["<" ">"]))) - -(def: close - (-> Tag Text) - (text.enclose ["</" ">"])) - -(abstract: #export (HTML brand) - Text - - (template [<name> <brand>] - [(abstract: #export <brand> Any) - (type: #export <name> (HTML <brand>))] - - [Meta Meta'] - [Head Head'] - [Item Item'] - [Option Option'] - [Input Input'] - [Cell Cell'] - [Header Header'] - [Row Row'] - [Column Column'] - [Parameter Parameter'] - [Body Body'] - [Document Document'] - ) - - (template [<super> <super-raw> <sub>+] - [(abstract: #export (<super-raw> brand) Any) - (type: #export <super> (HTML (<super-raw> Any))) - - (`` (template [<sub> <sub-raw>] - [(abstract: #export <sub-raw> Any) - (type: #export <sub> (HTML (<super-raw> <sub-raw>)))] - - (~~ (template.splice <sub>+))))] - - [Element Element' - [[Content Content'] - [Image Image']]] - - [Media Media' - [[Source Source'] - [Track Track']]] - ) - - (def: #export html - (-> Document Text) - (|>> :representation)) - - (def: #export (and pre post) - (All [brand] (-> (HTML brand) (HTML brand) (HTML brand))) - (:abstraction (format (:representation pre) (:representation post)))) - - (def: #export (comment content node) - (All [brand] (-> Text (HTML brand) (HTML brand))) - (:abstraction - (format (text.enclose ["<!--" "-->"] content) - (:representation node)))) - - (def: (empty name attributes) - (-> Tag Attributes HTML) - (:abstraction - (format (..open name attributes) - (..close name)))) - - (def: (simple tag attributes) - (-> Tag Attributes HTML) - (|> attributes - (..open tag) - :abstraction)) - - (def: (tag name attributes content) - (-> Tag Attributes (HTML Any) HTML) - (:abstraction - (format (..open name attributes) - (:representation content) - (..close name)))) - - (def: (raw tag attributes content) - (-> Text Attributes Text HTML) - (:abstraction - (format (..open tag attributes) - content - (..close tag)))) - - (template [<name> <tag> <brand>] - [(def: #export <name> - (-> Attributes <brand>) - (..simple <tag>))] - - [link "link" Meta] - [meta "meta" Meta] - [input "input" Input] - [embedded "embed" Element] - [column "col" Column] - [parameter "param" Parameter] - ) - - (def: #export (base href target) - (-> URL (Maybe Target) Meta) - (let [partial (list ["href" href]) - full (case target - (#.Some target) - (list& ["target" (..target target)] partial) - - #.None - partial)] - (..simple "base" full))) - - (def: #export style - (-> Style Meta) - (|>> style.inline (..raw "style" (list)))) - - (def: #export (script attributes inline) - (-> Attributes (Maybe Script) Meta) - (|> inline - (maybe\map js.code) - (maybe.default "") - (..raw "script" attributes))) - - (def: #export text - (-> Text Content) - (|>> ..sanitize - :abstraction)) - - (template [<tag> <alias> <name>] - [(def: #export <name> - Element - (..simple <tag> (list))) - - (def: #export <alias> <name>)] - ["br" br line-break] - ["wbr" wbr word-break] - ["hr" hr separator] - ) - - (def: #export (image source attributes) - (-> URL Attributes Image) - (|> attributes - (#.Cons ["src" source]) - (..simple "img"))) - - (def: #export (svg attributes content) - (-> Attributes XML Element) - (|> content - (\ xml.codec encode) - (..raw "svg" attributes))) - - (type: #export Coord - {#horizontal Nat - #vertical Nat}) - - (def: metric-separator ",") - (def: coord-separator ",") - - (def: (%coord [horizontal vertical]) - (Format Coord) - (format (%.nat horizontal) ..metric-separator (%.nat vertical))) - - (type: #export Rectangle - {#start Coord - #end Coord}) - - (type: #export Circle - {#center Coord - #radius Nat}) - - (type: #export Polygon - {#first Coord - #second Coord - #third Coord - #extra (List Coord)}) - - (def: (%rectangle [start end]) - (Format Rectangle) - (format (%coord start) ..coord-separator (%coord end))) - - (def: (%circle [center radius]) - (Format Circle) - (format (%coord center) ..metric-separator (%.nat radius))) - - (def: (%polygon [first second third extra]) - (Format Polygon) - (|> (list& first second third extra) - (list\map %coord) - (text.join-with ..coord-separator))) - - (type: #export Shape - (#Rectangle Rectangle) - (#Circle Circle) - (#Polygon Polygon)) - - (template [<name> <shape> <type> <format>] - [(def: (<name> attributes shape) - (-> Attributes <type> (HTML Any)) - (..simple "area" (list& ["shape" <shape>] - ["coords" (<format> shape)] - attributes)))] - - [rectangle "rect" Rectangle ..%rectangle] - [circle "circle" Circle ..%circle] - [polygon "poly" Polygon ..%polygon] - ) - - (def: (area attributes shape) - (-> Attributes Shape (HTML Any)) - (case shape - (#Rectangle rectangle) - (..rectangle attributes rectangle) - - (#Circle circle) - (..circle attributes circle) - - (#Polygon polygon) - (..polygon attributes polygon))) - - (def: #export (map attributes areas for) - (-> Attributes (List [Attributes Shape]) Image Image) - ($_ ..and - for - (case (list\map (product.uncurry ..area) areas) - #.Nil - (..empty "map" attributes) - - (#.Cons head tail) - (..tag "map" attributes - (list\fold (function.flip ..and) head tail))))) - - (template [<name> <tag> <type>] - [(def: #export <name> - (-> Attributes <type>) - (..empty <tag>))] - - [canvas "canvas" Element] - [progress "progress" Element] - [output "output" Input] - [source "source" Source] - [track "track" Track] - ) - - (template [<name> <tag>] - [(def: #export (<name> attributes media on-unsupported) - (-> Attributes Media (Maybe Content) Element) - (..tag <tag> attributes - (|> on-unsupported - (maybe.default (..text "")) - (..and media))))] - - [audio "audio"] - [video "video"] - ) - - (def: #export (picture attributes sources image) - (-> Attributes Source Image Element) - (..tag "picture" attributes (..and sources image))) - - (def: #export (anchor href attributes content) - (-> URL Attributes Element Element) - (..tag "a" (list& ["href" href] attributes) content)) - - (def: #export label - (-> ID Input) - (|>> ["for"] list (..empty "label"))) - - (template [<name> <container-tag> <description-tag> <type>] - [(def: #export (<name> description attributes content) - (-> (Maybe Content) Attributes <type> <type>) - (..tag <container-tag> attributes - (case description - (#.Some description) - ($_ ..and - (..tag <description-tag> (list) description) - content) - - #.None - content)))] - - [details "details" "summary" Element] - [field-set "fieldset" "legend" Input] - [figure "figure" "figcaption" Element] - ) - - (template [<name> <tag> <type>] - [(def: #export (<name> attributes content) - (-> Attributes (Maybe Content) <type>) - (|> content - (maybe.default (..text "")) - (..tag <tag> attributes)))] - - [text-area "textarea" Input] - [iframe "iframe" Element] - ) - - (type: #export Phrase (-> Attributes Content Element)) - - (template [<name> <tag>] - [(def: #export <name> - Phrase - (..tag <tag>))] - - [abbrebiation "abbr"] - [block-quote "blockquote"] - [bold "b"] - [cite "cite"] - [code "code"] - [definition "dfn"] - [deleted "del"] - [emphasized "em"] - [h1 "h1"] - [h2 "h2"] - [h3 "h3"] - [h4 "h4"] - [h5 "h5"] - [h6 "h6"] - [inserted "ins"] - [italic "i"] - [keyboard "kbd"] - [marked "mark"] - [meter "meter"] - [pre "pre"] - [quote "q"] - [sample "samp"] - [struck "s"] - [small "small"] - [sub "sub"] - [super "sup"] - [strong "strong"] - [time "time"] - [underlined "u"] - [variable "var"] - ) - - (def: #export incorrect ..struck) - - (def: (ruby-pronunciation pronunciation) - (-> Content (HTML Any)) - (..tag "rt" (list) - ($_ ..and - (..tag "rp" (list) (..text "(")) - pronunciation - (..tag "rp" (list) (..text ")"))))) - - (def: #export (ruby attributes content pronunciation) - (-> Attributes Content Content Element) - (..tag "ruby" attributes - ($_ ..and - content - (ruby-pronunciation pronunciation)))) - - (type: #export Composite (-> Attributes Element Element)) - - (template [<name> <tag>] - [(def: #export <name> - Composite - (..tag <tag>))] - - [article "article"] - [aside "aside"] - [dialog "dialog"] - [div "div"] - [footer "footer"] - [header "header"] - [main "main"] - [navigation "nav"] - [paragraph "p"] - [section "section"] - [span "span"] - ) - - (template [<tag> <name> <input>] - [(def: <name> - (-> <input> (HTML Any)) - (..tag <tag> (list)))] - - ["dt" term Content] - ["dd" description Element] - ) - - (def: #export (description-list attributes descriptions) - (-> Attributes (List [Content Element]) Element) - (case (list\map (function (_ [term description]) - ($_ ..and - (..term term) - (..description description))) - descriptions) - #.Nil - (..empty "dl" attributes) - - (#.Cons head tail) - (..tag "dl" attributes - (list\fold (function.flip ..and) head tail)))) - - (def: #export p ..paragraph) - - (template [<name> <tag> <input> <output>] - [(def: #export <name> - (-> Attributes <input> <output>) - (..tag <tag>))] - - [button "button" Element Input] - [item "li" Element Item] - [ordered-list "ol" Item Element] - [unordered-list "ul" Item Element] - [option "option" Content Option] - [option-group "optgroup" Option Option] - [data-list "datalist" Option Element] - [select "select" Option Input] - [address "address" Element Element] - [form "form" Input Element] - [data "data" Element Element] - [object "object" Parameter Element] - ) - - (template [<name> <tag> <input> <output>] - [(def: #export <name> - (-> <input> <output>) - (..tag <tag> (list)))] - - [title "title" Content Meta] - [no-script "noscript" Content Meta] - [template "template" (HTML Any) (HTML Nothing)] - [table-header "th" Element Header] - [table-cell "td" Element Cell] - [head "head" Meta Head] - [body "body" Element Body] - ) - - (template [<name> <tag> <input> <output>] - [(def: <name> - (-> <input> <output>) - (..tag <tag> (list)))] - - [table-row "tr" (HTML Any) Row] - [table-head "thead" Row HTML] - [table-body "tbody" Row HTML] - [table-foot "tfoot" Row HTML] - [columns-group "colgroup" Column HTML] - ) - - (def: #export (table attributes caption columns headers rows footer) - (-> Attributes (Maybe Content) (Maybe Column) Header (List Cell) (Maybe Cell) Element) - (let [head (..table-head (..table-row headers)) - content (case (list\map table-row rows) - #.Nil - head - - (#.Cons first rest) - (..and head - (..table-body - (list\fold (function.flip ..and) first rest)))) - content (case footer - #.None - content - - (#.Some footer) - (..and content - (..table-foot (..table-row footer)))) - content (case columns - #.None - content - - (#.Some columns) - (..and (..columns-group columns) - content)) - content (case caption - #.None - content - - (#.Some caption) - (..and (:as HTML caption) - content))] - (..tag "table" attributes - content))) - - (template [<name> <doc-type>] - [(def: #export <name> - (-> Head Body Document) - (let [doc-type <doc-type>] - (function (_ head body) - (|> (..tag "html" (list) (..and head body)) - :representation - (format doc-type) - :abstraction))))] - - [html-5 "<!DOCTYPE html>"] - [html-4_01 (format "<!DOCTYPE HTML PUBLIC " text.double-quote "-//W3C//DTD HTML 4.01//EN" text.double-quote " " text.double-quote "http://www.w3.org/TR/html4/strict.dtd" text.double-quote ">")] - [xhtml-1_0 (format "<!DOCTYPE html PUBLIC " text.double-quote "-//W3C//DTD XHTML 1.0 Strict//EN" text.double-quote " " text.double-quote "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd" text.double-quote ">")] - [xhtml-1_1 (format "<!DOCTYPE html PUBLIC " text.double-quote "-//W3C//DTD XHTML 1.1//EN" text.double-quote " " text.double-quote "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd" text.double-quote ">")] - ) - ) diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux deleted file mode 100644 index a9986822f..000000000 --- a/stdlib/source/lux/data/format/json.lux +++ /dev/null @@ -1,421 +0,0 @@ -(.module: {#.doc (.doc "Functionality for reading and writing values in the JSON format." - "For more information, please see: http://www.json.org/")} - [lux #* - ["." meta (#+ monad)] - [abstract - [equivalence (#+ Equivalence)] - [codec (#+ Codec)] - [predicate (#+ Predicate)] - ["." monad (#+ do)]] - [control - pipe - ["." try (#+ Try)] - ["<>" parser ("#\." monad) - ["<.>" text (#+ Parser)]]] - [data - ["." bit] - ["." maybe] - ["." product] - ["." text ("#\." equivalence monoid)] - [collection - ["." list ("#\." fold functor)] - ["." row (#+ Row row) ("#\." monad)] - ["." dictionary (#+ Dictionary)]]] - [macro (#+ with_gensyms) - [syntax (#+ syntax:)] - ["." code]] - [math - [number - ["n" nat] - ["f" frac ("#\." decimal)]]]]) - -(template [<name> <type>] - [(type: #export <name> - <type>)] - - [Null Any] - [Boolean Bit] - [Number Frac] - [String Text] - ) - -(type: #export #rec JSON - (#Null Null) - (#Boolean Boolean) - (#Number Number) - (#String String) - (#Array (Row JSON)) - (#Object (Dictionary String JSON))) - -(template [<name> <type>] - [(type: #export <name> - <type>)] - - [Array (Row JSON)] - [Object (Dictionary String JSON)] - ) - -(def: #export null? - (Predicate JSON) - (|>> (case> #Null true - _ false))) - -(def: #export object - (-> (List [String JSON]) JSON) - (|>> (dictionary.from_list text.hash) #..Object)) - -(syntax: #export (json token) - {#.doc (doc "A simple way to produce JSON literals." - (json #null) - (json #1) - (json +123.456) - (json "this is a string") - (json ["this" "is" "an" "array"]) - (json {"this" "is" - "an" "object"}))} - (let [(^open ".") ..monad - wrapper (function (_ x) (` (..json (~ x))))] - (case token - (^template [<ast_tag> <ctor> <json_tag>] - [[_ (<ast_tag> value)] - (wrap (list (` (: JSON (<json_tag> (~ (<ctor> value)))))))]) - ([#.Bit code.bit #..Boolean] - [#.Frac code.frac #..Number] - [#.Text code.text #..String]) - - [_ (#.Tag ["" "null"])] - (wrap (list (` (: JSON #..Null)))) - - [_ (#.Tuple members)] - (wrap (list (` (: JSON (#..Array ((~! row) (~+ (list\map wrapper members)))))))) - - [_ (#.Record pairs)] - (do {! ..monad} - [pairs' (monad.map ! - (function (_ [slot value]) - (case slot - [_ (#.Text key_name)] - (wrap (` [(~ (code.text key_name)) (~ (wrapper value))])) - - _ - (meta.fail "Wrong syntax for JSON object."))) - pairs)] - (wrap (list (` (: JSON (#..Object ((~! dictionary.from_list) - (~! text.hash) - (list (~+ pairs'))))))))) - - _ - (wrap (list token))))) - -(def: #export (fields json) - {#.doc "Get all the fields in a JSON object."} - (-> JSON (Try (List String))) - (case json - (#Object obj) - (#try.Success (dictionary.keys obj)) - - _ - (#try.Failure ($_ text\compose "Cannot get the fields of a non-object.")))) - -(def: #export (get key json) - {#.doc "A JSON object field getter."} - (-> String JSON (Try JSON)) - (case json - (#Object obj) - (case (dictionary.get key obj) - (#.Some value) - (#try.Success value) - - #.None - (#try.Failure ($_ text\compose "Missing field '" key "' on object."))) - - _ - (#try.Failure ($_ text\compose "Cannot get field '" key "' on a non-object.")))) - -(def: #export (set key value json) - {#.doc "A JSON object field setter."} - (-> String JSON JSON (Try JSON)) - (case json - (#Object obj) - (#try.Success (#Object (dictionary.put key value obj))) - - _ - (#try.Failure ($_ text\compose "Cannot set field '" key "' on a non-object.")))) - -(template [<name> <tag> <type> <desc>] - [(def: #export (<name> key json) - {#.doc (code.text ($_ text\compose "A JSON object field getter for " <desc> "."))} - (-> Text JSON (Try <type>)) - (case (get key json) - (#try.Success (<tag> value)) - (#try.Success value) - - (#try.Success _) - (#try.Failure ($_ text\compose "Wrong value type at key: " key)) - - (#try.Failure error) - (#try.Failure error)))] - - [get_boolean #Boolean Boolean "booleans"] - [get_number #Number Number "numbers"] - [get_string #String String "strings"] - [get_array #Array Array "arrays"] - [get_object #Object Object "objects"] - ) - -(implementation: #export equivalence - (Equivalence JSON) - - (def: (= x y) - (case [x y] - [#Null #Null] - #1 - - (^template [<tag> <struct>] - [[(<tag> x') (<tag> y')] - (\ <struct> = x' y')]) - ([#Boolean bit.equivalence] - [#Number f.equivalence] - [#String text.equivalence]) - - [(#Array xs) (#Array ys)] - (and (n.= (row.size xs) (row.size ys)) - (list\fold (function (_ idx prev) - (and prev - (maybe.default #0 - (do maybe.monad - [x' (row.nth idx xs) - y' (row.nth idx ys)] - (wrap (= x' y')))))) - #1 - (list.indices (row.size xs)))) - - [(#Object xs) (#Object ys)] - (and (n.= (dictionary.size xs) (dictionary.size ys)) - (list\fold (function (_ [xk xv] prev) - (and prev - (case (dictionary.get xk ys) - #.None #0 - (#.Some yv) (= xv yv)))) - #1 - (dictionary.entries xs))) - - _ - #0))) - -############################################################ -############################################################ -############################################################ - -(def: (format_null _) - (-> Null Text) - "null") - -(def: format_boolean - (-> Boolean Text) - (|>> (case> - #0 "false" - #1 "true"))) - -(def: format_number - (-> Number Text) - (|>> (case> - (^or +0.0 -0.0) "0.0" - value (let [raw (\ f.decimal encode value)] - (if (f.< +0.0 value) - raw - (|> raw (text.split 1) maybe.assume product.right)))))) - -(def: escape "\") -(def: escaped_dq (text\compose ..escape text.double_quote)) - -(def: format_string - (-> String Text) - (|>> (text.replace_all text.double_quote ..escaped_dq) - (text.enclose [text.double_quote text.double_quote]))) - -(template [<token> <name>] - [(def: <name> - Text - <token>)] - - ["," separator] - [":" entry_separator] - - ["[" open_array] - ["]" close_array] - - ["{" open_object] - ["}" close_object] - ) - -(def: (format_array format) - (-> (-> JSON Text) (-> Array Text)) - (|>> (row\map format) - row.to_list - (text.join_with ..separator) - (text.enclose [..open_array ..close_array]))) - -(def: (format_kv format [key value]) - (-> (-> JSON Text) (-> [String JSON] Text)) - ($_ text\compose - (..format_string key) - ..entry_separator - (format value) - )) - -(def: (format_object format) - (-> (-> JSON Text) (-> Object Text)) - (|>> dictionary.entries - (list\map (..format_kv format)) - (text.join_with ..separator) - (text.enclose [..open_object ..close_object]))) - -(def: #export (format json) - (-> JSON Text) - (case json - (^template [<tag> <format>] - [(<tag> value) - (<format> value)]) - ([#Null ..format_null] - [#Boolean ..format_boolean] - [#Number ..format_number] - [#String ..format_string] - [#Array (..format_array format)] - [#Object (..format_object format)]) - )) - -############################################################ -############################################################ -############################################################ - -(def: parse_space - (Parser Text) - (<text>.some <text>.space)) - -(def: parse_separator - (Parser [Text Any Text]) - ($_ <>.and - ..parse_space - (<text>.this ..separator) - ..parse_space)) - -(def: parse_null - (Parser Null) - (do <>.monad - [_ (<text>.this "null")] - (wrap []))) - -(template [<name> <token> <value>] - [(def: <name> - (Parser Boolean) - (do <>.monad - [_ (<text>.this <token>)] - (wrap <value>)))] - - [parse_true "true" #1] - [parse_false "false" #0] - ) - -(def: parse_boolean - (Parser Boolean) - ($_ <>.either - ..parse_true - ..parse_false)) - -(def: parse_number - (Parser Number) - (do {! <>.monad} - [signed? (<>.parses? (<text>.this "-")) - digits (<text>.many <text>.decimal) - decimals (<>.default "0" - (do ! - [_ (<text>.this ".")] - (<text>.many <text>.decimal))) - exp (<>.default "" - (do ! - [mark (<text>.one_of "eE") - signed?' (<>.parses? (<text>.this "-")) - offset (<text>.many <text>.decimal)] - (wrap ($_ text\compose mark (if signed?' "-" "") offset))))] - (case (f\decode ($_ text\compose (if signed? "-" "") digits "." decimals exp)) - (#try.Failure message) - (<>.fail message) - - (#try.Success value) - (wrap value)))) - -(def: parse_escaped - (Parser Text) - ($_ <>.either - (<>.after (<text>.this "\t") - (<>\wrap text.tab)) - (<>.after (<text>.this "\b") - (<>\wrap text.back_space)) - (<>.after (<text>.this "\n") - (<>\wrap text.new_line)) - (<>.after (<text>.this "\r") - (<>\wrap text.carriage_return)) - (<>.after (<text>.this "\f") - (<>\wrap text.form_feed)) - (<>.after (<text>.this (text\compose "\" text.double_quote)) - (<>\wrap text.double_quote)) - (<>.after (<text>.this "\\") - (<>\wrap "\")))) - -(def: parse_string - (Parser String) - (<| (<text>.enclosed [text.double_quote text.double_quote]) - (loop [_ []]) - (do {! <>.monad} - [chars (<text>.some (<text>.none_of (text\compose "\" text.double_quote))) - stop <text>.peek]) - (if (text\= "\" stop) - (do ! - [escaped parse_escaped - next_chars (recur [])] - (wrap ($_ text\compose chars escaped next_chars))) - (wrap chars)))) - -(def: (parse_kv parse_json) - (-> (Parser JSON) (Parser [String JSON])) - (do <>.monad - [key ..parse_string - _ ..parse_space - _ (<text>.this ..entry_separator) - _ ..parse_space - value parse_json] - (wrap [key value]))) - -(template [<name> <type> <open> <close> <elem_parser> <prep>] - [(def: (<name> parse_json) - (-> (Parser JSON) (Parser <type>)) - (do <>.monad - [_ (<text>.this <open>) - _ parse_space - elems (<>.separated_by ..parse_separator <elem_parser>) - _ parse_space - _ (<text>.this <close>)] - (wrap (<prep> elems))))] - - [parse_array Array ..open_array ..close_array parse_json row.from_list] - [parse_object Object ..open_object ..close_object (parse_kv parse_json) (dictionary.from_list text.hash)] - ) - -(def: parse_json - (Parser JSON) - (<>.rec - (function (_ parse_json) - ($_ <>.or - parse_null - parse_boolean - parse_number - parse_string - (parse_array parse_json) - (parse_object parse_json))))) - -(implementation: #export codec - (Codec Text JSON) - - (def: encode ..format) - (def: decode (<text>.run parse_json))) diff --git a/stdlib/source/lux/data/format/markdown.lux b/stdlib/source/lux/data/format/markdown.lux deleted file mode 100644 index 5cdc68865..000000000 --- a/stdlib/source/lux/data/format/markdown.lux +++ /dev/null @@ -1,180 +0,0 @@ -(.module: - [lux (#- and) - [data - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)]]] - [type - abstract] - [world - [net (#+ URL)]]]) - -## https://www.markdownguide.org/basic-syntax/ - -(def: sanitize - (-> Text Text) - (|>> (text.replace-all "\" "\\") - (text.replace-all "`" "\`") - (text.replace-all "*" "\*") - (text.replace-all "_" "\_") - (text.replace-all "{" "\{") - (text.replace-all "}" "\}") - (text.replace-all "[" "\[") - (text.replace-all "]" "\]") - (text.replace-all "(" "\(") - (text.replace-all ")" "\)") - (text.replace-all "#" "\#") - (text.replace-all "+" "\+") - (text.replace-all "-" "\-") - (text.replace-all "." "\.") - (text.replace-all "!" "\!"))) - -(abstract: #export Span Any) -(abstract: #export Block Any) - -(abstract: #export (Markdown brand) - Text - - (def: #export empty - Markdown - (:abstraction "")) - - (def: #export text - (-> Text (Markdown Span)) - (|>> ..sanitize :abstraction)) - - (def: blank-line (format text.new-line text.new-line)) - - (template [<name> <prefix>] - [(def: #export (<name> content) - (-> Text Markdown) - (:abstraction (format <prefix> " " (..sanitize content) ..blank-line)))] - - [heading/1 "#"] - [heading/2 "##"] - [heading/3 "###"] - [heading/4 "####"] - [heading/5 "#####"] - [heading/6 "######"] - ) - - (def: (block content) - (-> Text (Markdown Block)) - (:abstraction (format content ..blank-line))) - - (def: #export paragraph - (-> (Markdown Span) (Markdown Block)) - (|>> :representation ..block)) - - (def: #export break - (Markdown Span) - (:abstraction (format " " text.new-line))) - - (template [<name> <wrapper>] - [(def: #export <name> - (-> (Markdown Span) (Markdown Span)) - (|>> :representation - (text.enclose [<wrapper> <wrapper>]) - :abstraction))] - - [bold "**"] - [italic "_"] - ) - - (def: (prefix with) - (-> Text (-> Text Text)) - (|>> (text.split-all-with text.new-line) - (list\map (function (_ line) - (if (text.empty? line) - line - (format with line)))) - (text.join-with text.new-line))) - - (def: indent - (-> Text Text) - (..prefix text.tab)) - - (def: #export quote - (-> (Markdown Block) (Markdown Block)) - (|>> :representation - (..prefix "> ") - :abstraction)) - - (def: #export numbered-list - (-> (List [(Markdown Span) (Maybe (Markdown Block))]) - (Markdown Block)) - (|>> list.enumeration - (list\map (function (_ [idx [summary detail]]) - (format (%.nat (inc idx)) ". " (:representation summary) text.new-line - (case detail - (#.Some detail) - (|> detail :representation ..indent (text.enclose [text.new-line text.new-line])) - - #.None - "")))) - (text.join-with text.new-line) - ..block)) - - (def: #export bullet-list - (-> (List [(Markdown Span) (Maybe (Markdown Block))]) - (Markdown Block)) - (|>> (list\map (function (_ [summary detail]) - (format "*. " (:representation summary) text.new-line - (case detail - (#.Some detail) - (|> detail :representation ..indent (text.enclose [text.new-line text.new-line])) - - #.None - "")))) - (text.join-with text.new-line) - ..block)) - - (def: #export snippet - {#.doc "A snippet of code."} - (-> Text (Markdown Span)) - (|>> ..sanitize (text.enclose ["`" "`"]) :abstraction)) - - (def: #export code - {#.doc "A block of code."} - (-> Text (Markdown Block)) - (let [open (format "```" text.new-line) - close (format text.new-line "```")] - (|>> (text.enclose [open close]) ..block))) - - (def: #export (image description url) - (-> Text URL (Markdown Span)) - (:abstraction (format "![" (..sanitize description) "](" url ")"))) - - (def: #export horizontal-rule - (Markdown Block) - (..block "___")) - - (def: #export (link description url) - (-> (Markdown Span) URL (Markdown Span)) - (:abstraction (format "[" (:representation description) "](" url ")"))) - - (type: #export Email Text) - - (template [<name> <type>] - [(def: #export <name> - (-> <type> (Markdown Span)) - (|>> (text.enclose ["<" ">"]) :abstraction))] - - [url URL] - [email Email] - ) - - (template [<name> <brand> <infix>] - [(def: #export (<name> pre post) - (-> (Markdown <brand>) (Markdown <brand>) (Markdown <brand>)) - (:abstraction (format (:representation pre) <infix> (:representation post))))] - - [and Span " "] - [then Block ""] - ) - - (def: #export markdown - (-> (Markdown Any) Text) - (|>> :representation)) - ) diff --git a/stdlib/source/lux/data/format/tar.lux b/stdlib/source/lux/data/format/tar.lux deleted file mode 100644 index 504b7f5ac..000000000 --- a/stdlib/source/lux/data/format/tar.lux +++ /dev/null @@ -1,870 +0,0 @@ -(.module: - [lux (#- Mode Name and) - [abstract - [monad (#+ do)]] - [control - [pipe (#+ case>)] - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["<>" parser - ["<b>" binary (#+ Parser)]]] - [data - ["." product] - ["." binary (#+ Binary)] - ["." text (#+ Char) - ["%" format (#+ format)] - [encoding - ["." utf8]]] - ["." format #_ - ["#" binary (#+ Writer) ("#\." monoid)]] - [collection - ["." list ("#\." fold)] - ["." row (#+ Row) ("#\." fold)]]] - [math - ["." number - ["n" nat] - ["." i64]]] - [time - ["." instant (#+ Instant)] - ["." duration]] - [world - ["." file]] - [type - abstract]]) - -(type: Size Nat) - -(def: octal_size Size 8) - -(def: (octal_padding max_size number) - (-> Size Text Text) - (let [padding_size (n.- (text.size number) - max_size) - padding (|> "0" - (list.repeat padding_size) - (text.join_with ""))] - (format padding number))) - -(def: blank " ") -(def: null text.null) - -(def: small_size Size 6) -(def: big_size Size 11) - -(template [<exception> <limit> <size> - <type> <in> <out> <writer> <suffix> - <coercion>] - [(def: #export <limit> - Nat - (|> ..octal_size - (list.repeat <size>) - (list\fold n.* 1) - inc)) - - (exception: #export (<exception> {value Nat}) - (exception.report - ["Value" (%.nat value)] - ["Maximum" (%.nat (dec <limit>))])) - - (abstract: #export <type> - Nat - - (def: #export (<in> value) - (-> Nat (Try <type>)) - (if (n.< <limit> value) - (#try.Success (:abstraction value)) - (exception.throw <exception> [value]))) - - (def: #export <out> - (-> <type> Nat) - (|>> :representation)) - - (def: <writer> - (Writer <type>) - (let [suffix <suffix> - padded_size (n.+ (text.size suffix) <size>)] - (|>> :representation - (\ n.octal encode) - (..octal_padding <size>) - (text.suffix suffix) - (\ utf8.codec encode) - (format.segment padded_size)))) - - (def: <coercion> - (-> Nat <type>) - (|>> (n.% <limit>) - :abstraction)) - )] - - [not_a_small_number small_limit ..small_size - Small small from_small - small_writer (format ..blank ..null) - coerce_small] - [not_a_big_number big_limit ..big_size - Big big from_big - big_writer ..blank - coerce_big] - ) - -(exception: #export (wrong_character {expected Char} {actual Char}) - (exception.report - ["Expected" (%.nat expected)] - ["Actual" (%.nat actual)])) - -(def: verify_small_suffix - (Parser Any) - (do <>.monad - [pre_end <b>.bits/8 - end <b>.bits/8 - _ (let [expected (`` (char (~~ (static ..blank))))] - (<>.assert (exception.construct ..wrong_character [expected pre_end]) - (n.= expected pre_end))) - _ (let [expected (`` (char (~~ (static ..null))))] - (<>.assert (exception.construct ..wrong_character [expected end]) - (n.= expected end)))] - (wrap []))) - -(def: small_parser - (Parser Small) - (do <>.monad - [digits (<b>.segment ..small_size) - digits (<>.lift (\ utf8.codec decode digits)) - _ ..verify_small_suffix] - (<>.lift - (do {! try.monad} - [value (\ n.octal decode digits)] - (..small value))))) - -(def: big_parser - (Parser Big) - (do <>.monad - [digits (<b>.segment ..big_size) - digits (<>.lift (\ utf8.codec decode digits)) - end <b>.bits/8 - _ (let [expected (`` (char (~~ (static ..blank))))] - (<>.assert (exception.construct ..wrong_character [expected end]) - (n.= expected end)))] - (<>.lift - (do {! try.monad} - [value (\ n.octal decode digits)] - (..big value))))) - -(abstract: Checksum - Text - - (def: from_checksum - (-> Checksum Text) - (|>> :representation)) - - (def: dummy_checksum - Checksum - (:abstraction " ")) - - (def: checksum_suffix - (format ..blank ..null)) - - (def: checksum - (-> Binary Nat) - (binary.fold n.+ 0)) - - (def: checksum_checksum - (|> ..dummy_checksum - :representation - (\ utf8.codec encode) - ..checksum)) - - (def: checksum_code - (-> Binary Checksum) - (|>> ..checksum - ..coerce_small - ..from_small - (\ n.octal encode) - (..octal_padding ..small_size) - (text.suffix ..checksum_suffix) - :abstraction)) - - (def: checksum_writer - (Writer Checksum) - (let [padded_size (n.+ (text.size ..checksum_suffix) - ..small_size)] - (|>> :representation - (\ utf8.codec encode) - (format.segment padded_size)))) - - (def: checksum_parser - (Parser [Nat Checksum]) - (do <>.monad - [ascii (<b>.segment ..small_size) - digits (<>.lift (\ utf8.codec decode ascii)) - _ ..verify_small_suffix - value (<>.lift - (\ n.octal decode digits))] - (wrap [value - (:abstraction (format digits ..checksum_suffix))]))) - ) - -(def: last_ascii - Char - (number.hex "007F")) - -(def: ascii? - (-> Text Bit) - (|>> (\ utf8.codec encode) - (binary.fold (function (_ char verdict) - (.and verdict - (n.<= ..last_ascii char))) - true))) - -(exception: #export (not_ascii {text Text}) - (exception.report - ["Text" (%.text text)])) - -(def: #export name_size Size 31) -(def: #export path_size Size 99) - -(def: (un_pad string) - (-> Binary (Try Binary)) - (case (binary.size string) - 0 (#try.Success string) - size (loop [end (dec size)] - (case end - 0 (#try.Success (\ utf8.codec encode "")) - _ (do try.monad - [last_char (binary.read/8 end string)] - (`` (case (.nat last_char) - (^ (char (~~ (static ..null)))) - (recur (dec end)) - - _ - (binary.slice 0 (inc end) string)))))))) - -(template [<type> <representation> <size> <exception> <in> <out> <writer> <parser> <none>] - [(abstract: #export <type> - <representation> - - (exception: #export (<exception> {value Text}) - (exception.report - ["Value" (%.text value)] - ["Size" (%.nat (text.size value))] - ["Maximum" (%.nat <size>)])) - - (def: #export (<in> value) - (-> <representation> (Try <type>)) - (if (..ascii? value) - (if (|> value (\ utf8.codec encode) binary.size (n.<= <size>)) - (#try.Success (:abstraction value)) - (exception.throw <exception> [value])) - (exception.throw ..not_ascii [value]))) - - (def: #export <out> - (-> <type> <representation>) - (|>> :representation)) - - (def: <writer> - (Writer <type>) - (let [suffix ..null - padded_size (n.+ (text.size suffix) <size>)] - (|>> :representation - (text.suffix suffix) - (\ utf8.codec encode) - (format.segment padded_size)))) - - (def: <parser> - (Parser <type>) - (do <>.monad - [string (<b>.segment <size>) - end <b>.bits/8 - #let [expected (`` (char (~~ (static ..null))))] - _ (<>.assert (exception.construct ..wrong_character [expected end]) - (n.= expected end))] - (<>.lift - (do {! try.monad} - [ascii (..un_pad string) - text (\ utf8.codec decode ascii)] - (<in> text))))) - - (def: #export <none> - <type> - (try.assume (<in> ""))) - )] - - [Name Text ..name_size name_is_too_long name from_name name_writer name_parser anonymous] - [Path file.Path ..path_size path_is_too_long path from_path path_writer path_parser no_path] - ) - -(def: magic_size Size 7) - -(abstract: Magic - Text - - (def: ustar (:abstraction "ustar ")) - - (def: from_magic - (-> Magic Text) - (|>> :representation)) - - (def: magic_writer - (Writer Magic) - (let [padded_size (n.+ (text.size ..null) - ..magic_size)] - (|>> :representation - (\ utf8.codec encode) - (format.segment padded_size)))) - - (def: magic_parser - (Parser Magic) - (do <>.monad - [string (<b>.segment ..magic_size) - end <b>.bits/8 - #let [expected (`` (char (~~ (static ..null))))] - _ (<>.assert (exception.construct ..wrong_character [expected end]) - (n.= expected end))] - (<>.lift - (\ try.monad map (|>> :abstraction) - (\ utf8.codec decode string))))) - ) - -(def: block_size Size 512) - -(def: owner_id_size ..small_size) - -(def: blank_size Size (text.size ..blank)) -(def: null_size Size (text.size ..null)) -(def: mode_size Size ..small_size) -(def: content_size Size ..big_size) -(def: modification_time_size Size ..big_size) -(def: checksum_size Size ..small_size) -(def: link_flag_size Size 1) -(def: device_size Size ..small_size) - -(def: small_number - (-> Size Size) - (|>> ($_ n.+ ..blank_size ..null_size))) - -(def: big_number - (-> Size Size) - (|>> ($_ n.+ ..blank_size))) - -(def: string - (-> Size Size) - (|>> ($_ n.+ ..null_size))) - -(def: header_size - ($_ n.+ - ## name - (..string ..path_size) - ## mode - (..small_number ..mode_size) - ## uid - (..small_number ..owner_id_size) - ## gid - (..small_number ..owner_id_size) - ## size - (..big_number ..content_size) - ## mtime - (..big_number ..modification_time_size) - ## chksum - (..small_number ..checksum_size) - ## linkflag - ..link_flag_size - ## linkname - (..string ..path_size) - ## magic - (..string ..magic_size) - ## uname - (..string ..name_size) - ## gname - (..string ..name_size) - ## devmajor - (..small_number ..device_size) - ## devminor - (..small_number ..device_size))) - -(abstract: Link_Flag - Char - - (def: link_flag - (-> Link_Flag Char) - (|>> :representation)) - - (def: link_flag_writer - (Writer Link_Flag) - (|>> :representation - format.bits/8)) - - (with_expansions [<options> (as_is [0 old_normal] - [(char "0") normal] - [(char "1") link] - [(char "2") symbolic_link] - [(char "3") character] - [(char "4") block] - [(char "5") directory] - [(char "6") fifo] - [(char "7") contiguous])] - (template [<flag> <name>] - [(def: <name> - Link_Flag - (:abstraction <flag>))] - - <options> - ) - - (exception: #export (invalid_link_flag {value Nat}) - (exception.report - ["Value" (%.nat value)])) - - (def: link_flag_parser - (Parser Link_Flag) - (do <>.monad - [linkflag <b>.bits/8] - (case (.nat linkflag) - (^template [<value> <link_flag>] - [(^ <value>) - (wrap <link_flag>)]) - (<options>) - - _ - (<>.lift - (exception.throw ..invalid_link_flag [(.nat linkflag)])))))) - ) - -(abstract: #export Mode - Nat - - (def: #export mode - (-> Mode Nat) - (|>> :representation)) - - (def: #export (and left right) - (-> Mode Mode Mode) - (:abstraction - (i64.or (:representation left) - (:representation right)))) - - (def: mode_writer - (Writer Mode) - (|>> :representation - ..small - try.assume - ..small_writer)) - - (exception: #export (invalid_mode {value Nat}) - (exception.report - ["Value" (%.nat value)])) - - (with_expansions [<options> (as_is ["0000" none] - - ["0001" execute_by_other] - ["0002" write_by_other] - ["0004" read_by_other] - - ["0010" execute_by_group] - ["0020" write_by_group] - ["0040" read_by_group] - - ["0100" execute_by_owner] - ["0200" write_by_owner] - ["0400" read_by_owner] - - ["1000" save_text] - ["2000" set_group_id_on_execution] - ["4000" set_user_id_on_execution])] - (template [<code> <name>] - [(def: #export <name> - Mode - (:abstraction (number.oct <code>)))] - - <options> - ) - - (def: maximum_mode - Mode - ($_ and - ..none - - ..execute_by_other - ..write_by_other - ..read_by_other - - ..execute_by_group - ..write_by_group - ..read_by_group - - ..execute_by_owner - ..write_by_owner - ..read_by_owner - - ..save_text - ..set_group_id_on_execution - ..set_user_id_on_execution - )) - - (def: mode_parser - (Parser Mode) - (do {! <>.monad} - [value (\ ! map ..from_small ..small_parser)] - (if (n.<= (:representation ..maximum_mode) - value) - (wrap (:abstraction value)) - (<>.lift - (exception.throw ..invalid_mode [value])))))) - ) - -(def: maximum_content_size - Nat - (|> ..octal_size - (list.repeat ..content_size) - (list\fold n.* 1))) - -(abstract: #export Content - [Big Binary] - - (def: #export (content content) - (-> Binary (Try Content)) - (do try.monad - [size (..big (binary.size content))] - (wrap (:abstraction [size content])))) - - (def: from_content - (-> Content [Big Binary]) - (|>> :representation)) - - (def: #export data - (-> Content Binary) - (|>> :representation product.right)) - ) - -(type: #export ID - Small) - -(def: #export no_id - ID - (..coerce_small 0)) - -(type: #export Owner - {#name Name - #id ID}) - -(type: #export Ownership - {#user Owner - #group Owner}) - -(type: #export File - [Path Instant Mode Ownership Content]) - -(type: #export Normal File) -(type: #export Symbolic_Link Path) -(type: #export Directory Path) -(type: #export Contiguous File) - -(type: #export Entry - (#Normal ..Normal) - (#Symbolic_Link ..Symbolic_Link) - (#Directory ..Directory) - (#Contiguous ..Contiguous)) - -(type: Device - Small) - -(def: no_device - Device - (try.assume (..small 0))) - -(type: #export Tar - (Row Entry)) - -(def: (blocks size) - (-> Big Nat) - (n.+ (n./ ..block_size - (..from_big size)) - (case (n.% ..block_size (..from_big size)) - 0 0 - _ 1))) - -(def: rounded_content_size - (-> Big Nat) - (|>> ..blocks - (n.* ..block_size))) - -(type: Header - {#path Path - #mode Mode - #user_id ID - #group_id ID - #size Big - #modification_time Big - #checksum Checksum - #link_flag Link_Flag - #link_name Path - #magic Magic - #user_name Name - #group_name Name - #major_device Device - #minor_device Device}) - -(def: header_writer' - (Writer Header) - ($_ format.and - ..path_writer - ..mode_writer - ..small_writer - ..small_writer - ..big_writer - ..big_writer - ..checksum_writer - ..link_flag_writer - ..path_writer - ..magic_writer - ..name_writer - ..name_writer - ..small_writer - ..small_writer - )) - -(def: (header_writer header) - (Writer Header) - (let [checksum (|> header - (set@ #checksum ..dummy_checksum) - (format.run ..header_writer') - ..checksum_code)] - (|> header - (set@ #checksum checksum) - (format.run ..header_writer') - (format.segment ..block_size)))) - -(def: modification_time - (-> Instant Big) - (|>> instant.relative - (duration.query duration.second) - .nat - ..coerce_big)) - -(def: (file_writer link_flag) - (-> Link_Flag (Writer File)) - (function (_ [path modification_time mode ownership content]) - (let [[size content] (..from_content content) - writer ($_ format.and - ..header_writer - (format.segment (..rounded_content_size size)))] - (writer [{#path path - #mode mode - #user_id (get@ [#user #id] ownership) - #group_id (get@ [#group #id] ownership) - #size size - #modification_time (..modification_time modification_time) - #checksum ..dummy_checksum - #link_flag link_flag - #link_name ..no_path - #magic ..ustar - #user_name (get@ [#user #name] ownership) - #group_name (get@ [#group #name] ownership) - #major_device ..no_device - #minor_device ..no_device} - content])))) - -(def: normal_file_writer - (Writer File) - (..file_writer ..normal)) - -(def: contiguous_file_writer - (Writer File) - (..file_writer ..contiguous)) - -(def: (symbolic_link_writer path) - (Writer Path) - (..header_writer - {#path ..no_path - #mode ..none - #user_id ..no_id - #group_id ..no_id - #size (..coerce_big 0) - #modification_time (..coerce_big 0) - #checksum ..dummy_checksum - #link_flag ..symbolic_link - #link_name path - #magic ..ustar - #user_name ..anonymous - #group_name ..anonymous - #major_device ..no_device - #minor_device ..no_device})) - -(def: (directory_writer path) - (Writer Path) - (..header_writer - {#path path - #mode ..none - #user_id ..no_id - #group_id ..no_id - #size (..coerce_big 0) - #modification_time (..coerce_big 0) - #checksum ..dummy_checksum - #link_flag ..directory - #link_name ..no_path - #magic ..ustar - #user_name ..anonymous - #group_name ..anonymous - #major_device ..no_device - #minor_device ..no_device})) - -(def: entry_writer - (Writer Entry) - (|>> (case> (#Normal value) (..normal_file_writer value) - (#Symbolic_Link value) (..symbolic_link_writer value) - (#Directory value) (..directory_writer value) - (#Contiguous value) (..contiguous_file_writer value)))) - -(def: end_of_archive_size Size (n.* 2 ..block_size)) - -(def: #export writer - (Writer Tar) - (let [end_of_archive (binary.create ..end_of_archive_size)] - (function (_ tar) - (format\compose (row\fold (function (_ next total) - (format\compose total (..entry_writer next))) - format\identity - tar) - (format.segment ..end_of_archive_size end_of_archive))))) - -(exception: #export (wrong_checksum {expected Nat} {actual Nat}) - (exception.report - ["Expected" (%.nat expected)] - ["Actual" (%.nat actual)])) - -(def: header_padding_size - (n.- header_size block_size)) - -## When the checksum gets originally calculated, the assumption is that all the characters in the checksum field -## of the header will be spaces. -## This means that just calculating the checksum of the 512 bytes of the header, when reading them, would yield -## an incorrect result, as the contents of the checksum field would be an actual checksum, instead of just spaces. -## To correct for this, it is necessary to calculate the checksum of just the checksum field, subtract that, and then -## add-in the checksum of the spaces. -(def: (expected_checksum checksum header) - (-> Checksum Binary Nat) - (let [|checksum| (|> checksum - ..from_checksum - (\ utf8.codec encode) - ..checksum)] - (|> (..checksum header) - (n.- |checksum|) - (n.+ ..checksum_checksum)))) - -(def: header_parser - (Parser Header) - (do <>.monad - [binary_header (<>.speculative (<b>.segment block_size)) - path ..path_parser - mode ..mode_parser - user_id ..small_parser - group_id ..small_parser - size ..big_parser - modification_time ..big_parser - [actual checksum_code] ..checksum_parser - _ (let [expected (expected_checksum checksum_code binary_header)] - (<>.lift - (exception.assert ..wrong_checksum [expected actual] - (n.= expected actual)))) - link_flag ..link_flag_parser - link_name ..path_parser - magic ..magic_parser - user_name ..name_parser - group_name ..name_parser - major_device ..small_parser - minor_device ..small_parser - _ (<b>.segment ..header_padding_size)] - (wrap {#path path - #mode mode - #user_id user_id - #group_id group_id - #size size - #modification_time modification_time - #checksum checksum_code - #link_flag link_flag - #link_name link_name - #magic magic - #user_name user_name - #group_name group_name - #major_device major_device - #minor_device minor_device}))) - -(exception: #export (wrong_link_flag {expected Link_Flag} {actual Link_Flag}) - (exception.report - ["Expected" (%.nat (..link_flag expected))] - ["Actual" (%.nat (..link_flag actual))])) - -(def: (file_parser expected) - (-> Link_Flag (Parser File)) - (do <>.monad - [header ..header_parser - _ (<>.assert (exception.construct ..wrong_link_flag [expected (get@ #link_flag header)]) - (is? expected (get@ #link_flag header))) - #let [size (get@ #size header) - rounded_size (..rounded_content_size size)] - content (<b>.segment (..from_big size)) - content (<>.lift (..content content)) - _ (<b>.segment (n.- (..from_big size) rounded_size))] - (wrap [(get@ #path header) - (|> header - (get@ #modification_time) - ..from_big - .int - duration.from_millis - (duration.up (|> duration.second duration.to_millis .nat)) - instant.absolute) - (get@ #mode header) - {#user {#name (get@ #user_name header) - #id (get@ #user_id header)} - #group {#name (get@ #group_name header) - #id (get@ #group_id header)}} - content]))) - -(def: (file_name_parser expected extractor) - (-> Link_Flag (-> Header Path) (Parser Path)) - (do <>.monad - [header ..header_parser - _ (<>.lift - (exception.assert ..wrong_link_flag [expected (get@ #link_flag header)] - (n.= (..link_flag expected) - (..link_flag (get@ #link_flag header)))))] - (wrap (extractor header)))) - -(def: entry_parser - (Parser Entry) - ($_ <>.either - (\ <>.monad map (|>> #..Normal) - (<>.either (..file_parser ..normal) - (..file_parser ..old_normal))) - (\ <>.monad map (|>> #..Symbolic_Link) - (..file_name_parser ..symbolic_link (get@ #link_name))) - (\ <>.monad map (|>> #..Directory) - (..file_name_parser ..directory (get@ #path))) - (\ <>.monad map (|>> #..Contiguous) - (..file_parser ..contiguous)))) - -## It's safe to implement the parser this way because the range of values for Nat is 2^64 -## Whereas the maximum possible value for the checksum of a 512 block is (256 × 512) = 131,072 -(def: end_of_archive_block_parser - (Parser Any) - (do <>.monad - [block (<b>.segment ..block_size)] - (let [actual (..checksum block)] - (<>.lift - (exception.assert ..wrong_checksum [0 actual] - (n.= 0 actual)))))) - -(exception: #export invalid_end_of_archive) - -(def: end_of_archive_parser - (Parser Any) - (do <>.monad - [_ (<>.at_most 2 end_of_archive_block_parser) - done? <b>.end?] - (<>.lift - (exception.assert ..invalid_end_of_archive [] - done?)))) - -(def: #export parser - (Parser Tar) - (|> (<>.some entry_parser) - (\ <>.monad map row.from_list) - (<>.before ..end_of_archive_parser))) diff --git a/stdlib/source/lux/data/format/xml.lux b/stdlib/source/lux/data/format/xml.lux deleted file mode 100644 index 4097d1171..000000000 --- a/stdlib/source/lux/data/format/xml.lux +++ /dev/null @@ -1,298 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)] - [equivalence (#+ Equivalence)] - [codec (#+ Codec)]] - [control - [try (#+ Try)] - ["<>" parser ("#\." monad) - ["<.>" text (#+ Parser)]]] - [data - ["." product] - ["." name ("#\." equivalence codec)] - ["." text ("#\." equivalence monoid)] - [collection - ["." list ("#\." functor)] - ["." dictionary (#+ Dictionary)]]] - [math - [number - ["n" nat] - ["." int]]]]) - -(type: #export Tag - Name) - -(type: #export Attribute - Name) - -(type: #export Attrs - (Dictionary Attribute Text)) - -(def: #export attributes - Attrs - (dictionary.new name.hash)) - -(type: #export #rec XML - (#Text Text) - (#Node Tag Attrs (List XML))) - -(def: namespace_separator - ":") - -(def: xml_standard_escape_char^ - (Parser Text) - ($_ <>.either - (<>.after (<text>.this "<") (<>\wrap "<")) - (<>.after (<text>.this ">") (<>\wrap ">")) - (<>.after (<text>.this "&") (<>\wrap "&")) - (<>.after (<text>.this "'") (<>\wrap "'")) - (<>.after (<text>.this """) (<>\wrap text.double_quote)) - )) - -(def: xml_unicode_escape_char^ - (Parser Text) - (|> (do <>.monad - [hex? (<>.maybe (<text>.this "x")) - code (case hex? - #.None - (<>.codec int.decimal (<text>.many <text>.decimal)) - - (#.Some _) - (<>.codec int.decimal (<text>.many <text>.hexadecimal)))] - (wrap (|> code .nat text.from_code))) - (<>.before (<text>.this ";")) - (<>.after (<text>.this "&#")))) - -(def: xml_escape_char^ - (Parser Text) - (<>.either xml_standard_escape_char^ - xml_unicode_escape_char^)) - -(def: xml_char^ - (Parser Text) - (<>.either (<text>.none_of ($_ text\compose "<>&" text.double_quote)) - xml_escape_char^)) - -(def: xml_identifier - (Parser Text) - (do <>.monad - [head (<>.either (<text>.one_of "_") - <text>.alpha) - tail (<text>.some (<>.either (<text>.one_of "_.-") - <text>.alpha_num))] - (wrap ($_ text\compose head tail)))) - -(def: namespaced_symbol^ - (Parser Name) - (do <>.monad - [first_part xml_identifier - ?second_part (<| <>.maybe (<>.after (<text>.this ..namespace_separator)) xml_identifier)] - (case ?second_part - #.None - (wrap ["" first_part]) - - (#.Some second_part) - (wrap [first_part second_part])))) - -(def: tag^ namespaced_symbol^) -(def: attr_name^ namespaced_symbol^) - -(def: spaced^ - (All [a] (-> (Parser a) (Parser a))) - (let [white_space^ (<>.some <text>.space)] - (|>> (<>.before white_space^) - (<>.after white_space^)))) - -(def: attr_value^ - (Parser Text) - (let [value^ (<text>.some xml_char^)] - (<>.either (<text>.enclosed [text.double_quote text.double_quote] value^) - (<text>.enclosed ["'" "'"] value^)))) - -(def: attrs^ - (Parser Attrs) - (<| (\ <>.monad map (dictionary.from_list name.hash)) - <>.some - (<>.and (..spaced^ attr_name^)) - (<>.after (<text>.this "=")) - (..spaced^ attr_value^))) - -(def: (close_tag^ expected) - (-> Tag (Parser [])) - (do <>.monad - [actual (|> tag^ - ..spaced^ - (<>.after (<text>.this "/")) - (<text>.enclosed ["<" ">"]))] - (<>.assert ($_ text\compose "Close tag does not match open tag." text.new_line - "Expected: " (name\encode expected) text.new_line - " Actual: " (name\encode actual) text.new_line) - (name\= expected actual)))) - -(def: comment^ - (Parser Text) - (|> (<text>.not (<text>.this "--")) - <text>.some - (<text>.enclosed ["<!--" "-->"]) - ..spaced^)) - -(def: xml_header^ - (Parser Attrs) - (|> (..spaced^ attrs^) - (<>.before (<text>.this "?>")) - (<>.after (<text>.this "<?xml")) - ..spaced^)) - -(def: cdata^ - (Parser Text) - (let [end (<text>.this "]]>")] - (|> (<text>.some (<text>.not end)) - (<>.after end) - (<>.after (<text>.this "<![CDATA[")) - ..spaced^))) - -(def: text^ - (Parser XML) - (|> (..spaced^ (<text>.many xml_char^)) - (<>.either cdata^) - (<>\map (|>> #Text)))) - -(def: null^ - (Parser Any) - (<text>.this (text.from_code 0))) - -(def: xml^ - (Parser XML) - (|> (<>.rec - (function (_ node^) - (|> (do <>.monad - [_ (<text>.this "<") - tag (..spaced^ tag^) - attrs (..spaced^ attrs^) - #let [no_children^ ($_ <>.either - (do <>.monad - [_ (<text>.this "/>")] - (wrap (#Node tag attrs (list)))) - (do <>.monad - [_ (<text>.this ">") - _ (<>.some (<>.either <text>.space - ..comment^)) - _ (..close_tag^ tag)] - (wrap (#Node tag attrs (list))))) - with_children^ (do <>.monad - [_ (<text>.this ">") - children (<>.many node^) - _ (..close_tag^ tag)] - (wrap (#Node tag attrs children)))]] - ($_ <>.either - no_children^ - with_children^)) - ..spaced^ - (<>.before (<>.some ..comment^)) - (<>.after (<>.some ..comment^)) - (<>.either ..text^)))) - (<>.before (<>.some ..null^)) - (<>.after (<>.maybe ..xml_header^)))) - -(def: read - (-> Text (Try XML)) - (<text>.run xml^)) - -(def: (sanitize_value input) - (-> Text Text) - (|> input - (text.replace_all "&" "&") - (text.replace_all "<" "<") - (text.replace_all ">" ">") - (text.replace_all "'" "'") - (text.replace_all text.double_quote """))) - -(def: #export (tag [namespace name]) - (-> Tag Text) - (case namespace - "" name - _ ($_ text\compose namespace ..namespace_separator name))) - -(def: #export attribute - (-> Attribute Text) - ..tag) - -(def: (write_attrs attrs) - (-> Attrs Text) - (|> attrs - dictionary.entries - (list\map (function (_ [key value]) - ($_ text\compose (..attribute key) "=" text.double_quote (sanitize_value value) text.double_quote))) - (text.join_with " "))) - -(def: xml_header - Text - (let [quote (: (-> Text Text) - (function (_ value) - ($_ text\compose text.double_quote value text.double_quote)))] - ($_ text\compose - "<?xml" - " version=" (quote "1.0") - " encoding=" (quote "UTF-8") - "?>"))) - -(def: (write input) - (-> XML Text) - ($_ text\compose - ..xml_header text.new_line - (loop [prefix "" - input input] - (case input - (#Text value) - (sanitize_value value) - - (^ (#Node xml_tag xml_attrs (list (#Text value)))) - (let [tag (..tag xml_tag) - attrs (if (dictionary.empty? xml_attrs) - "" - ($_ text\compose " " (..write_attrs xml_attrs)))] - ($_ text\compose - prefix "<" tag attrs ">" - (sanitize_value value) - "</" tag ">")) - - (#Node xml_tag xml_attrs xml_children) - (let [tag (..tag xml_tag) - attrs (if (dictionary.empty? xml_attrs) - "" - ($_ text\compose " " (..write_attrs xml_attrs)))] - (if (list.empty? xml_children) - ($_ text\compose prefix "<" tag attrs "/>") - ($_ text\compose prefix "<" tag attrs ">" - (|> xml_children - (list\map (|>> (recur (text\compose prefix text.tab)) (text\compose text.new_line))) - (text.join_with "")) - text.new_line prefix "</" tag ">"))))) - )) - -(implementation: #export codec - (Codec Text XML) - - (def: encode ..write) - (def: decode ..read)) - -(implementation: #export equivalence - (Equivalence XML) - - (def: (= reference sample) - (case [reference sample] - [(#Text reference/value) (#Text sample/value)] - (text\= reference/value sample/value) - - [(#Node reference/tag reference/attrs reference/children) - (#Node sample/tag sample/attrs sample/children)] - (and (name\= reference/tag sample/tag) - (\ (dictionary.equivalence text.equivalence) = reference/attrs sample/attrs) - (n.= (list.size reference/children) - (list.size sample/children)) - (|> (list.zip/2 reference/children sample/children) - (list.every? (product.uncurry =)))) - - _ - false))) diff --git a/stdlib/source/lux/data/identity.lux b/stdlib/source/lux/data/identity.lux deleted file mode 100644 index 35b44ec62..000000000 --- a/stdlib/source/lux/data/identity.lux +++ /dev/null @@ -1,37 +0,0 @@ -(.module: - [lux #* - [abstract - [functor (#+ Functor)] - [apply (#+ Apply)] - [monad (#+ Monad)] - [comonad (#+ CoMonad)]] - [control - ["." function]]]) - -(type: #export (Identity a) - a) - -(implementation: #export functor - (Functor Identity) - - (def: map function.identity)) - -(implementation: #export apply - (Apply Identity) - - (def: &functor ..functor) - (def: (apply ff fa) (ff fa))) - -(implementation: #export monad - (Monad Identity) - - (def: &functor ..functor) - (def: wrap function.identity) - (def: join function.identity)) - -(implementation: #export comonad - (CoMonad Identity) - - (def: &functor ..functor) - (def: unwrap function.identity) - (def: split function.identity)) diff --git a/stdlib/source/lux/data/lazy.lux b/stdlib/source/lux/data/lazy.lux deleted file mode 100644 index adc8458e6..000000000 --- a/stdlib/source/lux/data/lazy.lux +++ /dev/null @@ -1,67 +0,0 @@ -(.module: - [lux #* - [abstract - [functor (#+ Functor)] - [apply (#+ Apply)] - [monad (#+ Monad do)] - [equivalence (#+ Equivalence)]] - [control - ["." io] - [parser - ["s" code]] - [concurrency - ["." atom]]] - [macro (#+ with_gensyms) - [syntax (#+ syntax:)]] - [type - abstract]]) - -(abstract: #export (Lazy a) - (-> [] a) - - (def: (freeze' generator) - (All [a] (-> (-> [] a) (Lazy a))) - (let [cache (atom.atom #.None)] - (:abstraction (function (_ _) - (case (io.run (atom.read cache)) - (#.Some value) - value - - _ - (let [value (generator [])] - (exec (io.run (atom.compare_and_swap _ (#.Some value) cache)) - value))))))) - - (def: #export (thaw l_value) - (All [a] (-> (Lazy a) a)) - ((:representation l_value) []))) - -(syntax: #export (freeze expr) - (with_gensyms [g!_] - (wrap (list (` ((~! freeze') (function ((~ g!_) (~ g!_)) (~ expr)))))))) - -(implementation: #export (equivalence (^open "_\.")) - (All [a] (-> (Equivalence a) (Equivalence (Lazy a)))) - - (def: (= left right) - (_\= (..thaw left) (..thaw right)))) - -(implementation: #export functor - (Functor Lazy) - - (def: (map f fa) - (freeze (f (thaw fa))))) - -(implementation: #export apply - (Apply Lazy) - - (def: &functor ..functor) - (def: (apply ff fa) - (freeze ((thaw ff) (thaw fa))))) - -(implementation: #export monad - (Monad Lazy) - - (def: &functor ..functor) - (def: wrap (|>> freeze)) - (def: join thaw)) diff --git a/stdlib/source/lux/data/maybe.lux b/stdlib/source/lux/data/maybe.lux deleted file mode 100644 index 6376cfebf..000000000 --- a/stdlib/source/lux/data/maybe.lux +++ /dev/null @@ -1,150 +0,0 @@ -(.module: - [lux #* - [abstract - [monoid (#+ Monoid)] - [equivalence (#+ Equivalence)] - [hash (#+ Hash)] - [apply (#+ Apply)] - ["." functor (#+ Functor)] - ["." monad (#+ Monad do)]] - [meta - ["." location]]]) - -## (type: (Maybe a) -## #.None -## (#.Some a)) - -(implementation: #export monoid - (All [a] (Monoid (Maybe a))) - - (def: identity #.None) - - (def: (compose mx my) - (case mx - #.None - my - - (#.Some x) - (#.Some x)))) - -(implementation: #export functor - (Functor Maybe) - - (def: (map f ma) - (case ma - #.None #.None - (#.Some a) (#.Some (f a))))) - -(implementation: #export apply - (Apply Maybe) - - (def: &functor ..functor) - - (def: (apply ff fa) - (case [ff fa] - [(#.Some f) (#.Some a)] - (#.Some (f a)) - - _ - #.None))) - -(implementation: #export monad - (Monad Maybe) - - (def: &functor ..functor) - - (def: (wrap x) - (#.Some x)) - - (def: (join mma) - (case mma - #.None - #.None - - (#.Some mx) - mx))) - -(implementation: #export (equivalence super) - (All [a] (-> (Equivalence a) (Equivalence (Maybe a)))) - - (def: (= mx my) - (case [mx my] - [#.None #.None] - #1 - - [(#.Some x) (#.Some y)] - (\ super = x y) - - _ - #0))) - -(implementation: #export (hash super) - (All [a] (-> (Hash a) (Hash (Maybe a)))) - - (def: &equivalence - (..equivalence (\ super &equivalence))) - - (def: (hash value) - (case value - #.None - 0 - - (#.Some value) - (\ super hash value)))) - -(implementation: #export (with monad) - (All [M] (-> (Monad M) (Monad (All [a] (M (Maybe a)))))) - - (def: &functor (functor.compose (get@ #monad.&functor monad) ..functor)) - - (def: wrap (|>> (\ ..monad wrap) (\ monad wrap))) - - (def: (join MmMma) - (do monad - [mMma MmMma] - (case mMma - #.None - (wrap #.None) - - (#.Some Mma) - Mma)))) - -(def: #export (lift monad) - (All [M a] (-> (Monad M) (-> (M a) (M (Maybe a))))) - (\ monad map (\ ..monad wrap))) - -(macro: #export (default tokens state) - {#.doc (doc "Allows you to provide a default value that will be used" - "if a (Maybe x) value turns out to be #.None." - "Note: the expression for the default value will not be computed if the base computation succeeds." - (default +20 (#.Some +10)) - "=>" - +10 - (default +20 #.None) - "=>" - +20)} - (case tokens - (^ (list else maybe)) - (let [g!temp (: Code [location.dummy (#.Identifier ["" ""])])] - (#.Right [state (list (` (case (~ maybe) - (#.Some (~ g!temp)) - (~ g!temp) - - #.None - (~ else))))])) - - _ - (#.Left "Wrong syntax for default"))) - -(def: #export assume - (All [a] (-> (Maybe a) a)) - (|>> (..default (undefined)))) - -(def: #export (to-list value) - (All [a] (-> (Maybe a) (List a))) - (case value - #.None - #.Nil - - (#.Some value) - (#.Cons value #.Nil))) diff --git a/stdlib/source/lux/data/name.lux b/stdlib/source/lux/data/name.lux deleted file mode 100644 index 539b9a99f..000000000 --- a/stdlib/source/lux/data/name.lux +++ /dev/null @@ -1,63 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)] - [order (#+ Order)] - [codec (#+ Codec)]] - [data - ["." text ("#\." equivalence monoid)] - ["." product]]]) - -## (type: Name -## [Text Text]) - -(template [<name> <side>] - [(def: #export (<name> [module short]) - (-> Name Text) - <side>)] - - [module module] - [short short] - ) - -(def: #export hash - (Hash Name) - (product.hash text.hash text.hash)) - -(def: #export equivalence - (Equivalence Name) - (\ ..hash &equivalence)) - -(implementation: #export order - (Order Name) - - (def: &equivalence ..equivalence) - (def: (< [moduleP shortP] [moduleS shortS]) - (if (text\= moduleP moduleS) - (\ text.order < shortP shortS) - (\ text.order < moduleP moduleS)))) - -(def: separator - ".") - -(implementation: #export codec - (Codec Text Name) - - (def: (encode [module short]) - (case module - "" short - _ ($_ text\compose module ..separator short))) - - (def: (decode input) - (if (text\= "" input) - (#.Left (text\compose "Invalid format for Name: " input)) - (case (text.split_all_with ..separator input) - (^ (list short)) - (#.Right ["" short]) - - (^ (list module short)) - (#.Right [module short]) - - _ - (#.Left (text\compose "Invalid format for Name: " input)))))) diff --git a/stdlib/source/lux/data/product.lux b/stdlib/source/lux/data/product.lux deleted file mode 100644 index 9a8c37fb2..000000000 --- a/stdlib/source/lux/data/product.lux +++ /dev/null @@ -1,68 +0,0 @@ -(.module: - {#.doc "Functionality for working with tuples (particularly 2-tuples)."} - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)]]]) - -(template [<name> <type> <output>] - [(def: #export (<name> xy) - (All [a b] (-> (& a b) <type>)) - (let [[x y] xy] - <output>))] - - [left a x] - [right b y] - ) - -(def: #export (curry f) - (All [a b c] - (-> (-> (& a b) c) - (-> a b c))) - (function (_ x y) - (f [x y]))) - -(def: #export (uncurry f) - (All [a b c] - (-> (-> a b c) - (-> (& a b) c))) - (function (_ xy) - (let [[x y] xy] - (f x y)))) - -(def: #export (swap xy) - (All [a b] (-> (& a b) (& b a))) - (let [[x y] xy] - [y x])) - -(def: #export (apply f g) - (All [a b c d] - (-> (-> a c) (-> b d) - (-> (& a b) (& c d)))) - (function (_ [x y]) - [(f x) (g y)])) - -(def: #export (fork f g) - (All [a l r] - (-> (-> a l) (-> a r) - (-> a (& l r)))) - (function (_ x) - [(f x) (g x)])) - -(implementation: #export (equivalence left right) - (All [l r] (-> (Equivalence l) (Equivalence r) (Equivalence [l r]))) - - (def: (= [rl rr] [sl sr]) - (and (\ left = rl sl) - (\ right = rr sr)))) - -(def: #export (hash left right) - (All [l r] (-> (Hash l) (Hash r) (Hash (& l r)))) - (implementation - (def: &equivalence - (..equivalence (\ left &equivalence) - (\ right &equivalence))) - (def: (hash [leftV rightV]) - ("lux i64 +" - (\ left hash leftV) - (\ right hash rightV))))) diff --git a/stdlib/source/lux/data/store.lux b/stdlib/source/lux/data/store.lux deleted file mode 100644 index 52842eac9..000000000 --- a/stdlib/source/lux/data/store.lux +++ /dev/null @@ -1,49 +0,0 @@ -(.module: - [lux #* - [abstract - [functor (#+ Functor)] - comonad] - [type - implicit]]) - -(type: #export (Store s a) - {#cursor s - #peek (-> s a)}) - -(def: (extend f wa) - (All [s a b] (-> (-> (Store s a) b) (Store s a) (Store s b))) - {#cursor (get@ #cursor wa) - #peek (function (_ s) (f (set@ #cursor s wa)))}) - -(implementation: #export functor - (All [s] (Functor (Store s))) - - (def: (map f fa) - (extend (function (_ store) - (f (\ store peek (\ store cursor)))) - fa))) - -(implementation: #export comonad - (All [s] (CoMonad (Store s))) - - (def: &functor ..functor) - - (def: (unwrap wa) (\\ peek (\\ cursor))) - - (def: split (extend id))) - -(def: #export (peeks trans store) - (All [s a] (-> (-> s s) (Store s a) a)) - (|> (\\ cursor) trans (\\ peek))) - -(def: #export (seek cursor store) - (All [s a] (-> s (Store s a) (Store s a))) - (\ (\\ split store) peek cursor)) - -(def: #export (seeks change store) - (All [s a] (-> (-> s s) (Store s a) (Store s a))) - (|> store (\\ split) (peeks change))) - -(def: #export (experiment Functor<f> change store) - (All [f s a] (-> (Functor f) (-> s (f s)) (Store s a) (f a))) - (\ Functor<f> map (\\ peek) (change (\\ cursor)))) diff --git a/stdlib/source/lux/data/sum.lux b/stdlib/source/lux/data/sum.lux deleted file mode 100644 index bb0e6d0e7..000000000 --- a/stdlib/source/lux/data/sum.lux +++ /dev/null @@ -1,89 +0,0 @@ -(.module: - {#.doc "Functionality for working with variants (particularly 2-variants)."} - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)]]]) - -(template [<name> <type> <right?>] - [(def: #export (<name> value) - (All [a b] (-> <type> (| a b))) - (0 <right?> value))] - - [left a #0] - [right b #1]) - -(def: #export (either fl fr) - (All [a b c] - (-> (-> a c) (-> b c) - (-> (| a b) c))) - (function (_ input) - (case input - (0 #0 l) (fl l) - (0 #1 r) (fr r)))) - -(def: #export (apply fl fr) - (All [l l' r r'] - (-> (-> l l') (-> r r') - (-> (| l r) (| l' r')))) - (function (_ input) - (case input - (0 #0 l) (0 #0 (fl l)) - (0 #1 r) (0 #1 (fr r))))) - -(template [<name> <side> <right?>] - [(def: #export (<name> es) - (All [a b] (-> (List (| a b)) (List <side>))) - (case es - #.Nil - #.Nil - - (#.Cons (0 <right?> x) es') - (#.Cons [x (<name> es')]) - - (#.Cons _ es') - (<name> es')))] - - [lefts a #0] - [rights b #1] - ) - -(def: #export (partition xs) - (All [a b] (-> (List (| a b)) [(List a) (List b)])) - (case xs - #.Nil - [#.Nil #.Nil] - - (#.Cons x xs') - (let [[lefts rights] (partition xs')] - (case x - (0 #0 x') [(#.Cons x' lefts) rights] - (0 #1 x') [lefts (#.Cons x' rights)])))) - -(def: #export (equivalence left right) - (All [l r] (-> (Equivalence l) (Equivalence r) (Equivalence (| l r)))) - (implementation - (def: (= reference sample) - (case [reference sample] - [(#.Left reference) (#.Left sample)] - (\ left = reference sample) - - [(#.Right reference) (#.Right sample)] - (\ right = reference sample) - - _ - false)))) - -(def: #export (hash left right) - (All [l r] (-> (Hash l) (Hash r) (Hash (| l r)))) - (implementation - (def: &equivalence - (..equivalence (\ left &equivalence) - (\ right &equivalence))) - (def: (hash value) - (case value - (#.Left value) - (\ left hash value) - - (#.Right value) - (\ right hash value))))) diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux deleted file mode 100644 index 1c54218f9..000000000 --- a/stdlib/source/lux/data/text.lux +++ /dev/null @@ -1,379 +0,0 @@ -(.module: - [lux #* - ["@" target] - [abstract - [hash (#+ Hash)] - [monoid (#+ Monoid)] - [equivalence (#+ Equivalence)] - [order (#+ Order)] - [monad (#+ Monad do)] - [codec (#+ Codec)]] - [data - ["." maybe] - [collection - ["." list ("#\." fold)]]] - [math - [number - ["n" nat] - ["." i64]]]]) - -(type: #export Char - Nat) - -## TODO: Instead of ints, chars should be produced fron nats. -## (The JVM specifies chars as 16-bit unsigned integers) -(def: #export from_code - (-> Char Text) - (|>> .int "lux i64 char")) - -(template [<code> <short> <long>] - [(def: #export <long> (from_code <code>)) - (def: #export <short> <long>)] - - [00 \0 null] - [07 \a alarm] - [08 \b back_space] - [09 \t tab] - [10 \n new_line] - [11 \v vertical_tab] - [12 \f form_feed] - [13 \r carriage_return] - [34 \'' double_quote] - ) - -(def: #export line_feed ..new_line) - -(def: #export size - (-> Text Nat) - (|>> "lux text size")) - -(def: #export (nth idx input) - (-> Nat Text (Maybe Char)) - (if (n.< ("lux text size" input) idx) - (#.Some ("lux text char" idx input)) - #.None)) - -(def: #export (index_of' pattern from input) - (-> Text Nat Text (Maybe Nat)) - ("lux text index" from pattern input)) - -(def: #export (index_of pattern input) - (-> Text Text (Maybe Nat)) - ("lux text index" 0 pattern input)) - -(def: (last_index_of'' part since text) - (-> Text Nat Text (Maybe Nat)) - (case ("lux text index" (inc since) part text) - #.None - (#.Some since) - - (#.Some since') - (last_index_of'' part since' text))) - -(def: #export (last_index_of' part from text) - (-> Text Nat Text (Maybe Nat)) - (case ("lux text index" from part text) - (#.Some since) - (last_index_of'' part since text) - - #.None - #.None)) - -(def: #export (last_index_of part text) - (-> Text Text (Maybe Nat)) - (case ("lux text index" 0 part text) - (#.Some since) - (last_index_of'' part since text) - - #.None - #.None)) - -(def: #export (starts_with? prefix x) - (-> Text Text Bit) - (case (index_of prefix x) - (#.Some 0) - true - - _ - false)) - -(def: #export (ends_with? postfix x) - (-> Text Text Bit) - (case (last_index_of postfix x) - (#.Some n) - (n.= (size x) - (n.+ (size postfix) n)) - - _ - false)) - -(def: #export (encloses? boundary value) - (-> Text Text Bit) - (and (starts_with? boundary value) - (ends_with? boundary value))) - -(def: #export (contains? sub text) - (-> Text Text Bit) - (case ("lux text index" 0 sub text) - (#.Some _) - true - - _ - false)) - -(def: #export (prefix param subject) - (-> Text Text Text) - ("lux text concat" param subject)) - -(def: #export (suffix param subject) - (-> Text Text Text) - ("lux text concat" subject param)) - -(def: #export (enclose [left right] content) - {#.doc "Surrounds the given content text with left and right side additions."} - (-> [Text Text] Text Text) - ($_ "lux text concat" left content right)) - -(def: #export (enclose' boundary content) - {#.doc "Surrounds the given content text with the same boundary text."} - (-> Text Text Text) - (enclose [boundary boundary] content)) - -(def: #export format - (-> Text Text) - (..enclose' ..double_quote)) - -(def: #export (clip offset characters input) - (-> Nat Nat Text (Maybe Text)) - (if (|> characters (n.+ offset) (n.<= ("lux text size" input))) - (#.Some ("lux text clip" offset characters input)) - #.None)) - -(def: #export (clip' offset input) - (-> Nat Text (Maybe Text)) - (let [size ("lux text size" input)] - (if (n.<= size offset) - (#.Some ("lux text clip" offset (n.- offset size) input)) - #.None))) - -(def: #export (split at x) - (-> Nat Text (Maybe [Text Text])) - (case [(..clip 0 at x) (..clip' at x)] - [(#.Some pre) (#.Some post)] - (#.Some [pre post]) - - _ - #.None)) - -(def: #export (split_with token sample) - (-> Text Text (Maybe [Text Text])) - (do maybe.monad - [index (index_of token sample) - [pre post'] (split index sample) - [_ post] (split (size token) post')] - (wrap [pre post]))) - -(def: #export (split_all_with token sample) - (-> Text Text (List Text)) - (loop [input sample - output (: (List Text) (list))] - (case (..split_with token input) - (#.Some [pre post]) - (|> output - (#.Cons pre) - (recur post)) - - #.None - (|> output - (#.Cons input) - list.reverse)))) - -(def: #export (replace_once pattern replacement template) - (-> Text Text Text Text) - (<| (maybe.default template) - (do maybe.monad - [[pre post] (..split_with pattern template)] - (wrap ($_ "lux text concat" pre replacement post))))) - -(def: #export (replace_all pattern replacement template) - (-> Text Text Text Text) - (for {@.old - (:as Text - ("jvm invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence" - (:as (primitive "java.lang.String") template) - (:as (primitive "java.lang.CharSequence") pattern) - (:as (primitive "java.lang.CharSequence") replacement))) - @.jvm - (:as Text - ("jvm member invoke virtual" [] "java.lang.String" "replace" [] - (:as (primitive "java.lang.String") template) - ["Ljava/lang/CharSequence;" (:as (primitive "java.lang.CharSequence") pattern)] - ["Ljava/lang/CharSequence;" (:as (primitive "java.lang.CharSequence") replacement)])) - ## TODO: Comment/turn-off when generating a JS compiler using a JVM-based compiler because Nashorn's implementation of "replaceAll" is incorrect. - @.js - (:as Text - ("js object do" "replaceAll" template [pattern replacement])) - @.python - (:as Text - ("python object do" "replace" template pattern replacement)) - ## TODO @.lua - @.ruby - (:as Text - ("ruby object do" "gsub" template pattern replacement)) - @.php - (:as Text - ("php apply" (:assume ("php constant" "str_replace")) - pattern replacement template)) - ## TODO @.scheme - ## TODO @.common_lisp - ## TODO @.r - } - ## Inefficient default - (loop [left "" - right template] - (case (..split_with pattern right) - (#.Some [pre post]) - (recur ($_ "lux text concat" left pre replacement) post) - - #.None - ("lux text concat" left right))))) - -(implementation: #export equivalence - (Equivalence Text) - - (def: (= reference sample) - ("lux text =" reference sample))) - -(implementation: #export order - (Order Text) - - (def: &equivalence ..equivalence) - - (def: (< reference sample) - ("lux text <" reference sample))) - -(implementation: #export monoid - (Monoid Text) - - (def: identity "") - - (def: (compose left right) - ("lux text concat" left right))) - -(implementation: #export hash - (Hash Text) - - (def: &equivalence ..equivalence) - - (def: (hash input) - (for {@.old - (|> input - (: (primitive "java.lang.String")) - "jvm invokevirtual:java.lang.String:hashCode:" - "jvm convert int-to-long" - (:as Nat)) - - @.jvm - (|> input - (:as (primitive "java.lang.String")) - ("jvm member invoke virtual" [] "java.lang.String" "hashCode" []) - "jvm conversion int-to-long" - "jvm object cast" - (: (primitive "java.lang.Long")) - (:as Nat))} - ## Platform-independent default. - (let [length ("lux text size" input)] - (loop [idx 0 - hash 0] - (if (n.< length idx) - (recur (inc idx) - (|> hash - (i64.left_shift 5) - (n.- hash) - (n.+ ("lux text char" idx input)))) - hash)))))) - -(def: #export concat - (-> (List Text) Text) - (let [(^open ".") ..monoid] - (|>> list.reverse (list\fold compose identity)))) - -(def: #export (join_with sep texts) - (-> Text (List Text) Text) - (|> texts (list.interpose sep) concat)) - -(def: #export (empty? text) - (-> Text Bit) - (case text - "" true - _ false)) - -(def: #export space - Text - " ") - -(def: #export (space? char) - {#.doc "Checks whether the character is white-space."} - (-> Char Bit) - (with_expansions [<options> (template [<char>] - [(^ (char (~~ (static <char>))))] - - [..tab] - [..vertical_tab] - [..space] - [..new_line] - [..carriage_return] - [..form_feed] - )] - (`` (case char - (^or <options>) - true - - _ - false)))) - -(def: #export (lower_case value) - (-> Text Text) - (for {@.old - (:as Text - ("jvm invokevirtual:java.lang.String:toLowerCase:" - (:as (primitive "java.lang.String") value))) - @.jvm - (:as Text - ("jvm member invoke virtual" [] "java.lang.String" "toLowerCase" [] - (:as (primitive "java.lang.String") value))) - @.js - (:as Text - ("js object do" "toLowerCase" value [])) - @.python - (:as Text - ("python object do" "lower" value)) - @.lua - (:as Text - ("lua apply" ("lua constant" "string.lower") value)) - @.ruby - (:as Text - ("ruby object do" "downcase" value))})) - -(def: #export (upper_case value) - (-> Text Text) - (for {@.old - (:as Text - ("jvm invokevirtual:java.lang.String:toUpperCase:" - (:as (primitive "java.lang.String") value))) - @.jvm - (:as Text - ("jvm member invoke virtual" [] "java.lang.String" "toUpperCase" [] - (:as (primitive "java.lang.String") value))) - @.js - (:as Text - ("js object do" "toUpperCase" value [])) - @.python - (:as Text - ("python object do" "upper" value)) - @.lua - (:as Text - ("lua apply" ("lua constant" "string.upper") value)) - @.ruby - (:as Text - ("ruby object do" "upcase" value))})) diff --git a/stdlib/source/lux/data/text/buffer.lux b/stdlib/source/lux/data/text/buffer.lux deleted file mode 100644 index d07b10567..000000000 --- a/stdlib/source/lux/data/text/buffer.lux +++ /dev/null @@ -1,114 +0,0 @@ -(.module: - [lux #* - [ffi (#+ import:)] - ["@" target] - [control - ["." function]] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." array] - ["." row (#+ Row) ("#\." fold)]]] - [math - [number - ["n" nat]]] - [type - abstract]] - ["." //]) - -(with_expansions [<jvm> (as_is (import: java/lang/CharSequence) - - (import: java/lang/Appendable - ["#::." - (append [java/lang/CharSequence] java/lang/Appendable)]) - - (import: java/lang/String - ["#::." - (new [int]) - (toString [] java/lang/String)]) - - (import: java/lang/StringBuilder - ["#::." - (new [int]) - (toString [] java/lang/String)]))] - (`` (for {@.old (as_is <jvm>) - @.jvm (as_is <jvm>) - @.lua (as_is (import: (table/concat [(array.Array Text) Text] Text)) - ##https://www.lua.org/manual/5.3/manual.html#pdf-table.concat - (import: (table/insert [(array.Array Text) Text] #? Nothing)) - ## https://www.lua.org/manual/5.3/manual.html#pdf-table.insert - )} - (as_is)))) - -(`` (abstract: #export Buffer - (for {@.old [Nat (-> java/lang/StringBuilder java/lang/StringBuilder)] - @.jvm [Nat (-> java/lang/StringBuilder java/lang/StringBuilder)] - @.lua [Nat (-> (array.Array Text) (array.Array Text))]} - ## default - (Row Text)) - - {#.doc "Immutable text buffer for efficient text concatenation."} - - (def: #export empty - Buffer - (:abstraction (with_expansions [<jvm> [0 function.identity]] - (for {@.old <jvm> - @.jvm <jvm> - @.lua [0 function.identity]} - ## default - row.empty)))) - - (def: #export (append chunk buffer) - (-> Text Buffer Buffer) - (with_expansions [<jvm> (let [[capacity transform] (:representation buffer) - append! (: (-> Text java/lang/StringBuilder java/lang/StringBuilder) - (function (_ chunk builder) - (exec - (java/lang/Appendable::append (:as java/lang/CharSequence chunk) - builder) - builder)))] - (:abstraction [(n.+ (//.size chunk) capacity) - (|>> transform (append! chunk))]))] - (for {@.old <jvm> - @.jvm <jvm> - @.lua (let [[capacity transform] (:representation buffer) - append! (: (-> Text (array.Array Text) (array.Array Text)) - (function (_ chunk array) - (exec - (table/insert [array chunk]) - array)))] - (:abstraction [(n.+ (//.size chunk) capacity) - (|>> transform (append! chunk))]))} - ## default - (|> buffer :representation (row.add chunk) :abstraction)))) - - (def: #export size - (-> Buffer Nat) - (with_expansions [<jvm> (|>> :representation product.left)] - (for {@.old <jvm> - @.jvm <jvm> - @.lua <jvm>} - ## default - (|>> :representation - (row\fold (function (_ chunk total) - (n.+ (//.size chunk) total)) - 0))))) - - (def: #export (text buffer) - (-> Buffer Text) - (with_expansions [<jvm> (let [[capacity transform] (:representation buffer)] - (|> (java/lang/StringBuilder::new (.int capacity)) - transform - java/lang/StringBuilder::toString))] - (for {@.old <jvm> - @.jvm <jvm> - @.lua (let [[capacity transform] (:representation buffer)] - (table/concat [(transform (array.new 0)) ""]))} - ## default - (row\fold (function (_ chunk total) - (format total chunk)) - "" - (:representation buffer))))) - )) diff --git a/stdlib/source/lux/data/text/encoding.lux b/stdlib/source/lux/data/text/encoding.lux deleted file mode 100644 index 92f68dfe0..000000000 --- a/stdlib/source/lux/data/text/encoding.lux +++ /dev/null @@ -1,162 +0,0 @@ -(.module: - [lux #* - [type - abstract]]) - -## https://docs.oracle.com/javase/8/docs/technotes/guides/intl/encoding.doc.html - -(abstract: #export Encoding - Text - - (template [<name> <encoding>] - [(def: #export <name> Encoding (:abstraction <encoding>))] - - [ascii "ASCII"] - - [ibm_37 "IBM037"] - [ibm_273 "IBM273"] - [ibm_277 "IBM277"] - [ibm_278 "IBM278"] - [ibm_280 "IBM280"] - [ibm_284 "IBM284"] - [ibm_285 "IBM285"] - [ibm_290 "IBM290"] - [ibm_297 "IBM297"] - [ibm_300 "IBM300"] - [ibm_420 "IBM420"] - [ibm_424 "IBM424"] - [ibm_437 "IBM437"] - [ibm_500 "IBM500"] - [ibm_737 "IBM737"] - [ibm_775 "IBM775"] - [ibm_833 "IBM833"] - [ibm_834 "IBM834"] - [ibm_838 "IBM-Thai"] - [ibm_850 "IBM850"] - [ibm_852 "IBM852"] - [ibm_855 "IBM855"] - [ibm_856 "IBM856"] - [ibm_857 "IBM857"] - [ibm_858 "IBM00858"] - [ibm_860 "IBM860"] - [ibm_861 "IBM861"] - [ibm_862 "IBM862"] - [ibm_863 "IBM863"] - [ibm_864 "IBM864"] - [ibm_865 "IBM865"] - [ibm_866 "IBM866"] - [ibm_868 "IBM868"] - [ibm_869 "IBM869"] - [ibm_870 "IBM870"] - [ibm_871 "IBM871"] - [ibm_874 "IBM874"] - [ibm_875 "IBM875"] - [ibm_918 "IBM918"] - [ibm_921 "IBM921"] - [ibm_922 "IBM922"] - [ibm_930 "IBM930"] - [ibm_933 "IBM933"] - [ibm_935 "IBM935"] - [ibm_937 "IBM937"] - [ibm_939 "IBM939"] - [ibm_942 "IBM942"] - [ibm_942c "IBM942C"] - [ibm_943 "IBM943"] - [ibm_943c "IBM943C"] - [ibm_948 "IBM948"] - [ibm_949 "IBM949"] - [ibm_949c "IBM949C"] - [ibm_950 "IBM950"] - [ibm_964 "IBM964"] - [ibm_970 "IBM970"] - [ibm_1006 "IBM1006"] - [ibm_1025 "IBM1025"] - [ibm_1026 "IBM1026"] - [ibm_1046 "IBM1046"] - [ibm_1047 "IBM1047"] - [ibm_1097 "IBM1097"] - [ibm_1098 "IBM1098"] - [ibm_1112 "IBM1112"] - [ibm_1122 "IBM1122"] - [ibm_1123 "IBM1123"] - [ibm_1124 "IBM1124"] - [ibm_1140 "IBM01140"] - [ibm_1141 "IBM01141"] - [ibm_1142 "IBM01142"] - [ibm_1143 "IBM01143"] - [ibm_1144 "IBM01144"] - [ibm_1145 "IBM01145"] - [ibm_1146 "IBM01146"] - [ibm_1147 "IBM01147"] - [ibm_1148 "IBM01148"] - [ibm_1149 "IBM01149"] - [ibm_1166 "IBM1166"] - [ibm_1364 "IBM1364"] - [ibm_1381 "IBM1381"] - [ibm_1383 "IBM1383"] - [ibm_33722 "IBM33722"] - - [iso_2022_cn "ISO-2022-CN"] - [iso2022_cn_cns "ISO2022-CN-CNS"] - [iso2022_cn_gb "ISO2022-CN-GB"] - [iso_2022_jp "ISO-2022-JP"] - [iso_2022_jp_2 "ISO-2022-JP-2"] - [iso_2022_kr "ISO-2022-KR"] - [iso_8859_1 "ISO-8859-1"] - [iso_8859_2 "ISO-8859-2"] - [iso_8859_3 "ISO-8859-3"] - [iso_8859_4 "ISO-8859-4"] - [iso_8859_5 "ISO-8859-5"] - [iso_8859_6 "ISO-8859-6"] - [iso_8859_7 "ISO-8859-7"] - [iso_8859_8 "ISO-8859-8"] - [iso_8859_9 "ISO-8859-9"] - [iso_8859_11 "iso-8859-11"] - [iso_8859_13 "ISO-8859-13"] - [iso_8859_15 "ISO-8859-15"] - - [mac_arabic "MacArabic"] - [mac_central_europe "MacCentralEurope"] - [mac_croatian "MacCroatian"] - [mac_cyrillic "MacCyrillic"] - [mac_dingbat "MacDingbat"] - [mac_greek "MacGreek"] - [mac_hebrew "MacHebrew"] - [mac_iceland "MacIceland"] - [mac_roman "MacRoman"] - [mac_romania "MacRomania"] - [mac_symbol "MacSymbol"] - [mac_thai "MacThai"] - [mac_turkish "MacTurkish"] - [mac_ukraine "MacUkraine"] - - [utf_8 "UTF-8"] - [utf_16 "UTF-16"] - [utf_32 "UTF-32"] - - [windows_31j "windows-31j"] - [windows_874 "windows-874"] - [windows_949 "windows-949"] - [windows_950 "windows-950"] - [windows_1250 "windows-1250"] - [windows_1252 "windows-1252"] - [windows_1251 "windows-1251"] - [windows_1253 "windows-1253"] - [windows_1254 "windows-1254"] - [windows_1255 "windows-1255"] - [windows_1256 "windows-1256"] - [windows_1257 "windows-1257"] - [windows_1258 "windows-1258"] - [windows_iso2022jp "windows-iso2022jp"] - [windows_50220 "windows-50220"] - [windows_50221 "windows-50221"] - - [cesu_8 "CESU-8"] - [koi8_r "KOI8-R"] - [koi8_u "KOI8-U"] - ) - - (def: #export name - (-> Encoding Text) - (|>> :representation)) - ) diff --git a/stdlib/source/lux/data/text/encoding/utf8.lux b/stdlib/source/lux/data/text/encoding/utf8.lux deleted file mode 100644 index 7b9e75524..000000000 --- a/stdlib/source/lux/data/text/encoding/utf8.lux +++ /dev/null @@ -1,163 +0,0 @@ -(.module: - [lux #* - ["@" target] - ["." ffi] - [abstract - [codec (#+ Codec)]] - [control - ["." try (#+ Try)]] - [data - ["." binary (#+ Binary)]]] - ["." //]) - -(with_expansions [<jvm> (as_is (ffi.import: java/lang/String - ["#::." - (new [[byte] java/lang/String]) - (getBytes [java/lang/String] [byte])]))] - (for {@.old (as_is <jvm>) - @.jvm (as_is <jvm>) - - @.js - (as_is (ffi.import: Uint8Array) - - ## On Node - (ffi.import: Buffer - ["#::." - (#static from #as from|encode [ffi.String ffi.String] Buffer) - (#static from #as from|decode [Uint8Array] Buffer) - (toString [ffi.String] ffi.String)]) - - ## On the browser - (ffi.import: TextEncoder - ["#::." - (new [ffi.String]) - (encode [ffi.String] Uint8Array)]) - - (ffi.import: TextDecoder - ["#::." - (new [ffi.String]) - (decode [Uint8Array] ffi.String)])) - - @.ruby - (as_is (ffi.import: String #as RubyString - ["#::." - (encode [Text] RubyString) - (force_encoding [Text] Text) - (bytes [] Binary)]) - - (ffi.import: Array #as RubyArray - ["#::." - (pack [Text] RubyString)])) - - @.php - (as_is (ffi.import: Almost_Binary) - (ffi.import: (unpack [ffi.String ffi.String] Almost_Binary)) - (ffi.import: (array_values [Almost_Binary] Binary)) - (def: php_byte_array_format "C*")) - - @.scheme - ## https://srfi.schemers.org/srfi-140/srfi-140.html - (as_is (ffi.import: (string->utf8 [Text] Binary)) - (ffi.import: (utf8->string [Binary] Text)))} - (as_is))) - -(def: (encode value) - (-> Text Binary) - (for {@.old - (java/lang/String::getBytes (//.name //.utf_8) - ## TODO: Remove coercion below. - ## The coercion below may seem - ## gratuitous, but removing it - ## causes a grave compilation problem. - (:as java/lang/String value)) - - @.jvm - (java/lang/String::getBytes (//.name //.utf_8) value) - - @.js - (cond ffi.on_nashorn? - (:as Binary ("js object do" "getBytes" value ["utf8"])) - - ffi.on_node_js? - (|> (Buffer::from|encode [value "utf8"]) - ## This coercion is valid as per NodeJS's documentation: - ## https://nodejs.org/api/buffer.html#buffer_buffers_and_typedarrays - (:as Uint8Array)) - - ## On the browser - (|> (TextEncoder::new [(//.name //.utf_8)]) - (TextEncoder::encode [value])) - ) - - @.python - (:as Binary ("python apply" (:assume ("python constant" "bytearray")) value "utf-8")) - - @.lua - ("lua utf8 encode" value) - - @.ruby - (|> value - (:as RubyString) - (RubyString::encode ["UTF-8"]) - (RubyString::bytes [])) - - @.php - (|> (..unpack [..php_byte_array_format value]) - ..array_values - ("php object new" "ArrayObject") - (:as Binary)) - - @.scheme - (..string->utf8 value)})) - -(def: (decode value) - (-> Binary (Try Text)) - (with_expansions [<jvm> (#try.Success (java/lang/String::new value (//.name //.utf_8)))] - (for {@.old <jvm> - @.jvm <jvm> - - @.js - (cond ffi.on_nashorn? - (|> ("js object new" ("js constant" "java.lang.String") [value "utf8"]) - (:as Text) - #try.Success) - - ffi.on_node_js? - (|> (Buffer::from|decode [value]) - (Buffer::toString ["utf8"]) - #try.Success) - - ## On the browser - (|> (TextDecoder::new [(//.name //.utf_8)]) - (TextDecoder::decode [value]) - #try.Success)) - - @.python - (try (:as Text ("python object do" "decode" (:assume value) "utf-8"))) - - @.lua - (#try.Success ("lua utf8 decode" value)) - - @.ruby - (|> value - (:as RubyArray) - (RubyArray::pack ["C*"]) - (:as RubyString) - (RubyString::force_encoding ["UTF-8"]) - #try.Success) - - @.php - (|> value - ("php pack" ..php_byte_array_format) - #try.Success) - - @.scheme - (|> value - ..utf8->string - #try.Success)}))) - -(implementation: #export codec - (Codec Binary Text) - - (def: encode ..encode) - (def: decode ..decode)) diff --git a/stdlib/source/lux/data/text/escape.lux b/stdlib/source/lux/data/text/escape.lux deleted file mode 100644 index 7a710ae74..000000000 --- a/stdlib/source/lux/data/text/escape.lux +++ /dev/null @@ -1,243 +0,0 @@ -(.module: - [lux #* - ["." meta] - [abstract - [monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["<>" parser - ["<.>" code]]] - [data - ["." maybe]] - [math - [number (#+ hex) - ["n" nat]]] - [macro - [syntax (#+ syntax:)] - ["." code]]] - ["." // (#+ Char) - ["%" format (#+ format)]]) - -(def: sigil "\") - -(template [<char> <sigil>] - [(def: <char> - (|> <sigil> (//.nth 0) maybe.assume))] - - [sigil_char ..sigil] - [\u_sigil "u"] - ) - -(template [<literal> <sigil> <escaped>] - [(def: <sigil> - (|> <literal> (//.nth 0) maybe.assume)) - - (def: <escaped> - (format ..sigil <literal>))] - - ["0" \0_sigil escaped_\0] - ["a" \a_sigil escaped_\a] - ["b" \b_sigil escaped_\b] - ["t" \t_sigil escaped_\t] - ["n" \n_sigil escaped_\n] - ["v" \v_sigil escaped_\v] - ["f" \f_sigil escaped_\f] - ["r" \r_sigil escaped_\r] - [//.\'' \''_sigil escaped_\''] - [..sigil \\_sigil escaped_\\] - ) - -(template [<char> <text>] - [(def: <char> - (|> <text> (//.nth 0) maybe.assume))] - - [\0 //.\0] - [\a //.\a] - [\b //.\b] - [\t //.\t] - [\n //.\n] - [\v //.\v] - [\f //.\f] - [\r //.\r] - [\'' //.\''] - [\\ ..sigil] - ) - -(def: ascii_bottom (hex "20")) -(def: ascii_top (hex "7E")) - -(def: #export (escapable? char) - (-> Char Bit) - (case char - (^template [<char>] - [(^ (static <char>)) - true]) - ([..\0] [..\a] [..\b] [..\t] - [..\n] [..\v] [..\f] [..\r] - [..\''] [..\\]) - - _ - (or (n.< ..ascii_bottom char) - (n.> ..ascii_top char)))) - -(def: (ascii_escape replacement pre_offset pre_limit previous current) - (-> Text Nat Nat Text Text [Text Text Nat]) - (let [post_offset (inc pre_offset) - post_limit (n.- post_offset pre_limit)] - [(format previous - ("lux text clip" 0 pre_offset current) - replacement) - ("lux text clip" post_offset post_limit current) - post_limit])) - -(def: (unicode_escape char pre_offset pre_limit previous current) - (-> Char Nat Nat Text Text [Text Text Nat]) - (let [code (\ n.hex encode char) - replacement (format ..sigil "u" - (case ("lux text size" code) - 1 (format "000" code) - 2 (format "00" code) - 3 (format "0" code) - _ code)) - post_offset (inc pre_offset) - post_limit (n.- post_offset pre_limit)] - [(format previous - ("lux text clip" 0 pre_offset current) - replacement) - ("lux text clip" post_offset post_limit current) - post_limit])) - -(def: #export (escape text) - (-> Text Text) - (loop [offset 0 - previous "" - current text - limit ("lux text size" text)] - (if (n.< limit offset) - (case ("lux text char" offset current) - (^template [<char> <replacement>] - [(^ (static <char>)) - (let [[previous' current' limit'] (ascii_escape <replacement> offset limit previous current)] - (recur 0 previous' current' limit'))]) - ([..\0 ..escaped_\0] - [..\a ..escaped_\a] - [..\b ..escaped_\b] - [..\t ..escaped_\t] - [..\n ..escaped_\n] - [..\v ..escaped_\v] - [..\f ..escaped_\f] - [..\r ..escaped_\r] - [..\'' ..escaped_\''] - [..\\ ..escaped_\\]) - - char - (if (or (n.< ..ascii_bottom char) - (n.> ..ascii_top char)) - (let [[previous' current' limit'] (unicode_escape char offset limit previous current)] - (recur 0 previous' current' limit')) - (recur (inc offset) previous current limit))) - (format previous current)))) - -(exception: #export (dangling_escape {text Text}) - (exception.report - ["In" (%.text text)] - ["At" (%.nat (dec (//.size text)))])) - -(exception: #export (invalid_escape {text Text} {offset Nat} {sigil Char}) - (exception.report - ["In" (%.text text)] - ["At" (%.nat offset)] - ["Name" (%.text (//.from_code sigil))])) - -(exception: #export (invalid_unicode_escape {text Text} {offset Nat}) - (exception.report - ["In" (%.text text)] - ["At" (%.nat offset)])) - -(def: code_size - 4) - -(def: ascii_escape_offset - 2) - -(def: unicode_escape_offset - (n.+ ..ascii_escape_offset ..code_size)) - -(def: (ascii_un_escape replacement offset previous current limit) - (-> Text Nat Text Text Nat [Text Text Nat]) - (let [limit' (|> limit (n.- offset) (n.- ..ascii_escape_offset))] - [(format previous - ("lux text clip" 0 offset current) - replacement) - ("lux text clip" (n.+ ..ascii_escape_offset offset) limit' current) - limit'])) - -(def: (unicode_un_escape offset previous current limit) - (-> Nat Text Text Nat (Try [Text Text Nat])) - (case (|> current - ("lux text clip" (n.+ ..ascii_escape_offset offset) ..code_size) - (\ n.hex decode)) - (#try.Success char) - (let [limit' (|> limit (n.- offset) (n.- ..unicode_escape_offset))] - (#try.Success [(format previous - ("lux text clip" 0 offset current) - (//.from_code char)) - ("lux text clip" (n.+ ..unicode_escape_offset offset) limit' current) - limit'])) - - (#try.Failure error) - (exception.throw ..invalid_unicode_escape [current offset]))) - -(def: #export (un_escape text) - (-> Text (Try Text)) - (loop [offset 0 - previous "" - current text - limit ("lux text size" text)] - (if (n.< limit offset) - (case ("lux text char" offset current) - (^ (static ..sigil_char)) - (let [@sigil (inc offset)] - (if (n.< limit @sigil) - (case ("lux text char" @sigil current) - (^template [<sigil> <un_escaped>] - [(^ (static <sigil>)) - (let [[previous' current' limit'] (..ascii_un_escape <un_escaped> offset previous current limit)] - (recur 0 previous' current' limit'))]) - ([..\0_sigil //.\0] - [..\a_sigil //.\a] - [..\b_sigil //.\b] - [..\t_sigil //.\t] - [..\n_sigil //.\n] - [..\v_sigil //.\v] - [..\f_sigil //.\f] - [..\r_sigil //.\r] - [..\''_sigil //.\''] - [..\\_sigil ..sigil]) - - (^ (static ..\u_sigil)) - (let [@unicode (n.+ code_size @sigil)] - (if (n.< limit @unicode) - (do try.monad - [[previous' current' limit'] (..unicode_un_escape offset previous current limit)] - (recur 0 previous' current' limit')) - (exception.throw ..invalid_unicode_escape [text offset]))) - - invalid_sigil - (exception.throw ..invalid_escape [text offset invalid_sigil])) - (exception.throw ..dangling_escape [text]))) - - _ - (recur (inc offset) previous current limit)) - (#try.Success (case previous - "" current - _ (format previous current)))))) - -(syntax: #export (escaped {literal <code>.text}) - (case (..un_escape literal) - (#try.Success un_escaped) - (wrap (list (code.text un_escaped))) - - (#try.Failure error) - (meta.fail error))) diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux deleted file mode 100644 index 6deb80074..000000000 --- a/stdlib/source/lux/data/text/format.lux +++ /dev/null @@ -1,134 +0,0 @@ -(.module: - [lux (#- list nat int rev type) - [abstract - [monad (#+ do)] - [functor - ["." contravariant]]] - [control - ["<>" parser - ["<c>" code (#+ Parser)]]] - [data - ["." bit] - ["." name] - ["." text] - [format - ["." xml] - ["." json]] - [collection - ["." list ("#\." monad)]]] - ["." time - ["." instant] - ["." duration] - ["." date] - ["." day] - ["." month]] - [math - ["." modular] - [number - ["." nat] - ["." int] - ["." rev] - ["." frac] - ["." ratio]]] - [macro - [syntax (#+ syntax:)] - ["." code] - ["." template]] - [meta - ["." location]] - ["." type]]) - -(type: #export (Format a) - {#.doc "A way to produce readable text from values."} - (-> a Text)) - -(implementation: #export functor - (contravariant.Functor Format) - - (def: (map f fb) - (|>> f fb))) - -(syntax: #export (format {fragments (<>.many <c>.any)}) - {#.doc (doc "Text interpolation." - (format "Static part " (text static) " does not match URI: " uri))} - (wrap (.list (` ($_ "lux text concat" (~+ fragments)))))) - -(template [<name> <type> <formatter>] - [(def: #export <name> - (Format <type>) - <formatter>)] - - [bit Bit (\ bit.codec encode)] - [nat Nat (\ nat.decimal encode)] - [int Int (\ int.decimal encode)] - [rev Rev (\ rev.decimal encode)] - [frac Frac (\ frac.decimal encode)] - [text Text text.format] - - [ratio ratio.Ratio (\ ratio.codec encode)] - [name Name (\ name.codec encode)] - [location Location location.format] - [code Code code.format] - [type Type type.format] - - [instant instant.Instant (\ instant.codec encode)] - [duration duration.Duration (\ duration.codec encode)] - [date date.Date (\ date.codec encode)] - [time time.Time (\ time.codec encode)] - [day day.Day (\ day.codec encode)] - [month month.Month (\ month.codec encode)] - - [xml xml.XML (\ xml.codec encode)] - [json json.JSON (\ json.codec encode)] - ) - -(template [<type> <format>,<codec>] - [(`` (template [<format> <codec>] - [(def: #export <format> - (Format <type>) - (\ <codec> encode))] - - (~~ (template.splice <format>,<codec>))))] - - [Nat - [[nat/2 nat.binary] - [nat/8 nat.octal] - [nat/10 nat.decimal] - [nat/16 nat.hex]]] - [Int - [[int/2 int.binary] - [int/8 int.octal] - [int/10 int.decimal] - [int/16 int.hex]]] - [Rev - [[rev/2 rev.binary] - [rev/8 rev.octal] - [rev/10 rev.decimal] - [rev/16 rev.hex]]] - [Frac - [[frac/2 frac.binary] - [frac/8 frac.octal] - [frac/10 frac.decimal] - [frac/16 frac.hex]]] - ) - -(def: #export (mod modular) - (All [m] (Format (modular.Mod m))) - (let [codec (modular.codec (modular.modulus modular))] - (\ codec encode modular))) - -(def: #export (list formatter) - (All [a] (-> (Format a) (Format (List a)))) - (|>> (list\map (|>> formatter (format " "))) - (text.join_with "") - (text.enclose ["(list" ")"]))) - -(def: #export (maybe format) - (All [a] (-> (Format a) (Format (Maybe a)))) - (function (_ value) - (case value - #.None - "#.None" - - (#.Some value) - (..format "(#.Some " (format value) ")")))) diff --git a/stdlib/source/lux/data/text/regex.lux b/stdlib/source/lux/data/text/regex.lux deleted file mode 100644 index 47b559d15..000000000 --- a/stdlib/source/lux/data/text/regex.lux +++ /dev/null @@ -1,494 +0,0 @@ -(.module: - [lux #* - ["." meta] - [abstract - monad] - [control - ["." try] - ["<>" parser ("#\." monad) - ["<t>" text (#+ Parser)] - ["<c>" code]]] - [data - ["." product] - ["." maybe] - [collection - ["." list ("#\." fold monad)]]] - [macro (#+ with_gensyms) - [syntax (#+ syntax:)] - ["." code]] - [math - [number (#+ hex) - ["n" nat ("#\." decimal)]]]] - ["." // - ["%" format (#+ format)]]) - -(def: regex_char^ - (Parser Text) - (<t>.none_of "\.|&()[]{}")) - -(def: escaped_char^ - (Parser Text) - (do <>.monad - [? (<>.parses? (<t>.this "\"))] - (if ? - <t>.any - regex_char^))) - -(def: (refine^ refinement^ base^) - (All [a] (-> (Parser a) (Parser Text) (Parser Text))) - (do <>.monad - [output base^ - _ (<t>.local output refinement^)] - (wrap output))) - -(def: word^ - (Parser Text) - (<>.either <t>.alpha_num - (<t>.one_of "_"))) - -(def: (copy reference) - (-> Text (Parser Text)) - (<>.after (<t>.this reference) (<>\wrap reference))) - -(def: (join_text^ part^) - (-> (Parser (List Text)) (Parser Text)) - (do <>.monad - [parts part^] - (wrap (//.join_with "" parts)))) - -(def: name_char^ - (Parser Text) - (<t>.none_of (format "[]{}()s#.<>" //.double_quote))) - -(def: name_part^ - (Parser Text) - (do <>.monad - [head (refine^ (<t>.not <t>.decimal) - name_char^) - tail (<t>.some name_char^)] - (wrap (format head tail)))) - -(def: (name^ current_module) - (-> Text (Parser Name)) - ($_ <>.either - (<>.and (<>\wrap current_module) (<>.after (<t>.this "..") name_part^)) - (<>.and name_part^ (<>.after (<t>.this ".") name_part^)) - (<>.and (<>\wrap "lux") (<>.after (<t>.this ".") name_part^)) - (<>.and (<>\wrap "") name_part^))) - -(def: (re_var^ current_module) - (-> Text (Parser Code)) - (do <>.monad - [name (<t>.enclosed ["\@<" ">"] (name^ current_module))] - (wrap (` (: (Parser Text) (~ (code.identifier name))))))) - -(def: re_range^ - (Parser Code) - (do {! <>.monad} - [from (|> regex_char^ (\ ! map (|>> (//.nth 0) maybe.assume))) - _ (<t>.this "-") - to (|> regex_char^ (\ ! map (|>> (//.nth 0) maybe.assume)))] - (wrap (` (<t>.range (~ (code.nat from)) (~ (code.nat to))))))) - -(def: re_char^ - (Parser Code) - (do <>.monad - [char escaped_char^] - (wrap (` ((~! ..copy) (~ (code.text char))))))) - -(def: re_options^ - (Parser Code) - (do <>.monad - [options (<t>.many escaped_char^)] - (wrap (` (<t>.one_of (~ (code.text options))))))) - -(def: re_user_class^' - (Parser Code) - (do <>.monad - [negate? (<>.maybe (<t>.this "^")) - parts (<>.many ($_ <>.either - re_range^ - re_options^))] - (wrap (case negate? - (#.Some _) (` (<t>.not ($_ <>.either (~+ parts)))) - #.None (` ($_ <>.either (~+ parts))))))) - -(def: re_user_class^ - (Parser Code) - (do <>.monad - [_ (wrap []) - init re_user_class^' - rest (<>.some (<>.after (<t>.this "&&") (<t>.enclosed ["[" "]"] re_user_class^')))] - (wrap (list\fold (function (_ refinement base) - (` ((~! refine^) (~ refinement) (~ base)))) - init - rest)))) - -(def: blank^ - (Parser Text) - (<t>.one_of (format " " //.tab))) - -(def: ascii^ - (Parser Text) - (<t>.range (hex "0") (hex "7F"))) - -(def: control^ - (Parser Text) - (<>.either (<t>.range (hex "0") (hex "1F")) - (<t>.one_of (//.from_code (hex "7F"))))) - -(def: punct^ - (Parser Text) - (<t>.one_of (format "!#$%&'()*+,-./:;<=>?@[\]^_`{|}~" - //.double_quote))) - -(def: graph^ - (Parser Text) - (<>.either punct^ <t>.alpha_num)) - -(def: print^ - (Parser Text) - (<>.either graph^ - (<t>.one_of (//.from_code (hex "20"))))) - -(def: re_system_class^ - (Parser Code) - (do <>.monad - [] - ($_ <>.either - (<>.after (<t>.this ".") (wrap (` <t>.any))) - (<>.after (<t>.this "\d") (wrap (` <t>.decimal))) - (<>.after (<t>.this "\D") (wrap (` (<t>.not <t>.decimal)))) - (<>.after (<t>.this "\s") (wrap (` <t>.space))) - (<>.after (<t>.this "\S") (wrap (` (<t>.not <t>.space)))) - (<>.after (<t>.this "\w") (wrap (` (~! word^)))) - (<>.after (<t>.this "\W") (wrap (` (<t>.not (~! word^))))) - - (<>.after (<t>.this "\p{Lower}") (wrap (` <t>.lower))) - (<>.after (<t>.this "\p{Upper}") (wrap (` <t>.upper))) - (<>.after (<t>.this "\p{Alpha}") (wrap (` <t>.alpha))) - (<>.after (<t>.this "\p{Digit}") (wrap (` <t>.decimal))) - (<>.after (<t>.this "\p{Alnum}") (wrap (` <t>.alpha_num))) - (<>.after (<t>.this "\p{Space}") (wrap (` <t>.space))) - (<>.after (<t>.this "\p{HexDigit}") (wrap (` <t>.hexadecimal))) - (<>.after (<t>.this "\p{OctDigit}") (wrap (` <t>.octal))) - (<>.after (<t>.this "\p{Blank}") (wrap (` (~! blank^)))) - (<>.after (<t>.this "\p{ASCII}") (wrap (` (~! ascii^)))) - (<>.after (<t>.this "\p{Contrl}") (wrap (` (~! control^)))) - (<>.after (<t>.this "\p{Punct}") (wrap (` (~! punct^)))) - (<>.after (<t>.this "\p{Graph}") (wrap (` (~! graph^)))) - (<>.after (<t>.this "\p{Print}") (wrap (` (~! print^)))) - ))) - -(def: re_class^ - (Parser Code) - (<>.either re_system_class^ - (<t>.enclosed ["[" "]"] re_user_class^))) - -(def: number^ - (Parser Nat) - (|> (<t>.many <t>.decimal) - (<>.codec n.decimal))) - -(def: re_back_reference^ - (Parser Code) - (<>.either (do <>.monad - [_ (<t>.this "\") - id number^] - (wrap (` ((~! ..copy) (~ (code.identifier ["" (n\encode id)])))))) - (do <>.monad - [_ (<t>.this "\k<") - captured_name name_part^ - _ (<t>.this ">")] - (wrap (` ((~! ..copy) (~ (code.identifier ["" captured_name])))))))) - -(def: (re_simple^ current_module) - (-> Text (Parser Code)) - ($_ <>.either - re_class^ - (re_var^ current_module) - re_back_reference^ - re_char^ - )) - -(def: (re_simple_quantified^ current_module) - (-> Text (Parser Code)) - (do <>.monad - [base (re_simple^ current_module) - quantifier (<t>.one_of "?*+")] - (case quantifier - "?" - (wrap (` (<>.default "" (~ base)))) - - "*" - (wrap (` ((~! join_text^) (<>.some (~ base))))) - - ## "+" - _ - (wrap (` ((~! join_text^) (<>.many (~ base))))) - ))) - -(def: (re_counted_quantified^ current_module) - (-> Text (Parser Code)) - (do {! <>.monad} - [base (re_simple^ current_module)] - (<t>.enclosed ["{" "}"] - ($_ <>.either - (do ! - [[from to] (<>.and number^ (<>.after (<t>.this ",") number^))] - (wrap (` ((~! join_text^) (<>.between (~ (code.nat from)) - (~ (code.nat to)) - (~ base)))))) - (do ! - [limit (<>.after (<t>.this ",") number^)] - (wrap (` ((~! join_text^) (<>.at_most (~ (code.nat limit)) (~ base)))))) - (do ! - [limit (<>.before (<t>.this ",") number^)] - (wrap (` ((~! join_text^) (<>.at_least (~ (code.nat limit)) (~ base)))))) - (do ! - [limit number^] - (wrap (` ((~! join_text^) (<>.exactly (~ (code.nat limit)) (~ base)))))))))) - -(def: (re_quantified^ current_module) - (-> Text (Parser Code)) - (<>.either (re_simple_quantified^ current_module) - (re_counted_quantified^ current_module))) - -(def: (re_complex^ current_module) - (-> Text (Parser Code)) - ($_ <>.either - (re_quantified^ current_module) - (re_simple^ current_module))) - -(type: Re_Group - #Non_Capturing - (#Capturing [(Maybe Text) Nat])) - -(def: (re_sequential^ capturing? re_scoped^ current_module) - (-> Bit - (-> Text (Parser [Re_Group Code])) - Text - (Parser [Nat Code])) - (do <>.monad - [parts (<>.many (<>.or (re_complex^ current_module) - (re_scoped^ current_module))) - #let [g!total (code.identifier ["" "0total"]) - g!temp (code.identifier ["" "0temp"]) - [_ names steps] (list\fold (: (-> (Either Code [Re_Group Code]) - [Nat (List Code) (List (List Code))] - [Nat (List Code) (List (List Code))]) - (function (_ part [idx names steps]) - (case part - (^or (#.Left complex) (#.Right [#Non_Capturing complex])) - [idx - names - (list& (list g!temp complex - (' #let) (` [(~ g!total) (\ (~! //.monoid) (~' compose) (~ g!total) (~ g!temp))])) - steps)] - - (#.Right [(#Capturing [?name num_captures]) scoped]) - (let [[idx! name!] (case ?name - (#.Some _name) - [idx (code.identifier ["" _name])] - - #.None - [(inc idx) (code.identifier ["" (n\encode idx)])]) - access (if (n.> 0 num_captures) - (` ((~! product.left) (~ name!))) - name!)] - [idx! - (list& name! names) - (list& (list name! scoped - (' #let) (` [(~ g!total) (\ (~! //.monoid) (~' compose) (~ g!total) (~ access))])) - steps)]) - ))) - [0 - (: (List Code) (list)) - (: (List (List Code)) (list))] - parts)]] - (wrap [(if capturing? - (list.size names) - 0) - (` (do <>.monad - [(~ (' #let)) [(~ g!total) ""] - (~+ (|> steps list.reverse list\join))] - ((~ (' wrap)) [(~ g!total) (~+ (list.reverse names))])))]) - )) - -(def: (unflatten^ lexer) - (-> (Parser Text) (Parser [Text Any])) - (<>.and lexer (\ <>.monad wrap []))) - -(def: (|||^ left right) - (All [l r] (-> (Parser [Text l]) (Parser [Text r]) (Parser [Text (| l r)]))) - (function (_ input) - (case (left input) - (#try.Success [input' [lt lv]]) - (#try.Success [input' [lt (0 #0 lv)]]) - - (#try.Failure _) - (case (right input) - (#try.Success [input' [rt rv]]) - (#try.Success [input' [rt (0 #1 rv)]]) - - (#try.Failure error) - (#try.Failure error))))) - -(def: (|||_^ left right) - (All [l r] (-> (Parser [Text l]) (Parser [Text r]) (Parser Text))) - (function (_ input) - (case (left input) - (#try.Success [input' [lt lv]]) - (#try.Success [input' lt]) - - (#try.Failure _) - (case (right input) - (#try.Success [input' [rt rv]]) - (#try.Success [input' rt]) - - (#try.Failure error) - (#try.Failure error))))) - -(def: (prep_alternative [num_captures alt]) - (-> [Nat Code] Code) - (if (n.> 0 num_captures) - alt - (` ((~! unflatten^) (~ alt))))) - -(def: (re_alternative^ capturing? re_scoped^ current_module) - (-> Bit - (-> Text (Parser [Re_Group Code])) - Text - (Parser [Nat Code])) - (do <>.monad - [#let [sub^ (re_sequential^ capturing? re_scoped^ current_module)] - head sub^ - tail (<>.some (<>.after (<t>.this "|") sub^))] - (if (list.empty? tail) - (wrap head) - (wrap [(list\fold n.max (product.left head) (list\map product.left tail)) - (` ($_ ((~ (if capturing? - (` (~! |||^)) - (` (~! |||_^))))) - (~ (prep_alternative head)) - (~+ (list\map prep_alternative tail))))])))) - -(def: (re_scoped^ current_module) - (-> Text (Parser [Re_Group Code])) - ($_ <>.either - (do <>.monad - [_ (<t>.this "(?:") - [_ scoped] (re_alternative^ #0 re_scoped^ current_module) - _ (<t>.this ")")] - (wrap [#Non_Capturing scoped])) - (do <>.monad - [complex (re_complex^ current_module)] - (wrap [#Non_Capturing complex])) - (do <>.monad - [_ (<t>.this "(?<") - captured_name name_part^ - _ (<t>.this ">") - [num_captures pattern] (re_alternative^ #1 re_scoped^ current_module) - _ (<t>.this ")")] - (wrap [(#Capturing [(#.Some captured_name) num_captures]) pattern])) - (do <>.monad - [_ (<t>.this "(") - [num_captures pattern] (re_alternative^ #1 re_scoped^ current_module) - _ (<t>.this ")")] - (wrap [(#Capturing [#.None num_captures]) pattern])))) - -(def: (regex^ current_module) - (-> Text (Parser Code)) - (\ <>.monad map product.right (re_alternative^ #1 re_scoped^ current_module))) - -(syntax: #export (regex {pattern <c>.text}) - {#.doc (doc "Create lexers using regular-expression syntax." - "For example:" - - "Literals" - (regex "a") - - "Wildcards" - (regex ".") - - "Escaping" - (regex "\.") - - "Character classes" - (regex "\d") - (regex "\p{Lower}") - (regex "[abc]") - (regex "[a-z]") - (regex "[a-zA-Z]") - (regex "[a-z&&[def]]") - - "Negation" - (regex "[^abc]") - (regex "[^a-z]") - (regex "[^a-zA-Z]") - (regex "[a-z&&[^bc]]") - (regex "[a-z&&[^m-p]]") - - "Combinations" - (regex "aa") - (regex "a?") - (regex "a*") - (regex "a+") - - "Specific amounts" - (regex "a{2}") - - "At least" - (regex "a{1,}") - - "At most" - (regex "a{,1}") - - "Between" - (regex "a{1,2}") - - "Groups" - (regex "a(.)c") - (regex "a(b+)c") - (regex "(\d{3})-(\d{3})-(\d{4})") - (regex "(\d{3})-(?:\d{3})-(\d{4})") - (regex "(?<code>\d{3})-\k<code>-(\d{4})") - (regex "(?<code>\d{3})-\k<code>-(\d{4})-\0") - (regex "(\d{3})-((\d{3})-(\d{4}))") - - "Alternation" - (regex "a|b") - (regex "a(.)(.)|b(.)(.)") - )} - (do meta.monad - [current_module meta.current_module_name] - (case (<t>.run (regex^ current_module) - pattern) - (#try.Failure error) - (meta.fail (format "Error while parsing regular-expression:" //.new_line - error)) - - (#try.Success regex) - (wrap (list regex)) - ))) - -(syntax: #export (^regex {[pattern bindings] (<c>.form (<>.and <c>.text (<>.maybe <c>.any)))} - body - {branches (<>.many <c>.any)}) - {#.doc (doc "Allows you to test text against regular expressions." - (case some_text - (^regex "(\d{3})-(\d{3})-(\d{4})" - [_ country_code area_code place_code]) - do_some_thing_when_number - - (^regex "\w+") - do_some_thing_when_word - - _ - do_something_else))} - (with_gensyms [g!temp] - (wrap (list& (` (^multi (~ g!temp) - [((~! <t>.run) (..regex (~ (code.text pattern))) (~ g!temp)) - (#try.Success (~ (maybe.default g!temp bindings)))])) - body - branches)))) diff --git a/stdlib/source/lux/data/text/unicode/block.lux b/stdlib/source/lux/data/text/unicode/block.lux deleted file mode 100644 index 76fe97b78..000000000 --- a/stdlib/source/lux/data/text/unicode/block.lux +++ /dev/null @@ -1,204 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)] - [monoid (#+ Monoid)] - ["." interval (#+ Interval)]] - [math - [number (#+ hex) - ["n" nat ("#\." interval)] - ["." i64]]] - [type - abstract]] - [/// (#+ Char)]) - -(abstract: #export Block - (Interval Char) - - (implementation: #export monoid - (Monoid Block) - - (def: identity - (:abstraction (interval.between n.enum n\top n\bottom))) - (def: (compose left right) - (let [left (:representation left) - right (:representation right)] - (:abstraction - (interval.between n.enum - (n.min (\ left bottom) - (\ right bottom)) - (n.max (\ left top) - (\ right top))))))) - - (def: #export (block start end) - (-> Char Char Block) - (:abstraction (interval.between n.enum (n.min start end) (n.max start end)))) - - (template [<name> <slot>] - [(def: #export <name> - (-> Block Char) - (|>> :representation (get@ <slot>)))] - - [start #interval.bottom] - [end #interval.top] - ) - - (def: #export (size block) - (-> Block Nat) - (let [start (get@ #interval.bottom (:representation block)) - end (get@ #interval.top (:representation block))] - (|> end (n.- start) inc))) - - (def: #export (within? block char) - (All [a] (-> Block Char Bit)) - (interval.within? (:representation block) char)) - ) - -(implementation: #export equivalence - (Equivalence Block) - - (def: (= reference subject) - (and (n.= (..start reference) (..start subject)) - (n.= (..end reference) (..end subject))))) - -(implementation: #export hash - (Hash Block) - - (def: &equivalence ..equivalence) - (def: (hash value) - (i64.or (i64.left_shift 32 (..start value)) - (..end value)))) - -(template [<name> <start> <end>] - [(def: #export <name> Block (..block (hex <start>) (hex <end>)))] - - ## Normal blocks - [basic_latin "0000" "007F"] - [latin_1_supplement "00A0" "00FF"] - [latin_extended_a "0100" "017F"] - [latin_extended_b "0180" "024F"] - [ipa_extensions "0250" "02AF"] - [spacing_modifier_letters "02B0" "02FF"] - [combining_diacritical_marks "0300" "036F"] - [greek_and_coptic "0370" "03FF"] - [cyrillic "0400" "04FF"] - [cyrillic_supplementary "0500" "052F"] - [armenian "0530" "058F"] - [hebrew "0590" "05FF"] - [arabic "0600" "06FF"] - [syriac "0700" "074F"] - [thaana "0780" "07BF"] - [devanagari "0900" "097F"] - [bengali "0980" "09FF"] - [gurmukhi "0A00" "0A7F"] - [gujarati "0A80" "0AFF"] - [oriya "0B00" "0B7F"] - [tamil "0B80" "0BFF"] - [telugu "0C00" "0C7F"] - [kannada "0C80" "0CFF"] - [malayalam "0D00" "0D7F"] - [sinhala "0D80" "0DFF"] - [thai "0E00" "0E7F"] - [lao "0E80" "0EFF"] - [tibetan "0F00" "0FFF"] - [myanmar "1000" "109F"] - [georgian "10A0" "10FF"] - [hangul_jamo "1100" "11FF"] - [ethiopic "1200" "137F"] - [cherokee "13A0" "13FF"] - [unified_canadian_aboriginal_syllabics "1400" "167F"] - [ogham "1680" "169F"] - [runic "16A0" "16FF"] - [tagalog "1700" "171F"] - [hanunoo "1720" "173F"] - [buhid "1740" "175F"] - [tagbanwa "1760" "177F"] - [khmer "1780" "17FF"] - [mongolian "1800" "18AF"] - [limbu "1900" "194F"] - [tai_le "1950" "197F"] - [khmer_symbols "19E0" "19FF"] - [phonetic_extensions "1D00" "1D7F"] - [latin_extended_additional "1E00" "1EFF"] - [greek_extended "1F00" "1FFF"] - [general_punctuation "2000" "206F"] - [superscripts_and_subscripts "2070" "209F"] - [currency_symbols "20A0" "20CF"] - [combining_diacritical_marks_for_symbols "20D0" "20FF"] - [letterlike_symbols "2100" "214F"] - [number_forms "2150" "218F"] - [arrows "2190" "21FF"] - [mathematical_operators "2200" "22FF"] - [miscellaneous_technical "2300" "23FF"] - [control_pictures "2400" "243F"] - [optical_character_recognition "2440" "245F"] - [enclosed_alphanumerics "2460" "24FF"] - [box_drawing "2500" "257F"] - [block_elements "2580" "259F"] - [geometric_shapes "25A0" "25FF"] - [miscellaneous_symbols "2600" "26FF"] - [dingbats "2700" "27BF"] - [miscellaneous_mathematical_symbols_a "27C0" "27EF"] - [supplemental_arrows_a "27F0" "27FF"] - [braille_patterns "2800" "28FF"] - [supplemental_arrows_b "2900" "297F"] - [miscellaneous_mathematical_symbols_b "2980" "29FF"] - [supplemental_mathematical_operators "2A00" "2AFF"] - [miscellaneous_symbols_and_arrows "2B00" "2BFF"] - [cjk_radicals_supplement "2E80" "2EFF"] - [kangxi_radicals "2F00" "2FDF"] - [ideographic_description_characters "2FF0" "2FFF"] - [cjk_symbols_and_punctuation "3000" "303F"] - [hiragana "3040" "309F"] - [katakana "30A0" "30FF"] - [bopomofo "3100" "312F"] - [hangul_compatibility_jamo "3130" "318F"] - [kanbun "3190" "319F"] - [bopomofo_extended "31A0" "31BF"] - [katakana_phonetic_extensions "31F0" "31FF"] - [enclosed_cjk_letters_and_months "3200" "32FF"] - [cjk_compatibility "3300" "33FF"] - [cjk_unified_ideographs_extension_a "3400" "4DBF"] - [yijing_hexagram_symbols "4DC0" "4DFF"] - [cjk_unified_ideographs "4E00" "9FFF"] - [yi_syllables "A000" "A48F"] - [yi_radicals "A490" "A4CF"] - [hangul_syllables "AC00" "D7AF"] - [high_surrogates "D800" "DB7F"] - [high_private_use_surrogates "DB80" "DBFF"] - [low_surrogates "DC00" "DFFF"] - [private_use_area "E000" "F8FF"] - [cjk_compatibility_ideographs "F900" "FAFF"] - [alphabetic_presentation_forms "FB00" "FB4F"] - [arabic_presentation_forms_a "FB50" "FDFF"] - [variation_selectors "FE00" "FE0F"] - [combining_half_marks "FE20" "FE2F"] - [cjk_compatibility_forms "FE30" "FE4F"] - [small_form_variants "FE50" "FE6F"] - [arabic_presentation_forms_b "FE70" "FEFF"] - [halfwidth_and_fullwidth_forms "FF00" "FFEF"] - [specials "FFF0" "FFFF"] - ## [linear_b_syllabary "10000" "1007F"] - ## [linear_b_ideograms "10080" "100FF"] - ## [aegean_numbers "10100" "1013F"] - ## [old_italic "10300" "1032F"] - ## [gothic "10330" "1034F"] - ## [ugaritic "10380" "1039F"] - ## [deseret "10400" "1044F"] - ## [shavian "10450" "1047F"] - ## [osmanya "10480" "104AF"] - ## [cypriot_syllabary "10800" "1083F"] - ## [byzantine_musical_symbols "1D000" "1D0FF"] - ## [musical_symbols "1D100" "1D1FF"] - ## [tai_xuan_jing_symbols "1D300" "1D35F"] - ## [mathematical_alphanumeric_symbols "1D400" "1D7FF"] - ## [cjk_unified_ideographs_extension_b "20000" "2A6DF"] - ## [cjk_compatibility_ideographs_supplement "2F800" "2FA1F"] - ## [tags "E0000" "E007F"] - - ## Specialized blocks - [basic_latin/decimal "0030" "0039"] - [basic_latin/upper "0041" "005A"] - [basic_latin/lower "0061" "007A"] - ) diff --git a/stdlib/source/lux/data/text/unicode/set.lux b/stdlib/source/lux/data/text/unicode/set.lux deleted file mode 100644 index 117df224c..000000000 --- a/stdlib/source/lux/data/text/unicode/set.lux +++ /dev/null @@ -1,239 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)]] - [data - [collection - ["." list ("#\." fold functor)] - ["." set ("#\." equivalence)] - ["." tree #_ - ["#" finger (#+ Tree)]]]] - [type (#+ :by_example) - abstract]] - ["." / #_ - ["/#" // #_ - [// (#+ Char)] - ["#." block (#+ Block)]]]) - -(def: builder - (tree.builder //block.monoid)) - -(def: :@: - (:by_example [@] - (tree.Builder @ Block) - ..builder - - @)) - -(abstract: #export Set - (Tree :@: Block []) - - (def: #export (compose left right) - (-> Set Set Set) - (:abstraction - (\ builder branch - (:representation left) - (:representation right)))) - - (def: (singleton block) - (-> Block Set) - (:abstraction - (\ builder leaf block []))) - - (def: #export (set [head tail]) - (-> [Block (List Block)] Set) - (list\fold (: (-> Block Set Set) - (function (_ block set) - (..compose (..singleton block) set))) - (..singleton head) - tail)) - - (def: character/0 - Set - (..set [//block.basic_latin - (list //block.latin_1_supplement - //block.latin_extended_a - //block.latin_extended_b - //block.ipa_extensions - //block.spacing_modifier_letters - //block.combining_diacritical_marks - //block.greek_and_coptic - //block.cyrillic - //block.cyrillic_supplementary - //block.armenian - //block.hebrew - //block.arabic - //block.syriac - //block.thaana - //block.devanagari - //block.bengali - //block.gurmukhi - //block.gujarati - //block.oriya - //block.tamil - //block.telugu - //block.kannada - //block.malayalam - //block.sinhala - //block.thai - //block.lao - //block.tibetan - //block.myanmar - //block.georgian)])) - - (def: character/1 - Set - (..set [//block.hangul_jamo - (list //block.ethiopic - //block.cherokee - //block.unified_canadian_aboriginal_syllabics - //block.ogham - //block.runic - //block.tagalog - //block.hanunoo - //block.buhid - //block.tagbanwa - //block.khmer - //block.mongolian - //block.limbu - //block.tai_le - //block.khmer_symbols - //block.phonetic_extensions - //block.latin_extended_additional - //block.greek_extended - //block.general_punctuation - //block.superscripts_and_subscripts - //block.currency_symbols - //block.combining_diacritical_marks_for_symbols - //block.letterlike_symbols - //block.number_forms - //block.arrows - //block.mathematical_operators - //block.miscellaneous_technical - //block.control_pictures - //block.optical_character_recognition - //block.enclosed_alphanumerics - //block.box_drawing)])) - - (def: character/2 - Set - (..set [//block.block_elements - (list //block.geometric_shapes - //block.miscellaneous_symbols - //block.dingbats - //block.miscellaneous_mathematical_symbols_a - //block.supplemental_arrows_a - //block.braille_patterns - //block.supplemental_arrows_b - //block.miscellaneous_mathematical_symbols_b - //block.supplemental_mathematical_operators - //block.miscellaneous_symbols_and_arrows - //block.cjk_radicals_supplement - //block.kangxi_radicals - //block.ideographic_description_characters - //block.cjk_symbols_and_punctuation - //block.hiragana - //block.katakana - //block.bopomofo - //block.hangul_compatibility_jamo - //block.kanbun - //block.bopomofo_extended - //block.katakana_phonetic_extensions - //block.enclosed_cjk_letters_and_months - //block.cjk_compatibility - //block.cjk_unified_ideographs_extension_a - //block.yijing_hexagram_symbols - //block.cjk_unified_ideographs - //block.yi_syllables - //block.yi_radicals - //block.hangul_syllables - )])) - - (def: #export character - Set - ($_ ..compose - ..character/0 - ..character/1 - ..character/2 - )) - - (def: #export non_character - Set - (..set [//block.high_surrogates - (list //block.high_private_use_surrogates - //block.low_surrogates - //block.private_use_area - //block.cjk_compatibility_ideographs - //block.alphabetic_presentation_forms - //block.arabic_presentation_forms_a - //block.variation_selectors - //block.combining_half_marks - //block.cjk_compatibility_forms - //block.small_form_variants - //block.arabic_presentation_forms_b - //block.halfwidth_and_fullwidth_forms - //block.specials - ## //block.linear_b_syllabary - ## //block.linear_b_ideograms - ## //block.aegean_numbers - ## //block.old_italic - ## //block.gothic - ## //block.ugaritic - ## //block.deseret - ## //block.shavian - ## //block.osmanya - ## //block.cypriot_syllabary - ## //block.byzantine_musical_symbols - ## //block.musical_symbols - ## //block.tai_xuan_jing_symbols - ## //block.mathematical_alphanumeric_symbols - ## //block.cjk_unified_ideographs_extension_b - ## //block.cjk_compatibility_ideographs_supplement - ## //block.tags - )])) - - (def: #export full - Set - ($_ ..compose - ..character - ..non_character - )) - - (def: #export (range set) - (-> Set [Char Char]) - (let [tag (tree.tag (:representation set))] - [(//block.start tag) - (//block.end tag)])) - - (def: #export (member? set character) - (-> Set Char Bit) - (loop [tree (:representation set)] - (if (//block.within? (tree.tag tree) character) - (case (tree.root tree) - (0 #0 _) - true - - (0 #1 left right) - (or (recur left) - (recur right))) - false))) - - (implementation: #export equivalence - (Equivalence Set) - - (def: (= reference subject) - (set\= (set.from_list //block.hash (tree.tags (:representation reference))) - (set.from_list //block.hash (tree.tags (:representation subject)))))) - ) - -(template [<name> <blocks>] - [(def: #export <name> - (..set <blocks>))] - - [ascii [//block.basic_latin (list)]] - [ascii/alpha [//block.basic_latin/upper (list //block.basic_latin/lower)]] - [ascii/alpha_num [//block.basic_latin/upper (list //block.basic_latin/lower //block.basic_latin/decimal)]] - [ascii/numeric [//block.basic_latin/decimal (list)]] - [ascii/upper [//block.basic_latin/upper (list)]] - [ascii/lower [//block.basic_latin/lower (list)]] - ) diff --git a/stdlib/source/lux/data/trace.lux b/stdlib/source/lux/data/trace.lux deleted file mode 100644 index 1b2f87ddf..000000000 --- a/stdlib/source/lux/data/trace.lux +++ /dev/null @@ -1,35 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monoid (#+ Monoid)] - [functor (#+ Functor)] - comonad] - function]) - -(type: #export (Trace t a) - {#monoid (Monoid t) - #trace (-> t a)}) - -(implementation: #export functor (All [t] (Functor (Trace t))) - (def: (map f fa) - (update@ #trace (compose f) fa))) - -(implementation: #export comonad (All [t] (CoMonad (Trace t))) - (def: &functor ..functor) - - (def: (unwrap wa) - ((get@ #trace wa) - (get@ [#monoid #monoid.identity] wa))) - - (def: (split wa) - (let [monoid (get@ #monoid wa)] - {#monoid monoid - #trace (function (_ t1) - {#monoid monoid - #trace (function (_ t2) - ((get@ #trace wa) - (\ monoid compose t1 t2)))})}))) - -(def: #export (run context tracer) - (All [t a] (-> t (Trace t a) a)) - (\ tracer trace context)) diff --git a/stdlib/source/lux/debug.lux b/stdlib/source/lux/debug.lux deleted file mode 100644 index cf6fb803c..000000000 --- a/stdlib/source/lux/debug.lux +++ /dev/null @@ -1,597 +0,0 @@ -(.module: - [lux (#- type) - ["@" target] - ["." type] - ["." ffi (#+ import:)] - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - [pipe (#+ new>)] - ["." function] - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["<>" parser - ["<.>" type (#+ Parser)] - ["<.>" code]]] - [data - ["." text - ["%" format (#+ Format)]] - [format - [xml (#+ XML)] - ["." json]] - [collection - ["." array] - ["." list ("#\." functor)] - ["." dictionary]]] - [macro - ["." template] - ["." syntax (#+ syntax:)] - ["." code]] - [math - [number - [ratio (#+ Ratio)] - ["n" nat] - ["i" int]]] - [time (#+ Time) - [instant (#+ Instant)] - [duration (#+ Duration)] - [date (#+ Date)] - [month (#+ Month)] - [day (#+ Day)]]]) - -(with_expansions [<jvm> (as_is (import: java/lang/String) - - (import: (java/lang/Class a) - ["#::." - (getCanonicalName [] java/lang/String)]) - - (import: java/lang/Object - ["#::." - (new []) - (toString [] java/lang/String) - (getClass [] (java/lang/Class java/lang/Object))]) - - (import: java/lang/Integer - ["#::." - (longValue [] long)]) - - (import: java/lang/Long - ["#::." - (intValue [] int)]) - - (import: java/lang/Number - ["#::." - (intValue [] int) - (longValue [] long) - (doubleValue [] double)]))] - (for {@.old (as_is <jvm>) - @.jvm (as_is <jvm>) - - @.js - (as_is (import: JSON - ["#::." - (#static stringify [.Any] ffi.String)]) - (import: Array - ["#::." - (#static isArray [.Any] ffi.Boolean)])) - - @.python - (as_is (type: PyType - (primitive "python_type")) - - (import: (type [.Any] PyType)) - (import: (str [.Any] ffi.String))) - - @.lua - (as_is (import: (type [.Any] ffi.String)) - (import: (tostring [.Any] ffi.String)) - - (import: math - ["#::." - (#static type [.Any] #? ffi.String)])) - - @.ruby - (as_is (import: Class) - - (import: Object - ["#::." - (class [] Class) - (to_s [] ffi.String)])) - - @.php - (as_is (import: (gettype [.Any] ffi.String)) - (import: (strval [.Any] ffi.String))) - - @.scheme - (as_is (import: (boolean? [.Any] Bit)) - (import: (integer? [.Any] Bit)) - (import: (real? [.Any] Bit)) - (import: (string? [.Any] Bit)) - (import: (vector? [.Any] Bit)) - (import: (pair? [.Any] Bit)) - (import: (car [.Any] .Any)) - (import: (cdr [.Any] .Any)) - (import: (format [Text .Any] Text))) - })) - -(def: Inspector - (.type (Format Any))) - -(for {@.lua (def: (tuple_array tuple) - (-> (array.Array Any) (array.Array Any)) - (array.from_list - (loop [idx 0] - (let [member ("lua array read" idx tuple)] - (if ("lua object nil?" member) - #.Nil - (#.Cons member (recur (inc idx))))))))} - (as_is)) - -(def: (inspect_tuple inspect) - (-> Inspector Inspector) - (with_expansions [<adaption> (for {@.lua (~~ (as_is ..tuple_array))} - (~~ (as_is)))] - (`` (|>> (:as (array.Array Any)) - <adaption> - array.to_list - (list\map inspect) - (text.join_with " ") - (text.enclose ["[" "]"]))))) - -(def: #export (inspect value) - Inspector - (with_expansions [<jvm> (let [object (:as java/lang/Object value)] - (`` (<| (~~ (template [<class> <processing>] - [(case (ffi.check <class> object) - (#.Some value) - (`` (|> value (~~ (template.splice <processing>)))) - #.None)] - - [java/lang/Boolean [(:as .Bit) %.bit]] - [java/lang/Long [(:as .Int) %.int]] - [java/lang/Number [java/lang/Number::doubleValue %.frac]] - [java/lang/String [(:as .Text) %.text]] - )) - (case (ffi.check [java/lang/Object] object) - (#.Some value) - (let [value (:as (array.Array java/lang/Object) value)] - (case (array.read 0 value) - (^multi (#.Some tag) - [(ffi.check java/lang/Integer tag) - (#.Some tag)] - [[(array.read 1 value) - (array.read 2 value)] - [last? - (#.Some choice)]]) - (let [last? (case last? - (#.Some _) #1 - #.None #0)] - (|> (%.format (%.nat (.nat (java/lang/Integer::longValue tag))) - " " (%.bit last?) - " " (inspect choice)) - (text.enclose ["(" ")"]))) - - _ - (inspect_tuple inspect value))) - #.None) - (java/lang/Object::toString object))))] - (for {@.old <jvm> - @.jvm <jvm> - - @.js - (case (ffi.type_of value) - (^template [<type_of> <then>] - [<type_of> - (`` (|> value (~~ (template.splice <then>))))]) - (["boolean" [(:as .Bit) %.bit]] - ["number" [(:as .Frac) %.frac]] - ["string" [(:as .Text) %.text]] - ["undefined" [JSON::stringify]]) - - "object" - (let [variant_tag ("js object get" "_lux_tag" value) - variant_flag ("js object get" "_lux_flag" value) - variant_value ("js object get" "_lux_value" value)] - (cond (not (or ("js object undefined?" variant_tag) - ("js object undefined?" variant_flag) - ("js object undefined?" variant_value))) - (|> (%.format (JSON::stringify variant_tag) - " " (%.bit (not ("js object null?" variant_flag))) - " " (inspect variant_value)) - (text.enclose ["(" ")"])) - - (not (or ("js object undefined?" ("js object get" "_lux_low" value)) - ("js object undefined?" ("js object get" "_lux_high" value)))) - (|> value (:as .Int) %.int) - - (Array::isArray value) - (inspect_tuple inspect value) - - ## else - (JSON::stringify value))) - - _ - (JSON::stringify value)) - - @.python - (case (..str (..type value)) - (^template [<type_of> <class_of> <then>] - [(^or <type_of> <class_of>) - (`` (|> value (~~ (template.splice <then>))))]) - (["<type 'bool'>" "<class 'bool'>" [(:as .Bit) %.bit]] - ["<type 'int'>" "<class 'int'>" [(:as .Int) %.int]] - ["<type 'float'>" "<class 'float'>" [(:as .Frac) %.frac]] - ["<type 'str'>" "<class 'str'>" [(:as .Text) %.text]] - ["<type 'unicode'>" "<class 'unicode'>" [(:as .Text) %.text]]) - - (^or "<type 'list'>" "<class 'list'>") - (inspect_tuple inspect value) - - (^or "<type 'tuple'>" "<type 'tuple'>") - (let [variant (:as (array.Array Any) value)] - (case (array.size variant) - 3 (let [variant_tag ("python array read" 0 variant) - variant_flag ("python array read" 1 variant) - variant_value ("python array read" 2 variant)] - (if (or ("python object none?" variant_tag) - ("python object none?" variant_value)) - (..str value) - (|> (%.format (|> variant_tag (:as .Nat) %.nat) - " " (|> variant_flag "python object none?" not %.bit) - " " (inspect variant_value)) - (text.enclose ["(" ")"])))) - _ (..str value))) - - _ - (..str value)) - - @.lua - (case (..type value) - (^template [<type_of> <then>] - [<type_of> - (`` (|> value (~~ (template.splice <then>))))]) - (["boolean" [(:as .Bit) %.bit]] - ["string" [(:as .Text) %.text]] - ["nil" [(new> "nil" [])]]) - - "number" - (case (math::type [value]) - (#.Some "integer") (|> value (:as .Int) %.int) - (#.Some "float") (|> value (:as .Frac) %.frac) - - _ - (..tostring value)) - - "table" - (let [variant_tag ("lua object get" "_lux_tag" value) - variant_flag ("lua object get" "_lux_flag" value) - variant_value ("lua object get" "_lux_value" value)] - (if (or ("lua object nil?" variant_tag) - ("lua object nil?" variant_value)) - (inspect_tuple inspect value) - (|> (%.format (|> variant_tag (:as .Nat) %.nat) - " " (%.bit (not ("lua object nil?" variant_flag))) - " " (inspect variant_value)) - (text.enclose ["(" ")"])))) - - _ - (..tostring value)) - - @.ruby - (template.let [(class_of <literal>) - [(|> <literal> - (:as ..Object) - (Object::class []))] - - (to_s <object>) - [(|> <object> - (:as ..Object) - (Object::to_s []))]] - (let [value_class (class_of value)] - (`` (cond (~~ (template [<literal> <type> <format>] - [(is? (class_of <literal>) value_class) - (|> value (:as <type>) <format>)] - - [#0 Bit %.bit] - [#1 Bit %.bit] - [+1 Int %.int] - [+1.0 Frac %.frac] - ["" Text %.text] - [("ruby object nil") Any (new> "nil" [])] - )) - - (is? (class_of #.None) value_class) - (let [variant_tag ("ruby object get" "_lux_tag" value) - variant_flag ("ruby object get" "_lux_flag" value) - variant_value ("ruby object get" "_lux_value" value)] - (if (or ("ruby object nil?" variant_tag) - ("ruby object nil?" variant_value)) - (inspect_tuple inspect value) - (|> (%.format (|> variant_tag (:as .Nat) %.nat) - " " (%.bit (not ("ruby object nil?" variant_flag))) - " " (inspect variant_value)) - (text.enclose ["(" ")"])))) - - (is? (class_of [[] []]) value_class) - (inspect_tuple inspect value) - - ## else - (to_s value))))) - - @.php - (case (..gettype value) - (^template [<type_of> <then>] - [<type_of> - (`` (|> value (~~ (template.splice <then>))))]) - (["boolean" [(:as .Bit) %.bit]] - ["integer" [(:as .Int) %.int]] - ["double" [(:as .Frac) %.frac]] - ["string" [(:as .Text) %.text]] - ["NULL" [(new> "null" [])]] - ["array" [(inspect_tuple inspect)]]) - - "object" - (let [variant_tag ("php object get" "_lux_tag" value) - variant_flag ("php object get" "_lux_flag" value) - variant_value ("php object get" "_lux_value" value)] - (if (or ("php object null?" variant_tag) - ("php object null?" variant_value)) - (..strval value) - (|> (%.format (|> variant_tag (:as .Nat) %.nat) - " " (%.bit (not ("php object null?" variant_flag))) - " " (inspect variant_value)) - (text.enclose ["(" ")"])))) - - _ - (..strval value)) - - @.scheme - (`` (cond (~~ (template [<when> <then>] - [(<when> value) - (`` (|> value (~~ (template.splice <then>))))] - - [..boolean? [(:as .Bit) %.bit]] - [..integer? [(:as .Int) %.int]] - [..real? [(:as .Frac) %.frac]] - [..string? [(:as .Text) %.text]] - ["scheme object nil?" [(new> "()" [])]] - [..vector? [(inspect_tuple inspect)]])) - - (..pair? value) - (let [variant_tag (..car value) - variant_rest (..cdr value)] - (if (and (..integer? variant_tag) - (i.> +0 (:as Int variant_tag)) - (..pair? variant_rest)) - (let [variant_flag (..car variant_rest) - variant_value (..cdr variant_rest)] - (|> (%.format (|> variant_tag (:as .Nat) %.nat) - " " (%.bit (not ("scheme object nil?" variant_flag))) - " " (inspect variant_value)) - (text.enclose ["(" ")"]))) - (..format ["~s" value]))) - - ## else - (..format ["~s" value]) - )) - }))) - -(exception: #export (cannot_represent_value {type Type}) - (exception.report - ["Type" (%.type type)])) - -(type: Representation - (-> Any Text)) - -(def: primitive_representation - (Parser Representation) - (`` ($_ <>.either - (do <>.monad - [_ (<type>.exactly Any)] - (wrap (function.constant "[]"))) - - (~~ (template [<type> <formatter>] - [(do <>.monad - [_ (<type>.sub <type>)] - (wrap (|>> (:as <type>) <formatter>)))] - - [Bit %.bit] - [Nat %.nat] - [Int %.int] - [Rev %.rev] - [Frac %.frac] - [Text %.text])) - ))) - -(def: (special_representation representation) - (-> (Parser Representation) (Parser Representation)) - (`` ($_ <>.either - (~~ (template [<type> <formatter>] - [(do <>.monad - [_ (<type>.sub <type>)] - (wrap (|>> (:as <type>) <formatter>)))] - - [Ratio %.ratio] - [Name %.name] - [Location %.location] - [Type %.type] - [Code %.code] - - [Instant %.instant] - [Duration %.duration] - [Date %.date] - [Time %.time] - [Month %.month] - [Day %.day] - - [json.JSON %.json] - [XML %.xml])) - - (do <>.monad - [[_ elemT] (<type>.apply (<>.and (<type>.exactly List) <type>.any)) - elemR (<type>.local (list elemT) representation)] - (wrap (|>> (:as (List Any)) (%.list elemR)))) - - (do <>.monad - [[_ elemT] (<type>.apply (<>.and (<type>.exactly Maybe) <type>.any)) - elemR (<type>.local (list elemT) representation)] - (wrap (|>> (:as (Maybe Any)) - (%.maybe elemR))))))) - -(def: (variant_representation representation) - (-> (Parser Representation) (Parser Representation)) - (do <>.monad - [membersR+ (<type>.variant (<>.many representation))] - (wrap (function (_ variantV) - (let [[lefts right? sub_repr] (loop [lefts 0 - representations membersR+ - variantV variantV] - (case representations - (#.Cons leftR (#.Cons rightR extraR+)) - (case (:as (| Any Any) variantV) - (#.Left left) - [lefts #0 (leftR left)] - - (#.Right right) - (case extraR+ - #.Nil - [lefts #1 (rightR right)] - - _ - (recur (inc lefts) (#.Cons rightR extraR+) right))) - - _ - (undefined)))] - (%.format "(" (%.nat lefts) " " (%.bit right?) " " sub_repr ")")))))) - -(def: (tuple_representation representation) - (-> (Parser Representation) (Parser Representation)) - (do <>.monad - [membersR+ (<type>.tuple (<>.many representation))] - (wrap (function (_ tupleV) - (let [tuple_body (loop [representations membersR+ - tupleV tupleV] - (case representations - #.Nil - "" - - (#.Cons lastR #.Nil) - (lastR tupleV) - - (#.Cons headR tailR) - (let [[leftV rightV] (:as [Any Any] tupleV)] - (%.format (headR leftV) " " (recur tailR rightV)))))] - (%.format "[" tuple_body "]")))))) - -(def: representation - (Parser Representation) - (<>.rec - (function (_ representation) - ($_ <>.either - ..primitive_representation - (..special_representation representation) - (..variant_representation representation) - (..tuple_representation representation) - - (do <>.monad - [[funcT inputsT+] (<type>.apply (<>.and <type>.any (<>.many <type>.any)))] - (case (type.apply inputsT+ funcT) - (#.Some outputT) - (<type>.local (list outputT) representation) - - #.None - (<>.fail ""))) - - (do <>.monad - [[name anonymous] <type>.named] - (<type>.local (list anonymous) representation)) - - (<>.fail "") - )))) - -(def: #export (represent type value) - (-> Type Any (Try Text)) - (case (<type>.run ..representation type) - (#try.Success representation) - (#try.Success (representation value)) - - (#try.Failure _) - (exception.throw ..cannot_represent_value type))) - -(syntax: #export (private {definition <code>.identifier}) - (let [[module _] definition] - (wrap (list (` ("lux in-module" - (~ (code.text module)) - (~ (code.identifier definition)))))))) - -(def: #export (log! message) - {#.doc "Logs message to standard output."} - (-> Text Any) - ("lux io log" message)) - -(exception: #export (type_hole {location Location} {type Type}) - (exception.report - ["Location" (%.location location)] - ["Type" (%.type type)])) - -(syntax: #export (:hole) - (do meta.monad - [location meta.location - expectedT meta.expected_type] - (function.constant (exception.throw ..type_hole [location expectedT])))) - -(type: Target - [Text (Maybe Code)]) - -(def: target - (<code>.Parser Target) - (<>.either (<>.and <code>.local_identifier - (\ <>.monad wrap #.None)) - (<code>.record (<>.and <code>.local_identifier - (\ <>.monad map (|>> #.Some) <code>.any))))) - -(exception: #export (unknown_local_binding {name Text}) - (exception.report - ["Name" (%.text name)])) - -(syntax: #export (here {targets (: (<code>.Parser (List Target)) - (|> ..target - <>.some - (<>.default (list))))}) - (do {! meta.monad} - [location meta.location - locals meta.locals - #let [environment (|> locals - list.concat - ## The list is reversed to make sure that, when building the dictionary, - ## later bindings overshadow earlier ones if they have the same name. - list.reverse - (dictionary.from_list text.hash))] - targets (: (Meta (List Target)) - (case targets - #.Nil - (|> environment - dictionary.keys - (list\map (function (_ local) [local #.None])) - wrap) - - _ - (monad.map ! (function (_ [name format]) - (if (dictionary.key? environment name) - (wrap [name format]) - (function.constant (exception.throw ..unknown_local_binding [name])))) - targets)))] - (wrap (list (` (..log! ("lux text concat" - (~ (code.text (%.format (%.location location) text.new_line))) - ((~! exception.report) - (~+ (list\map (function (_ [name format]) - (let [format (case format - #.None - (` (~! ..inspect)) - - (#.Some format) - format)] - (` [(~ (code.text name)) - ((~ format) (~ (code.local_identifier name)))]))) - targets)))))))))) diff --git a/stdlib/source/lux/extension.lux b/stdlib/source/lux/extension.lux deleted file mode 100644 index 4f02d6ebe..000000000 --- a/stdlib/source/lux/extension.lux +++ /dev/null @@ -1,88 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad]] - [control - ["<>" parser ("#\." monad) - ["<c>" code (#+ Parser)] - ["<a>" analysis] - ["<s>" synthesis]]] - [data - ["." product] - [collection - ["." list ("#\." functor)]]] - [macro (#+ with_gensyms) - ["." code] - [syntax (#+ syntax:)]] - [tool - [compiler - ["." phase]]]]) - -(type: Input - {#variable Text - #parser Code}) - -(def: (simple default) - (-> Code (Parser Input)) - ($_ <>.and - <c>.local_identifier - (<>\wrap default))) - -(def: complex - (Parser Input) - (<c>.record ($_ <>.and - <c>.local_identifier - <c>.any))) - -(def: (input default) - (-> Code (Parser Input)) - (<>.either (..simple default) - ..complex)) - -(type: Declaration - {#name Code - #label Text - #phase Text - #archive Text - #inputs (List Input)}) - -(def: (declaration default) - (-> Code (Parser Declaration)) - (<c>.form ($_ <>.and - <c>.any - <c>.local_identifier - <c>.local_identifier - <c>.local_identifier - (<>.some (..input default))))) - -(template [<any> <end> <and> <run> <extension> <name>] - [(syntax: #export (<name> - {[name extension phase archive inputs] (..declaration (` <any>))} - body) - (let [g!parser (case (list\map product.right inputs) - #.Nil - (` <end>) - - parsers - (` (.$_ <and> (~+ parsers)))) - g!name (code.local_identifier extension) - g!phase (code.local_identifier phase) - g!archive (code.local_identifier archive)] - (with_gensyms [g!handler g!inputs g!error] - (wrap (list (` (<extension> (~ name) - (.function ((~ g!handler) (~ g!name) (~ g!phase) (~ g!archive) (~ g!inputs)) - (.case ((~! <run>) (~ g!parser) (~ g!inputs)) - (#.Right [(~+ (list\map (|>> product.left - code.local_identifier) - inputs))]) - (~ body) - - (#.Left (~ g!error)) - ((~! phase.fail) (~ g!error))) - ))))))))] - - [<c>.any <c>.end! <c>.and <c>.run "lux def analysis" analysis:] - [<a>.any <a>.end! <a>.and <a>.run "lux def synthesis" synthesis:] - [<s>.any <s>.end! <s>.and <s>.run "lux def generation" generation:] - [<c>.any <c>.end! <c>.and <c>.run "lux def directive" directive:] - ) diff --git a/stdlib/source/lux/ffi.js.lux b/stdlib/source/lux/ffi.js.lux deleted file mode 100644 index dd5f584c5..000000000 --- a/stdlib/source/lux/ffi.js.lux +++ /dev/null @@ -1,363 +0,0 @@ -(.module: - [lux #* - ["." meta] - [abstract - [monad (#+ do)]] - [control - ["." io] - ["<>" parser - ["<.>" code (#+ Parser)]]] - [data - ["." product] - ["." maybe] - ["." text - ["%" format]] - [collection - ["." list ("#\." functor fold)]]] - [type - abstract] - [macro (#+ with_gensyms) - [syntax (#+ syntax:)] - ["." code] - ["." template]]]) - -(abstract: #export (Object brand) - Any) - -(template [<name>] - [(with_expansions [<brand> (template.identifier [<name> "'"])] - (abstract: <brand> - Any - - (type: #export <name> - (Object <brand>))))] - - [Function] - [Symbol] - [Null] - [Undefined] - ) - -(template [<name> <type>] - [(type: #export <name> - <type>)] - - [Boolean Bit] - [Number Frac] - [String Text] - ) - -(type: Nullable - [Bit Code]) - -(def: nullable - (Parser Nullable) - (let [token (' #?)] - (<| (<>.and (<>.parses? (<code>.this! token))) - (<>.after (<>.not (<code>.this! token))) - <code>.any))) - -(type: Constructor - (List Nullable)) - -(def: constructor - (Parser Constructor) - (<code>.form (<>.after (<code>.this! (' new)) - (<code>.tuple (<>.some ..nullable))))) - -(type: Field - [Bit Text Nullable]) - -(def: static! - (Parser Any) - (<code>.this! (' #static))) - -(def: field - (Parser Field) - (<code>.form ($_ <>.and - (<>.parses? ..static!) - <code>.local_identifier - ..nullable))) - -(type: Common_Method - {#name Text - #alias (Maybe Text) - #inputs (List Nullable) - #io? Bit - #try? Bit - #output Nullable}) - -(type: Static_Method Common_Method) -(type: Virtual_Method Common_Method) - -(type: Method - (#Static Static_Method) - (#Virtual Virtual_Method)) - -(def: common_method - (Parser Common_Method) - ($_ <>.and - <code>.local_identifier - (<>.maybe (<>.after (<code>.this! (' #as)) <code>.local_identifier)) - (<code>.tuple (<>.some ..nullable)) - (<>.parses? (<code>.this! (' #io))) - (<>.parses? (<code>.this! (' #try))) - ..nullable)) - -(def: static_method - (<>.after ..static! ..common_method)) - -(def: method - (Parser Method) - (<code>.form (<>.or ..static_method - ..common_method))) - -(type: Member - (#Constructor Constructor) - (#Field Field) - (#Method Method)) - -(def: member - (Parser Member) - ($_ <>.or - ..constructor - ..field - ..method - )) - -(def: input_variables - (-> (List Nullable) (List [Bit Code])) - (|>> list.enumeration - (list\map (function (_ [idx [nullable? type]]) - [nullable? (|> idx %.nat code.local_identifier)])))) - -(def: (nullable_type [nullable? type]) - (-> Nullable Code) - (if nullable? - (` (.Maybe (~ type))) - type)) - -(def: (with_null g!temp [nullable? input]) - (-> Code [Bit Code] Code) - (if nullable? - (` (case (~ input) - (#.Some (~ g!temp)) - (~ g!temp) - - #.None - ("js object null"))) - input)) - -(def: (without_null g!temp [nullable? outputT] output) - (-> Code Nullable Code Code) - (if nullable? - (` (let [(~ g!temp) (~ output)] - (if ("js object null?" (~ g!temp)) - #.None - (#.Some (~ g!temp))))) - (` (let [(~ g!temp) (~ output)] - (if (not ("js object null?" (~ g!temp))) - (~ g!temp) - (.error! "Null is an invalid value.")))))) - -(type: Import - (#Class [Text Text (List Member)]) - (#Function Static_Method)) - -(def: import - (Parser Import) - (<>.or (<>.and <code>.local_identifier - (<>.default ["" (list)] - (<code>.tuple (<>.and <code>.text - (<>.some member))))) - (<code>.form ..common_method))) - -(def: (with_io with? without) - (-> Bit Code Code) - (if with? - (` (io.io (~ without))) - without)) - -(def: (io_type io? rawT) - (-> Bit Code Code) - (if io? - (` (io.IO (~ rawT))) - rawT)) - -(def: (with_try with? without_try) - (-> Bit Code Code) - (if with? - (` (.try (~ without_try))) - without_try)) - -(def: (try_type try? rawT) - (-> Bit Code Code) - (if try? - (` (.Either .Text (~ rawT))) - rawT)) - -(def: (make_function g!method g!temp source inputsT io? try? outputT) - (-> Code Code Text (List Nullable) Bit Bit Nullable Code) - (let [g!inputs (input_variables inputsT)] - (` (def: ((~ g!method) - [(~+ (list\map product.right g!inputs))]) - (-> [(~+ (list\map nullable_type inputsT))] - (~ (|> (nullable_type outputT) - (try_type try?) - (io_type io?)))) - (:assume - (~ (<| (with_io io?) - (with_try try?) - (without_null g!temp outputT) - (` ("js apply" - ("js constant" (~ (code.text source))) - (~+ (list\map (with_null g!temp) g!inputs))))))))))) - -(syntax: #export (import: {import ..import}) - (with_gensyms [g!temp] - (case import - (#Class [class format members]) - (with_gensyms [g!object] - (let [qualify (: (-> Text Code) - (function (_ member_name) - (|> format - (text.replace_all "#" class) - (text.replace_all "." member_name) - code.local_identifier))) - g!type (code.local_identifier class) - real_class (text.replace_all "/" "." class)] - (wrap (list& (` (type: (~ g!type) - (..Object (primitive (~ (code.text real_class)))))) - (list\map (function (_ member) - (case member - (#Constructor inputsT) - (let [g!inputs (input_variables inputsT)] - (` (def: ((~ (qualify "new")) - [(~+ (list\map product.right g!inputs))]) - (-> [(~+ (list\map nullable_type inputsT))] - (~ g!type)) - (:assume - ("js object new" - ("js constant" (~ (code.text real_class))) - [(~+ (list\map (with_null g!temp) g!inputs))]))))) - - (#Field [static? field fieldT]) - (if static? - (` ((~! syntax:) ((~ (qualify field))) - (\ (~! meta.monad) (~' wrap) - (list (` (.:as (~ (nullable_type fieldT)) - ("js constant" (~ (code.text (%.format real_class "." field)))))))))) - (` (def: ((~ (qualify field)) - (~ g!object)) - (-> (~ g!type) - (~ (nullable_type fieldT))) - (:assume - (~ (without_null g!temp fieldT (` ("js object get" (~ (code.text field)) (~ g!object))))))))) - - (#Method method) - (case method - (#Static [method alias inputsT io? try? outputT]) - (..make_function (qualify (maybe.default method alias)) - g!temp - (%.format real_class "." method) - inputsT - io? - try? - outputT) - - (#Virtual [method alias inputsT io? try? outputT]) - (let [g!inputs (input_variables inputsT)] - (` (def: ((~ (qualify (maybe.default method alias))) - [(~+ (list\map product.right g!inputs))] - (~ g!object)) - (-> [(~+ (list\map nullable_type inputsT))] - (~ g!type) - (~ (|> (nullable_type outputT) - (try_type try?) - (io_type io?)))) - (:assume - (~ (<| (with_io io?) - (with_try try?) - (without_null g!temp outputT) - (` ("js object do" - (~ (code.text method)) - (~ g!object) - [(~+ (list\map (with_null g!temp) g!inputs))]))))))))))) - members))))) - - (#Function [name alias inputsT io? try? outputT]) - (wrap (list (..make_function (code.local_identifier (maybe.default name alias)) - g!temp - name - inputsT - io? - try? - outputT))) - ))) - -(template: #export (type_of object) - ("js type-of" object)) - -(syntax: #export (constant type - {[head tail] (<code>.tuple (<>.and <code>.local_identifier (<>.some <code>.local_identifier)))}) - (with_gensyms [g!_] - (let [constant (` ("js constant" (~ (code.text head))))] - (case tail - #.Nil - (wrap (list (` (: (.Maybe (~ type)) - (case (..type_of (~ constant)) - "undefined" - #.None - - (~ g!_) - (#.Some (:as (~ type) (~ constant)))))))) - - (#.Cons [next tail]) - (let [separator "."] - (wrap (list (` (: (.Maybe (~ type)) - (case (..type_of (~ constant)) - "undefined" - #.None - - (~ g!_) - (..constant (~ type) [(~ (code.local_identifier (%.format head "." next))) - (~+ (list\map code.local_identifier tail))]))))))))))) - -(template: (!defined? <constant>) - (.case (..constant Any <constant>) - #.None - .false - - (#.Some _) - .true)) - -(template [<name> <constant>] - [(def: #export <name> - Bit - (!defined? <constant>))] - - [on_browser? [window]] - [on_nashorn? [java lang Object]] - ) - -(def: #export on_node_js? - Bit - (case (..constant (Object Any) [process]) - (#.Some process) - (case (:as Text - ("js apply" ("js constant" "Object.prototype.toString.call") process)) - "[object process]" - true - - _ - false) - - #.None - false)) - -(template: #export (closure <inputs> <output>) - (.:as ..Function - (`` ("js function" - (~~ (template.count <inputs>)) - (.function (_ [<inputs>]) - <output>))))) diff --git a/stdlib/source/lux/ffi.jvm.lux b/stdlib/source/lux/ffi.jvm.lux deleted file mode 100644 index 8e58c5e50..000000000 --- a/stdlib/source/lux/ffi.jvm.lux +++ /dev/null @@ -1,2047 +0,0 @@ -(.module: - ["." lux (#- Type type int char interface:) - ["#_." type ("#\." equivalence)] - [abstract - ["." monad (#+ Monad do)] - ["." enum]] - [control - ["." function] - ["." io] - ["." try (#+ Try)] - ["." exception (#+ Exception exception:)] - ["<>" parser ("#\." monad) - ["<.>" code (#+ Parser)]]] - [data - ["." maybe] - ["." product] - ["." text ("#\." equivalence) - ["%" format (#+ format)]] - [collection - ["." array] - ["." list ("#\." monad fold monoid)] - ["." dictionary (#+ Dictionary)]]] - [macro (#+ with_gensyms) - [syntax (#+ syntax:)] - ["." code] - ["." template]] - ["." meta - ["." annotation]] - [target - [jvm - [encoding - ["." name (#+ External)]] - ["." type (#+ Type Argument Typed) - ["." category (#+ Void Value' Value Return' Return Method Primitive Object Class Array Var Parameter Declaration)] - ["." box] - ["." descriptor] - ["." signature] - ["." reflection] - ["." parser]]]]]) - -(def: internal - (-> External Text) - (|>> name.internal - name.read)) - -(def: signature - (All [category] - (-> (Type category) Text)) - (|>> type.signature signature.signature)) - -(def: reflection - (All [category] - (-> (Type (<| Return' Value' category)) Text)) - (|>> type.reflection reflection.reflection)) - -(template [<name> <class>] - [(def: #export <name> - .Type - (#.Primitive <class> #.Nil))] - - [Boolean box.boolean] - [Byte box.byte] - [Short box.short] - [Integer box.int] - [Long box.long] - [Float box.float] - [Double box.double] - [Character box.char] - ) - -(template [<name> <class>] - [(def: #export <name> - .Type - (#.Primitive (reflection.reflection <class>) #.Nil))] - - ## Primitives - [boolean reflection.boolean] - [byte reflection.byte] - [short reflection.short] - [int reflection.int] - [long reflection.long] - [float reflection.float] - [double reflection.double] - [char reflection.char] - ) - -(def: (get_static_field class field) - (-> Text Text Code) - (` ("jvm member get static" - (~ (code.text class)) - (~ (code.text field))))) - -(def: (get_virtual_field class field object) - (-> Text Text Code Code) - (` ("jvm member get virtual" - (~ (code.text class)) - (~ (code.text field)) - (~ object)))) - -(def: boxes - (Dictionary (Type Value) Text) - (|> (list [type.boolean box.boolean] - [type.byte box.byte] - [type.short box.short] - [type.int box.int] - [type.long box.long] - [type.float box.float] - [type.double box.double] - [type.char box.char]) - (dictionary.from_list type.hash))) - -(template [<name> <pre> <post>] - [(def: (<name> unboxed boxed raw) - (-> (Type Value) Text Code Code) - (let [unboxed (..reflection unboxed)] - (` (|> (~ raw) - (: (primitive (~ (code.text <pre>)))) - "jvm object cast" - (: (primitive (~ (code.text <post>))))))))] - - [unbox boxed unboxed] - [box unboxed boxed] - ) - -(template [<name> <op> <from> <to>] - [(template: #export (<name> value) - {#.doc (doc "Type converter." - (: <to> - (<name> (: <from> foo))))} - (|> value - (: <from>) - "jvm object cast" - <op> - "jvm object cast" - (: <to>)))] - - [byte_to_long "jvm conversion byte-to-long" ..Byte ..Long] - - [short_to_long "jvm conversion short-to-long" ..Short ..Long] - - [double_to_int "jvm conversion double-to-int" ..Double ..Integer] - [double_to_long "jvm conversion double-to-long" ..Double ..Long] - [double_to_float "jvm conversion double-to-float" ..Double ..Float] - - [float_to_int "jvm conversion float-to-int" ..Float ..Integer] - [float_to_long "jvm conversion float-to-long" ..Float ..Long] - [float_to_double "jvm conversion float-to-double" ..Float ..Double] - - [int_to_byte "jvm conversion int-to-byte" ..Integer ..Byte] - [int_to_short "jvm conversion int-to-short" ..Integer ..Short] - [int_to_long "jvm conversion int-to-long" ..Integer ..Long] - [int_to_float "jvm conversion int-to-float" ..Integer ..Float] - [int_to_double "jvm conversion int-to-double" ..Integer ..Double] - [int_to_char "jvm conversion int-to-char" ..Integer ..Character] - - [long_to_byte "jvm conversion long-to-byte" ..Long ..Byte] - [long_to_short "jvm conversion long-to-short" ..Long ..Short] - [long_to_int "jvm conversion long-to-int" ..Long ..Integer] - [long_to_float "jvm conversion long-to-float" ..Long ..Float] - [long_to_double "jvm conversion long-to-double" ..Long ..Double] - - [char_to_byte "jvm conversion char-to-byte" ..Character ..Byte] - [char_to_short "jvm conversion char-to-short" ..Character ..Short] - [char_to_int "jvm conversion char-to-int" ..Character ..Integer] - [char_to_long "jvm conversion char-to-long" ..Character ..Long] - ) - -(template [<name> <from> <to> <0> <1>] - [(template: #export (<name> value) - {#.doc (doc "Type converter." - (: <to> - (<name> (: <from> foo))))} - (|> value <0> <1>))] - - [long_to_char ..Long ..Character ..long_to_int ..int_to_char] - [byte_to_int ..Byte ..Integer ..byte_to_long ..long_to_int] - [short_to_int ..Short ..Integer ..short_to_long ..long_to_int] - [byte_to_char ..Byte ..Character ..byte_to_int ..int_to_char] - [short_to_char ..Short ..Character ..short_to_int ..int_to_char] - ) - -(def: constructor_method_name - "<init>") - -(type: Primitive_Mode - #ManualPrM - #AutoPrM) - -(type: Privacy - #PublicP - #PrivateP - #ProtectedP - #DefaultP) - -(type: StateModifier - #VolatileSM - #FinalSM - #DefaultSM) - -(type: InheritanceModifier - #FinalIM - #AbstractIM - #DefaultIM) - -(type: Class_Kind - #Class - #Interface) - -(type: StackFrame (primitive "java/lang/StackTraceElement")) -(type: StackTrace (array.Array StackFrame)) - -(type: Annotation_Parameter - [Text Code]) - -(type: Annotation - {#ann_name Text - #ann_params (List Annotation_Parameter)}) - -(type: Member_Declaration - {#member_name Text - #member_privacy Privacy - #member_anns (List Annotation)}) - -(type: FieldDecl - (#ConstantField (Type Value) Code) - (#VariableField StateModifier (Type Value))) - -(type: MethodDecl - {#method_tvars (List (Type Var)) - #method_inputs (List (Type Value)) - #method_output (Type Return) - #method_exs (List (Type Class))}) - -(type: Method_Definition - (#ConstructorMethod [Bit - (List (Type Var)) - Text - (List Argument) - (List (Typed Code)) - Code - (List (Type Class))]) - (#VirtualMethod [Bit - Bit - (List (Type Var)) - Text - (List Argument) - (Type Return) - Code - (List (Type Class))]) - (#OverridenMethod [Bit - (Type Declaration) - (List (Type Var)) - Text - (List Argument) - (Type Return) - Code - (List (Type Class))]) - (#StaticMethod [Bit - (List (Type Var)) - (List Argument) - (Type Return) - Code - (List (Type Class))]) - (#AbstractMethod [(List (Type Var)) - (List Argument) - (Type Return) - (List (Type Class))]) - (#NativeMethod [(List (Type Var)) - (List Argument) - (Type Return) - (List (Type Class))])) - -(type: Partial_Call - {#pc_method Name - #pc_args (List Code)}) - -(type: ImportMethodKind - #StaticIMK - #VirtualIMK) - -(type: ImportMethodCommons - {#import_member_mode Primitive_Mode - #import_member_alias Text - #import_member_kind ImportMethodKind - #import_member_tvars (List (Type Var)) - #import_member_args (List [Bit (Type Value)]) - #import_member_maybe? Bit - #import_member_try? Bit - #import_member_io? Bit}) - -(type: ImportConstructorDecl - {}) - -(type: ImportMethodDecl - {#import_method_name Text - #import_method_return (Type Return)}) - -(type: ImportFieldDecl - {#import_field_mode Primitive_Mode - #import_field_name Text - #import_field_static? Bit - #import_field_maybe? Bit - #import_field_setter? Bit - #import_field_type (Type Value)}) - -(type: Import_Member_Declaration - (#EnumDecl (List Text)) - (#ConstructorDecl [ImportMethodCommons ImportConstructorDecl]) - (#MethodDecl [ImportMethodCommons ImportMethodDecl]) - (#FieldAccessDecl ImportFieldDecl)) - -(def: (primitive_type mode type) - (-> Primitive_Mode (Type Primitive) Code) - (case mode - #ManualPrM - (cond (\ type.equivalence = type.boolean type) (` ..Boolean) - (\ type.equivalence = type.byte type) (` ..Byte) - (\ type.equivalence = type.short type) (` ..Short) - (\ type.equivalence = type.int type) (` ..Integer) - (\ type.equivalence = type.long type) (` ..Long) - (\ type.equivalence = type.float type) (` ..Float) - (\ type.equivalence = type.double type) (` ..Double) - (\ type.equivalence = type.char type) (` ..Character) - ## else - (undefined)) - - #AutoPrM - (cond (\ type.equivalence = type.boolean type) - (` .Bit) - - (or (\ type.equivalence = type.short type) - (\ type.equivalence = type.byte type) - (\ type.equivalence = type.int type) - (\ type.equivalence = type.long type)) - (` .Int) - - (or (\ type.equivalence = type.float type) - (\ type.equivalence = type.double type)) - (` .Frac) - - (\ type.equivalence = type.char type) - (` .Nat) - - ## else - (undefined)))) - -(def: (parameter_type type) - (-> (Type Parameter) Code) - (`` (<| (~~ (template [<when> <binding> <then>] - [(case (<when> type) - (#.Some <binding>) - <then> - - #.None)] - - [parser.var? name (code.identifier ["" name])] - [parser.wildcard? _ (` .Any)] - [parser.lower? _ (` .Any)] - [parser.upper? limit (parameter_type limit)] - [parser.class? [name parameters] - (` (.primitive (~ (code.text name)) - [(~+ (list\map parameter_type parameters))]))])) - ## else - (undefined) - ))) - -(def: (value_type mode type) - (-> Primitive_Mode (Type Value) Code) - (`` (<| (~~ (template [<when> <binding> <then>] - [(case (<when> type) - (#.Some <binding>) - <then> - - #.None)] - - [parser.parameter? type (parameter_type type)] - [parser.primitive? type (primitive_type mode type)] - [parser.array? elementT (case (parser.primitive? elementT) - (#.Some elementT) - (` (#.Primitive (~ (code.text (..reflection (type.array elementT)))) #.Nil)) - - #.None - (` (#.Primitive (~ (code.text array.type_name)) - (#.Cons (~ (value_type mode elementT)) #.Nil))))])) - (undefined) - ))) - -(def: declaration_type$ - (-> (Type Declaration) Code) - (|>> ..signature code.text)) - -(def: (make_get_const_parser class_name field_name) - (-> Text Text (Parser Code)) - (do <>.monad - [#let [dotted_name (format "::" field_name)] - _ (<code>.this! (code.identifier ["" dotted_name]))] - (wrap (get_static_field class_name field_name)))) - -(def: (make_get_var_parser class_name field_name) - (-> Text Text (Parser Code)) - (do <>.monad - [#let [dotted_name (format "::" field_name)] - _ (<code>.this! (code.identifier ["" dotted_name]))] - (wrap (get_virtual_field class_name field_name (' _jvm_this))))) - -(def: (make_put_var_parser class_name field_name) - (-> Text Text (Parser Code)) - (do <>.monad - [#let [dotted_name (format "::" field_name)] - [_ _ value] (: (Parser [Any Any Code]) - (<code>.form ($_ <>.and (<code>.this! (' :=)) (<code>.this! (code.identifier ["" dotted_name])) <code>.any)))] - (wrap (`' ((~ (code.text (format "jvm putfield" ":" class_name ":" field_name))) _jvm_this (~ value)))))) - -(def: (pre_walk_replace f input) - (-> (-> Code Code) Code Code) - (case (f input) - (^template [<tag>] - [[meta (<tag> parts)] - [meta (<tag> (list\map (pre_walk_replace f) parts))]]) - ([#.Form] - [#.Tuple]) - - [meta (#.Record pairs)] - [meta (#.Record (list\map (: (-> [Code Code] [Code Code]) - (function (_ [key val]) - [(pre_walk_replace f key) (pre_walk_replace f val)])) - pairs))] - - ast' - ast')) - -(def: (parser->replacer p ast) - (-> (Parser Code) (-> Code Code)) - (case (<>.run p (list ast)) - (#.Right [#.Nil ast']) - ast' - - _ - ast - )) - -(def: (field->parser class_name [[field_name _ _] field]) - (-> Text [Member_Declaration FieldDecl] (Parser Code)) - (case field - (#ConstantField _) - (make_get_const_parser class_name field_name) - - (#VariableField _) - (<>.either (make_get_var_parser class_name field_name) - (make_put_var_parser class_name field_name)))) - -(def: (decorate_input [class value]) - (-> [(Type Value) Code] Code) - (` [(~ (code.text (..signature class))) (~ value)])) - -(def: (make_constructor_parser class_name arguments) - (-> Text (List Argument) (Parser Code)) - (do <>.monad - [args (: (Parser (List Code)) - (<code>.form (<>.after (<code>.this! (' ::new!)) - (<code>.tuple (<>.exactly (list.size arguments) <code>.any)))))] - (wrap (` ("jvm member invoke constructor" (~ (code.text class_name)) - (~+ (|> args - (list.zip/2 (list\map product.right arguments)) - (list\map ..decorate_input)))))))) - -(def: (make_static_method_parser class_name method_name arguments) - (-> Text Text (List Argument) (Parser Code)) - (do <>.monad - [#let [dotted_name (format "::" method_name "!")] - args (: (Parser (List Code)) - (<code>.form (<>.after (<code>.this! (code.identifier ["" dotted_name])) - (<code>.tuple (<>.exactly (list.size arguments) <code>.any)))))] - (wrap (` ("jvm member invoke static" (~ (code.text class_name)) (~ (code.text method_name)) - (~+ (|> args - (list.zip/2 (list\map product.right arguments)) - (list\map ..decorate_input)))))))) - -(template [<name> <jvm_op>] - [(def: (<name> class_name method_name arguments) - (-> Text Text (List Argument) (Parser Code)) - (do <>.monad - [#let [dotted_name (format "::" method_name "!")] - args (: (Parser (List Code)) - (<code>.form (<>.after (<code>.this! (code.identifier ["" dotted_name])) - (<code>.tuple (<>.exactly (list.size arguments) <code>.any)))))] - (wrap (` (<jvm_op> (~ (code.text class_name)) (~ (code.text method_name)) - (~' _jvm_this) - (~+ (|> args - (list.zip/2 (list\map product.right arguments)) - (list\map ..decorate_input))))))))] - - [make_special_method_parser "jvm member invoke special"] - [make_virtual_method_parser "jvm member invoke virtual"] - ) - -(def: (method->parser class_name [[method_name _ _] meth_def]) - (-> Text [Member_Declaration Method_Definition] (Parser Code)) - (case meth_def - (#ConstructorMethod strict? type_vars self_name args constructor_args return_expr exs) - (make_constructor_parser class_name args) - - (#StaticMethod strict? type_vars args return_type return_expr exs) - (make_static_method_parser class_name method_name args) - - (^or (#VirtualMethod final? strict? type_vars self_name args return_type return_expr exs) - (#OverridenMethod strict? owner_class type_vars self_name args return_type return_expr exs)) - (make_special_method_parser class_name method_name args) - - (#AbstractMethod type_vars args return_type exs) - (make_virtual_method_parser class_name method_name args) - - (#NativeMethod type_vars args return_type exs) - (make_virtual_method_parser class_name method_name args))) - -(def: privacy_modifier^ - (Parser Privacy) - (let [(^open ".") <>.monad] - ($_ <>.or - (<code>.this! (' #public)) - (<code>.this! (' #private)) - (<code>.this! (' #protected)) - (wrap [])))) - -(def: inheritance_modifier^ - (Parser InheritanceModifier) - (let [(^open ".") <>.monad] - ($_ <>.or - (<code>.this! (' #final)) - (<code>.this! (' #abstract)) - (wrap [])))) - -(exception: #export (class_names_cannot_contain_periods {name Text}) - (exception.report - ["Name" (%.text name)])) - -(exception: #export (class_name_cannot_be_a_type_variable {name Text} - {type_vars (List (Type Var))}) - (exception.report - ["Name" (%.text name)] - ["Type Variables" (exception.enumerate parser.name type_vars)])) - -(def: (assert exception payload test) - (All [e] (-> (Exception e) e Bit (Parser Any))) - (<>.assert (exception.construct exception payload) - test)) - -(def: (valid_class_name type_vars) - (-> (List (Type Var)) (Parser External)) - (do <>.monad - [name <code>.local_identifier - _ (..assert ..class_names_cannot_contain_periods [name] - (not (text.contains? name.external_separator name))) - _ (..assert ..class_name_cannot_be_a_type_variable [name type_vars] - (not (list.member? text.equivalence - (list\map parser.name type_vars) - name)))] - (wrap name))) - -(def: (class^' parameter^ type_vars) - (-> (-> (List (Type Var)) (Parser (Type Parameter))) - (-> (List (Type Var)) (Parser (Type Class)))) - (do <>.monad - [[name parameters] (: (Parser [External (List (Type Parameter))]) - ($_ <>.either - (<>.and (valid_class_name type_vars) - (<>\wrap (list))) - (<code>.form (<>.and <code>.local_identifier - (<>.some (parameter^ type_vars))))))] - (wrap (type.class (name.sanitize name) parameters)))) - -(exception: #export (unexpected_type_variable {name Text} - {type_vars (List (Type Var))}) - (exception.report - ["Unexpected Type Variable" (%.text name)] - ["Expected Type Variables" (exception.enumerate parser.name type_vars)])) - -(def: (variable^ type_vars) - (-> (List (Type Var)) (Parser (Type Parameter))) - (do <>.monad - [name <code>.local_identifier - _ (..assert ..unexpected_type_variable [name type_vars] - (list.member? text.equivalence (list\map parser.name type_vars) name))] - (wrap (type.var name)))) - -(def: wildcard^ - (Parser (Type Parameter)) - (do <>.monad - [_ (<code>.this! (' ?))] - (wrap type.wildcard))) - -(template [<name> <comparison> <constructor>] - [(def: <name> - (-> (Parser (Type Class)) (Parser (Type Parameter))) - (|>> (<>.after (<code>.this! (' <comparison>))) - (<>.after ..wildcard^) - <code>.tuple - (\ <>.monad map <constructor>)))] - - [upper^ < type.upper] - [lower^ > type.lower] - ) - -(def: (parameter^ type_vars) - (-> (List (Type Var)) (Parser (Type Parameter))) - (<>.rec - (function (_ recur^) - (let [class^ (..class^' parameter^ type_vars)] - ($_ <>.either - (..variable^ type_vars) - ..wildcard^ - (upper^ class^) - (lower^ class^) - class^ - ))))) - -(def: (itself^ type) - (All [category] - (-> (Type (<| Return' Value' category)) - (Parser (Type (<| Return' Value' category))))) - (do <>.monad - [_ (<code>.identifier! ["" (..reflection type)])] - (wrap type))) - -(def: primitive^ - (Parser (Type Primitive)) - ($_ <>.either - (itself^ type.boolean) - (itself^ type.byte) - (itself^ type.short) - (itself^ type.int) - (itself^ type.long) - (itself^ type.float) - (itself^ type.double) - (itself^ type.char) - )) - -(def: array^ - (-> (Parser (Type Value)) (Parser (Type Array))) - (|>> <code>.tuple - (\ <>.monad map type.array))) - -(def: (type^ type_vars) - (-> (List (Type Var)) (Parser (Type Value))) - (<>.rec - (function (_ type^) - ($_ <>.either - ..primitive^ - (..parameter^ type_vars) - (..array^ type^) - )))) - -(def: void^ - (Parser (Type Void)) - (do <>.monad - [_ (<code>.identifier! ["" (reflection.reflection reflection.void)])] - (wrap type.void))) - -(def: (return^ type_vars) - (-> (List (Type Var)) (Parser (Type Return))) - (<>.either ..void^ - (..type^ type_vars))) - -(def: var^ - (Parser (Type Var)) - (\ <>.monad map type.var <code>.local_identifier)) - -(def: vars^ - (Parser (List (Type Var))) - (<code>.tuple (<>.some var^))) - -(def: declaration^ - (Parser (Type Declaration)) - (do <>.monad - [[name variables] (: (Parser [External (List (Type Var))]) - (<>.either (<>.and (..valid_class_name (list)) - (<>\wrap (list))) - (<code>.form (<>.and (..valid_class_name (list)) - (<>.some var^))) - ))] - (wrap (type.declaration name variables)))) - -(def: (class^ type_vars) - (-> (List (Type Var)) (Parser (Type Class))) - (class^' parameter^ type_vars)) - -(def: annotation_parameters^ - (Parser (List Annotation_Parameter)) - (<code>.record (<>.some (<>.and <code>.local_tag <code>.any)))) - -(def: annotation^ - (Parser Annotation) - (<>.either (do <>.monad - [ann_name <code>.local_identifier] - (wrap [ann_name (list)])) - (<code>.form (<>.and <code>.local_identifier - annotation_parameters^)))) - -(def: annotations^' - (Parser (List Annotation)) - (do <>.monad - [_ (<code>.this! (' #ann))] - (<code>.tuple (<>.some ..annotation^)))) - -(def: annotations^ - (Parser (List Annotation)) - (do <>.monad - [anns?? (<>.maybe ..annotations^')] - (wrap (maybe.default (list) anns??)))) - -(def: (throws_decl^ type_vars) - (-> (List (Type Var)) (Parser (List (Type Class)))) - (<| (<>.default (list)) - (do <>.monad - [_ (<code>.this! (' #throws))] - (<code>.tuple (<>.some (..class^ type_vars)))))) - -(def: (method_decl^ type_vars) - (-> (List (Type Var)) (Parser [Member_Declaration MethodDecl])) - (<code>.form (do <>.monad - [tvars (<>.default (list) ..vars^) - name <code>.local_identifier - anns ..annotations^ - inputs (<code>.tuple (<>.some (..type^ type_vars))) - output (..return^ type_vars) - exs (throws_decl^ type_vars)] - (wrap [[name #PublicP anns] {#method_tvars tvars - #method_inputs inputs - #method_output output - #method_exs exs}])))) - -(def: state_modifier^ - (Parser StateModifier) - ($_ <>.or - (<code>.this! (' #volatile)) - (<code>.this! (' #final)) - (\ <>.monad wrap []))) - -(def: (field_decl^ type_vars) - (-> (List (Type Var)) (Parser [Member_Declaration FieldDecl])) - (<>.either (<code>.form (do <>.monad - [_ (<code>.this! (' #const)) - name <code>.local_identifier - anns ..annotations^ - type (..type^ type_vars) - body <code>.any] - (wrap [[name #PublicP anns] (#ConstantField [type body])]))) - (<code>.form (do <>.monad - [pm privacy_modifier^ - sm state_modifier^ - name <code>.local_identifier - anns ..annotations^ - type (..type^ type_vars)] - (wrap [[name pm anns] (#VariableField [sm type])]))))) - -(def: (argument^ type_vars) - (-> (List (Type Var)) (Parser Argument)) - (<code>.record (<>.and <code>.local_identifier - (..type^ type_vars)))) - -(def: (arguments^ type_vars) - (-> (List (Type Var)) (Parser (List Argument))) - (<>.some (..argument^ type_vars))) - -(def: (constructor_arg^ type_vars) - (-> (List (Type Var)) (Parser (Typed Code))) - (<code>.record (<>.and (..type^ type_vars) <code>.any))) - -(def: (constructor_args^ type_vars) - (-> (List (Type Var)) (Parser (List (Typed Code)))) - (<code>.tuple (<>.some (..constructor_arg^ type_vars)))) - -(def: (constructor_method^ class_vars) - (-> (List (Type Var)) (Parser [Member_Declaration Method_Definition])) - (<code>.form (do <>.monad - [pm privacy_modifier^ - strict_fp? (<>.parses? (<code>.this! (' #strict))) - method_vars (<>.default (list) ..vars^) - #let [total_vars (list\compose class_vars method_vars)] - [_ self_name arguments] (<code>.form ($_ <>.and - (<code>.this! (' new)) - <code>.local_identifier - (..arguments^ total_vars))) - constructor_args (..constructor_args^ total_vars) - exs (throws_decl^ total_vars) - annotations ..annotations^ - body <code>.any] - (wrap [{#member_name constructor_method_name - #member_privacy pm - #member_anns annotations} - (#ConstructorMethod strict_fp? method_vars self_name arguments constructor_args body exs)])))) - -(def: (virtual_method_def^ class_vars) - (-> (List (Type Var)) (Parser [Member_Declaration Method_Definition])) - (<code>.form (do <>.monad - [pm privacy_modifier^ - strict_fp? (<>.parses? (<code>.this! (' #strict))) - final? (<>.parses? (<code>.this! (' #final))) - method_vars (<>.default (list) ..vars^) - #let [total_vars (list\compose class_vars method_vars)] - [name self_name arguments] (<code>.form ($_ <>.and - <code>.local_identifier - <code>.local_identifier - (..arguments^ total_vars))) - return_type (..return^ total_vars) - exs (throws_decl^ total_vars) - annotations ..annotations^ - body <code>.any] - (wrap [{#member_name name - #member_privacy pm - #member_anns annotations} - (#VirtualMethod final? strict_fp? method_vars self_name arguments return_type body exs)])))) - -(def: overriden_method_def^ - (Parser [Member_Declaration Method_Definition]) - (<code>.form (do <>.monad - [strict_fp? (<>.parses? (<code>.this! (' #strict))) - owner_class ..declaration^ - method_vars (<>.default (list) ..vars^) - #let [total_vars (list\compose (product.right (parser.declaration owner_class)) - method_vars)] - [name self_name arguments] (<code>.form ($_ <>.and - <code>.local_identifier - <code>.local_identifier - (..arguments^ total_vars))) - return_type (..return^ total_vars) - exs (throws_decl^ total_vars) - annotations ..annotations^ - body <code>.any] - (wrap [{#member_name name - #member_privacy #PublicP - #member_anns annotations} - (#OverridenMethod strict_fp? owner_class method_vars self_name arguments return_type body exs)])))) - -(def: static_method_def^ - (Parser [Member_Declaration Method_Definition]) - (<code>.form (do <>.monad - [pm privacy_modifier^ - strict_fp? (<>.parses? (<code>.this! (' #strict))) - _ (<code>.this! (' #static)) - method_vars (<>.default (list) ..vars^) - #let [total_vars method_vars] - [name arguments] (<code>.form (<>.and <code>.local_identifier - (..arguments^ total_vars))) - return_type (..return^ total_vars) - exs (throws_decl^ total_vars) - annotations ..annotations^ - body <code>.any] - (wrap [{#member_name name - #member_privacy pm - #member_anns annotations} - (#StaticMethod strict_fp? method_vars arguments return_type body exs)])))) - -(def: abstract_method_def^ - (Parser [Member_Declaration Method_Definition]) - (<code>.form (do <>.monad - [pm privacy_modifier^ - _ (<code>.this! (' #abstract)) - method_vars (<>.default (list) ..vars^) - #let [total_vars method_vars] - [name arguments] (<code>.form (<>.and <code>.local_identifier - (..arguments^ total_vars))) - return_type (..return^ total_vars) - exs (throws_decl^ total_vars) - annotations ..annotations^] - (wrap [{#member_name name - #member_privacy pm - #member_anns annotations} - (#AbstractMethod method_vars arguments return_type exs)])))) - -(def: native_method_def^ - (Parser [Member_Declaration Method_Definition]) - (<code>.form (do <>.monad - [pm privacy_modifier^ - _ (<code>.this! (' #native)) - method_vars (<>.default (list) ..vars^) - #let [total_vars method_vars] - [name arguments] (<code>.form (<>.and <code>.local_identifier - (..arguments^ total_vars))) - return_type (..return^ total_vars) - exs (throws_decl^ total_vars) - annotations ..annotations^] - (wrap [{#member_name name - #member_privacy pm - #member_anns annotations} - (#NativeMethod method_vars arguments return_type exs)])))) - -(def: (method_def^ class_vars) - (-> (List (Type Var)) (Parser [Member_Declaration Method_Definition])) - ($_ <>.either - (..constructor_method^ class_vars) - (..virtual_method_def^ class_vars) - ..overriden_method_def^ - ..static_method_def^ - ..abstract_method_def^ - ..native_method_def^)) - -(def: partial_call^ - (Parser Partial_Call) - (<code>.form (<>.and <code>.identifier (<>.some <code>.any)))) - -(def: class_kind^ - (Parser Class_Kind) - (<>.either (do <>.monad - [_ (<code>.this! (' #class))] - (wrap #Class)) - (do <>.monad - [_ (<code>.this! (' #interface))] - (wrap #Interface)) - )) - -(def: import_member_alias^ - (Parser (Maybe Text)) - (<>.maybe (do <>.monad - [_ (<code>.this! (' #as))] - <code>.local_identifier))) - -(def: (import_member_args^ type_vars) - (-> (List (Type Var)) (Parser (List [Bit (Type Value)]))) - (<code>.tuple (<>.some (<>.and (<>.parses? (<code>.tag! ["" "?"])) - (..type^ type_vars))))) - -(def: import_member_return_flags^ - (Parser [Bit Bit Bit]) - ($_ <>.and - (<>.parses? (<code>.this! (' #io))) - (<>.parses? (<code>.this! (' #try))) - (<>.parses? (<code>.this! (' #?))))) - -(def: primitive_mode^ - (Parser Primitive_Mode) - (<>.or (<code>.tag! ["" "manual"]) - (<code>.tag! ["" "auto"]))) - -(def: (import_member_decl^ owner_vars) - (-> (List (Type Var)) (Parser Import_Member_Declaration)) - ($_ <>.either - (<code>.form (do <>.monad - [_ (<code>.this! (' #enum)) - enum_members (<>.some <code>.local_identifier)] - (wrap (#EnumDecl enum_members)))) - (<code>.form (do <>.monad - [tvars (<>.default (list) ..vars^) - _ (<code>.identifier! ["" "new"]) - ?alias import_member_alias^ - #let [total_vars (list\compose owner_vars tvars)] - ?prim_mode (<>.maybe primitive_mode^) - args (..import_member_args^ total_vars) - [io? try? maybe?] import_member_return_flags^] - (wrap (#ConstructorDecl [{#import_member_mode (maybe.default #AutoPrM ?prim_mode) - #import_member_alias (maybe.default "new" ?alias) - #import_member_kind #VirtualIMK - #import_member_tvars tvars - #import_member_args args - #import_member_maybe? maybe? - #import_member_try? try? - #import_member_io? io?} - {}])) - )) - (<code>.form (do <>.monad - [kind (: (Parser ImportMethodKind) - (<>.or (<code>.tag! ["" "static"]) - (wrap []))) - tvars (<>.default (list) ..vars^) - name <code>.local_identifier - ?alias import_member_alias^ - #let [total_vars (list\compose owner_vars tvars)] - ?prim_mode (<>.maybe primitive_mode^) - args (..import_member_args^ total_vars) - [io? try? maybe?] import_member_return_flags^ - return (..return^ total_vars)] - (wrap (#MethodDecl [{#import_member_mode (maybe.default #AutoPrM ?prim_mode) - #import_member_alias (maybe.default name ?alias) - #import_member_kind kind - #import_member_tvars tvars - #import_member_args args - #import_member_maybe? maybe? - #import_member_try? try? - #import_member_io? io?} - {#import_method_name name - #import_method_return return}])))) - (<code>.form (do <>.monad - [static? (<>.parses? (<code>.this! (' #static))) - name <code>.local_identifier - ?prim_mode (<>.maybe primitive_mode^) - gtype (..type^ owner_vars) - maybe? (<>.parses? (<code>.this! (' #?))) - setter? (<>.parses? (<code>.this! (' #!)))] - (wrap (#FieldAccessDecl {#import_field_mode (maybe.default #AutoPrM ?prim_mode) - #import_field_name name - #import_field_static? static? - #import_field_maybe? maybe? - #import_field_setter? setter? - #import_field_type gtype})))) - )) - -(def: bundle - (-> (List (Type Var)) (Parser [Text (List Import_Member_Declaration)])) - (|>> ..import_member_decl^ - <>.some - (<>.and <code>.text) - <code>.tuple)) - -(def: (privacy_modifier$ pm) - (-> Privacy Code) - (case pm - #PublicP (code.text "public") - #PrivateP (code.text "private") - #ProtectedP (code.text "protected") - #DefaultP (code.text "default"))) - -(def: (inheritance_modifier$ im) - (-> InheritanceModifier Code) - (case im - #FinalIM (code.text "final") - #AbstractIM (code.text "abstract") - #DefaultIM (code.text "default"))) - -(def: (annotation_parameter$ [name value]) - (-> Annotation_Parameter Code) - (` [(~ (code.text name)) (~ value)])) - -(def: (annotation$ [name params]) - (-> Annotation Code) - (` ((~ (code.text name)) (~+ (list\map annotation_parameter$ params))))) - -(template [<name> <category>] - [(def: <name> - (-> (Type <category>) Code) - (|>> ..signature code.text))] - - [var$ Var] - [parameter$ Parameter] - [value$ Value] - [return$ Return] - [declaration$ Declaration] - [class$ Class] - ) - -(def: var$' - (-> (Type Var) Code) - (|>> ..signature code.local_identifier)) - -(def: (method_decl$ [[name pm anns] method_decl]) - (-> [Member_Declaration MethodDecl] Code) - (let [(^slots [#method_tvars #method_inputs #method_output #method_exs]) method_decl] - (` ((~ (code.text name)) - [(~+ (list\map annotation$ anns))] - [(~+ (list\map var$ method_tvars))] - [(~+ (list\map class$ method_exs))] - [(~+ (list\map value$ method_inputs))] - (~ (return$ method_output)))))) - -(def: (state_modifier$ sm) - (-> StateModifier Code) - (case sm - #VolatileSM (' "volatile") - #FinalSM (' "final") - #DefaultSM (' "default"))) - -(def: (field_decl$ [[name pm anns] field]) - (-> [Member_Declaration FieldDecl] Code) - (case field - (#ConstantField class value) - (` ("constant" (~ (code.text name)) - [(~+ (list\map annotation$ anns))] - (~ (value$ class)) - (~ value) - )) - - (#VariableField sm class) - (` ("variable" (~ (code.text name)) - (~ (privacy_modifier$ pm)) - (~ (state_modifier$ sm)) - [(~+ (list\map annotation$ anns))] - (~ (value$ class)) - )) - )) - -(def: (argument$ [name type]) - (-> Argument Code) - (` [(~ (code.text name)) (~ (value$ type))])) - -(def: (constructor_arg$ [class term]) - (-> (Typed Code) Code) - (` [(~ (value$ class)) (~ term)])) - -(def: (method_def$ replacer super_class [[name pm anns] method_def]) - (-> (-> Code Code) (Type Class) [Member_Declaration Method_Definition] Code) - (case method_def - (#ConstructorMethod strict_fp? type_vars self_name arguments constructor_args body exs) - (` ("init" - (~ (privacy_modifier$ pm)) - (~ (code.bit strict_fp?)) - [(~+ (list\map annotation$ anns))] - [(~+ (list\map var$ type_vars))] - [(~+ (list\map class$ exs))] - (~ (code.text self_name)) - [(~+ (list\map argument$ arguments))] - [(~+ (list\map constructor_arg$ constructor_args))] - (~ (pre_walk_replace replacer body)) - )) - - (#VirtualMethod final? strict_fp? type_vars self_name arguments return_type body exs) - (` ("virtual" - (~ (code.text name)) - (~ (privacy_modifier$ pm)) - (~ (code.bit final?)) - (~ (code.bit strict_fp?)) - [(~+ (list\map annotation$ anns))] - [(~+ (list\map var$ type_vars))] - (~ (code.text self_name)) - [(~+ (list\map argument$ arguments))] - (~ (return$ return_type)) - [(~+ (list\map class$ exs))] - (~ (pre_walk_replace replacer body)))) - - (#OverridenMethod strict_fp? declaration type_vars self_name arguments return_type body exs) - (let [super_replacer (parser->replacer (<code>.form (do <>.monad - [_ (<code>.this! (' ::super!)) - args (<code>.tuple (<>.exactly (list.size arguments) <code>.any))] - (wrap (` ("jvm member invoke special" - (~ (code.text (product.left (parser.read_class super_class)))) - (~ (code.text name)) - (~' _jvm_this) - (~+ (|> args - (list.zip/2 (list\map product.right arguments)) - (list\map ..decorate_input)))))))))] - (` ("override" - (~ (declaration$ declaration)) - (~ (code.text name)) - (~ (code.bit strict_fp?)) - [(~+ (list\map annotation$ anns))] - [(~+ (list\map var$ type_vars))] - (~ (code.text self_name)) - [(~+ (list\map argument$ arguments))] - (~ (return$ return_type)) - [(~+ (list\map class$ exs))] - (~ (|> body - (pre_walk_replace replacer) - (pre_walk_replace super_replacer))) - ))) - - (#StaticMethod strict_fp? type_vars arguments return_type body exs) - (` ("static" - (~ (code.text name)) - (~ (privacy_modifier$ pm)) - (~ (code.bit strict_fp?)) - [(~+ (list\map annotation$ anns))] - [(~+ (list\map var$ type_vars))] - [(~+ (list\map class$ exs))] - [(~+ (list\map argument$ arguments))] - (~ (return$ return_type)) - (~ (pre_walk_replace replacer body)))) - - (#AbstractMethod type_vars arguments return_type exs) - (` ("abstract" - (~ (code.text name)) - (~ (privacy_modifier$ pm)) - [(~+ (list\map annotation$ anns))] - [(~+ (list\map var$ type_vars))] - [(~+ (list\map class$ exs))] - [(~+ (list\map argument$ arguments))] - (~ (return$ return_type)))) - - (#NativeMethod type_vars arguments return_type exs) - (` ("native" - (~ (code.text name)) - (~ (privacy_modifier$ pm)) - [(~+ (list\map annotation$ anns))] - [(~+ (list\map var$ type_vars))] - [(~+ (list\map class$ exs))] - [(~+ (list\map argument$ arguments))] - (~ (return$ return_type)))) - )) - -(def: (complete_call$ g!obj [method args]) - (-> Code Partial_Call Code) - (` ((~ (code.identifier method)) (~+ args) (~ g!obj)))) - -(def: $Object - (Type Class) - (type.class "java.lang.Object" (list))) - -(syntax: #export (class: - {#let [! <>.monad]} - {im inheritance_modifier^} - {[full_class_name class_vars] (\ ! map parser.declaration ..declaration^)} - {super (<>.default $Object - (class^ class_vars))} - {interfaces (<>.default (list) - (<code>.tuple (<>.some (class^ class_vars))))} - {annotations ..annotations^} - {fields (<>.some (..field_decl^ class_vars))} - {methods (<>.some (..method_def^ class_vars))}) - {#.doc (doc "Allows defining JVM classes in Lux code." - "For example:" - (class: #final (TestClass A) [Runnable] - ## Fields - (#private foo boolean) - (#private bar A) - (#private baz java/lang/Object) - ## Methods - (#public [] (new [value A]) [] - (exec (:= ::foo #1) - (:= ::bar value) - (:= ::baz "") - [])) - (#public (virtual) java/lang/Object - "") - (#public #static (static) java/lang/Object - "") - (Runnable [] (run) void - []) - ) - - "The tuple corresponds to parent interfaces." - "An optional super-class can be specified before the tuple. If not specified, java.lang.Object will be assumed." - "Fields and methods defined in the class can be used with special syntax." - "For example:" - "::resolved, for accessing the 'resolved' field." - "(:= ::resolved #1) for modifying it." - "(::new! []) for calling the class's constructor." - "(::resolve! container [value]) for calling the 'resolve' method." - )} - (do meta.monad - [current_module meta.current_module_name - #let [fully_qualified_class_name (name.qualify current_module full_class_name) - field_parsers (list\map (field->parser fully_qualified_class_name) fields) - method_parsers (list\map (method->parser fully_qualified_class_name) methods) - replacer (parser->replacer (list\fold <>.either - (<>.fail "") - (list\compose field_parsers method_parsers)))]] - (wrap (list (` ("jvm class" - (~ (declaration$ (type.declaration (name.qualify current_module full_class_name) class_vars))) - (~ (class$ super)) - [(~+ (list\map class$ interfaces))] - (~ (inheritance_modifier$ im)) - [(~+ (list\map annotation$ annotations))] - [(~+ (list\map field_decl$ fields))] - [(~+ (list\map (method_def$ replacer super) methods))])))))) - -(syntax: #export (interface: - {#let [! <>.monad]} - {[full_class_name class_vars] (\ ! map parser.declaration ..declaration^)} - {supers (<>.default (list) - (<code>.tuple (<>.some (class^ class_vars))))} - {annotations ..annotations^} - {members (<>.some (..method_decl^ class_vars))}) - {#.doc (doc "Allows defining JVM interfaces." - (interface: TestInterface - ([] foo [boolean String] void #throws [Exception])))} - (do meta.monad - [current_module meta.current_module_name] - (wrap (list (` ("jvm class interface" - (~ (declaration$ (type.declaration (name.qualify current_module full_class_name) class_vars))) - [(~+ (list\map class$ supers))] - [(~+ (list\map annotation$ annotations))] - (~+ (list\map method_decl$ members)))))))) - -(syntax: #export (object - {class_vars ..vars^} - {super (<>.default $Object - (class^ class_vars))} - {interfaces (<>.default (list) - (<code>.tuple (<>.some (class^ class_vars))))} - {constructor_args (..constructor_args^ class_vars)} - {methods (<>.some ..overriden_method_def^)}) - {#.doc (doc "Allows defining anonymous classes." - "The 1st tuple corresponds to class-level type-variables." - "The 2nd tuple corresponds to parent interfaces." - "The 3rd tuple corresponds to arguments to the super class constructor." - "An optional super-class can be specified before the 1st tuple. If not specified, java.lang.Object will be assumed." - (object [] [Runnable] - [] - (Runnable [] (run self) void - (exec (do_something some_value) - []))) - )} - (wrap (list (` ("jvm class anonymous" - [(~+ (list\map var$ class_vars))] - (~ (class$ super)) - [(~+ (list\map class$ interfaces))] - [(~+ (list\map constructor_arg$ constructor_args))] - [(~+ (list\map (method_def$ function.identity super) methods))]))))) - -(syntax: #export (null) - {#.doc (doc "Null object reference." - (null))} - (wrap (list (` ("jvm object null"))))) - -(def: #export (null? obj) - {#.doc (doc "Test for null object reference." - (= (null? (null)) - true) - (= (null? "YOLO") - false))} - (-> (primitive "java.lang.Object") Bit) - ("jvm object null?" obj)) - -(syntax: #export (??? expr) - {#.doc (doc "Takes a (potentially null) ObjectType reference and creates a (Maybe ObjectType) for it." - (= (??? (: java/lang/String (null))) - #.None) - (= (??? "YOLO") - (#.Some "YOLO")))} - (with_gensyms [g!temp] - (wrap (list (` (let [(~ g!temp) (~ expr)] - (if ("jvm object null?" (~ g!temp)) - #.None - (#.Some (~ g!temp))))))))) - -(syntax: #export (!!! expr) - {#.doc (doc "Takes a (Maybe ObjectType) and returns a ObjectType." - "A #.None would get translated into a (null)." - (= (null) - (!!! (??? (: java/lang/Thread (null))))) - (= "foo" - (!!! (??? "foo"))))} - (with_gensyms [g!value] - (wrap (list (` ({(#.Some (~ g!value)) - (~ g!value) - - #.None - ("jvm object null")} - (~ expr))))))) - -(syntax: #export (check {class (..type^ (list))} - {unchecked (<>.maybe <code>.any)}) - {#.doc (doc "Checks whether an object is an instance of a particular class." - "Caveat emptor: Cannot check for polymorphism, so avoid using parameterized classes." - (case (check String "YOLO") - (#.Some value_as_string) - #.None))} - (with_gensyms [g!_ g!unchecked] - (let [class_name (..reflection class) - class_type (` (.primitive (~ (code.text class_name)))) - check_type (` (.Maybe (~ class_type))) - check_code (` (if ("jvm object instance?" (~ (code.text class_name)) (~ g!unchecked)) - (#.Some (.:as (~ class_type) - (~ g!unchecked))) - #.None))] - (case unchecked - (#.Some unchecked) - (wrap (list (` (: (~ check_type) - (let [(~ g!unchecked) (~ unchecked)] - (~ check_code)))))) - - #.None - (wrap (list (` (: (-> (primitive "java.lang.Object") (~ check_type)) - (function ((~ g!_) (~ g!unchecked)) - (~ check_code)))))) - )))) - -(syntax: #export (synchronized lock body) - {#.doc (doc "Evaluates body, while holding a lock on a given object." - (synchronized object_to_be_locked - (exec (do_something ___) - (do_something_else ___) - (finish_the_computation ___))))} - (wrap (list (` ("jvm object synchronized" (~ lock) (~ body)))))) - -(syntax: #export (do_to obj {methods (<>.some partial_call^)}) - {#.doc (doc "Call a variety of methods on an object. Then, return the object." - (do_to object - (ClassName::method1 arg0 arg1 arg2) - (ClassName::method2 arg3 arg4 arg5)))} - (with_gensyms [g!obj] - (wrap (list (` (let [(~ g!obj) (~ obj)] - (exec (~+ (list\map (complete_call$ g!obj) methods)) - (~ g!obj)))))))) - -(def: (class_import$ declaration) - (-> (Type Declaration) Code) - (let [[full_name params] (parser.declaration declaration) - def_name (..internal full_name) - params' (list\map ..var$' params)] - (` (def: (~ (code.identifier ["" def_name])) - {#..jvm_class (~ (code.text (..internal full_name)))} - .Type - (All [(~+ params')] - (primitive (~ (code.text full_name)) - [(~+ params')])))))) - -(def: (member_type_vars class_tvars member) - (-> (List (Type Var)) Import_Member_Declaration (List (Type Var))) - (case member - (#ConstructorDecl [commons _]) - (list\compose class_tvars (get@ #import_member_tvars commons)) - - (#MethodDecl [commons _]) - (case (get@ #import_member_kind commons) - #StaticIMK - (get@ #import_member_tvars commons) - - _ - (list\compose class_tvars (get@ #import_member_tvars commons))) - - _ - class_tvars)) - -(def: (member_def_arg_bindings vars member) - (-> (List (Type Var)) Import_Member_Declaration (Meta [(List [Bit Code]) (List (Type Value)) (List Code)])) - (case member - (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) - (let [(^slots [#import_member_tvars #import_member_args]) commons] - (do {! meta.monad} - [arg_inputs (monad.map ! - (: (-> [Bit (Type Value)] (Meta [Bit Code])) - (function (_ [maybe? _]) - (with_gensyms [arg_name] - (wrap [maybe? arg_name])))) - import_member_args) - #let [input_jvm_types (list\map product.right import_member_args) - arg_types (list\map (: (-> [Bit (Type Value)] Code) - (function (_ [maybe? arg]) - (let [arg_type (value_type (get@ #import_member_mode commons) arg)] - (if maybe? - (` (Maybe (~ arg_type))) - arg_type)))) - import_member_args)]] - (wrap [arg_inputs input_jvm_types arg_types]))) - - _ - (\ meta.monad wrap [(list) (list) (list)]))) - -(def: (decorate_return_maybe member never_null? unboxed return_term) - (-> Import_Member_Declaration Bit (Type Value) Code Code) - (case member - (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) - (cond (or never_null? - (dictionary.key? ..boxes unboxed)) - return_term - - (get@ #import_member_maybe? commons) - (` (??? (~ return_term))) - - ## else - (let [g!temp (` ((~' ~') (~ (code.identifier ["" " Ω "]))))] - (` (let [(~ g!temp) (~ return_term)] - (if (not (..null? (:as (primitive "java.lang.Object") - (~ g!temp)))) - (~ g!temp) - (error! "Cannot produce null references from method calls.")))))) - - _ - return_term)) - -(template [<name> <tag> <term_trans>] - [(def: (<name> member return_term) - (-> Import_Member_Declaration Code Code) - (case member - (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) - (if (get@ <tag> commons) - <term_trans> - return_term) - - _ - return_term))] - - [decorate_return_try #import_member_try? (` (.try (~ return_term)))] - [decorate_return_io #import_member_io? (` ((~! io.io) (~ return_term)))] - ) - -(def: $String - (type.class "java.lang.String" (list))) - -(template [<input?> <name> <unbox/box> <special+>] - [(def: (<name> mode [unboxed raw]) - (-> Primitive_Mode [(Type Value) Code] Code) - (let [[unboxed refined post] (: [(Type Value) Code (List Code)] - (case mode - #ManualPrM - [unboxed raw (list)] - - #AutoPrM - (with_expansions [<special+>' (template.splice <special+>) - <cond_cases> (template [<old> <new> <pre> <post>] - [(\ type.equivalence = <old> unboxed) - (with_expansions [<post>' (template.splice <post>)] - [<new> - (` (.|> (~ raw) (~+ <pre>))) - (list <post>')])] - - <special+>')] - (cond <cond_cases> - ## else - [unboxed - (if <input?> - (` ("jvm object cast" (~ raw))) - raw) - (list)])))) - unboxed/boxed (case (dictionary.get unboxed ..boxes) - (#.Some boxed) - (<unbox/box> unboxed boxed refined) - - #.None - refined)] - (case post - #.Nil - unboxed/boxed - - _ - (` (.|> (~ unboxed/boxed) (~+ post))))))] - - [#1 auto_convert_input ..unbox - [[type.boolean type.boolean (list (` (.: .Bit)) (` (.:as (.primitive (~ (code.text box.boolean)))))) []] - [type.byte type.byte (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long))))) (` ..long_to_byte)) []] - [type.short type.short (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long))))) (` ..long_to_short)) []] - [type.int type.int (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long))))) (` ..long_to_int)) []] - [type.long type.long (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long)))))) []] - [type.float type.float (list (` (.: .Frac)) (` (.:as (.primitive (~ (code.text box.double))))) (` ..double_to_float)) []] - [type.double type.double (list (` (.: .Frac)) (` (.:as (.primitive (~ (code.text box.double)))))) []] - [..$String ..$String (list (` (.: .Text)) (` (.:as (.primitive (~ (code.text (..reflection ..$String))))))) []] - [(type.class box.boolean (list)) (type.class box.boolean (list)) (list (` (.: .Bit)) (` (.:as (.primitive (~ (code.text box.boolean)))))) []] - [(type.class box.long (list)) (type.class box.long (list)) (list (` (.: .Int)) (` (.:as (.primitive (~ (code.text box.long)))))) []] - [(type.class box.double (list)) (type.class box.double (list)) (list (` (.: .Frac)) (` (.:as (.primitive (~ (code.text box.double)))))) []]]] - [#0 auto_convert_output ..box - [[type.boolean type.boolean (list) [(` (.: (.primitive (~ (code.text box.boolean))))) (` (.:as .Bit))]] - [type.byte type.long (list (` "jvm conversion byte-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]] - [type.short type.long (list (` "jvm conversion short-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]] - [type.int type.long (list (` "jvm conversion int-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]] - [type.long type.long (list) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]] - [type.float type.double (list (` "jvm conversion float-to-double")) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:as .Frac))]] - [type.double type.double (list) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:as .Frac))]] - [..$String ..$String (list) [(` (.: (.primitive (~ (code.text (..reflection ..$String)))))) (` (.:as .Text))]] - [(type.class box.boolean (list)) (type.class box.boolean (list)) (list) [(` (.: (.primitive (~ (code.text box.boolean))))) (` (.:as .Bit))]] - [(type.class box.long (list)) (type.class box.long (list)) (list) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:as .Int))]] - [(type.class box.double (list)) (type.class box.double (list)) (list) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:as .Frac))]]]] - ) - -(def: (un_quote quoted) - (-> Code Code) - (` ((~' ~) (~ quoted)))) - -(def: (jvm_invoke_inputs mode classes inputs) - (-> Primitive_Mode (List (Type Value)) (List [Bit Code]) (List Code)) - (|> inputs - (list.zip/2 classes) - (list\map (function (_ [class [maybe? input]]) - (|> (if maybe? - (` (: (.primitive (~ (code.text (..reflection class)))) - ((~! !!!) (~ (un_quote input))))) - (un_quote input)) - [class] - (auto_convert_input mode)))))) - -(def: (import_name format class member) - (-> Text Text Text Text) - (|> format - (text.replace_all "#" class) - (text.replace_all "." member))) - -(def: (member_def_interop vars kind class [arg_function_inputs input_jvm_types arg_types] member method_prefix import_format) - (-> (List (Type Var)) Class_Kind (Type Declaration) [(List [Bit Code]) (List (Type Value)) (List Code)] Import_Member_Declaration Text Text (Meta (List Code))) - (let [[full_name class_tvars] (parser.declaration class)] - (case member - (#EnumDecl enum_members) - (do meta.monad - [#let [enum_type (: Code - (case class_tvars - #.Nil - (` (primitive (~ (code.text full_name)))) - - _ - (let [=class_tvars (list\map ..var$' class_tvars)] - (` (All [(~+ =class_tvars)] (primitive (~ (code.text full_name)) [(~+ =class_tvars)])))))) - getter_interop (: (-> Text Code) - (function (_ name) - (let [getter_name (code.identifier ["" (..import_name import_format method_prefix name)])] - (` (def: (~ getter_name) - (~ enum_type) - (~ (get_static_field full_name name)))))))]] - (wrap (list\map getter_interop enum_members))) - - (#ConstructorDecl [commons _]) - (do meta.monad - [#let [classT (type.class full_name (list)) - def_name (code.identifier ["" (..import_name import_format method_prefix (get@ #import_member_alias commons))]) - jvm_interop (|> [classT - (` ("jvm member invoke constructor" - [(~+ (list\map ..var$ class_tvars))] - (~ (code.text full_name)) - [(~+ (list\map ..var$ (get@ #import_member_tvars commons)))] - (~+ (|> (jvm_invoke_inputs (get@ #import_member_mode commons) input_jvm_types arg_function_inputs) - (list.zip/2 input_jvm_types) - (list\map ..decorate_input)))))] - (auto_convert_output (get@ #import_member_mode commons)) - (decorate_return_maybe member true classT) - (decorate_return_try member) - (decorate_return_io member))]] - (wrap (list (` ((~! syntax:) ((~ def_name) (~+ (list\map product.right arg_function_inputs))) - ((~' wrap) (.list (.` (~ jvm_interop))))))))) - - (#MethodDecl [commons method]) - (with_gensyms [g!obj] - (do meta.monad - [#let [def_name (code.identifier ["" (..import_name import_format method_prefix (get@ #import_member_alias commons))]) - (^slots [#import_member_kind]) commons - (^slots [#import_method_name]) method - [jvm_op object_ast] (: [Text (List Code)] - (case import_member_kind - #StaticIMK - ["jvm member invoke static" - (list)] - - #VirtualIMK - (case kind - #Class - ["jvm member invoke virtual" - (list g!obj)] - - #Interface - ["jvm member invoke interface" - (list g!obj)] - ))) - method_return (get@ #import_method_return method) - callC (: Code - (` ((~ (code.text jvm_op)) - [(~+ (list\map ..var$ class_tvars))] - (~ (code.text full_name)) - (~ (code.text import_method_name)) - [(~+ (list\map ..var$ (get@ #import_member_tvars commons)))] - (~+ (|> object_ast - (list\map ..un_quote) - (list.zip/2 (list (type.class full_name (list)))) - (list\map (auto_convert_input (get@ #import_member_mode commons))))) - (~+ (|> (jvm_invoke_inputs (get@ #import_member_mode commons) input_jvm_types arg_function_inputs) - (list.zip/2 input_jvm_types) - (list\map ..decorate_input)))))) - jvm_interop (: Code - (case (type.void? method_return) - (#.Left method_return) - (|> [method_return - callC] - (auto_convert_output (get@ #import_member_mode commons)) - (decorate_return_maybe member false method_return) - (decorate_return_try member) - (decorate_return_io member)) - - - (#.Right method_return) - (|> callC - (decorate_return_try member) - (decorate_return_io member))))]] - (wrap (list (` ((~! syntax:) ((~ def_name) (~+ (list\map product.right arg_function_inputs)) (~+ object_ast)) - ((~' wrap) (.list (.` (~ jvm_interop)))))))))) - - (#FieldAccessDecl fad) - (do meta.monad - [#let [(^open ".") fad - getter_name (code.identifier ["" (..import_name import_format method_prefix import_field_name)]) - setter_name (code.identifier ["" (..import_name import_format method_prefix (format import_field_name "!"))])] - getter_interop (with_gensyms [g!obj] - (let [getter_call (if import_field_static? - (` ((~ getter_name))) - (` ((~ getter_name) (~ g!obj)))) - getter_body (<| (auto_convert_output import_field_mode) - [import_field_type - (if import_field_static? - (get_static_field full_name import_field_name) - (get_virtual_field full_name import_field_name (un_quote g!obj)))]) - getter_body (if import_field_maybe? - (` ((~! ???) (~ getter_body))) - getter_body) - getter_body (if import_field_setter? - (` ((~! io.io) (~ getter_body))) - getter_body)] - (wrap (` ((~! syntax:) (~ getter_call) - ((~' wrap) (.list (.` (~ getter_body))))))))) - setter_interop (: (Meta (List Code)) - (if import_field_setter? - (with_gensyms [g!obj g!value] - (let [setter_call (if import_field_static? - (` ((~ setter_name) (~ g!value))) - (` ((~ setter_name) (~ g!value) (~ g!obj)))) - setter_value (|> [import_field_type (un_quote g!value)] - (auto_convert_input import_field_mode)) - setter_value (if import_field_maybe? - (` ((~! !!!) (~ setter_value))) - setter_value) - setter_command (format (if import_field_static? "jvm putstatic" "jvm putfield") - ":" full_name ":" import_field_name) - g!obj+ (: (List Code) - (if import_field_static? - (list) - (list (un_quote g!obj))))] - (wrap (list (` ((~! syntax:) (~ setter_call) - ((~' wrap) (.list (.` ((~! io.io) ((~ (code.text setter_command)) (~+ g!obj+) (~ setter_value)))))))))))) - (wrap (list))))] - (wrap (list& getter_interop setter_interop))) - ))) - -(def: (member_import$ vars kind class [import_format member]) - (-> (List (Type Var)) Class_Kind (Type Declaration) [Text Import_Member_Declaration] (Meta (List Code))) - (let [[full_name _] (parser.declaration class) - method_prefix (..internal full_name)] - (do meta.monad - [=args (member_def_arg_bindings vars member)] - (member_def_interop vars kind class =args member method_prefix import_format)))) - -(def: interface? - (All [a] (-> (primitive "java.lang.Class" [a]) Bit)) - (|>> ("jvm member invoke virtual" [] "java.lang.Class" "isInterface" []) - "jvm object cast" - (: ..Boolean) - (:as Bit))) - -(def: load_class - (-> External (Try (primitive "java.lang.Class" [Any]))) - (|>> (:as (primitive "java.lang.String")) - ["Ljava/lang/String;"] - ("jvm member invoke static" [] "java.lang.Class" "forName" []) - try)) - -(def: (class_kind declaration) - (-> (Type Declaration) (Meta Class_Kind)) - (let [[class_name _] (parser.declaration declaration)] - (case (load_class class_name) - (#.Right class) - (\ meta.monad wrap (if (interface? class) - #Interface - #Class)) - - (#.Left _) - (meta.fail (format "Unknown class: " class_name))))) - -(syntax: #export (import: - {declaration ..declaration^} - {#let [[class_name class_type_vars] (parser.declaration declaration)]} - {bundles (<>.some (..bundle class_type_vars))}) - {#.doc (doc "Allows importing JVM classes, and using them as types." - "Their methods, fields and enum options can also be imported." - (import: java/lang/Object - ["#::." - (new []) - (equals [java/lang/Object] boolean) - (wait [int] #io #try void)]) - - "Special options can also be given for the return values." - "#? means that the values will be returned inside a Maybe type. That way, null becomes #.None." - "#try means that the computation might throw an exception, and the return value will be wrapped by the Try type." - "#io means the computation has side effects, and will be wrapped by the IO type." - "These options must show up in the following order [#io #try #?] (although, each option can be used independently)." - (import: java/lang/String - ["#::." - (new [[byte]]) - (#static valueOf [char] java/lang/String) - (#static valueOf #as int_valueOf [int] java/lang/String)]) - - (import: (java/util/List e) - ["#::." - (size [] int) - (get [int] e)]) - - (import: (java/util/ArrayList a) - ["#::." - ([T] toArray [[T]] [T])]) - - "The class-type that is generated is of the fully-qualified name." - "This avoids a clash between the java.util.List type, and Lux's own List type." - "All enum options to be imported must be specified." - (import: java/lang/Character$UnicodeScript - ["#::." - (#enum ARABIC CYRILLIC LATIN)]) - - "It should also be noted, the only types that may show up in method arguments or return values may be Java classes, arrays, primitives, void or type-vars." - "Lux types, such as Maybe cannot be named (otherwise, they'd be confused for Java classes)." - (import: (lux/concurrency/promise/JvmPromise A) - ["#::." - (resolve [A] boolean) - (poll [] A) - (wasResolved [] boolean) - (waitOn [lux/Function] void) - (#static [A] make [A] (lux/concurrency/promise/JvmPromise A))]) - - "Also, the names of the imported members will look like Class::member" - (java/lang/Object::new []) - (java/lang/Object::equals [other_object] my_object) - (java/util/List::size [] my_list) - java/lang/Character$UnicodeScript::LATIN - )} - (do {! meta.monad} - [kind (class_kind declaration) - =members (|> bundles - (list\map (function (_ [import_format members]) - (list\map (|>> [import_format]) members))) - list.concat - (monad.map ! (member_import$ class_type_vars kind declaration)))] - (wrap (list& (class_import$ declaration) (list\join =members))))) - -(syntax: #export (array {type (..type^ (list))} - size) - {#.doc (doc "Create an array of the given type, with the given size." - (array java/lang/Object 10))} - (let [g!size (` (|> (~ size) - (.: .Nat) - (.:as (.primitive (~ (code.text box.long)))) - "jvm object cast" - "jvm conversion long-to-int"))] - (`` (cond (~~ (template [<primitive> <array_op>] - [(\ type.equivalence = <primitive> type) - (wrap (list (` (<array_op> (~ g!size)))))] - - [type.boolean "jvm array new boolean"] - [type.byte "jvm array new byte"] - [type.short "jvm array new short"] - [type.int "jvm array new int"] - [type.long "jvm array new long"] - [type.float "jvm array new float"] - [type.double "jvm array new double"] - [type.char "jvm array new char"])) - ## else - (wrap (list (` (: (~ (value_type #ManualPrM (type.array type))) - ("jvm array new object" (~ g!size)))))))))) - -(exception: #export (cannot_convert_to_jvm_type {type .Type}) - (exception.report - ["Lux Type" (%.type type)])) - -(with_expansions [<failure> (as_is (meta.fail (exception.construct ..cannot_convert_to_jvm_type [type])))] - (def: (lux_type->jvm_type type) - (-> .Type (Meta (Type Value))) - (if (lux_type\= .Any type) - (\ meta.monad wrap $Object) - (case type - (#.Primitive name params) - (`` (cond (~~ (template [<type>] - [(text\= (..reflection <type>) name) - (case params - #.Nil - (\ meta.monad wrap <type>) - - _ - <failure>)] - - [type.boolean] - [type.byte] - [type.short] - [type.int] - [type.long] - [type.float] - [type.double] - [type.char])) - - (~~ (template [<type>] - [(text\= (..reflection (type.array <type>)) name) - (case params - #.Nil - (\ meta.monad wrap (type.array <type>)) - - _ - <failure>)] - - [type.boolean] - [type.byte] - [type.short] - [type.int] - [type.long] - [type.float] - [type.double] - [type.char])) - - (text\= array.type_name name) - (case params - (#.Cons elementLT #.Nil) - (\ meta.monad map type.array - (lux_type->jvm_type elementLT)) - - _ - <failure>) - - (text.starts_with? descriptor.array_prefix name) - (case params - #.Nil - (let [[_ unprefixed] (maybe.assume (text.split_with descriptor.array_prefix name))] - (\ meta.monad map type.array - (lux_type->jvm_type (#.Primitive unprefixed (list))))) - - _ - <failure>) - - ## else - (\ meta.monad map (type.class name) - (: (Meta (List (Type Parameter))) - (monad.map meta.monad - (function (_ paramLT) - (do meta.monad - [paramJT (lux_type->jvm_type paramLT)] - (case (parser.parameter? paramJT) - (#.Some paramJT) - (wrap paramJT) - - #.None - <failure>))) - params))))) - - (#.Apply A F) - (case (lux_type.apply (list A) F) - #.None - <failure> - - (#.Some type') - (lux_type->jvm_type type')) - - (#.Named _ type') - (lux_type->jvm_type type') - - _ - <failure>)))) - -(syntax: #export (array_length array) - {#.doc (doc "Gives the length of an array." - (array_length my_array))} - (case array - [_ (#.Identifier array_name)] - (do meta.monad - [array_type (meta.find_type array_name) - array_jvm_type (lux_type->jvm_type array_type) - #let [g!extension (code.text (`` (cond (~~ (template [<primitive> <extension>] - [(\ type.equivalence = - (type.array <primitive>) - array_jvm_type) - <extension>] - - [type.boolean "jvm array length boolean"] - [type.byte "jvm array length byte"] - [type.short "jvm array length short"] - [type.int "jvm array length int"] - [type.long "jvm array length long"] - [type.float "jvm array length float"] - [type.double "jvm array length double"] - [type.char "jvm array length char"])) - - ## else - "jvm array length object")))]] - (wrap (list (` (.|> ((~ g!extension) (~ array)) - "jvm conversion int-to-long" - "jvm object cast" - (.: (.primitive (~ (code.text box.long)))) - (.:as .Nat)))))) - - _ - (with_gensyms [g!array] - (wrap (list (` (let [(~ g!array) (~ array)] - (..array_length (~ g!array))))))))) - -(syntax: #export (array_read idx array) - {#.doc (doc "Loads an element from an array." - (array_read 10 my_array))} - (case array - [_ (#.Identifier array_name)] - (do meta.monad - [array_type (meta.find_type array_name) - array_jvm_type (lux_type->jvm_type array_type) - #let [g!idx (` (.|> (~ idx) - (.: .Nat) - (.:as (.primitive (~ (code.text box.long)))) - "jvm object cast" - "jvm conversion long-to-int"))]] - (`` (cond (~~ (template [<primitive> <extension> <box>] - [(\ type.equivalence = - (type.array <primitive>) - array_jvm_type) - (wrap (list (` (.|> (<extension> (~ g!idx) (~ array)) - "jvm object cast" - (.: (.primitive (~ (code.text <box>))))))))] - - [type.boolean "jvm array read boolean" box.boolean] - [type.byte "jvm array read byte" box.byte] - [type.short "jvm array read short" box.short] - [type.int "jvm array read int" box.int] - [type.long "jvm array read long" box.long] - [type.float "jvm array read float" box.float] - [type.double "jvm array read double" box.double] - [type.char "jvm array read char" box.char])) - - ## else - (wrap (list (` ("jvm array read object" (~ g!idx) (~ array)))))))) - - _ - (with_gensyms [g!array] - (wrap (list (` (let [(~ g!array) (~ array)] - (..array_read (~ idx) (~ g!array))))))))) - -(syntax: #export (array_write idx value array) - {#.doc (doc "Stores an element into an array." - (array_write 10 my_object my_array))} - (case array - [_ (#.Identifier array_name)] - (do meta.monad - [array_type (meta.find_type array_name) - array_jvm_type (lux_type->jvm_type array_type) - #let [g!idx (` (.|> (~ idx) - (.: .Nat) - (.:as (.primitive (~ (code.text box.long)))) - "jvm object cast" - "jvm conversion long-to-int"))]] - (`` (cond (~~ (template [<primitive> <extension> <box>] - [(\ type.equivalence = - (type.array <primitive>) - array_jvm_type) - (let [g!value (` (.|> (~ value) - (.:as (.primitive (~ (code.text <box>)))) - "jvm object cast"))] - (wrap (list (` (<extension> (~ g!idx) (~ g!value) (~ array))))))] - - [type.boolean "jvm array write boolean" box.boolean] - [type.byte "jvm array write byte" box.byte] - [type.short "jvm array write short" box.short] - [type.int "jvm array write int" box.int] - [type.long "jvm array write long" box.long] - [type.float "jvm array write float" box.float] - [type.double "jvm array write double" box.double] - [type.char "jvm array write char" box.char])) - - ## else - (wrap (list (` ("jvm array write object" (~ g!idx) (~ value) (~ array)))))))) - - _ - (with_gensyms [g!array] - (wrap (list (` (let [(~ g!array) (~ array)] - (..array_write (~ idx) (~ value) (~ g!array))))))))) - -(syntax: #export (class_for {type (..type^ (list))}) - {#.doc (doc "Loads the class as a java.lang.Class object." - (class_for java/lang/String))} - (wrap (list (` ("jvm object class" (~ (code.text (..reflection type)))))))) - -(syntax: #export (type {type (..type^ (list))}) - (wrap (list (..value_type #ManualPrM type)))) - -(exception: #export (cannot_cast_to_non_object {type (Type Value)}) - (exception.report - ["Signature" (..signature type)] - ["Reflection" (..reflection type)])) - -(syntax: #export (:cast {type (..type^ (list))} - object) - (case [(parser.array? type) - (parser.class? type)] - (^or [(#.Some _) _] [_ (#.Some _)]) - (wrap (list (` (.: (~ (..value_type #ManualPrM type)) - ("jvm object cast" (~ object)))))) - - _ - (meta.fail (exception.construct ..cannot_cast_to_non_object [type])))) diff --git a/stdlib/source/lux/ffi.lua.lux b/stdlib/source/lux/ffi.lua.lux deleted file mode 100644 index 61ee5b35c..000000000 --- a/stdlib/source/lux/ffi.lua.lux +++ /dev/null @@ -1,309 +0,0 @@ -(.module: - [lux #* - ["." meta] - ["@" target] - [abstract - [monad (#+ do)]] - [control - ["." io] - ["<>" parser ("#\." monad) - ["<.>" code (#+ Parser)]]] - [data - ["." product] - ["." maybe] - ["." text - ["%" format]] - [collection - ["." list ("#\." functor fold)]]] - [type - abstract] - [macro (#+ with_gensyms) - [syntax (#+ syntax:)] - ["." code] - ["." template]]]) - -(abstract: #export (Object brand) Any) - -(template [<name>] - [(with_expansions [<brand> (template.identifier [<name> "'"])] - (abstract: #export <brand> Any) - (type: #export <name> - (..Object <brand>)))] - - [Nil] - [Function] - [Table] - ) - -(template [<name> <type>] - [(type: #export <name> - <type>)] - - [Boolean Bit] - [Integer Int] - [Float Frac] - [String Text] - ) - -(type: Nilable - [Bit Code]) - -(def: nilable - (Parser Nilable) - (let [token (' #?)] - (<| (<>.and (<>.parses? (<code>.this! token))) - (<>.after (<>.not (<code>.this! token))) - <code>.any))) - -(type: Field - [Bit Text Nilable]) - -(def: static! - (Parser Any) - (<code>.this! (' #static))) - -(def: field - (Parser Field) - (<code>.form ($_ <>.and - (<>.parses? ..static!) - <code>.local_identifier - ..nilable))) - -(def: constant - (Parser Field) - (<code>.form ($_ <>.and - (<>\wrap true) - <code>.local_identifier - ..nilable))) - -(type: Common_Method - {#name Text - #alias (Maybe Text) - #inputs (List Nilable) - #io? Bit - #try? Bit - #output Nilable}) - -(type: Static_Method Common_Method) -(type: Virtual_Method Common_Method) - -(type: Method - (#Static Static_Method) - (#Virtual Virtual_Method)) - -(def: common_method - (Parser Common_Method) - ($_ <>.and - <code>.local_identifier - (<>.maybe (<>.after (<code>.this! (' #as)) <code>.local_identifier)) - (<code>.tuple (<>.some ..nilable)) - (<>.parses? (<code>.this! (' #io))) - (<>.parses? (<code>.this! (' #try))) - ..nilable)) - -(def: static_method - (<>.after ..static! ..common_method)) - -(def: method - (Parser Method) - (<code>.form (<>.or ..static_method - ..common_method))) - -(type: Member - (#Field Field) - (#Method Method)) - -(def: member - (Parser Member) - ($_ <>.or - ..field - ..method - )) - -(def: input_variables - (-> (List Nilable) (List [Bit Code])) - (|>> list.enumeration - (list\map (function (_ [idx [nilable? type]]) - [nilable? (|> idx %.nat code.local_identifier)])))) - -(def: (nilable_type [nilable? type]) - (-> Nilable Code) - (if nilable? - (` (.Maybe (~ type))) - type)) - -(def: (with_nil g!temp [nilable? input]) - (-> Code [Bit Code] Code) - (if nilable? - (` (case (~ input) - (#.Some (~ g!temp)) - (~ g!temp) - - #.Nil - ("lua object nil"))) - input)) - -(def: (without_nil g!temp [nilable? outputT] output) - (-> Code Nilable Code Code) - (if nilable? - (` (let [(~ g!temp) (~ output)] - (if ("lua object nil?" (~ g!temp)) - #.None - (#.Some (~ g!temp))))) - (` (let [(~ g!temp) (~ output)] - (if (not ("lua object nil?" (~ g!temp))) - (~ g!temp) - (.error! "Nil is an invalid value!")))))) - -(type: Import - (#Class [Text Text (List Member)]) - (#Function Static_Method) - (#Constant Field)) - -(def: import - ($_ <>.or - (<>.and <code>.local_identifier - (<>.default ["" (list)] - (<code>.tuple (<>.and <code>.text - (<>.some member))))) - (<code>.form ..common_method) - ..constant - )) - -(def: (with_io with? without) - (-> Bit Code Code) - (if with? - (` (io.io (~ without))) - without)) - -(def: (io_type io? rawT) - (-> Bit Code Code) - (if io? - (` (io.IO (~ rawT))) - rawT)) - -(def: (with_try with? without_try) - (-> Bit Code Code) - (if with? - (` (.try (~ without_try))) - without_try)) - -(def: (try_type try? rawT) - (-> Bit Code Code) - (if try? - (` (.Either .Text (~ rawT))) - rawT)) - -(def: (make_function g!method g!temp source inputsT io? try? outputT) - (-> Code Code Code (List Nilable) Bit Bit Nilable Code) - (let [g!inputs (input_variables inputsT)] - (` (def: ((~ g!method) - [(~+ (list\map product.right g!inputs))]) - (-> [(~+ (list\map nilable_type inputsT))] - (~ (|> (nilable_type outputT) - (try_type try?) - (io_type io?)))) - (:assume - (~ (<| (with_io io?) - (with_try try?) - (without_nil g!temp outputT) - (` ("lua apply" - (:as ..Function (~ source)) - (~+ (list\map (with_nil g!temp) g!inputs))))))))))) - -(syntax: #export (import: {import ..import}) - (with_gensyms [g!temp] - (case import - (#Class [class format members]) - (with_gensyms [g!object] - (let [qualify (: (-> Text Code) - (function (_ member_name) - (|> format - (text.replace_all "#" class) - (text.replace_all "." member_name) - code.local_identifier))) - g!type (code.local_identifier class) - real_class (text.replace_all "/" "." class) - imported (case (text.split_all_with "/" class) - (#.Cons head tail) - (list\fold (function (_ sub super) - (` ("lua object get" (~ (code.text sub)) - (:as (..Object .Any) (~ super))))) - (` ("lua import" (~ (code.text head)))) - tail) - - #.Nil - (` ("lua import" (~ (code.text class)))))] - (wrap (list& (` (type: (~ g!type) - (..Object (primitive (~ (code.text real_class)))))) - (list\map (function (_ member) - (case member - (#Field [static? field fieldT]) - (if static? - (` ((~! syntax:) ((~ (qualify field))) - (\ (~! meta.monad) (~' wrap) - (list (` (.:as (~ (nilable_type fieldT)) - ("lua object get" (~ (code.text field)) - (:as (..Object .Any) (~ imported))))))))) - (` (def: ((~ (qualify field)) - (~ g!object)) - (-> (~ g!type) - (~ (nilable_type fieldT))) - (:assume - (~ (without_nil g!temp fieldT (` ("lua object get" (~ (code.text field)) - (:as (..Object .Any) (~ g!object)))))))))) - - (#Method method) - (case method - (#Static [method alias inputsT io? try? outputT]) - (..make_function (qualify (maybe.default method alias)) - g!temp - (` ("lua object get" (~ (code.text method)) - (:as (..Object .Any) (~ imported)))) - inputsT - io? - try? - outputT) - - (#Virtual [method alias inputsT io? try? outputT]) - (let [g!inputs (input_variables inputsT)] - (` (def: ((~ (qualify (maybe.default method alias))) - [(~+ (list\map product.right g!inputs))] - (~ g!object)) - (-> [(~+ (list\map nilable_type inputsT))] - (~ g!type) - (~ (|> (nilable_type outputT) - (try_type try?) - (io_type io?)))) - (:assume - (~ (<| (with_io io?) - (with_try try?) - (without_nil g!temp outputT) - (` ("lua object do" - (~ (code.text method)) - (~ g!object) - (~+ (list\map (with_nil g!temp) g!inputs))))))))))))) - members))))) - - (#Function [name alias inputsT io? try? outputT]) - (wrap (list (..make_function (code.local_identifier (maybe.default name alias)) - g!temp - (` ("lua constant" (~ (code.text (text.replace_all "/" "." name))))) - inputsT - io? - try? - outputT))) - - (#Constant [_ name fieldT]) - (wrap (list (` ((~! syntax:) ((~ (code.local_identifier name))) - (\ (~! meta.monad) (~' wrap) - (list (` (.:as (~ (nilable_type fieldT)) - ("lua constant" (~ (code.text (text.replace_all "/" "." name)))))))))))) - ))) - -(template: #export (closure <inputs> <output>) - (.:as ..Function - (`` ("lua function" - (~~ (template.count <inputs>)) - (.function (_ [<inputs>]) - <output>))))) diff --git a/stdlib/source/lux/ffi.old.lux b/stdlib/source/lux/ffi.old.lux deleted file mode 100644 index 9e6a642ed..000000000 --- a/stdlib/source/lux/ffi.old.lux +++ /dev/null @@ -1,1828 +0,0 @@ -(.module: - [lux (#- type interface:) - ["." type ("#\." equivalence)] - [abstract - ["." monad (#+ Monad do)] - ["." enum]] - [control - ["." function] - ["." io] - ["." try (#+ Try)] - ["<>" parser - ["<.>" code (#+ Parser)]]] - [data - ["." maybe] - ["." product] - ["." bit ("#\." codec)] - ["." text ("#\." equivalence monoid) - ["%" format (#+ format)]] - [collection - ["." array (#+ Array)] - ["." list ("#\." monad fold monoid)]]] - [macro (#+ with_gensyms) - [syntax (#+ syntax:)] - ["." code]] - ["." meta - ["." annotation]]]) - -(template [<name> <op> <from> <to>] - [(def: #export (<name> value) - {#.doc (doc "Type converter." - (: <to> - (<name> (: <from> foo))))} - (-> (primitive <from>) (primitive <to>)) - (<op> value))] - - [byte_to_long "jvm convert byte-to-long" "java.lang.Byte" "java.lang.Long"] - - [short_to_long "jvm convert short-to-long" "java.lang.Short" "java.lang.Long"] - - [double_to_int "jvm convert double-to-int" "java.lang.Double" "java.lang.Integer"] - [double_to_long "jvm convert double-to-long" "java.lang.Double" "java.lang.Long"] - [double_to_float "jvm convert double-to-float" "java.lang.Double" "java.lang.Float"] - - [float_to_int "jvm convert float-to-int" "java.lang.Float" "java.lang.Integer"] - [float_to_long "jvm convert float-to-long" "java.lang.Float" "java.lang.Long"] - [float_to_double "jvm convert float-to-double" "java.lang.Float" "java.lang.Double"] - - [int_to_byte "jvm convert int-to-byte" "java.lang.Integer" "java.lang.Byte"] - [int_to_short "jvm convert int-to-short" "java.lang.Integer" "java.lang.Short"] - [int_to_long "jvm convert int-to-long" "java.lang.Integer" "java.lang.Long"] - [int_to_float "jvm convert int-to-float" "java.lang.Integer" "java.lang.Float"] - [int_to_double "jvm convert int-to-double" "java.lang.Integer" "java.lang.Double"] - [int_to_char "jvm convert int-to-char" "java.lang.Integer" "java.lang.Character"] - - [long_to_byte "jvm convert long-to-byte" "java.lang.Long" "java.lang.Byte"] - [long_to_short "jvm convert long-to-short" "java.lang.Long" "java.lang.Short"] - [long_to_int "jvm convert long-to-int" "java.lang.Long" "java.lang.Integer"] - [long_to_float "jvm convert long-to-float" "java.lang.Long" "java.lang.Float"] - [long_to_double "jvm convert long-to-double" "java.lang.Long" "java.lang.Double"] - - [char_to_byte "jvm convert char-to-byte" "java.lang.Character" "java.lang.Byte"] - [char_to_short "jvm convert char-to-short" "java.lang.Character" "java.lang.Short"] - [char_to_int "jvm convert char-to-int" "java.lang.Character" "java.lang.Integer"] - [char_to_long "jvm convert char-to-long" "java.lang.Character" "java.lang.Long"] - ) - -## [Utils] -(def: constructor_method_name "<init>") -(def: member_separator "::") - -## Types -(type: JVM_Code Text) - -(type: BoundKind - #UpperBound - #LowerBound) - -(type: #rec GenericType - (#GenericTypeVar Text) - (#GenericClass [Text (List GenericType)]) - (#GenericArray GenericType) - (#GenericWildcard (Maybe [BoundKind GenericType]))) - -(type: Type_Parameter - [Text (List GenericType)]) - -(type: Primitive_Mode - #ManualPrM - #AutoPrM) - -(type: PrivacyModifier - #PublicPM - #PrivatePM - #ProtectedPM - #DefaultPM) - -(type: StateModifier - #VolatileSM - #FinalSM - #DefaultSM) - -(type: InheritanceModifier - #FinalIM - #AbstractIM - #DefaultIM) - -(type: Class_Kind - #Class - #Interface) - -(type: Class_Declaration - {#class_name Text - #class_params (List Type_Parameter)}) - -(type: StackFrame (primitive "java/lang/StackTraceElement")) -(type: StackTrace (Array StackFrame)) - -(type: Super_Class_Decl - {#super_class_name Text - #super_class_params (List GenericType)}) - -(type: AnnotationParam - [Text Code]) - -(type: Annotation - {#ann_name Text - #ann_params (List AnnotationParam)}) - -(type: Member_Declaration - {#member_name Text - #member_privacy PrivacyModifier - #member_anns (List Annotation)}) - -(type: FieldDecl - (#ConstantField GenericType Code) - (#VariableField StateModifier GenericType)) - -(type: MethodDecl - {#method_tvars (List Type_Parameter) - #method_inputs (List GenericType) - #method_output GenericType - #method_exs (List GenericType)}) - -(type: ArgDecl - {#arg_name Text - #arg_type GenericType}) - -(type: ConstructorArg - [GenericType Code]) - -(type: Method_Definition - (#ConstructorMethod [Bit - (List Type_Parameter) - (List ArgDecl) - (List ConstructorArg) - Code - (List GenericType)]) - (#VirtualMethod [Bit - Bit - (List Type_Parameter) - Text - (List ArgDecl) - GenericType - Code - (List GenericType)]) - (#OverridenMethod [Bit - Class_Declaration - (List Type_Parameter) - Text - (List ArgDecl) - GenericType - Code - (List GenericType)]) - (#StaticMethod [Bit - (List Type_Parameter) - (List ArgDecl) - GenericType - Code - (List GenericType)]) - (#AbstractMethod [(List Type_Parameter) - (List ArgDecl) - GenericType - (List GenericType)]) - (#NativeMethod [(List Type_Parameter) - (List ArgDecl) - GenericType - (List GenericType)])) - -(type: Partial_Call - {#pc_method Name - #pc_args (List Code)}) - -(type: ImportMethodKind - #StaticIMK - #VirtualIMK) - -(type: ImportMethodCommons - {#import_member_mode Primitive_Mode - #import_member_alias Text - #import_member_kind ImportMethodKind - #import_member_tvars (List Type_Parameter) - #import_member_args (List [Bit GenericType]) - #import_member_maybe? Bit - #import_member_try? Bit - #import_member_io? Bit}) - -(type: ImportConstructorDecl - {}) - -(type: ImportMethodDecl - {#import_method_name Text - #import_method_return GenericType}) - -(type: ImportFieldDecl - {#import_field_mode Primitive_Mode - #import_field_name Text - #import_field_static? Bit - #import_field_maybe? Bit - #import_field_setter? Bit - #import_field_type GenericType}) - -(type: Import_Member_Declaration - (#EnumDecl (List Text)) - (#ConstructorDecl [ImportMethodCommons ImportConstructorDecl]) - (#MethodDecl [ImportMethodCommons ImportMethodDecl]) - (#FieldAccessDecl ImportFieldDecl)) - -## Utils -(def: (manual_primitive_to_type class) - (-> Text (Maybe Code)) - (case class - (^template [<prim> <type>] - [<prim> - (#.Some (' <type>))]) - (["boolean" (primitive "java.lang.Boolean")] - ["byte" (primitive "java.lang.Byte")] - ["short" (primitive "java.lang.Short")] - ["int" (primitive "java.lang.Integer")] - ["long" (primitive "java.lang.Long")] - ["float" (primitive "java.lang.Float")] - ["double" (primitive "java.lang.Double")] - ["char" (primitive "java.lang.Character")] - ["void" .Any]) - - _ - #.None)) - -(def: (auto_primitive_to_type class) - (-> Text (Maybe Code)) - (case class - (^template [<prim> <type>] - [<prim> - (#.Some (' <type>))]) - (["boolean" .Bit] - ["byte" .Int] - ["short" .Int] - ["int" .Int] - ["long" .Int] - ["float" .Frac] - ["double" .Frac] - ["void" .Any]) - - _ - #.None)) - -(def: sanitize - (-> Text Text) - (text.replace_all "/" ".")) - -(def: (generic_class_to_type' mode type_params in_array? name+params - class_to_type') - (-> Primitive_Mode (List Type_Parameter) Bit [Text (List GenericType)] - (-> Primitive_Mode (List Type_Parameter) Bit GenericType Code) - Code) - (case [name+params mode in_array?] - (^multi [[prim #.Nil] #ManualPrM #0] - [(manual_primitive_to_type prim) (#.Some output)]) - output - - (^multi [[prim #.Nil] #AutoPrM #0] - [(auto_primitive_to_type prim) (#.Some output)]) - output - - [[name params] _ _] - (let [name (sanitize name) - =params (list\map (class_to_type' mode type_params in_array?) params)] - (` (primitive (~ (code.text name)) [(~+ =params)]))))) - -(def: (class_to_type' mode type_params in_array? class) - (-> Primitive_Mode (List Type_Parameter) Bit GenericType Code) - (case class - (#GenericTypeVar name) - (case (list.find (function (_ [pname pbounds]) - (and (text\= name pname) - (not (list.empty? pbounds)))) - type_params) - #.None - (code.identifier ["" name]) - - (#.Some [pname pbounds]) - (class_to_type' mode type_params in_array? (maybe.assume (list.head pbounds)))) - - (#GenericClass name+params) - (generic_class_to_type' mode type_params in_array? name+params - class_to_type') - - (#GenericArray param) - (let [=param (class_to_type' mode type_params #1 param)] - (` ((~! array.Array) (~ =param)))) - - (^or (#GenericWildcard #.None) (#GenericWildcard (#.Some [#LowerBound _]))) - (` .Any) - - (#GenericWildcard (#.Some [#UpperBound upper_bound])) - (class_to_type' mode type_params in_array? upper_bound) - )) - -(def: (class_to_type mode type_params class) - (-> Primitive_Mode (List Type_Parameter) GenericType Code) - (class_to_type' mode type_params #0 class)) - -(def: (type_param_type$ [name bounds]) - (-> Type_Parameter Code) - (code.identifier ["" name])) - -(def: (class_decl_type$ (^slots [#class_name #class_params])) - (-> Class_Declaration Code) - (let [=params (list\map (: (-> Type_Parameter Code) - (function (_ [pname pbounds]) - (case pbounds - #.Nil - (code.identifier ["" pname]) - - (#.Cons bound1 _) - (class_to_type #ManualPrM class_params bound1)))) - class_params)] - (` (primitive (~ (code.text (sanitize class_name))) - [(~+ =params)])))) - -(def: type_var_class Text "java.lang.Object") - -(def: (simple_class$ env class) - (-> (List Type_Parameter) GenericType Text) - (case class - (#GenericTypeVar name) - (case (list.find (function (_ [pname pbounds]) - (and (text\= name pname) - (not (list.empty? pbounds)))) - env) - #.None - type_var_class - - (#.Some [pname pbounds]) - (simple_class$ env (maybe.assume (list.head pbounds)))) - - (^or (#GenericWildcard #.None) (#GenericWildcard (#.Some [#LowerBound _]))) - type_var_class - - (#GenericWildcard (#.Some [#UpperBound upper_bound])) - (simple_class$ env upper_bound) - - (#GenericClass name env) - (sanitize name) - - (#GenericArray param') - (case param' - (#GenericArray param) - (format "[" (simple_class$ env param)) - - (^template [<prim> <class>] - [(#GenericClass <prim> #.Nil) - <class>]) - (["boolean" "[Z"] - ["byte" "[B"] - ["short" "[S"] - ["int" "[I"] - ["long" "[J"] - ["float" "[F"] - ["double" "[D"] - ["char" "[C"]) - - param - (format "[L" (simple_class$ env param) ";")) - )) - -(def: (make_get_const_parser class_name field_name) - (-> Text Text (Parser Code)) - (do <>.monad - [#let [dotted_name (format "::" field_name)] - _ (<code>.this! (code.identifier ["" dotted_name]))] - (wrap (`' ((~ (code.text (format "jvm getstatic" ":" class_name ":" field_name)))))))) - -(def: (make_get_var_parser class_name field_name) - (-> Text Text (Parser Code)) - (do <>.monad - [#let [dotted_name (format "::" field_name)] - _ (<code>.this! (code.identifier ["" dotted_name]))] - (wrap (`' ((~ (code.text (format "jvm getfield" ":" class_name ":" field_name))) _jvm_this))))) - -(def: (make_put_var_parser class_name field_name) - (-> Text Text (Parser Code)) - (do <>.monad - [#let [dotted_name (format "::" field_name)] - [_ _ value] (: (Parser [Any Any Code]) - (<code>.form ($_ <>.and (<code>.this! (' :=)) (<code>.this! (code.identifier ["" dotted_name])) <code>.any)))] - (wrap (`' ((~ (code.text (format "jvm putfield" ":" class_name ":" field_name))) _jvm_this (~ value)))))) - -(def: (pre_walk_replace f input) - (-> (-> Code Code) Code Code) - (case (f input) - (^template [<tag>] - [[meta (<tag> parts)] - [meta (<tag> (list\map (pre_walk_replace f) parts))]]) - ([#.Form] - [#.Tuple]) - - [meta (#.Record pairs)] - [meta (#.Record (list\map (: (-> [Code Code] [Code Code]) - (function (_ [key val]) - [(pre_walk_replace f key) (pre_walk_replace f val)])) - pairs))] - - ast' - ast')) - -(def: (parser->replacer p ast) - (-> (Parser Code) (-> Code Code)) - (case (<>.run p (list ast)) - (#.Right [#.Nil ast']) - ast' - - _ - ast - )) - -(def: (field->parser class_name [[field_name _ _] field]) - (-> Text [Member_Declaration FieldDecl] (Parser Code)) - (case field - (#ConstantField _) - (make_get_const_parser class_name field_name) - - (#VariableField _) - (<>.either (make_get_var_parser class_name field_name) - (make_put_var_parser class_name field_name)))) - -(def: (make_constructor_parser params class_name arg_decls) - (-> (List Type_Parameter) Text (List ArgDecl) (Parser Code)) - (do <>.monad - [args (: (Parser (List Code)) - (<code>.form (<>.after (<code>.this! (' ::new!)) - (<code>.tuple (<>.exactly (list.size arg_decls) <code>.any))))) - #let [arg_decls' (: (List Text) (list\map (|>> product.right (simple_class$ params)) arg_decls))]] - (wrap (` ((~ (code.text (format "jvm new" ":" class_name ":" (text.join_with "," arg_decls')))) - (~+ args)))))) - -(def: (make_static_method_parser params class_name method_name arg_decls) - (-> (List Type_Parameter) Text Text (List ArgDecl) (Parser Code)) - (do <>.monad - [#let [dotted_name (format "::" method_name "!")] - args (: (Parser (List Code)) - (<code>.form (<>.after (<code>.this! (code.identifier ["" dotted_name])) - (<code>.tuple (<>.exactly (list.size arg_decls) <code>.any))))) - #let [arg_decls' (: (List Text) (list\map (|>> product.right (simple_class$ params)) arg_decls))]] - (wrap (`' ((~ (code.text (format "jvm invokestatic" ":" class_name ":" method_name ":" (text.join_with "," arg_decls')))) - (~+ args)))))) - -(template [<name> <jvm_op>] - [(def: (<name> params class_name method_name arg_decls) - (-> (List Type_Parameter) Text Text (List ArgDecl) (Parser Code)) - (do <>.monad - [#let [dotted_name (format "::" method_name "!")] - args (: (Parser (List Code)) - (<code>.form (<>.after (<code>.this! (code.identifier ["" dotted_name])) - (<code>.tuple (<>.exactly (list.size arg_decls) <code>.any))))) - #let [arg_decls' (: (List Text) (list\map (|>> product.right (simple_class$ params)) arg_decls))]] - (wrap (`' ((~ (code.text (format <jvm_op> ":" class_name ":" method_name ":" (text.join_with "," arg_decls')))) - (~' _jvm_this) (~+ args))))))] - - [make_special_method_parser "jvm invokespecial"] - [make_virtual_method_parser "jvm invokevirtual"] - ) - -(def: (method->parser params class_name [[method_name _ _] meth_def]) - (-> (List Type_Parameter) Text [Member_Declaration Method_Definition] (Parser Code)) - (case meth_def - (#ConstructorMethod strict? type_vars args constructor_args return_expr exs) - (make_constructor_parser params class_name args) - - (#StaticMethod strict? type_vars args return_type return_expr exs) - (make_static_method_parser params class_name method_name args) - - (^or (#VirtualMethod final? strict? type_vars self_name args return_type return_expr exs) - (#OverridenMethod strict? owner_class type_vars self_name args return_type return_expr exs)) - (make_special_method_parser params class_name method_name args) - - (#AbstractMethod type_vars args return_type exs) - (make_virtual_method_parser params class_name method_name args) - - (#NativeMethod type_vars args return_type exs) - (make_virtual_method_parser params class_name method_name args))) - -## Parsers -(def: privacy_modifier^ - (Parser PrivacyModifier) - (let [(^open ".") <>.monad] - ($_ <>.or - (<code>.this! (' #public)) - (<code>.this! (' #private)) - (<code>.this! (' #protected)) - (wrap [])))) - -(def: inheritance_modifier^ - (Parser InheritanceModifier) - (let [(^open ".") <>.monad] - ($_ <>.or - (<code>.this! (' #final)) - (<code>.this! (' #abstract)) - (wrap [])))) - -(def: bound_kind^ - (Parser BoundKind) - (<>.or (<code>.this! (' <)) - (<code>.this! (' >)))) - -(def: (assert_no_periods name) - (-> Text (Parser Any)) - (<>.assert "Names in class declarations cannot contain periods." - (not (text.contains? "." name)))) - -(def: (generic_type^ type_vars) - (-> (List Type_Parameter) (Parser GenericType)) - (<>.rec - (function (_ recur^) - ($_ <>.either - (do <>.monad - [_ (<code>.this! (' ?))] - (wrap (#GenericWildcard #.None))) - (<code>.tuple (do <>.monad - [_ (<code>.this! (' ?)) - bound_kind bound_kind^ - bound recur^] - (wrap (#GenericWildcard (#.Some [bound_kind bound]))))) - (do <>.monad - [name <code>.local_identifier - _ (assert_no_periods name)] - (if (list.member? text.equivalence (list\map product.left type_vars) name) - (wrap (#GenericTypeVar name)) - (wrap (#GenericClass name (list))))) - (<code>.tuple (do <>.monad - [component recur^] - (case component - (^template [<class> <name>] - [(#GenericClass <name> #.Nil) - (wrap (#GenericClass <class> (list)))]) - (["[Z" "boolean"] - ["[B" "byte"] - ["[S" "short"] - ["[I" "int"] - ["[J" "long"] - ["[F" "float"] - ["[D" "double"] - ["[C" "char"]) - - _ - (wrap (#GenericArray component))))) - (<code>.form (do <>.monad - [name <code>.local_identifier - _ (assert_no_periods name) - params (<>.some recur^) - _ (<>.assert (format name " cannot be a type-parameter!") - (not (list.member? text.equivalence (list\map product.left type_vars) name)))] - (wrap (#GenericClass name params)))) - )))) - -(def: type_param^ - (Parser Type_Parameter) - (<>.either (do <>.monad - [param_name <code>.local_identifier] - (wrap [param_name (list)])) - (<code>.tuple (do <>.monad - [param_name <code>.local_identifier - _ (<code>.this! (' <)) - bounds (<>.many (..generic_type^ (list)))] - (wrap [param_name bounds]))))) - -(def: type_params^ - (Parser (List Type_Parameter)) - (|> ..type_param^ - <>.some - <code>.tuple - (<>.default (list)))) - -(def: class_decl^ - (Parser Class_Declaration) - (<>.either (do <>.monad - [name <code>.local_identifier - _ (assert_no_periods name)] - (wrap [name (list)])) - (<code>.form (do <>.monad - [name <code>.local_identifier - _ (assert_no_periods name) - params (<>.some ..type_param^)] - (wrap [name params]))) - )) - -(def: (super_class_decl^ type_vars) - (-> (List Type_Parameter) (Parser Super_Class_Decl)) - (<>.either (do <>.monad - [name <code>.local_identifier - _ (assert_no_periods name)] - (wrap [name (list)])) - (<code>.form (do <>.monad - [name <code>.local_identifier - _ (assert_no_periods name) - params (<>.some (..generic_type^ type_vars))] - (wrap [name params]))))) - -(def: annotation_params^ - (Parser (List AnnotationParam)) - (<code>.record (<>.some (<>.and <code>.local_tag <code>.any)))) - -(def: annotation^ - (Parser Annotation) - (<>.either (do <>.monad - [ann_name <code>.local_identifier] - (wrap [ann_name (list)])) - (<code>.form (<>.and <code>.local_identifier - annotation_params^)))) - -(def: annotations^' - (Parser (List Annotation)) - (do <>.monad - [_ (<code>.this! (' #ann))] - (<code>.tuple (<>.some ..annotation^)))) - -(def: annotations^ - (Parser (List Annotation)) - (do <>.monad - [anns?? (<>.maybe ..annotations^')] - (wrap (maybe.default (list) anns??)))) - -(def: (throws_decl'^ type_vars) - (-> (List Type_Parameter) (Parser (List GenericType))) - (do <>.monad - [_ (<code>.this! (' #throws))] - (<code>.tuple (<>.some (..generic_type^ type_vars))))) - -(def: (throws_decl^ type_vars) - (-> (List Type_Parameter) (Parser (List GenericType))) - (do <>.monad - [exs? (<>.maybe (throws_decl'^ type_vars))] - (wrap (maybe.default (list) exs?)))) - -(def: (method_decl^ type_vars) - (-> (List Type_Parameter) (Parser [Member_Declaration MethodDecl])) - (<code>.form (do <>.monad - [tvars ..type_params^ - name <code>.local_identifier - anns ..annotations^ - inputs (<code>.tuple (<>.some (..generic_type^ type_vars))) - output (..generic_type^ type_vars) - exs (..throws_decl^ type_vars)] - (wrap [[name #PublicPM anns] {#method_tvars tvars - #method_inputs inputs - #method_output output - #method_exs exs}])))) - -(def: state_modifier^ - (Parser StateModifier) - ($_ <>.or - (<code>.this! (' #volatile)) - (<code>.this! (' #final)) - (\ <>.monad wrap []))) - -(def: (field_decl^ type_vars) - (-> (List Type_Parameter) (Parser [Member_Declaration FieldDecl])) - (<>.either (<code>.form (do <>.monad - [_ (<code>.this! (' #const)) - name <code>.local_identifier - anns ..annotations^ - type (..generic_type^ type_vars) - body <code>.any] - (wrap [[name #PublicPM anns] (#ConstantField [type body])]))) - (<code>.form (do <>.monad - [pm privacy_modifier^ - sm state_modifier^ - name <code>.local_identifier - anns ..annotations^ - type (..generic_type^ type_vars)] - (wrap [[name pm anns] (#VariableField [sm type])]))))) - -(def: (arg_decl^ type_vars) - (-> (List Type_Parameter) (Parser ArgDecl)) - (<code>.record (<>.and <code>.local_identifier - (..generic_type^ type_vars)))) - -(def: (arg_decls^ type_vars) - (-> (List Type_Parameter) (Parser (List ArgDecl))) - (<>.some (arg_decl^ type_vars))) - -(def: (constructor_arg^ type_vars) - (-> (List Type_Parameter) (Parser ConstructorArg)) - (<code>.record (<>.and (..generic_type^ type_vars) <code>.any))) - -(def: (constructor_args^ type_vars) - (-> (List Type_Parameter) (Parser (List ConstructorArg))) - (<code>.tuple (<>.some (constructor_arg^ type_vars)))) - -(def: (constructor_method^ class_vars) - (-> (List Type_Parameter) (Parser [Member_Declaration Method_Definition])) - (<code>.form (do <>.monad - [pm privacy_modifier^ - strict_fp? (<>.parses? (<code>.this! (' #strict))) - method_vars ..type_params^ - #let [total_vars (list\compose class_vars method_vars)] - [_ arg_decls] (<code>.form (<>.and (<code>.this! (' new)) - (..arg_decls^ total_vars))) - constructor_args (..constructor_args^ total_vars) - exs (..throws_decl^ total_vars) - annotations ..annotations^ - body <code>.any] - (wrap [{#member_name constructor_method_name - #member_privacy pm - #member_anns annotations} - (#ConstructorMethod strict_fp? method_vars arg_decls constructor_args body exs)])))) - -(def: (virtual_method_def^ class_vars) - (-> (List Type_Parameter) (Parser [Member_Declaration Method_Definition])) - (<code>.form (do <>.monad - [pm privacy_modifier^ - strict_fp? (<>.parses? (<code>.this! (' #strict))) - final? (<>.parses? (<code>.this! (' #final))) - method_vars ..type_params^ - #let [total_vars (list\compose class_vars method_vars)] - [name this_name arg_decls] (<code>.form ($_ <>.and - <code>.local_identifier - <code>.local_identifier - (..arg_decls^ total_vars))) - return_type (..generic_type^ total_vars) - exs (..throws_decl^ total_vars) - annotations ..annotations^ - body <code>.any] - (wrap [{#member_name name - #member_privacy pm - #member_anns annotations} - (#VirtualMethod final? strict_fp? - method_vars - this_name arg_decls return_type - body exs)])))) - -(def: overriden_method_def^ - (Parser [Member_Declaration Method_Definition]) - (<code>.form (do <>.monad - [strict_fp? (<>.parses? (<code>.this! (' #strict))) - owner_class ..class_decl^ - method_vars ..type_params^ - #let [total_vars (list\compose (product.right owner_class) method_vars)] - [name this_name arg_decls] (<code>.form ($_ <>.and - <code>.local_identifier - <code>.local_identifier - (..arg_decls^ total_vars))) - return_type (..generic_type^ total_vars) - exs (..throws_decl^ total_vars) - annotations ..annotations^ - body <code>.any] - (wrap [{#member_name name - #member_privacy #PublicPM - #member_anns annotations} - (#OverridenMethod strict_fp? - owner_class method_vars - this_name arg_decls return_type - body exs)])))) - -(def: static_method_def^ - (Parser [Member_Declaration Method_Definition]) - (<code>.form (do <>.monad - [pm privacy_modifier^ - strict_fp? (<>.parses? (<code>.this! (' #strict))) - _ (<code>.this! (' #static)) - method_vars ..type_params^ - #let [total_vars method_vars] - [name arg_decls] (<code>.form (<>.and <code>.local_identifier - (..arg_decls^ total_vars))) - return_type (..generic_type^ total_vars) - exs (..throws_decl^ total_vars) - annotations ..annotations^ - body <code>.any] - (wrap [{#member_name name - #member_privacy pm - #member_anns annotations} - (#StaticMethod strict_fp? method_vars arg_decls return_type body exs)])))) - -(def: abstract_method_def^ - (Parser [Member_Declaration Method_Definition]) - (<code>.form (do <>.monad - [pm privacy_modifier^ - _ (<code>.this! (' #abstract)) - method_vars ..type_params^ - #let [total_vars method_vars] - [name arg_decls] (<code>.form (<>.and <code>.local_identifier - (..arg_decls^ total_vars))) - return_type (..generic_type^ total_vars) - exs (..throws_decl^ total_vars) - annotations ..annotations^] - (wrap [{#member_name name - #member_privacy pm - #member_anns annotations} - (#AbstractMethod method_vars arg_decls return_type exs)])))) - -(def: native_method_def^ - (Parser [Member_Declaration Method_Definition]) - (<code>.form (do <>.monad - [pm privacy_modifier^ - _ (<code>.this! (' #native)) - method_vars ..type_params^ - #let [total_vars method_vars] - [name arg_decls] (<code>.form (<>.and <code>.local_identifier - (..arg_decls^ total_vars))) - return_type (..generic_type^ total_vars) - exs (..throws_decl^ total_vars) - annotations ..annotations^] - (wrap [{#member_name name - #member_privacy pm - #member_anns annotations} - (#NativeMethod method_vars arg_decls return_type exs)])))) - -(def: (method_def^ class_vars) - (-> (List Type_Parameter) (Parser [Member_Declaration Method_Definition])) - ($_ <>.either - (..constructor_method^ class_vars) - (..virtual_method_def^ class_vars) - ..overriden_method_def^ - ..static_method_def^ - ..abstract_method_def^ - ..native_method_def^)) - -(def: partial_call^ - (Parser Partial_Call) - (<code>.form (<>.and <code>.identifier (<>.some <code>.any)))) - -(def: class_kind^ - (Parser Class_Kind) - (<>.either (do <>.monad - [_ (<code>.this! (' #class))] - (wrap #Class)) - (do <>.monad - [_ (<code>.this! (' #interface))] - (wrap #Interface)) - )) - -(def: import_member_alias^ - (Parser (Maybe Text)) - (<>.maybe (do <>.monad - [_ (<code>.this! (' #as))] - <code>.local_identifier))) - -(def: (import_member_args^ type_vars) - (-> (List Type_Parameter) (Parser (List [Bit GenericType]))) - (<code>.tuple (<>.some (<>.and (<>.parses? (<code>.this! (' #?))) (..generic_type^ type_vars))))) - -(def: import_member_return_flags^ - (Parser [Bit Bit Bit]) - ($_ <>.and (<>.parses? (<code>.this! (' #io))) (<>.parses? (<code>.this! (' #try))) (<>.parses? (<code>.this! (' #?))))) - -(def: primitive_mode^ - (Parser Primitive_Mode) - (<>.or (<code>.this! (' #manual)) - (<code>.this! (' #auto)))) - -(def: (import_member_decl^ owner_vars) - (-> (List Type_Parameter) (Parser Import_Member_Declaration)) - ($_ <>.either - (<code>.form (do <>.monad - [_ (<code>.this! (' #enum)) - enum_members (<>.some <code>.local_identifier)] - (wrap (#EnumDecl enum_members)))) - (<code>.form (do <>.monad - [tvars ..type_params^ - _ (<code>.this! (' new)) - ?alias import_member_alias^ - #let [total_vars (list\compose owner_vars tvars)] - ?prim_mode (<>.maybe primitive_mode^) - args (..import_member_args^ total_vars) - [io? try? maybe?] import_member_return_flags^] - (wrap (#ConstructorDecl [{#import_member_mode (maybe.default #AutoPrM ?prim_mode) - #import_member_alias (maybe.default "new" ?alias) - #import_member_kind #VirtualIMK - #import_member_tvars tvars - #import_member_args args - #import_member_maybe? maybe? - #import_member_try? try? - #import_member_io? io?} - {}])) - )) - (<code>.form (do <>.monad - [kind (: (Parser ImportMethodKind) - (<>.or (<code>.this! (' #static)) - (wrap []))) - tvars ..type_params^ - name <code>.local_identifier - ?alias import_member_alias^ - #let [total_vars (list\compose owner_vars tvars)] - ?prim_mode (<>.maybe primitive_mode^) - args (..import_member_args^ total_vars) - [io? try? maybe?] import_member_return_flags^ - return (..generic_type^ total_vars)] - (wrap (#MethodDecl [{#import_member_mode (maybe.default #AutoPrM ?prim_mode) - #import_member_alias (maybe.default name ?alias) - #import_member_kind kind - #import_member_tvars tvars - #import_member_args args - #import_member_maybe? maybe? - #import_member_try? try? - #import_member_io? io?} - {#import_method_name name - #import_method_return return - }])))) - (<code>.form (do <>.monad - [static? (<>.parses? (<code>.this! (' #static))) - name <code>.local_identifier - ?prim_mode (<>.maybe primitive_mode^) - gtype (..generic_type^ owner_vars) - maybe? (<>.parses? (<code>.this! (' #?))) - setter? (<>.parses? (<code>.this! (' #!)))] - (wrap (#FieldAccessDecl {#import_field_mode (maybe.default #AutoPrM ?prim_mode) - #import_field_name name - #import_field_static? static? - #import_field_maybe? maybe? - #import_field_setter? setter? - #import_field_type gtype})))) - )) - -(def: bundle - (-> (List Type_Parameter) (Parser [Text (List Import_Member_Declaration)])) - (|>> ..import_member_decl^ - <>.some - (<>.and <code>.text) - <code>.tuple)) - -## Generators -(def: with_parens - (-> JVM_Code JVM_Code) - (text.enclose ["(" ")"])) - -(def: with_brackets - (-> JVM_Code JVM_Code) - (text.enclose ["[" "]"])) - -(def: spaced - (-> (List JVM_Code) JVM_Code) - (text.join_with " ")) - -(def: (privacy_modifier$ pm) - (-> PrivacyModifier JVM_Code) - (case pm - #PublicPM "public" - #PrivatePM "private" - #ProtectedPM "protected" - #DefaultPM "default")) - -(def: (inheritance_modifier$ im) - (-> InheritanceModifier JVM_Code) - (case im - #FinalIM "final" - #AbstractIM "abstract" - #DefaultIM "default")) - -(def: (annotation_param$ [name value]) - (-> AnnotationParam JVM_Code) - (format name "=" (code.format value))) - -(def: (annotation$ [name params]) - (-> Annotation JVM_Code) - (format "(" name " " "{" (text.join_with text.tab (list\map annotation_param$ params)) "}" ")")) - -(def: (bound_kind$ kind) - (-> BoundKind JVM_Code) - (case kind - #UpperBound "<" - #LowerBound ">")) - -(def: (generic_type$ gtype) - (-> GenericType JVM_Code) - (case gtype - (#GenericTypeVar name) - name - - (#GenericClass name params) - (format "(" (sanitize name) " " (spaced (list\map generic_type$ params)) ")") - - (#GenericArray param) - (format "(" array.type_name " " (generic_type$ param) ")") - - (#GenericWildcard #.None) - "?" - - (#GenericWildcard (#.Some [bound_kind bound])) - (format (bound_kind$ bound_kind) (generic_type$ bound)))) - -(def: (type_param$ [name bounds]) - (-> Type_Parameter JVM_Code) - (format "(" name " " (spaced (list\map generic_type$ bounds)) ")")) - -(def: (class_decl$ (^open ".")) - (-> Class_Declaration JVM_Code) - (format "(" (sanitize class_name) " " (spaced (list\map type_param$ class_params)) ")")) - -(def: (super_class_decl$ (^slots [#super_class_name #super_class_params])) - (-> Super_Class_Decl JVM_Code) - (format "(" (sanitize super_class_name) " " (spaced (list\map generic_type$ super_class_params)) ")")) - -(def: (method_decl$ [[name pm anns] method_decl]) - (-> [Member_Declaration MethodDecl] JVM_Code) - (let [(^slots [#method_tvars #method_inputs #method_output #method_exs]) method_decl] - (with_parens - (spaced (list name - (with_brackets (spaced (list\map annotation$ anns))) - (with_brackets (spaced (list\map type_param$ method_tvars))) - (with_brackets (spaced (list\map generic_type$ method_exs))) - (with_brackets (spaced (list\map generic_type$ method_inputs))) - (generic_type$ method_output)) - )))) - -(def: (state_modifier$ sm) - (-> StateModifier JVM_Code) - (case sm - #VolatileSM "volatile" - #FinalSM "final" - #DefaultSM "default")) - -(def: (field_decl$ [[name pm anns] field]) - (-> [Member_Declaration FieldDecl] JVM_Code) - (case field - (#ConstantField class value) - (with_parens - (spaced (list "constant" name - (with_brackets (spaced (list\map annotation$ anns))) - (generic_type$ class) - (code.format value)) - )) - - (#VariableField sm class) - (with_parens - (spaced (list "variable" name - (privacy_modifier$ pm) - (state_modifier$ sm) - (with_brackets (spaced (list\map annotation$ anns))) - (generic_type$ class)) - )) - )) - -(def: (arg_decl$ [name type]) - (-> ArgDecl JVM_Code) - (with_parens - (spaced (list name (generic_type$ type))))) - -(def: (constructor_arg$ [class term]) - (-> ConstructorArg JVM_Code) - (with_brackets - (spaced (list (generic_type$ class) (code.format term))))) - -(def: (method_def$ replacer super_class [[name pm anns] method_def]) - (-> (-> Code Code) Super_Class_Decl [Member_Declaration Method_Definition] JVM_Code) - (case method_def - (#ConstructorMethod strict_fp? type_vars arg_decls constructor_args body exs) - (with_parens - (spaced (list "init" - (privacy_modifier$ pm) - (bit\encode strict_fp?) - (with_brackets (spaced (list\map annotation$ anns))) - (with_brackets (spaced (list\map type_param$ type_vars))) - (with_brackets (spaced (list\map generic_type$ exs))) - (with_brackets (spaced (list\map arg_decl$ arg_decls))) - (with_brackets (spaced (list\map constructor_arg$ constructor_args))) - (code.format (pre_walk_replace replacer body)) - ))) - - (#VirtualMethod final? strict_fp? type_vars this_name arg_decls return_type body exs) - (with_parens - (spaced (list "virtual" - name - (privacy_modifier$ pm) - (bit\encode final?) - (bit\encode strict_fp?) - (with_brackets (spaced (list\map annotation$ anns))) - (with_brackets (spaced (list\map type_param$ type_vars))) - (with_brackets (spaced (list\map generic_type$ exs))) - (with_brackets (spaced (list\map arg_decl$ arg_decls))) - (generic_type$ return_type) - (code.format (pre_walk_replace replacer (` (let [(~ (code.local_identifier this_name)) (~' _jvm_this)] - (~ body)))))))) - - (#OverridenMethod strict_fp? class_decl type_vars this_name arg_decls return_type body exs) - (let [super_replacer (parser->replacer (<code>.form (do <>.monad - [_ (<code>.this! (' ::super!)) - args (<code>.tuple (<>.exactly (list.size arg_decls) <code>.any)) - #let [arg_decls' (: (List Text) (list\map (|>> product.right (simple_class$ (list))) - arg_decls))]] - (wrap (`' ((~ (code.text (format "jvm invokespecial" - ":" (get@ #super_class_name super_class) - ":" name - ":" (text.join_with "," arg_decls')))) - (~' _jvm_this) (~+ args)))))))] - (with_parens - (spaced (list "override" - (class_decl$ class_decl) - name - (bit\encode strict_fp?) - (with_brackets (spaced (list\map annotation$ anns))) - (with_brackets (spaced (list\map type_param$ type_vars))) - (with_brackets (spaced (list\map generic_type$ exs))) - (with_brackets (spaced (list\map arg_decl$ arg_decls))) - (generic_type$ return_type) - (|> (` (let [(~ (code.local_identifier this_name)) (~' _jvm_this)] - (~ body))) - (pre_walk_replace replacer) - (pre_walk_replace super_replacer) - (code.format)) - )))) - - (#StaticMethod strict_fp? type_vars arg_decls return_type body exs) - (with_parens - (spaced (list "static" - name - (privacy_modifier$ pm) - (bit\encode strict_fp?) - (with_brackets (spaced (list\map annotation$ anns))) - (with_brackets (spaced (list\map type_param$ type_vars))) - (with_brackets (spaced (list\map generic_type$ exs))) - (with_brackets (spaced (list\map arg_decl$ arg_decls))) - (generic_type$ return_type) - (code.format (pre_walk_replace replacer body))))) - - (#AbstractMethod type_vars arg_decls return_type exs) - (with_parens - (spaced (list "abstract" - name - (privacy_modifier$ pm) - (with_brackets (spaced (list\map annotation$ anns))) - (with_brackets (spaced (list\map type_param$ type_vars))) - (with_brackets (spaced (list\map generic_type$ exs))) - (with_brackets (spaced (list\map arg_decl$ arg_decls))) - (generic_type$ return_type)))) - - (#NativeMethod type_vars arg_decls return_type exs) - (with_parens - (spaced (list "native" - name - (privacy_modifier$ pm) - (with_brackets (spaced (list\map annotation$ anns))) - (with_brackets (spaced (list\map type_param$ type_vars))) - (with_brackets (spaced (list\map generic_type$ exs))) - (with_brackets (spaced (list\map arg_decl$ arg_decls))) - (generic_type$ return_type)))) - )) - -(def: (complete_call$ g!obj [method args]) - (-> Code Partial_Call Code) - (` ((~ (code.identifier method)) (~+ args) (~ g!obj)))) - -## [Syntax] -(def: object_super_class - Super_Class_Decl - {#super_class_name "java/lang/Object" - #super_class_params (list)}) - -(syntax: #export (class: - {im inheritance_modifier^} - {class_decl ..class_decl^} - {#let [full_class_name (product.left class_decl)]} - {#let [class_vars (product.right class_decl)]} - {super (<>.default object_super_class - (..super_class_decl^ class_vars))} - {interfaces (<>.default (list) - (<code>.tuple (<>.some (..super_class_decl^ class_vars))))} - {annotations ..annotations^} - {fields (<>.some (..field_decl^ class_vars))} - {methods (<>.some (..method_def^ class_vars))}) - {#.doc (doc "Allows defining JVM classes in Lux code." - "For example:" - (class: #final (TestClass A) [Runnable] - ## Fields - (#private foo boolean) - (#private bar A) - (#private baz java/lang/Object) - ## Methods - (#public [] (new [value A]) [] - (exec (:= ::foo #1) - (:= ::bar value) - (:= ::baz "") - [])) - (#public (virtual) java/lang/Object - "") - (#public #static (static) java/lang/Object - "") - (Runnable [] (run) void - []) - ) - - "The tuple corresponds to parent interfaces." - "An optional super-class can be specified before the tuple. If not specified, java.lang.Object will be assumed." - "Fields and methods defined in the class can be used with special syntax." - "For example:" - "::resolved, for accessing the 'resolved' field." - "(:= ::resolved #1) for modifying it." - "(::new! []) for calling the class's constructor." - "(::resolve! container [value]) for calling the 'resolve' method." - )} - (do meta.monad - [current_module meta.current_module_name - #let [fully_qualified_class_name (format (sanitize current_module) "." full_class_name) - field_parsers (list\map (field->parser fully_qualified_class_name) fields) - method_parsers (list\map (method->parser (product.right class_decl) fully_qualified_class_name) methods) - replacer (parser->replacer (list\fold <>.either - (<>.fail "") - (list\compose field_parsers method_parsers))) - def_code (format "jvm class:" - (spaced (list (class_decl$ class_decl) - (super_class_decl$ super) - (with_brackets (spaced (list\map super_class_decl$ interfaces))) - (inheritance_modifier$ im) - (with_brackets (spaced (list\map annotation$ annotations))) - (with_brackets (spaced (list\map field_decl$ fields))) - (with_brackets (spaced (list\map (method_def$ replacer super) methods))))))]] - (wrap (list (` ((~ (code.text def_code)))))))) - -(syntax: #export (interface: - {class_decl ..class_decl^} - {#let [class_vars (product.right class_decl)]} - {supers (<>.default (list) - (<code>.tuple (<>.some (..super_class_decl^ class_vars))))} - {annotations ..annotations^} - {members (<>.some (..method_decl^ class_vars))}) - {#.doc (doc "Allows defining JVM interfaces." - (interface: TestInterface - ([] foo [boolean String] void #throws [Exception])))} - (let [def_code (format "jvm interface:" - (spaced (list (class_decl$ class_decl) - (with_brackets (spaced (list\map super_class_decl$ supers))) - (with_brackets (spaced (list\map annotation$ annotations))) - (spaced (list\map method_decl$ members)))))] - (wrap (list (` ((~ (code.text def_code)))))) - )) - -(syntax: #export (object - {class_vars (<code>.tuple (<>.some ..type_param^))} - {super (<>.default object_super_class - (..super_class_decl^ class_vars))} - {interfaces (<>.default (list) - (<code>.tuple (<>.some (..super_class_decl^ class_vars))))} - {constructor_args (..constructor_args^ class_vars)} - {methods (<>.some ..overriden_method_def^)}) - {#.doc (doc "Allows defining anonymous classes." - "The 1st tuple corresponds to class-level type-variables." - "The 2nd tuple corresponds to parent interfaces." - "The 3rd tuple corresponds to arguments to the super class constructor." - "An optional super-class can be specified before the 1st tuple. If not specified, java.lang.Object will be assumed." - (object [] [Runnable] - [] - (Runnable [] (run self) void - (exec (do_something some_value) - []))) - )} - (let [def_code (format "jvm anon-class:" - (spaced (list (super_class_decl$ super) - (with_brackets (spaced (list\map super_class_decl$ interfaces))) - (with_brackets (spaced (list\map constructor_arg$ constructor_args))) - (with_brackets (spaced (list\map (method_def$ function.identity super) methods))))))] - (wrap (list (` ((~ (code.text def_code)))))))) - -(syntax: #export (null) - {#.doc (doc "Null object reference." - (null))} - (wrap (list (` ("jvm object null"))))) - -(def: #export (null? obj) - {#.doc (doc "Test for null object reference." - (= (null? (null)) - true) - (= (null? "YOLO") - false))} - (-> (primitive "java.lang.Object") Bit) - ("jvm object null?" obj)) - -(syntax: #export (??? expr) - {#.doc (doc "Takes a (potentially null) ObjectType reference and creates a (Maybe ObjectType) for it." - (= (??? (: java/lang/String (null))) - #.None) - (= (??? "YOLO") - (#.Some "YOLO")))} - (with_gensyms [g!temp] - (wrap (list (` (let [(~ g!temp) (~ expr)] - (if ("jvm object null?" (~ g!temp)) - #.None - (#.Some (~ g!temp))))))))) - -(syntax: #export (!!! expr) - {#.doc (doc "Takes a (Maybe ObjectType) and returns a ObjectType." - "A #.None would get translated into a (null)." - (= (null) - (!!! (??? (: java/lang/Thread (null))))) - (= "foo" - (!!! (??? "foo"))))} - (with_gensyms [g!value] - (wrap (list (` ({(#.Some (~ g!value)) - (~ g!value) - - #.None - ("jvm object null")} - (~ expr))))))) - -(syntax: #export (check {class (..generic_type^ (list))} - {unchecked (<>.maybe <code>.any)}) - {#.doc (doc "Checks whether an object is an instance of a particular class." - "Caveat emptor: Cannot check for polymorphism, so avoid using parameterized classes." - (case (check java/lang/String "YOLO") - (#.Some value_as_string) - #.None))} - (with_gensyms [g!_ g!unchecked] - (let [class_name (simple_class$ (list) class) - class_type (` (.primitive (~ (code.text class_name)))) - check_type (` (.Maybe (~ class_type))) - check_code (` (if ((~ (code.text (format "jvm instanceof" ":" class_name))) (~ g!unchecked)) - (#.Some (.:as (~ class_type) - (~ g!unchecked))) - #.None))] - (case unchecked - (#.Some unchecked) - (wrap (list (` (: (~ check_type) - (let [(~ g!unchecked) (~ unchecked)] - (~ check_code)))))) - - #.None - (wrap (list (` (: (-> (primitive "java.lang.Object") (~ check_type)) - (function ((~ g!_) (~ g!unchecked)) - (~ check_code)))))) - )))) - -(syntax: #export (synchronized lock body) - {#.doc (doc "Evaluates body, while holding a lock on a given object." - (synchronized object_to_be_locked - (exec (do_something ___) - (do_something_else ___) - (finish_the_computation ___))))} - (wrap (list (` ("jvm object synchronized" (~ lock) (~ body)))))) - -(syntax: #export (do_to obj {methods (<>.some partial_call^)}) - {#.doc (doc "Call a variety of methods on an object. Then, return the object." - (do_to object - (ClassName::method1 arg0 arg1 arg2) - (ClassName::method2 arg3 arg4 arg5)))} - (with_gensyms [g!obj] - (wrap (list (` (let [(~ g!obj) (~ obj)] - (exec (~+ (list\map (complete_call$ g!obj) methods)) - (~ g!obj)))))))) - -(def: (class_import$ [full_name params]) - (-> Class_Declaration Code) - (let [params' (list\map (|>> product.left code.local_identifier) params)] - (` (def: (~ (code.identifier ["" full_name])) - {#..jvm_class (~ (code.text full_name))} - Type - (All [(~+ params')] - (primitive (~ (code.text (sanitize full_name))) - [(~+ params')])))))) - -(def: (member_type_vars class_tvars member) - (-> (List Type_Parameter) Import_Member_Declaration (List Type_Parameter)) - (case member - (#ConstructorDecl [commons _]) - (list\compose class_tvars (get@ #import_member_tvars commons)) - - (#MethodDecl [commons _]) - (case (get@ #import_member_kind commons) - #StaticIMK - (get@ #import_member_tvars commons) - - _ - (list\compose class_tvars (get@ #import_member_tvars commons))) - - _ - class_tvars)) - -(def: (member_def_arg_bindings type_params class member) - (-> (List Type_Parameter) Class_Declaration Import_Member_Declaration (Meta [(List [Bit Code]) (List Text) (List Code)])) - (case member - (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) - (let [(^slots [#import_member_tvars #import_member_args]) commons] - (do {! meta.monad} - [arg_inputs (monad.map ! - (: (-> [Bit GenericType] (Meta [Bit Code])) - (function (_ [maybe? _]) - (with_gensyms [arg_name] - (wrap [maybe? arg_name])))) - import_member_args) - #let [arg_classes (: (List Text) - (list\map (|>> product.right (simple_class$ (list\compose type_params import_member_tvars))) - import_member_args)) - arg_types (list\map (: (-> [Bit GenericType] Code) - (function (_ [maybe? arg]) - (let [arg_type (class_to_type (get@ #import_member_mode commons) type_params arg)] - (if maybe? - (` (Maybe (~ arg_type))) - arg_type)))) - import_member_args)]] - (wrap [arg_inputs arg_classes arg_types]))) - - _ - (\ meta.monad wrap [(list) (list) (list)]))) - -(def: (decorate_return_maybe class member return_term) - (-> Class_Declaration Import_Member_Declaration Code Code) - (case member - (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) - (if (get@ #import_member_maybe? commons) - (` (??? (~ return_term))) - (let [g!temp (` ((~' ~') (~ (code.identifier ["" " Ω "]))))] - (` (let [(~ g!temp) (~ return_term)] - (if (not (..null? (:as (primitive "java.lang.Object") - (~ g!temp)))) - (~ g!temp) - (error! (~ (code.text (format "Cannot produce null references from method calls @ " - (get@ #class_name class) - "." (get@ #import_member_alias commons)))))))))) - - _ - return_term)) - -(template [<name> <tag> <term_trans>] - [(def: (<name> member return_term) - (-> Import_Member_Declaration Code Code) - (case member - (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) - (if (get@ <tag> commons) - <term_trans> - return_term) - - _ - return_term))] - - [decorate_return_try #import_member_try? (` (.try (~ return_term)))] - [decorate_return_io #import_member_io? (` ((~! io.io) (~ return_term)))] - ) - -(def: (free_type_param? [name bounds]) - (-> Type_Parameter Bit) - (case bounds - #.Nil #1 - _ #0)) - -(def: (type_param->type_arg [name _]) - (-> Type_Parameter Code) - (code.identifier ["" name])) - -(template [<name> <byte> <short> <int> <float>] - [(def: (<name> mode [class expression]) - (-> Primitive_Mode [Text Code] Code) - (case mode - #ManualPrM - expression - - #AutoPrM - (case class - "byte" (` (<byte> (~ expression))) - "short" (` (<short> (~ expression))) - "int" (` (<int> (~ expression))) - "float" (` (<float> (~ expression))) - _ expression)))] - - [auto_convert_input long_to_byte long_to_short long_to_int double_to_float] - [auto_convert_output byte_to_long short_to_long int_to_long float_to_double] - ) - -(def: (un_quote quoted) - (-> Code Code) - (` ((~' ~) (~ quoted)))) - -(def: (jvm_extension_inputs mode classes inputs) - (-> Primitive_Mode (List Text) (List [Bit Code]) (List Code)) - (|> inputs - (list\map (function (_ [maybe? input]) - (if maybe? - (` ((~! !!!) (~ (un_quote input)))) - (un_quote input)))) - (list.zip/2 classes) - (list\map (auto_convert_input mode)))) - -(def: (import_name format class member) - (-> Text Text Text Text) - (|> format - (text.replace_all "#" class) - (text.replace_all "." member))) - -(def: (member_def_interop type_params kind class [arg_function_inputs arg_classes arg_types] member method_prefix import_format) - (-> (List Type_Parameter) Class_Kind Class_Declaration [(List [Bit Code]) (List Text) (List Code)] Import_Member_Declaration Text Text (Meta (List Code))) - (let [[full_name class_tvars] class - full_name (sanitize full_name) - all_params (|> (member_type_vars class_tvars member) - (list.filter free_type_param?) - (list\map type_param->type_arg))] - (case member - (#EnumDecl enum_members) - (do {! meta.monad} - [#let [enum_type (: Code - (case class_tvars - #.Nil - (` (primitive (~ (code.text full_name)))) - - _ - (let [=class_tvars (|> class_tvars - (list.filter free_type_param?) - (list\map type_param->type_arg))] - (` (All [(~+ =class_tvars)] (primitive (~ (code.text full_name)) [(~+ =class_tvars)])))))) - getter_interop (: (-> Text Code) - (function (_ name) - (let [getter_name (code.identifier ["" (..import_name import_format method_prefix name)])] - (` (def: (~ getter_name) - (~ enum_type) - ((~ (code.text (format "jvm getstatic" ":" full_name ":" name)))))))))]] - (wrap (list\map getter_interop enum_members))) - - (#ConstructorDecl [commons _]) - (do meta.monad - [#let [def_name (code.identifier ["" (..import_name import_format method_prefix (get@ #import_member_alias commons))]) - jvm_extension (code.text (format "jvm new" ":" full_name ":" (text.join_with "," arg_classes))) - jvm_interop (|> (` ((~ jvm_extension) - (~+ (jvm_extension_inputs (get@ #import_member_mode commons) arg_classes arg_function_inputs)))) - (decorate_return_maybe class member) - (decorate_return_try member) - (decorate_return_io member))]] - (wrap (list (` ((~! syntax:) ((~ def_name) (~+ (list\map product.right arg_function_inputs))) - ((~' wrap) (.list (.` (~ jvm_interop))))))))) - - (#MethodDecl [commons method]) - (with_gensyms [g!obj] - (do meta.monad - [#let [def_name (code.identifier ["" (..import_name import_format method_prefix (get@ #import_member_alias commons))]) - (^slots [#import_member_kind]) commons - (^slots [#import_method_name]) method - [jvm_op object_ast] (: [Text (List Code)] - (case import_member_kind - #StaticIMK - ["invokestatic" - (list)] - - #VirtualIMK - (case kind - #Class - ["invokevirtual" - (list g!obj)] - - #Interface - ["invokeinterface" - (list g!obj)] - ))) - jvm_extension (code.text (format "jvm " jvm_op ":" full_name ":" import_method_name ":" (text.join_with "," arg_classes))) - jvm_interop (|> [(simple_class$ (list) (get@ #import_method_return method)) - (` ((~ jvm_extension) (~+ (list\map un_quote object_ast)) - (~+ (jvm_extension_inputs (get@ #import_member_mode commons) arg_classes arg_function_inputs))))] - (auto_convert_output (get@ #import_member_mode commons)) - (decorate_return_maybe class member) - (decorate_return_try member) - (decorate_return_io member))]] - (wrap (list (` ((~! syntax:) ((~ def_name) (~+ (list\map product.right arg_function_inputs)) (~+ object_ast)) - ((~' wrap) (.list (.` (~ jvm_interop)))))))))) - - (#FieldAccessDecl fad) - (do meta.monad - [#let [(^open ".") fad - base_gtype (class_to_type import_field_mode type_params import_field_type) - classC (class_decl_type$ class) - typeC (if import_field_maybe? - (` (Maybe (~ base_gtype))) - base_gtype) - tvar_asts (: (List Code) - (|> class_tvars - (list.filter free_type_param?) - (list\map type_param->type_arg))) - getter_name (code.identifier ["" (..import_name import_format method_prefix import_field_name)]) - setter_name (code.identifier ["" (..import_name import_format method_prefix (format import_field_name "!"))])] - getter_interop (with_gensyms [g!obj] - (let [getter_call (if import_field_static? - (` ((~ getter_name))) - (` ((~ getter_name) (~ g!obj)))) - getter_body (<| (auto_convert_output import_field_mode) - [(simple_class$ (list) import_field_type) - (if import_field_static? - (let [jvm_extension (code.text (format "jvm getstatic" ":" full_name ":" import_field_name))] - (` ((~ jvm_extension)))) - (let [jvm_extension (code.text (format "jvm getfield" ":" full_name ":" import_field_name))] - (` ((~ jvm_extension) (~ (un_quote g!obj))))))]) - getter_body (if import_field_maybe? - (` ((~! ???) (~ getter_body))) - getter_body) - getter_body (if import_field_setter? - (` ((~! io.io) (~ getter_body))) - getter_body)] - (wrap (` ((~! syntax:) (~ getter_call) - ((~' wrap) (.list (.` (~ getter_body))))))))) - setter_interop (: (Meta (List Code)) - (if import_field_setter? - (with_gensyms [g!obj g!value] - (let [setter_call (if import_field_static? - (` ((~ setter_name) (~ g!value))) - (` ((~ setter_name) (~ g!value) (~ g!obj)))) - setter_value (auto_convert_input import_field_mode - [(simple_class$ (list) import_field_type) (un_quote g!value)]) - setter_value (if import_field_maybe? - (` ((~! !!!) (~ setter_value))) - setter_value) - setter_command (format (if import_field_static? "jvm putstatic" "jvm putfield") - ":" full_name ":" import_field_name) - g!obj+ (: (List Code) - (if import_field_static? - (list) - (list (un_quote g!obj))))] - (wrap (list (` ((~! syntax:) (~ setter_call) - ((~' wrap) (.list (.` ((~! io.io) ((~ (code.text setter_command)) (~+ g!obj+) (~ setter_value)))))))))))) - (wrap (list))))] - (wrap (list& getter_interop setter_interop))) - ))) - -(def: (member_import$ type_params kind class [import_format member]) - (-> (List Type_Parameter) Class_Kind Class_Declaration [Text Import_Member_Declaration] (Meta (List Code))) - (let [[method_prefix _] class] - (do meta.monad - [=args (member_def_arg_bindings type_params class member)] - (member_def_interop type_params kind class =args member method_prefix import_format)))) - -(type: (java/lang/Class a) - (primitive "java.lang.Class" [a])) - -(def: interface? - (All [a] (-> (java/lang/Class a) Bit)) - (|>> "jvm invokevirtual:java.lang.Class:isInterface:")) - -(def: (load_class class_name) - (-> Text (Try (java/lang/Class Any))) - (try ("jvm invokestatic:java.lang.Class:forName:java.lang.String" class_name))) - -(def: (class_kind [class_name _]) - (-> Class_Declaration (Meta Class_Kind)) - (let [class_name (..sanitize class_name)] - (case (..load_class class_name) - (#try.Success class) - (\ meta.monad wrap (if (interface? class) - #Interface - #Class)) - - (#try.Failure error) - (meta.fail (format "Cannot load class: " class_name text.new_line - error))))) - -(syntax: #export (import: - {class_decl ..class_decl^} - {bundles (<>.some (..bundle (product.right class_decl)))}) - {#.doc (doc "Allows importing JVM classes, and using them as types." - "Their methods, fields and enum options can also be imported." - (import: java/lang/Object - ["#::." - (new []) - (equals [java/lang/Object] boolean) - (wait [int] #io #try void)]) - - "Special options can also be given for the return values." - "#? means that the values will be returned inside a Maybe type. That way, null becomes #.None." - "#try means that the computation might throw an exception, and the return value will be wrapped by the Try type." - "#io means the computation has side effects, and will be wrapped by the IO type." - "These options must show up in the following order [#io #try #?] (although, each option can be used independently)." - (import: java/lang/String - ["#::." - (new [[byte]]) - (#static valueOf [char] java/lang/String) - (#static valueOf #as int_valueOf [int] java/lang/String)]) - - (import: (java/util/List e) - ["#::." - (size [] int) - (get [int] e)]) - - (import: (java/util/ArrayList a) - ["#::." - ([T] toArray [[T]] [T])]) - - "The class-type that is generated is of the fully-qualified name." - "This avoids a clash between the java.util.List type, and Lux's own List type." - "All enum options to be imported must be specified." - (import: java/lang/Character$UnicodeScript - ["#::." - (#enum ARABIC CYRILLIC LATIN)]) - - "It should also be noted, the only types that may show up in method arguments or return values may be Java classes, arrays, primitives, void or type-parameters." - "Lux types, such as Maybe cannot be named (otherwise, they'd be confused for Java classes)." - (import: (lux/concurrency/promise/JvmPromise A) - ["#::." - (resolve [A] boolean) - (poll [] A) - (wasResolved [] boolean) - (waitOn [lux/Function] void) - (#static [A] make [A] (lux/concurrency/promise/JvmPromise A))]) - - "Also, the names of the imported members will look like Class::member" - (java/lang/Object::new []) - (java/lang/Object::equals [other_object] my_object) - (java/util/List::size [] my_list) - java/lang/Character$UnicodeScript::LATIN - )} - (do {! meta.monad} - [kind (class_kind class_decl) - =members (|> bundles - (list\map (function (_ [import_format members]) - (list\map (|>> [import_format]) members))) - list.concat - (monad.map ! (member_import$ (product.right class_decl) kind class_decl)))] - (wrap (list& (class_import$ class_decl) (list\join =members))))) - -(syntax: #export (array {type (..generic_type^ (list))} - size) - {#.doc (doc "Create an array of the given type, with the given size." - (array java/lang/Object 10))} - (case type - (^template [<type> <array_op>] - [(^ (#GenericClass <type> (list))) - (wrap (list (` (<array_op> (~ size)))))]) - (["boolean" "jvm znewarray"] - ["byte" "jvm bnewarray"] - ["short" "jvm snewarray"] - ["int" "jvm inewarray"] - ["long" "jvm lnewarray"] - ["float" "jvm fnewarray"] - ["double" "jvm dnewarray"] - ["char" "jvm cnewarray"]) - - _ - (wrap (list (` ("jvm anewarray" (~ (code.text (generic_type$ type))) (~ size))))))) - -(syntax: #export (array_length array) - {#.doc (doc "Gives the length of an array." - (array_length my_array))} - (wrap (list (` ("jvm arraylength" (~ array)))))) - -(def: (type->class_name type) - (-> Type (Meta Text)) - (if (type\= Any type) - (\ meta.monad wrap "java.lang.Object") - (case type - (#.Primitive name params) - (\ meta.monad wrap name) - - (#.Apply A F) - (case (type.apply (list A) F) - #.None - (meta.fail (format "Cannot apply type: " (type.format F) " to " (type.format A))) - - (#.Some type') - (type->class_name type')) - - (#.Named _ type') - (type->class_name type') - - _ - (meta.fail (format "Cannot convert to JvmType: " (type.format type)))))) - -(syntax: #export (array_read idx array) - {#.doc (doc "Loads an element from an array." - (array_read 10 my_array))} - (case array - [_ (#.Identifier array_name)] - (do meta.monad - [array_type (meta.find_type array_name) - array_jvm_type (type->class_name array_type)] - (case array_jvm_type - (^template [<type> <array_op>] - [<type> - (wrap (list (` (<array_op> (~ array) (~ idx)))))]) - (["[Z" "jvm zaload"] - ["[B" "jvm baload"] - ["[S" "jvm saload"] - ["[I" "jvm iaload"] - ["[J" "jvm jaload"] - ["[F" "jvm faload"] - ["[D" "jvm daload"] - ["[C" "jvm caload"]) - - _ - (wrap (list (` ("jvm aaload" (~ array) (~ idx))))))) - - _ - (with_gensyms [g!array] - (wrap (list (` (let [(~ g!array) (~ array)] - (..array_read (~ idx) (~ g!array))))))))) - -(syntax: #export (array_write idx value array) - {#.doc (doc "Stores an element into an array." - (array_write 10 my_object my_array))} - (case array - [_ (#.Identifier array_name)] - (do meta.monad - [array_type (meta.find_type array_name) - array_jvm_type (type->class_name array_type)] - (case array_jvm_type - (^template [<type> <array_op>] - [<type> - (wrap (list (` (<array_op> (~ array) (~ idx) (~ value)))))]) - (["[Z" "jvm zastore"] - ["[B" "jvm bastore"] - ["[S" "jvm sastore"] - ["[I" "jvm iastore"] - ["[J" "jvm jastore"] - ["[F" "jvm fastore"] - ["[D" "jvm dastore"] - ["[C" "jvm castore"]) - - _ - (wrap (list (` ("jvm aastore" (~ array) (~ idx) (~ value))))))) - - _ - (with_gensyms [g!array] - (wrap (list (` (let [(~ g!array) (~ array)] - (..array_write (~ idx) (~ value) (~ g!array))))))))) - -(syntax: #export (class_for {type (..generic_type^ (list))}) - {#.doc (doc "Loads the class as a java.lang.Class object." - (class_for java/lang/String))} - (wrap (list (` ("jvm object class" (~ (code.text (simple_class$ (list) type)))))))) - -(syntax: #export (type {type (..generic_type^ (list))}) - (wrap (list (..class_to_type #ManualPrM (list) type)))) diff --git a/stdlib/source/lux/ffi.php.lux b/stdlib/source/lux/ffi.php.lux deleted file mode 100644 index 08a837c44..000000000 --- a/stdlib/source/lux/ffi.php.lux +++ /dev/null @@ -1,313 +0,0 @@ -(.module: - [lux (#- Alias) - ["." meta] - ["@" target] - [abstract - [monad (#+ do)]] - [control - ["." io] - ["<>" parser ("#\." monad) - ["<.>" code (#+ Parser)]]] - [data - ["." product] - ["." maybe] - ["." text - ["%" format]] - [collection - ["." list ("#\." functor fold)]]] - [type - abstract] - [macro (#+ with_gensyms) - [syntax (#+ syntax:)] - ["." code] - ["." template]]]) - -(abstract: #export (Object brand) Any) - -(template [<name>] - [(with_expansions [<brand> (template.identifier [<name> "'"])] - (abstract: #export <brand> Any) - (type: #export <name> - (..Object <brand>)))] - - [Null] - [Function] - ) - -(template [<name> <type>] - [(type: #export <name> - <type>)] - - [Boolean Bit] - [Integer Int] - [Float Frac] - [String Text] - ) - -(type: Nullable - [Bit Code]) - -(def: nullable - (Parser Nullable) - (let [token (' #?)] - (<| (<>.and (<>.parses? (<code>.this! token))) - (<>.after (<>.not (<code>.this! token))) - <code>.any))) - -(type: Alias - Text) - -(def: alias - (Parser Alias) - (<>.after (<code>.this! (' #as)) <code>.local_identifier)) - -(type: Field - [Bit Text (Maybe Alias) Nullable]) - -(def: static! - (Parser Any) - (<code>.this! (' #static))) - -(def: field - (Parser Field) - (<code>.form ($_ <>.and - (<>.parses? ..static!) - <code>.local_identifier - (<>.maybe ..alias) - ..nullable))) - -(def: constant - (Parser Field) - (<code>.form ($_ <>.and - (<>\wrap true) - <code>.local_identifier - (<>.maybe ..alias) - ..nullable))) - -(type: Common_Method - {#name Text - #alias (Maybe Alias) - #inputs (List Nullable) - #io? Bit - #try? Bit - #output Nullable}) - -(type: Static_Method Common_Method) -(type: Virtual_Method Common_Method) - -(type: Method - (#Static Static_Method) - (#Virtual Virtual_Method)) - -(def: common_method - (Parser Common_Method) - ($_ <>.and - <code>.local_identifier - (<>.maybe ..alias) - (<code>.tuple (<>.some ..nullable)) - (<>.parses? (<code>.this! (' #io))) - (<>.parses? (<code>.this! (' #try))) - ..nullable)) - -(def: static_method - (<>.after ..static! ..common_method)) - -(def: method - (Parser Method) - (<code>.form (<>.or ..static_method - ..common_method))) - -(type: Member - (#Field Field) - (#Method Method)) - -(def: member - (Parser Member) - ($_ <>.or - ..field - ..method - )) - -(def: input_variables - (-> (List Nullable) (List [Bit Code])) - (|>> list.enumeration - (list\map (function (_ [idx [nullable? type]]) - [nullable? (|> idx %.nat code.local_identifier)])))) - -(def: (nullable_type [nullable? type]) - (-> Nullable Code) - (if nullable? - (` (.Maybe (~ type))) - type)) - -(def: (with_null g!temp [nullable? input]) - (-> Code [Bit Code] Code) - (if nullable? - (` (case (~ input) - (#.Some (~ g!temp)) - (~ g!temp) - - #.Null - ("php object null"))) - input)) - -(def: (without_null g!temp [nullable? outputT] output) - (-> Code Nullable Code Code) - (if nullable? - (` (let [(~ g!temp) (~ output)] - (if ("php object null?" (~ g!temp)) - #.None - (#.Some (~ g!temp))))) - (` (let [(~ g!temp) (~ output)] - (if (not ("php object null?" (~ g!temp))) - (~ g!temp) - (.error! "Null is an invalid value!")))))) - -(type: Import - (#Class Text (Maybe Alias) Text (List Member)) - (#Function Static_Method) - (#Constant Field)) - -(def: import - (Parser Import) - ($_ <>.or - ($_ <>.and - <code>.local_identifier - (<>.maybe ..alias) - (<>.default ["" (list)] - (<code>.tuple (<>.and <code>.text - (<>.some member))))) - (<code>.form ..common_method) - ..constant - )) - -(syntax: #export (try expression) - {#.doc (doc (case (try (risky_computation input)) - (#.Right success) - (do_something success) - - (#.Left error) - (recover_from_failure error)))} - (wrap (list (` ("lux try" ((~! io.io) (~ expression))))))) - -(def: (with_io with? without) - (-> Bit Code Code) - (if with? - (` (io.io (~ without))) - without)) - -(def: (io_type io? rawT) - (-> Bit Code Code) - (if io? - (` (io.IO (~ rawT))) - rawT)) - -(def: (with_try with? without_try) - (-> Bit Code Code) - (if with? - (` (..try (~ without_try))) - without_try)) - -(def: (try_type try? rawT) - (-> Bit Code Code) - (if try? - (` (.Either .Text (~ rawT))) - rawT)) - -(def: (make_function g!method g!temp source inputsT io? try? outputT) - (-> Code Code Code (List Nullable) Bit Bit Nullable Code) - (let [g!inputs (input_variables inputsT)] - (` (def: ((~ g!method) - [(~+ (list\map product.right g!inputs))]) - (-> [(~+ (list\map nullable_type inputsT))] - (~ (|> (nullable_type outputT) - (try_type try?) - (io_type io?)))) - (:assume - (~ (<| (with_io io?) - (with_try try?) - (without_null g!temp outputT) - (` ("php apply" - (:as ..Function (~ source)) - (~+ (list\map (with_null g!temp) g!inputs))))))))))) - -(syntax: #export (import: {import ..import}) - (with_gensyms [g!temp] - (case import - (#Class [class alias format members]) - (with_gensyms [g!object] - (let [qualify (: (-> Text Code) - (function (_ member_name) - (|> format - (text.replace_all "#" (maybe.default class alias)) - (text.replace_all "." member_name) - code.local_identifier))) - g!type (code.local_identifier (maybe.default class alias)) - class_import (` ("php constant" (~ (code.text class))))] - (wrap (list& (` (type: (~ g!type) - (..Object (primitive (~ (code.text class)))))) - (list\map (function (_ member) - (case member - (#Field [static? field alias fieldT]) - (if static? - (` ((~! syntax:) ((~ (qualify (maybe.default field alias)))) - (\ (~! meta.monad) (~' wrap) - (list (` (.:as (~ (nullable_type fieldT)) - ("php constant" (~ (code.text (%.format class "::" field)))))))))) - (` (def: ((~ (qualify field)) - (~ g!object)) - (-> (~ g!type) - (~ (nullable_type fieldT))) - (:assume - (~ (without_null g!temp fieldT (` ("php object get" (~ (code.text field)) - (:as (..Object .Any) (~ g!object)))))))))) - - (#Method method) - (case method - (#Static [method alias inputsT io? try? outputT]) - (..make_function (qualify (maybe.default method alias)) - g!temp - (` ("php object get" (~ (code.text method)) - (:as (..Object .Any) - ("php constant" (~ (code.text (%.format class "::" method))))))) - inputsT - io? - try? - outputT) - - (#Virtual [method alias inputsT io? try? outputT]) - (let [g!inputs (input_variables inputsT)] - (` (def: ((~ (qualify (maybe.default method alias))) - [(~+ (list\map product.right g!inputs))] - (~ g!object)) - (-> [(~+ (list\map nullable_type inputsT))] - (~ g!type) - (~ (|> (nullable_type outputT) - (try_type try?) - (io_type io?)))) - (:assume - (~ (<| (with_io io?) - (with_try try?) - (without_null g!temp outputT) - (` ("php object do" - (~ (code.text method)) - (~ g!object) - (~+ (list\map (with_null g!temp) g!inputs))))))))))))) - members))))) - - (#Function [name alias inputsT io? try? outputT]) - (let [imported (` ("php constant" (~ (code.text name))))] - (wrap (list (..make_function (code.local_identifier (maybe.default name alias)) - g!temp - imported - inputsT - io? - try? - outputT)))) - - (#Constant [_ name alias fieldT]) - (let [imported (` ("php constant" (~ (code.text name))))] - (wrap (list (` ((~! syntax:) ((~ (code.local_identifier (maybe.default name alias)))) - (\ (~! meta.monad) (~' wrap) - (list (` (.:as (~ (nullable_type fieldT)) (~ imported)))))))))) - ))) diff --git a/stdlib/source/lux/ffi.py.lux b/stdlib/source/lux/ffi.py.lux deleted file mode 100644 index 396cebf5c..000000000 --- a/stdlib/source/lux/ffi.py.lux +++ /dev/null @@ -1,314 +0,0 @@ -(.module: - [lux #* - ["." meta] - ["@" target] - [abstract - [monad (#+ do)]] - [control - ["." io] - ["<>" parser - ["<.>" code (#+ Parser)]]] - [data - ["." product] - ["." maybe] - ["." text - ["%" format]] - [collection - ["." list ("#\." functor fold)]]] - [type - abstract] - [macro (#+ with_gensyms) - [syntax (#+ syntax:)] - ["." code] - ["." template]]]) - -(abstract: #export (Object brand) Any) - -(template [<name>] - [(with_expansions [<brand> (template.identifier [<name> "'"])] - (abstract: #export <brand> Any) - (type: #export <name> - (..Object <brand>)))] - - [None] - [Function] - [Dict] - ) - -(template [<name> <type>] - [(type: #export <name> - <type>)] - - [Boolean Bit] - [Integer Int] - [Float Frac] - [String Text] - ) - -(type: Noneable - [Bit Code]) - -(def: noneable - (Parser Noneable) - (let [token (' #?)] - (<| (<>.and (<>.parses? (<code>.this! token))) - (<>.after (<>.not (<code>.this! token))) - <code>.any))) - -(type: Constructor - (List Noneable)) - -(def: constructor - (Parser Constructor) - (<code>.form (<>.after (<code>.this! (' new)) - (<code>.tuple (<>.some ..noneable))))) - -(type: Field - [Bit Text Noneable]) - -(def: static! - (Parser Any) - (<code>.this! (' #static))) - -(def: field - (Parser Field) - (<code>.form ($_ <>.and - (<>.parses? ..static!) - <code>.local_identifier - ..noneable))) - -(type: Common_Method - {#name Text - #alias (Maybe Text) - #inputs (List Noneable) - #io? Bit - #try? Bit - #output Noneable}) - -(type: Static_Method Common_Method) -(type: Virtual_Method Common_Method) - -(type: Method - (#Static Static_Method) - (#Virtual Virtual_Method)) - -(def: common_method - (Parser Common_Method) - ($_ <>.and - <code>.local_identifier - (<>.maybe (<>.after (<code>.this! (' #as)) <code>.local_identifier)) - (<code>.tuple (<>.some ..noneable)) - (<>.parses? (<code>.this! (' #io))) - (<>.parses? (<code>.this! (' #try))) - ..noneable)) - -(def: static_method - (<>.after ..static! ..common_method)) - -(def: method - (Parser Method) - (<code>.form (<>.or ..static_method - ..common_method))) - -(type: Member - (#Constructor Constructor) - (#Field Field) - (#Method Method)) - -(def: member - (Parser Member) - ($_ <>.or - ..constructor - ..field - ..method - )) - -(def: input_variables - (-> (List Noneable) (List [Bit Code])) - (|>> list.enumeration - (list\map (function (_ [idx [noneable? type]]) - [noneable? (|> idx %.nat code.local_identifier)])))) - -(def: (noneable_type [noneable? type]) - (-> Noneable Code) - (if noneable? - (` (.Maybe (~ type))) - type)) - -(def: (with_none g!temp [noneable? input]) - (-> Code [Bit Code] Code) - (if noneable? - (` (case (~ input) - (#.Some (~ g!temp)) - (~ g!temp) - - #.None - ("python object none"))) - input)) - -(def: (without_none g!temp [noneable? outputT] output) - (-> Code Noneable Code Code) - (if noneable? - (` (let [(~ g!temp) (~ output)] - (if ("python object none?" (~ g!temp)) - #.None - (#.Some (~ g!temp))))) - (` (let [(~ g!temp) (~ output)] - (if (not ("python object none?" (~ g!temp))) - (~ g!temp) - (.error! "None is an invalid value!")))))) - -(type: Import - (#Class [Text Text (List Member)]) - (#Function Static_Method)) - -(def: import - (Parser Import) - (<>.or (<>.and <code>.local_identifier - (<>.default ["" (list)] - (<code>.tuple (<>.and <code>.text - (<>.some member))))) - (<code>.form ..common_method))) - -(def: (with_io with? without) - (-> Bit Code Code) - (if with? - (` (io.io (~ without))) - without)) - -(def: (io_type io? rawT) - (-> Bit Code Code) - (if io? - (` (io.IO (~ rawT))) - rawT)) - -(def: (with_try with? without_try) - (-> Bit Code Code) - (if with? - (` (.try (~ without_try))) - without_try)) - -(def: (try_type try? rawT) - (-> Bit Code Code) - (if try? - (` (.Either .Text (~ rawT))) - rawT)) - -(def: (make_function g!method g!temp source inputsT io? try? outputT) - (-> Code Code Code (List Noneable) Bit Bit Noneable Code) - (let [g!inputs (input_variables inputsT)] - (` (def: ((~ g!method) - [(~+ (list\map product.right g!inputs))]) - (-> [(~+ (list\map noneable_type inputsT))] - (~ (|> (noneable_type outputT) - (try_type try?) - (io_type io?)))) - (:assume - (~ (<| (with_io io?) - (with_try try?) - (without_none g!temp outputT) - (` ("python apply" - (:as ..Function (~ source)) - (~+ (list\map (with_none g!temp) g!inputs))))))))))) - -(syntax: #export (import: {import ..import}) - (with_gensyms [g!temp] - (case import - (#Class [class format members]) - (with_gensyms [g!object] - (let [qualify (: (-> Text Code) - (function (_ member_name) - (|> format - (text.replace_all "#" class) - (text.replace_all "." member_name) - code.local_identifier))) - g!type (code.local_identifier class) - real_class (text.replace_all "/" "." class) - imported (case (text.split_all_with "/" class) - (#.Cons head tail) - (list\fold (function (_ sub super) - (` ("python object get" (~ (code.text sub)) - (:as (..Object .Any) (~ super))))) - (` ("python import" (~ (code.text head)))) - tail) - - #.Nil - (` ("python import" (~ (code.text class)))))] - (wrap (list& (` (type: (~ g!type) - (..Object (primitive (~ (code.text real_class)))))) - (list\map (function (_ member) - (case member - (#Constructor inputsT) - (let [g!inputs (input_variables inputsT)] - (` (def: ((~ (qualify "new")) - [(~+ (list\map product.right g!inputs))]) - (-> [(~+ (list\map noneable_type inputsT))] - (~ g!type)) - (:assume - ("python apply" - (:as ..Function (~ imported)) - (~+ (list\map (with_none g!temp) g!inputs))))))) - - (#Field [static? field fieldT]) - (if static? - (` ((~! syntax:) ((~ (qualify field))) - (\ (~! meta.monad) (~' wrap) - (list (` (.:as (~ (noneable_type fieldT)) - ("python object get" (~ (code.text field)) - (:as (..Object .Any) (~ imported))))))))) - (` (def: ((~ (qualify field)) - (~ g!object)) - (-> (~ g!type) - (~ (noneable_type fieldT))) - (:assume - (~ (without_none g!temp fieldT (` ("python object get" (~ (code.text field)) - (:as (..Object .Any) (~ g!object)))))))))) - - (#Method method) - (case method - (#Static [method alias inputsT io? try? outputT]) - (..make_function (qualify (maybe.default method alias)) - g!temp - (` ("python object get" (~ (code.text method)) - (:as (..Object .Any) (~ imported)))) - inputsT - io? - try? - outputT) - - (#Virtual [method alias inputsT io? try? outputT]) - (let [g!inputs (input_variables inputsT)] - (` (def: ((~ (qualify (maybe.default method alias))) - [(~+ (list\map product.right g!inputs))] - (~ g!object)) - (-> [(~+ (list\map noneable_type inputsT))] - (~ g!type) - (~ (|> (noneable_type outputT) - (try_type try?) - (io_type io?)))) - (:assume - (~ (<| (with_io io?) - (with_try try?) - (without_none g!temp outputT) - (` ("python object do" - (~ (code.text method)) - (~ g!object) - (~+ (list\map (with_none g!temp) g!inputs))))))))))))) - members))))) - - (#Function [name alias inputsT io? try? outputT]) - (wrap (list (..make_function (code.local_identifier (maybe.default name alias)) - g!temp - (` ("python constant" (~ (code.text name)))) - inputsT - io? - try? - outputT))) - ))) - -(template: #export (lambda <inputs> <output>) - (.:as ..Function - (`` ("python function" - (~~ (template.count <inputs>)) - (.function (_ [<inputs>]) - <output>))))) diff --git a/stdlib/source/lux/ffi.rb.lux b/stdlib/source/lux/ffi.rb.lux deleted file mode 100644 index df71dcc18..000000000 --- a/stdlib/source/lux/ffi.rb.lux +++ /dev/null @@ -1,331 +0,0 @@ -(.module: - [lux (#- Alias) - ["@" target] - ["." meta] - [abstract - [monad (#+ do)]] - [control - ["." io] - ["<>" parser ("#\." monad) - ["<.>" code (#+ Parser)]]] - [data - ["." product] - ["." maybe] - ["." text - ["%" format]] - [collection - ["." list ("#\." functor fold)]]] - [type - abstract] - [macro (#+ with_gensyms) - [syntax (#+ syntax:)] - ["." code] - ["." template]]]) - -(abstract: #export (Object brand) Any) - -(template [<name>] - [(with_expansions [<brand> (template.identifier [<name> "'"])] - (abstract: #export <brand> Any) - (type: #export <name> - (..Object <brand>)))] - - [Nil] - [Function] - ) - -(template [<name> <type>] - [(type: #export <name> - <type>)] - - [Boolean Bit] - [Integer Int] - [Float Frac] - [String Text] - ) - -(type: Nilable - [Bit Code]) - -(def: nilable - (Parser Nilable) - (let [token (' #?)] - (<| (<>.and (<>.parses? (<code>.this! token))) - (<>.after (<>.not (<code>.this! token))) - <code>.any))) - -(type: Alias - Text) - -(def: alias - (Parser Alias) - (<>.after (<code>.this! (' #as)) <code>.local_identifier)) - -(type: Field - [Bit Text (Maybe Alias) Nilable]) - -(def: static! - (Parser Any) - (<code>.this! (' #static))) - -(def: field - (Parser Field) - (<code>.form ($_ <>.and - (<>.parses? ..static!) - <code>.local_identifier - (<>.maybe ..alias) - ..nilable))) - -(def: constant - (Parser Field) - (<code>.form ($_ <>.and - (<>\wrap true) - <code>.local_identifier - (<>.maybe ..alias) - ..nilable))) - -(type: Common_Method - {#name Text - #alias (Maybe Alias) - #inputs (List Nilable) - #io? Bit - #try? Bit - #output Nilable}) - -(type: Static_Method Common_Method) -(type: Virtual_Method Common_Method) - -(type: Method - (#Static Static_Method) - (#Virtual Virtual_Method)) - -(def: common_method - (Parser Common_Method) - ($_ <>.and - <code>.local_identifier - (<>.maybe ..alias) - (<code>.tuple (<>.some ..nilable)) - (<>.parses? (<code>.this! (' #io))) - (<>.parses? (<code>.this! (' #try))) - ..nilable)) - -(def: static_method - (<>.after ..static! ..common_method)) - -(def: method - (Parser Method) - (<code>.form (<>.or ..static_method - ..common_method))) - -(type: Member - (#Field Field) - (#Method Method)) - -(def: member - (Parser Member) - ($_ <>.or - ..field - ..method - )) - -(def: input_variables - (-> (List Nilable) (List [Bit Code])) - (|>> list.enumeration - (list\map (function (_ [idx [nilable? type]]) - [nilable? (|> idx %.nat code.local_identifier)])))) - -(def: (nilable_type [nilable? type]) - (-> Nilable Code) - (if nilable? - (` (.Maybe (~ type))) - type)) - -(def: (with_nil g!temp [nilable? input]) - (-> Code [Bit Code] Code) - (if nilable? - (` (case (~ input) - (#.Some (~ g!temp)) - (~ g!temp) - - #.Nil - ("ruby object nil"))) - input)) - -(def: (without_nil g!temp [nilable? outputT] output) - (-> Code Nilable Code Code) - (if nilable? - (` (let [(~ g!temp) (~ output)] - (if ("ruby object nil?" (~ g!temp)) - #.None - (#.Some (~ g!temp))))) - (` (let [(~ g!temp) (~ output)] - (if (not ("ruby object nil?" (~ g!temp))) - (~ g!temp) - (.error! "Nil is an invalid value!")))))) - -(type: Import - (#Class Text (Maybe Alias) Text (List Member)) - (#Function Static_Method) - (#Constant Field)) - -(def: import - (Parser [(Maybe Text) Import]) - ($_ <>.and - (<>.maybe <code>.text) - ($_ <>.or - ($_ <>.and - <code>.local_identifier - (<>.maybe ..alias) - (<>.default ["" (list)] - (<code>.tuple (<>.and <code>.text - (<>.some member))))) - (<code>.form ..common_method) - ..constant - ))) - -(def: (with_io with? without) - (-> Bit Code Code) - (if with? - (` (io.io (~ without))) - without)) - -(def: (io_type io? rawT) - (-> Bit Code Code) - (if io? - (` (io.IO (~ rawT))) - rawT)) - -(def: (with_try with? without_try) - (-> Bit Code Code) - (if with? - (` (.try (~ without_try))) - without_try)) - -(def: (try_type try? rawT) - (-> Bit Code Code) - (if try? - (` (.Either .Text (~ rawT))) - rawT)) - -(def: (make_function g!method g!temp source inputsT io? try? outputT) - (-> Code Code Code (List Nilable) Bit Bit Nilable Code) - (let [g!inputs (input_variables inputsT)] - (` (def: ((~ g!method) - [(~+ (list\map product.right g!inputs))]) - (-> [(~+ (list\map nilable_type inputsT))] - (~ (|> (nilable_type outputT) - (try_type try?) - (io_type io?)))) - (:assume - (~ (<| (with_io io?) - (with_try try?) - (without_nil g!temp outputT) - (` ("ruby apply" - (:as ..Function (~ source)) - (~+ (list\map (with_nil g!temp) g!inputs))))))))))) - -(syntax: #export (import: {[?module import] ..import}) - (with_gensyms [g!temp] - (case import - (#Class [class alias format members]) - (with_gensyms [g!object] - (let [qualify (: (-> Text Code) - (function (_ member_name) - (|> format - (text.replace_all "#" (maybe.default class alias)) - (text.replace_all "." member_name) - code.local_identifier))) - g!type (code.local_identifier (maybe.default class alias)) - module_import (: (List Code) - (case ?module - (#.Some module) - (list (` ("ruby import" (~ (code.text module))))) - - #.None - (list))) - class_import (` ("ruby constant" (~ (code.text class))))] - (wrap (list& (` (type: (~ g!type) - (..Object (primitive (~ (code.text class)))))) - (list\map (function (_ member) - (case member - (#Field [static? field alias fieldT]) - (if static? - (` ((~! syntax:) ((~ (qualify (maybe.default field alias)))) - (\ (~! meta.monad) (~' wrap) - (list (` (.:as (~ (nilable_type fieldT)) - (.exec - (~+ module_import) - ("ruby constant" (~ (code.text (%.format class "::" field))))))))))) - (` (def: ((~ (qualify field)) - (~ g!object)) - (-> (~ g!type) - (~ (nilable_type fieldT))) - (:assume - (~ (without_nil g!temp fieldT (` ("ruby object get" (~ (code.text field)) - (:as (..Object .Any) (~ g!object)))))))))) - - (#Method method) - (case method - (#Static [method alias inputsT io? try? outputT]) - (..make_function (qualify (maybe.default method alias)) - g!temp - (` ("ruby object get" (~ (code.text method)) - (:as (..Object .Any) - (.exec - (~+ module_import) - ("ruby constant" (~ (code.text (%.format class "::" method)))))))) - inputsT - io? - try? - outputT) - - (#Virtual [method alias inputsT io? try? outputT]) - (let [g!inputs (input_variables inputsT)] - (` (def: ((~ (qualify (maybe.default method alias))) - [(~+ (list\map product.right g!inputs))] - (~ g!object)) - (-> [(~+ (list\map nilable_type inputsT))] - (~ g!type) - (~ (|> (nilable_type outputT) - (try_type try?) - (io_type io?)))) - (:assume - (~ (<| (with_io io?) - (with_try try?) - (without_nil g!temp outputT) - (` ("ruby object do" - (~ (code.text method)) - (~ g!object) - (~+ (list\map (with_nil g!temp) g!inputs))))))))))))) - members))))) - - (#Function [name alias inputsT io? try? outputT]) - (let [imported (` (.exec - (~+ (case ?module - (#.Some module) - (list (` ("ruby import" (~ (code.text module))))) - - #.None - (list))) - ("ruby constant" (~ (code.text name)))))] - (wrap (list (..make_function (code.local_identifier (maybe.default name alias)) - g!temp - imported - inputsT - io? - try? - outputT)))) - - (#Constant [_ name alias fieldT]) - (let [imported (` (.exec - (~+ (case ?module - (#.Some module) - (list (` ("ruby import" (~ (code.text module))))) - - #.None - (list))) - ("ruby constant" (~ (code.text name)))))] - (wrap (list (` ((~! syntax:) ((~ (code.local_identifier (maybe.default name alias)))) - (\ (~! meta.monad) (~' wrap) - (list (` (.:as (~ (nilable_type fieldT)) (~ imported)))))))))) - ))) diff --git a/stdlib/source/lux/ffi.scm.lux b/stdlib/source/lux/ffi.scm.lux deleted file mode 100644 index c6c447b72..000000000 --- a/stdlib/source/lux/ffi.scm.lux +++ /dev/null @@ -1,219 +0,0 @@ -(.module: - [lux (#- Alias) - ["@" target] - ["." meta] - [abstract - [monad (#+ do)]] - [control - ["." io] - ["<>" parser ("#\." monad) - ["<.>" code (#+ Parser)]]] - [data - ["." product] - ["." maybe] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [type - abstract] - [macro (#+ with_gensyms) - [syntax (#+ syntax:)] - ["." code] - ["." template]]]) - -(abstract: #export (Object brand) Any) - -(template [<name>] - [(with_expansions [<brand> (template.identifier [<name> "'"])] - (abstract: #export <brand> Any) - (type: #export <name> - (..Object <brand>)))] - - [Nil] - [Function] - ) - -(template [<name> <type>] - [(type: #export <name> - <type>)] - - [Boolean Bit] - [Integer Int] - [Float Frac] - [String Text] - ) - -(type: Nilable - [Bit Code]) - -(def: nilable - (Parser Nilable) - (let [token (' #?)] - (<| (<>.and (<>.parses? (<code>.this! token))) - (<>.after (<>.not (<code>.this! token))) - <code>.any))) - -(type: Alias - Text) - -(def: alias - (Parser Alias) - (<>.after (<code>.this! (' #as)) <code>.local_identifier)) - -(type: Field - [Bit Text (Maybe Alias) Nilable]) - -(def: static! - (Parser Any) - (<code>.this! (' #static))) - -(def: field - (Parser Field) - (<code>.form ($_ <>.and - (<>.parses? ..static!) - <code>.local_identifier - (<>.maybe ..alias) - ..nilable))) - -(def: constant - (Parser Field) - (<code>.form ($_ <>.and - (<>\wrap true) - <code>.local_identifier - (<>.maybe ..alias) - ..nilable))) - -(type: Common_Method - {#name Text - #alias (Maybe Alias) - #inputs (List Nilable) - #io? Bit - #try? Bit - #output Nilable}) - -(def: common_method - (Parser Common_Method) - ($_ <>.and - <code>.local_identifier - (<>.maybe ..alias) - (<code>.tuple (<>.some ..nilable)) - (<>.parses? (<code>.this! (' #io))) - (<>.parses? (<code>.this! (' #try))) - ..nilable)) - -(def: input_variables - (-> (List Nilable) (List [Bit Code])) - (|>> list.enumeration - (list\map (function (_ [idx [nilable? type]]) - [nilable? (|> idx %.nat code.local_identifier)])))) - -(def: (nilable_type [nilable? type]) - (-> Nilable Code) - (if nilable? - (` (.Maybe (~ type))) - type)) - -(def: (with_nil g!temp [nilable? input]) - (-> Code [Bit Code] Code) - (if nilable? - (` (case (~ input) - (#.Some (~ g!temp)) - (~ g!temp) - - #.Nil - ("scheme object nil"))) - input)) - -(def: (without_nil g!temp [nilable? outputT] output) - (-> Code Nilable Code Code) - (if nilable? - (` (let [(~ g!temp) (~ output)] - (if ("scheme object nil?" (~ g!temp)) - #.None - (#.Some (~ g!temp))))) - (` (let [(~ g!temp) (~ output)] - (if (not ("scheme object nil?" (~ g!temp))) - (~ g!temp) - (.error! "Nil is an invalid value!")))))) - -(type: Import - (#Function Common_Method) - (#Constant Field)) - -(def: import - (Parser Import) - ($_ <>.or - (<code>.form ..common_method) - ..constant - )) - -(syntax: #export (try expression) - {#.doc (doc (case (try (risky_computation input)) - (#.Right success) - (do_something success) - - (#.Left error) - (recover_from_failure error)))} - (wrap (list (` ("lux try" ((~! io.io) (~ expression))))))) - -(def: (with_io with? without) - (-> Bit Code Code) - (if with? - (` (io.io (~ without))) - without)) - -(def: (io_type io? rawT) - (-> Bit Code Code) - (if io? - (` (io.IO (~ rawT))) - rawT)) - -(def: (with_try with? without_try) - (-> Bit Code Code) - (if with? - (` (..try (~ without_try))) - without_try)) - -(def: (try_type try? rawT) - (-> Bit Code Code) - (if try? - (` (.Either .Text (~ rawT))) - rawT)) - -(def: (make_function g!method g!temp source inputsT io? try? outputT) - (-> Code Code Code (List Nilable) Bit Bit Nilable Code) - (let [g!inputs (input_variables inputsT)] - (` (def: ((~ g!method) - [(~+ (list\map product.right g!inputs))]) - (-> [(~+ (list\map nilable_type inputsT))] - (~ (|> (nilable_type outputT) - (try_type try?) - (io_type io?)))) - (:assume - (~ (<| (with_io io?) - (with_try try?) - (without_nil g!temp outputT) - (` ("scheme apply" - (:as ..Function (~ source)) - (~+ (list\map (with_nil g!temp) g!inputs))))))))))) - -(syntax: #export (import: {import ..import}) - (with_gensyms [g!temp] - (case import - (#Function [name alias inputsT io? try? outputT]) - (let [imported (` ("scheme constant" (~ (code.text name))))] - (wrap (list (..make_function (code.local_identifier (maybe.default name alias)) - g!temp - imported - inputsT - io? - try? - outputT)))) - - (#Constant [_ name alias fieldT]) - (let [imported (` ("scheme constant" (~ (code.text name))))] - (wrap (list (` ((~! syntax:) ((~ (code.local_identifier (maybe.default name alias)))) - (\ (~! meta.monad) (~' wrap) - (list (` (.:as (~ (nilable_type fieldT)) (~ imported)))))))))) - ))) diff --git a/stdlib/source/lux/locale.lux b/stdlib/source/lux/locale.lux deleted file mode 100644 index 38b11fd6b..000000000 --- a/stdlib/source/lux/locale.lux +++ /dev/null @@ -1,44 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - ["." hash (#+ Hash)]] - [data - ["." maybe ("#\." functor)] - ["." text - ["%" format (#+ format)] - ["." encoding (#+ Encoding)]]] - [type - abstract]] - [/ - ["." language (#+ Language)] - ["." territory (#+ Territory)]]) - -(abstract: #export Locale - Text - - (def: territory_separator "_") - (def: encoding_separator ".") - - (def: #export (locale language territory encoding) - (-> Language (Maybe Territory) (Maybe Encoding) Locale) - (:abstraction (format (language.code language) - (|> territory - (maybe\map (|>> territory.long_code (format ..territory_separator))) - (maybe.default "")) - (|> encoding - (maybe\map (|>> encoding.name (format ..encoding_separator))) - (maybe.default ""))))) - - (def: #export code - (-> Locale Text) - (|>> :representation)) - - (def: #export hash - (Hash Locale) - (\ hash.functor map ..code text.hash)) - - (def: #export equivalence - (Equivalence Locale) - (\ ..hash &equivalence)) - ) diff --git a/stdlib/source/lux/locale/language.lux b/stdlib/source/lux/locale/language.lux deleted file mode 100644 index 7dd4b22e0..000000000 --- a/stdlib/source/lux/locale/language.lux +++ /dev/null @@ -1,572 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)]] - [data - ["." text]] - [type - abstract] - [macro - ["." template]]]) - -## https://en.wikipedia.org/wiki/List_of_ISO_639-2_codes -(abstract: #export Language - {#name Text - #code Text} - - (template [<name> <tag>] - [(def: #export <name> - (-> Language Text) - (|>> :representation (get@ <tag>)))] - - [name #name] - [code #code] - ) - - (template [<bundle>] - [(with_expansions [<bundle>' (template.splice <bundle>)] - (template [<code> <name> <definition> <alias>+] - [(def: #export <definition> - Language - (:abstraction {#name <name> - #code <code>})) - (`` (template [<alias>] - [(def: #export <alias> - Language - <definition>)] - - (~~ (template.splice <alias>+))))] - - <bundle>' - ))] - - [[["mis" "uncoded languages" uncoded []] - ["mul" "multiple languages" multiple []] - ["und" "undetermined" undetermined []] - ["zxx" "no linguistic content; not applicable" not_applicable []]]] - - [[["aar" "Afar" afar []] - ["abk" "Abkhazian" abkhazian []] - ["ace" "Achinese" achinese []] - ["ach" "Acoli" acoli []] - ["ada" "Adangme" adangme []] - ["ady" "Adyghe; Adygei" adyghe []] - ["afa" "Afro-Asiatic languages" afro_asiatic []] - ["afh" "Afrihili" afrihili []] - ["afr" "Afrikaans" afrikaans []] - ["ain" "Ainu" ainu []] - ["aka" "Akan" akan []] - ["akk" "Akkadian" akkadian []] - ["ale" "Aleut" aleut []] - ["alg" "Algonquian languages" algonquian []] - ["alt" "Southern Altai" southern_altai []] - ["amh" "Amharic" amharic []] - ["ang" "Old English (ca.450–1100)" old_english []] - ["anp" "Angika" angika []] - ["apa" "Apache languages" apache []] - ["ara" "Arabic" arabic []] - ["arc" "Official Aramaic (700–300 BCE); Imperial Aramaic (700–300 BCE)" official_aramaic [[imperial_aramaic]]] - ["arg" "Aragonese" aragonese []] - ["arn" "Mapudungun; Mapuche" mapudungun []] - ["arp" "Arapaho" arapaho []] - ["art" "Artificial languages" artificial []] - ["arw" "Arawak" arawak []] - ["asm" "Assamese" assamese []] - ["ast" "Asturian; Bable; Leonese; Asturleonese" asturian [[bable] [leonese] [asturleonese]]] - ["ath" "Athapascan languages" athapascan []] - ["aus" "Australian languages" australian []] - ["ava" "Avaric" avaric []] - ["ave" "Avestan" avestan []] - ["awa" "Awadhi" awadhi []] - ["aym" "Aymara" aymara []] - ["aze" "Azerbaijani" azerbaijani []]]] - - [[["bad" "Banda languages" banda []] - ["bai" "Bamileke languages" bamileke []] - ["bak" "Bashkir" bashkir []] - ["bal" "Baluchi" baluchi []] - ["bam" "Bambara" bambara []] - ["ban" "Balinese" balinese []] - ["bas" "Basa" basa []] - ["bat" "Baltic languages" baltic []] - ["bej" "Beja; Bedawiyet" beja []] - ["bel" "Belarusian" belarusian []] - ["bem" "Bemba" bemba []] - ["ben" "Bengali" bengali []] - ["ber" "Berber languages" berber []] - ["bho" "Bhojpuri" bhojpuri []] - ["bih" "Bihari languages" bihari []] - ["bik" "Bikol" bikol []] - ["bin" "Bini; Edo" bini [[edo]]] - ["bis" "Bislama" bislama []] - ["bla" "Siksika" siksika []] - ["bnt" "Bantu languages" bantu []] - ["bod" "Tibetan" tibetan []] - ["bos" "Bosnian" bosnian []] - ["bra" "Braj" braj []] - ["bre" "Breton" breton []] - ["btk" "Batak languages" batak []] - ["bua" "Buriat" buriat []] - ["bug" "Buginese" buginese []] - ["bul" "Bulgarian" bulgarian []] - ["byn" "Blin; Bilin" blin [[bilin]]]]] - - [[["cad" "Caddo" caddo []] - ["cai" "Central American Indian languages" central_american_indian []] - ["car" "Galibi Carib" galibi_carib []] - ["cat" "Catalan; Valencian" catalan [[valencian]]] - ["cau" "Caucasian languages" caucasian []] - ["ceb" "Cebuano" cebuano []] - ["cel" "Celtic languages" celtic []] - ["ces" "Czech" czech []] - ["cha" "Chamorro" chamorro []] - ["chb" "Chibcha" chibcha []] - ["che" "Chechen" chechen []] - ["chg" "Chagatai" chagatai []] - ["chk" "Chuukese" chuukese []] - ["chm" "Mari" mari []] - ["chn" "Chinook jargon" chinook []] - ["cho" "Choctaw" choctaw []] - ["chp" "Chipewyan; Dene Suline" chipewyan []] - ["chr" "Cherokee" cherokee []] - ["chu" "Church Slavic; Old Slavonic; Church Slavonic; Old Bulgarian; Old Church Slavonic" church_slavic [[old_slavonic] [church_slavonic] [old_bulgarian] [old_church_slavonic]]] - ["chv" "Chuvash" chuvash []] - ["chy" "Cheyenne" cheyenne []] - ["cmc" "Chamic languages" chamic []] - ["cnr" "Montenegrin" montenegrin []] - ["cop" "Coptic" coptic []] - ["cor" "Cornish" cornish []] - ["cos" "Corsican" corsican []] - ["cpe" "Creoles and pidgins, English based" creoles_and_pidgins/english []] - ["cpf" "Creoles and pidgins, French-based" creoles_and_pidgins/french []] - ["cpp" "Creoles and pidgins, Portuguese-based" creoles_and_pidgins/portuguese []] - ["cre" "Cree" cree []] - ["crh" "Crimean Tatar; Crimean Turkish" crimean []] - ["crp" "Creoles and pidgins" creoles_and_pidgins []] - ["csb" "Kashubian" kashubian []] - ["cus" "Cushitic languages" cushitic []] - ["cym" "Welsh" welsh []]]] - - [[["dak" "Dakota" dakota []] - ["dan" "Danish" danish []] - ["dar" "Dargwa" dargwa []] - ["day" "Land Dayak languages" land_dayak []] - ["del" "Delaware" delaware []] - ["den" "Slave (Athapascan)" slavey []] - ["deu" "German" german []] - ["dgr" "Dogrib" dogrib []] - ["din" "Dinka" dinka []] - ["div" "Divehi; Dhivehi; Maldivian" dhivehi [[maldivian]]] - ["doi" "Dogri" dogri []] - ["dra" "Dravidian languages" dravidian []] - ["dsb" "Lower Sorbian" lower_sorbian []] - ["dua" "Duala" duala []] - ["dum" "Middle Dutch (ca. 1050–1350)" middle_dutch []] - ["dyu" "Dyula" dyula []] - ["dzo" "Dzongkha" dzongkha []]]] - - [[["efi" "Efik" efik []] - ["egy" "Ancient Egyptian" egyptian []] - ["eka" "Ekajuk" ekajuk []] - ["ell" "Modern Greek (1453–)" greek []] - ["elx" "Elamite" elamite []] - ["eng" "English" english []] - ["enm" "Middle English (1100–1500)" middle_english []] - ["epo" "Esperanto" esperanto []] - ["est" "Estonian" estonian []] - ["eus" "Basque" basque []] - ["ewe" "Ewe" ewe []] - ["ewo" "Ewondo" ewondo []]]] - - [[["fan" "Fang" fang []] - ["fao" "Faroese" faroese []] - ["fas" "Persian" persian []] - ["fat" "Fanti" fanti []] - ["fij" "Fijian" fijian []] - ["fil" "Filipino; Pilipino" filipino []] - ["fin" "Finnish" finnish []] - ["fiu" "Finno-Ugrian languages" finno_ugrian []] - ["fon" "Fon" fon []] - ["fra" "French" french []] - ["frm" "Middle French (ca. 1400–1600)" middle_french []] - ["fro" "Old French (ca. 842–1400)" old_french []] - ["frr" "Northern Frisian" northern_frisian []] - ["frs" "Eastern Frisian" eastern_frisian []] - ["fry" "Western Frisian" western_frisian []] - ["ful" "Fulah" fulah []] - ["fur" "Friulian" friulian []]]] - - [[["gaa" "Ga" ga []] - ["gay" "Gayo" gayo []] - ["gba" "Gbaya" gbaya []] - ["gem" "Germanic languages" germanic []] - ["gez" "Geez" geez []] - ["gil" "Gilbertese" gilbertese []] - ["gla" "Gaelic; Scottish Gaelic" gaelic []] - ["gle" "Irish" irish []] - ["glg" "Galician" galician []] - ["glv" "Manx" manx []] - ["gmh" "Middle High German (ca. 1050–1500)" middle_high_german []] - ["goh" "Old High German (ca. 750–1050)" old_high_german []] - ["gon" "Gondi" gondi []] - ["gor" "Gorontalo" gorontalo []] - ["got" "Gothic" gothic []] - ["grb" "Grebo" grebo []] - ["grc" "Ancient Greek (to 1453)" ancient_greek []] - ["grn" "Guarani" guarani []] - ["gsw" "Swiss German; Alemannic; Alsatian" swiss_german [[alemannic] [alsatian]]] - ["guj" "Gujarati" gujarati []] - ["gwi" "Gwich'in" gwich'in []]]] - - [[["hai" "Haida" haida []] - ["hat" "Haitian; Haitian Creole" haitian []] - ["hau" "Hausa" hausa []] - ["haw" "Hawaiian" hawaiian []] - ["heb" "Hebrew" hebrew []] - ["her" "Herero" herero []] - ["hil" "Hiligaynon" hiligaynon []] - ["him" "Himachali languages; Pahari languages" himachali []] - ["hin" "Hindi" hindi []] - ["hit" "Hittite" hittite []] - ["hmn" "Hmong; Mong" hmong []] - ["hmo" "Hiri Motu" hiri_motu []] - ["hrv" "Croatian" croatian []] - ["hsb" "Upper Sorbian" upper_sorbian []] - ["hun" "Hungarian" hungarian []] - ["hup" "Hupa" hupa []] - ["hye" "Armenian" armenian []]]] - - [[["iba" "Iban" iban []] - ["ibo" "Igbo" igbo []] - ["ido" "Ido" ido []] - ["iii" "Sichuan Yi; Nuosu" sichuan_yi [[nuosu]]] - ["ijo" "Ijo languages" ijo []] - ["iku" "Inuktitut" inuktitut []] - ["ile" "Interlingue; Occidental" interlingue []] - ["ilo" "Iloko" iloko []] - ["ina" "Interlingua (International Auxiliary Language Association)" interlingua []] - ["inc" "Indic languages" indic []] - ["ind" "Indonesian" indonesian []] - ["ine" "Indo-European languages" indo_european []] - ["inh" "Ingush" ingush []] - ["ipk" "Inupiaq" inupiaq []] - ["ira" "Iranian languages" iranian []] - ["iro" "Iroquoian languages" iroquoian []] - ["isl" "Icelandic" icelandic []] - ["ita" "Italian" italian []]]] - - [[["jav" "Javanese" javanese []] - ["jbo" "Lojban" lojban []] - ["jpn" "Japanese" japanese []] - ["jpr" "Judeo-Persian" judeo_persian []] - ["jrb" "Judeo-Arabic" judeo_arabic []]]] - - [[["kaa" "Kara-Kalpak" kara_kalpak []] - ["kab" "Kabyle" kabyle []] - ["kac" "Kachin; Jingpho" kachin [[jingpho]]] - ["kal" "Kalaallisut; Greenlandic" kalaallisut [[greenlandic]]] - ["kam" "Kamba" kamba []] - ["kan" "Kannada" kannada []] - ["kar" "Karen languages" karen []] - ["kas" "Kashmiri" kashmiri []] - ["kat" "Georgian" georgian []] - ["kau" "Kanuri" kanuri []] - ["kaw" "Kawi" kawi []] - ["kaz" "Kazakh" kazakh []] - ["kbd" "Kabardian" kabardian []] - ["kha" "Khasi" khasi []] - ["khi" "Khoisan languages" khoisan []] - ["khm" "Central Khmer" central_khmer []] - ["kho" "Khotanese; Sakan" khotanese [[sakan]]] - ["kik" "Kikuyu; Gikuyu" gikuyu []] - ["kin" "Kinyarwanda" kinyarwanda []] - ["kir" "Kirghiz; Kyrgyz" kyrgyz []] - ["kmb" "Kimbundu" kimbundu []] - ["kok" "Konkani" konkani []] - ["kom" "Komi" komi []] - ["kon" "Kongo" kongo []] - ["kor" "Korean" korean []] - ["kos" "Kosraean" kosraean []] - ["kpe" "Kpelle" kpelle []] - ["krc" "Karachay-Balkar" karachay_balkar []] - ["krl" "Karelian" karelian []] - ["kro" "Kru languages" kru []] - ["kru" "Kurukh" kurukh []] - ["kua" "Kuanyama; Kwanyama" kwanyama []] - ["kum" "Kumyk" kumyk []] - ["kur" "Kurdish" kurdish []] - ["kut" "Kutenai" kutenai []]]] - - [[["lad" "Ladino" ladino []] - ["lah" "Lahnda" lahnda []] - ["lam" "Lamba" lamba []] - ["lao" "Lao" lao []] - ["lat" "Latin" latin []] - ["lav" "Latvian" latvian []] - ["lez" "Lezghian" lezghian []] - ["lim" "Limburgan; Limburger; Limburgish" limburgan []] - ["lin" "Lingala" lingala []] - ["lit" "Lithuanian" lithuanian []] - ["lol" "Mongo" mongo []] - ["loz" "Lozi" lozi []] - ["ltz" "Luxembourgish; Letzeburgesch" luxembourgish []] - ["lua" "Luba-Lulua" luba_lulua []] - ["lub" "Luba-Katanga" luba_katanga []] - ["lug" "Ganda" ganda []] - ["lui" "Luiseno" luiseno []] - ["lun" "Lunda" lunda []] - ["luo" "Luo (Kenya and Tanzania)" luo []] - ["lus" "Lushai" lushai []]]] - - [[["mad" "Madurese" madurese []] - ["mag" "Magahi" magahi []] - ["mah" "Marshallese" marshallese []] - ["mai" "Maithili" maithili []] - ["mak" "Makasar" makasar []] - ["mal" "Malayalam" malayalam []] - ["man" "Mandingo" mandingo []] - ["map" "Austronesian languages" austronesian []] - ["mar" "Marathi" marathi []] - ["mas" "Masai" masai []] - ["mdf" "Moksha" moksha []] - ["mdr" "Mandar" mandar []] - ["men" "Mende" mende []] - ["mga" "Middle Irish (900–1200)" middle_irish []] - ["mic" "Mi'kmaq; Micmac" mi'kmaq [[micmac]]] - ["min" "Minangkabau" minangkabau []] - ["mkd" "Macedonian" macedonian []] - ["mkh" "Mon-Khmer languages" mon_khmer []] - ["mlg" "Malagasy" malagasy []] - ["mlt" "Maltese" maltese []] - ["mnc" "Manchu" manchu []] - ["mni" "Manipuri" manipuri []] - ["mno" "Manobo languages" manobo []] - ["moh" "Mohawk" mohawk []] - ["mon" "Mongolian" mongolian []] - ["mos" "Mossi" mossi []] - ["mri" "Maori" maori []] - ["msa" "Malay" malay []] - ["mun" "Munda languages" munda []] - ["mus" "Creek" creek []] - ["mwl" "Mirandese" mirandese []] - ["mwr" "Marwari" marwari []] - ["mya" "Burmese" burmese []] - ["myn" "Mayan languages" mayan []] - ["myv" "Erzya" erzya []]]] - - [[["nah" "Nahuatl languages" nahuatl []] - ["nai" "North American Indian languages" north_american_indian []] - ["nap" "Neapolitan" neapolitan []] - ["nau" "Nauru" nauru []] - ["nav" "Navajo; Navaho" navajo []] - ["nbl" "South Ndebele" south_ndebele []] - ["nde" "North Ndebele" north_ndebele []] - ["ndo" "Ndonga" ndonga []] - ["nds" "Low German; Low Saxon" low_german []] - ["nep" "Nepali" nepali []] - ["new" "Nepal Bhasa; Newari" newari [[nepal_bhasa]]] - ["nia" "Nias" nias []] - ["nic" "Niger-Kordofanian languages" niger_kordofanian []] - ["niu" "Niuean" niuean []] - ["nld" "Dutch; Flemish" dutch [[flemish]]] - ["nno" "Norwegian Nynorsk" nynorsk []] - ["nob" "Norwegian Bokmål" bokmal []] - ["nog" "Nogai" nogai []] - ["non" "Old Norse" old_norse []] - ["nor" "Norwegian" norwegian []] - ["nqo" "N'Ko" n'ko []] - ["nso" "Pedi; Sepedi; Northern Sotho" northern_sotho [[pedi] [sepedi]]] - ["nub" "Nubian languages" nubian []] - ["nwc" "Classical Newari; Old Newari; Classical Nepal Bhasa" old_newari [[classical_newari] [classical_nepal_bhasa]]] - ["nya" "Chichewa; Chewa; Nyanja" nyanja [[chichewa] [chewa]]] - ["nym" "Nyamwezi" nyamwezi []] - ["nyn" "Nyankole" nyankole []] - ["nyo" "Nyoro" nyoro []] - ["nzi" "Nzima" nzima []]]] - - [[["oci" "Occitan (post 1500); Provençal" occitan [[provencal]]] - ["oji" "Ojibwa" ojibwa []] - ["ori" "Oriya" oriya []] - ["orm" "Oromo" oromo []] - ["osa" "Osage" osage []] - ["oss" "Ossetian; Ossetic" ossetic []] - ["ota" "Ottoman Turkish (1500–1928)" ottoman_turkish []] - ["oto" "Otomian languages" otomian []]]] - - [[["paa" "Papuan languages" papuan []] - ["pag" "Pangasinan" pangasinan []] - ["pal" "Pahlavi" pahlavi []] - ["pam" "Pampanga; Kapampangan" pampanga [[kapampangan]]] - ["pan" "Panjabi; Punjabi" punjabi []] - ["pap" "Papiamento" papiamento []] - ["pau" "Palauan" palauan []] - ["peo" "Old Persian (ca. 600–400 B.C.)" old_persian []] - ["phi" "Philippine languages" philippine []] - ["phn" "Phoenician" phoenician []] - ["pli" "Pali" pali []] - ["pol" "Polish" polish []] - ["pon" "Pohnpeian" pohnpeian []] - ["por" "Portuguese" portuguese []] - ["pra" "Prakrit languages" prakrit []] - ["pro" "Old Provençal (to 1500); Old Occitan (to 1500)" old_provencal []] - ["pus" "Pushto; Pashto" pashto []]]] - - [[["que" "Quechua" quechua []]]] - - [[["raj" "Rajasthani" rajasthani []] - ["rap" "Rapanui" rapanui []] - ["rar" "Rarotongan; Cook Islands Maori" rarotongan [[cook_islands_maori]]] - ["roa" "Romance languages" romance []] - ["roh" "Romansh" romansh []] - ["rom" "Romany" romany []] - ["ron" "Romanian; Moldavian; Moldovan" romanian [[moldavian] [moldovan]]] - ["run" "Rundi" rundi []] - ["rup" "Aromanian; Arumanian; Macedo-Romanian" aromanian [[arumanian] [macedo_romanian]]] - ["rus" "Russian" russian []]]] - - [[["sad" "Sandawe" sandawe []] - ["sag" "Sango" sango []] - ["sah" "Yakut" yakut []] - ["sai" "South American Indian (Other)" south_american_indian []] - ["sal" "Salishan languages" salishan []] - ["sam" "Samaritan Aramaic" samaritan_aramaic []] - ["san" "Sanskrit" sanskrit []] - ["sas" "Sasak" sasak []] - ["sat" "Santali" santali []] - ["scn" "Sicilian" sicilian []] - ["sco" "Scots" scots []] - ["sel" "Selkup" selkup []] - ["sem" "Semitic languages" semitic []] - ["sga" "Old Irish (to 900)" old_irish []] - ["sgn" "Sign Languages" sign []] - ["shn" "Shan" shan []] - ["sid" "Sidamo" sidamo []] - ["sin" "Sinhala; Sinhalese" sinhalese []] - ["sio" "Siouan languages" siouan []] - ["sit" "Sino-Tibetan languages" sino_tibetan []] - ["sla" "Slavic languages" slavic []] - ["slk" "Slovak" slovak []] - ["slv" "Slovenian" slovenian []] - ["sma" "Southern Sami" southern_sami []] - ["sme" "Northern Sami" northern_sami []] - ["smi" "Sami languages" sami []] - ["smj" "Lule Sami" lule []] - ["smn" "Inari Sami" inari []] - ["smo" "Samoan" samoan []] - ["sms" "Skolt Sami" skolt_sami []] - ["sna" "Shona" shona []] - ["snd" "Sindhi" sindhi []] - ["snk" "Soninke" soninke []] - ["sog" "Sogdian" sogdian []] - ["som" "Somali" somali []] - ["son" "Songhai languages" songhai []] - ["sot" "Southern Sotho" southern_sotho []] - ["spa" "Spanish; Castilian" spanish [[castilian]]] - ["sqi" "Albanian" albanian []] - ["srd" "Sardinian" sardinian []] - ["srn" "Sranan Tongo" sranan_tongo []] - ["srp" "Serbian" serbian []] - ["srr" "Serer" serer []] - ["ssa" "Nilo-Saharan languages" nilo_saharan []] - ["ssw" "Swati" swati []] - ["suk" "Sukuma" sukuma []] - ["sun" "Sundanese" sundanese []] - ["sus" "Susu" susu []] - ["sux" "Sumerian" sumerian []] - ["swa" "Swahili" swahili []] - ["swe" "Swedish" swedish []] - ["syc" "Classical Syriac" classical_syriac []] - ["syr" "Syriac" syriac []]]] - - [[["tah" "Tahitian" tahitian []] - ["tai" "Tai languages" tai []] - ["tam" "Tamil" tamil []] - ["tat" "Tatar" tatar []] - ["tel" "Telugu" telugu []] - ["tem" "Timne" timne []] - ["ter" "Tereno" tereno []] - ["tet" "Tetum" tetum []] - ["tgk" "Tajik" tajik []] - ["tgl" "Tagalog" tagalog []] - ["tha" "Thai" thai []] - ["tig" "Tigre" tigre []] - ["tir" "Tigrinya" tigrinya []] - ["tiv" "Tiv" tiv []] - ["tkl" "Tokelau" tokelau []] - ["tlh" "Klingon; tlhIngan-Hol" klingon []] - ["tli" "Tlingit" tlingit []] - ["tmh" "Tamashek" tamashek []] - ["tog" "Tonga (Nyasa)" tonga []] - ["ton" "Tonga (Tonga Islands)" tongan []] - ["tpi" "Tok Pisin" tok_pisin []] - ["tsi" "Tsimshian" tsimshian []] - ["tsn" "Tswana" tswana []] - ["tso" "Tsonga" tsonga []] - ["tuk" "Turkmen" turkmen []] - ["tum" "Tumbuka" tumbuka []] - ["tup" "Tupi languages" tupi []] - ["tur" "Turkish" turkish []] - ["tut" "Altaic languages" altaic []] - ["tvl" "Tuvalu" tuvalu []] - ["twi" "Twi" twi []] - ["tyv" "Tuvinian" tuvinian []]]] - - [[["udm" "Udmurt" udmurt []] - ["uga" "Ugaritic" ugaritic []] - ["uig" "Uighur; Uyghur" uyghur []] - ["ukr" "Ukrainian" ukrainian []] - ["umb" "Umbundu" umbundu []] - ["urd" "Urdu" urdu []] - ["uzb" "Uzbek" uzbek []]]] - - [[["vai" "Vai" vai []] - ["ven" "Venda" venda []] - ["vie" "Vietnamese" vietnamese []] - ["vol" "Volapük" volapük []] - ["vot" "Votic" votic []]]] - - [[["wak" "Wakashan languages" wakashan []] - ["wal" "Wolaitta; Wolaytta" walamo []] - ["war" "Waray" waray []] - ["was" "Washo" washo []] - ["wen" "Sorbian languages" sorbian []] - ["wln" "Walloon" walloon []] - ["wol" "Wolof" wolof []]]] - - [[["xal" "Kalmyk; Oirat" kalmyk [[oirat]]] - ["xho" "Xhosa" xhosa []]]] - - [[["yao" "Yao" yao []] - ["yap" "Yapese" yapese []] - ["yid" "Yiddish" yiddish []] - ["yor" "Yoruba" yoruba []] - ["ypk" "Yupik languages" yupik []]]] - - [[["zap" "Zapotec" zapotec []] - ["zbl" "Blissymbols; Blissymbolics; Bliss" blissymbols []] - ["zen" "Zenaga" zenaga []] - ["zgh" "Standard Moroccan Tamazight" standard_moroccan_tamazight []] - ["zha" "Zhuang; Chuang" zhuang []] - ["zho" "Chinese" chinese []] - ["znd" "Zande languages" zande []] - ["zul" "Zulu" zulu []] - ["zun" "Zuni" zuni []] - ["zza" "Zaza; Dimili; Dimli; Kirdki; Kirmanjki; Zazaki" zaza [[dimili] [dimli] [kirdki] [kirmanjki] [zazaki]]]]]) - - (implementation: #export equivalence - (Equivalence Language) - - (def: (= reference sample) - (is? reference sample))) - - (implementation: #export hash - (Hash Language) - - (def: &equivalence - ..equivalence) - - (def: hash - (|>> ..code - (\ text.hash hash)))) - ) diff --git a/stdlib/source/lux/locale/territory.lux b/stdlib/source/lux/locale/territory.lux deleted file mode 100644 index dfb20896c..000000000 --- a/stdlib/source/lux/locale/territory.lux +++ /dev/null @@ -1,311 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)]] - [data - ["." text]] - [type - abstract] - [macro - ["." template]]]) - -## https://en.wikipedia.org/wiki/ISO_3166-1 -(abstract: #export Territory - {#name Text - #short Text - #long Text - #code Nat} - - (template [<name> <field> <type>] - [(def: #export <name> - (-> Territory <type>) - (|>> :representation - (get@ <field>)))] - - [name #name Text] - [short_code #short Text] - [long_code #long Text] - [numeric_code #code Nat] - ) - - (template [<short> <long> <number> <name> <main> <neighbor>+] - [(def: #export <main> - Territory - (:abstraction {#name <name> - #short <short> - #long <long> - #code <number>})) - - (`` (template [<neighbor>] - [(def: #export <neighbor> Territory <main>)] - - (~~ (template.splice <neighbor>+))))] - - ["AF" "AFG" 004 "Afghanistan" afghanistan []] - ["AX" "ALA" 248 "Åland Islands" aland_islands []] - ["AL" "ALB" 008 "Albania" albania []] - ["DZ" "DZA" 012 "Algeria" algeria []] - ["AS" "ASM" 016 "American Samoa" american_samoa []] - ["AD" "AND" 020 "Andorra" andorra []] - ["AO" "AGO" 024 "Angola" angola []] - ["AI" "AIA" 660 "Anguilla" anguilla []] - ["AQ" "ATA" 010 "Antarctica" antarctica []] - ["AG" "ATG" 028 "Antigua and Barbuda" antigua [[barbuda]]] - ["AR" "ARG" 032 "Argentina" argentina []] - ["AM" "ARM" 051 "Armenia" armenia []] - ["AW" "ABW" 533 "Aruba" aruba []] - ["AU" "AUS" 036 "Australia" australia []] - ["AT" "AUT" 040 "Austria" austria []] - ["AZ" "AZE" 031 "Azerbaijan" azerbaijan []] - ["BS" "BHS" 044 "The Bahamas" the_bahamas []] - ["BH" "BHR" 048 "Bahrain" bahrain []] - ["BD" "BGD" 050 "Bangladesh" bangladesh []] - ["BB" "BRB" 052 "Barbados" barbados []] - ["BY" "BLR" 112 "Belarus" belarus []] - ["BE" "BEL" 056 "Belgium" belgium []] - ["BZ" "BLZ" 084 "Belize" belize []] - ["BJ" "BEN" 204 "Benin" benin []] - ["BM" "BMU" 060 "Bermuda" bermuda []] - ["BT" "BTN" 064 "Bhutan" bhutan []] - ["BO" "BOL" 068 "Bolivia" bolivia []] - ["BQ" "BES" 535 "Bonaire, Sint Eustatius and Saba" bonaire [[sint_eustatius] [saba]]] - ["BA" "BIH" 070 "Bosnia and Herzegovina" bosnia [[herzegovina]]] - ["BW" "BWA" 072 "Botswana" botswana []] - ["BV" "BVT" 074 "Bouvet Island" bouvet_island []] - ["BR" "BRA" 076 "Brazil" brazil []] - ["IO" "IOT" 086 "British Indian Ocean Territory" british_indian_ocean_territory []] - ["BN" "BRN" 096 "Brunei Darussalam" brunei_darussalam []] - ["BG" "BGR" 100 "Bulgaria" bulgaria []] - ["BF" "BFA" 854 "Burkina Faso" burkina_faso []] - ["BI" "BDI" 108 "Burundi" burundi []] - ["CV" "CPV" 132 "Cape Verde" cape_verde []] - ["KH" "KHM" 116 "Cambodia" cambodia []] - ["CM" "CMR" 120 "Cameroon" cameroon []] - ["CA" "CAN" 124 "Canada" canada []] - ["KY" "CYM" 136 "Cayman Islands" cayman_islands []] - ["CF" "CAF" 140 "Central African Republic" central_african_republic []] - ["TD" "TCD" 148 "Chad" chad []] - ["CL" "CHL" 152 "Chile" chile []] - ["CN" "CHN" 156 "China" china []] - ["CX" "CXR" 162 "Christmas Island" christmas_island []] - ["CC" "CCK" 166 "Cocos (Keeling) Islands" cocos_islands []] - ["CO" "COL" 170 "Colombia" colombia []] - ["KM" "COM" 174 "Comoros" comoros []] - ["CG" "COG" 178 "Congo" congo []] - ["CD" "COD" 180 "Democratic Republic of the Congo" democratic_republic_of_the_congo []] - ["CK" "COK" 184 "Cook Islands" cook_islands []] - ["CR" "CRI" 188 "Costa Rica" costa_rica []] - ["CI" "CIV" 384 "Ivory Coast" ivory_coast []] - ["HR" "HRV" 191 "Croatia" croatia []] - ["CU" "CUB" 192 "Cuba" cuba []] - ["CW" "CUW" 531 "Curacao" curacao []] - ["CY" "CYP" 196 "Cyprus" cyprus []] - ["CZ" "CZE" 203 "Czech Republic" czech_republic []] - ["DK" "DNK" 208 "Denmark" denmark []] - ["DJ" "DJI" 262 "Djibouti" djibouti []] - ["DM" "DMA" 212 "Dominica" dominica []] - ["DO" "DOM" 214 "Dominican Republic" dominican_republic []] - ["EC" "ECU" 218 "Ecuador" ecuador []] - ["EG" "EGY" 818 "Egypt" egypt []] - ["SV" "SLV" 222 "El Salvador" el_salvador []] - ["GQ" "GNQ" 226 "Equatorial Guinea" equatorial_guinea []] - ["ER" "ERI" 232 "Eritrea" eritrea []] - ["EE" "EST" 233 "Estonia" estonia []] - ["SZ" "SWZ" 748 "Eswatini" eswatini []] - ["ET" "ETH" 231 "Ethiopia" ethiopia []] - ["FK" "FLK" 238 "Falkland Islands" falkland_islands []] - ["FO" "FRO" 234 "Faroe Islands" faroe_islands []] - ["FJ" "FJI" 242 "Fiji" fiji []] - ["FI" "FIN" 246 "Finland" finland []] - ["FR" "FRA" 250 "France" france []] - ["GF" "GUF" 254 "French Guiana" french_guiana []] - ["PF" "PYF" 258 "French Polynesia" french_polynesia []] - ["TF" "ATF" 260 "French Southern Territories" french_southern_territories []] - ["GA" "GAB" 266 "Gabon" gabon []] - ["GM" "GMB" 270 "The Gambia" the_gambia []] - ["GE" "GEO" 268 "Georgia" georgia []] - ["DE" "DEU" 276 "Germany" germany []] - ["GH" "GHA" 288 "Ghana" ghana []] - ["GI" "GIB" 292 "Gibraltar" gibraltar []] - ["GR" "GRC" 300 "Greece" greece []] - ["GL" "GRL" 304 "Greenland" greenland []] - ["GD" "GRD" 308 "Grenada" grenada []] - ["GP" "GLP" 312 "Guadeloupe" guadeloupe []] - ["GU" "GUM" 316 "Guam" guam []] - ["GT" "GTM" 320 "Guatemala" guatemala []] - ["GG" "GGY" 831 "Guernsey" guernsey []] - ["GN" "GIN" 324 "Guinea" guinea []] - ["GW" "GNB" 624 "Guinea-Bissau" guinea_bissau []] - ["GY" "GUY" 328 "Guyana" guyana []] - ["HT" "HTI" 332 "Haiti" haiti []] - ["HM" "HMD" 334 "Heard Island and McDonald Islands" heard_island [[mcdonald_islands]]] - ["VA" "VAT" 336 "Vatican City" vatican_city []] - ["HN" "HND" 340 "Honduras" honduras []] - ["HK" "HKG" 344 "Hong Kong" hong_kong []] - ["HU" "HUN" 348 "Hungary" hungary []] - ["IS" "ISL" 352 "Iceland" iceland []] - ["IN" "IND" 356 "India" india []] - ["ID" "IDN" 360 "Indonesia" indonesia []] - ["IR" "IRN" 364 "Iran" iran []] - ["IQ" "IRQ" 368 "Iraq" iraq []] - ["IE" "IRL" 372 "Ireland" ireland []] - ["IM" "IMN" 833 "Isle of Man" isle_of_man []] - ["IL" "ISR" 376 "Israel" israel []] - ["IT" "ITA" 380 "Italy" italy []] - ["JM" "JAM" 388 "Jamaica" jamaica []] - ["JP" "JPN" 392 "Japan" japan []] - ["JE" "JEY" 832 "Jersey" jersey []] - ["JO" "JOR" 400 "Jordan" jordan []] - ["KZ" "KAZ" 398 "Kazakhstan" kazakhstan []] - ["KE" "KEN" 404 "Kenya" kenya []] - ["KI" "KIR" 296 "Kiribati" kiribati []] - ["KP" "PRK" 408 "North Korea" north_korea []] - ["KR" "KOR" 410 "South Korea" south_korea []] - ["KW" "KWT" 414 "Kuwait" kuwait []] - ["KG" "KGZ" 417 "Kyrgyzstan" kyrgyzstan []] - ["LA" "LAO" 418 "Laos" laos []] - ["LV" "LVA" 428 "Latvia" latvia []] - ["LB" "LBN" 422 "Lebanon" lebanon []] - ["LS" "LSO" 426 "Lesotho" lesotho []] - ["LR" "LBR" 430 "Liberia" liberia []] - ["LY" "LBY" 434 "Libya" libya []] - ["LI" "LIE" 438 "Liechtenstein" liechtenstein []] - ["LT" "LTU" 440 "Lithuania" lithuania []] - ["LU" "LUX" 442 "Luxembourg" luxembourg []] - ["MO" "MAC" 446 "Macau" macau []] - ["MK" "MKD" 807 "Macedonia" macedonia []] - ["MG" "MDG" 450 "Madagascar" madagascar []] - ["MW" "MWI" 454 "Malawi" malawi []] - ["MY" "MYS" 458 "Malaysia" malaysia []] - ["MV" "MDV" 462 "Maldives" maldives []] - ["ML" "MLI" 466 "Mali" mali []] - ["MT" "MLT" 470 "Malta" malta []] - ["MH" "MHL" 584 "Marshall Islands" marshall_islands []] - ["MQ" "MTQ" 474 "Martinique" martinique []] - ["MR" "MRT" 478 "Mauritania" mauritania []] - ["MU" "MUS" 480 "Mauritius" mauritius []] - ["YT" "MYT" 175 "Mayotte" mayotte []] - ["MX" "MEX" 484 "Mexico" mexico []] - ["FM" "FSM" 583 "Micronesia" micronesia []] - ["MD" "MDA" 498 "Moldova" moldova []] - ["MC" "MCO" 492 "Monaco" monaco []] - ["MN" "MNG" 496 "Mongolia" mongolia []] - ["ME" "MNE" 499 "Montenegro" montenegro []] - ["MS" "MSR" 500 "Montserrat" montserrat []] - ["MA" "MAR" 504 "Morocco" morocco []] - ["MZ" "MOZ" 508 "Mozambique" mozambique []] - ["MM" "MMR" 104 "Myanmar" myanmar []] - ["NA" "NAM" 516 "Namibia" namibia []] - ["NR" "NRU" 520 "Nauru" nauru []] - ["NP" "NPL" 524 "Nepal" nepal []] - ["NL" "NLD" 528 "Netherlands" netherlands []] - ["NC" "NCL" 540 "New Caledonia" new_caledonia []] - ["NZ" "NZL" 554 "New Zealand" new_zealand []] - ["NI" "NIC" 558 "Nicaragua" nicaragua []] - ["NE" "NER" 562 "Niger" niger []] - ["NG" "NGA" 566 "Nigeria" nigeria []] - ["NU" "NIU" 570 "Niue" niue []] - ["NF" "NFK" 574 "Norfolk Island" norfolk_island []] - ["MP" "MNP" 580 "Northern Mariana Islands" northern_mariana_islands []] - ["NO" "NOR" 578 "Norway" norway []] - ["OM" "OMN" 512 "Oman" oman []] - ["PK" "PAK" 586 "Pakistan" pakistan []] - ["PW" "PLW" 585 "Palau" palau []] - ["PS" "PSE" 275 "Palestine" palestine []] - ["PA" "PAN" 591 "Panama" panama []] - ["PG" "PNG" 598 "Papua New Guinea" papua_new_guinea []] - ["PY" "PRY" 600 "Paraguay" paraguay []] - ["PE" "PER" 604 "Peru" peru []] - ["PH" "PHL" 608 "Philippines" philippines []] - ["PN" "PCN" 612 "Pitcairn Islands" pitcairn_islands []] - ["PL" "POL" 616 "Poland" poland []] - ["PT" "PRT" 620 "Portugal" portugal []] - ["PR" "PRI" 630 "Puerto Rico" puerto_rico []] - ["QA" "QAT" 634 "Qatar" qatar []] - ["RE" "REU" 638 "Reunion" reunion []] - ["RO" "ROU" 642 "Romania" romania []] - ["RU" "RUS" 643 "Russia" russia []] - ["RW" "RWA" 646 "Rwanda" rwanda []] - ["BL" "BLM" 652 "Saint Barthélemy" saint_barthelemy []] - ["SH" "SHN" 654 "Saint Helena, Ascension and Tristan da Cunha" saint_helena [[ascension] [tristan_da_cunha]]] - ["KN" "KNA" 659 "Saint Kitts and Nevis" saint_kitts [[nevis]]] - ["LC" "LCA" 662 "Saint Lucia" saint_lucia []] - ["MF" "MAF" 663 "Saint Martin" saint_martin []] - ["PM" "SPM" 666 "Saint Pierre and Miquelon" saint_pierre [[miquelon]]] - ["VC" "VCT" 670 "Saint Vincent and the Grenadines" saint_vincent [[the_grenadines]]] - ["WS" "WSM" 882 "Samoa" samoa []] - ["SM" "SMR" 674 "San Marino" san_marino []] - ["ST" "STP" 678 "Sao Tome and Principe" sao_tome [[principe]]] - ["SA" "SAU" 682 "Saudi Arabia" saudi_arabia []] - ["SN" "SEN" 686 "Senegal" senegal []] - ["RS" "SRB" 688 "Serbia" serbia []] - ["SC" "SYC" 690 "Seychelles" seychelles []] - ["SL" "SLE" 694 "Sierra Leone" sierra_leone []] - ["SG" "SGP" 702 "Singapore" singapore []] - ["SX" "SXM" 534 "Sint Maarten" sint_maarten []] - ["SK" "SVK" 703 "Slovakia" slovakia []] - ["SI" "SVN" 705 "Slovenia" slovenia []] - ["SB" "SLB" 090 "Solomon Islands" solomon_islands []] - ["SO" "SOM" 706 "Somalia" somalia []] - ["ZA" "ZAF" 710 "South Africa" south_africa []] - ["GS" "SGS" 239 "South Georgia and the South Sandwich Islands" south_georgia [[south_sandwich_islands]]] - ["SS" "SSD" 728 "South Sudan" south_sudan []] - ["ES" "ESP" 724 "Spain" spain []] - ["LK" "LKA" 144 "Sri Lanka" sri_lanka []] - ["SD" "SDN" 729 "Sudan" sudan []] - ["SR" "SUR" 740 "Suriname" suriname []] - ["SJ" "SJM" 744 "Svalbard and Jan Mayen" svalbard [[jan_mayen]]] - ["SE" "SWE" 752 "Sweden" sweden []] - ["CH" "CHE" 756 "Switzerland" switzerland []] - ["SY" "SYR" 760 "Syria" syria []] - ["TW" "TWN" 158 "Taiwan" taiwan []] - ["TJ" "TJK" 762 "Tajikistan" tajikistan []] - ["TZ" "TZA" 834 "Tanzania" tanzania []] - ["TH" "THA" 764 "Thailand" thailand []] - ["TL" "TLS" 626 "East Timor" east_timor []] - ["TG" "TGO" 768 "Togo" togo []] - ["TK" "TKL" 772 "Tokelau" tokelau []] - ["TO" "TON" 776 "Tonga" tonga []] - ["TT" "TTO" 780 "Trinidad and Tobago" trinidad [[tobago]]] - ["TN" "TUN" 788 "Tunisia" tunisia []] - ["TR" "TUR" 792 "Turkey" turkey []] - ["TM" "TKM" 795 "Turkmenistan" turkmenistan []] - ["TC" "TCA" 796 "Turks and Caicos Islands" turks [[caicos_islands]]] - ["TV" "TUV" 798 "Tuvalu" tuvalu []] - ["UG" "UGA" 800 "Uganda" uganda []] - ["UA" "UKR" 804 "Ukraine" ukraine []] - ["AE" "ARE" 784 "United Arab Emirates" united_arab_emirates []] - ["GB" "GBR" 826 "United Kingdom of Great Britain and Northern Ireland" united_kingdom [[northern_ireland]]] - ["US" "USA" 840 "United States of America" united_states_of_america []] - ["UM" "UMI" 581 "United States Minor Outlying Islands" united_states_minor_outlying_islands []] - ["UY" "URY" 858 "Uruguay" uruguay []] - ["UZ" "UZB" 860 "Uzbekistan" uzbekistan []] - ["VU" "VUT" 548 "Vanuatu" vanuatu []] - ["VE" "VEN" 862 "Venezuela" venezuela []] - ["VN" "VNM" 704 "Vietnam" vietnam []] - ["VG" "VGB" 092 "British Virgin Islands" british_virgin_islands []] - ["VI" "VIR" 850 "United States Virgin Islands" united_states_virgin_islands []] - ["WF" "WLF" 876 "Wallis and Futuna" wallis [[futuna]]] - ["EH" "ESH" 732 "Western Sahara" western_sahara []] - ["YE" "YEM" 887 "Yemen" yemen []] - ["ZM" "ZMB" 894 "Zambia" zambia []] - ["ZW" "ZWE" 716 "Zimbabwe" zimbabwe []] - ) - - (implementation: #export equivalence - (Equivalence Territory) - - (def: (= reference sample) - (is? reference sample))) - - (implementation: #export hash - (Hash Territory) - - (def: &equivalence ..equivalence) - - (def: hash - (|>> :representation - (get@ #long) - (\ text.hash hash)))) - ) diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux deleted file mode 100644 index 1b83d179a..000000000 --- a/stdlib/source/lux/macro.lux +++ /dev/null @@ -1,209 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [data - ["." text ("#\." monoid)] - ["." name ("#\." codec)] - [collection - ["." list ("#\." monoid monad)]]] - [macro - ["." code]] - [math - [number - ["." nat] - ["." int]]]] - ["." // #_ - ["#" meta - ["." location]]]) - -(def: #export (expand_once syntax) - {#.doc (doc "Given code that requires applying a macro, does it once and returns the result." - "Otherwise, returns the code as-is.")} - (-> Code (Meta (List Code))) - (case syntax - [_ (#.Form (#.Cons [[_ (#.Identifier name)] args]))] - (do //.monad - [?macro (//.find_macro name)] - (case ?macro - (#.Some macro) - ((:as Macro' macro) args) - - #.None - (\ //.monad wrap (list syntax)))) - - _ - (\ //.monad wrap (list syntax)))) - -(def: #export (expand syntax) - {#.doc (doc "Given code that requires applying a macro, expands repeatedly until no more direct macro-calls are left." - "Otherwise, returns the code as-is.")} - (-> Code (Meta (List Code))) - (case syntax - [_ (#.Form (#.Cons [[_ (#.Identifier name)] args]))] - (do //.monad - [?macro (//.find_macro name)] - (case ?macro - (#.Some macro) - (do //.monad - [expansion ((:as Macro' macro) args) - expansion' (monad.map //.monad expand expansion)] - (wrap (list\join expansion'))) - - #.None - (\ //.monad wrap (list syntax)))) - - _ - (\ //.monad wrap (list syntax)))) - -(def: #export (expand_all syntax) - {#.doc "Expands all macro-calls everywhere recursively, until only primitive/base code remains."} - (-> Code (Meta (List Code))) - (case syntax - [_ (#.Form (#.Cons [[_ (#.Identifier name)] args]))] - (do //.monad - [?macro (//.find_macro name)] - (case ?macro - (#.Some macro) - (do //.monad - [expansion ((:as Macro' macro) args) - expansion' (monad.map //.monad expand_all expansion)] - (wrap (list\join expansion'))) - - #.None - (do //.monad - [parts' (monad.map //.monad expand_all (list& (code.identifier name) args))] - (wrap (list (code.form (list\join parts'))))))) - - [_ (#.Form (#.Cons [harg targs]))] - (do //.monad - [harg+ (expand_all harg) - targs+ (monad.map //.monad expand_all targs)] - (wrap (list (code.form (list\compose harg+ (list\join (: (List (List Code)) targs+))))))) - - [_ (#.Tuple members)] - (do //.monad - [members' (monad.map //.monad expand_all members)] - (wrap (list (code.tuple (list\join members'))))) - - [_ (#.Record members)] - (|> members - (monad.map //.monad - (function (_ [left right]) - (do //.monad - [left (expand_all left) - right (expand_all right)] - (case [left right] - [(#.Cons left #.Nil) (#.Cons right #.Nil)] - (wrap [left right]) - - _ - (//.fail "Record members must expand into singletons."))))) - (\ //.monad map (|>> code.record list))) - - _ - (\ //.monad wrap (list syntax)))) - -(def: #export (gensym prefix) - {#.doc (doc "Generates a unique name as an Code node (ready to be used in code templates)." - "A prefix can be given (or just be empty text) to better identify the code for debugging purposes.")} - (-> Text (Meta Code)) - (do //.monad - [id //.count] - (wrap (|> id - (\ nat.decimal encode) - ($_ text\compose "__gensym__" prefix) - [""] code.identifier)))) - -(def: (get_local_identifier ast) - (-> Code (Meta Text)) - (case ast - [_ (#.Identifier [_ name])] - (\ //.monad wrap name) - - _ - (//.fail (text\compose "Code is not a local identifier: " (code.format ast))))) - -(def: #export wrong_syntax_error - (-> Name Text) - (|>> name\encode - (text\compose "Wrong syntax for "))) - -(macro: #export (with_gensyms tokens) - {#.doc (doc "Creates new identifiers and offers them to the body expression." - (syntax: #export (synchronized lock body) - (with_gensyms [g!lock g!body g!_] - (wrap (list (` (let [(~ g!lock) (~ lock) - (~ g!_) ("jvm monitorenter" (~ g!lock)) - (~ g!body) (~ body) - (~ g!_) ("jvm monitorexit" (~ g!lock))] - (~ g!body))))) - )))} - (case tokens - (^ (list [_ (#.Tuple identifiers)] body)) - (do {! //.monad} - [identifier_names (monad.map ! ..get_local_identifier identifiers) - #let [identifier_defs (list\join (list\map (: (-> Text (List Code)) - (function (_ name) (list (code.identifier ["" name]) (` (gensym (~ (code.text name))))))) - identifier_names))]] - (wrap (list (` ((~! do) (~! //.monad) - [(~+ identifier_defs)] - (~ body)))))) - - _ - (//.fail (..wrong_syntax_error (name_of ..with_gensyms))))) - -(def: #export (expand_1 token) - {#.doc "Works just like expand, except that it ensures that the output is a single Code token."} - (-> Code (Meta Code)) - (do //.monad - [token+ (..expand token)] - (case token+ - (^ (list token')) - (wrap token') - - _ - (//.fail "Macro expanded to more than 1 element.")))) - -(template [<macro> <func>] - [(macro: #export (<macro> tokens) - {#.doc (doc "Performs a macro-expansion and logs the resulting code." - "You can either use the resulting code, or omit them." - "By omitting them, this macro produces nothing (just like the lux.comment macro)." - (<macro> #omit - (def: (foo bar baz) - (-> Int Int Int) - (int.+ bar baz))))} - (let [[module _] (name_of .._) - [_ short] (name_of <macro>) - macro_name [module short]] - (case (: (Maybe [Bit Code]) - (case tokens - (^ (list [_ (#.Tag ["" "omit"])] - token)) - (#.Some [#1 token]) - - (^ (list token)) - (#.Some [#0 token]) - - _ - #.None)) - (#.Some [omit? token]) - (do //.monad - [location //.location - output (<func> token) - #let [_ ("lux io log" ($_ text\compose (name\encode macro_name) " " (location.format location))) - _ (list\map (|>> code.format "lux io log") - output) - _ ("lux io log" "")]] - (wrap (if omit? - (list) - output))) - - #.None - (//.fail (..wrong_syntax_error macro_name)))))] - - [log_expand_once! expand_once] - [log_expand! expand] - [log_expand_all! expand_all] - ) diff --git a/stdlib/source/lux/macro/code.lux b/stdlib/source/lux/macro/code.lux deleted file mode 100644 index a17b38233..000000000 --- a/stdlib/source/lux/macro/code.lux +++ /dev/null @@ -1,160 +0,0 @@ -(.module: - [lux (#- nat int rev) - [abstract - [equivalence (#+ Equivalence)]] - [data - ["." product] - ["." bit] - ["." name] - ["." text ("#\." monoid equivalence)] - [collection - ["." list ("#\." functor fold)]]] - [math - [number - ["." nat] - ["." int] - ["." rev] - ["." frac]]] - [meta - ["." location]]]) - -## (type: (Code' w) -## (#.Bit Bit) -## (#.Nat Nat) -## (#.Int Int) -## (#.Rev Rev) -## (#.Frac Frac) -## (#.Text Text) -## (#.Identifier Name) -## (#.Tag Name) -## (#.Form (List (w (Code' w)))) -## (#.Tuple (List (w (Code' w)))) -## (#.Record (List [(w (Code' w)) (w (Code' w))]))) - -## (type: Code -## (Ann Location (Code' (Ann Location)))) - -(template [<name> <type> <tag>] - [(def: #export (<name> x) - (-> <type> Code) - [location.dummy (<tag> x)])] - - [bit Bit #.Bit] - [nat Nat #.Nat] - [int Int #.Int] - [rev Rev #.Rev] - [frac Frac #.Frac] - [text Text #.Text] - [identifier Name #.Identifier] - [tag Name #.Tag] - [form (List Code) #.Form] - [tuple (List Code) #.Tuple] - [record (List [Code Code]) #.Record] - ) - -(template [<name> <tag> <doc>] - [(def: #export (<name> name) - {#.doc <doc>} - (-> Text Code) - [location.dummy (<tag> ["" name])])] - - [local_identifier #.Identifier "Produces a local identifier (an identifier with no module prefix)."] - [local_tag #.Tag "Produces a local tag (a tag with no module prefix)."]) - -(implementation: #export equivalence - (Equivalence Code) - - (def: (= x y) - (case [x y] - (^template [<tag> <eq>] - [[[_ (<tag> x')] [_ (<tag> y')]] - (\ <eq> = x' y')]) - ([#.Bit bit.equivalence] - [#.Nat nat.equivalence] - [#.Int int.equivalence] - [#.Rev rev.equivalence] - [#.Frac frac.equivalence] - [#.Text text.equivalence] - [#.Identifier name.equivalence] - [#.Tag name.equivalence]) - - (^template [<tag>] - [[[_ (<tag> xs')] [_ (<tag> ys')]] - (\ (list.equivalence =) = xs' ys')]) - ([#.Form] - [#.Tuple]) - - [[_ (#.Record xs')] [_ (#.Record ys')]] - (\ (list.equivalence (product.equivalence = =)) - = xs' ys') - - _ - false))) - -(def: #export (format ast) - (-> Code Text) - (case ast - (^template [<tag> <struct>] - [[_ (<tag> value)] - (\ <struct> encode value)]) - ([#.Bit bit.codec] - [#.Nat nat.decimal] - [#.Int int.decimal] - [#.Rev rev.decimal] - [#.Frac frac.decimal] - [#.Identifier name.codec]) - - [_ (#.Text value)] - (text.format value) - - [_ (#.Tag name)] - (text\compose "#" (\ name.codec encode name)) - - (^template [<tag> <open> <close>] - [[_ (<tag> members)] - ($_ text\compose - <open> - (list\fold (function (_ next prev) - (let [next (format next)] - (if (text\= "" prev) - next - ($_ text\compose prev " " next)))) - "" - members) - <close>)]) - ([#.Form "(" ")"] - [#.Tuple "[" "]"]) - - [_ (#.Record pairs)] - ($_ text\compose - "{" - (list\fold (function (_ [left right] prev) - (let [next ($_ text\compose (format left) " " (format right))] - (if (text\= "" prev) - next - ($_ text\compose prev " " next)))) - "" - pairs) - "}") - )) - -(def: #export (replace original substitute ast) - {#.doc "Replaces all code that looks like the 'original' with the 'substitute'."} - (-> Code Code Code Code) - (if (\ ..equivalence = original ast) - substitute - (case ast - (^template [<tag>] - [[location (<tag> parts)] - [location (<tag> (list\map (replace original substitute) parts))]]) - ([#.Form] - [#.Tuple]) - - [location (#.Record parts)] - [location (#.Record (list\map (function (_ [left right]) - [(replace original substitute left) - (replace original substitute right)]) - parts))] - - _ - ast))) diff --git a/stdlib/source/lux/macro/local.lux b/stdlib/source/lux/macro/local.lux deleted file mode 100644 index fc9e8bef5..000000000 --- a/stdlib/source/lux/macro/local.lux +++ /dev/null @@ -1,105 +0,0 @@ -(.module: - [lux #* - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["." product] - ["." text] - [collection - ["." list ("#\." functor)] - [dictionary - ["." plist (#+ PList)]]]]] - ["." // - ["#." code]]) - -(exception: #export (unknown_module {module Text}) - (exception.report - ["Module" (text.format module)])) - -(template [<name>] - [(exception: #export (<name> {module Text} {definition Text}) - (exception.report - ["Module" (text.format module)] - ["Definition" (text.format definition)]))] - - [cannot_shadow_definition] - [unknown_definition] - ) - -(def: (with_module name body) - (All [a] (-> Text (-> Module (Try [Module a])) (Meta a))) - (function (_ compiler) - (case (|> compiler (get@ #.modules) (plist.get name)) - (#.Some module) - (case (body module) - (#try.Success [module' output]) - (#try.Success [(update@ #.modules (plist.put name module') compiler) - output]) - - (#try.Failure error) - (#try.Failure error)) - - #.None - (exception.throw ..unknown_module [name])))) - -(def: (push_one [name macro]) - (-> [Name Macro] (Meta Any)) - (do meta.monad - [[module_name definition_name] (meta.normalize name) - #let [definition (: Global (#.Definition [false .Macro (' {}) macro])) - add_macro! (: (-> (PList Global) (PList Global)) - (plist.put definition_name definition))]] - (..with_module module_name - (function (_ module) - (case (|> module (get@ #.definitions) (plist.get definition_name)) - #.None - (#try.Success [(update@ #.definitions add_macro! module) - []]) - - (#.Some _) - (exception.throw ..cannot_shadow_definition [module_name definition_name])))))) - -(def: (pop_one name) - (-> Name (Meta Any)) - (do meta.monad - [[module_name definition_name] (meta.normalize name) - #let [remove_macro! (: (-> (PList Global) (PList Global)) - (plist.remove definition_name))]] - (..with_module module_name - (function (_ module) - (case (|> module (get@ #.definitions) (plist.get definition_name)) - (#.Some _) - (#try.Success [(update@ #.definitions remove_macro! module) - []]) - - #.None - (exception.throw ..unknown_definition [module_name definition_name])))))) - -(def: (pop_all macros self) - (-> (List Name) Name Macro) - ("lux macro" - (function (_ _) - (do {! meta.monad} - [_ (monad.map ! ..pop_one macros) - _ (..pop_one self) - compiler meta.get_compiler] - (wrap (case (get@ #.expected compiler) - (#.Some _) - (list (' [])) - - #.None - (list))))))) - -(def: #export (push macros) - (-> (List [Name Macro]) (Meta Code)) - (do meta.monad - [_ (monad.map meta.monad ..push_one macros) - seed meta.count - g!pop (//.gensym "pop") - _ (let [g!pop (: Name ["" (//code.format g!pop)])] - (..push_one [g!pop (..pop_all (list\map product.left macros) g!pop)]))] - (wrap (` ((~ g!pop)))))) diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux deleted file mode 100644 index d29966a87..000000000 --- a/stdlib/source/lux/macro/poly.lux +++ /dev/null @@ -1,127 +0,0 @@ -(.module: - [lux #* - ["." meta] - ["." type] - [abstract - ["." monad (#+ do)]] - [control - ["p" parser - ["<.>" type (#+ Env)] - ["s" code]]] - [data - ["." product] - ["." maybe] - ["." text] - [collection - ["." list ("#\." fold functor)] - ["." dictionary]]] - [macro (#+ with_gensyms) - ["." code] - [syntax (#+ syntax:) - ["|.|" export]]] - [math - [number - ["n" nat]]]]) - -(syntax: #export (poly: {export |export|.parser} - {name s.local_identifier} - body) - (with_gensyms [g!_ g!type g!output] - (let [g!name (code.identifier ["" name])] - (wrap (.list (` ((~! syntax:) (~+ (|export|.format export)) ((~ g!name) {(~ g!type) (~! s.identifier)}) - ((~! do) (~! meta.monad) - [(~ g!type) ((~! meta.find_type_def) (~ g!type))] - (case (: (.Either .Text .Code) - ((~! <type>.run) ((~! p.rec) - (function ((~ g!_) (~ g!name)) - (~ body))) - (~ g!type))) - (#.Left (~ g!output)) - ((~! meta.fail) (~ g!output)) - - (#.Right (~ g!output)) - ((~' wrap) (.list (~ g!output)))))))))))) - -(def: (common_poly_name? poly_func) - (-> Text Bit) - (text.contains? "?" poly_func)) - -(def: (derivation_name poly args) - (-> Text (List Text) (Maybe Text)) - (if (common_poly_name? poly) - (#.Some (list\fold (text.replace_once "?") poly args)) - #.None)) - -(syntax: #export (derived: {export |export|.parser} - {?name (p.maybe s.local_identifier)} - {[poly_func poly_args] (s.form (p.and s.identifier (p.many s.identifier)))} - {?custom_impl (p.maybe s.any)}) - (do {! meta.monad} - [poly_args (monad.map ! meta.normalize poly_args) - name (case ?name - (#.Some name) - (wrap name) - - (^multi #.None - [(derivation_name (product.right poly_func) (list\map product.right poly_args)) - (#.Some derived_name)]) - (wrap derived_name) - - _ - (p.fail "derived: was given no explicit name, and cannot generate one from given information.")) - #let [impl (case ?custom_impl - (#.Some custom_impl) - custom_impl - - #.None - (` ((~ (code.identifier poly_func)) (~+ (list\map code.identifier poly_args)))))]] - (wrap (.list (` (def: (~+ (|export|.format export)) - (~ (code.identifier ["" name])) - {#.implementation? #1} - (~ impl))))))) - -(def: #export (to_code env type) - (-> Env Type Code) - (case type - (#.Primitive name params) - (` (#.Primitive (~ (code.text name)) - (list (~+ (list\map (to_code env) params))))) - - (^template [<tag>] - [(<tag> idx) - (` (<tag> (~ (code.nat idx))))]) - ([#.Var] [#.Ex]) - - (#.Parameter idx) - (let [idx (<type>.adjusted_idx env idx)] - (if (n.= 0 idx) - (|> (dictionary.get idx env) maybe.assume product.left (to_code env)) - (` (.$ (~ (code.nat (dec idx))))))) - - (#.Apply (#.Named ["lux" "Nothing"] _) (#.Parameter idx)) - (let [idx (<type>.adjusted_idx env idx)] - (if (n.= 0 idx) - (|> (dictionary.get idx env) maybe.assume product.left (to_code env)) - (undefined))) - - (^template [<tag>] - [(<tag> left right) - (` (<tag> (~ (to_code env left)) - (~ (to_code env right))))]) - ([#.Function] [#.Apply]) - - (^template [<macro> <tag> <flattener>] - [(<tag> left right) - (` (<macro> (~+ (list\map (to_code env) (<flattener> type)))))]) - ([| #.Sum type.flatten_variant] - [& #.Product type.flatten_tuple]) - - (#.Named name sub_type) - (code.identifier name) - - (^template [<tag>] - [(<tag> scope body) - (` (<tag> (list (~+ (list\map (to_code env) scope))) - (~ (to_code env body))))]) - ([#.UnivQ] [#.ExQ]) - )) diff --git a/stdlib/source/lux/macro/syntax.lux b/stdlib/source/lux/macro/syntax.lux deleted file mode 100644 index 738ae2a22..000000000 --- a/stdlib/source/lux/macro/syntax.lux +++ /dev/null @@ -1,128 +0,0 @@ -(.module: - [lux #* - ["." macro (#+ with_gensyms)] - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["." try] - ["<>" parser - ["</>" code (#+ Parser)]]] - [data - ["." maybe] - ["." text ("#\." monoid)] - [collection - ["." list ("#\." functor)]]] - [math - [number - ["." nat] - ["." int] - ["." rev] - ["." frac]]]] - [// - ["." code]]) - -(def: (self_documenting binding parser) - (All [a] (-> Code (Parser a) (Parser a))) - (function (_ tokens) - (case (parser tokens) - (#try.Success [tokens output]) - (#try.Success [tokens output]) - - (#try.Failure error) - (#try.Failure ($_ text\compose - "Failed to parse: " (code.format binding) text.new_line - error))))) - -(def: (join_pairs pairs) - (All [a] (-> (List [a a]) (List a))) - (case pairs - #.Nil #.Nil - (#.Cons [[x y] pairs']) (list& x y (join_pairs pairs')))) - -(macro: #export (syntax: tokens) - {#.doc (doc "A more advanced way to define macros than 'macro:'." - "The inputs to the macro can be parsed in complex ways through the use of syntax parsers." - "The macro body is also (implicitly) run in the Meta monad, to save some typing." - "Also, the compiler state can be accessed through the *compiler* binding." - (syntax: #export (object {#let [imports (class_imports *compiler*)]} - {#let [class_vars (list)]} - {super (opt (super_class_decl^ imports class_vars))} - {interfaces (tuple (some (super_class_decl^ imports class_vars)))} - {constructor_args (constructor_args^ imports class_vars)} - {methods (some (overriden_method_def^ imports))}) - (let [def_code ($_ text\compose "anon-class:" - (spaced (list (super_class_decl$ (maybe.default object_super_class super)) - (with_brackets (spaced (list\map super_class_decl$ interfaces))) - (with_brackets (spaced (list\map constructor_arg$ constructor_args))) - (with_brackets (spaced (list\map (method_def$ id) methods))))))] - (wrap (list (` ((~ (code.text def_code)))))))))} - (let [[exported? tokens] (: [Bit (List Code)] - (case tokens - (^ (list& [_ (#.Tag ["" "export"])] tokens')) - [#1 tokens'] - - _ - [#0 tokens])) - ?parts (: (Maybe [Text (List Code) Code Code]) - (case tokens - (^ (list [_ (#.Form (list& [_ (#.Identifier ["" name])] args))] - body)) - (#.Some name args (` {}) body) - - (^ (list [_ (#.Form (list& [_ (#.Identifier ["" name])] args))] - meta_data - body)) - (#.Some name args meta_data body) - - _ - #.None))] - (case ?parts - (#.Some [name args meta body]) - (with_gensyms [g!tokens g!body g!error] - (do {! meta.monad} - [vars+parsers (monad.map ! - (: (-> Code (Meta [Code Code])) - (function (_ arg) - (case arg - (^ [_ (#.Record (list [var parser]))]) - (case var - [_ (#.Tag ["" "let"])] - (wrap [var parser]) - - _ - (wrap [var - (` ((~! ..self_documenting) (' (~ var)) - (~ parser)))])) - - [_ (#.Identifier var_name)] - (wrap [arg - (` ((~! ..self_documenting) (' (~ arg)) - (~! </>.any)))]) - - _ - (meta.fail "Syntax pattern expects records or identifiers.")))) - args) - this_module meta.current_module_name - #let [g!state (code.identifier ["" "*compiler*"]) - error_msg (code.text (macro.wrong_syntax_error [this_module name])) - export_ast (: (List Code) - (if exported? - (list (' #export)) - (list)))]] - (wrap (list (` (macro: (~+ export_ast) ((~ (code.identifier ["" name])) (~ g!tokens) (~ g!state)) - (~ meta) - ({(#.Right (~ g!body)) - ((~ g!body) (~ g!state)) - - (#.Left (~ g!error)) - (#.Left ((~! text.join_with) (~! text.new_line) (list (~ error_msg) (~ g!error))))} - ((~! </>.run) - (: ((~! </>.Parser) (Meta (List Code))) - ((~! do) (~! <>.monad) - [(~+ (..join_pairs vars+parsers))] - ((~' wrap) (~ body)))) - (~ g!tokens))))))))) - - _ - (meta.fail (macro.wrong_syntax_error (name_of ..syntax:)))))) diff --git a/stdlib/source/lux/macro/syntax/annotations.lux b/stdlib/source/lux/macro/syntax/annotations.lux deleted file mode 100644 index a0453771a..000000000 --- a/stdlib/source/lux/macro/syntax/annotations.lux +++ /dev/null @@ -1,41 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)]] - [control - ["." function] - ["<>" parser - ["<.>" code (#+ Parser)]]] - [data - ["." product] - ["." name] - [collection - ["." list ("#\." functor)]]] - [macro - ["." code]]]) - -(type: #export Annotations - (List [Name Code])) - -(def: #export equivalence - (Equivalence Annotations) - (list.equivalence - (product.equivalence name.equivalence - code.equivalence))) - -(def: #export empty - Annotations - (list)) - -(def: #export format - (-> Annotations Code) - (let [entry (product.apply code.tag function.identity)] - (|>> (list\map entry) - code.record))) - -(def: #export parser - (Parser Annotations) - (<code>.record - (<>.some - (<>.and <code>.tag - <code>.any)))) diff --git a/stdlib/source/lux/macro/syntax/check.lux b/stdlib/source/lux/macro/syntax/check.lux deleted file mode 100644 index d3007b2b8..000000000 --- a/stdlib/source/lux/macro/syntax/check.lux +++ /dev/null @@ -1,41 +0,0 @@ -(.module: - [lux #* - ["." meta] - [abstract - [equivalence (#+ Equivalence)] - [monad (#+ do)]] - [control - ["." exception (#+ exception:)] - ["<>" parser - ["<.>" code (#+ Parser)]]] - [data - ["." product]] - [macro - ["." code]]]) - -(def: extension - "lux check") - -(type: #export Check - {#type Code - #value Code}) - -(def: #export equivalence - (Equivalence Check) - ($_ product.equivalence - code.equivalence - code.equivalence - )) - -(def: #export (format (^slots [#type #value])) - (-> Check Code) - (` ((~ (code.text ..extension)) - (~ type) - (~ value)))) - -(def: #export parser - (Parser Check) - (<| <code>.form - (<>.after (<code>.text! ..extension)) - (<>.and <code>.any - <code>.any))) diff --git a/stdlib/source/lux/macro/syntax/declaration.lux b/stdlib/source/lux/macro/syntax/declaration.lux deleted file mode 100644 index 92158b842..000000000 --- a/stdlib/source/lux/macro/syntax/declaration.lux +++ /dev/null @@ -1,46 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)]] - [control - ["<>" parser ("#\." monad) - ["<.>" code (#+ Parser)]]] - [data - ["." product] - ["." text] - [collection - ["." list ("#\." functor)]]] - [macro - ["." code]]]) - -(type: #export Declaration - {#name Text - #arguments (List Text)}) - -(def: #export equivalence - (Equivalence Declaration) - ($_ product.equivalence - text.equivalence - (list.equivalence text.equivalence) - )) - -(def: #export parser - {#.doc (doc "A parser for declaration syntax." - "Such as:" - quux - (foo bar baz))} - (Parser Declaration) - (<>.either (<>.and <code>.local_identifier - (<>\wrap (list))) - (<code>.form (<>.and <code>.local_identifier - (<>.some <code>.local_identifier))))) - -(def: #export (format value) - (-> Declaration Code) - (let [g!name (code.local_identifier (get@ #name value))] - (case (get@ #arguments value) - #.Nil - g!name - - arguments - (` ((~ g!name) (~+ (list\map code.local_identifier arguments))))))) diff --git a/stdlib/source/lux/macro/syntax/definition.lux b/stdlib/source/lux/macro/syntax/definition.lux deleted file mode 100644 index bbb72fb37..000000000 --- a/stdlib/source/lux/macro/syntax/definition.lux +++ /dev/null @@ -1,140 +0,0 @@ -(.module: - [lux (#- Definition) - [abstract - [equivalence (#+ Equivalence)] - [monad (#+ do)]] - [control - ["." exception (#+ exception:)] - ["<>" parser - ["<.>" code (#+ Parser)]]] - [data - ["." sum] - ["." product] - ["." bit] - ["." name] - ["." text - ["%" format]] - [collection - ["." list]]] - ["." macro - ["." code]] - ["." meta - ["." location]]] - ["." // - ["#." annotations (#+ Annotations)] - ["#." check (#+ Check)]]) - -(type: #export Definition - {#name Text - #value (Either Check - Code) - #anns Annotations - #export? Bit}) - -(def: #export equivalence - (Equivalence Definition) - ($_ product.equivalence - text.equivalence - ($_ sum.equivalence - //check.equivalence - code.equivalence - ) - //annotations.equivalence - bit.equivalence - )) - -(def: extension - "lux def") - -(def: (format_tag [module short]) - (-> Name Code) - (` [(~ (code.text module)) - (~ (code.text short))])) - -(def: (format_annotations value) - (-> Annotations Code) - (case value - #.Nil - (` #.Nil) - - (#.Cons [name value] tail) - (` (#.Cons [(~ (..format_tag name)) - (~ value)] - (~ (format_annotations tail)))))) - -(def: dummy - Code - (` {#.module (~ (code.text (get@ #.module location.dummy))) - #.line (~ (code.nat (get@ #.line location.dummy))) - #.column (~ (code.nat (get@ #.column location.dummy)))})) - -(def: #export (format (^slots [#name #value #anns #export?])) - (-> Definition Code) - (` ((~ (code.text ..extension)) - (~ (code.local_identifier name)) - (~ (case value - (#.Left check) - (//check.format check) - - (#.Right value) - value)) - [(~ ..dummy) (#.Record (~ (..format_annotations anns)))] - (~ (code.bit export?))))) - -(def: tag_parser - (Parser Name) - (<code>.tuple (<>.and <code>.text <code>.text))) - -(def: annotations_parser - (Parser Annotations) - (<>.rec - (function (_ recur) - ($_ <>.or - (<code>.tag! (name_of #.Nil)) - (<code>.form (do <>.monad - [_ (<code>.tag! (name_of #.Cons)) - [head tail] (<>.and (<code>.tuple (<>.and tag_parser <code>.any)) - recur)] - (wrap [head tail]))) - )))) - -(def: #export (parser compiler) - {#.doc "A reader that first macro-expands and then analyses the input Code, to ensure it's a definition."} - (-> Lux (Parser Definition)) - (do {! <>.monad} - [raw <code>.any - me_raw (|> raw - macro.expand_all - (meta.run compiler) - <>.lift)] - (<| (<code>.local me_raw) - <code>.form - (<>.after (<code>.text! ..extension)) - ($_ <>.and - <code>.local_identifier - (<>.or //check.parser - <code>.any) - (<| <code>.tuple - (<>.after <code>.any) - <code>.form - (<>.after (<code>.this! (` #.Record))) - ..annotations_parser) - <code>.bit - )))) - -(exception: #export (lacks_type! {definition Definition}) - (exception.report - ["Definition" (%.code (..format definition))])) - -(def: #export (typed compiler) - {#.doc "Only works for typed definitions."} - (-> Lux (Parser Definition)) - (do <>.monad - [definition (..parser compiler) - _ (case (get@ #value definition) - (#.Left _) - (wrap []) - - (#.Right _) - (<>.lift (exception.throw ..lacks_type! [definition])))] - (wrap definition))) diff --git a/stdlib/source/lux/macro/syntax/export.lux b/stdlib/source/lux/macro/syntax/export.lux deleted file mode 100644 index fceecc6e7..000000000 --- a/stdlib/source/lux/macro/syntax/export.lux +++ /dev/null @@ -1,20 +0,0 @@ -(.module: - [lux #* - [control - ["<>" parser ("#\." monad) - ["<.>" code (#+ Parser)]]]]) - -(def: token - (' #export)) - -(def: #export (format exported?) - (-> Bit (List Code)) - (if exported? - (list ..token) - (list))) - -(def: #export parser - (Parser Bit) - (<>.either (<>.after (<code>.this! ..token) - (<>\wrap true)) - (<>\wrap false))) diff --git a/stdlib/source/lux/macro/syntax/input.lux b/stdlib/source/lux/macro/syntax/input.lux deleted file mode 100644 index 9b9fcb576..000000000 --- a/stdlib/source/lux/macro/syntax/input.lux +++ /dev/null @@ -1,37 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)]] - [control - ["<>" parser - ["<.>" code (#+ Parser)]]] - [data - ["." product]] - [macro - ["." code]]]) - -(type: #export Input - {#binding Code - #type Code}) - -(def: #export equivalence - (Equivalence Input) - ($_ product.equivalence - code.equivalence - code.equivalence - )) - -(def: #export (format value) - (-> Input Code) - (code.record - (list [(get@ #binding value) - (get@ #type value)]))) - -(def: #export parser - {#.doc "Parser for the common typed-argument syntax used by many macros."} - (Parser Input) - (<code>.record - ($_ <>.and - <code>.any - <code>.any - ))) diff --git a/stdlib/source/lux/macro/syntax/type/variable.lux b/stdlib/source/lux/macro/syntax/type/variable.lux deleted file mode 100644 index 22f37a35c..000000000 --- a/stdlib/source/lux/macro/syntax/type/variable.lux +++ /dev/null @@ -1,27 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)]] - [control - [parser - ["<.>" code (#+ Parser)]]] - [data - ["." text]] - [macro - ["." code]]]) - -(type: #export Variable - Text) - -(def: #export equivalence - (Equivalence Variable) - text.equivalence) - -(def: #export format - (-> Variable Code) - code.local_identifier) - -(def: #export parser - {#.doc "Parser for the common type variable/parameter used by many macros."} - (Parser Variable) - <code>.local_identifier) diff --git a/stdlib/source/lux/macro/template.lux b/stdlib/source/lux/macro/template.lux deleted file mode 100644 index b970cae05..000000000 --- a/stdlib/source/lux/macro/template.lux +++ /dev/null @@ -1,184 +0,0 @@ -(.module: - [lux (#- let) - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["<>" parser ("#\." functor) - ["<.>" code (#+ Parser)]]] - [data - ["." bit ("#\." codec)] - ["." text] - [collection - ["." list ("#\." monad)] - ["." dictionary (#+ Dictionary)]]] - [math - [number - ["." nat ("#\." decimal)] - ["." int ("#\." decimal)] - ["." rev ("#\." decimal)] - ["." frac ("#\." decimal)]]]] - ["." // - [syntax (#+ syntax:)] - ["." code] - ["." local]]) - -(syntax: #export (splice {parts (<code>.tuple (<>.some <code>.any))}) - (wrap parts)) - -(syntax: #export (count {parts (<code>.tuple (<>.some <code>.any))}) - (wrap (list (code.nat (list.size parts))))) - -(syntax: #export (with_locals {locals (<code>.tuple (<>.some <code>.local_identifier))} - body) - (do {! meta.monad} - [g!locals (|> locals - (list\map //.gensym) - (monad.seq !))] - (wrap (list (` (.with_expansions [(~+ (|> (list.zip/2 locals g!locals) - (list\map (function (_ [name identifier]) - (list (code.local_identifier name) (as_is identifier)))) - list\join))] - (~ body))))))) - -(def: (name_side module_side? parser) - (-> Bit (Parser Name) (Parser Text)) - (do <>.monad - [[module short] parser] - (wrap (if module_side? - (case module - "" short - _ module) - short)))) - -(def: (snippet module_side?) - (-> Bit (Parser Text)) - (.let [full_identifier (..name_side module_side? <code>.identifier) - full_tag (..name_side module_side? <code>.tag)] - ($_ <>.either - <code>.text - (if module_side? - full_identifier - (<>.either <code>.local_identifier - full_identifier)) - (if module_side? - full_tag - (<>.either <code>.local_tag - full_tag)) - (<>\map bit\encode <code>.bit) - (<>\map nat\encode <code>.nat) - (<>\map int\encode <code>.int) - (<>\map rev\encode <code>.rev) - (<>\map frac\encode <code>.frac) - ))) - -(def: (part module_side?) - (-> Bit (Parser (List Text))) - (<code>.tuple (<>.many (..snippet module_side?)))) - -(syntax: #export (text {simple (..part false)}) - (wrap (list (|> simple (text.join_with "") code.text)))) - -(template [<name> <simple> <complex>] - [(syntax: #export (<name> {name (<>.or (<>.and (..part true) (..part false)) - (..part false))}) - (case name - (#.Left [simple complex]) - (wrap (list (<complex> [(text.join_with "" simple) - (text.join_with "" complex)]))) - - (#.Right simple) - (wrap (list (|> simple (text.join_with "") <simple>)))))] - - [identifier code.local_identifier code.identifier] - [tag code.local_tag code.tag] - ) - -(type: Environment - (Dictionary Text Code)) - -(def: (apply env template) - (-> Environment Code Code) - (case template - [_ (#.Identifier "" name)] - (case (dictionary.get name env) - (#.Some substitute) - substitute - - #.None - template) - - (^template [<tag>] - [[meta (<tag> elems)] - [meta (<tag> (list\map (apply env) elems))]]) - ([#.Tuple] - [#.Form]) - - [meta (#.Record members)] - [meta (#.Record (list\map (: (-> [Code Code] [Code Code]) - (function (_ [key value]) - [(apply env key) - (apply env value)])) - members))] - - _ - template)) - -(type: Local - {#name Text - #parameters (List Text) - #template (List Code)}) - -(exception: #export (irregular_arguments {expected Nat} {actual Nat}) - (exception.report - ["Expected" (\ nat.decimal encode expected)] - ["Actual" (\ nat.decimal encode actual)])) - -(def: (macro (^slots [#parameters #template])) - (-> Local Macro) - ("lux macro" - (function (_ inputs compiler) - (.let [parameters_count (list.size parameters) - inputs_count (list.size inputs)] - (if (nat.= parameters_count inputs_count) - (.let [environment (: Environment - (|> (list.zip/2 parameters inputs) - (dictionary.from_list text.hash)))] - (#.Right [compiler (list\map (..apply environment) template)])) - (exception.throw ..irregular_arguments [parameters_count inputs_count])))))) - -(def: local - (Parser Local) - (do <>.monad - [[name parameters] (<code>.form (<>.and <code>.local_identifier - (<>.many <code>.local_identifier))) - template (<code>.tuple (<>.some <code>.any))] - (wrap {#name name - #parameters parameters - #template template}))) - -(syntax: #export (let {locals (<code>.tuple (<>.some ..local))} - body) - (do meta.monad - [here_name meta.current_module_name - expression? (: (Meta Bit) - (function (_ lux) - (#try.Success [lux (case (get@ #.expected lux) - #.None - false - - (#.Some _) - true)]))) - g!pop (local.push (list\map (function (_ local) - [[here_name (get@ #name local)] - (..macro local)]) - locals))] - (if expression? - (//.with_gensyms [g!body] - (wrap (list (` (.let [(~ g!body) (~ body)] - (exec (~ g!pop) - (~ g!body))))))) - (wrap (list body - g!pop))))) diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux deleted file mode 100644 index c7e709578..000000000 --- a/stdlib/source/lux/math.lux +++ /dev/null @@ -1,393 +0,0 @@ -(.module: {#.doc "Common mathematical constants and functions."} - [lux #* - ["@" target] - [math - [number - ["n" nat] - ["i" int]]]]) - -(template [<name> <value> <doc>] - [(def: #export <name> - {#.doc <doc>} - <value>)] - - [e +2.7182818284590452354 "The base of the natural logarithm."] - [pi +3.14159265358979323846 "The ratio of a circle's circumference to its diameter."] - [tau +6.28318530717958647692 "The ratio of a circle's circumference to its radius."] - ) - -(for {@.old - (as_is (template [<name> <method>] - [(def: #export (<name> input) - (-> Frac Frac) - (<method> input))] - - [cos "jvm invokestatic:java.lang.Math:cos:double"] - [sin "jvm invokestatic:java.lang.Math:sin:double"] - [tan "jvm invokestatic:java.lang.Math:tan:double"] - - [acos "jvm invokestatic:java.lang.Math:acos:double"] - [asin "jvm invokestatic:java.lang.Math:asin:double"] - [atan "jvm invokestatic:java.lang.Math:atan:double"] - - [exp "jvm invokestatic:java.lang.Math:exp:double"] - [log "jvm invokestatic:java.lang.Math:log:double"] - - [ceil "jvm invokestatic:java.lang.Math:ceil:double"] - [floor "jvm invokestatic:java.lang.Math:floor:double"] - ) - (def: #export (pow param subject) - (-> Frac Frac Frac) - ("jvm invokestatic:java.lang.Math:pow:double,double" subject param))) - - @.jvm - (as_is (template: (!double value) - (|> value - (:as (primitive "java.lang.Double")) - "jvm object cast")) - - (template: (!frac value) - (|> value - "jvm object cast" - (: (primitive "java.lang.Double")) - (:as Frac))) - - (template [<name> <method>] - [(def: #export <name> - (-> Frac Frac) - (|>> !double - ["D"] - ("jvm member invoke static" [] "java.lang.Math" <method> []) - !frac))] - - [cos "cos"] - [sin "sin"] - [tan "tan"] - - [acos "acos"] - [asin "asin"] - [atan "atan"] - - [exp "exp"] - [log "log"] - - [ceil "ceil"] - [floor "floor"] - - [root/2 "sqrt"] - [root/3 "cbrt"] - ) - - (def: #export (pow param subject) - (-> Frac Frac Frac) - (|> ("jvm member invoke static" [] "java.lang.Math" "pow" [] - ["D" (!double subject)] ["D" (!double param)]) - !frac))) - - @.js - (as_is (template [<name> <method>] - [(def: #export <name> - (-> Frac Frac) - (|>> ("js apply" ("js constant" <method>)) - (:as Frac)))] - - [cos "Math.cos"] - [sin "Math.sin"] - [tan "Math.tan"] - - [acos "Math.acos"] - [asin "Math.asin"] - [atan "Math.atan"] - - [exp "Math.exp"] - [log "Math.log"] - - [ceil "Math.ceil"] - [floor "Math.floor"] - - [root/2 "Math.sqrt"] - [root/3 "Math.cbrt"] - ) - - (def: #export (pow param subject) - (-> Frac Frac Frac) - (:as Frac ("js apply" ("js constant" "Math.pow") subject param)))) - - @.python - (as_is (template [<name> <method>] - [(def: #export <name> - (-> Frac Frac) - (|>> ("python object do" <method> ("python import" "math")) - (:as Frac)))] - - [cos "cos"] - [sin "sin"] - [tan "tan"] - - [acos "acos"] - [asin "asin"] - [atan "atan"] - - [exp "exp"] - [log "log"] - - [ceil "ceil"] - [floor "floor"] - - [root/2 "sqrt"] - ) - - (def: #export (pow param subject) - (-> Frac Frac Frac) - (:as Frac ("python object do" "pow" ("python import" "math") subject param))) - - (def: #export root/3 - (-> Frac Frac) - (..pow ("lux f64 /" +3.0 +1.0)))) - - @.lua - (as_is (template [<name> <method>] - [(def: #export <name> - (-> Frac Frac) - (|>> ("lua apply" ("lua constant" <method>)) - (:as Frac)))] - - [cos "math.cos"] - [sin "math.sin"] - [tan "math.tan"] - - [acos "math.acos"] - [asin "math.asin"] - [atan "math.atan"] - - [exp "math.exp"] - [log "math.log"] - - [ceil "math.ceil"] - [floor "math.floor"] - - [root/2 "math.sqrt"] - ) - - (def: #export (pow param subject) - (-> Frac Frac Frac) - ("lua power" param subject)) - - (def: #export root/3 - (-> Frac Frac) - (..pow ("lux f64 /" +3.0 +1.0)))) - - @.ruby - (as_is (template [<name> <method>] - [(def: #export <name> - (-> Frac Frac) - (|>> ("ruby apply" ("ruby constant" <method>)) - (:as Frac)))] - - [cos "Math.cos"] - [sin "Math.sin"] - [tan "Math.tan"] - - [acos "Math.acos"] - [asin "Math.asin"] - [atan "Math.atan"] - - [exp "Math.exp"] - [log "Math.log"] - - [root/2 "Math.sqrt"] - [root/3 "Math.cbrt"] - ) - - (template [<name> <method>] - [(def: #export <name> - (-> Frac Frac) - (|>> ("ruby object do" <method>) - (:as Int) - ("lux i64 f64")))] - - [ceil "ceil"] - [floor "floor"] - ) - - (def: #export (pow param subject) - (-> Frac Frac Frac) - (:as Frac ("ruby object do" "**" subject param)))) - - @.php - (as_is (template [<name> <method>] - [(def: #export <name> - (-> Frac Frac) - (|>> ("php apply" ("php constant" <method>)) - (:as Frac)))] - - [cos "cos"] - [sin "sin"] - [tan "tan"] - - [acos "acos"] - [asin "asin"] - [atan "atan"] - - [exp "exp"] - [log "log"] - - [ceil "ceil"] - [floor "floor"] - - [root/2 "sqrt"] - ) - - (def: #export (pow param subject) - (-> Frac Frac Frac) - (:as Frac ("php apply" ("php constant" "pow") subject param))) - - (def: #export root/3 - (-> Frac Frac) - (..pow ("lux f64 /" +3.0 +1.0)))) - - @.scheme - (as_is (template [<name> <method>] - [(def: #export <name> - (-> Frac Frac) - (|>> ("scheme apply" ("scheme constant" <method>)) - (:as Frac)))] - - [cos "cos"] - [sin "sin"] - [tan "tan"] - - [acos "acos"] - [asin "asin"] - [atan "atan"] - - [exp "exp"] - [log "log"] - - [ceil "ceiling"] - [floor "floor"] - - [root/2 "sqrt"] - ) - - (def: #export (pow param subject) - (-> Frac Frac Frac) - (:as Frac ("scheme apply" ("scheme constant" "expt") subject param))) - - (def: #export root/3 - (-> Frac Frac) - (..pow ("lux f64 /" +3.0 +1.0)))) - }) - -(def: #export (round input) - (-> Frac Frac) - (let [floored (floor input) - diff ("lux f64 -" floored input)] - (cond ("lux f64 <" diff +0.5) - ("lux f64 +" +1.0 floored) - - ("lux f64 <" -0.5 diff) - ("lux f64 +" -1.0 floored) - - ## else - floored))) - -(def: #export (atan/2 x y) - (-> Frac Frac Frac) - (cond ("lux f64 <" x +0.0) - (..atan ("lux f64 /" x y)) - - ("lux f64 <" +0.0 x) - (if (or ("lux f64 <" y +0.0) - ("lux f64 =" +0.0 y)) - (|> y ("lux f64 /" x) atan ("lux f64 +" pi)) - (|> y ("lux f64 /" x) atan ("lux f64 -" pi))) - - ## ("lux f64 =" +0.0 x) - (cond ("lux f64 <" y +0.0) - (|> pi ("lux f64 /" +2.0)) - - ("lux f64 <" +0.0 y) - (|> pi ("lux f64 /" -2.0)) - - ## ("lux f64 =" +0.0 y) - ("lux f64 /" +0.0 +0.0)))) - -(def: #export (log' base input) - (-> Frac Frac Frac) - ("lux f64 /" - (..log base) - (..log input))) - -(def: #export (factorial n) - (-> Nat Nat) - (loop [acc 1 - n n] - (if (n.<= 1 n) - acc - (recur (n.* n acc) (dec n))))) - -(def: #export (hypotenuse catA catB) - (-> Frac Frac Frac) - (..pow +0.5 ("lux f64 +" - (..pow +2.0 catA) - (..pow +2.0 catB)))) - -## Hyperbolic functions -## https://en.wikipedia.org/wiki/Hyperbolic_function#Definitions -(template [<name> <comp> <inverse>] - [(def: #export (<name> x) - (-> Frac Frac) - (|> (..exp x) (<comp> (..exp ("lux f64 *" -1.0 x))) ("lux f64 /" +2.0))) - - (def: #export (<inverse> x) - (-> Frac Frac) - (|> +2.0 ("lux f64 /" (|> (..exp x) (<comp> (..exp ("lux f64 *" -1.0 x)))))))] - - [sinh "lux f64 -" csch] - [cosh "lux f64 +" sech] - ) - -(template [<name> <top> <bottom>] - [(def: #export (<name> x) - (-> Frac Frac) - (let [e+ (exp x) - e- (exp ("lux f64 *" -1.0 x)) - sinh' (|> e+ ("lux f64 -" e-)) - cosh' (|> e+ ("lux f64 +" e-))] - (|> <top> ("lux f64 /" <bottom>))))] - - [tanh sinh' cosh'] - [coth cosh' sinh'] - ) - -## https://en.wikipedia.org/wiki/Inverse_hyperbolic_functions#Definitions_in_terms_of_logarithms -(template [<name> <comp>] - [(def: #export (<name> x) - (-> Frac Frac) - (|> x (pow +2.0) (<comp> +1.0) (pow +0.5) ("lux f64 +" x) log))] - - [asinh "lux f64 +"] - [acosh "lux f64 -"] - ) - -(template [<name> <base> <diff>] - [(def: #export (<name> x) - (-> Frac Frac) - (let [x+ (|> <base> ("lux f64 +" <diff>)) - x- (|> <base> ("lux f64 -" <diff>))] - (|> x+ ("lux f64 /" x-) log ("lux f64 /" +2.0))))] - - [atanh +1.0 x] - [acoth x +1.0] - ) - -(template [<name> <op>] - [(def: #export (<name> x) - (-> Frac Frac) - (let [x^2 (|> x (pow +2.0))] - (|> +1.0 (<op> x^2) (pow +0.5) ("lux f64 +" +1.0) ("lux f64 /" x) log)))] - - [asech "lux f64 -"] - [acsch "lux f64 +"] - ) diff --git a/stdlib/source/lux/math/infix.lux b/stdlib/source/lux/math/infix.lux deleted file mode 100644 index 674544ae8..000000000 --- a/stdlib/source/lux/math/infix.lux +++ /dev/null @@ -1,95 +0,0 @@ -(.module: {#.doc "Common mathematical constants and functions."} - [lux #* - [abstract - [monad (#+ do)]] - [control - ["<>" parser ("#\." functor) - ["<.>" code (#+ Parser)]]] - [data - ["." product] - [collection - ["." list ("#\." fold)]]] - [macro - [syntax (#+ syntax:)] - ["." code]] - [math - [number - ["n" nat] - ["i" int]]]]) - -(type: #rec Infix - (#Const Code) - (#Call (List Code)) - (#Unary Code Infix) - (#Binary Infix Code Infix)) - -(def: infix^ - (Parser Infix) - (<| <>.rec (function (_ infix^)) - ($_ <>.or - ($_ <>.either - (<>\map code.bit <code>.bit) - (<>\map code.nat <code>.nat) - (<>\map code.int <code>.int) - (<>\map code.rev <code>.rev) - (<>\map code.frac <code>.frac) - (<>\map code.text <code>.text) - (<>\map code.identifier <code>.identifier) - (<>\map code.tag <code>.tag)) - (<code>.form (<>.many <code>.any)) - (<code>.tuple (<>.and <code>.any infix^)) - (<code>.tuple ($_ <>.either - (do <>.monad - [_ (<code>.this! (' #and)) - init_subject infix^ - init_op <code>.any - init_param infix^ - steps (<>.some (<>.and <code>.any infix^))] - (wrap (product.right (list\fold (function (_ [op param] [subject [_subject _op _param]]) - [param [(#Binary _subject _op _param) - (` and) - (#Binary subject op param)]]) - [init_param [init_subject init_op init_param]] - steps)))) - (do <>.monad - [init_subject infix^ - init_op <code>.any - init_param infix^ - steps (<>.some (<>.and <code>.any infix^))] - (wrap (list\fold (function (_ [op param] [_subject _op _param]) - [(#Binary _subject _op _param) op param]) - [init_subject init_op init_param] - steps))) - )) - ))) - -(def: (to_prefix infix) - (-> Infix Code) - (case infix - (#Const value) - value - - (#Call parts) - (code.form parts) - - (#Unary op subject) - (` ((~ op) (~ (to_prefix subject)))) - - (#Binary left op right) - (` ((~ op) (~ (to_prefix right)) (~ (to_prefix left)))) - )) - -(syntax: #export (infix {expr infix^}) - {#.doc (doc "Infix math syntax." - (infix [x i.* +10]) - (infix [[x i.+ y] i.* [x i.- y]]) - (infix [sin [x i.+ y]]) - (infix [[x n.< y] and [y n.< z]]) - (infix [#and x n.< y n.< z]) - (infix [(n.* 3 9) gcd 450]) - - "The rules for infix syntax are simple." - "If you want your binary function to work well with it." - "Then take the argument to the right (y) as your first argument," - "and take the argument to the left (x) as your second argument.")} - (wrap (list (..to_prefix expr)))) diff --git a/stdlib/source/lux/math/logic/continuous.lux b/stdlib/source/lux/math/logic/continuous.lux deleted file mode 100644 index 445bd8447..000000000 --- a/stdlib/source/lux/math/logic/continuous.lux +++ /dev/null @@ -1,39 +0,0 @@ -(.module: - [lux (#- false true or and not) - [abstract - [monoid (#+ Monoid)]] - [math - [number - ["r" rev ("#\." interval)]]]]) - -(def: #export false Rev r\bottom) -(def: #export true Rev r\top) - -(template [<name> <chooser> <monoid> <identity>] - [(def: #export <name> - (-> Rev Rev Rev) - <chooser>) - - (implementation: #export <monoid> - (Monoid Rev) - - (def: identity <identity>) - (def: compose <name>))] - - [or r.max disjunction ..false] - [and r.min conjunction ..true] - ) - -(def: #export (not input) - (-> Rev Rev) - (r.- input ..true)) - -(def: #export (implies consequent antecedent) - (-> Rev Rev Rev) - (or (not antecedent) - consequent)) - -(def: #export (= left right) - (-> Rev Rev Rev) - (and (or (not left) right) - (or left (not right)))) diff --git a/stdlib/source/lux/math/logic/fuzzy.lux b/stdlib/source/lux/math/logic/fuzzy.lux deleted file mode 100644 index 5308786fa..000000000 --- a/stdlib/source/lux/math/logic/fuzzy.lux +++ /dev/null @@ -1,131 +0,0 @@ -(.module: - [lux #* - [abstract - [predicate (#+ Predicate)] - [functor - ["." contravariant]]] - [data - [collection - ["." list] - ["." set (#+ Set)]]] - [math - [number - ["/" rev]]]] - ["." // #_ - ["#" continuous]]) - -(type: #export (Fuzzy a) - (-> a Rev)) - -(implementation: #export functor - (contravariant.Functor Fuzzy) - - (def: (map f fb) - (|>> f fb))) - -(template [<name> <verdict>] - [(def: #export <name> - Fuzzy - (function (_ _) - <verdict>))] - - [empty //.false] - [full //.true] - ) - -(def: #export (membership set elem) - (All [a] (-> (Fuzzy a) a Rev)) - (set elem)) - -(template [<set_composition> <membership_composition>] - [(def: #export (<set_composition> left right) - (All [a] (-> (Fuzzy a) (Fuzzy a) (Fuzzy a))) - (function (_ elem) - (<membership_composition> (left elem) - (right elem))))] - - [union //.or] - [intersection //.and] - ) - -(def: #export (complement set) - (All [a] (-> (Fuzzy a) (Fuzzy a))) - (|>> set //.not)) - -(def: #export (difference sub base) - (All [a] (-> (Fuzzy a) (Fuzzy a) (Fuzzy a))) - (..intersection (..complement sub) base)) - -(def: #export (from_predicate predicate) - (All [a] (-> (Predicate a) (Fuzzy a))) - (function (_ elem) - (if (predicate elem) - //.true - //.false))) - -(def: #export (to_predicate treshold set) - (All [a] (-> Rev (Fuzzy a) (Predicate a))) - (function (_ elem) - (/.> treshold (set elem)))) - -(def: #export from_set - (All [a] (-> (Set a) (Fuzzy a))) - (|>> set.member? ..from_predicate)) - -(def: (ascending from to) - (-> Rev Rev (Fuzzy Rev)) - (let [measure (/.- from to)] - (function (_ elem) - (cond (/.< from elem) - ## below - //.false - - (/.< to elem) - ## in the middle... - (|> elem - (/.- from) - (/./ measure)) - - ## above - //.true)))) - -(def: (descending from to) - (-> Rev Rev (Fuzzy Rev)) - (..complement (..ascending from to))) - -(def: #export (gradient from to) - (-> Rev Rev (Fuzzy Rev)) - (if (/.< to from) - (..ascending from to) - (..descending from to))) - -(template: (!sort_2 <low> <high>) - (if (/.> <low> <high>) - [<low> <high>] - [<high> <low>])) - -(def: #export (triangle bottom middle top) - (-> Rev Rev Rev (Fuzzy Rev)) - (let [[low_0 high_0] (!sort_2 bottom middle) - [bottom' high_1] (!sort_2 low_0 top) - [middle' top'] (!sort_2 high_0 high_1)] - (..intersection (..ascending bottom' middle') - (..descending middle' top')))) - -(def: #export (trapezoid bottom middle_bottom middle_top top) - (-> Rev Rev Rev Rev (Fuzzy Rev)) - (let [[low_0 high_0] (!sort_2 bottom middle_bottom) - [low_1 high_1] (!sort_2 middle_top top) - [bottom' middle_0] (!sort_2 low_0 low_1) - [middle_1 top'] (!sort_2 high_0 high_1) - [middle_bottom' middle_top'] (!sort_2 middle_0 middle_1)] - (..intersection (..ascending bottom' middle_bottom') - (..descending middle_top' top')))) - -(def: #export (cut treshold set) - (All [a] (-> Rev (Fuzzy a) (Fuzzy a))) - (function (_ elem) - (let [membership (set elem)] - (if (/.< treshold membership) - //.false - (|> membership (/.- treshold) (/.* //.true)))))) diff --git a/stdlib/source/lux/math/modular.lux b/stdlib/source/lux/math/modular.lux deleted file mode 100644 index 5ecfb6763..000000000 --- a/stdlib/source/lux/math/modular.lux +++ /dev/null @@ -1,156 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [order (#+ Order)] - [monoid (#+ Monoid)] - [codec (#+ Codec)] - [monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["<>" parser - ["<.>" text (#+ Parser)] - ["<.>" code]]] - [data - ["." product] - ["." text ("#\." monoid)]] - [macro - [syntax (#+ syntax:)] - ["." code]] - [math - [number - ["i" int ("#\." decimal)]]] - [type - abstract]] - ["." // #_ - ["#" modulus (#+ Modulus)]]) - -(abstract: #export (Mod m) - {#modulus (Modulus m) - #value Int} - - {#.doc "A number under a modulus."} - - (def: #export (modular modulus value) - (All [%] (-> (Modulus %) Int (Mod %))) - (:abstraction {#modulus modulus - #value (i.mod (//.divisor modulus) value)})) - - (template [<name> <type> <side>] - [(def: #export <name> - (All [%] (-> (Mod %) <type>)) - (|>> :representation <side>))] - - [modulus (Modulus %) product.left] - [value Int product.right] - ) - - (exception: #export [%] (incorrect_modulus {modulus (Modulus %)} - {parsed Int}) - (exception.report - ["Expected" (i\encode (//.divisor modulus))] - ["Actual" (i\encode parsed)])) - - (def: separator - " mod ") - - (def: intL - (Parser Int) - (<>.codec i.decimal - (<text>.and (<text>.one_of "-+") (<text>.many <text>.decimal)))) - - (implementation: #export (codec expected) - (All [%] (-> (Modulus %) (Codec Text (Mod %)))) - - (def: (encode modular) - (let [[_ value] (:representation modular)] - ($_ text\compose - (i\encode value) - ..separator - (i\encode (//.divisor expected))))) - - (def: decode - (<text>.run - (do <>.monad - [[value _ actual] ($_ <>.and intL (<text>.this ..separator) intL) - _ (<>.assert (exception.construct ..incorrect_modulus [expected actual]) - (i.= (//.divisor expected) actual))] - (wrap (..modular expected value)))))) - - (template [<name> <op>] - [(def: #export (<name> reference subject) - (All [%] (-> (Mod %) (Mod %) Bit)) - (let [[_ reference] (:representation reference) - [_ subject] (:representation subject)] - (<op> reference subject)))] - - [= i.=] - [< i.<] - [<= i.<=] - [> i.>] - [>= i.>=] - ) - - (implementation: #export equivalence - (All [%] (Equivalence (Mod %))) - - (def: = ..=)) - - (implementation: #export order - (All [%] (Order (Mod %))) - - (def: &equivalence ..equivalence) - (def: < ..<)) - - (template [<name> <op>] - [(def: #export (<name> param subject) - (All [%] (-> (Mod %) (Mod %) (Mod %))) - (let [[modulus param] (:representation param) - [_ subject] (:representation subject)] - (:abstraction {#modulus modulus - #value (|> subject - (<op> param) - (i.mod (//.divisor modulus)))})))] - - [+ i.+] - [- i.-] - [* i.*] - ) - - (template [<composition> <identity> <monoid>] - [(implementation: #export (<monoid> modulus) - (All [%] (-> (Modulus %) (Monoid (Mod %)))) - - (def: identity - (..modular modulus <identity>)) - (def: compose - <composition>))] - - [..+ +0 addition] - [..* +1 multiplication] - ) - - (def: #export (inverse modular) - (All [%] (-> (Mod %) (Maybe (Mod %)))) - (let [[modulus value] (:representation modular) - [[vk mk] gcd] (i.extended_gcd value (//.divisor modulus))] - (case gcd - +1 (#.Some (..modular modulus vk)) - _ #.None))) - ) - -(exception: #export [r% s%] (moduli_are_not_equal {reference (Modulus r%)} - {subject (Modulus s%)}) - (exception.report - ["Reference" (i\encode (//.divisor reference))] - ["Subject" (i\encode (//.divisor subject))])) - -(def: #export (adapter reference subject) - (All [r% s%] - (-> (Modulus r%) (Modulus s%) - (Try (-> (Mod s%) (Mod r%))))) - (if (//.= reference subject) - (#try.Success (|>> ..value - (..modular reference))) - (exception.throw ..moduli_are_not_equal [reference subject]))) diff --git a/stdlib/source/lux/math/modulus.lux b/stdlib/source/lux/math/modulus.lux deleted file mode 100644 index 00949f6ce..000000000 --- a/stdlib/source/lux/math/modulus.lux +++ /dev/null @@ -1,55 +0,0 @@ -(.module: - [lux #* - ["." meta] - [abstract - [monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)] - [parser - ["<.>" code]]] - [macro - [syntax (#+ syntax:)] - ["." code]] - [math - [number - ["i" int]]] - [type - abstract]]) - -(exception: #export zero_cannot_be_a_modulus) - -(abstract: #export (Modulus m) - Int - - {#.doc (doc "A number used as a modulus in modular arithmetic." - "It cannot be 0.")} - - (def: #export (modulus value) - (Ex [m] (-> Int (Try (Modulus m)))) - (if (i.= +0 value) - (exception.throw ..zero_cannot_be_a_modulus []) - (#try.Success (:abstraction value)))) - - (def: #export divisor - (All [m] (-> (Modulus m) Int)) - (|>> :representation)) - - (def: #export (= reference subject) - (All [r s] (-> (Modulus r) (Modulus s) Bit)) - (i.= (:representation reference) - (:representation subject))) - - (def: #export (congruent? modulus reference subject) - (All [m] (-> (Modulus m) Int Int Bit)) - (|> subject - (i.- reference) - (i.% (:representation modulus)) - (i.= +0))) - ) - -(syntax: #export (literal {divisor <code>.int}) - (meta.lift - (do try.monad - [_ (..modulus divisor)] - (wrap (list (` ((~! try.assume) (..modulus (~ (code.int divisor)))))))))) diff --git a/stdlib/source/lux/math/number.lux b/stdlib/source/lux/math/number.lux deleted file mode 100644 index a96c450ee..000000000 --- a/stdlib/source/lux/math/number.lux +++ /dev/null @@ -1,86 +0,0 @@ -(.module: - [lux #* - [abstract - [codec (#+ Codec)]] - [control - ["." try (#+ Try)]] - [data - ["." text]]] - ["." / #_ - ["#." nat] - ["#." int] - ["#." rev] - ["#." frac]]) - -(macro: (encoding_doc tokens state) - (case tokens - (^ (list [location (#.Text encoding)] example_1 example_2)) - (let [encoding ($_ "lux text concat" - "Given syntax for a " - encoding - " number, generates a Nat, an Int, a Rev or a Frac.") - separators "Allows for the presence of commas among the digits." - description [location (#.Text ($_ "lux text concat" encoding " " separators))]] - (#try.Success [state (list (` (doc (~ description) - (~ example_1) - (~ example_2))))])) - - _ - (#try.Failure "Wrong syntax for 'encoding_doc'."))) - -(def: separator - ",") - -(def: (separator_prefixed? number) - (-> Text Bit) - (case ("lux text index" 0 ..separator number) - (#.Some 0) - #1 - - _ - #0)) - -(def: clean_separators - (-> Text Text) - (text.replace_all ..separator "")) - -(template [<macro> <nat> <int> <rev> <frac> <error> <doc>] - [(macro: #export (<macro> tokens state) - {#.doc <doc>} - (case tokens - (#.Cons [meta (#.Text repr')] #.Nil) - (if (..separator_prefixed? repr') - (#try.Failure <error>) - (let [repr (..clean_separators repr')] - (case (\ <nat> decode repr) - (#try.Success value) - (#try.Success [state (list [meta (#.Nat value)])]) - - (^multi (#try.Failure _) - [(\ <int> decode repr) (#try.Success value)]) - (#try.Success [state (list [meta (#.Int value)])]) - - (^multi (#try.Failure _) - [(\ <rev> decode repr) (#try.Success value)]) - (#try.Success [state (list [meta (#.Rev value)])]) - - (^multi (#try.Failure _) - [(\ <frac> decode repr) (#try.Success value)]) - (#try.Success [state (list [meta (#.Frac value)])]) - - _ - (#try.Failure <error>)))) - - _ - (#try.Failure <error>)))] - - [bin /nat.binary /int.binary /rev.binary /frac.binary - "Invalid binary syntax." - (encoding_doc "binary" (bin "11001001") (bin "11,00,10,01"))] - [oct /nat.octal /int.octal /rev.octal /frac.octal - "Invalid octal syntax." - (encoding_doc "octal" (oct "615243") (oct "615,243"))] - [hex /nat.hex /int.hex /rev.hex /frac.hex - "Invalid hexadecimal syntax." - (encoding_doc "hexadecimal" (hex "deadBEEF") (hex "dead,BEEF"))] - ) diff --git a/stdlib/source/lux/math/number/complex.lux b/stdlib/source/lux/math/number/complex.lux deleted file mode 100644 index 279f6177a..000000000 --- a/stdlib/source/lux/math/number/complex.lux +++ /dev/null @@ -1,315 +0,0 @@ -(.module: {#.doc "Complex arithmetic."} - [lux #* - ["." math] - [abstract - [equivalence (#+ Equivalence)] - [codec (#+ Codec)] - ["M" monad (#+ Monad do)]] - [control - ["<>" parser - ["<.>" code (#+ Parser)]]] - [data - ["." maybe] - [collection - ["." list ("#\." functor)]]] - [macro - [syntax (#+ syntax:)] - ["." code]] - [math - [number - ["n" nat] - ["f" frac] - ["." int]]]]) - -(type: #export Complex - {#real Frac - #imaginary Frac}) - -(syntax: #export (complex real {?imaginary (<>.maybe <code>.any)}) - {#.doc (doc "Complex literals." - (complex real imaginary) - "The imaginary part can be omitted if it's 0." - (complex real))} - (wrap (list (` {#..real (~ real) - #..imaginary (~ (maybe.default (' +0.0) - ?imaginary))})))) - -(def: #export i - (..complex +0.0 +1.0)) - -(def: #export +one - (..complex +1.0 +0.0)) - -(def: #export -one - (..complex -1.0 +0.0)) - -(def: #export zero - (..complex +0.0 +0.0)) - -(def: #export (not_a_number? complex) - (or (f.not_a_number? (get@ #real complex)) - (f.not_a_number? (get@ #imaginary complex)))) - -(def: #export (= param input) - (-> Complex Complex Bit) - (and (f.= (get@ #real param) - (get@ #real input)) - (f.= (get@ #imaginary param) - (get@ #imaginary input)))) - -(template [<name> <op>] - [(def: #export (<name> param input) - (-> Complex Complex Complex) - {#real (<op> (get@ #real param) - (get@ #real input)) - #imaginary (<op> (get@ #imaginary param) - (get@ #imaginary input))})] - - [+ f.+] - [- f.-] - ) - -(implementation: #export equivalence - (Equivalence Complex) - - (def: = ..=)) - -(template [<name> <transform>] - [(def: #export <name> - (-> Complex Complex) - (|>> (update@ #real <transform>) - (update@ #imaginary <transform>)))] - - [negate f.negate] - [signum f.signum] - ) - -(def: #export conjugate - (-> Complex Complex) - (update@ #imaginary f.negate)) - -(def: #export (*' param input) - (-> Frac Complex Complex) - {#real (f.* param - (get@ #real input)) - #imaginary (f.* param - (get@ #imaginary input))}) - -(def: #export (* param input) - (-> Complex Complex Complex) - {#real (f.- (f.* (get@ #imaginary param) - (get@ #imaginary input)) - (f.* (get@ #real param) - (get@ #real input))) - #imaginary (f.+ (f.* (get@ #real param) - (get@ #imaginary input)) - (f.* (get@ #imaginary param) - (get@ #real input)))}) - -(def: #export (/ param input) - (-> Complex Complex Complex) - (let [(^slots [#real #imaginary]) param] - (if (f.< (f.abs imaginary) - (f.abs real)) - (let [quot (f./ imaginary real) - denom (|> real (f.* quot) (f.+ imaginary))] - {#real (|> (get@ #real input) (f.* quot) (f.+ (get@ #imaginary input)) (f./ denom)) - #imaginary (|> (get@ #imaginary input) (f.* quot) (f.- (get@ #real input)) (f./ denom))}) - (let [quot (f./ real imaginary) - denom (|> imaginary (f.* quot) (f.+ real))] - {#real (|> (get@ #imaginary input) (f.* quot) (f.+ (get@ #real input)) (f./ denom)) - #imaginary (|> (get@ #imaginary input) (f.- (f.* quot (get@ #real input))) (f./ denom))})))) - -(def: #export (/' param subject) - (-> Frac Complex Complex) - (let [(^slots [#real #imaginary]) subject] - {#real (f./ param real) - #imaginary (f./ param imaginary)})) - -(def: #export (% param input) - (-> Complex Complex Complex) - (let [scaled (/ param input) - quotient (|> scaled - (update@ #real math.floor) - (update@ #imaginary math.floor))] - (- (* quotient param) - input))) - -(def: #export (cos subject) - (-> Complex Complex) - (let [(^slots [#real #imaginary]) subject] - {#real (f.* (math.cosh imaginary) - (math.cos real)) - #imaginary (f.negate (f.* (math.sinh imaginary) - (math.sin real)))})) - -(def: #export (cosh subject) - (-> Complex Complex) - (let [(^slots [#real #imaginary]) subject] - {#real (f.* (math.cos imaginary) - (math.cosh real)) - #imaginary (f.* (math.sin imaginary) - (math.sinh real))})) - -(def: #export (sin subject) - (-> Complex Complex) - (let [(^slots [#real #imaginary]) subject] - {#real (f.* (math.cosh imaginary) - (math.sin real)) - #imaginary (f.* (math.sinh imaginary) - (math.cos real))})) - -(def: #export (sinh subject) - (-> Complex Complex) - (let [(^slots [#real #imaginary]) subject] - {#real (f.* (math.cos imaginary) - (math.sinh real)) - #imaginary (f.* (math.sin imaginary) - (math.cosh real))})) - -(def: #export (tan subject) - (-> Complex Complex) - (let [(^slots [#real #imaginary]) subject - r2 (f.* +2.0 real) - i2 (f.* +2.0 imaginary) - d (f.+ (math.cos r2) (math.cosh i2))] - {#real (f./ d (math.sin r2)) - #imaginary (f./ d (math.sinh i2))})) - -(def: #export (tanh subject) - (-> Complex Complex) - (let [(^slots [#real #imaginary]) subject - r2 (f.* +2.0 real) - i2 (f.* +2.0 imaginary) - d (f.+ (math.cosh r2) (math.cos i2))] - {#real (f./ d (math.sinh r2)) - #imaginary (f./ d (math.sin i2))})) - -(def: #export (abs subject) - (-> Complex Frac) - (let [(^slots [#real #imaginary]) subject] - (if (f.< (f.abs imaginary) - (f.abs real)) - (if (f.= +0.0 imaginary) - (f.abs real) - (let [q (f./ imaginary real)] - (f.* (math.pow +0.5 (f.+ +1.0 (f.* q q))) - (f.abs imaginary)))) - (if (f.= +0.0 real) - (f.abs imaginary) - (let [q (f./ real imaginary)] - (f.* (math.pow +0.5 (f.+ +1.0 (f.* q q))) - (f.abs real))))))) - -(def: #export (exp subject) - (-> Complex Complex) - (let [(^slots [#real #imaginary]) subject - r_exp (math.exp real)] - {#real (f.* r_exp (math.cos imaginary)) - #imaginary (f.* r_exp (math.sin imaginary))})) - -(def: #export (log subject) - (-> Complex Complex) - (let [(^slots [#real #imaginary]) subject] - {#real (|> subject ..abs math.log) - #imaginary (math.atan/2 real imaginary)})) - -(template [<name> <type> <op>] - [(def: #export (<name> param input) - (-> <type> Complex Complex) - (|> input log (<op> param) exp))] - - [pow Complex ..*] - [pow' Frac ..*'] - ) - -(def: (copy_sign sign magnitude) - (-> Frac Frac Frac) - (f.* (f.signum sign) magnitude)) - -(def: #export (root/2 input) - (-> Complex Complex) - (let [(^slots [#real #imaginary]) input - t (|> input ..abs (f.+ (f.abs real)) (f./ +2.0) (math.pow +0.5))] - (if (f.>= +0.0 real) - {#real t - #imaginary (f./ (f.* +2.0 t) - imaginary)} - {#real (f./ (f.* +2.0 t) - (f.abs imaginary)) - #imaginary (f.* t (..copy_sign imaginary +1.0))}))) - -(def: (root/2-1z input) - (-> Complex Complex) - (|> (complex +1.0) (- (* input input)) ..root/2)) - -(def: #export (reciprocal (^slots [#real #imaginary])) - (-> Complex Complex) - (if (f.< (f.abs imaginary) - (f.abs real)) - (let [q (f./ imaginary real) - scale (f./ (|> real (f.* q) (f.+ imaginary)) - +1.0)] - {#real (f.* q scale) - #imaginary (f.negate scale)}) - (let [q (f./ real imaginary) - scale (f./ (|> imaginary (f.* q) (f.+ real)) - +1.0)] - {#real scale - #imaginary (|> scale f.negate (f.* q))}))) - -(def: #export (acos input) - (-> Complex Complex) - (|> input - (..+ (|> input ..root/2-1z (..* ..i))) - ..log - (..* (..negate ..i)))) - -(def: #export (asin input) - (-> Complex Complex) - (|> input - ..root/2-1z - (..+ (..* ..i input)) - ..log - (..* (..negate ..i)))) - -(def: #export (atan input) - (-> Complex Complex) - (|> input - (..+ ..i) - (../ (..- input ..i)) - ..log - (..* (../ (..complex +2.0) ..i)))) - -(def: #export (argument (^slots [#real #imaginary])) - (-> Complex Frac) - (math.atan/2 real imaginary)) - -(def: #export (roots nth input) - (-> Nat Complex (List Complex)) - (if (n.= 0 nth) - (list) - (let [r_nth (|> nth .int int.frac) - nth_root_of_abs (|> input ..abs (math.pow (f./ r_nth +1.0))) - nth_phi (|> input ..argument (f./ r_nth)) - slice (|> math.pi (f.* +2.0) (f./ r_nth))] - (|> (list.indices nth) - (list\map (function (_ nth') - (let [inner (|> nth' .int int.frac - (f.* slice) - (f.+ nth_phi)) - real (f.* nth_root_of_abs - (math.cos inner)) - imaginary (f.* nth_root_of_abs - (math.sin inner))] - {#real real - #imaginary imaginary}))))))) - -(def: #export (approximately? margin_of_error standard value) - (-> Frac Complex Complex Bit) - (and (f.approximately? margin_of_error - (get@ #..real standard) - (get@ #..real value)) - (f.approximately? margin_of_error - (get@ #..imaginary standard) - (get@ #..imaginary value)))) diff --git a/stdlib/source/lux/math/number/frac.lux b/stdlib/source/lux/math/number/frac.lux deleted file mode 100644 index 4c25d5ca7..000000000 --- a/stdlib/source/lux/math/number/frac.lux +++ /dev/null @@ -1,446 +0,0 @@ -(.module: - [lux (#- nat int rev) - ["@" target] - [abstract - [hash (#+ Hash)] - [monoid (#+ Monoid)] - [equivalence (#+ Equivalence)] - [codec (#+ Codec)] - [predicate (#+ Predicate)] - [order (#+ Order)] - [monad (#+ do)]] - [control - ["." try (#+ Try)]] - [data - ["." maybe] - ["." text]]] - ["." // #_ - ["#." i64] - ["#." nat] - ["#." int] - ["#." rev] - ["/#" //]]) - -(def: #export (= reference sample) - {#.doc "Frac(tion) equivalence."} - (-> Frac Frac Bit) - ("lux f64 =" reference sample)) - -(def: #export (< reference sample) - {#.doc "Frac(tion) less-than."} - (-> Frac Frac Bit) - ("lux f64 <" reference sample)) - -(def: #export (<= reference sample) - {#.doc "Frac(tion) less-than or equal."} - (-> Frac Frac Bit) - (or ("lux f64 <" reference sample) - ("lux f64 =" reference sample))) - -(def: #export (> reference sample) - {#.doc "Frac(tion) greater-than."} - (-> Frac Frac Bit) - ("lux f64 <" sample reference)) - -(def: #export (>= reference sample) - {#.doc "Frac(tion) greater-than or equal."} - (-> Frac Frac Bit) - (or ("lux f64 <" sample reference) - ("lux f64 =" sample reference))) - -(template [<comparison> <name>] - [(def: #export <name> - (Predicate Frac) - (<comparison> +0.0))] - - [..> positive?] - [..< negative?] - [..= zero?] - ) - -(template [<name> <op> <doc>] - [(def: #export (<name> param subject) - {#.doc <doc>} - (-> Frac Frac Frac) - (<op> param subject))] - - [+ "lux f64 +" "Frac(tion) addition."] - [- "lux f64 -" "Frac(tion) substraction."] - [* "lux f64 *" "Frac(tion) multiplication."] - [/ "lux f64 /" "Frac(tion) division."] - [% "lux f64 %" "Frac(tion) remainder."] - ) - -(def: #export (/% param subject) - (-> Frac Frac [Frac Frac]) - [(../ param subject) - (..% param subject)]) - -(def: #export negate - (-> Frac Frac) - (..* -1.0)) - -(def: #export (abs x) - (-> Frac Frac) - (if (..< +0.0 x) - (..* -1.0 x) - x)) - -(def: #export (signum x) - (-> Frac Frac) - (cond (..= +0.0 x) +0.0 - (..< +0.0 x) -1.0 - ## else - +1.0)) - -(def: min_exponent -1022) -(def: max_exponent (//int.frac +1023)) - -(template [<name> <test> <doc>] - [(def: #export (<name> left right) - {#.doc <doc>} - (-> Frac Frac Frac) - (if (<test> right left) - left - right))] - - [min ..< "Frac(tion) minimum."] - [max ..> "Frac(tion) minimum."] - ) - -(def: #export nat - (-> Frac Nat) - (|>> "lux f64 i64" .nat)) - -(def: #export int - (-> Frac Int) - (|>> "lux f64 i64")) - -(def: mantissa_size Nat 52) -(def: exponent_size Nat 11) - -(def: frac_denominator - (|> -1 - ("lux i64 right-shift" ..exponent_size) - "lux i64 f64")) - -(def: #export rev - (-> Frac Rev) - (|>> ..abs - (..% +1.0) - (..* ..frac_denominator) - "lux f64 i64" - ("lux i64 left-shift" ..exponent_size))) - -(implementation: #export equivalence - (Equivalence Frac) - - (def: = ..=)) - -(implementation: #export order - (Order Frac) - - (def: &equivalence ..equivalence) - (def: < ..<)) - -(def: #export smallest - Frac - (///.pow (//int.frac (//int.- (.int ..mantissa_size) ..min_exponent)) - +2.0)) - -(def: #export biggest - Frac - (let [f2^-52 (///.pow (//nat.frac (//nat.- ..mantissa_size 0)) +2.0) - f2^+1023 (///.pow ..max_exponent +2.0)] - (|> +2.0 - (..- f2^-52) - (..* f2^+1023)))) - -(template [<name> <compose> <identity>] - [(implementation: #export <name> - (Monoid Frac) - - (def: identity <identity>) - (def: compose <compose>))] - - [addition ..+ +0.0] - [multiplication ..* +1.0] - [minimum ..min ..biggest] - [maximum ..max (..* -1.0 ..biggest)] - ) - -(template [<name> <numerator> <doc>] - [(def: #export <name> - {#.doc <doc>} - Frac - (../ +0.0 <numerator>))] - - [not_a_number +0.0 "Not a number."] - [positive_infinity +1.0 "Positive infinity."] - ) - -(def: #export negative_infinity - {#.doc "Negative infinity."} - Frac - (..* -1.0 ..positive_infinity)) - -(def: #export (not_a_number? number) - {#.doc "Tests whether a frac is actually not-a-number."} - (-> Frac Bit) - (not (..= number number))) - -(def: #export (number? value) - (-> Frac Bit) - (not (or (..not_a_number? value) - (..= ..positive_infinity value) - (..= ..negative_infinity value)))) - -(implementation: #export decimal - (Codec Text Frac) - - (def: (encode x) - (case x - -0.0 (let [output ("lux f64 encode" x)] - (if (text.starts_with? "-" output) - output - ("lux text concat" "+" output))) - _ (if (..< +0.0 x) - ("lux f64 encode" x) - ("lux text concat" "+" ("lux f64 encode" x))))) - - (def: (decode input) - (case ("lux f64 decode" [input]) - (#.Some value) - (#try.Success value) - - #.None - (#try.Failure "Could not decode Frac")))) - -(def: log/2 - (-> Frac Frac) - (|>> ///.log - (../ (///.log +2.0)))) - -(def: double_bias Nat 1023) - -(def: exponent_mask (//i64.mask ..exponent_size)) - -(def: exponent_offset ..mantissa_size) -(def: sign_offset (//nat.+ ..exponent_size ..exponent_offset)) - -(template [<cast> <hex> <name>] - [(def: <name> (|> <hex> (\ //nat.hex decode) try.assume <cast>))] - - [.i64 "FFF8000000000000" not_a_number_bits] - [.i64 "7FF0000000000000" positive_infinity_bits] - [.i64 "FFF0000000000000" negative_infinity_bits] - [.i64 "0000000000000000" positive_zero_bits] - [.i64 "8000000000000000" negative_zero_bits] - [.nat "7FF" special_exponent_bits] - ) - -(def: smallest_exponent - (..log/2 ..smallest)) - -(def: #export (to_bits input) - (-> Frac I64) - (.i64 (cond (..not_a_number? input) - ..not_a_number_bits - - (..= positive_infinity input) - ..positive_infinity_bits - - (..= negative_infinity input) - ..negative_infinity_bits - - (..= +0.0 input) - (let [reciprocal (../ input +1.0)] - (if (..= positive_infinity reciprocal) - ## Positive zero - ..positive_zero_bits - ## Negative zero - ..negative_zero_bits)) - - ## else - (let [sign_bit (if (..< -0.0 input) - 1 - 0) - input (..abs input) - exponent (|> input - ..log/2 - ///.floor - (..min ..max_exponent)) - min_gap (..- (//int.frac ..min_exponent) exponent) - power (|> (//nat.frac ..mantissa_size) - (..+ (..min +0.0 min_gap)) - (..- exponent)) - max_gap (..- ..max_exponent power) - mantissa (|> input - (..* (///.pow (..min ..max_exponent power) +2.0)) - (..* (if (..> +0.0 max_gap) - (///.pow max_gap +2.0) - +1.0))) - exponent_bits (|> (if (..< +0.0 min_gap) - (|> (..int exponent) - (//int.- (..int min_gap)) - dec) - (..int exponent)) - (//int.+ (.int ..double_bias)) - (//i64.and ..exponent_mask)) - mantissa_bits (..int mantissa)] - ($_ //i64.or - (//i64.left_shift ..sign_offset sign_bit) - (//i64.left_shift ..exponent_offset exponent_bits) - (//i64.clear ..mantissa_size mantissa_bits))) - ))) - -(template [<getter> <size> <offset>] - [(def: <getter> - (-> (I64 Any) I64) - (let [mask (|> 1 (//i64.left_shift <size>) dec (//i64.left_shift <offset>))] - (|>> (//i64.and mask) (//i64.right_shift <offset>) .i64)))] - - [mantissa ..mantissa_size 0] - [exponent ..exponent_size ..mantissa_size] - [sign 1 ..sign_offset] - ) - -(def: #export (from_bits input) - (-> I64 Frac) - (case [(: Nat (..exponent input)) - (: Nat (..mantissa input)) - (: Nat (..sign input))] - (^ [(static ..special_exponent_bits) 0 0]) - ..positive_infinity - - (^ [(static ..special_exponent_bits) 0 1]) - ..negative_infinity - - (^ [(static ..special_exponent_bits) _ _]) - ..not_a_number - - ## Positive zero - [0 0 0] +0.0 - ## Negative zero - [0 0 1] (..* -1.0 +0.0) - - [E M S] - (let [sign (if (//nat.= 0 S) - +1.0 - -1.0) - [mantissa power] (if (//nat.< ..mantissa_size E) - [(if (//nat.= 0 E) - M - (//i64.set ..mantissa_size M)) - (|> E - (//nat.- ..double_bias) - .int - (//int.max ..min_exponent) - (//int.- (.int ..mantissa_size)))] - [(//i64.set ..mantissa_size M) - (|> E (//nat.- ..double_bias) (//nat.- ..mantissa_size) .int)]) - exponent (///.pow (//int.frac power) +2.0)] - (|> (//nat.frac mantissa) - (..* exponent) - (..* sign))))) - -(def: (split_exponent codec representation) - (-> (Codec Text Nat) Text (Try [Text Int])) - (case [("lux text index" 0 "e+" representation) - ("lux text index" 0 "E+" representation) - ("lux text index" 0 "e-" representation) - ("lux text index" 0 "E-" representation)] - (^template [<factor> <patterns>] - [<patterns> - (do try.monad - [#let [after_offset (//nat.+ 2 split_index) - after_length (//nat.- after_offset ("lux text size" representation))] - exponent (|> representation - ("lux text clip" after_offset after_length) - (\ codec decode))] - (wrap [("lux text clip" 0 split_index representation) - (//int.* <factor> (.int exponent))]))]) - ([+1 (^or [(#.Some split_index) #.None #.None #.None] - [#.None (#.Some split_index) #.None #.None])] - [-1 (^or [#.None #.None (#.Some split_index) #.None] - [#.None #.None #.None (#.Some split_index)])]) - - _ - (#try.Success [representation +0]))) - -(template [<struct> <nat> <int> <error>] - [(implementation: #export <struct> - (Codec Text Frac) - - (def: (encode value) - (let [bits (..to_bits value) - mantissa (..mantissa bits) - exponent (//int.- (.int ..double_bias) (..exponent bits)) - sign (..sign bits)] - ($_ "lux text concat" - (case (.nat sign) - 1 "-" - 0 "+" - _ (undefined)) - (\ <nat> encode (.nat mantissa)) - ".0E" - (\ <int> encode exponent)))) - - (def: (decode representation) - (let [negative? (text.starts_with? "-" representation) - positive? (text.starts_with? "+" representation)] - (if (or negative? positive?) - (do {! try.monad} - [[mantissa exponent] (..split_exponent <nat> representation) - [whole decimal] (case ("lux text index" 0 "." mantissa) - (#.Some split_index) - (do ! - [#let [after_offset (inc split_index) - after_length (//nat.- after_offset ("lux text size" mantissa))] - decimal (|> mantissa - ("lux text clip" after_offset after_length) - (\ <nat> decode))] - (wrap [("lux text clip" 0 split_index mantissa) - decimal])) - - #.None - (#try.Failure ("lux text concat" <error> representation))) - #let [whole ("lux text clip" 1 (dec ("lux text size" whole)) whole)] - mantissa (\ <nat> decode (case decimal - 0 whole - _ ("lux text concat" whole (\ <nat> encode decimal)))) - #let [sign (if negative? 1 0)]] - (wrap (..from_bits - ($_ //i64.or - (//i64.left_shift ..sign_offset (.i64 sign)) - (//i64.left_shift ..mantissa_size (.i64 (//int.+ (.int ..double_bias) exponent))) - (//i64.clear ..mantissa_size (.i64 mantissa)))))) - (#try.Failure ("lux text concat" <error> representation))))))] - - [binary //nat.binary //int.binary "Invalid binary syntax: "] - [octal //nat.octal //int.octal "Invalid octaladecimal syntax: "] - [hex //nat.hex //int.hex "Invalid hexadecimal syntax: "] - ) - -(implementation: #export hash - (Hash Frac) - - (def: &equivalence ..equivalence) - (def: hash ..to_bits)) - -(def: #export (approximately? margin_of_error standard value) - (-> Frac Frac Frac Bit) - (|> value - (..- standard) - ..abs - (..< margin_of_error))) - -(def: #export (mod divisor dividend) - (All [m] (-> Frac Frac Frac)) - (let [remainder (..% divisor dividend)] - (if (or (and (..< +0.0 divisor) - (..> +0.0 remainder)) - (and (..> +0.0 divisor) - (..< +0.0 remainder))) - (..+ divisor remainder) - remainder))) diff --git a/stdlib/source/lux/math/number/i16.lux b/stdlib/source/lux/math/number/i16.lux deleted file mode 100644 index ba4f9cd02..000000000 --- a/stdlib/source/lux/math/number/i16.lux +++ /dev/null @@ -1,23 +0,0 @@ -(.module: - [lux (#- i64) - [abstract - [equivalence (#+ Equivalence)]] - [data - ["." maybe]] - [type (#+ :by_example)]] - [// - ["." i64 (#+ Sub)]]) - -(def: sub (maybe.assume (i64.sub 16))) - -(def: #export I16 - (:by_example [size] - (Sub size) - ..sub - - (I64 size))) - -(def: #export equivalence (Equivalence I16) (\ ..sub &equivalence)) -(def: #export width Nat (\ ..sub width)) -(def: #export i16 (-> I64 I16) (\ ..sub narrow)) -(def: #export i64 (-> I16 I64) (\ ..sub widen)) diff --git a/stdlib/source/lux/math/number/i32.lux b/stdlib/source/lux/math/number/i32.lux deleted file mode 100644 index 9141c175d..000000000 --- a/stdlib/source/lux/math/number/i32.lux +++ /dev/null @@ -1,23 +0,0 @@ -(.module: - [lux (#- i64) - [abstract - [equivalence (#+ Equivalence)]] - [data - ["." maybe]] - [type (#+ :by_example)]] - [// - ["." i64 (#+ Sub)]]) - -(def: sub (maybe.assume (i64.sub 32))) - -(def: #export I32 - (:by_example [size] - (Sub size) - ..sub - - (I64 size))) - -(def: #export equivalence (Equivalence I32) (\ ..sub &equivalence)) -(def: #export width Nat (\ ..sub width)) -(def: #export i32 (-> I64 I32) (\ ..sub narrow)) -(def: #export i64 (-> I32 I64) (\ ..sub widen)) diff --git a/stdlib/source/lux/math/number/i64.lux b/stdlib/source/lux/math/number/i64.lux deleted file mode 100644 index a3b415287..000000000 --- a/stdlib/source/lux/math/number/i64.lux +++ /dev/null @@ -1,213 +0,0 @@ -(.module: - [lux (#- and or not false true) - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)] - [monoid (#+ Monoid)]] - [control - ["." try]]] - [// - ["n" nat]]) - -(def: #export bits_per_byte - 8) - -(def: #export bytes_per_i64 - 8) - -(def: #export width - Nat - (n.* ..bits_per_byte - ..bytes_per_i64)) - -(template [<parameter_type> <name> <op> <doc>] - [(def: #export (<name> parameter subject) - {#.doc <doc>} - (All [s] (-> <parameter_type> (I64 s) (I64 s))) - (<op> parameter subject))] - - [(I64 Any) or "lux i64 or" "Bitwise or."] - [(I64 Any) xor "lux i64 xor" "Bitwise xor."] - [(I64 Any) and "lux i64 and" "Bitwise and."] - - [Nat left_shift "lux i64 left-shift" "Bitwise left-shift."] - [Nat right_shift "lux i64 right-shift" "Unsigned/logic bitwise right-shift."] - ) - -(type: #export Mask - I64) - -(def: #export (bit position) - (-> Nat Mask) - (|> 1 .i64 (..left_shift (n.% ..width position)))) - -(def: #export sign - Mask - (..bit (dec ..width))) - -(def: #export not - {#.doc "Bitwise negation."} - (All [s] (-> (I64 s) (I64 s))) - (..xor (.i64 (dec 0)))) - -(def: #export false - Mask - (.i64 0)) - -(def: #export true - Mask - (..not ..false)) - -(def: #export (mask amount_of_bits) - (-> Nat Mask) - (case amount_of_bits - 0 ..false - bits (case (n.% ..width bits) - 0 ..true - bits (|> 1 .i64 (..left_shift (n.% ..width bits)) .dec)))) - -(def: (add_shift shift value) - (-> Nat Nat Nat) - (|> value (right_shift shift) (n.+ value))) - -(def: #export (count subject) - {#.doc "Count the number of 1s in a bit-map."} - (-> (I64 Any) Nat) - (let [count' (n.- (|> subject (right_shift 1) (..and 6148914691236517205) i64) - (i64 subject))] - (|> count' - (right_shift 2) (..and 3689348814741910323) (n.+ (..and 3689348814741910323 count')) - (add_shift 4) (..and 1085102592571150095) - (add_shift 8) - (add_shift 16) - (add_shift 32) - (..and 127)))) - -(def: #export (clear idx input) - {#.doc "Clear bit at given index."} - (All [s] (-> Nat (I64 s) (I64 s))) - (|> idx ..bit ..not (..and input))) - -(template [<name> <op> <doc>] - [(def: #export (<name> idx input) - {#.doc <doc>} - (All [s] (-> Nat (I64 s) (I64 s))) - (|> idx ..bit (<op> input)))] - - [set ..or "Set bit at given index."] - [flip ..xor "Flip bit at given index."] - ) - -(def: #export (set? idx input) - (-> Nat (I64 Any) Bit) - (|> input (:as I64) (..and (..bit idx)) (n.= 0) .not)) - -(def: #export (clear? idx input) - (-> Nat (I64 Any) Bit) - (.not (..set? idx input))) - -(template [<name> <forward> <backward>] - [(def: #export (<name> distance input) - (All [s] (-> Nat (I64 s) (I64 s))) - (..or (<forward> distance input) - (<backward> (n.- (n.% ..width distance) ..width) input)))] - - [rotate_left ..left_shift ..right_shift] - [rotate_right ..right_shift ..left_shift] - ) - -(def: #export (region size offset) - (-> Nat Nat Mask) - (..left_shift offset (..mask size))) - -(implementation: #export equivalence - (All [a] (Equivalence (I64 a))) - - (def: (= reference sample) - ("lux i64 =" reference sample))) - -(implementation: #export hash - (All [a] (Hash (I64 a))) - - (def: &equivalence ..equivalence) - - (def: hash .nat)) - -(template [<monoid> <identity> <compose>] - [(implementation: #export <monoid> - (All [a] (Monoid (I64 a))) - - (def: identity <identity>) - (def: compose <compose>))] - - [disjunction ..false ..or] - [conjunction ..true ..and] - ) - -(def: #export reverse - (All [a] (-> (I64 a) (I64 a))) - (let [swapper (: (-> Nat (All [a] (-> (I64 a) (I64 a)))) - (function (_ power) - (let [size (..left_shift power 1) - repetitions (: (-> Nat Text Text) - (function (_ times char) - (loop [iterations 1 - output char] - (if (n.< times iterations) - (recur (inc iterations) - ("lux text concat" char output)) - output)))) - pattern (repetitions (n./ (n.+ size size) ..width) - ("lux text concat" - (repetitions size "1") - (repetitions size "0"))) - - high (try.assume (\ n.binary decode pattern)) - low (..rotate_right size high)] - (function (_ value) - (..or (..right_shift size (..and high value)) - (..left_shift size (..and low value))))))) - - swap/01 (swapper 0) - swap/02 (swapper 1) - swap/04 (swapper 2) - swap/08 (swapper 3) - swap/16 (swapper 4) - swap/32 (swapper 5)] - (|>> swap/32 - swap/16 - swap/08 - swap/04 - swap/02 - swap/01))) - -(interface: #export (Sub size) - (: (Equivalence (I64 size)) - &equivalence) - (: Nat - width) - (: (-> I64 (I64 size)) - narrow) - (: (-> (I64 size) I64) - widen)) - -(def: #export (sub width) - (Ex [size] (-> Nat (Maybe (Sub size)))) - (if (.and (n.> 0 width) - (n.< ..width width)) - (let [sign_shift (n.- width ..width) - sign (..bit (dec width)) - mantissa (..mask (dec width)) - co_mantissa (..xor (.i64 -1) mantissa)] - (#.Some (: Sub - (implementation - (def: &equivalence ..equivalence) - (def: width width) - (def: (narrow value) - (..or (|> value (..and ..sign) (..right_shift sign_shift)) - (|> value (..and mantissa)))) - (def: (widen value) - (.i64 (case (.nat (..and sign value)) - 0 value - _ (..or co_mantissa value)))))))) - #.None)) diff --git a/stdlib/source/lux/math/number/i8.lux b/stdlib/source/lux/math/number/i8.lux deleted file mode 100644 index d6184315c..000000000 --- a/stdlib/source/lux/math/number/i8.lux +++ /dev/null @@ -1,23 +0,0 @@ -(.module: - [lux (#- i64) - [abstract - [equivalence (#+ Equivalence)]] - [data - ["." maybe]] - [type (#+ :by_example)]] - [// - ["." i64 (#+ Sub)]]) - -(def: sub (maybe.assume (i64.sub 8))) - -(def: #export I8 - (:by_example [size] - (Sub size) - ..sub - - (I64 size))) - -(def: #export equivalence (Equivalence I8) (\ ..sub &equivalence)) -(def: #export width Nat (\ ..sub width)) -(def: #export i8 (-> I64 I8) (\ ..sub narrow)) -(def: #export i64 (-> I8 I64) (\ ..sub widen)) diff --git a/stdlib/source/lux/math/number/int.lux b/stdlib/source/lux/math/number/int.lux deleted file mode 100644 index 708ab8dd4..000000000 --- a/stdlib/source/lux/math/number/int.lux +++ /dev/null @@ -1,259 +0,0 @@ -(.module: - [lux #* - [abstract - [hash (#+ Hash)] - [enum (#+ Enum)] - [interval (#+ Interval)] - [monoid (#+ Monoid)] - [equivalence (#+ Equivalence)] - [codec (#+ Codec)] - [predicate (#+ Predicate)] - ["." order (#+ Order)]] - [control - ["." try (#+ Try)]] - [data - [text (#+ Char)] - ["." maybe]]] - ["." // #_ - ["#." nat] - ["#." i64]]) - -(def: #export (= reference sample) - {#.doc "Int(eger) equivalence."} - (-> Int Int Bit) - ("lux i64 =" reference sample)) - -(def: #export (< reference sample) - {#.doc "Int(eger) less-than."} - (-> Int Int Bit) - ("lux i64 <" reference sample)) - -(def: #export (<= reference sample) - {#.doc "Int(eger) less-than or equal."} - (-> Int Int Bit) - (if ("lux i64 <" reference sample) - #1 - ("lux i64 =" reference sample))) - -(def: #export (> reference sample) - {#.doc "Int(eger) greater-than."} - (-> Int Int Bit) - ("lux i64 <" sample reference)) - -(def: #export (>= reference sample) - {#.doc "Int(eger) greater-than or equal."} - (-> Int Int Bit) - (if ("lux i64 <" sample reference) - #1 - ("lux i64 =" reference sample))) - -(template [<comparison> <name>] - [(def: #export <name> - (Predicate Int) - (<comparison> +0))] - - [..> positive?] - [..< negative?] - [..= zero?] - ) - -(template [<name> <test> <doc>] - [(def: #export (<name> left right) - {#.doc <doc>} - (-> Int Int Int) - (if (<test> right left) - left - right))] - - [min ..< "Int(eger) minimum."] - [max ..> "Int(eger) maximum."] - ) - -(template [<name> <op> <doc>] - [(def: #export (<name> param subject) - {#.doc <doc>} - (-> Int Int Int) - (<op> param subject))] - - [+ "lux i64 +" "Int(eger) addition."] - [- "lux i64 -" "Int(eger) substraction."] - [* "lux i64 *" "Int(eger) multiplication."] - [/ "lux i64 /" "Int(eger) division."] - [% "lux i64 %" "Int(eger) remainder."] - ) - -(def: #export (/% param subject) - (-> Int Int [Int Int]) - [(../ param subject) - (..% param subject)]) - -(def: #export (negate value) - (-> Int Int) - (..- value +0)) - -(def: #export (abs x) - (-> Int Int) - (if (..< +0 x) - (..* -1 x) - x)) - -(def: #export (signum x) - (-> Int Int) - (cond (..= +0 x) +0 - (..< +0 x) -1 - ## else - +1)) - -## https://rob.conery.io/2018/08/21/mod-and-remainder-are-not-the-same/ -(def: #export (mod divisor dividend) - (All [m] (-> Int Int Int)) - (let [remainder (..% divisor dividend)] - (if (or (and (..< +0 divisor) - (..> +0 remainder)) - (and (..> +0 divisor) - (..< +0 remainder))) - (..+ divisor remainder) - remainder))) - -(def: #export even? - (-> Int Bit) - (|>> (..% +2) ("lux i64 =" +0))) - -(def: #export odd? - (-> Int Bit) - (|>> ..even? not)) - -(def: #export (gcd a b) - {#.doc "Greatest Common Divisor."} - (-> Int Int Int) - (case b - +0 a - _ (gcd b (..% b a)))) - -(def: #export (co-prime? a b) - (-> Int Int Bit) - (..= +1 (..gcd a b))) - -## https://en.wikipedia.org/wiki/Extended_Euclidean_algorithm -(def: #export (extended_gcd a b) - {#.doc "Extended euclidean algorithm."} - (-> Int Int [[Int Int] Int]) - (loop [x +1 x1 +0 - y +0 y1 +1 - a1 a b1 b] - (case b1 - +0 [[x y] a1] - _ (let [q (/ b1 a1)] - (recur x1 (- (* q x1) x) - y1 (- (* q y1) y) - b1 (- (* q b1) a1)))))) - -(def: #export (lcm a b) - {#.doc "Least Common Multiple."} - (-> Int Int Int) - (case [a b] - (^or [_ +0] [+0 _]) - +0 - - _ - (|> a (/ (gcd a b)) (* b)) - )) - -(def: #export frac - (-> Int Frac) - (|>> "lux i64 f64")) - -(implementation: #export equivalence - (Equivalence Int) - - (def: = ..=)) - -(implementation: #export order - (Order Int) - - (def: &equivalence ..equivalence) - (def: < ..<)) - -(implementation: #export enum - (Enum Int) - - (def: &order ..order) - (def: succ inc) - (def: pred dec)) - -## TODO: Find out why the numeric literals fail during JS compilation. -(implementation: #export interval - (Interval Int) - - (def: &enum ..enum) - (def: top - ## +9,223,372,036,854,775,807 - (let [half (//i64.left_shift 62 +1)] - (+ half - (dec half)))) - (def: bottom - ## -9,223,372,036,854,775,808 - (//i64.left_shift 63 +1))) - -(template [<name> <compose> <identity>] - [(implementation: #export <name> - (Monoid Int) - - (def: identity <identity>) - (def: compose <compose>))] - - [addition ..+ +0] - [multiplication ..* +1] - [maximum ..max (\ ..interval bottom)] - [minimum ..min (\ ..interval top)] - ) - -(def: -sign "-") -(def: +sign "+") - -(template [<struct> <codec> <error>] - [(implementation: #export <struct> - (Codec Text Int) - - (def: (encode value) - (if (..< +0 value) - (|> value inc ..negate .nat inc (\ <codec> encode) ("lux text concat" ..-sign)) - (|> value .nat (\ <codec> encode) ("lux text concat" ..+sign)))) - - (def: (decode repr) - (let [input_size ("lux text size" repr)] - (if (//nat.> 1 input_size) - (case ("lux text clip" 0 1 repr) - (^ (static ..+sign)) - (|> repr - ("lux text clip" 1 (dec input_size)) - (\ <codec> decode) - (\ try.functor map .int)) - - (^ (static ..-sign)) - (|> repr - ("lux text clip" 1 (dec input_size)) - (\ <codec> decode) - (\ try.functor map (|>> dec .int ..negate dec))) - - _ - (#try.Failure <error>)) - (#try.Failure <error>)))))] - - [binary //nat.binary "Invalid binary syntax for Int: "] - [octal //nat.octal "Invalid octal syntax for Int: "] - [decimal //nat.decimal "Invalid syntax for Int: "] - [hex //nat.hex "Invalid hexadecimal syntax for Int: "] - ) - -(implementation: #export hash - (Hash Int) - - (def: &equivalence ..equivalence) - (def: hash .nat)) - -(def: #export (right_shift parameter subject) - {#.doc "Signed/arithmetic bitwise right-shift."} - (-> Nat Int Int) - (//i64.or (//i64.and //i64.sign subject) - (//i64.right_shift parameter subject))) diff --git a/stdlib/source/lux/math/number/nat.lux b/stdlib/source/lux/math/number/nat.lux deleted file mode 100644 index 248c169ba..000000000 --- a/stdlib/source/lux/math/number/nat.lux +++ /dev/null @@ -1,379 +0,0 @@ -(.module: - [lux #* - [abstract - [hash (#+ Hash)] - [enum (#+ Enum)] - [interval (#+ Interval)] - [monoid (#+ Monoid)] - [equivalence (#+ Equivalence)] - [codec (#+ Codec)] - ["." order (#+ Order)]] - [control - ["." function] - ["." try (#+ Try)]] - [data - ["." maybe]]]) - -(template [<extension> <output> <name> <documentation>] - [(def: #export (<name> parameter subject) - {#.doc <documentation>} - (-> Nat Nat <output>) - (<extension> parameter subject))] - - ["lux i64 =" Bit = "Nat(ural) equivalence."] - ["lux i64 +" Nat + "Nat(ural) addition."] - ["lux i64 -" Nat - "Nat(ural) substraction."] - ) - -(def: high - (-> (I64 Any) I64) - (|>> ("lux i64 right-shift" 32))) - -(def: low - (-> (I64 Any) I64) - (let [mask (|> 1 ("lux i64 left-shift" 32) ("lux i64 -" 1))] - (|>> ("lux i64 and" mask)))) - -(def: #export (< reference sample) - {#.doc "Nat(ural) less-than."} - (-> Nat Nat Bit) - (let [referenceH (..high reference) - sampleH (..high sample)] - (if ("lux i64 <" referenceH sampleH) - #1 - (if ("lux i64 =" referenceH sampleH) - ("lux i64 <" - (..low reference) - (..low sample)) - #0)))) - -(def: #export (<= reference sample) - {#.doc "Nat(ural) less-than or equal."} - (-> Nat Nat Bit) - (if (..< reference sample) - #1 - ("lux i64 =" reference sample))) - -(def: #export (> reference sample) - {#.doc "Nat(ural) greater-than."} - (-> Nat Nat Bit) - (..< sample reference)) - -(def: #export (>= reference sample) - {#.doc "Nat(ural) greater-than or equal."} - (-> Nat Nat Bit) - (if (..< sample reference) - #1 - ("lux i64 =" reference sample))) - -(template [<name> <test> <doc>] - [(def: #export (<name> left right) - {#.doc <doc>} - (-> Nat Nat Nat) - (if (<test> right left) - left - right))] - - [min ..< "Nat(ural) minimum."] - [max ..> "Nat(ural) maximum."] - ) - -(def: #export (* parameter subject) - {#.doc "Nat(ural) multiplication."} - (-> Nat Nat Nat) - (:as Nat - ("lux i64 *" - (:as Int parameter) - (:as Int subject)))) - -(def: #export (/ parameter subject) - {#.doc "Nat(ural) division."} - (-> Nat Nat Nat) - (if ("lux i64 <" +0 (:as Int parameter)) - (if (..< parameter subject) - 0 - 1) - (let [quotient (|> subject - ("lux i64 right-shift" 1) - ("lux i64 /" (:as Int parameter)) - ("lux i64 left-shift" 1)) - flat ("lux i64 *" - (:as Int parameter) - (:as Int quotient)) - remainder ("lux i64 -" flat subject)] - (if (..< parameter remainder) - quotient - ("lux i64 +" 1 quotient))))) - -(def: #export (/% parameter subject) - {#.doc "Nat(ural) [division remainder]."} - (-> Nat Nat [Nat Nat]) - (let [quotient (../ parameter subject) - flat ("lux i64 *" - (:as Int parameter) - (:as Int quotient))] - [quotient ("lux i64 -" flat subject)])) - -(def: #export (% parameter subject) - {#.doc "Nat(ural) remainder."} - (-> Nat Nat Nat) - (let [flat ("lux i64 *" - (:as Int parameter) - (:as Int (../ parameter subject)))] - ("lux i64 -" flat subject))) - -(def: #export (gcd a b) - {#.doc "Greatest Common Divisor."} - (-> Nat Nat Nat) - (case b - 0 a - _ (gcd b (..% b a)))) - -(def: #export (co-prime? a b) - (-> Nat Nat Bit) - (..= 1 (..gcd a b))) - -(def: #export (lcm a b) - {#.doc "Least Common Multiple."} - (-> Nat Nat Nat) - (case [a b] - (^or [_ 0] [0 _]) - 0 - - _ - (|> a (../ (..gcd a b)) (..* b)))) - -(def: #export even? - (-> Nat Bit) - (|>> (..% 2) ("lux i64 =" 0))) - -(def: #export odd? - (-> Nat Bit) - (|>> ..even? not)) - -(def: #export frac - (-> Nat Frac) - (|>> .int "lux i64 f64")) - -(implementation: #export equivalence - (Equivalence Nat) - - (def: = ..=)) - -(implementation: #export order - (Order Nat) - - (def: &equivalence ..equivalence) - (def: < ..<)) - -(implementation: #export enum - (Enum Nat) - - (def: &order ..order) - (def: succ inc) - (def: pred dec)) - -(implementation: #export interval - (Interval Nat) - - (def: &enum ..enum) - (def: top (dec 0)) - (def: bottom 0)) - -(template [<name> <compose> <identity>] - [(implementation: #export <name> - (Monoid Nat) - - (def: identity <identity>) - (def: compose <compose>))] - - [addition ..+ 0] - [multiplication ..* 1] - [minimum ..min (\ ..interval top)] - [maximum ..max (\ ..interval bottom)] - ) - -(def: (binary-character value) - (-> Nat Text) - (case value - 0 "0" - 1 "1" - _ (undefined))) - -(def: (binary-value digit) - (-> Nat (Maybe Nat)) - (case digit - (^ (char "0")) (#.Some 0) - (^ (char "1")) (#.Some 1) - _ #.None)) - -(def: (octal-character value) - (-> Nat Text) - (case value - 0 "0" - 1 "1" - 2 "2" - 3 "3" - 4 "4" - 5 "5" - 6 "6" - 7 "7" - _ (undefined))) - -(def: (octal-value digit) - (-> Nat (Maybe Nat)) - (case digit - (^ (char "0")) (#.Some 0) - (^ (char "1")) (#.Some 1) - (^ (char "2")) (#.Some 2) - (^ (char "3")) (#.Some 3) - (^ (char "4")) (#.Some 4) - (^ (char "5")) (#.Some 5) - (^ (char "6")) (#.Some 6) - (^ (char "7")) (#.Some 7) - _ #.None)) - -(def: (decimal-character value) - (-> Nat Text) - (case value - 0 "0" - 1 "1" - 2 "2" - 3 "3" - 4 "4" - 5 "5" - 6 "6" - 7 "7" - 8 "8" - 9 "9" - _ (undefined))) - -(def: (decimal-value digit) - (-> Nat (Maybe Nat)) - (case digit - (^ (char "0")) (#.Some 0) - (^ (char "1")) (#.Some 1) - (^ (char "2")) (#.Some 2) - (^ (char "3")) (#.Some 3) - (^ (char "4")) (#.Some 4) - (^ (char "5")) (#.Some 5) - (^ (char "6")) (#.Some 6) - (^ (char "7")) (#.Some 7) - (^ (char "8")) (#.Some 8) - (^ (char "9")) (#.Some 9) - _ #.None)) - -(def: (hexadecimal-character value) - (-> Nat Text) - (case value - 0 "0" - 1 "1" - 2 "2" - 3 "3" - 4 "4" - 5 "5" - 6 "6" - 7 "7" - 8 "8" - 9 "9" - 10 "A" - 11 "B" - 12 "C" - 13 "D" - 14 "E" - 15 "F" - _ (undefined))) - -(def: (hexadecimal-value digit) - (-> Nat (Maybe Nat)) - (case digit - (^template [<character> <number>] - [(^ (char <character>)) (#.Some <number>)]) - (["0" 0] ["1" 1] ["2" 2] ["3" 3] ["4" 4] - ["5" 5] ["6" 6] ["7" 7] ["8" 8] ["9" 9]) - - (^template [<lower> <upper> <number>] - [(^or (^ (char <lower>)) (^ (char <upper>))) (#.Some <number>)]) - (["a" "A" 10] ["b" "B" 11] ["c" "C" 12] - ["d" "D" 13] ["e" "E" 14] ["f" "F" 15]) - _ #.None)) - -(template [<shift> <struct> <to-character> <to-value> <error>] - [(implementation: #export <struct> - (Codec Text Nat) - - (def: encode - (let [mask (|> 1 ("lux i64 left-shift" <shift>) dec)] - (function (_ value) - (loop [input value - output ""] - (let [output' ("lux text concat" - (<to-character> ("lux i64 and" mask input)) - output)] - (case (: Nat ("lux i64 right-shift" <shift> input)) - 0 - output' - - input' - (recur input' output'))))))) - - (def: (decode repr) - (let [input-size ("lux text size" repr)] - (if (..> 0 input-size) - (loop [idx 0 - output 0] - (if (..< input-size idx) - (case (<to-value> ("lux text char" idx repr)) - (#.Some digit-value) - (recur (inc idx) - (|> output - ("lux i64 left-shift" <shift>) - ("lux i64 or" digit-value))) - - _ - (#try.Failure ("lux text concat" <error> repr))) - (#try.Success output))) - (#try.Failure ("lux text concat" <error> repr))))))] - - [1 binary binary-character binary-value "Invalid binary syntax for Nat: "] - [3 octal octal-character octal-value "Invalid octal syntax for Nat: "] - [4 hex hexadecimal-character hexadecimal-value "Invalid hexadecimal syntax for Nat: "] - ) - -(implementation: #export decimal - (Codec Text Nat) - - (def: (encode value) - (loop [input value - output ""] - (let [digit (decimal-character (..% 10 input)) - output' ("lux text concat" digit output)] - (case (../ 10 input) - 0 - output' - - input' - (recur input' output'))))) - - (def: (decode repr) - (let [input-size ("lux text size" repr)] - (with_expansions [<failure> (#try.Failure ("lux text concat" "Invalid decimal syntax for Nat: " repr))] - (if (..> 0 input-size) - (loop [idx 0 - output 0] - (if (..< input-size idx) - (case (decimal-value ("lux text char" idx repr)) - #.None - <failure> - - (#.Some digit-value) - (recur (inc idx) - (|> output (..* 10) (..+ digit-value)))) - (#try.Success output))) - <failure>))))) - -(implementation: #export hash - (Hash Nat) - - (def: &equivalence ..equivalence) - (def: hash function.identity)) diff --git a/stdlib/source/lux/math/number/ratio.lux b/stdlib/source/lux/math/number/ratio.lux deleted file mode 100644 index ad2092fbd..000000000 --- a/stdlib/source/lux/math/number/ratio.lux +++ /dev/null @@ -1,161 +0,0 @@ -(.module: - {#.doc "Rational numbers."} - [lux (#- nat) - [abstract - [equivalence (#+ Equivalence)] - [order (#+ Order)] - [monoid (#+ Monoid)] - [codec (#+ Codec)] - [monad (#+ do)]] - [control - ["." function] - ["." try] - ["<>" parser - ["<.>" code (#+ Parser)]]] - [data - ["." product] - ["." maybe] - ["." text ("#\." monoid)]] - [macro - [syntax (#+ syntax:)] - ["." code]]] - [// - ["n" nat ("#\." decimal)]]) - -(type: #export Ratio - {#numerator Nat - #denominator Nat}) - -(def: #export (nat value) - (-> Ratio (Maybe Nat)) - (case (get@ #denominator value) - 1 (#.Some (get@ #numerator value)) - _ #.None)) - -(def: (normalize (^slots [#numerator #denominator])) - (-> Ratio Ratio) - (let [common (n.gcd numerator denominator)] - {#numerator (n./ common numerator) - #denominator (n./ common denominator)})) - -(syntax: #export (ratio numerator {?denominator (<>.maybe <code>.any)}) - {#.doc (doc "Rational literals." - (ratio numerator denominator) - "The denominator can be omitted if it's 1." - (ratio numerator))} - (wrap (list (` ((~! ..normalize) {#..numerator (~ numerator) - #..denominator (~ (maybe.default (' 1) - ?denominator))}))))) - -(def: #export (= parameter subject) - (-> Ratio Ratio Bit) - (and (n.= (get@ #numerator parameter) - (get@ #numerator subject)) - (n.= (get@ #denominator parameter) - (get@ #denominator subject)))) - -(implementation: #export equivalence - (Equivalence Ratio) - - (def: = ..=)) - -(def: (equalize parameter subject) - (-> Ratio Ratio [Nat Nat]) - [(n.* (get@ #denominator subject) - (get@ #numerator parameter)) - (n.* (get@ #denominator parameter) - (get@ #numerator subject))]) - -(def: #export (< parameter subject) - (-> Ratio Ratio Bit) - (let [[parameter' subject'] (..equalize parameter subject)] - (n.< parameter' subject'))) - -(def: #export (<= parameter subject) - (-> Ratio Ratio Bit) - (or (< parameter subject) - (= parameter subject))) - -(def: #export (> parameter subject) - (-> Ratio Ratio Bit) - (..< subject parameter)) - -(def: #export (>= parameter subject) - (-> Ratio Ratio Bit) - (or (> parameter subject) - (= parameter subject))) - -(implementation: #export order - (Order Ratio) - - (def: &equivalence ..equivalence) - (def: < ..<)) - -(def: #export (+ parameter subject) - (-> Ratio Ratio Ratio) - (let [[parameter' subject'] (..equalize parameter subject)] - (normalize [(n.+ parameter' subject') - (n.* (get@ #denominator parameter) - (get@ #denominator subject))]))) - -(def: #export (- parameter subject) - (-> Ratio Ratio Ratio) - (let [[parameter' subject'] (..equalize parameter subject)] - (normalize [(n.- parameter' subject') - (n.* (get@ #denominator parameter) - (get@ #denominator subject))]))) - -(def: #export (* parameter subject) - (-> Ratio Ratio Ratio) - (normalize [(n.* (get@ #numerator parameter) - (get@ #numerator subject)) - (n.* (get@ #denominator parameter) - (get@ #denominator subject))])) - -(def: #export (/ parameter subject) - (-> Ratio Ratio Ratio) - (let [[parameter' subject'] (..equalize parameter subject)] - (normalize [subject' parameter']))) - -(def: #export (% parameter subject) - (-> Ratio Ratio Ratio) - (let [[parameter' subject'] (..equalize parameter subject) - quot (n./ parameter' subject')] - (..- (update@ #numerator (n.* quot) parameter) - subject))) - -(def: #export (reciprocal (^slots [#numerator #denominator])) - (-> Ratio Ratio) - {#numerator denominator - #denominator numerator}) - -(def: separator ":") - -(implementation: #export codec - (Codec Text Ratio) - - (def: (encode (^slots [#numerator #denominator])) - ($_ text\compose (n\encode numerator) ..separator (n\encode denominator))) - - (def: (decode input) - (case (text.split_with ..separator input) - (#.Some [num denom]) - (do try.monad - [numerator (n\decode num) - denominator (n\decode denom)] - (wrap (normalize {#numerator numerator - #denominator denominator}))) - - #.None - (#.Left (text\compose "Invalid syntax for ratio: " input))))) - -(template [<identity> <compose> <name>] - [(implementation: #export <name> - (Monoid Ratio) - - (def: identity (..ratio <identity>)) - (def: compose <compose>))] - - [0 ..+ addition] - [1 ..* multiplication] - ) diff --git a/stdlib/source/lux/math/number/rev.lux b/stdlib/source/lux/math/number/rev.lux deleted file mode 100644 index 0f96320e3..000000000 --- a/stdlib/source/lux/math/number/rev.lux +++ /dev/null @@ -1,462 +0,0 @@ -(.module: - [lux #* - [abstract - [hash (#+ Hash)] - [enum (#+ Enum)] - [interval (#+ Interval)] - [monoid (#+ Monoid)] - [equivalence (#+ Equivalence)] - [codec (#+ Codec)] - [order (#+ Order)]] - [control - ["." try]] - [data - ["." maybe] - [collection - ["." array (#+ Array)]]]] - ["." // #_ - ["#." i64] - ["#." nat] - ["#." int]]) - -(template [<power> <name>] - [(def: #export <name> - Rev - (.rev (//i64.left_shift (//nat.- <power> //i64.width) 1)))] - - [01 /2] - [02 /4] - [03 /8] - [04 /16] - [05 /32] - [06 /64] - [07 /128] - [08 /256] - [09 /512] - [10 /1024] - [11 /2048] - [12 /4096] - ) - -(def: #export (= reference sample) - {#.doc "Rev(olution) equivalence."} - (-> Rev Rev Bit) - ("lux i64 =" reference sample)) - -(def: #export (< reference sample) - {#.doc "Rev(olution) less-than."} - (-> Rev Rev Bit) - (//nat.< (.nat reference) (.nat sample))) - -(def: #export (<= reference sample) - {#.doc "Rev(olution) less-than or equal."} - (-> Rev Rev Bit) - (if (//nat.< (.nat reference) (.nat sample)) - true - ("lux i64 =" reference sample))) - -(def: #export (> reference sample) - {#.doc "Rev(olution) greater-than."} - (-> Rev Rev Bit) - (..< sample reference)) - -(def: #export (>= reference sample) - {#.doc "Rev(olution) greater-than or equal."} - (-> Rev Rev Bit) - (if (..< sample reference) - true - ("lux i64 =" reference sample))) - -(template [<name> <test> <doc>] - [(def: #export (<name> left right) - {#.doc <doc>} - (-> Rev Rev Rev) - (if (<test> right left) - left - right))] - - [min ..< "Rev(olution) minimum."] - [max ..> "Rev(olution) maximum."] - ) - -(template [<name> <op> <doc>] - [(def: #export (<name> param subject) - {#.doc <doc>} - (-> Rev Rev Rev) - (<op> param subject))] - - [+ "lux i64 +" "Rev(olution) addition."] - [- "lux i64 -" "Rev(olution) substraction."] - ) - -(def: high - (-> (I64 Any) I64) - (|>> ("lux i64 right-shift" 32))) - -(def: low - (-> (I64 Any) I64) - (let [mask (|> 1 ("lux i64 left-shift" 32) ("lux i64 -" 1))] - (|>> ("lux i64 and" mask)))) - -(def: #export (* param subject) - {#.doc "Rev(olution) multiplication."} - (-> Rev Rev Rev) - (let [subjectH (..high subject) - subjectL (..low subject) - paramH (..high param) - paramL (..low param) - bottom (|> subjectL - ("lux i64 *" paramL) - ("lux i64 right-shift" 32)) - middle ("lux i64 +" - ("lux i64 *" paramL subjectH) - ("lux i64 *" paramH subjectL)) - top ("lux i64 *" subjectH paramH)] - (|> bottom - ("lux i64 +" middle) - ..high - ("lux i64 +" top)))) - -(def: even_one (//i64.rotate_right 1 1)) -(def: odd_one (dec 0)) - -(def: (even_reciprocal numerator) - (-> Nat Nat) - (//nat./ (//i64.right_shift 1 numerator) - ..even_one)) - -(def: (odd_reciprocal numerator) - (-> Nat Nat) - (//nat./ numerator ..odd_one)) - -(with_expansions [<least_significant_bit> 1] - (def: #export (reciprocal numerator) - {#.doc "Rev(olution) reciprocal of a Nat(ural)."} - (-> Nat Rev) - (.rev (case (: Nat ("lux i64 and" <least_significant_bit> numerator)) - 0 (..even_reciprocal numerator) - _ (..odd_reciprocal numerator)))) - - (def: #export (/ param subject) - {#.doc "Rev(olution) division."} - (-> Rev Rev Rev) - (if ("lux i64 =" +0 param) - (error! "Cannot divide Rev by zero!") - (let [reciprocal (case (: Nat ("lux i64 and" <least_significant_bit> param)) - 0 (..even_reciprocal (.nat param)) - _ (..odd_reciprocal (.nat param)))] - (.rev (//nat.* reciprocal (.nat subject))))))) - -(template [<operator> <name> <output> <output_type> <documentation>] - [(def: #export (<name> param subject) - {#.doc <documentation>} - (-> Rev Rev <output_type>) - (<output> (<operator> (.nat param) (.nat subject))))] - - [//nat.% % .rev Rev "Rev(olution) remainder."] - [//nat./ ratio |> Nat "Ratio between two rev(olution)s."] - ) - -(template [<operator> <name>] - [(def: #export (<name> scale subject) - (-> Nat Rev Rev) - (.rev (<operator> (.nat scale) (.nat subject))))] - - [//nat.* up] - [//nat./ down] - ) - -(def: #export (/% param subject) - (-> Rev Rev [Rev Rev]) - [(../ param subject) - (..% param subject)]) - -(def: mantissa - (-> (I64 Any) Frac) - (|>> ("lux i64 right-shift" 11) - "lux i64 f64")) - -(def: frac_denominator - (..mantissa -1)) - -(def: #export frac - (-> Rev Frac) - (|>> ..mantissa ("lux f64 /" ..frac_denominator))) - -(implementation: #export equivalence - (Equivalence Rev) - - (def: = ..=)) - -(implementation: #export hash - (Hash Rev) - - (def: &equivalence ..equivalence) - (def: hash .nat)) - -(implementation: #export order - (Order Rev) - - (def: &equivalence ..equivalence) - (def: < ..<)) - -(implementation: #export enum - (Enum Rev) - - (def: &order ..order) - (def: succ inc) - (def: pred dec)) - -(implementation: #export interval - (Interval Rev) - - (def: &enum ..enum) - (def: top (.rev -1)) - (def: bottom (.rev 0))) - -(template [<name> <compose> <identity>] - [(implementation: #export <name> - (Monoid Rev) - - (def: identity (\ interval <identity>)) - (def: compose <compose>))] - - [addition ..+ bottom] - [maximum ..max bottom] - [minimum ..min top] - ) - -(def: (de_prefix input) - (-> Text Text) - ("lux text clip" 1 (dec ("lux text size" input)) input)) - -(template [<struct> <codec> <char_bit_size> <error>] - [(with_expansions [<error_output> (as_is (#try.Failure ("lux text concat" <error> repr)))] - (implementation: #export <struct> - (Codec Text Rev) - - (def: (encode value) - (let [raw_output (\ <codec> encode (.nat value)) - max_num_chars (//nat.+ (//nat./ <char_bit_size> //i64.width) - (case (//nat.% <char_bit_size> //i64.width) - 0 0 - _ 1)) - raw_size ("lux text size" raw_output) - zero_padding (: Text - (loop [zeroes_left (: Nat (//nat.- raw_size max_num_chars)) - output (: Text "")] - (if (//nat.= 0 zeroes_left) - output - (recur (dec zeroes_left) - ("lux text concat" "0" output)))))] - (|> raw_output - ("lux text concat" zero_padding) - ("lux text concat" ".")))) - - (def: (decode repr) - (let [repr_size ("lux text size" repr)] - (if (//nat.> 1 repr_size) - (case ("lux text char" 0 repr) - (^ (char ".")) - (case (\ <codec> decode (de_prefix repr)) - (#try.Success output) - (#try.Success (.rev output)) - - _ - <error_output>) - - _ - <error_output>) - <error_output>)))))] - - [binary //nat.binary 1 "Invalid binary syntax: "] - [octal //nat.octal 3 "Invalid octal syntax: "] - [hex //nat.hex 4 "Invalid hexadecimal syntax: "] - ) - -## The following code allows one to encode/decode Rev numbers as text. -## This is not a simple algorithm, and it requires subverting the Rev -## abstraction a bit. -## It takes into account the fact that Rev numbers are represented by -## Lux as 64-bit integers. -## A valid way to model them is as Lux's Nat type. -## This is a somewhat hackish way to do things, but it allows one to -## write the encoding/decoding algorithm once, in pure Lux, rather -## than having to implement it on the compiler for every platform -## targeted by Lux. -(type: Digits (Array Nat)) - -(def: (digits::new _) - (-> Any Digits) - (array.new //i64.width)) - -(def: (digits::get idx digits) - (-> Nat Digits Nat) - (|> digits (array.read idx) (maybe.default 0))) - -(def: digits::put - (-> Nat Nat Digits Digits) - array.write!) - -(def: (prepend left right) - (-> Text Text Text) - ("lux text concat" left right)) - -(def: (digits::times_5! idx output) - (-> Nat Digits Digits) - (loop [idx idx - carry 0 - output output] - (if (//int.>= +0 (.int idx)) - (let [raw (|> (digits::get idx output) - (//nat.* 5) - (//nat.+ carry))] - (recur (dec idx) - (//nat./ 10 raw) - (digits::put idx (//nat.% 10 raw) output))) - output))) - -(def: (digits::power power) - (-> Nat Digits) - (loop [times power - output (|> (digits::new []) - (digits::put power 1))] - (if (//int.>= +0 (.int times)) - (recur (dec times) - (digits::times_5! power output)) - output))) - -(def: (digits::format digits) - (-> Digits Text) - (loop [idx (dec //i64.width) - all_zeroes? true - output ""] - (if (//int.>= +0 (.int idx)) - (let [digit (digits::get idx digits)] - (if (and (//nat.= 0 digit) - all_zeroes?) - (recur (dec idx) true output) - (recur (dec idx) - false - ("lux text concat" - (\ //nat.decimal encode digit) - output)))) - (if all_zeroes? - "0" - output)))) - -(def: (digits::+ param subject) - (-> Digits Digits Digits) - (loop [idx (dec //i64.width) - carry 0 - output (digits::new [])] - (if (//int.>= +0 (.int idx)) - (let [raw ($_ //nat.+ - carry - (digits::get idx param) - (digits::get idx subject))] - (recur (dec idx) - (//nat./ 10 raw) - (digits::put idx (//nat.% 10 raw) output))) - output))) - -(def: (text_to_digits input) - (-> Text (Maybe Digits)) - (let [length ("lux text size" input)] - (if (//nat.<= //i64.width length) - (loop [idx 0 - output (digits::new [])] - (if (//nat.< length idx) - (case ("lux text index" 0 ("lux text clip" idx 1 input) "0123456789") - #.None - #.None - - (#.Some digit) - (recur (inc idx) - (digits::put idx digit output))) - (#.Some output))) - #.None))) - -(def: (digits::< param subject) - (-> Digits Digits Bit) - (loop [idx 0] - (and (//nat.< //i64.width idx) - (let [pd (digits::get idx param) - sd (digits::get idx subject)] - (if (//nat.= pd sd) - (recur (inc idx)) - (//nat.< pd sd)))))) - -(def: (digits::-!' idx param subject) - (-> Nat Nat Digits Digits) - (let [sd (digits::get idx subject)] - (if (//nat.>= param sd) - (digits::put idx (//nat.- param sd) subject) - (let [diff (|> sd - (//nat.+ 10) - (//nat.- param))] - (|> subject - (digits::put idx diff) - (digits::-!' (dec idx) 1)))))) - -(def: (digits::-! param subject) - (-> Digits Digits Digits) - (loop [idx (dec //i64.width) - output subject] - (if (//int.>= +0 (.int idx)) - (recur (dec idx) - (digits::-!' idx (digits::get idx param) output)) - output))) - -(implementation: #export decimal - (Codec Text Rev) - - (def: (encode input) - (case (.nat input) - 0 - ".0" - - input - (let [last_idx (dec //i64.width)] - (loop [idx last_idx - digits (digits::new [])] - (if (//int.>= +0 (.int idx)) - (if (//i64.set? idx input) - (let [digits' (digits::+ (digits::power (//nat.- idx last_idx)) - digits)] - (recur (dec idx) - digits')) - (recur (dec idx) - digits)) - ("lux text concat" "." (digits::format digits)) - ))))) - - (def: (decode input) - (let [dotted? (case ("lux text index" 0 "." input) - (#.Some 0) - true - - _ - false) - within_limits? (//nat.<= (inc //i64.width) - ("lux text size" input))] - (if (and dotted? within_limits?) - (case (text_to_digits (de_prefix input)) - (#.Some digits) - (loop [digits digits - idx 0 - output 0] - (if (//nat.< //i64.width idx) - (let [power (digits::power idx)] - (if (digits::< power digits) - ## Skip power - (recur digits (inc idx) output) - (recur (digits::-! power digits) - (inc idx) - (//i64.set (//nat.- idx (dec //i64.width)) output)))) - (#try.Success (.rev output)))) - - #.None - (#try.Failure ("lux text concat" "Wrong syntax for Rev: " input))) - (#try.Failure ("lux text concat" "Wrong syntax for Rev: " input)))) - )) diff --git a/stdlib/source/lux/math/random.lux b/stdlib/source/lux/math/random.lux deleted file mode 100644 index 8c95c63fa..000000000 --- a/stdlib/source/lux/math/random.lux +++ /dev/null @@ -1,399 +0,0 @@ -(.module: {#.doc "Pseudo-random number generation (PRNG) algorithms."} - [lux (#- or and list i64 nat int rev char) - [abstract - [hash (#+ Hash)] - [functor (#+ Functor)] - [apply (#+ Apply)] - ["." monad (#+ Monad do)]] - [data - ["." text (#+ Char) ("#\." monoid) - ["." unicode #_ - ["#" set]]] - [collection - ["." list ("#\." fold)] - ["." array (#+ Array)] - ["." dictionary (#+ Dictionary)] - ["." queue (#+ Queue)] - ["." set (#+ Set)] - ["." stack (#+ Stack)] - ["." row (#+ Row)] - [tree - ["." finger (#+ Tree)]]]] - [math - [number (#+ hex) - ["n" nat] - ["i" int] - ["f" frac] - ["r" ratio] - ["c" complex] - ["." i64]]] - ["." time (#+ Time) - ["." instant (#+ Instant)] - ["." date (#+ Date)] - ["." duration (#+ Duration)] - ["." month (#+ Month)] - ["." day (#+ Day)]] - [type - [refinement (#+ Refiner Refined)]]]) - -(type: #export #rec PRNG - {#.doc "An abstract way to represent any PRNG."} - (-> Any [PRNG I64])) - -(type: #export (Random a) - {#.doc "A producer of random values based on a PRNG."} - (-> PRNG [PRNG a])) - -(implementation: #export functor - (Functor Random) - - (def: (map f fa) - (function (_ state) - (let [[state' a] (fa state)] - [state' (f a)])))) - -(implementation: #export apply - (Apply Random) - - (def: &functor ..functor) - - (def: (apply ff fa) - (function (_ state) - (let [[state' f] (ff state) - [state'' a] (fa state')] - [state'' (f a)])))) - -(implementation: #export monad - (Monad Random) - - (def: &functor ..functor) - - (def: (wrap a) - (function (_ state) - [state a])) - - (def: (join ffa) - (function (_ state) - (let [[state' fa] (ffa state)] - (fa state'))))) - -(def: #export (filter pred gen) - {#.doc "Retries the generator until the output satisfies a predicate."} - (All [a] (-> (-> a Bit) (Random a) (Random a))) - (do ..monad - [sample gen] - (if (pred sample) - (wrap sample) - (filter pred gen)))) - -(def: #export (one check random) - (All [a b] - (-> (-> a (Maybe b)) (Random a) (Random b))) - (do ..monad - [sample random] - (case (check sample) - (#.Some output) - (wrap output) - - #.None - (one check random)))) - -(def: #export (refine refiner gen) - {#.doc "Retries the generator until the output can be refined."} - (All [t r] (-> (Refiner t r) (Random t) (Random (Refined t r)))) - (do ..monad - [sample gen] - (case (refiner sample) - (#.Some refined) - (wrap refined) - - #.None - (refine refiner gen)))) - -(def: #export bit - (Random Bit) - (function (_ prng) - (let [[prng output] (prng [])] - [prng (|> output (i64.and 1) (n.= 1))]))) - -(def: #export i64 - (Random I64) - (function (_ prng) - (let [[prng left] (prng []) - [prng right] (prng [])] - [prng (|> left - (i64.left_shift 32) - ("lux i64 +" right))]))) - -(template [<name> <type> <cast>] - [(def: #export <name> - (Random <type>) - (\ ..monad map <cast> ..i64))] - - [nat Nat .nat] - [int Int .int] - [rev Rev .rev] - ) - -(def: #export frac - (Random Frac) - (\ ..monad map (|>> .i64 f.from_bits) ..nat)) - -(def: #export safe_frac - (Random Frac) - (let [mantissa_range (.int (i64.left_shift 53 1)) - mantissa_max (i.frac (dec mantissa_range))] - (\ ..monad map - (|>> (i.% mantissa_range) - i.frac - (f./ mantissa_max)) - ..int))) - -(def: #export (char set) - (-> unicode.Set (Random Char)) - (let [[start end] (unicode.range set) - size (n.- start end) - in_range (: (-> Char Char) - (|>> (n.% size) (n.+ start)))] - (|> ..nat - (\ ..monad map in_range) - (..filter (unicode.member? set))))) - -(def: #export (text char_gen size) - (-> (Random Char) Nat (Random Text)) - (if (n.= 0 size) - (\ ..monad wrap "") - (do ..monad - [x char_gen - xs (text char_gen (dec size))] - (wrap (text\compose (text.from_code x) xs))))) - -(template [<name> <set>] - [(def: #export <name> - (-> Nat (Random Text)) - (..text (..char <set>)))] - - [unicode unicode.character] - [ascii unicode.ascii] - [ascii/alpha unicode.ascii/alpha] - [ascii/alpha_num unicode.ascii/alpha_num] - [ascii/numeric unicode.ascii/numeric] - [ascii/upper unicode.ascii/upper] - [ascii/lower unicode.ascii/lower] - ) - -(template [<name> <type> <ctor> <gen>] - [(def: #export <name> - (Random <type>) - (do ..monad - [left <gen> - right <gen>] - (wrap (<ctor> left right))))] - - [ratio r.Ratio r.ratio ..nat] - [complex c.Complex c.complex ..safe_frac] - ) - -(def: #export (and left right) - {#.doc "Sequencing combinator."} - (All [a b] (-> (Random a) (Random b) (Random [a b]))) - (do ..monad - [=left left - =right right] - (wrap [=left =right]))) - -(def: #export (or left right) - {#.doc "Heterogeneous alternative combinator."} - (All [a b] (-> (Random a) (Random b) (Random (| a b)))) - (do {! ..monad} - [? bit] - (if ? - (do ! - [=left left] - (wrap (0 #0 =left))) - (do ! - [=right right] - (wrap (0 #1 =right)))))) - -(def: #export (either left right) - {#.doc "Homogeneous alternative combinator."} - (All [a] (-> (Random a) (Random a) (Random a))) - (do ..monad - [? bit] - (if ? - left - right))) - -(def: #export (rec gen) - {#.doc "A combinator for producing recursive random generators."} - (All [a] (-> (-> (Random a) (Random a)) (Random a))) - (function (_ state) - (let [gen' (gen (rec gen))] - (gen' state)))) - -(def: #export (maybe value_gen) - (All [a] (-> (Random a) (Random (Maybe a)))) - (do {! ..monad} - [some? bit] - (if some? - (do ! - [value value_gen] - (wrap (#.Some value))) - (wrap #.None)))) - -(template [<name> <type> <zero> <plus>] - [(def: #export (<name> size value_gen) - (All [a] (-> Nat (Random a) (Random (<type> a)))) - (if (n.> 0 size) - (do ..monad - [x value_gen - xs (<name> (dec size) value_gen)] - (wrap (<plus> x xs))) - (\ ..monad wrap <zero>)))] - - [list List (.list) #.Cons] - [row Row row.empty row.add] - ) - -(template [<name> <type> <ctor>] - [(def: #export (<name> size value_gen) - (All [a] (-> Nat (Random a) (Random (<type> a)))) - (do ..monad - [values (list size value_gen)] - (wrap (|> values <ctor>))))] - - [array Array array.from_list] - [queue Queue queue.from_list] - [stack Stack (list\fold stack.push stack.empty)] - ) - -(def: #export (set Hash<a> size value_gen) - (All [a] (-> (Hash a) Nat (Random a) (Random (Set a)))) - (if (n.> 0 size) - (do {! ..monad} - [xs (set Hash<a> (dec size) value_gen)] - (loop [_ []] - (do ! - [x value_gen - #let [xs+ (set.add x xs)]] - (if (n.= size (set.size xs+)) - (wrap xs+) - (recur []))))) - (\ ..monad wrap (set.new Hash<a>)))) - -(def: #export (dictionary Hash<a> size key_gen value_gen) - (All [k v] (-> (Hash k) Nat (Random k) (Random v) (Random (Dictionary k v)))) - (if (n.> 0 size) - (do {! ..monad} - [kv (dictionary Hash<a> (dec size) key_gen value_gen)] - (loop [_ []] - (do ! - [k key_gen - v value_gen - #let [kv+ (dictionary.put k v kv)]] - (if (n.= size (dictionary.size kv+)) - (wrap kv+) - (recur []))))) - (\ ..monad wrap (dictionary.new Hash<a>)))) - -(def: #export instant - (Random Instant) - (\ ..monad map instant.from_millis ..int)) - -(def: #export date - (Random Date) - (\ ..monad map instant.date ..instant)) - -(def: #export time - (Random Time) - (\ ..monad map instant.time ..instant)) - -(def: #export duration - (Random Duration) - (\ ..monad map duration.from_millis ..int)) - -(def: #export month - (Random Month) - (let [(^open "\.") ..monad] - (..either (..either (..either (\wrap #month.January) - (..either (\wrap #month.February) - (\wrap #month.March))) - (..either (\wrap #month.April) - (..either (\wrap #month.May) - (\wrap #month.June)))) - (..either (..either (\wrap #month.July) - (..either (\wrap #month.August) - (\wrap #month.September))) - (..either (\wrap #month.October) - (..either (\wrap #month.November) - (\wrap #month.December))))))) - -(def: #export day - (Random Day) - (let [(^open "\.") ..monad] - (..either (..either (\wrap #day.Sunday) - (..either (\wrap #day.Monday) - (\wrap #day.Tuesday))) - (..either (..either (\wrap #day.Wednesday) - (\wrap #day.Thursday)) - (..either (\wrap #day.Friday) - (\wrap #day.Saturday)))))) - -(def: #export (run prng calc) - (All [a] (-> PRNG (Random a) [PRNG a])) - (calc prng)) - -(def: #export (prng update return) - (All [a] (-> (-> a a) (-> a I64) (-> a PRNG))) - (function (recur state) - (function (_ _) - [(recur (update state)) - (return state)]))) - -(def: #export (pcg32 [increase seed]) - {#.doc (doc "An implementation of the PCG32 algorithm." - "For more information, please see: http://www.pcg-random.org/")} - (-> [(I64 Any) (I64 Any)] PRNG) - (let [magic 6364136223846793005] - (function (_ _) - [(|> seed .nat (n.* magic) ("lux i64 +" increase) [increase] pcg32) - (let [rot (|> seed .i64 (i64.right_shift 59))] - (|> seed - (i64.right_shift 18) - (i64.xor seed) - (i64.right_shift 27) - (i64.rotate_right rot) - .i64))]))) - -(def: #export (xoroshiro_128+ [s0 s1]) - {#.doc (doc "An implementation of the Xoroshiro128+ algorithm." - "For more information, please see: http://xoroshiro.di.unimi.it/")} - (-> [(I64 Any) (I64 Any)] PRNG) - (function (_ _) - [(let [s01 (i64.xor s0 s1)] - (xoroshiro_128+ [(|> s0 - (i64.rotate_left 55) - (i64.xor s01) - (i64.xor (i64.left_shift 14 s01))) - (i64.rotate_left 36 s01)])) - ("lux i64 +" s0 s1)])) - -## https://en.wikipedia.org/wiki/Xorshift#Initialization -## http://xorshift.di.unimi.it/splitmix64.c -(def: #export split_mix_64 - {#.doc (doc "An implementation of the SplitMix64 algorithm.")} - (-> Nat PRNG) - (let [twist (: (-> Nat Nat Nat) - (function (_ shift value) - (i64.xor (i64.right_shift shift value) - value))) - mix n.*] - (..prng (n.+ (hex "9E,37,79,B9,7F,4A,7C,15")) - (|>> (twist 30) - (mix (hex "BF,58,47,6D,1C,E4,E5,B9")) - - (twist 27) - (mix (hex "94,D0,49,BB,13,31,11,EB")) - - (twist 31) - .i64)))) diff --git a/stdlib/source/lux/meta.lux b/stdlib/source/lux/meta.lux deleted file mode 100644 index a6877765b..000000000 --- a/stdlib/source/lux/meta.lux +++ /dev/null @@ -1,567 +0,0 @@ -(.module: {#.doc "Functions for extracting information from the state of the compiler."} - [lux #* - [abstract - [functor (#+ Functor)] - [apply (#+ Apply)] - ["." monad (#+ Monad do)]] - [control - ["." try (#+ Try)]] - [data - ["." product] - ["." maybe] - ["." text ("#\." monoid equivalence)] - ["." name ("#\." codec equivalence)] - [collection - ["." list ("#\." monoid monad)] - [dictionary - ["." plist]]]] - [macro - ["." code]] - [math - [number - ["n" nat] - ["i" int]]]] - [/ - ["." location]]) - -## (type: (Meta a) -## (-> Lux (Try [Lux a]))) - -(implementation: #export functor - (Functor Meta) - - (def: (map f fa) - (function (_ compiler) - (case (fa compiler) - (#try.Failure msg) - (#try.Failure msg) - - (#try.Success [compiler' a]) - (#try.Success [compiler' (f a)]))))) - -(implementation: #export apply - (Apply Meta) - - (def: &functor ..functor) - - (def: (apply ff fa) - (function (_ compiler) - (case (ff compiler) - (#try.Success [compiler' f]) - (case (fa compiler') - (#try.Success [compiler'' a]) - (#try.Success [compiler'' (f a)]) - - (#try.Failure msg) - (#try.Failure msg)) - - (#try.Failure msg) - (#try.Failure msg))))) - -(implementation: #export monad - (Monad Meta) - - (def: &functor ..functor) - - (def: (wrap x) - (function (_ compiler) - (#try.Success [compiler x]))) - - (def: (join mma) - (function (_ compiler) - (case (mma compiler) - (#try.Failure msg) - (#try.Failure msg) - - (#try.Success [compiler' ma]) - (ma compiler'))))) - -(def: #export (run' compiler action) - (All [a] (-> Lux (Meta a) (Try [Lux a]))) - (action compiler)) - -(def: #export (run compiler action) - (All [a] (-> Lux (Meta a) (Try a))) - (case (action compiler) - (#try.Failure error) - (#try.Failure error) - - (#try.Success [_ output]) - (#try.Success output))) - -(def: #export (either left right) - {#.doc "Pick whichever computation succeeds."} - (All [a] (-> (Meta a) (Meta a) (Meta a))) - (function (_ compiler) - (case (left compiler) - (#try.Failure error) - (right compiler) - - (#try.Success [compiler' output]) - (#try.Success [compiler' output])))) - -(def: #export (assert message test) - {#.doc "Fails with the given message if the test is #0."} - (-> Text Bit (Meta Any)) - (function (_ compiler) - (if test - (#try.Success [compiler []]) - (#try.Failure message)))) - -(def: #export (fail error) - {#.doc "Fails with the given error message."} - (All [a] - (-> Text (Meta a))) - (function (_ state) - (#try.Failure (location.with (get@ #.location state) error)))) - -(def: #export (find_module name) - (-> Text (Meta Module)) - (function (_ compiler) - (case (plist.get name (get@ #.modules compiler)) - (#.Some module) - (#try.Success [compiler module]) - - _ - (#try.Failure ($_ text\compose "Unknown module: " name))))) - -(def: #export current_module_name - (Meta Text) - (function (_ compiler) - (case (get@ #.current_module compiler) - (#.Some current_module) - (#try.Success [compiler current_module]) - - _ - (#try.Failure "No current module.")))) - -(def: #export current_module - (Meta Module) - (let [(^open "\.") ..monad] - (|> ..current_module_name - (\map ..find_module) - \join))) - -(def: (macro_type? type) - (-> Type Bit) - (case type - (#.Named ["lux" "Macro"] (#.Primitive "#Macro" #.Nil)) - true - - _ - false)) - -(def: #export (normalize name) - {#.doc (doc "If given a name without a module prefix, gives it the current module's name as prefix." - "Otherwise, returns the name as-is.")} - (-> Name (Meta Name)) - (case name - ["" name] - (do ..monad - [module_name ..current_module_name] - (wrap [module_name name])) - - _ - (\ ..monad wrap name))) - -(def: (find_macro' modules this_module module name) - (-> (List [Text Module]) Text Text Text - (Maybe Macro)) - (do maybe.monad - [$module (plist.get module modules) - definition (: (Maybe Global) - (|> (: Module $module) - (get@ #.definitions) - (plist.get name)))] - (case definition - (#.Alias [r_module r_name]) - (find_macro' modules this_module r_module r_name) - - (#.Definition [exported? def_type def_anns def_value]) - (if (macro_type? def_type) - (#.Some (:as Macro def_value)) - #.None)))) - -(def: #export (find_macro full_name) - (-> Name (Meta (Maybe Macro))) - (do ..monad - [[module name] (normalize full_name)] - (: (Meta (Maybe Macro)) - (function (_ compiler) - (let [macro (case (..current_module_name compiler) - (#try.Failure error) - #.None - - (#try.Success [_ this_module]) - (find_macro' (get@ #.modules compiler) this_module module name))] - (#try.Success [compiler macro])))))) - -(def: #export count - (Meta Nat) - (function (_ compiler) - (#try.Success [(update@ #.seed inc compiler) - (get@ #.seed compiler)]))) - -(def: #export (module_exists? module) - (-> Text (Meta Bit)) - (function (_ compiler) - (#try.Success [compiler (case (plist.get module (get@ #.modules compiler)) - (#.Some _) - #1 - - #.None - #0)]))) - -(def: (try_both f x1 x2) - (All [a b] - (-> (-> a (Maybe b)) a a (Maybe b))) - (case (f x1) - #.None (f x2) - (#.Some y) (#.Some y))) - -(def: (find_type_var idx bindings) - (-> Nat (List [Nat (Maybe Type)]) (Maybe Type)) - (case bindings - #.Nil - #.None - - (#.Cons [var bound] bindings') - (if (n.= idx var) - bound - (find_type_var idx bindings')))) - -(def: (clean_type type) - (-> Type (Meta Type)) - (case type - (#.Var var) - (function (_ compiler) - (case (|> compiler - (get@ [#.type_context #.var_bindings]) - (find_type_var var)) - (^or #.None (#.Some (#.Var _))) - (#try.Success [compiler type]) - - (#.Some type') - (#try.Success [compiler type']))) - - _ - (\ ..monad wrap type))) - -(def: #export (find_var_type name) - {#.doc "Looks-up the type of a local variable somewhere in the environment."} - (-> Text (Meta Type)) - (function (_ compiler) - (let [test (: (-> [Text [Type Any]] Bit) - (|>> product.left (text\= name)))] - (case (do maybe.monad - [scope (list.find (function (_ env) - (or (list.any? test (: (List [Text [Type Any]]) - (get@ [#.locals #.mappings] env))) - (list.any? test (: (List [Text [Type Any]]) - (get@ [#.captured #.mappings] env))))) - (get@ #.scopes compiler)) - [_ [type _]] (try_both (list.find test) - (: (List [Text [Type Any]]) - (get@ [#.locals #.mappings] scope)) - (: (List [Text [Type Any]]) - (get@ [#.captured #.mappings] scope)))] - (wrap type)) - (#.Some var_type) - ((clean_type var_type) compiler) - - #.None - (#try.Failure ($_ text\compose "Unknown variable: " name)))))) - -(def: #export (find_def name) - {#.doc "Looks-up a definition's whole data in the available modules (including the current one)."} - (-> Name (Meta Global)) - (do ..monad - [name (normalize name) - #let [[normal_module normal_short] name]] - (function (_ compiler) - (case (: (Maybe Global) - (do maybe.monad - [(^slots [#.definitions]) (|> compiler - (get@ #.modules) - (plist.get normal_module))] - (plist.get normal_short definitions))) - (#.Some definition) - (#try.Success [compiler definition]) - - _ - (let [current_module (|> compiler (get@ #.current_module) (maybe.default "???")) - separator ($_ text\compose text.new_line " ")] - (#try.Failure ($_ text\compose - "Unknown definition: " (name\encode name) text.new_line - " Current module: " current_module text.new_line - (case (plist.get current_module (get@ #.modules compiler)) - (#.Some this_module) - (let [candidates (|> compiler - (get@ #.modules) - (list\map (function (_ [module_name module]) - (|> module - (get@ #.definitions) - (list.all (function (_ [def_name global]) - (case global - (#.Definition [exported? _ _ _]) - (if (and exported? - (text\= normal_short def_name)) - (#.Some (name\encode [module_name def_name])) - #.None) - - (#.Alias _) - #.None)))))) - list.concat - (text.join_with separator)) - imports (|> this_module - (get@ #.imports) - (text.join_with separator)) - aliases (|> this_module - (get@ #.module_aliases) - (list\map (function (_ [alias real]) ($_ text\compose alias " => " real))) - (text.join_with separator))] - ($_ text\compose - " Candidates: " candidates text.new_line - " Imports: " imports text.new_line - " Aliases: " aliases text.new_line)) - - _ - "") - " All known modules: " (|> compiler (get@ #.modules) (list\map product.left) (text.join_with separator)) text.new_line))))))) - -(def: #export (find_export name) - {#.doc "Looks-up a definition's type in the available modules (including the current one)."} - (-> Name (Meta Definition)) - (do ..monad - [definition (..find_def name)] - (case definition - (#.Left de_aliased) - (fail ($_ text\compose - "Aliases are not considered exports: " - (name\encode name))) - - (#.Right definition) - (let [[exported? def_type def_data def_value] definition] - (if exported? - (wrap definition) - (fail ($_ text\compose "Definition is not an export: " (name\encode name)))))))) - -(def: #export (find_def_type name) - {#.doc "Looks-up a definition's type in the available modules (including the current one)."} - (-> Name (Meta Type)) - (do ..monad - [definition (find_def name)] - (case definition - (#.Left de_aliased) - (find_def_type de_aliased) - - (#.Right [exported? def_type def_data def_value]) - (clean_type def_type)))) - -(def: #export (find_type name) - {#.doc "Looks-up the type of either a local variable or a definition."} - (-> Name (Meta Type)) - (do ..monad - [#let [[_ _name] name]] - (case name - ["" _name] - (either (find_var_type _name) - (find_def_type name)) - - _ - (find_def_type name)))) - -(def: #export (find_type_def name) - {#.doc "Finds the value of a type definition (such as Int, Any or Lux)."} - (-> Name (Meta Type)) - (do ..monad - [definition (find_def name)] - (case definition - (#.Left de_aliased) - (find_type_def de_aliased) - - (#.Right [exported? def_type def_data def_value]) - (let [type_to_code ("lux in-module" "lux" .type_to_code)] - (if (or (is? .Type def_type) - (\ code.equivalence = - (type_to_code .Type) - (type_to_code def_type))) - (wrap (:as Type def_value)) - (..fail ($_ text\compose "Definition is not a type: " (name\encode name)))))))) - -(def: #export (globals module) - {#.doc "The entire list of globals in a module (including the non-exported/private ones)."} - (-> Text (Meta (List [Text Global]))) - (function (_ compiler) - (case (plist.get module (get@ #.modules compiler)) - #.None - (#try.Failure ($_ text\compose "Unknown module: " module)) - - (#.Some module) - (#try.Success [compiler (get@ #.definitions module)])))) - -(def: #export (definitions module) - {#.doc "The entire list of definitions in a module (including the non-exported/private ones)."} - (-> Text (Meta (List [Text Definition]))) - (\ ..monad map - (list.all (function (_ [name global]) - (case global - (#.Left de_aliased) - #.None - - (#.Right definition) - (#.Some [name definition])))) - (..globals module))) - -(def: #export (exports module_name) - {#.doc "All the exported definitions in a module."} - (-> Text (Meta (List [Text Definition]))) - (do ..monad - [constants (..definitions module_name)] - (wrap (do list.monad - [[name [exported? def_type def_data def_value]] constants] - (if exported? - (wrap [name [exported? def_type def_data def_value]]) - (list)))))) - -(def: #export modules - {#.doc "All the available modules (including the current one)."} - (Meta (List [Text Module])) - (function (_ compiler) - (|> compiler - (get@ #.modules) - [compiler] - #try.Success))) - -(def: #export (tags_of type_name) - {#.doc "All the tags associated with a type definition."} - (-> Name (Meta (Maybe (List Name)))) - (do ..monad - [#let [[module name] type_name] - module (find_module module)] - (case (plist.get name (get@ #.types module)) - (#.Some [tags _]) - (wrap (#.Some tags)) - - _ - (wrap #.None)))) - -(def: #export location - {#.doc "The location of the current expression being analyzed."} - (Meta Location) - (function (_ compiler) - (#try.Success [compiler (get@ #.location compiler)]))) - -(def: #export expected_type - {#.doc "The expected type of the current expression being analyzed."} - (Meta Type) - (function (_ compiler) - (case (get@ #.expected compiler) - (#.Some type) - (#try.Success [compiler type]) - - #.None - (#try.Failure "Not expecting any type.")))) - -(def: #export (imported_modules module_name) - {#.doc "All the modules imported by a specified module."} - (-> Text (Meta (List Text))) - (do ..monad - [(^slots [#.imports]) (..find_module module_name)] - (wrap imports))) - -(def: #export (imported_by? import module) - (-> Text Text (Meta Bit)) - (do ..monad - [(^slots [#.imports]) (..find_module module)] - (wrap (list.any? (text\= import) imports)))) - -(def: #export (imported? import) - (-> Text (Meta Bit)) - (\ ..functor map - (|>> (get@ #.imports) (list.any? (text\= import))) - ..current_module)) - -(def: #export (resolve_tag tag) - {#.doc "Given a tag, finds out what is its index, its related tag-list and its associated type."} - (-> Name (Meta [Nat (List Name) Type])) - (do ..monad - [#let [[module name] tag] - =module (..find_module module) - this_module_name ..current_module_name - imported! (..imported? module)] - (case (plist.get name (get@ #.tags =module)) - (#.Some [idx tag_list exported? type]) - (if (or (text\= this_module_name module) - (and imported! exported?)) - (wrap [idx tag_list type]) - (..fail ($_ text\compose "Cannot access tag: " (name\encode tag) " from module " this_module_name))) - - _ - (..fail ($_ text\compose - "Unknown tag: " (name\encode tag) text.new_line - " Known tags: " (|> =module - (get@ #.tags) - (list\map (|>> product.left [module] name\encode (text.prefix text.new_line))) - (text.join_with "")) - ))))) - -(def: #export (tag_lists module) - {#.doc "All the tag-lists defined in a module, with their associated types."} - (-> Text (Meta (List [(List Name) Type]))) - (do ..monad - [=module (..find_module module) - this_module_name ..current_module_name] - (wrap (|> (get@ #.types =module) - (list.filter (function (_ [type_name [tag_list exported? type]]) - (or exported? - (text\= this_module_name module)))) - (list\map (function (_ [type_name [tag_list exported? type]]) - [tag_list type])))))) - -(def: #export locals - {#.doc "All the local variables currently in scope, separated in different scopes."} - (Meta (List (List [Text Type]))) - (function (_ compiler) - (case (list.inits (get@ #.scopes compiler)) - #.None - (#try.Failure "No local environment") - - (#.Some scopes) - (#try.Success [compiler - (list\map (|>> (get@ [#.locals #.mappings]) - (list\map (function (_ [name [type _]]) - [name type]))) - scopes)])))) - -(def: #export (un_alias def_name) - {#.doc "Given an aliased definition's name, returns the original definition being referenced."} - (-> Name (Meta Name)) - (do ..monad - [constant (..find_def def_name)] - (wrap (case constant - (#.Left real_def_name) - real_def_name - - (#.Right _) - def_name)))) - -(def: #export get_compiler - {#.doc "Obtains the current state of the compiler."} - (Meta Lux) - (function (_ compiler) - (#try.Success [compiler compiler]))) - -(def: #export type_context - (Meta Type_Context) - (function (_ compiler) - (#try.Success [compiler (get@ #.type_context compiler)]))) - -(def: #export (lift result) - (All [a] (-> (Try a) (Meta a))) - (case result - (#try.Success output) - (\ ..monad wrap output) - - (#try.Failure error) - (..fail error))) diff --git a/stdlib/source/lux/meta/annotation.lux b/stdlib/source/lux/meta/annotation.lux deleted file mode 100644 index 648119177..000000000 --- a/stdlib/source/lux/meta/annotation.lux +++ /dev/null @@ -1,94 +0,0 @@ -(.module: - [lux (#- nat int rev) - [abstract - ["." monad (#+ do)]] - [data - ["." maybe] - ["." name ("#\." equivalence)]]]) - -(type: #export Annotation - Code) - -(def: #export (value tag ann) - (-> Name Annotation (Maybe Code)) - (case ann - [_ (#.Record ann)] - (loop [ann ann] - (case ann - (#.Cons [key value] ann') - (case key - [_ (#.Tag tag')] - (if (name\= tag tag') - (#.Some value) - (recur ann')) - - _ - (recur ann')) - - #.Nil - #.None)) - - _ - #.None)) - -(template [<name> <tag> <type>] - [(def: #export (<name> tag ann) - (-> Name Annotation (Maybe <type>)) - (case (..value tag ann) - (#.Some [_ (<tag> value)]) - (#.Some value) - - _ - #.None))] - - [bit #.Bit Bit] - [nat #.Nat Nat] - [int #.Int Int] - [rev #.Rev Rev] - [frac #.Frac Frac] - [text #.Text Text] - [identifier #.Identifier Name] - [tag #.Tag Name] - [form #.Form (List Code)] - [tuple #.Tuple (List Code)] - [record #.Record (List [Code Code])] - ) - -(def: #export documentation - (-> Annotation (Maybe Text)) - (..text (name_of #.doc))) - -(def: #export (flagged? flag) - (-> Name Annotation Bit) - (|>> (..bit flag) (maybe.default false))) - -(template [<name> <tag>] - [(def: #export <name> - (-> Annotation Bit) - (..flagged? (name_of <tag>)))] - - [implementation? #.implementation?] - [recursive_type? #.type-rec?] - [signature? #.sig?] - ) - -(def: (parse_text input) - (-> Code (Maybe Text)) - (case input - [_ (#.Text actual_value)] - (#.Some actual_value) - - _ - #.None)) - -(template [<name> <tag>] - [(def: #export (<name> ann) - (-> Annotation (List Text)) - (maybe.default (list) - (do {! maybe.monad} - [args (..tuple (name_of <tag>) ann)] - (monad.map ! ..parse_text args))))] - - [function_arguments #.func-args] - [type_arguments #.type-args] - ) diff --git a/stdlib/source/lux/meta/location.lux b/stdlib/source/lux/meta/location.lux deleted file mode 100644 index 5e8453c50..000000000 --- a/stdlib/source/lux/meta/location.lux +++ /dev/null @@ -1,48 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)]]]) - -(implementation: #export equivalence - (Equivalence Location) - - (def: (= reference subject) - (and ("lux text =" (get@ #.module reference) (get@ #.module subject)) - ("lux i64 =" (get@ #.line reference) (get@ #.line subject)) - ("lux i64 =" (get@ #.column reference) (get@ #.column subject))))) - -(def: #export dummy - Location - {#.module "" - #.line 0 - #.column 0}) - -(macro: #export (here tokens compiler) - (case tokens - #.Nil - (let [location (get@ #.location compiler)] - (#.Right [compiler - (list (` [(~ [..dummy (#.Text (get@ #.module location))]) - (~ [..dummy (#.Nat (get@ #.line location))]) - (~ [..dummy (#.Nat (get@ #.column location))])]))])) - - _ - (#.Left (("lux in-module" "lux" wrong_syntax_error) (name_of ..here))))) - -(def: #export (format value) - (-> Location Text) - (let [separator "," - [file line column] value] - ($_ "lux text concat" - "@" - (("lux in-module" "lux" .text\encode) file) separator - (("lux in-module" "lux" .nat\encode) line) separator - (("lux in-module" "lux" .nat\encode) column)))) - -(def: \n - ("lux i64 char" +10)) - -(def: #export (with location error) - (-> Location Text Text) - ($_ "lux text concat" (..format location) \n - error)) diff --git a/stdlib/source/lux/program.lux b/stdlib/source/lux/program.lux deleted file mode 100644 index 475bd7322..000000000 --- a/stdlib/source/lux/program.lux +++ /dev/null @@ -1,82 +0,0 @@ -(.module: - [lux #* - ["@" target] - [abstract - [monad (#+ do)]] - [control - ["." io] - [concurrency - ["." thread]] - ["<>" parser - ["<.>" code] - ["<.>" cli]]] - [data - ["." text] - [collection - ["." list ("#\." monad)]]] - [macro (#+ with_gensyms) - [syntax (#+ syntax:)] - ["." code]]]) - -(type: Arguments - (#Raw Text) - (#Parsed (List [Code Code]))) - -(def: arguments^ - (<code>.Parser Arguments) - (<>.or <code>.local_identifier - (<code>.tuple (<>.some (<>.either (do <>.monad - [name <code>.local_identifier] - (wrap [(code.identifier ["" name]) (` (~! <cli>.any))])) - (<code>.record (<>.and <code>.any <code>.any))))))) - -(syntax: #export (program: - {args ..arguments^} - body) - {#.doc (doc "Defines the entry-point to a program (similar to the 'main' function/method in other programming languages)." - "Can take a list of all the input parameters to the program." - "Or, can destructure them using CLI-option combinators from the lux/control/parser/cli module." - (program: all_args - (do io.monad - [foo init_program - bar (do_something all_args)] - (wrap []))) - - (program: [name] - (io (log! (\ text.monoid compose "Hello, " name)))) - - (program: [{config configuration_parser}] - (do io.monad - [data (init_program config)] - (do_something data))))} - (with_gensyms [g!program g!args g!_ g!output g!message] - (let [initialization+event_loop - (` ((~! do) (~! io.monad) - [(~ g!output) (~ body) - (~+ (for {@.old (list) - @.jvm (list) - @.js (list) - @.python (list)} - (list g!_ (` (~! thread.run!)))))] - ((~' wrap) (~ g!output))))] - (wrap (list (` ("lux def program" - (~ (case args - (#Raw args) - (` (.function ((~ g!program) (~ (code.identifier ["" args]))) - (~ initialization+event_loop))) - - (#Parsed args) - (` (.function ((~ g!program) (~ g!args)) - (case ((~! <cli>.run) (: (~! (<cli>.Parser (io.IO .Any))) - ((~! do) (~! <>.monad) - [(~+ (|> args - (list\map (function (_ [binding parser]) - (list binding parser))) - list\join))] - ((~' wrap) (~ initialization+event_loop)))) - (~ g!args)) - (#.Right (~ g!output)) - (~ g!output) - - (#.Left (~ g!message)) - (.error! (~ g!message)))))))))))))) diff --git a/stdlib/source/lux/target.lux b/stdlib/source/lux/target.lux deleted file mode 100644 index c548e6809..000000000 --- a/stdlib/source/lux/target.lux +++ /dev/null @@ -1,25 +0,0 @@ -(.module: - lux) - -(type: #export Target - Text) - -(template [<name> <value>] - [(def: #export <name> - Target - <value>)] - - ## TODO: Delete ASAP. - [old "{old}"] - ## Available. - [js "JavaScript"] - [jvm "JVM"] - [lua "Lua"] - [python "Python"] - [ruby "Ruby"] - ## Not available yet. - [common_lisp "Common Lisp"] - [php "PHP"] - [r "R"] - [scheme "Scheme"] - ) diff --git a/stdlib/source/lux/target/common_lisp.lux b/stdlib/source/lux/target/common_lisp.lux deleted file mode 100644 index f68d28c28..000000000 --- a/stdlib/source/lux/target/common_lisp.lux +++ /dev/null @@ -1,468 +0,0 @@ -(.module: - [lux (#- Code int if cond or and comment let) - [control - [pipe (#+ case> cond> new>)]] - [data - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." monad fold monoid)]]] - [macro - ["." template]] - [math - [number - ["f" frac]]] - [type - abstract]]) - -(def: as_form - (-> Text Text) - (text.enclose ["(" ")"])) - -(abstract: #export (Code brand) - Text - - (def: #export manual - (-> Text Code) - (|>> :abstraction)) - - (def: #export code - (-> (Code Any) Text) - (|>> :representation)) - - (template [<type> <super>] - [(with_expansions [<brand> (template.identifier [<type> "'"])] - (`` (abstract: #export (<brand> brand) Any)) - (`` (type: #export (<type> brand) - (<super> (<brand> brand)))))] - - [Expression Code] - [Computation Expression] - [Access Computation] - [Var Access] - - [Input Code] - ) - - (template [<type> <super>] - [(with_expansions [<brand> (template.identifier [<type> "'"])] - (`` (abstract: #export <brand> Any)) - (`` (type: #export <type> (<super> <brand>))))] - - [Label Code] - [Tag Expression] - [Literal Expression] - [Var/1 Var] - [Var/* Input] - ) - - (type: #export Lambda - {#input Var/* - #output (Expression Any)}) - - (def: #export nil - Literal - (:abstraction "()")) - - (template [<prefix> <name>] - [(def: #export <name> - (-> Text Literal) - (|>> (format <prefix>) :abstraction))] - - ["'" symbol] - [":" keyword]) - - (def: #export bool - (-> Bit Literal) - (|>> (case> #0 ..nil - #1 (..symbol "t")))) - - (def: #export int - (-> Int Literal) - (|>> %.int :abstraction)) - - (def: #export float - (-> Frac Literal) - (|>> (cond> [(f.= f.positive_infinity)] - [(new> "(/ 1.0 0.0)" [])] - - [(f.= f.negative_infinity)] - [(new> "(/ -1.0 0.0)" [])] - - [f.not_a_number?] - [(new> "(/ 0.0 0.0)" [])] - - ## else - [%.frac]) - :abstraction)) - - (def: #export (double value) - (-> Frac Literal) - (:abstraction - (.cond (f.= f.positive_infinity value) - "(/ 1.0d0 0.0d0)" - - (f.= f.negative_infinity value) - "(/ -1.0d0 0.0d0)" - - (f.not_a_number? value) - "(/ 0.0d0 0.0d0)" - - ## else - (.let [raw (%.frac value)] - (.if (text.contains? "E" raw) - (text.replace_once "E" "d" raw) - (format raw "d0")))))) - - (def: sanitize - (-> Text Text) - (`` (|>> (~~ (template [<find> <replace>] - [(text.replace_all <find> <replace>)] - - ["\" "\\"] - [text.tab "\t"] - [text.vertical_tab "\v"] - [text.null "\0"] - [text.back_space "\b"] - [text.form_feed "\f"] - [text.new_line "\n"] - [text.carriage_return "\r"] - [text.double_quote (format "\" text.double_quote)] - )) - ))) - - (def: #export string - (-> Text Literal) - (|>> ..sanitize - (text.enclose' text.double_quote) - :abstraction)) - - (def: #export var - (-> Text Var/1) - (|>> :abstraction)) - - (def: #export args - (-> (List Var/1) Var/*) - (|>> (list\map ..code) - (text.join_with " ") - ..as_form - :abstraction)) - - (def: #export (args& singles rest) - (-> (List Var/1) Var/1 Var/*) - (|> (case singles - #.Nil - "" - - (#.Cons _) - (|> singles - (list\map ..code) - (text.join_with " ") - (text.suffix " "))) - (format "&rest " (:representation rest)) - ..as_form - :abstraction)) - - (def: form - (-> (List (Expression Any)) Expression) - (|>> (list\map ..code) - (text.join_with " ") - ..as_form - :abstraction)) - - (def: #export (call/* func) - (-> (Expression Any) (-> (List (Expression Any)) (Computation Any))) - (|>> (#.Cons func) ..form)) - - (template [<name> <function>] - [(def: #export <name> - (-> (List (Expression Any)) (Computation Any)) - (..call/* (..var <function>)))] - - [vector/* "vector"] - [list/* "list"] - ) - - (def: #export (labels definitions body) - (-> (List [Var/1 Lambda]) (Expression Any) (Computation Any)) - (..form (list (..var "labels") - (..form (list\map (function (_ [def_name [def_args def_body]]) - (..form (list def_name (:transmutation def_args) def_body))) - definitions)) - body))) - - (def: #export (destructuring-bind [bindings expression] body) - (-> [Var/* (Expression Any)] (List (Expression Any)) (Computation Any)) - (..form (list& (..var "destructuring-bind") - (:transmutation bindings) expression - body))) - - (template [<call> <input_var>+ <input_type>+ <function>+] - [(`` (def: #export (<call> [(~~ (template.splice <input_var>+))] function) - (-> [(~~ (template.splice <input_type>+))] (Expression Any) (Computation Any)) - (..call/* function (list (~~ (template.splice <input_var>+)))))) - - (`` (template [<lux_name> <host_name>] - [(def: #export (<lux_name> args) - (-> [(~~ (template.splice <input_type>+))] (Computation Any)) - (<call> args (..var <host_name>)))] - - (~~ (template.splice <function>+))))] - - [call/0 [] [] - [[get-universal-time/0 "get-universal-time"] - [make-hash-table/0 "make-hash-table"]]] - [call/1 [in0] [(Expression Any)] - [[length/1 "length"] - [function/1 "function"] - [copy-seq/1 "copy-seq"] - [null/1 "null"] - [error/1 "error"] - [not/1 "not"] - [floor/1 "floor"] - [type-of/1 "type-of"] - [write-to-string/1 "write-to-string"] - [read-from-string/1 "read-from-string"] - [print/1 "print"] - [reverse/1 "reverse"] - [sxhash/1 "sxhash"] - [string-upcase/1 "string-upcase"] - [string-downcase/1 "string-downcase"] - [char-int/1 "char-int"] - [text/1 "text"] - [hash-table-size/1 "hash-table-size"] - [hash-table-rehash-size/1 "hash-table-rehash-size"] - [code-char/1 "code-char"] - [char-code/1 "char-code"] - [string/1 "string"] - [write-line/1 "write-line"] - [pprint/1 "pprint"] - [identity/1 "identity"]]] - [call/2 [in0 in1] [(Expression Any) (Expression Any)] - [[apply/2 "apply"] - [append/2 "append"] - [cons/2 "cons"] - [char/2 "char"] - [nth/2 "nth"] - [nthcdr/2 "nthcdr"] - [coerce/2 "coerce"] - [eq/2 "eq"] - [equal/2 "equal"] - [string=/2 "string="] - [=/2 "="] - [+/2 "+"] - [*/2 "*"]]] - [call/3 [in0 in1 in2] [(Expression Any) (Expression Any) (Expression Any)] - [[subseq/3 "subseq"] - [map/3 "map"] - [concatenate/3 "concatenate"] - [format/3 "format"]]] - ) - - (template [<call> <input_type>+ <function>+] - [(`` (template [<lux_name> <host_name>] - [(def: #export (<lux_name> args) - (-> [(~~ (template.splice <input_type>+))] (Access Any)) - (:transmutation (<call> args (..var <host_name>))))] - - (~~ (template.splice <function>+))))] - - [call/1 [(Expression Any)] - [[car/1 "car"] - [cdr/1 "cdr"] - [cadr/1 "cadr"] - [cddr/1 "cddr"]]] - [call/2 [(Expression Any) (Expression Any)] - [[svref/2 "svref"] - [elt/2 "elt"] - [gethash/2 "gethash"]]] - ) - - (def: #export (make-hash-table/with_size size) - (-> (Expression Any) (Computation Any)) - (..call/* (..var "make-hash-table") - (list (..keyword "size") - size))) - - (def: #export (funcall/+ [func args]) - (-> [(Expression Any) (List (Expression Any))] (Computation Any)) - (..call/* (..var "funcall") (list& func args))) - - (def: #export (search/3 [reference space start]) - (-> [(Expression Any) (Expression Any) (Expression Any)] (Computation Any)) - (..call/* (..var "search") - (list reference - space - (..keyword "start2") start))) - - (def: #export (concatenate/2|string [left right]) - (-> [(Expression Any) (Expression Any)] (Computation Any)) - (concatenate/3 [(..symbol "string") left right])) - - (template [<lux_name> <host_name>] - [(def: #export (<lux_name> left right) - (-> (Expression Any) (Expression Any) (Computation Any)) - (..form (list (..var <host_name>) left right)))] - - [or "or"] - [and "and"] - ) - - (template [<lux_name> <host_name>] - [(def: #export (<lux_name> [param subject]) - (-> [(Expression Any) (Expression Any)] (Computation Any)) - (..form (list (..var <host_name>) subject param)))] - - [</2 "<"] - [<=/2 "<="] - [>/2 ">"] - [>=/2 ">="] - [string</2 "string<"] - [-/2 "-"] - [//2 "/"] - [rem/2 "rem"] - [floor/2 "floor"] - [mod/2 "mod"] - [ash/2 "ash"] - [logand/2 "logand"] - [logior/2 "logior"] - [logxor/2 "logxor"] - ) - - (def: #export (if test then else) - (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any)) - (..form (list (..var "if") test then else))) - - (def: #export (when test then) - (-> (Expression Any) (Expression Any) (Computation Any)) - (..form (list (..var "when") test then))) - - (def: #export (lambda input body) - (-> Var/* (Expression Any) Literal) - (..form (list (..var "lambda") (:transmutation input) body))) - - (template [<lux_name> <host_name>] - [(def: #export (<lux_name> bindings body) - (-> (List [Var/1 (Expression Any)]) (List (Expression Any)) (Computation Any)) - (..form (list& (..var <host_name>) - (|> bindings - (list\map (function (_ [name value]) - (..form (list name value)))) - ..form) - body)))] - - [let "let"] - [let* "let*"] - ) - - (def: #export (defparameter name body) - (-> Var/1 (Expression Any) (Expression Any)) - (..form (list (..var "defparameter") name body))) - - (def: #export (defun name inputs body) - (-> Var/1 Var/* (Expression Any) (Expression Any)) - (..form (list (..var "defun") name (:transmutation inputs) body))) - - (template [<name> <symbol>] - [(def: #export <name> - (-> (List (Expression Any)) (Computation Any)) - (|>> (list& (..var <symbol>)) ..form))] - - [progn "progn"] - [tagbody "tagbody"] - [values/* "values"] - ) - - (def: #export (setq name value) - (-> Var/1 (Expression Any) (Expression Any)) - (..form (list (..var "setq") name value))) - - (def: #export (setf access value) - (-> (Access Any) (Expression Any) (Expression Any)) - (..form (list (..var "setf") access value))) - - (type: #export Handler - {#condition_type (Expression Any) - #condition Var/1 - #body (Expression Any)}) - - (def: #export (handler-case handlers body) - (-> (List Handler) (Expression Any) (Computation Any)) - (..form (list& (..var "handler-case") - body - (list\map (function (_ [type condition handler]) - (..form (list type - (:transmutation (..args (list condition))) - handler))) - handlers)))) - - (template [<name> <prefix>] - [(def: #export (<name> conditions expression) - (-> (List Text) (Expression Any) (Expression Any)) - (case conditions - #.Nil - expression - - (#.Cons single #.Nil) - (:abstraction - (format <prefix> single " " (:representation expression))) - - _ - (:abstraction - (format <prefix> (|> conditions (list\map ..symbol) - (list& (..symbol "or")) ..form - :representation) - " " (:representation expression)))))] - - [conditional+ "#+"] - [conditional- "#-"]) - - (def: #export label - (-> Text Label) - (|>> :abstraction)) - - (def: #export (block name body) - (-> Label (List (Expression Any)) (Computation Any)) - (..form (list& (..var "block") (:transmutation name) body))) - - (def: #export (return-from target value) - (-> Label (Expression Any) (Computation Any)) - (..form (list (..var "return-from") (:transmutation target) value))) - - (def: #export (return value) - (-> (Expression Any) (Computation Any)) - (..form (list (..var "return") value))) - - (def: #export (cond clauses else) - (-> (List [(Expression Any) (Expression Any)]) (Expression Any) (Computation Any)) - (..form (list& (..var "cond") - (list\compose (list\map (function (_ [test then]) - (..form (list test then))) - clauses) - (list (..form (list (..bool true) else))))))) - - (def: #export tag - (-> Text Tag) - (|>> :abstraction)) - - (def: #export go - (-> Tag (Expression Any)) - (|>> (list (..var "go")) - ..form)) - - (def: #export values-list/1 - (-> (Expression Any) (Expression Any)) - (|>> (list (..var "values-list")) - ..form)) - - (def: #export (multiple-value-setq bindings values) - (-> Var/* (Expression Any) (Expression Any)) - (..form (list (..var "multiple-value-setq") - (:transmutation bindings) - values))) - ) - -(def: #export (while condition body) - (-> (Expression Any) (Expression Any) (Computation Any)) - (..form (list (..var "loop") (..var "while") condition - (..var "do") body))) diff --git a/stdlib/source/lux/target/js.lux b/stdlib/source/lux/target/js.lux deleted file mode 100644 index f1a7c3e72..000000000 --- a/stdlib/source/lux/target/js.lux +++ /dev/null @@ -1,448 +0,0 @@ -(.module: - [lux (#- Location Code or and function if cond undefined for comment not int try) - [control - [pipe (#+ case>)]] - [data - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [macro - ["." template]] - [math - [number - ["i" int] - ["f" frac]]] - [type - abstract]]) - -(def: expression (text.enclose ["(" ")"])) -(def: element (text.enclose ["[" "]"])) - -(def: nest - (-> Text Text) - (|>> (format text.new_line) - (text.replace_all text.new_line (format text.new_line text.tab)))) - -(abstract: #export (Code brand) - Text - - (def: #export code - (-> (Code Any) Text) - (|>> :representation)) - - (template [<type> <super>+] - [(with_expansions [<brand> (template.identifier [<type> "'"])] - (abstract: (<brand> brand) Any) - (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+))))))] - - [Expression [Code]] - [Computation [Expression' Code]] - [Location [Computation' Expression' Code]] - [Statement [Code]] - ) - - (template [<type> <super>+] - [(with_expansions [<brand> (template.identifier [<type> "'"])] - (abstract: #export <brand> Any) - (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+))))))] - - [Var [Location' Computation' Expression' Code]] - [Access [Location' Computation' Expression' Code]] - [Literal [Computation' Expression' Code]] - [Loop [Statement' Code]] - [Label [Code]] - ) - - (template [<name> <literal>] - [(def: #export <name> Literal (:abstraction <literal>))] - - [null "null"] - [undefined "undefined"] - ) - - (def: #export boolean - (-> Bit Literal) - (|>> (case> - #0 "false" - #1 "true") - :abstraction)) - - (def: #export (number value) - (-> Frac Literal) - (:abstraction - (.cond (f.not_a_number? value) - "NaN" - - (f.= f.positive_infinity value) - "Infinity" - - (f.= f.negative_infinity value) - "-Infinity" - - ## else - (|> value %.frac ..expression)))) - - (def: sanitize - (-> Text Text) - (`` (|>> (~~ (template [<replace> <find>] - [(text.replace_all <find> <replace>)] - - ["\\" "\"] - ["\t" text.tab] - ["\v" text.vertical_tab] - ["\0" text.null] - ["\b" text.back_space] - ["\f" text.form_feed] - ["\n" text.new_line] - ["\r" text.carriage_return] - [(format "\" text.double_quote) - text.double_quote] - )) - ))) - - (def: #export string - (-> Text Literal) - (|>> ..sanitize - (text.enclose [text.double_quote text.double_quote]) - :abstraction)) - - (def: argument_separator ", ") - (def: field_separator ": ") - (def: statement_suffix ";") - - (def: #export array - (-> (List Expression) Computation) - (|>> (list\map ..code) - (text.join_with ..argument_separator) - ..element - :abstraction)) - - (def: #export var - (-> Text Var) - (|>> :abstraction)) - - (def: #export (at index array_or_object) - (-> Expression Expression Access) - (:abstraction (format (:representation array_or_object) (..element (:representation index))))) - - (def: #export (the field object) - (-> Text Expression Access) - (:abstraction (format (:representation object) "." field))) - - (def: #export (apply/* function inputs) - (-> Expression (List Expression) Computation) - (|> inputs - (list\map ..code) - (text.join_with ..argument_separator) - ..expression - (format (:representation function)) - :abstraction)) - - (def: #export (do method inputs object) - (-> Text (List Expression) Expression Computation) - (apply/* (..the method object) inputs)) - - (def: #export object - (-> (List [Text Expression]) Computation) - (|>> (list\map (.function (_ [key val]) - (format (:representation (..string key)) ..field_separator (:representation val)))) - (text.join_with ..argument_separator) - (text.enclose ["{" "}"]) - ..expression - :abstraction)) - - (def: #export (, pre post) - (-> Expression Expression Computation) - (|> (format (:representation pre) ..argument_separator (:representation post)) - ..expression - :abstraction)) - - (def: #export (then pre post) - (-> Statement Statement Statement) - (:abstraction (format (:representation pre) - text.new_line - (:representation post)))) - - (def: block - (-> Statement Text) - (let [close (format text.new_line "}")] - (|>> :representation - ..nest - (text.enclose ["{" - close])))) - - (def: #export (function! name inputs body) - (-> Var (List Var) Statement Statement) - (|> body - ..block - (format "function " (:representation name) - (|> inputs - (list\map ..code) - (text.join_with ..argument_separator) - ..expression) - " ") - :abstraction)) - - (def: #export (function name inputs body) - (-> Var (List Var) Statement Computation) - (|> (..function! name inputs body) - :representation - ..expression - :abstraction)) - - (def: #export (closure inputs body) - (-> (List Var) Statement Computation) - (|> body - ..block - (format "function" - (|> inputs - (list\map ..code) - (text.join_with ..argument_separator) - ..expression) - " ") - ..expression - :abstraction)) - - (template [<name> <op>] - [(def: #export (<name> param subject) - (-> Expression Expression Computation) - (|> (format (:representation subject) " " <op> " " (:representation param)) - ..expression - :abstraction))] - - [= "==="] - [< "<"] - [<= "<="] - [> ">"] - [>= ">="] - - [+ "+"] - [- "-"] - [* "*"] - [/ "/"] - [% "%"] - - [left_shift "<<"] - [arithmetic_right_shift ">>"] - [logic_right_shift ">>>"] - - [or "||"] - [and "&&"] - [bit_xor "^"] - [bit_or "|"] - [bit_and "&"] - ) - - (template [<name> <prefix>] - [(def: #export <name> - (-> Expression Computation) - (|>> :representation (text.prefix <prefix>) ..expression :abstraction))] - - [not "!"] - [bit_not "~"] - [negate "-"] - ) - - (template [<name> <input> <format>] - [(def: #export (<name> value) - {#.doc "A 32-bit integer expression."} - (-> <input> Computation) - (:abstraction (..expression (format (<format> value) "|0"))))] - - [to_i32 Expression :representation] - [i32 Int %.int] - ) - - (def: #export (int value) - (-> Int Literal) - (:abstraction (.if (i.< +0 value) - (%.int value) - (%.nat (.nat value))))) - - (def: #export (? test then else) - (-> Expression Expression Expression Computation) - (|> (format (:representation test) - " ? " (:representation then) - " : " (:representation else)) - ..expression - :abstraction)) - - (def: #export type_of - (-> Expression Computation) - (|>> :representation - (format "typeof ") - ..expression - :abstraction)) - - (def: #export (new constructor inputs) - (-> Expression (List Expression) Computation) - (|> (format "new " (:representation constructor) - (|> inputs - (list\map ..code) - (text.join_with ..argument_separator) - ..expression)) - ..expression - :abstraction)) - - (def: #export statement - (-> Expression Statement) - (|>> :representation (text.suffix ..statement_suffix) :abstraction)) - - (def: #export use_strict - Statement - (:abstraction (format text.double_quote "use strict" text.double_quote ..statement_suffix))) - - (def: #export (declare name) - (-> Var Statement) - (:abstraction (format "var " (:representation name) ..statement_suffix))) - - (def: #export (define name value) - (-> Var Expression Statement) - (:abstraction (format "var " (:representation name) " = " (:representation value) ..statement_suffix))) - - (def: #export (set' name value) - (-> Location Expression Expression) - (:abstraction (..expression (format (:representation name) " = " (:representation value))))) - - (def: #export (set name value) - (-> Location Expression Statement) - (:abstraction (format (:representation name) " = " (:representation value) ..statement_suffix))) - - (def: #export (throw message) - (-> Expression Statement) - (:abstraction (format "throw " (:representation message) ..statement_suffix))) - - (def: #export (return value) - (-> Expression Statement) - (:abstraction (format "return " (:representation value) ..statement_suffix))) - - (def: #export (delete' value) - (-> Location Expression) - (:abstraction (format "delete " (:representation value)))) - - (def: #export (delete value) - (-> Location Statement) - (:abstraction (format (:representation (delete' value)) ..statement_suffix))) - - (def: #export (if test then! else!) - (-> Expression Statement Statement Statement) - (:abstraction (format "if(" (:representation test) ") " - (..block then!) - " else " - (..block else!)))) - - (def: #export (when test then!) - (-> Expression Statement Statement) - (:abstraction (format "if(" (:representation test) ") " - (..block then!)))) - - (def: #export (while test body) - (-> Expression Statement Loop) - (:abstraction (format "while(" (:representation test) ") " - (..block body)))) - - (def: #export (do_while test body) - (-> Expression Statement Loop) - (:abstraction (format "do " (..block body) - " while(" (:representation test) ")" ..statement_suffix))) - - (def: #export (try body [exception catch]) - (-> Statement [Var Statement] Statement) - (:abstraction (format "try " - (..block body) - " catch(" (:representation exception) ") " - (..block catch)))) - - (def: #export (for var init condition update iteration) - (-> Var Expression Expression Expression Statement Loop) - (:abstraction (format "for(" (:representation (..define var init)) - " " (:representation condition) - ..statement_suffix " " (:representation update) - ")" - (..block iteration)))) - - (def: #export label - (-> Text Label) - (|>> :abstraction)) - - (def: #export (with_label label loop) - (-> Label Loop Statement) - (:abstraction (format (:representation label) ": " (:representation loop)))) - - (template [<keyword> <0> <1>] - [(def: #export <0> - Statement - (:abstraction (format <keyword> ..statement_suffix))) - - (def: #export (<1> label) - (-> Label Statement) - (:abstraction (format <keyword> " " (:representation label) ..statement_suffix)))] - - ["break" break break_at] - ["continue" continue continue_at] - ) - - (template [<name> <js>] - [(def: #export <name> - (-> Location Expression) - (|>> :representation - (text.suffix <js>) - :abstraction))] - - [++ "++"] - [-- "--"] - ) - - (def: #export (comment commentary on) - (All [kind] (-> Text (Code kind) (Code kind))) - (:abstraction (format "/* " commentary " */" " " (:representation on)))) - - (def: #export (switch input cases default) - (-> Expression (List [(List Literal) Statement]) (Maybe Statement) Statement) - (:abstraction (format "switch (" (:representation input) ") " - (|> (format (|> cases - (list\map (.function (_ [when then]) - (format (|> when - (list\map (|>> :representation (text.enclose ["case " ":"]))) - (text.join_with text.new_line)) - (..nest (:representation then))))) - (text.join_with text.new_line)) - text.new_line - (case default - (#.Some default) - (format "default:" - (..nest (:representation default))) - - #.None "")) - :abstraction - ..block)))) - ) - -(def: #export (cond clauses else!) - (-> (List [Expression Statement]) Statement Statement) - (list\fold (.function (_ [test then!] next!) - (..if test then! next!)) - else! - (list.reverse clauses))) - -(template [<apply> <arg>+ <type>+ <function>+] - [(`` (def: #export (<apply> function) - (-> Expression (~~ (template.splice <type>+)) Computation) - (.function (_ (~~ (template.splice <arg>+))) - (..apply/* function (list (~~ (template.splice <arg>+))))))) - - (`` (template [<definition> <function>] - [(def: #export <definition> (<apply> (..var <function>)))] - - (~~ (template.splice <function>+))))] - - [apply/1 [_0] [Expression] - [[not_a_number? "isNaN"]]] - - [apply/2 [_0 _1] [Expression Expression] - []] - - [apply/3 [_0 _1 _2] [Expression Expression Expression] - []] - ) diff --git a/stdlib/source/lux/target/jvm.lux b/stdlib/source/lux/target/jvm.lux deleted file mode 100644 index 4250bf705..000000000 --- a/stdlib/source/lux/target/jvm.lux +++ /dev/null @@ -1,283 +0,0 @@ -(.module: - [lux (#- Type) - [data - [collection - [row (#+ Row)]]] - [target - [jvm - [type (#+ Type) - ["." category (#+ Primitive Class Value Method)]]]]]) - -(type: #export Literal - (#Boolean Bit) - (#Int Int) - (#Long Int) - (#Double Frac) - (#Char Nat) - (#String Text)) - -(type: #export Constant - (#BIPUSH Int) - - (#SIPUSH Int) - - #ICONST_M1 - #ICONST_0 - #ICONST_1 - #ICONST_2 - #ICONST_3 - #ICONST_4 - #ICONST_5 - - #LCONST_0 - #LCONST_1 - - #FCONST_0 - #FCONST_1 - #FCONST_2 - - #DCONST_0 - #DCONST_1 - - #ACONST_NULL - - (#LDC Literal)) - -(type: #export Int_Arithmetic - #IADD - #ISUB - #IMUL - #IDIV - #IREM - #INEG) - -(type: #export Long_Arithmetic - #LADD - #LSUB - #LMUL - #LDIV - #LREM - #LNEG) - -(type: #export Float_Arithmetic - #FADD - #FSUB - #FMUL - #FDIV - #FREM - #FNEG) - -(type: #export Double_Arithmetic - #DADD - #DSUB - #DMUL - #DDIV - #DREM - #DNEG) - -(type: #export Arithmetic - (#Int_Arithmetic Int_Arithmetic) - (#Long_Arithmetic Long_Arithmetic) - (#Float_Arithmetic Float_Arithmetic) - (#Double_Arithmetic Double_Arithmetic)) - -(type: #export Int_Bitwise - #IOR - #IXOR - #IAND - #ISHL - #ISHR - #IUSHR) - -(type: #export Long_Bitwise - #LOR - #LXOR - #LAND - #LSHL - #LSHR - #LUSHR) - -(type: #export Bitwise - (#Int_Bitwise Int_Bitwise) - (#Long_Bitwise Long_Bitwise)) - -(type: #export Conversion - #I2B - #I2S - #I2L - #I2F - #I2D - #I2C - - #L2I - #L2F - #L2D - - #F2I - #F2L - #F2D - - #D2I - #D2L - #D2F) - -(type: #export Array - #ARRAYLENGTH - - (#NEWARRAY (Type Primitive)) - (#ANEWARRAY (Type category.Object)) - - #BALOAD - #BASTORE - - #SALOAD - #SASTORE - - #IALOAD - #IASTORE - - #LALOAD - #LASTORE - - #FALOAD - #FASTORE - - #DALOAD - #DASTORE - - #CALOAD - #CASTORE - - #AALOAD - #AASTORE) - -(type: #export Object - (#GETSTATIC (Type Class) Text (Type Value)) - (#PUTSTATIC (Type Class) Text (Type Value)) - - (#NEW (Type Class)) - - (#INSTANCEOF (Type Class)) - (#CHECKCAST (Type category.Object)) - - (#GETFIELD (Type Class) Text (Type Value)) - (#PUTFIELD (Type Class) Text (Type Value)) - - (#INVOKEINTERFACE (Type Class) Text (Type Method)) - (#INVOKESPECIAL (Type Class) Text (Type Method)) - (#INVOKESTATIC (Type Class) Text (Type Method)) - (#INVOKEVIRTUAL (Type Class) Text (Type Method))) - -(type: #export Register Nat) - -(type: #export Local_Int - (#ILOAD Register) - (#ISTORE Register)) - -(type: #export Local_Long - (#LLOAD Register) - (#LSTORE Register)) - -(type: #export Local_Float - (#FLOAD Register) - (#FSTORE Register)) - -(type: #export Local_Double - (#DLOAD Register) - (#DSTORE Register)) - -(type: #export Local_Object - (#ALOAD Register) - (#ASTORE Register)) - -(type: #export Local - (#Local_Int Local_Int) - (#IINC Register) - (#Local_Long Local_Long) - (#Local_Float Local_Float) - (#Local_Double Local_Double) - (#Local_Object Local_Object)) - -(type: #export Stack - #DUP - #DUP_X1 - #DUP_X2 - #DUP2 - #DUP2_X1 - #DUP2_X2 - #SWAP - #POP - #POP2) - -(type: #export Comparison - #LCMP - - #FCMPG - #FCMPL - - #DCMPG - #DCMPL) - -(type: #export Label Nat) - -(type: #export (Branching label) - (#IF_ICMPEQ label) - (#IF_ICMPGE label) - (#IF_ICMPGT label) - (#IF_ICMPLE label) - (#IF_ICMPLT label) - (#IF_ICMPNE label) - (#IFEQ label) - (#IFNE label) - (#IFGE label) - (#IFGT label) - (#IFLE label) - (#IFLT label) - - (#TABLESWITCH Int Int label (List label)) - (#LOOKUPSWITCH label (List [Int label])) - - (#IF_ACMPEQ label) - (#IF_ACMPNE label) - (#IFNONNULL label) - (#IFNULL label)) - -(type: #export (Exception label) - (#Try label label label (Type Class)) - #ATHROW) - -(type: #export Concurrency - #MONITORENTER - #MONITOREXIT) - -(type: #export Return - #RETURN - #IRETURN - #LRETURN - #FRETURN - #DRETURN - #ARETURN) - -(type: #export (Control label) - (#GOTO label) - (#Branching (Branching label)) - (#Exception (Exception label)) - (#Concurrency Concurrency) - (#Return Return)) - -(type: #export (Instruction embedded label) - #NOP - (#Constant Constant) - (#Arithmetic Arithmetic) - (#Bitwise Bitwise) - (#Conversion Conversion) - (#Array Array) - (#Object Object) - (#Local Local) - (#Stack Stack) - (#Comparison Comparison) - (#Control (Control label)) - (#Embedded embedded)) - -(type: #export (Bytecode embedded label) - (Row (Instruction embedded label))) diff --git a/stdlib/source/lux/target/jvm/attribute.lux b/stdlib/source/lux/target/jvm/attribute.lux deleted file mode 100644 index 0b8457a9c..000000000 --- a/stdlib/source/lux/target/jvm/attribute.lux +++ /dev/null @@ -1,122 +0,0 @@ -(.module: - [lux (#- Info Code) - [abstract - [monad (#+ do)] - ["." equivalence (#+ Equivalence)]] - [control - ["." try] - ["." exception (#+ exception:)]] - [data - ["." sum] - ["." product] - [format - [".F" binary (#+ Writer)]]] - [math - [number - ["n" nat]]]] - ["." // #_ - ["#." index (#+ Index)] - [encoding - ["#." unsigned (#+ U2 U4)]] - ["#." constant (#+ UTF8 Class Value) - ["#/." pool (#+ Pool Resource)]]] - ["." / #_ - ["#." constant (#+ Constant)] - ["#." code]]) - -(type: #export (Info about) - {#name (Index UTF8) - #length U4 - #info about}) - -(def: #export (info_equivalence Equivalence<about>) - (All [about] - (-> (Equivalence about) - (Equivalence (Info about)))) - ($_ product.equivalence - //index.equivalence - //unsigned.equivalence - Equivalence<about>)) - -(def: (info_writer writer) - (All [about] - (-> (Writer about) - (Writer (Info about)))) - (function (_ [name length info]) - (let [[nameS nameT] (//index.writer name) - [lengthS lengthT] (//unsigned.writer/4 length) - [infoS infoT] (writer info)] - [($_ n.+ nameS lengthS infoS) - (|>> nameT lengthT infoT)]))) - -(with_expansions [<Code> (as_is (/code.Code Attribute))] - (type: #export #rec Attribute - (#Constant (Info (Constant Any))) - (#Code (Info <Code>))) - - (type: #export Code - <Code>) - ) - -(def: #export equivalence - (Equivalence Attribute) - (equivalence.rec - (function (_ equivalence) - ($_ sum.equivalence - (info_equivalence /constant.equivalence) - (info_equivalence (/code.equivalence equivalence)))))) - -(def: common_attribute_length - ($_ n.+ - ## u2 attribute_name_index; - //unsigned.bytes/2 - ## u4 attribute_length; - //unsigned.bytes/4 - )) - -(def: (length attribute) - (-> Attribute Nat) - (case attribute - (^template [<tag>] - [(<tag> [name length info]) - (|> length //unsigned.value (n.+ ..common_attribute_length))]) - ([#Constant] [#Code]))) - -## TODO: Inline ASAP -(def: (constant' @name index) - (-> (Index UTF8) (Constant Any) Attribute) - (#Constant {#name @name - #length (|> /constant.length //unsigned.u4 try.assume) - #info index})) - -(def: #export (constant index) - (-> (Constant Any) (Resource Attribute)) - (do //constant/pool.monad - [@name (//constant/pool.utf8 "ConstantValue")] - (wrap (constant' @name index)))) - -## TODO: Inline ASAP -(def: (code' @name specification) - (-> (Index UTF8) Code Attribute) - (#Code {#name @name - ## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.3 - #length (|> specification - (/code.length ..length) - //unsigned.u4 - try.assume) - #info specification})) - -(def: #export (code specification) - (-> Code (Resource Attribute)) - (do //constant/pool.monad - [@name (//constant/pool.utf8 "Code")] - (wrap (code' @name specification)))) - -(def: #export (writer value) - (Writer Attribute) - (case value - (#Constant attribute) - ((info_writer /constant.writer) attribute) - - (#Code attribute) - ((info_writer (/code.writer writer)) attribute))) diff --git a/stdlib/source/lux/target/jvm/attribute/code.lux b/stdlib/source/lux/target/jvm/attribute/code.lux deleted file mode 100644 index 212d44765..000000000 --- a/stdlib/source/lux/target/jvm/attribute/code.lux +++ /dev/null @@ -1,82 +0,0 @@ -(.module: - [lux (#- Code) - [type (#+ :share)] - [abstract - [equivalence (#+ Equivalence)]] - [data - ["." product] - ["." binary (#+ Binary)] - [format - [".F" binary (#+ Writer) ("#\." monoid)]] - [collection - ["." row (#+ Row) ("#\." functor fold)]]] - [math - [number - ["n" nat]]]] - ["." /// #_ - [bytecode - [environment - ["#." limit (#+ Limit)]]] - [encoding - ["#." unsigned (#+ U2)]]] - ["." / #_ - ["#." exception (#+ Exception)]]) - -(type: #export (Code Attribute) - {#limit Limit - #code Binary - #exception_table (Row Exception) - #attributes (Row Attribute)}) - -(def: #export (length length code) - (All [Attribute] (-> (-> Attribute Nat) (Code Attribute) Nat)) - ($_ n.+ - ## u2 max_stack; - ## u2 max_locals; - ///limit.length - ## u4 code_length; - ///unsigned.bytes/4 - ## u1 code[code_length]; - (binary.size (get@ #code code)) - ## u2 exception_table_length; - ///unsigned.bytes/2 - ## exception_table[exception_table_length]; - (|> code - (get@ #exception_table) - row.size - (n.* /exception.length)) - ## u2 attributes_count; - ///unsigned.bytes/2 - ## attribute_info attributes[attributes_count]; - (|> code - (get@ #attributes) - (row\map length) - (row\fold n.+ 0)))) - -(def: #export (equivalence attribute_equivalence) - (All [attribute] - (-> (Equivalence attribute) (Equivalence (Code attribute)))) - ($_ product.equivalence - ///limit.equivalence - binary.equivalence - (row.equivalence /exception.equivalence) - (row.equivalence attribute_equivalence) - )) - -## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.3 -(def: #export (writer writer code) - (All [Attribute] (-> (Writer Attribute) (Writer (Code Attribute)))) - ($_ binaryF\compose - ## u2 max_stack; - ## u2 max_locals; - (///limit.writer (get@ #limit code)) - ## u4 code_length; - ## u1 code[code_length]; - (binaryF.binary/32 (get@ #code code)) - ## u2 exception_table_length; - ## exception_table[exception_table_length]; - ((binaryF.row/16 /exception.writer) (get@ #exception_table code)) - ## u2 attributes_count; - ## attribute_info attributes[attributes_count]; - ((binaryF.row/16 writer) (get@ #attributes code)) - )) diff --git a/stdlib/source/lux/target/jvm/attribute/code/exception.lux b/stdlib/source/lux/target/jvm/attribute/code/exception.lux deleted file mode 100644 index 9ae264438..000000000 --- a/stdlib/source/lux/target/jvm/attribute/code/exception.lux +++ /dev/null @@ -1,57 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)]] - [data - ["." product] - ["." format #_ - ["#" binary (#+ Writer)]]] - [math - [number - ["n" nat]]]] - ["." // #_ - ["//#" /// #_ - [constant (#+ Class)] - ["#." index (#+ Index)] - [bytecode - ["#." address (#+ Address)]] - [encoding - ["#." unsigned (#+ U2)]]]]) - -(type: #export Exception - {#start Address - #end Address - #handler Address - #catch (Index Class)}) - -(def: #export equivalence - (Equivalence Exception) - ($_ product.equivalence - ////address.equivalence - ////address.equivalence - ////address.equivalence - ////index.equivalence - )) - -## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.3 -(def: #export length - Nat - ($_ n.+ - ## u2 start_pc; - ////unsigned.bytes/2 - ## u2 end_pc; - ////unsigned.bytes/2 - ## u2 handler_pc; - ////unsigned.bytes/2 - ## u2 catch_type; - ////unsigned.bytes/2 - )) - -(def: #export writer - (Writer Exception) - ($_ format.and - ////address.writer - ////address.writer - ////address.writer - ////index.writer - )) diff --git a/stdlib/source/lux/target/jvm/attribute/constant.lux b/stdlib/source/lux/target/jvm/attribute/constant.lux deleted file mode 100644 index c5605bcc3..000000000 --- a/stdlib/source/lux/target/jvm/attribute/constant.lux +++ /dev/null @@ -1,26 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)]] - [data - [format - [binary (#+ Writer)]]]] - ["." /// #_ - [constant (#+ Value)] - ["#." index (#+ Index)] - [encoding - ["#." unsigned (#+ U2 U4)]]]) - -(type: #export (Constant a) - (Index (Value a))) - -(def: #export equivalence - (All [a] (Equivalence (Constant a))) - ///index.equivalence) - -(def: #export length - ///index.length) - -(def: #export writer - (All [a] (Writer (Constant a))) - ///index.writer) diff --git a/stdlib/source/lux/target/jvm/bytecode.lux b/stdlib/source/lux/target/jvm/bytecode.lux deleted file mode 100644 index 551b51087..000000000 --- a/stdlib/source/lux/target/jvm/bytecode.lux +++ /dev/null @@ -1,1045 +0,0 @@ -(.module: - [lux (#- Type int try) - ["." ffi (#+ import:)] - [abstract - [monoid (#+ Monoid)] - ["." monad (#+ Monad do)]] - [control - ["." writer (#+ Writer)] - ["." state (#+ State')] - ["." function] - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["." product] - ["." maybe] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." dictionary (#+ Dictionary)] - ["." row (#+ Row)]]] - [macro - ["." template]] - [math - [number - ["n" nat] - ["i" int] - ["." i32 (#+ I32)]]]] - ["." / #_ - ["#." address (#+ Address)] - ["#." jump (#+ Jump Big_Jump)] - ["_" instruction (#+ Primitive_Array_Type Instruction Estimator) ("#\." monoid)] - ["#." environment (#+ Environment) - [limit - ["/." registry (#+ Register Registry)] - ["/." stack (#+ Stack)]]] - ["/#" // #_ - ["#." index (#+ Index)] - [encoding - ["#." name] - ["#." unsigned (#+ U1 U2)] - ["#." signed (#+ S1 S2 S4)]] - ["#." constant (#+ UTF8) - ["#/." pool (#+ Pool Resource)]] - [attribute - [code - ["#." exception (#+ Exception)]]] - ["." type (#+ Type) - [category (#+ Class Object Value' Value Return' Return Method)] - ["." reflection] - ["." parser]]]]) - -(type: #export Label Nat) - -(type: #export Resolver (Dictionary Label [Stack (Maybe Address)])) - -(type: #export Tracker - {#program_counter Address - #next Label - #known Resolver}) - -(def: fresh - Tracker - {#program_counter /address.start - #next 0 - #known (dictionary.new n.hash)}) - -(type: #export Relative - (-> Resolver (Try [(Row Exception) Instruction]))) - -(def: no_exceptions - (Row Exception) - row.empty) - -(def: relative_identity - Relative - (function.constant (#try.Success [..no_exceptions _.empty]))) - -(implementation: relative_monoid - (Monoid Relative) - - (def: identity ..relative_identity) - - (def: (compose left right) - (cond (is? ..relative_identity left) - right - - (is? ..relative_identity right) - left - - ## else - (function (_ resolver) - (do try.monad - [[left_exceptions left_instruction] (left resolver) - [right_exceptions right_instruction] (right resolver)] - (wrap [(\ row.monoid compose left_exceptions right_exceptions) - (_\compose left_instruction right_instruction)])))))) - -(type: #export (Bytecode a) - (State' Try [Pool Environment Tracker] (Writer Relative a))) - -(def: #export new_label - (Bytecode Label) - (function (_ [pool environment tracker]) - (#try.Success [[pool - environment - (update@ #next inc tracker)] - [..relative_identity - (get@ #next tracker)]]))) - -(exception: #export (label_has_already_been_set {label Label}) - (exception.report - ["Label" (%.nat label)])) - -(exception: #export (mismatched_environments {instruction Name} - {label Label} - {address Address} - {expected Stack} - {actual Stack}) - (exception.report - ["Instruction" (%.name instruction)] - ["Label" (%.nat label)] - ["Address" (/address.format address)] - ["Expected" (/stack.format expected)] - ["Actual" (/stack.format actual)])) - -(with_expansions [<success> (as_is (wrap [[pool - environment - (update@ #known - (dictionary.put label [actual (#.Some @here)]) - tracker)] - [..relative_identity - []]]))] - (def: #export (set_label label) - (-> Label (Bytecode Any)) - (function (_ [pool environment tracker]) - (let [@here (get@ #program_counter tracker)] - (case (dictionary.get label (get@ #known tracker)) - (#.Some [expected (#.Some address)]) - (exception.throw ..label_has_already_been_set [label]) - - (#.Some [expected #.None]) - (do try.monad - [[actual environment] (/environment.continue expected environment)] - <success>) - - #.None - (do try.monad - [[actual environment] (/environment.continue (|> environment - (get@ #/environment.stack) - (maybe.default /stack.empty)) - environment)] - <success>)))))) - -(def: #export monad - (Monad Bytecode) - (<| (:as (Monad Bytecode)) - (writer.with ..relative_monoid) - (: (Monad (State' Try [Pool Environment Tracker]))) - state.with - (: (Monad Try)) - try.monad)) - -(def: #export fail - (-> Text Bytecode) - (|>> #try.Failure function.constant)) - -(def: #export (throw exception value) - (All [e] (-> (exception.Exception e) e Bytecode)) - (..fail (exception.construct exception value))) - -(def: #export (resolve environment bytecode) - (All [a] (-> Environment (Bytecode a) (Resource [Environment (Row Exception) Instruction a]))) - (function (_ pool) - (do try.monad - [[[pool environment tracker] [relative output]] (bytecode [pool environment ..fresh]) - [exceptions instruction] (relative (get@ #known tracker))] - (wrap [pool [environment exceptions instruction output]])))) - -(def: (step estimator counter) - (-> Estimator Address (Try Address)) - (/address.move (estimator counter) counter)) - -(def: (bytecode consumption production registry [estimator bytecode] input) - (All [a] (-> U2 U2 Registry [Estimator (-> [a] Instruction)] [a] (Bytecode Any))) - (function (_ [pool environment tracker]) - (do {! try.monad} - [environment' (|> environment - (/environment.consumes consumption) - (monad.bind ! (/environment.produces production)) - (monad.bind ! (/environment.has registry))) - program_counter' (step estimator (get@ #program_counter tracker))] - (wrap [[pool - environment' - (set@ #program_counter program_counter' tracker)] - [(function.constant (wrap [..no_exceptions (bytecode input)])) - []]])))) - -(template [<name> <frames>] - [(def: <name> U2 (|> <frames> //unsigned.u2 try.assume))] - - [$0 0] - [$1 1] - [$2 2] - [$3 3] - [$4 4] - [$5 5] - [$6 6] - ) - -(template [<name> <registry>] - [(def: <name> Registry (|> <registry> //unsigned.u2 try.assume /registry.registry))] - - [@_ 0] - [@0 1] - [@1 2] - [@2 3] - [@3 4] - [@4 5] - ) - -(template [<name> <consumption> <production> <registry> <instruction>] - [(def: #export <name> - (Bytecode Any) - (..bytecode <consumption> - <production> - <registry> - <instruction> - []))] - - [nop $0 $0 @_ _.nop] - - [aconst_null $0 $1 @_ _.aconst_null] - - [iconst_m1 $0 $1 @_ _.iconst_m1] - [iconst_0 $0 $1 @_ _.iconst_0] - [iconst_1 $0 $1 @_ _.iconst_1] - [iconst_2 $0 $1 @_ _.iconst_2] - [iconst_3 $0 $1 @_ _.iconst_3] - [iconst_4 $0 $1 @_ _.iconst_4] - [iconst_5 $0 $1 @_ _.iconst_5] - - [lconst_0 $0 $2 @_ _.lconst_0] - [lconst_1 $0 $2 @_ _.lconst_1] - - [fconst_0 $0 $1 @_ _.fconst_0] - [fconst_1 $0 $1 @_ _.fconst_1] - [fconst_2 $0 $1 @_ _.fconst_2] - - [dconst_0 $0 $2 @_ _.dconst_0] - [dconst_1 $0 $2 @_ _.dconst_1] - - [pop $1 $0 @_ _.pop] - [pop2 $2 $0 @_ _.pop2] - - [dup $1 $2 @_ _.dup] - [dup_x1 $2 $3 @_ _.dup_x1] - [dup_x2 $3 $4 @_ _.dup_x2] - [dup2 $2 $4 @_ _.dup2] - [dup2_x1 $3 $5 @_ _.dup2_x1] - [dup2_x2 $4 $6 @_ _.dup2_x2] - - [swap $2 $2 @_ _.swap] - - [iaload $2 $1 @_ _.iaload] - [laload $2 $2 @_ _.laload] - [faload $2 $1 @_ _.faload] - [daload $2 $2 @_ _.daload] - [aaload $2 $1 @_ _.aaload] - [baload $2 $1 @_ _.baload] - [caload $2 $1 @_ _.caload] - [saload $2 $1 @_ _.saload] - - [iload_0 $0 $1 @0 _.iload_0] - [iload_1 $0 $1 @1 _.iload_1] - [iload_2 $0 $1 @2 _.iload_2] - [iload_3 $0 $1 @3 _.iload_3] - - [lload_0 $0 $2 @1 _.lload_0] - [lload_1 $0 $2 @2 _.lload_1] - [lload_2 $0 $2 @3 _.lload_2] - [lload_3 $0 $2 @4 _.lload_3] - - [fload_0 $0 $1 @0 _.fload_0] - [fload_1 $0 $1 @1 _.fload_1] - [fload_2 $0 $1 @2 _.fload_2] - [fload_3 $0 $1 @3 _.fload_3] - - [dload_0 $0 $2 @1 _.dload_0] - [dload_1 $0 $2 @2 _.dload_1] - [dload_2 $0 $2 @3 _.dload_2] - [dload_3 $0 $2 @4 _.dload_3] - - [aload_0 $0 $1 @0 _.aload_0] - [aload_1 $0 $1 @1 _.aload_1] - [aload_2 $0 $1 @2 _.aload_2] - [aload_3 $0 $1 @3 _.aload_3] - - [iastore $3 $1 @_ _.iastore] - [lastore $4 $1 @_ _.lastore] - [fastore $3 $1 @_ _.fastore] - [dastore $4 $1 @_ _.dastore] - [aastore $3 $1 @_ _.aastore] - [bastore $3 $1 @_ _.bastore] - [castore $3 $1 @_ _.castore] - [sastore $3 $1 @_ _.sastore] - - [istore_0 $1 $0 @0 _.istore_0] - [istore_1 $1 $0 @1 _.istore_1] - [istore_2 $1 $0 @2 _.istore_2] - [istore_3 $1 $0 @3 _.istore_3] - - [lstore_0 $2 $0 @1 _.lstore_0] - [lstore_1 $2 $0 @2 _.lstore_1] - [lstore_2 $2 $0 @3 _.lstore_2] - [lstore_3 $2 $0 @4 _.lstore_3] - - [fstore_0 $1 $0 @0 _.fstore_0] - [fstore_1 $1 $0 @1 _.fstore_1] - [fstore_2 $1 $0 @2 _.fstore_2] - [fstore_3 $1 $0 @3 _.fstore_3] - - [dstore_0 $2 $0 @1 _.dstore_0] - [dstore_1 $2 $0 @2 _.dstore_1] - [dstore_2 $2 $0 @3 _.dstore_2] - [dstore_3 $2 $0 @4 _.dstore_3] - - [astore_0 $1 $0 @0 _.astore_0] - [astore_1 $1 $0 @1 _.astore_1] - [astore_2 $1 $0 @2 _.astore_2] - [astore_3 $1 $0 @3 _.astore_3] - - [iadd $2 $1 @_ _.iadd] - [isub $2 $1 @_ _.isub] - [imul $2 $1 @_ _.imul] - [idiv $2 $1 @_ _.idiv] - [irem $2 $1 @_ _.irem] - [ineg $1 $1 @_ _.ineg] - [iand $2 $1 @_ _.iand] - [ior $2 $1 @_ _.ior] - [ixor $2 $1 @_ _.ixor] - [ishl $2 $1 @_ _.ishl] - [ishr $2 $1 @_ _.ishr] - [iushr $2 $1 @_ _.iushr] - - [ladd $4 $2 @_ _.ladd] - [lsub $4 $2 @_ _.lsub] - [lmul $4 $2 @_ _.lmul] - [ldiv $4 $2 @_ _.ldiv] - [lrem $4 $2 @_ _.lrem] - [lneg $2 $2 @_ _.lneg] - [land $4 $2 @_ _.land] - [lor $4 $2 @_ _.lor] - [lxor $4 $2 @_ _.lxor] - [lshl $3 $2 @_ _.lshl] - [lshr $3 $2 @_ _.lshr] - [lushr $3 $2 @_ _.lushr] - - [fadd $2 $1 @_ _.fadd] - [fsub $2 $1 @_ _.fsub] - [fmul $2 $1 @_ _.fmul] - [fdiv $2 $1 @_ _.fdiv] - [frem $2 $1 @_ _.frem] - [fneg $1 $1 @_ _.fneg] - - [dadd $4 $2 @_ _.dadd] - [dsub $4 $2 @_ _.dsub] - [dmul $4 $2 @_ _.dmul] - [ddiv $4 $2 @_ _.ddiv] - [drem $4 $2 @_ _.drem] - [dneg $2 $2 @_ _.dneg] - - [l2i $2 $1 @_ _.l2i] - [l2f $2 $1 @_ _.l2f] - [l2d $2 $2 @_ _.l2d] - - [f2i $1 $1 @_ _.f2i] - [f2l $1 $2 @_ _.f2l] - [f2d $1 $2 @_ _.f2d] - - [d2i $2 $1 @_ _.d2i] - [d2l $2 $2 @_ _.d2l] - [d2f $2 $1 @_ _.d2f] - - [i2l $1 $2 @_ _.i2l] - [i2f $1 $1 @_ _.i2f] - [i2d $1 $2 @_ _.i2d] - [i2b $1 $1 @_ _.i2b] - [i2c $1 $1 @_ _.i2c] - [i2s $1 $1 @_ _.i2s] - - [lcmp $4 $1 @_ _.lcmp] - - [fcmpl $2 $1 @_ _.fcmpl] - [fcmpg $2 $1 @_ _.fcmpg] - - [dcmpl $4 $1 @_ _.dcmpl] - [dcmpg $4 $1 @_ _.dcmpg] - - [arraylength $1 $1 @_ _.arraylength] - - [monitorenter $1 $0 @_ _.monitorenter] - [monitorexit $1 $0 @_ _.monitorexit] - ) - -(def: discontinuity! - (Bytecode Any) - (function (_ [pool environment tracker]) - (do try.monad - [_ (/environment.stack environment)] - (wrap [[pool - (/environment.discontinue environment) - tracker] - [..relative_identity - []]])))) - -(template [<name> <consumption> <instruction>] - [(def: #export <name> - (Bytecode Any) - (do ..monad - [_ (..bytecode <consumption> $0 @_ <instruction> [])] - ..discontinuity!))] - - [ireturn $1 _.ireturn] - [lreturn $2 _.lreturn] - [freturn $1 _.freturn] - [dreturn $2 _.dreturn] - [areturn $1 _.areturn] - [return $0 _.return] - - [athrow $1 _.athrow] - ) - -(def: #export (bipush byte) - (-> S1 (Bytecode Any)) - (..bytecode $0 $1 @_ _.bipush [byte])) - -(def: (lift resource) - (All [a] - (-> (Resource a) - (Bytecode a))) - (function (_ [pool environment tracker]) - (do try.monad - [[pool' output] (resource pool)] - (wrap [[pool' environment tracker] - [..relative_identity - output]])))) - -(def: #export (string value) - (-> //constant.UTF8 (Bytecode Any)) - (do ..monad - [index (..lift (//constant/pool.string value))] - (case (|> index //index.value //unsigned.value //unsigned.u1) - (#try.Success index) - (..bytecode $0 $1 @_ _.ldc [index]) - - (#try.Failure _) - (..bytecode $0 $1 @_ _.ldc_w/string [index])))) - -(import: java/lang/Float - ["#::." - (#static floatToRawIntBits #manual [float] int)]) - -(import: java/lang/Double - ["#::." - (#static doubleToRawLongBits #manual [double] long)]) - -(template [<name> <type> <constructor> <constant> <wide> <to_lux> <specializations>] - [(def: #export (<name> value) - (-> <type> (Bytecode Any)) - (case (|> value <to_lux>) - (^template [<special> <instruction>] - [<special> (..bytecode $0 $1 @_ <instruction> [])]) - <specializations> - - _ (do ..monad - [index (..lift (<constant> (<constructor> value)))] - (case (|> index //index.value //unsigned.value //unsigned.u1) - (#try.Success index) - (..bytecode $0 $1 @_ _.ldc [index]) - - (#try.Failure _) - (..bytecode $0 $1 @_ <wide> [index])))))] - - [int I32 //constant.integer //constant/pool.integer _.ldc_w/integer - (<| .int i32.i64) - ([-1 _.iconst_m1] - [+0 _.iconst_0] - [+1 _.iconst_1] - [+2 _.iconst_2] - [+3 _.iconst_3] - [+4 _.iconst_4] - [+5 _.iconst_5])] - ) - -(def: (arbitrary_float value) - (-> java/lang/Float (Bytecode Any)) - (do ..monad - [index (..lift (//constant/pool.float (//constant.float value)))] - (case (|> index //index.value //unsigned.value //unsigned.u1) - (#try.Success index) - (..bytecode $0 $1 @_ _.ldc [index]) - - (#try.Failure _) - (..bytecode $0 $1 @_ _.ldc_w/float [index])))) - -(def: float_bits - (-> java/lang/Float Int) - (|>> java/lang/Float::floatToRawIntBits - ffi.int_to_long - (:as Int))) - -(def: negative_zero_float_bits - (|> -0.0 (:as java/lang/Double) ffi.double_to_float ..float_bits)) - -(def: #export (float value) - (-> java/lang/Float (Bytecode Any)) - (if (i.= ..negative_zero_float_bits - (..float_bits value)) - (..arbitrary_float value) - (case (|> value ffi.float_to_double (:as Frac)) - (^template [<special> <instruction>] - [<special> (..bytecode $0 $1 @_ <instruction> [])]) - ([+0.0 _.fconst_0] - [+1.0 _.fconst_1] - [+2.0 _.fconst_2]) - - _ (..arbitrary_float value)))) - -(template [<name> <type> <constructor> <constant> <wide> <to_lux> <specializations>] - [(def: #export (<name> value) - (-> <type> (Bytecode Any)) - (case (|> value <to_lux>) - (^template [<special> <instruction>] - [<special> (..bytecode $0 $2 @_ <instruction> [])]) - <specializations> - - _ (do ..monad - [index (..lift (<constant> (<constructor> value)))] - (..bytecode $0 $2 @_ <wide> [index]))))] - - [long Int //constant.long //constant/pool.long _.ldc2_w/long - (<|) - ([+0 _.lconst_0] - [+1 _.lconst_1])] - ) - -(def: (arbitrary_double value) - (-> java/lang/Double (Bytecode Any)) - (do ..monad - [index (..lift (//constant/pool.double (//constant.double (:as Frac value))))] - (..bytecode $0 $2 @_ _.ldc2_w/double [index]))) - -(def: double_bits - (-> java/lang/Double Int) - (|>> java/lang/Double::doubleToRawLongBits - (:as Int))) - -(def: negative_zero_double_bits - (..double_bits (:as java/lang/Double -0.0))) - -(def: #export (double value) - (-> java/lang/Double (Bytecode Any)) - (if (i.= ..negative_zero_double_bits - (..double_bits value)) - (..arbitrary_double value) - (case (:as Frac value) - (^template [<special> <instruction>] - [<special> (..bytecode $0 $2 @_ <instruction> [])]) - ([+0.0 _.dconst_0] - [+1.0 _.dconst_1]) - - _ (..arbitrary_double value)))) - -(exception: #export (invalid_register {id Nat}) - (exception.report - ["ID" (%.nat id)])) - -(def: (register id) - (-> Nat (Bytecode Register)) - (case (//unsigned.u1 id) - (#try.Success register) - (\ ..monad wrap register) - - (#try.Failure error) - (..throw ..invalid_register [id]))) - -(template [<for> <size> <name> <general> <specials>] - [(def: #export (<name> local) - (-> Nat (Bytecode Any)) - (with_expansions [<specials>' (template.splice <specials>)] - (`` (case local - (~~ (template [<case> <instruction> <registry>] - [<case> (..bytecode $0 <size> <registry> <instruction> [])] - - <specials>')) - _ (do ..monad - [local (..register local)] - (..bytecode $0 <size> (<for> local) <general> [local]))))))] - - [/registry.for $1 iload _.iload - [[0 _.iload_0 @0] - [1 _.iload_1 @1] - [2 _.iload_2 @2] - [3 _.iload_3 @3]]] - [/registry.for_wide $2 lload _.lload - [[0 _.lload_0 @1] - [1 _.lload_1 @2] - [2 _.lload_2 @3] - [3 _.lload_3 @4]]] - [/registry.for $1 fload _.fload - [[0 _.fload_0 @0] - [1 _.fload_1 @1] - [2 _.fload_2 @2] - [3 _.fload_3 @3]]] - [/registry.for_wide $2 dload _.dload - [[0 _.dload_0 @1] - [1 _.dload_1 @2] - [2 _.dload_2 @3] - [3 _.dload_3 @4]]] - [/registry.for $1 aload _.aload - [[0 _.aload_0 @0] - [1 _.aload_1 @1] - [2 _.aload_2 @2] - [3 _.aload_3 @3]]] - ) - -(template [<for> <size> <name> <general> <specials>] - [(def: #export (<name> local) - (-> Nat (Bytecode Any)) - (with_expansions [<specials>' (template.splice <specials>)] - (`` (case local - (~~ (template [<case> <instruction> <registry>] - [<case> (..bytecode <size> $0 <registry> <instruction> [])] - - <specials>')) - _ (do ..monad - [local (..register local)] - (..bytecode <size> $0 (<for> local) <general> [local]))))))] - - [/registry.for $1 istore _.istore - [[0 _.istore_0 @0] - [1 _.istore_1 @1] - [2 _.istore_2 @2] - [3 _.istore_3 @3]]] - [/registry.for_wide $2 lstore _.lstore - [[0 _.lstore_0 @1] - [1 _.lstore_1 @2] - [2 _.lstore_2 @3] - [3 _.lstore_3 @4]]] - [/registry.for $1 fstore _.fstore - [[0 _.fstore_0 @0] - [1 _.fstore_1 @1] - [2 _.fstore_2 @2] - [3 _.fstore_3 @3]]] - [/registry.for_wide $2 dstore _.dstore - [[0 _.dstore_0 @1] - [1 _.dstore_1 @2] - [2 _.dstore_2 @3] - [3 _.dstore_3 @4]]] - [/registry.for $1 astore _.astore - [[0 _.astore_0 @0] - [1 _.astore_1 @1] - [2 _.astore_2 @2] - [3 _.astore_3 @3]]] - ) - -(template [<consumption> <production> <name> <instruction> <input>] - [(def: #export <name> - (-> <input> (Bytecode Any)) - (..bytecode <consumption> <production> @_ <instruction>))] - - [$1 $1 newarray _.newarray Primitive_Array_Type] - [$0 $1 sipush _.sipush S2] - ) - -(exception: #export (unknown_label {label Label}) - (exception.report - ["Label" (%.nat label)])) - -(exception: #export (cannot_do_a_big_jump {label Label} - {@from Address} - {jump Big_Jump}) - (exception.report - ["Label" (%.nat label)] - ["Start" (|> @from /address.value //unsigned.value %.nat)] - ["Target" (|> jump //signed.value %.int)])) - -(type: Any_Jump (Either Big_Jump Jump)) - -(def: (jump @from @to) - (-> Address Address (Try Any_Jump)) - (do {! try.monad} - [jump (\ ! map //signed.value - (/address.jump @from @to))] - (let [big? (n.> (//unsigned.value //unsigned.maximum/2) - (.nat (i.* (if (i.>= +0 jump) - +1 - -1) - jump)))] - (if big? - (\ ! map (|>> #.Left) (//signed.s4 jump)) - (\ ! map (|>> #.Right) (//signed.s2 jump)))))) - -(exception: #export (unset_label {label Label}) - (exception.report - ["Label" (%.nat label)])) - -(def: (resolve_label label resolver) - (-> Label Resolver (Try [Stack Address])) - (case (dictionary.get label resolver) - (#.Some [actual (#.Some address)]) - (#try.Success [actual address]) - - (#.Some [actual #.None]) - (exception.throw ..unset_label [label]) - - #.None - (exception.throw ..unknown_label [label]))) - -(def: (acknowledge_label stack label tracker) - (-> Stack Label Tracker Tracker) - (case (dictionary.get label (get@ #known tracker)) - (#.Some _) - tracker - - #.None - (update@ #known (dictionary.put label [stack #.None]) tracker))) - -(template [<consumption> <name> <instruction>] - [(def: #export (<name> label) - (-> Label (Bytecode Any)) - (let [[estimator bytecode] <instruction>] - (function (_ [pool environment tracker]) - (let [@here (get@ #program_counter tracker)] - (do try.monad - [environment' (|> environment - (/environment.consumes <consumption>)) - actual (/environment.stack environment') - program_counter' (step estimator @here)] - (wrap (let [@from @here] - [[pool - environment' - (|> tracker - (..acknowledge_label actual label) - (set@ #program_counter program_counter'))] - [(function (_ resolver) - (do try.monad - [[expected @to] (..resolve_label label resolver) - _ (exception.assert ..mismatched_environments [(name_of <instruction>) label @here expected actual] - (\ /stack.equivalence = expected actual)) - jump (..jump @from @to)] - (case jump - (#.Left jump) - (exception.throw ..cannot_do_a_big_jump [label @from jump]) - - (#.Right jump) - (wrap [..no_exceptions (bytecode jump)])))) - []]])))))))] - - [$1 ifeq _.ifeq] - [$1 ifne _.ifne] - [$1 iflt _.iflt] - [$1 ifge _.ifge] - [$1 ifgt _.ifgt] - [$1 ifle _.ifle] - - [$1 ifnull _.ifnull] - [$1 ifnonnull _.ifnonnull] - - [$2 if_icmpeq _.if_icmpeq] - [$2 if_icmpne _.if_icmpne] - [$2 if_icmplt _.if_icmplt] - [$2 if_icmpge _.if_icmpge] - [$2 if_icmpgt _.if_icmpgt] - [$2 if_icmple _.if_icmple] - - [$2 if_acmpeq _.if_acmpeq] - [$2 if_acmpne _.if_acmpne] - ) - -(template [<name> <instruction> <on_long_jump> <on_short_jump>] - [(def: #export (<name> label) - (-> Label (Bytecode Any)) - (let [[estimator bytecode] <instruction>] - (function (_ [pool environment tracker]) - (do try.monad - [actual (/environment.stack environment) - #let [@here (get@ #program_counter tracker)] - program_counter' (step estimator @here)] - (wrap (let [@from @here] - [[pool - (/environment.discontinue environment) - (|> tracker - (..acknowledge_label actual label) - (set@ #program_counter program_counter'))] - [(function (_ resolver) - (case (dictionary.get label resolver) - (#.Some [expected (#.Some @to)]) - (do try.monad - [_ (exception.assert ..mismatched_environments [(name_of <instruction>) label @here expected actual] - (\ /stack.equivalence = expected actual)) - jump (..jump @from @to)] - (case jump - (#.Left jump) - <on_long_jump> - - (#.Right jump) - <on_short_jump>)) - - (#.Some [expected #.None]) - (exception.throw ..unset_label [label]) - - #.None - (exception.throw ..unknown_label [label]))) - []]]))))))] - - [goto _.goto - (exception.throw ..cannot_do_a_big_jump [label @from jump]) - (wrap [..no_exceptions (bytecode jump)])] - [goto_w _.goto_w - (wrap [..no_exceptions (bytecode jump)]) - (wrap [..no_exceptions (bytecode (/jump.lift jump))])] - ) - -(def: (big_jump jump) - (-> Any_Jump Big_Jump) - (case jump - (#.Left big) - big - - (#.Right small) - (/jump.lift small))) - -(exception: #export invalid_tableswitch) - -(def: #export (tableswitch minimum default [at_minimum afterwards]) - (-> S4 Label [Label (List Label)] (Bytecode Any)) - (let [[estimator bytecode] _.tableswitch] - (function (_ [pool environment tracker]) - (do try.monad - [environment' (|> environment - (/environment.consumes $1)) - actual (/environment.stack environment') - program_counter' (step (estimator (list.size afterwards)) (get@ #program_counter tracker))] - (wrap (let [@from (get@ #program_counter tracker)] - [[pool - environment' - (|> (list\fold (..acknowledge_label actual) tracker (list& default at_minimum afterwards)) - (set@ #program_counter program_counter'))] - [(function (_ resolver) - (let [get (: (-> Label (Maybe [Stack (Maybe Address)])) - (function (_ label) - (dictionary.get label resolver)))] - (case (do {! maybe.monad} - [@default (|> default get (monad.bind ! product.right)) - @at_minimum (|> at_minimum get (monad.bind ! product.right)) - @afterwards (|> afterwards - (monad.map ! get) - (monad.bind ! (monad.map ! product.right)))] - (wrap [@default @at_minimum @afterwards])) - (#.Some [@default @at_minimum @afterwards]) - (do {! try.monad} - [>default (\ ! map ..big_jump (..jump @from @default)) - >at_minimum (\ ! map ..big_jump (..jump @from @at_minimum)) - >afterwards (monad.map ! (|>> (..jump @from) (\ ! map ..big_jump)) - @afterwards)] - (wrap [..no_exceptions (bytecode minimum >default [>at_minimum >afterwards])])) - - #.None - (exception.throw ..invalid_tableswitch [])))) - []]])))))) - -(exception: #export invalid_lookupswitch) - -(def: #export (lookupswitch default cases) - (-> Label (List [S4 Label]) (Bytecode Any)) - (let [cases (list.sort (function (_ [left _] [right _]) - (i.< (//signed.value left) - (//signed.value right))) - cases) - [estimator bytecode] _.lookupswitch] - (function (_ [pool environment tracker]) - (do try.monad - [environment' (|> environment - (/environment.consumes $1)) - actual (/environment.stack environment') - program_counter' (step (estimator (list.size cases)) (get@ #program_counter tracker))] - (wrap (let [@from (get@ #program_counter tracker)] - [[pool - environment' - (|> (list\fold (..acknowledge_label actual) tracker (list& default (list\map product.right cases))) - (set@ #program_counter program_counter'))] - [(function (_ resolver) - (let [get (: (-> Label (Maybe [Stack (Maybe Address)])) - (function (_ label) - (dictionary.get label resolver)))] - (case (do {! maybe.monad} - [@default (|> default get (monad.bind ! product.right)) - @cases (|> cases - (monad.map ! (|>> product.right get)) - (monad.bind ! (monad.map ! product.right)))] - (wrap [@default @cases])) - (#.Some [@default @cases]) - (do {! try.monad} - [>default (\ ! map ..big_jump (..jump @from @default)) - >cases (|> @cases - (monad.map ! (|>> (..jump @from) (\ ! map ..big_jump))) - (\ ! map (|>> (list.zip/2 (list\map product.left cases)))))] - (wrap [..no_exceptions (bytecode >default >cases)])) - - #.None - (exception.throw ..invalid_lookupswitch [])))) - []]])))))) - -(def: reflection - (All [category] - (-> (Type (<| Return' Value' category)) Text)) - (|>> type.reflection reflection.reflection)) - -(template [<consumption> <production> <name> <category> <instruction>] - [(def: #export (<name> class) - (-> (Type <category>) (Bytecode Any)) - (do ..monad - [## TODO: Make sure it's impossible to have indexes greater than U2. - index (..lift (//constant/pool.class (//name.internal (..reflection class))))] - (..bytecode <consumption> <production> @_ <instruction> [index])))] - - [$0 $1 new Class _.new] - [$1 $1 anewarray Object _.anewarray] - [$1 $1 checkcast Object _.checkcast] - [$1 $1 instanceof Object _.instanceof] - ) - -(def: #export (iinc register increase) - (-> Nat U1 (Bytecode Any)) - (do ..monad - [register (..register register)] - (..bytecode $0 $0 (/registry.for register) _.iinc [register increase]))) - -(exception: #export (multiarray_cannot_be_zero_dimensional {class (Type Object)}) - (exception.report ["Class" (..reflection class)])) - -(def: #export (multianewarray class dimensions) - (-> (Type Object) U1 (Bytecode Any)) - (do ..monad - [_ (: (Bytecode Any) - (case (|> dimensions //unsigned.value) - 0 (..throw ..multiarray_cannot_be_zero_dimensional [class]) - _ (wrap []))) - index (..lift (//constant/pool.class (//name.internal (..reflection class))))] - (..bytecode (//unsigned.lift/2 dimensions) $1 @_ _.multianewarray [index dimensions]))) - -(def: (type_size type) - (-> (Type Return) Nat) - (cond (is? type.void type) - 0 - - (or (is? type.long type) - (is? type.double type)) - 2 - - ## else - 1)) - -(template [<static?> <name> <instruction> <method>] - [(def: #export (<name> class method type) - (-> (Type Class) Text (Type Method) (Bytecode Any)) - (let [[inputs output exceptions] (parser.method type)] - (do ..monad - [index (<| ..lift - (<method> (..reflection class)) - {#//constant/pool.name method - #//constant/pool.descriptor (type.descriptor type)}) - #let [consumption (|> inputs - (list\map ..type_size) - (list\fold n.+ (if <static?> 0 1)) - //unsigned.u1 - try.assume) - production (|> output ..type_size //unsigned.u1 try.assume)]] - (..bytecode (//unsigned.lift/2 consumption) - (//unsigned.lift/2 production) - @_ - <instruction> [index consumption production]))))] - - [#1 invokestatic _.invokestatic //constant/pool.method] - [#0 invokevirtual _.invokevirtual //constant/pool.method] - [#0 invokespecial _.invokespecial //constant/pool.method] - [#0 invokeinterface _.invokeinterface //constant/pool.interface_method] - ) - -(template [<consumption> <name> <1> <2>] - [(def: #export (<name> class field type) - (-> (Type Class) Text (Type Value) (Bytecode Any)) - (do ..monad - [index (<| ..lift - (//constant/pool.field (..reflection class)) - {#//constant/pool.name field - #//constant/pool.descriptor (type.descriptor type)})] - (if (or (is? type.long type) - (is? type.double type)) - (..bytecode <consumption> $2 @_ <2> [index]) - (..bytecode <consumption> $1 @_ <1> [index]))))] - - [$0 getstatic _.getstatic/1 _.getstatic/2] - [$1 putstatic _.putstatic/1 _.putstatic/2] - [$1 getfield _.getfield/1 _.getfield/2] - [$2 putfield _.putfield/1 _.putfield/2] - ) - -(exception: #export (invalid_range_for_try {start Address} {end Address}) - (exception.report - ["Start" (|> start /address.value //unsigned.value %.nat)] - ["End" (|> end /address.value //unsigned.value %.nat)])) - -(def: #export (try @start @end @handler catch) - (-> Label Label Label (Type Class) (Bytecode Any)) - (do ..monad - [@catch (..lift (//constant/pool.class (//name.internal (..reflection catch))))] - (function (_ [pool environment tracker]) - (#try.Success - [[pool - environment - (..acknowledge_label /stack.catch @handler tracker)] - [(function (_ resolver) - (do try.monad - [[_ @start] (..resolve_label @start resolver) - [_ @end] (..resolve_label @end resolver) - _ (if (/address.after? @start @end) - (wrap []) - (exception.throw ..invalid_range_for_try [@start @end])) - [_ @handler] (..resolve_label @handler resolver)] - (wrap [(row.row {#//exception.start @start - #//exception.end @end - #//exception.handler @handler - #//exception.catch @catch}) - _.empty]))) - []]])))) - -(def: #export (compose pre post) - (All [pre post] - (-> (Bytecode pre) (Bytecode post) (Bytecode post))) - (do ..monad - [_ pre] - post)) diff --git a/stdlib/source/lux/target/jvm/bytecode/address.lux b/stdlib/source/lux/target/jvm/bytecode/address.lux deleted file mode 100644 index b158bbd05..000000000 --- a/stdlib/source/lux/target/jvm/bytecode/address.lux +++ /dev/null @@ -1,73 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [monad (#+ do)]] - [control - ["." try (#+ Try)]] - [data - [format - [binary (#+ Writer)]] - [text - ["%" format (#+ Format)]]] - [math - [number - ["n" nat]]] - [type - abstract]] - ["." // #_ - [jump (#+ Big_Jump)] - ["/#" // #_ - [encoding - ["#." unsigned (#+ U2)] - ["#." signed (#+ S4)]]]]) - -(abstract: #export Address - U2 - - (def: #export value - (-> Address U2) - (|>> :representation)) - - (def: #export start - Address - (|> 0 ///unsigned.u2 try.assume :abstraction)) - - (def: #export (move distance) - (-> U2 (-> Address (Try Address))) - (|>> :representation - (///unsigned.+/2 distance) - (\ try.functor map (|>> :abstraction)))) - - (def: with_sign - (-> Address (Try S4)) - (|>> :representation ///unsigned.value .int ///signed.s4)) - - (def: #export (jump from to) - (-> Address Address (Try Big_Jump)) - (do try.monad - [from (with_sign from) - to (with_sign to)] - (///signed.-/4 from to))) - - (def: #export (after? reference subject) - (-> Address Address Bit) - (n.> (|> reference :representation ///unsigned.value) - (|> subject :representation ///unsigned.value))) - - (implementation: #export equivalence - (Equivalence Address) - - (def: (= reference subject) - (\ ///unsigned.equivalence = - (:representation reference) - (:representation subject)))) - - (def: #export writer - (Writer Address) - (|>> :representation ///unsigned.writer/2)) - - (def: #export format - (Format Address) - (|>> :representation ///unsigned.value %.nat)) - ) diff --git a/stdlib/source/lux/target/jvm/bytecode/environment.lux b/stdlib/source/lux/target/jvm/bytecode/environment.lux deleted file mode 100644 index 23bcb4558..000000000 --- a/stdlib/source/lux/target/jvm/bytecode/environment.lux +++ /dev/null @@ -1,107 +0,0 @@ -(.module: - [lux (#- Type static) - [abstract - [monad (#+ do)] - [monoid (#+ Monoid)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]]] - [/ - ["/." limit (#+ Limit) - ["/." stack (#+ Stack)] - ["/." registry (#+ Registry)]] - [/// - [encoding - [unsigned (#+ U2)]] - [type (#+ Type) - [category (#+ Method)]]]]) - -(type: #export Environment - {#limit Limit - #stack (Maybe Stack)}) - -(template [<name> <limit>] - [(def: #export (<name> type) - (-> (Type Method) (Try Environment)) - (do try.monad - [limit (<limit> type)] - (wrap {#limit limit - #stack (#.Some /stack.empty)})))] - - [static /limit.static] - [virtual /limit.virtual] - ) - -(type: #export Condition - (-> Environment (Try Environment))) - -(implementation: #export monoid - (Monoid Condition) - - (def: identity (|>> #try.Success)) - - (def: (compose left right) - (function (_ environment) - (do try.monad - [environment (left environment)] - (right environment))))) - -(exception: #export discontinuity) - -(def: #export (stack environment) - (-> Environment (Try Stack)) - (case (get@ #..stack environment) - (#.Some stack) - (#try.Success stack) - - #.None - (exception.throw ..discontinuity []))) - -(def: #export discontinue - (-> Environment Environment) - (set@ #..stack #.None)) - -(exception: #export (mismatched_stacks {expected Stack} - {actual Stack}) - (exception.report - ["Expected" (/stack.format expected)] - ["Actual" (/stack.format actual)])) - -(def: #export (continue expected environment) - (-> Stack Environment (Try [Stack Environment])) - (case (get@ #..stack environment) - (#.Some actual) - (if (\ /stack.equivalence = expected actual) - (#try.Success [actual environment]) - (exception.throw ..mismatched_stacks [expected actual])) - - #.None - (#try.Success [expected (set@ #..stack (#.Some expected) environment)]))) - -(def: #export (consumes amount) - (-> U2 Condition) - ## TODO: Revisit this definition once lenses/optics have been implemented, - ## since it can probably be simplified with them. - (function (_ environment) - (do try.monad - [previous (..stack environment) - current (/stack.pop amount previous)] - (wrap (set@ #..stack (#.Some current) environment))))) - -(def: #export (produces amount) - (-> U2 Condition) - (function (_ environment) - (do try.monad - [previous (..stack environment) - current (/stack.push amount previous) - #let [limit (|> environment - (get@ [#..limit #/limit.stack]) - (/stack.max current))]] - (wrap (|> environment - (set@ #..stack (#.Some current)) - (set@ [#..limit #/limit.stack] limit)))))) - -(def: #export (has registry) - (-> Registry Condition) - (|>> (update@ [#..limit #/limit.registry] (/registry.has registry)) - #try.Success)) diff --git a/stdlib/source/lux/target/jvm/bytecode/environment/limit.lux b/stdlib/source/lux/target/jvm/bytecode/environment/limit.lux deleted file mode 100644 index 7c277d4c6..000000000 --- a/stdlib/source/lux/target/jvm/bytecode/environment/limit.lux +++ /dev/null @@ -1,57 +0,0 @@ -(.module: - [lux (#- Type static) - [abstract - [monad (#+ do)] - [equivalence (#+ Equivalence)]] - [control - ["." try (#+ Try)]] - [data - ["." product] - ["." format #_ - ["#" binary (#+ Writer) ("#\." monoid)]]] - [math - [number - ["n" nat]]]] - ["." / #_ - ["#." stack (#+ Stack)] - ["#." registry (#+ Registry)] - [//// - [type (#+ Type) - [category (#+ Method)]]]]) - -(type: #export Limit - {#stack Stack - #registry Registry}) - -(template [<name> <registry>] - [(def: #export (<name> type) - (-> (Type Method) (Try Limit)) - (do try.monad - [registry (<registry> type)] - (wrap {#stack /stack.empty - #registry registry})))] - - [static /registry.static] - [virtual /registry.virtual] - ) - -(def: #export length - ($_ n.+ - ## u2 max_stack; - /stack.length - ## u2 max_locals; - /registry.length)) - -(def: #export equivalence - (Equivalence Limit) - ($_ product.equivalence - /stack.equivalence - /registry.equivalence - )) - -(def: #export (writer limit) - (Writer Limit) - ($_ format\compose - (/stack.writer (get@ #stack limit)) - (/registry.writer (get@ #registry limit)) - )) diff --git a/stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux b/stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux deleted file mode 100644 index 9165dfacb..000000000 --- a/stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux +++ /dev/null @@ -1,90 +0,0 @@ -(.module: - [lux (#- Type for static) - [abstract - ["." equivalence (#+ Equivalence)]] - [control - ["." try (#+ Try) ("#\." functor)]] - [data - [format - [binary (#+ Writer)]] - [collection - ["." list ("#\." functor fold)]]] - [math - [number - ["n" nat]]] - [type - abstract]] - ["." ///// #_ - [encoding - ["#." unsigned (#+ U1 U2)]] - ["#." type (#+ Type) - [category (#+ Method)] - ["#/." parser]]]) - -(type: #export Register U1) - -(def: normal 1) -(def: wide 2) - -(abstract: #export Registry - U2 - - (def: #export registry - (-> U2 Registry) - (|>> :abstraction)) - - (def: (minimal type) - (-> (Type Method) Nat) - (let [[inputs output exceptions] (/////type/parser.method type)] - (|> inputs - (list\map (function (_ input) - (if (or (is? /////type.long input) - (is? /////type.double input)) - ..wide - ..normal))) - (list\fold n.+ 0)))) - - (template [<start> <name>] - [(def: #export <name> - (-> (Type Method) (Try Registry)) - (|>> ..minimal - (n.+ <start>) - /////unsigned.u2 - (try\map ..registry)))] - - [0 static] - [1 virtual] - ) - - (def: #export equivalence - (Equivalence Registry) - (\ equivalence.functor map - (|>> :representation) - /////unsigned.equivalence)) - - (def: #export writer - (Writer Registry) - (|>> :representation /////unsigned.writer/2)) - - (def: #export (has needed) - (-> Registry Registry Registry) - (|>> :representation - (/////unsigned.max/2 (:representation needed)) - :abstraction)) - - (template [<name> <extra>] - [(def: #export <name> - (-> Register Registry) - (let [extra (|> <extra> /////unsigned.u2 try.assume)] - (|>> /////unsigned.lift/2 - (/////unsigned.+/2 extra) - try.assume - :abstraction)))] - - [for ..normal] - [for_wide ..wide] - ) - ) - -(def: #export length - /////unsigned.bytes/2) diff --git a/stdlib/source/lux/target/jvm/bytecode/environment/limit/stack.lux b/stdlib/source/lux/target/jvm/bytecode/environment/limit/stack.lux deleted file mode 100644 index e561d2a04..000000000 --- a/stdlib/source/lux/target/jvm/bytecode/environment/limit/stack.lux +++ /dev/null @@ -1,68 +0,0 @@ -(.module: - [lux #* - [abstract - ["." equivalence (#+ Equivalence)]] - [control - ["." try (#+ Try)]] - [data - ["." maybe] - [text - ["%" format (#+ Format)]] - [format - [binary (#+ Writer)]]] - [type - abstract]] - ["." ///// #_ - [encoding - ["#." unsigned (#+ U2)]]]) - -(abstract: #export Stack - U2 - - (template [<frames> <name>] - [(def: #export <name> - Stack - (|> <frames> /////unsigned.u2 maybe.assume :abstraction))] - - [0 empty] - [1 catch] - ) - - (def: #export equivalence - (Equivalence Stack) - (\ equivalence.functor map - (|>> :representation) - /////unsigned.equivalence)) - - (def: #export writer - (Writer Stack) - (|>> :representation /////unsigned.writer/2)) - - (def: stack - (-> U2 Stack) - (|>> :abstraction)) - - (template [<op> <name>] - [(def: #export (<name> amount) - (-> U2 (-> Stack (Try Stack))) - (|>> :representation - (<op> amount) - (\ try.functor map ..stack)))] - - [/////unsigned.+/2 push] - [/////unsigned.-/2 pop] - ) - - (def: #export (max left right) - (-> Stack Stack Stack) - (:abstraction - (/////unsigned.max/2 (:representation left) - (:representation right)))) - - (def: #export format - (Format Stack) - (|>> :representation /////unsigned.value %.nat)) - ) - -(def: #export length - /////unsigned.bytes/2) diff --git a/stdlib/source/lux/target/jvm/bytecode/instruction.lux b/stdlib/source/lux/target/jvm/bytecode/instruction.lux deleted file mode 100644 index 718f14199..000000000 --- a/stdlib/source/lux/target/jvm/bytecode/instruction.lux +++ /dev/null @@ -1,713 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)] - [monoid (#+ Monoid)]] - [control - ["." function] - ["." try]] - [data - ["." product] - ["." binary] - ["." format #_ - ["#" binary (#+ Mutation Specification)]] - [collection - ["." list]]] - [macro - ["." template]] - [math - [number (#+ hex) - ["n" nat]]] - [type - abstract]] - ["." // #_ - ["#." address (#+ Address)] - ["#." jump (#+ Jump Big_Jump)] - [environment - [limit - [registry (#+ Register)]]] - ["/#" // #_ - ["#." index (#+ Index)] - ["#." constant (#+ Class Reference)] - [encoding - ["#." unsigned (#+ U1 U2 U4)] - ["#." signed (#+ S1 S2 S4)]] - [type - [category (#+ Value Method)]]]]) - -(type: #export Size U2) - -(type: #export Estimator - (-> Address Size)) - -(def: fixed - (-> Size Estimator) - function.constant) - -(type: #export Instruction - (-> Specification Specification)) - -(def: #export empty - Instruction - function.identity) - -(def: #export run - (-> Instruction Specification) - (function.apply format.no_op)) - -(type: Opcode Nat) - -(template [<name> <size>] - [(def: <name> Size (|> <size> ///unsigned.u2 try.assume))] - - [opcode_size 1] - [register_size 1] - [byte_size 1] - [index_size 2] - [big_jump_size 4] - [integer_size 4] - ) - -(def: (nullary' opcode) - (-> Opcode Mutation) - (function (_ [offset binary]) - [(n.+ (///unsigned.value ..opcode_size) - offset) - (try.assume - (binary.write/8 offset opcode binary))])) - -(def: nullary - [Estimator (-> Opcode Instruction)] - [(..fixed ..opcode_size) - (function (_ opcode [size mutation]) - [(n.+ (///unsigned.value ..opcode_size) - size) - (|>> mutation ((nullary' opcode)))])]) - -(template [<name> <size>] - [(def: <name> - Size - (|> ..opcode_size - (///unsigned.+/2 <size>) try.assume))] - - [size/1 ..register_size] - [size/2 ..index_size] - [size/4 ..big_jump_size] - ) - -(template [<shift> <name> <inputT> <writer> <unwrap>] - [(with_expansions [<private> (template.identifier ["'" <name>])] - (def: (<private> opcode input0) - (-> Opcode <inputT> Mutation) - (function (_ [offset binary]) - [(n.+ (///unsigned.value <shift>) offset) - (try.assume - (do try.monad - [_ (binary.write/8 offset opcode binary)] - (<writer> (n.+ (///unsigned.value ..opcode_size) offset) - (<unwrap> input0) - binary)))])) - - (def: <name> - [Estimator (-> Opcode <inputT> Instruction)] - [(..fixed <shift>) - (function (_ opcode input0 [size mutation]) - [(n.+ (///unsigned.value <shift>) size) - (|>> mutation ((<private> opcode input0)))])]))] - - [..size/1 unary/1 U1 binary.write/8 ///unsigned.value] - [..size/2 unary/2 U2 binary.write/16 ///unsigned.value] - [..size/2 jump/2 Jump binary.write/16 ///signed.value] - [..size/4 jump/4 Big_Jump binary.write/32 ///signed.value] - ) - -(template [<shift> <name> <inputT> <writer>] - [(with_expansions [<private> (template.identifier ["'" <name>])] - (def: (<private> opcode input0) - (-> Opcode <inputT> Mutation) - (function (_ [offset binary]) - [(n.+ (///unsigned.value <shift>) offset) - (try.assume - (do try.monad - [_ (binary.write/8 offset opcode binary)] - (<writer> (n.+ (///unsigned.value ..opcode_size) offset) - (///signed.value input0) - binary)))])) - - (def: <name> - [Estimator (-> Opcode <inputT> Instruction)] - [(..fixed <shift>) - (function (_ opcode input0 [size mutation]) - [(n.+ (///unsigned.value <shift>) size) - (|>> mutation ((<private> opcode input0)))])]))] - - [..size/1 unary/1' S1 binary.write/8] - [..size/2 unary/2' S2 binary.write/16] - ) - -(def: size/11 - Size - (|> ..opcode_size - (///unsigned.+/2 ..register_size) try.assume - (///unsigned.+/2 ..byte_size) try.assume)) - -(def: (binary/11' opcode input0 input1) - (-> Opcode U1 U1 Mutation) - (function (_ [offset binary]) - [(n.+ (///unsigned.value ..size/11) offset) - (try.assume - (do try.monad - [_ (binary.write/8 offset opcode binary) - _ (binary.write/8 (n.+ (///unsigned.value ..opcode_size) offset) - (///unsigned.value input0) - binary)] - (binary.write/8 (n.+ (///unsigned.value ..size/1) offset) - (///unsigned.value input1) - binary)))])) - -(def: binary/11 - [Estimator (-> Opcode U1 U1 Instruction)] - [(..fixed ..size/11) - (function (_ opcode input0 input1 [size mutation]) - [(n.+ (///unsigned.value ..size/11) size) - (|>> mutation ((binary/11' opcode input0 input1)))])]) - -(def: size/21 - Size - (|> ..opcode_size - (///unsigned.+/2 ..index_size) try.assume - (///unsigned.+/2 ..byte_size) try.assume)) - -(def: (binary/21' opcode input0 input1) - (-> Opcode U2 U1 Mutation) - (function (_ [offset binary]) - [(n.+ (///unsigned.value ..size/21) offset) - (try.assume - (do try.monad - [_ (binary.write/8 offset opcode binary) - _ (binary.write/16 (n.+ (///unsigned.value ..opcode_size) offset) - (///unsigned.value input0) - binary)] - (binary.write/8 (n.+ (///unsigned.value ..size/2) offset) - (///unsigned.value input1) - binary)))])) - -(def: binary/21 - [Estimator (-> Opcode U2 U1 Instruction)] - [(..fixed ..size/21) - (function (_ opcode input0 input1 [size mutation]) - [(n.+ (///unsigned.value ..size/21) size) - (|>> mutation ((binary/21' opcode input0 input1)))])]) - -(def: size/211 - Size - (|> ..opcode_size - (///unsigned.+/2 ..index_size) try.assume - (///unsigned.+/2 ..byte_size) try.assume - (///unsigned.+/2 ..byte_size) try.assume)) - -(def: (trinary/211' opcode input0 input1 input2) - (-> Opcode U2 U1 U1 Mutation) - (function (_ [offset binary]) - [(n.+ (///unsigned.value ..size/211) offset) - (try.assume - (do try.monad - [_ (binary.write/8 offset opcode binary) - _ (binary.write/16 (n.+ (///unsigned.value ..opcode_size) offset) - (///unsigned.value input0) - binary) - _ (binary.write/8 (n.+ (///unsigned.value ..size/2) offset) - (///unsigned.value input1) - binary)] - (binary.write/8 (n.+ (///unsigned.value ..size/21) offset) - (///unsigned.value input2) - binary)))])) - -(def: trinary/211 - [Estimator (-> Opcode U2 U1 U1 Instruction)] - [(..fixed ..size/211) - (function (_ opcode input0 input1 input2 [size mutation]) - [(n.+ (///unsigned.value ..size/211) size) - (|>> mutation ((trinary/211' opcode input0 input1 input2)))])]) - -(abstract: #export Primitive_Array_Type - U1 - - (def: code - (-> Primitive_Array_Type U1) - (|>> :representation)) - - (template [<code> <name>] - [(def: #export <name> (|> <code> ///unsigned.u1 try.assume :abstraction))] - - [04 t_boolean] - [05 t_char] - [06 t_float] - [07 t_double] - [08 t_byte] - [09 t_short] - [10 t_int] - [11 t_long] - )) - -## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-6.html#jvms-6.5 -(with_expansions [<constants> (template [<code> <name>] - [[<code> <name> [] []]] - - ["01" aconst_null] - - ["02" iconst_m1] - ["03" iconst_0] - ["04" iconst_1] - ["05" iconst_2] - ["06" iconst_3] - ["07" iconst_4] - ["08" iconst_5] - - ["09" lconst_0] - ["0A" lconst_1] - - ["0B" fconst_0] - ["0C" fconst_1] - ["0D" fconst_2] - - ["0E" dconst_0] - ["0F" dconst_1]) - <register_loads> (template [<code> <name>] - [[<code> <name> [[register Register]] [register]]] - - ["15" iload] - ["16" lload] - ["17" fload] - ["18" dload] - ["19" aload]) - <simple_register_loads> (template [<code> <name>] - [[<code> <name> [] []]] - - ["1A" iload_0] - ["1B" iload_1] - ["1C" iload_2] - ["1D" iload_3] - - ["1E" lload_0] - ["1F" lload_1] - ["20" lload_2] - ["21" lload_3] - - ["22" fload_0] - ["23" fload_1] - ["24" fload_2] - ["25" fload_3] - - ["26" dload_0] - ["27" dload_1] - ["28" dload_2] - ["29" dload_3] - - ["2A" aload_0] - ["2B" aload_1] - ["2C" aload_2] - ["2D" aload_3]) - <register_stores> (template [<code> <name>] - [[<code> <name> [[register Register]] [register]]] - - ["36" istore] - ["37" lstore] - ["38" fstore] - ["39" dstore] - ["3A" astore]) - <simple_register_stores> (template [<code> <name>] - [[<code> <name> [] []]] - - ["3B" istore_0] - ["3C" istore_1] - ["3D" istore_2] - ["3E" istore_3] - - ["3F" lstore_0] - ["40" lstore_1] - ["41" lstore_2] - ["42" lstore_3] - - ["43" fstore_0] - ["44" fstore_1] - ["45" fstore_2] - ["46" fstore_3] - - ["47" dstore_0] - ["48" dstore_1] - ["49" dstore_2] - ["4A" dstore_3] - - ["4B" astore_0] - ["4C" astore_1] - ["4D" astore_2] - ["4E" astore_3]) - <array_loads> (template [<code> <name>] - [[<code> <name> [] []]] - - ["2E" iaload] - ["2F" laload] - ["30" faload] - ["31" daload] - ["32" aaload] - ["33" baload] - ["34" caload] - ["35" saload]) - <array_stores> (template [<code> <name>] - [[<code> <name> [] []]] - - ["4f" iastore] - ["50" lastore] - ["51" fastore] - ["52" dastore] - ["53" aastore] - ["54" bastore] - ["55" castore] - ["56" sastore]) - <arithmetic> (template [<code> <name>] - [[<code> <name> [] []]] - - ["60" iadd] - ["64" isub] - ["68" imul] - ["6c" idiv] - ["70" irem] - ["74" ineg] - ["78" ishl] - ["7a" ishr] - ["7c" iushr] - ["7e" iand] - ["80" ior] - ["82" ixor] - - ["61" ladd] - ["65" lsub] - ["69" lmul] - ["6D" ldiv] - ["71" lrem] - ["75" lneg] - ["7F" land] - ["81" lor] - ["83" lxor] - - ["62" fadd] - ["66" fsub] - ["6A" fmul] - ["6E" fdiv] - ["72" frem] - ["76" fneg] - - ["63" dadd] - ["67" dsub] - ["6B" dmul] - ["6F" ddiv] - ["73" drem] - ["77" dneg]) - <conversions> (template [<code> <name>] - [[<code> <name> [] []]] - - ["88" l2i] - ["89" l2f] - ["8A" l2d] - - ["8B" f2i] - ["8C" f2l] - ["8D" f2d] - - ["8E" d2i] - ["8F" d2l] - ["90" d2f] - - ["85" i2l] - ["86" i2f] - ["87" i2d] - ["91" i2b] - ["92" i2c] - ["93" i2s]) - <comparisons> (template [<code> <name>] - [[<code> <name> [] []]] - - ["94" lcmp] - - ["95" fcmpl] - ["96" fcmpg] - - ["97" dcmpl] - ["98" dcmpg]) - <returns> (template [<code> <name>] - [[<code> <name> [] []]] - - ["AC" ireturn] - ["AD" lreturn] - ["AE" freturn] - ["AF" dreturn] - ["B0" areturn] - ["B1" return] - ) - <jumps> (template [<code> <name>] - [[<code> <name> [[jump Jump]] [jump]]] - - ["99" ifeq] - ["9A" ifne] - ["9B" iflt] - ["9C" ifge] - ["9D" ifgt] - ["9E" ifle] - - ["9F" if_icmpeq] - ["A0" if_icmpne] - ["A1" if_icmplt] - ["A2" if_icmpge] - ["A3" if_icmpgt] - ["A4" if_icmple] - - ["A5" if_acmpeq] - ["A6" if_acmpne] - - ["A7" goto] - ["A8" jsr] - - ["C6" ifnull] - ["C7" ifnonnull]) - <fields> (template [<code> <name>] - [[<code> <name> [[index (Index (Reference Value))]] [(///index.value index)]]] - - ["B2" getstatic/1] ["B2" getstatic/2] - ["B3" putstatic/1] ["B3" putstatic/2] - ["B4" getfield/1] ["B4" getfield/2] - ["B5" putfield/1] ["B5" putfield/2])] - (template [<arity> <definitions>] - [(with_expansions [<definitions>' (template.splice <definitions>)] - (template [<code> <name> <instruction_inputs> <arity_inputs>] - [(with_expansions [<inputs>' (template.splice <instruction_inputs>) - <input_types> (template [<input_name> <input_type>] - [<input_type>] - - <inputs>') - <input_names> (template [<input_name> <input_type>] - [<input_name>] - - <inputs>')] - (def: #export <name> - [Estimator (-> [<input_types>] Instruction)] - (let [[estimator <arity>'] <arity>] - [estimator - (function (_ [<input_names>]) - (`` (<arity>' (hex <code>) (~~ (template.splice <arity_inputs>)))))])))] - - <definitions>' - ))] - - [..nullary - [["00" nop [] []] - <constants> - ["57" pop [] []] - ["58" pop2 [] []] - ["59" dup [] []] - ["5A" dup_x1 [] []] - ["5B" dup_x2 [] []] - ["5C" dup2 [] []] - ["5D" dup2_x1 [] []] - ["5E" dup2_x2 [] []] - ["5F" swap [] []] - <simple_register_loads> - <array_loads> - <simple_register_stores> - <array_stores> - <arithmetic> - ["79" lshl [] []] - ["7B" lshr [] []] - ["7D" lushr [] []] - <conversions> - <comparisons> - <returns> - ["BE" arraylength [] []] - ["BF" athrow [] []] - ["C2" monitorenter [] []] - ["C3" monitorexit [] []]]] - - [..unary/1 - [["12" ldc [[index U1]] [index]] - <register_loads> - <register_stores> - ["A9" ret [[register Register]] [register]] - ["BC" newarray [[type Primitive_Array_Type]] [(..code type)]]]] - - [..unary/1' - [["10" bipush [[byte S1]] [byte]]]] - - [..unary/2 - [["13" ldc_w/integer [[index (Index ///constant.Integer)]] [(///index.value index)]] - ["13" ldc_w/float [[index (Index ///constant.Float)]] [(///index.value index)]] - ["13" ldc_w/string [[index (Index ///constant.String)]] [(///index.value index)]] - ["14" ldc2_w/long [[index (Index ///constant.Long)]] [(///index.value index)]] - ["14" ldc2_w/double [[index (Index ///constant.Double)]] [(///index.value index)]] - <fields> - ["BB" new [[index (Index Class)]] [(///index.value index)]] - ["BD" anewarray [[index (Index Class)]] [(///index.value index)]] - ["C0" checkcast [[index (Index Class)]] [(///index.value index)]] - ["C1" instanceof [[index (Index Class)]] [(///index.value index)]] - ["B6" invokevirtual [[index (Index (Reference Method))] [count U1] [output_count U1]] [(///index.value index)]] - ["B7" invokespecial [[index (Index (Reference Method))] [count U1] [output_count U1]] [(///index.value index)]] - ["B8" invokestatic [[index (Index (Reference Method))] [count U1] [output_count U1]] [(///index.value index)]]]] - - [..unary/2' - [["11" sipush [[short S2]] [short]]]] - - [..jump/2 - [<jumps>]] - - [..jump/4 - [["C8" goto_w [[jump Big_Jump]] [jump]] - ["C9" jsr_w [[jump Big_Jump]] [jump]]]] - - [..binary/11 - [["84" iinc [[register Register] [byte U1]] [register byte]]]] - - [..binary/21 - [["C5" multianewarray [[index (Index Class)] [count U1]] [(///index.value index) count]]]] - - [..trinary/211 - [["B9" invokeinterface [[index (Index (Reference Method))] [count U1] [output_count U1]] [(///index.value index) count (try.assume (///unsigned.u1 0))]]]] - )) - -(def: (switch_padding offset) - (-> Nat Nat) - (let [parameter_start (n.+ (///unsigned.value ..opcode_size) - offset)] - (n.% 4 - (n.- (n.% 4 parameter_start) - 4)))) - -(def: #export tableswitch - [(-> Nat Estimator) - (-> S4 Big_Jump [Big_Jump (List Big_Jump)] Instruction)] - (let [estimator (: (-> Nat Estimator) - (function (_ amount_of_afterwards offset) - (|> ($_ n.+ - (///unsigned.value ..opcode_size) - (switch_padding (///unsigned.value (//address.value offset))) - (///unsigned.value ..big_jump_size) - (///unsigned.value ..integer_size) - (///unsigned.value ..integer_size) - (n.* (///unsigned.value ..big_jump_size) - (inc amount_of_afterwards))) - ///unsigned.u2 - try.assume)))] - [estimator - (function (_ minimum default [at_minimum afterwards]) - (let [amount_of_afterwards (list.size afterwards) - estimator (estimator amount_of_afterwards)] - (function (_ [size mutation]) - (let [padding (switch_padding size) - tableswitch_size (try.assume - (do {! try.monad} - [size (///unsigned.u2 size)] - (\ ! map (|>> estimator ///unsigned.value) - (//address.move size //address.start)))) - tableswitch_mutation (: Mutation - (function (_ [offset binary]) - [(n.+ tableswitch_size offset) - (try.assume - (do {! try.monad} - [amount_of_afterwards (|> amount_of_afterwards .int ///signed.s4) - maximum (///signed.+/4 minimum amount_of_afterwards) - _ (binary.write/8 offset (hex "AA") binary) - #let [offset (n.+ (///unsigned.value ..opcode_size) offset)] - _ (case padding - 3 (do ! - [_ (binary.write/8 offset 0 binary)] - (binary.write/16 (inc offset) 0 binary)) - 2 (binary.write/16 offset 0 binary) - 1 (binary.write/8 offset 0 binary) - _ (wrap binary)) - #let [offset (n.+ padding offset)] - _ (binary.write/32 offset (///signed.value default) binary) - #let [offset (n.+ (///unsigned.value ..big_jump_size) offset)] - _ (binary.write/32 offset (///signed.value minimum) binary) - #let [offset (n.+ (///unsigned.value ..integer_size) offset)] - _ (binary.write/32 offset (///signed.value maximum) binary)] - (loop [offset (n.+ (///unsigned.value ..integer_size) offset) - afterwards (: (List Big_Jump) - (#.Cons at_minimum afterwards))] - (case afterwards - #.Nil - (wrap binary) - - (#.Cons head tail) - (do ! - [_ (binary.write/32 offset (///signed.value head) binary)] - (recur (n.+ (///unsigned.value ..big_jump_size) offset) - tail))))))]))] - [(n.+ tableswitch_size - size) - (|>> mutation tableswitch_mutation)]))))])) - -(def: #export lookupswitch - [(-> Nat Estimator) - (-> Big_Jump (List [S4 Big_Jump]) Instruction)] - (let [case_size (n.+ (///unsigned.value ..integer_size) - (///unsigned.value ..big_jump_size)) - estimator (: (-> Nat Estimator) - (function (_ amount_of_cases offset) - (|> ($_ n.+ - (///unsigned.value ..opcode_size) - (switch_padding (///unsigned.value (//address.value offset))) - (///unsigned.value ..big_jump_size) - (///unsigned.value ..integer_size) - (n.* amount_of_cases case_size)) - ///unsigned.u2 - try.assume)))] - [estimator - (function (_ default cases) - (let [amount_of_cases (list.size cases) - estimator (estimator amount_of_cases)] - (function (_ [size mutation]) - (let [padding (switch_padding size) - lookupswitch_size (try.assume - (do {! try.monad} - [size (///unsigned.u2 size)] - (\ ! map (|>> estimator ///unsigned.value) - (//address.move size //address.start)))) - lookupswitch_mutation (: Mutation - (function (_ [offset binary]) - [(n.+ lookupswitch_size offset) - (try.assume - (do {! try.monad} - [_ (binary.write/8 offset (hex "AB") binary) - #let [offset (n.+ (///unsigned.value ..opcode_size) offset)] - _ (case padding - 3 (do ! - [_ (binary.write/8 offset 0 binary)] - (binary.write/16 (inc offset) 0 binary)) - 2 (binary.write/16 offset 0 binary) - 1 (binary.write/8 offset 0 binary) - _ (wrap binary)) - #let [offset (n.+ padding offset)] - _ (binary.write/32 offset (///signed.value default) binary) - #let [offset (n.+ (///unsigned.value ..big_jump_size) offset)] - _ (binary.write/32 offset amount_of_cases binary)] - (loop [offset (n.+ (///unsigned.value ..integer_size) offset) - cases cases] - (case cases - #.Nil - (wrap binary) - - (#.Cons [value jump] tail) - (do ! - [_ (binary.write/32 offset (///signed.value value) binary) - _ (binary.write/32 (n.+ (///unsigned.value ..integer_size) offset) (///signed.value jump) binary)] - (recur (n.+ case_size offset) - tail))))))]))] - [(n.+ lookupswitch_size - size) - (|>> mutation lookupswitch_mutation)]))))])) - -(implementation: #export monoid - (Monoid Instruction) - - (def: identity ..empty) - - (def: (compose left right) - (|>> left right))) diff --git a/stdlib/source/lux/target/jvm/bytecode/jump.lux b/stdlib/source/lux/target/jvm/bytecode/jump.lux deleted file mode 100644 index 4670b07ea..000000000 --- a/stdlib/source/lux/target/jvm/bytecode/jump.lux +++ /dev/null @@ -1,26 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)]] - [data - ["." format #_ - ["#" binary (#+ Writer)]]]] - ["." /// #_ - [encoding - ["#." signed (#+ S2 S4)]]]) - -(type: #export Jump S2) - -(def: #export equivalence - (Equivalence Jump) - ///signed.equivalence) - -(def: #export writer - (Writer Jump) - ///signed.writer/2) - -(type: #export Big_Jump S4) - -(def: #export lift - (-> Jump Big_Jump) - ///signed.lift/4) diff --git a/stdlib/source/lux/target/jvm/class.lux b/stdlib/source/lux/target/jvm/class.lux deleted file mode 100644 index ad90c3db5..000000000 --- a/stdlib/source/lux/target/jvm/class.lux +++ /dev/null @@ -1,133 +0,0 @@ - (.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - ["." monad (#+ do)]] - [control - ["." state] - ["." try (#+ Try)]] - [data - ["." product] - [format - [".F" binary (#+ Writer) ("#\." monoid)]] - [collection - ["." row (#+ Row)]]]] - ["." // #_ - ["#." modifier (#+ Modifier modifiers:)] - ["#." version (#+ Version Minor Major)] - ["#." magic (#+ Magic)] - ["#." index (#+ Index)] - ["#." attribute (#+ Attribute)] - ["#." field (#+ Field)] - ["#." method (#+ Method)] - [encoding - ["#." unsigned] - ["#." name (#+ Internal)]] - ["#." constant (#+ Constant) - ["#/." pool (#+ Pool Resource)]]]) - -(type: #export #rec Class - {#magic Magic - #minor_version Minor - #major_version Major - #constant_pool Pool - #modifier (Modifier Class) - #this (Index //constant.Class) - #super (Index //constant.Class) - #interfaces (Row (Index //constant.Class)) - #fields (Row Field) - #methods (Row Method) - #attributes (Row Attribute)}) - -(modifiers: Class - ["0001" public] - ["0010" final] - ["0020" super] - ["0200" interface] - ["0400" abstract] - ["1000" synthetic] - ["2000" annotation] - ["4000" enum] - ) - -(def: #export equivalence - (Equivalence Class) - ($_ product.equivalence - //unsigned.equivalence - //unsigned.equivalence - //unsigned.equivalence - //constant/pool.equivalence - //modifier.equivalence - //index.equivalence - //index.equivalence - (row.equivalence //index.equivalence) - (row.equivalence //field.equivalence) - (row.equivalence //method.equivalence) - (row.equivalence //attribute.equivalence))) - -(def: (install_classes this super interfaces) - (-> Internal Internal (List Internal) - (Resource [(Index //constant.Class) (Index //constant.Class) (Row (Index //constant.Class))])) - (do {! //constant/pool.monad} - [@this (//constant/pool.class this) - @super (//constant/pool.class super) - @interfaces (: (Resource (Row (Index //constant.Class))) - (monad.fold ! (function (_ interface @interfaces) - (do ! - [@interface (//constant/pool.class interface)] - (wrap (row.add @interface @interfaces)))) - row.empty - interfaces))] - (wrap [@this @super @interfaces]))) - -(def: #export (class version modifier - this super interfaces - fields methods attributes) - (-> Major (Modifier Class) - Internal Internal (List Internal) - (List (Resource Field)) - (List (Resource Method)) - (Row Attribute) - (Try Class)) - (do try.monad - [[pool [@this @super @interfaces] =fields =methods] - (<| (state.run' //constant/pool.empty) - (do //constant/pool.monad - [classes (install_classes this super interfaces) - =fields (monad.seq //constant/pool.monad fields) - =methods (monad.seq //constant/pool.monad methods)] - (wrap [classes =fields =methods])))] - (wrap {#magic //magic.code - #minor_version //version.default_minor - #major_version version - #constant_pool pool - #modifier modifier - #this @this - #super @super - #interfaces @interfaces - #fields (row.from_list =fields) - #methods (row.from_list =methods) - #attributes attributes}))) - -(def: #export (writer class) - (Writer Class) - (`` ($_ binaryF\compose - (~~ (template [<writer> <slot>] - [(<writer> (get@ <slot> class))] - - [//magic.writer #magic] - [//version.writer #minor_version] - [//version.writer #major_version] - [//constant/pool.writer #constant_pool] - [//modifier.writer #modifier] - [//index.writer #this] - [//index.writer #super])) - (~~ (template [<writer> <slot>] - [((binaryF.row/16 <writer>) (get@ <slot> class))] - - [//index.writer #interfaces] - [//field.writer #fields] - [//method.writer #methods] - [//attribute.writer #attributes] - )) - ))) diff --git a/stdlib/source/lux/target/jvm/constant.lux b/stdlib/source/lux/target/jvm/constant.lux deleted file mode 100644 index 651f667ee..000000000 --- a/stdlib/source/lux/target/jvm/constant.lux +++ /dev/null @@ -1,245 +0,0 @@ -(.module: - [lux #* - ["." ffi (#+ import:)] - ["@" target] - [abstract - [monad (#+ do)] - ["." equivalence (#+ Equivalence)]] - [data - ["." sum] - ["." product] - ["." text] - [format - [".F" binary (#+ Writer) ("#\." monoid)]] - [collection - ["." row (#+ Row)]]] - [macro - ["." template]] - [math - [number - ["." i32 (#+ I32)] - ["." i64] - ["." int] - ["." frac]]] - [type - abstract]] - ["." / #_ - ["#." tag] - ["/#" // #_ - ["#." index (#+ Index)] - [type - ["#." category] - ["#." descriptor (#+ Descriptor)]] - [encoding - ["#." unsigned]]]]) - -(type: #export UTF8 Text) - -(def: utf8_writer - (Writer UTF8) - binaryF.utf8/16) - -(abstract: #export Class - (Index UTF8) - - (def: #export index - (-> Class (Index UTF8)) - (|>> :representation)) - - (def: #export class - (-> (Index UTF8) Class) - (|>> :abstraction)) - - (def: #export class_equivalence - (Equivalence Class) - (\ equivalence.functor map - ..index - //index.equivalence)) - - (def: class_writer - (Writer Class) - (|>> :representation //index.writer)) - ) - -(import: java/lang/Float - ["#::." - (#static floatToRawIntBits #manual [float] int)]) - -(implementation: #export float_equivalence - (Equivalence java/lang/Float) - - (def: (= parameter subject) - (for {@.old - ("jvm feq" parameter subject) - - @.jvm - ("jvm float =" - ("jvm object cast" parameter) - ("jvm object cast" subject))}))) - -(import: java/lang/Double - ["#::." - (#static doubleToRawLongBits [double] long)]) - -(abstract: #export (Value kind) - kind - - (def: #export value - (All [kind] (-> (Value kind) kind)) - (|>> :representation)) - - (def: #export (value_equivalence Equivalence<kind>) - (All [kind] - (-> (Equivalence kind) - (Equivalence (Value kind)))) - (\ equivalence.functor map - (|>> :representation) - Equivalence<kind>)) - - (template [<constructor> <type> <marker>] - [(type: #export <type> (Value <marker>)) - - (def: #export <constructor> - (-> <marker> <type>) - (|>> :abstraction))] - - [integer Integer I32] - [float Float java/lang/Float] - [long Long .Int] - [double Double Frac] - [string String (Index UTF8)] - ) - - (template [<writer_name> <type> <write> <writer>] - [(def: <writer_name> - (Writer <type>) - (`` (|>> :representation - (~~ (template.splice <write>)) - (~~ (template.splice <writer>)))))] - - [integer_writer Integer [] [binaryF.bits/32]] - [float_writer Float [java/lang/Float::floatToRawIntBits ffi.int_to_long (:as I64)] [i32.i32 binaryF.bits/32]] - [long_writer Long [] [binaryF.bits/64]] - [double_writer Double [java/lang/Double::doubleToRawLongBits] [binaryF.bits/64]] - [string_writer String [] [//index.writer]] - ) - ) - -(type: #export (Name_And_Type of) - {#name (Index UTF8) - #descriptor (Index (Descriptor of))}) - -(type: #export (Reference of) - {#class (Index Class) - #name_and_type (Index (Name_And_Type of))}) - -(template [<type> <equivalence> <writer>] - [(def: #export <equivalence> - (Equivalence (<type> Any)) - ($_ product.equivalence - //index.equivalence - //index.equivalence)) - - (def: <writer> - (Writer (<type> Any)) - ($_ binaryF.and - //index.writer - //index.writer))] - - [Name_And_Type name_and_type_equivalence name_and_type_writer] - [Reference reference_equivalence reference_writer] - ) - -(type: #export Constant - (#UTF8 UTF8) - (#Integer Integer) - (#Float Float) - (#Long Long) - (#Double Double) - (#Class Class) - (#String String) - (#Field (Reference //category.Value)) - (#Method (Reference //category.Method)) - (#Interface_Method (Reference //category.Method)) - (#Name_And_Type (Name_And_Type Any))) - -(def: #export (size constant) - (-> Constant Nat) - (case constant - (^or (#Long _) (#Double _)) - 2 - - _ - 1)) - -(def: #export equivalence - (Equivalence Constant) - ## TODO: Delete the explicit "implementation" and use the combinator - ## version below as soon as the new format for variants is implemented. - (implementation - (def: (= reference sample) - (case [reference sample] - (^template [<tag> <equivalence>] - [[(<tag> reference) (<tag> sample)] - (\ <equivalence> = reference sample)]) - ([#UTF8 text.equivalence] - [#Integer (..value_equivalence i32.equivalence)] - [#Long (..value_equivalence int.equivalence)] - [#Float (..value_equivalence float_equivalence)] - [#Double (..value_equivalence frac.equivalence)] - [#Class ..class_equivalence] - [#String (..value_equivalence //index.equivalence)] - [#Field ..reference_equivalence] - [#Method ..reference_equivalence] - [#Interface_Method ..reference_equivalence] - [#Name_And_Type ..name_and_type_equivalence]) - - _ - false))) - ## ($_ sum.equivalence - ## ## #UTF8 - ## text.equivalence - ## ## #Long - ## (..value_equivalence int.equivalence) - ## ## #Double - ## (..value_equivalence frac.equivalence) - ## ## #Class - ## ..class_equivalence - ## ## #String - ## (..value_equivalence //index.equivalence) - ## ## #Field - ## ..reference_equivalence - ## ## #Method - ## ..reference_equivalence - ## ## #Interface_Method - ## ..reference_equivalence - ## ## #Name_And_Type - ## ..name_and_type_equivalence - ## ) - ) - -(def: #export writer - (Writer Constant) - (with_expansions [<constants> (as_is [#UTF8 /tag.utf8 ..utf8_writer] - [#Integer /tag.integer ..integer_writer] - [#Float /tag.float ..float_writer] - [#Long /tag.long ..long_writer] - [#Double /tag.double ..double_writer] - [#Class /tag.class ..class_writer] - [#String /tag.string ..string_writer] - [#Field /tag.field ..reference_writer] - [#Method /tag.method ..reference_writer] - [#Interface_Method /tag.interface_method ..reference_writer] - [#Name_And_Type /tag.name_and_type ..name_and_type_writer] - ## TODO: Method_Handle - ## TODO: Method_Type - ## TODO: Invoke_Dynamic - )] - (function (_ value) - (case value - (^template [<case> <tag> <writer>] - [(<case> value) - (binaryF\compose (/tag.writer <tag>) - (<writer> value))]) - (<constants>) - )))) diff --git a/stdlib/source/lux/target/jvm/constant/pool.lux b/stdlib/source/lux/target/jvm/constant/pool.lux deleted file mode 100644 index 8f378ed00..000000000 --- a/stdlib/source/lux/target/jvm/constant/pool.lux +++ /dev/null @@ -1,157 +0,0 @@ -(.module: - [lux #* - ["." ffi] - [abstract - [equivalence (#+ Equivalence)] - [monad (#+ Monad do)]] - [control - ["." state (#+ State')] - ["." try (#+ Try)]] - [data - ["." product] - ["." text] - ["." format #_ - ["#" binary (#+ Writer) ("specification\." monoid)]] - [collection - ["." row (#+ Row) ("#\." fold)]]] - [macro - ["." template]] - [math - [number - ["." i32] - ["n" nat] - ["." int] - ["." frac]]] - [type - abstract]] - ["." // (#+ UTF8 String Class Integer Float Long Double Constant Name_And_Type Reference) - [// - [encoding - ["#." name (#+ Internal External)] - ["#." unsigned]] - ["#." index (#+ Index)] - [type - [category (#+ Value Method)] - ["#." descriptor (#+ Descriptor)]]]]) - -(type: #export Pool [Index (Row [Index Constant])]) - -(def: #export equivalence - (Equivalence Pool) - (product.equivalence //index.equivalence - (row.equivalence (product.equivalence //index.equivalence - //.equivalence)))) - -(type: #export (Resource a) - (State' Try Pool a)) - -(def: #export monad - (Monad Resource) - (state.with try.monad)) - -(template: (!add <tag> <equivalence> <value>) - (function (_ [current pool]) - (let [<value>' <value>] - (with_expansions [<try_again> (as_is (recur (.inc idx)))] - (loop [idx 0] - (case (row.nth idx pool) - (#try.Success entry) - (case entry - [index (<tag> reference)] - (if (\ <equivalence> = reference <value>') - (#try.Success [[current pool] - index]) - <try_again>) - - _ - <try_again>) - - (#try.Failure _) - (let [new (<tag> <value>')] - (do {! try.monad} - [@new (//unsigned.u2 (//.size new)) - next (: (Try Index) - (|> current - //index.value - (//unsigned.+/2 @new) - (\ ! map //index.index)))] - (wrap [[next - (row.add [current new] pool)] - current]))))))))) - -(template: (!index <index>) - (|> <index> //index.value //unsigned.value)) - -(type: (Adder of) - (-> of (Resource (Index of)))) - -(template [<name> <type> <tag> <equivalence>] - [(def: #export (<name> value) - (Adder <type>) - (!add <tag> <equivalence> value))] - - [integer Integer #//.Integer (//.value_equivalence i32.equivalence)] - [float Float #//.Float (//.value_equivalence //.float_equivalence)] - [long Long #//.Long (//.value_equivalence int.equivalence)] - [double Double #//.Double (//.value_equivalence frac.equivalence)] - [utf8 UTF8 #//.UTF8 text.equivalence] - ) - -(def: #export (string value) - (-> Text (Resource (Index String))) - (do ..monad - [@value (utf8 value) - #let [value (//.string @value)]] - (!add #//.String (//.value_equivalence //index.equivalence) value))) - -(def: #export (class name) - (-> Internal (Resource (Index Class))) - (do ..monad - [@name (utf8 (//name.read name)) - #let [value (//.class @name)]] - (!add #//.Class //.class_equivalence value))) - -(def: #export (descriptor value) - (All [kind] - (-> (Descriptor kind) - (Resource (Index (Descriptor kind))))) - (let [value (//descriptor.descriptor value)] - (!add #//.UTF8 text.equivalence value))) - -(type: #export (Member of) - {#name UTF8 - #descriptor (Descriptor of)}) - -(def: #export (name_and_type [name descriptor]) - (All [of] - (-> (Member of) (Resource (Index (Name_And_Type of))))) - (do ..monad - [@name (utf8 name) - @descriptor (..descriptor descriptor)] - (!add #//.Name_And_Type //.name_and_type_equivalence {#//.name @name #//.descriptor @descriptor}))) - -(template [<name> <tag> <of>] - [(def: #export (<name> class member) - (-> External (Member <of>) (Resource (Index (Reference <of>)))) - (do ..monad - [@class (..class (//name.internal class)) - @name_and_type (name_and_type member)] - (!add <tag> //.reference_equivalence {#//.class @class #//.name_and_type @name_and_type})))] - - [field #//.Field Value] - [method #//.Method Method] - [interface_method #//.Interface_Method Method] - ) - -(def: #export writer - (Writer Pool) - (function (_ [next pool]) - (row\fold (function (_ [_index post] pre) - (specification\compose pre (//.writer post))) - (format.bits/16 (!index next)) - pool))) - -(def: #export empty - Pool - [(|> 1 //unsigned.u2 try.assume //index.index) - row.empty]) diff --git a/stdlib/source/lux/target/jvm/constant/tag.lux b/stdlib/source/lux/target/jvm/constant/tag.lux deleted file mode 100644 index 011e38374..000000000 --- a/stdlib/source/lux/target/jvm/constant/tag.lux +++ /dev/null @@ -1,49 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)]] - [control - ["." try]] - [data - [format - [binary (#+ Writer)]]] - [type - abstract]] - ["." /// #_ - [encoding - ["#." unsigned (#+ U1) ("u1//." equivalence)]]]) - -(abstract: #export Tag - U1 - - (implementation: #export equivalence - (Equivalence Tag) - (def: (= reference sample) - (u1//= (:representation reference) - (:representation sample)))) - - (template [<code> <name>] - [(def: #export <name> - Tag - (|> <code> ///unsigned.u1 try.assume :abstraction))] - - [01 utf8] - [03 integer] - [04 float] - [05 long] - [06 double] - [07 class] - [08 string] - [09 field] - [10 method] - [11 interface_method] - [12 name_and_type] - [15 method_handle] - [16 method_type] - [18 invoke_dynamic] - ) - - (def: #export writer - (Writer Tag) - (|>> :representation ///unsigned.writer/1)) - ) diff --git a/stdlib/source/lux/target/jvm/encoding/name.lux b/stdlib/source/lux/target/jvm/encoding/name.lux deleted file mode 100644 index 606c7439c..000000000 --- a/stdlib/source/lux/target/jvm/encoding/name.lux +++ /dev/null @@ -1,39 +0,0 @@ -(.module: - [lux #* - [data - ["." text - ["%" format (#+ format)]]] - [type - abstract]]) - -(def: #export internal_separator "/") -(def: #export external_separator ".") - -(type: #export External Text) - -(abstract: #export Internal - Text - - (def: #export internal - (-> External Internal) - (|>> (text.replace_all ..external_separator - ..internal_separator) - :abstraction)) - - (def: #export read - (-> Internal Text) - (|>> :representation)) - - (def: #export external - (-> Internal External) - (|>> :representation - (text.replace_all ..internal_separator - ..external_separator)))) - -(def: #export sanitize - (-> Text External) - (|>> ..internal ..external)) - -(def: #export (qualify package class) - (-> Text External External) - (format (..sanitize package) ..external_separator class)) diff --git a/stdlib/source/lux/target/jvm/encoding/signed.lux b/stdlib/source/lux/target/jvm/encoding/signed.lux deleted file mode 100644 index 934d48ce2..000000000 --- a/stdlib/source/lux/target/jvm/encoding/signed.lux +++ /dev/null @@ -1,106 +0,0 @@ -(.module: - [lux (#- int) - [abstract - [equivalence (#+ Equivalence)] - [order (#+ Order)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - [text - ["%" format (#+ format)]] - ["." format #_ - ["#" binary (#+ Writer)]]] - [macro - ["." template]] - [math - [number - ["." i64] - ["n" nat] - ["i" int]]] - [type - abstract]]) - -(abstract: #export (Signed brand) - Int - - (def: #export value - (-> (Signed Any) Int) - (|>> :representation)) - - (implementation: #export equivalence - (All [brand] (Equivalence (Signed brand))) - (def: (= reference sample) - (i.= (:representation reference) (:representation sample)))) - - (implementation: #export order - (All [brand] (Order (Signed brand))) - - (def: &equivalence ..equivalence) - (def: (< reference sample) - (i.< (:representation reference) (:representation sample)))) - - (exception: #export (value_exceeds_the_scope {value Int} - {scope Nat}) - (exception.report - ["Value" (%.int value)] - ["Scope (in bytes)" (%.nat scope)])) - - (template [<bytes> <name> <size> <constructor> <maximum> <+> <->] - [(with_expansions [<raw> (template.identifier [<name> "'"])] - (abstract: #export <raw> Any) - (type: #export <name> (Signed <raw>))) - - (def: #export <size> <bytes>) - - (def: #export <maximum> - <name> - (|> <bytes> (n.* i64.bits_per_byte) dec i64.mask :abstraction)) - - (def: #export <constructor> - (-> Int (Try <name>)) - (let [positive (|> <bytes> (n.* i64.bits_per_byte) i64.mask) - negative (|> positive .int (i.right_shift 1) i64.not)] - (function (_ value) - (if (i.= (if (i.< +0 value) - (i64.or negative value) - (i64.and positive value)) - value) - (#try.Success (:abstraction value)) - (exception.throw ..value_exceeds_the_scope [value <size>]))))) - - (template [<abstract_operation> <concrete_operation>] - [(def: #export (<abstract_operation> parameter subject) - (-> <name> <name> (Try <name>)) - (<constructor> - (<concrete_operation> (:representation parameter) - (:representation subject))))] - - [<+> i.+] - [<-> i.-] - )] - - [1 S1 bytes/1 s1 maximum/1 +/1 -/1] - [2 S2 bytes/2 s2 maximum/2 +/2 -/2] - [4 S4 bytes/4 s4 maximum/4 +/4 -/4] - ) - - (template [<name> <from> <to>] - [(def: #export <name> - (-> <from> <to>) - (|>> :transmutation))] - - [lift/2 S1 S2] - [lift/4 S2 S4] - ) - - (template [<writer_name> <type> <writer>] - [(def: #export <writer_name> - (Writer <type>) - (|>> :representation <writer>))] - - [writer/1 S1 format.bits/8] - [writer/2 S2 format.bits/16] - [writer/4 S4 format.bits/32] - ) - ) diff --git a/stdlib/source/lux/target/jvm/encoding/unsigned.lux b/stdlib/source/lux/target/jvm/encoding/unsigned.lux deleted file mode 100644 index 4cff01d68..000000000 --- a/stdlib/source/lux/target/jvm/encoding/unsigned.lux +++ /dev/null @@ -1,120 +0,0 @@ -(.module: - [lux (#- nat) - [abstract - [equivalence (#+ Equivalence)] - [order (#+ Order)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - [text - ["%" format (#+ format)]] - ["." format #_ - ["#" binary (#+ Writer)]]] - [macro - ["." template]] - [math - [number - ["n" nat] - ["." i64]]] - [type - abstract]]) - -(abstract: #export (Unsigned brand) - Nat - - (def: #export value - (-> (Unsigned Any) Nat) - (|>> :representation)) - - (implementation: #export equivalence - (All [brand] (Equivalence (Unsigned brand))) - (def: (= reference sample) - (n.= (:representation reference) - (:representation sample)))) - - (implementation: #export order - (All [brand] (Order (Unsigned brand))) - - (def: &equivalence ..equivalence) - (def: (< reference sample) - (n.< (:representation reference) - (:representation sample)))) - - (exception: #export (value_exceeds_the_maximum {type Name} - {value Nat} - {maximum (Unsigned Any)}) - (exception.report - ["Type" (%.name type)] - ["Value" (%.nat value)] - ["Maximum" (%.nat (:representation maximum))])) - - (exception: #export [brand] (subtraction_cannot_yield_negative_value - {type Name} - {parameter (Unsigned brand)} - {subject (Unsigned brand)}) - (exception.report - ["Type" (%.name type)] - ["Parameter" (%.nat (:representation parameter))] - ["Subject" (%.nat (:representation subject))])) - - (template [<bytes> <name> <size> <constructor> <maximum> <+> <-> <max>] - [(with_expansions [<raw> (template.identifier [<name> "'"])] - (abstract: #export <raw> Any) - (type: #export <name> (Unsigned <raw>))) - - (def: #export <size> <bytes>) - - (def: #export <maximum> - <name> - (|> <bytes> (n.* i64.bits_per_byte) i64.mask :abstraction)) - - (def: #export (<constructor> value) - (-> Nat (Try <name>)) - (if (n.<= (:representation <maximum>) value) - (#try.Success (:abstraction value)) - (exception.throw ..value_exceeds_the_maximum [(name_of <name>) value <maximum>]))) - - (def: #export (<+> parameter subject) - (-> <name> <name> (Try <name>)) - (<constructor> - (n.+ (:representation parameter) - (:representation subject)))) - - (def: #export (<-> parameter subject) - (-> <name> <name> (Try <name>)) - (let [parameter' (:representation parameter) - subject' (:representation subject)] - (if (n.<= subject' parameter') - (#try.Success (:abstraction (n.- parameter' subject'))) - (exception.throw ..subtraction_cannot_yield_negative_value [(name_of <name>) parameter subject])))) - - (def: #export (<max> left right) - (-> <name> <name> <name>) - (:abstraction (n.max (:representation left) - (:representation right))))] - - [1 U1 bytes/1 u1 maximum/1 +/1 -/1 max/1] - [2 U2 bytes/2 u2 maximum/2 +/2 -/2 max/2] - [4 U4 bytes/4 u4 maximum/4 +/4 -/4 max/4] - ) - - (template [<name> <from> <to>] - [(def: #export <name> - (-> <from> <to>) - (|>> :transmutation))] - - [lift/2 U1 U2] - [lift/4 U2 U4] - ) - - (template [<writer_name> <type> <writer>] - [(def: #export <writer_name> - (Writer <type>) - (|>> :representation <writer>))] - - [writer/1 U1 format.bits/8] - [writer/2 U2 format.bits/16] - [writer/4 U4 format.bits/32] - ) - ) diff --git a/stdlib/source/lux/target/jvm/field.lux b/stdlib/source/lux/target/jvm/field.lux deleted file mode 100644 index 2e8863f57..000000000 --- a/stdlib/source/lux/target/jvm/field.lux +++ /dev/null @@ -1,69 +0,0 @@ -(.module: - [lux (#- Type static) - [abstract - [equivalence (#+ Equivalence)] - ["." monad (#+ do)]] - [data - ["." product] - [format - [".F" binary (#+ Writer) ("#\." monoid)]] - [collection - ["." row (#+ Row)]]]] - ["." // #_ - ["." modifier (#+ Modifier modifiers:)] - ["#." constant (#+ UTF8) - ["#/." pool (#+ Pool Resource)]] - ["#." index (#+ Index)] - ["#." attribute (#+ Attribute)] - ["#." type (#+ Type) - [category (#+ Value)] - [descriptor (#+ Descriptor)]]]) - -(type: #export #rec Field - {#modifier (Modifier Field) - #name (Index UTF8) - #descriptor (Index (Descriptor Value)) - #attributes (Row Attribute)}) - -(modifiers: Field - ["0001" public] - ["0002" private] - ["0004" protected] - ["0008" static] - ["0010" final] - ["0040" volatile] - ["0080" transient] - ["1000" synthetic] - ["4000" enum] - ) - -(def: #export equivalence - (Equivalence Field) - ($_ product.equivalence - modifier.equivalence - //index.equivalence - //index.equivalence - (row.equivalence //attribute.equivalence))) - -(def: #export (writer field) - (Writer Field) - (`` ($_ binaryF\compose - (~~ (template [<writer> <slot>] - [(<writer> (get@ <slot> field))] - - [modifier.writer #modifier] - [//index.writer #name] - [//index.writer #descriptor] - [(binaryF.row/16 //attribute.writer) #attributes])) - ))) - -(def: #export (field modifier name type attributes) - (-> (Modifier Field) UTF8 (Type Value) (Row Attribute) - (Resource Field)) - (do //constant/pool.monad - [@name (//constant/pool.utf8 name) - @descriptor (//constant/pool.descriptor (//type.descriptor type))] - (wrap {#modifier modifier - #name @name - #descriptor @descriptor - #attributes attributes}))) diff --git a/stdlib/source/lux/target/jvm/index.lux b/stdlib/source/lux/target/jvm/index.lux deleted file mode 100644 index c4f0ec9d1..000000000 --- a/stdlib/source/lux/target/jvm/index.lux +++ /dev/null @@ -1,37 +0,0 @@ -(.module: - [lux #* - [abstract - ["." equivalence (#+ Equivalence)]] - [data - [format - [binary (#+ Writer)]]] - [type - abstract]] - ["." // #_ - [encoding - ["#." unsigned (#+ U2)]]]) - -(def: #export length - //unsigned.bytes/2) - -(abstract: #export (Index kind) - U2 - - (def: #export index - (All [kind] (-> U2 (Index kind))) - (|>> :abstraction)) - - (def: #export value - (-> (Index Any) U2) - (|>> :representation)) - - (def: #export equivalence - (All [kind] (Equivalence (Index kind))) - (\ equivalence.functor map - ..value - //unsigned.equivalence)) - - (def: #export writer - (All [kind] (Writer (Index kind))) - (|>> :representation //unsigned.writer/2)) - ) diff --git a/stdlib/source/lux/target/jvm/loader.lux b/stdlib/source/lux/target/jvm/loader.lux deleted file mode 100644 index 4ca391382..000000000 --- a/stdlib/source/lux/target/jvm/loader.lux +++ /dev/null @@ -1,142 +0,0 @@ -(.module: - [lux #* - ["@" target] - [abstract - [monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["." io (#+ IO)] - [concurrency - ["." atom (#+ Atom)]]] - [data - ["." binary (#+ Binary)] - ["." text - ["%" format (#+ format)]] - [collection - ["." array] - ["." dictionary (#+ Dictionary)]]] - ["." ffi (#+ import: object do_to)]]) - -(type: #export Library - (Atom (Dictionary Text Binary))) - -(exception: #export (already_stored {class Text}) - (exception.report - ["Class" class])) - -(exception: #export (unknown {class Text} {known_classes (List Text)}) - (exception.report - ["Class" class] - ["Known classes" (exception.enumerate (|>>) known_classes)])) - -(exception: #export (cannot_define {class Text} {error Text}) - (exception.report - ["Class" class] - ["Error" error])) - -(import: java/lang/Object - ["#::." - (getClass [] (java/lang/Class java/lang/Object))]) - -(import: java/lang/String) - -(import: java/lang/reflect/Method - ["#::." - (invoke [java/lang/Object [java/lang/Object]] #try java/lang/Object)]) - -(import: (java/lang/Class a) - ["#::." - (getDeclaredMethod [java/lang/String [(java/lang/Class [? < java/lang/Object])]] java/lang/reflect/Method)]) - -(import: java/lang/Integer - ["#::." - (#static TYPE (java/lang/Class java/lang/Integer))]) - -(import: java/lang/reflect/AccessibleObject - ["#::." - (setAccessible [boolean] void)]) - -(import: java/lang/ClassLoader - ["#::." - (loadClass [java/lang/String] - #io #try (java/lang/Class java/lang/Object))]) - -(with_expansions [<elemT> (as_is (java/lang/Class java/lang/Object))] - (def: java/lang/ClassLoader::defineClass - java/lang/reflect/Method - (let [signature (|> (ffi.array <elemT> 4) - (ffi.array_write 0 (:as <elemT> - (ffi.class_for java/lang/String))) - (ffi.array_write 1 (java/lang/Object::getClass (ffi.array byte 0))) - (ffi.array_write 2 (:as <elemT> - (java/lang/Integer::TYPE))) - (ffi.array_write 3 (:as <elemT> - (java/lang/Integer::TYPE))))] - (do_to (java/lang/Class::getDeclaredMethod "defineClass" - signature - (ffi.class_for java/lang/ClassLoader)) - (java/lang/reflect/AccessibleObject::setAccessible true))))) - -(def: #export (define class_name bytecode loader) - (-> Text Binary java/lang/ClassLoader (Try java/lang/Object)) - (let [signature (array.from_list (list (:as java/lang/Object - class_name) - (:as java/lang/Object - bytecode) - (:as java/lang/Object - (|> 0 - (:as (primitive "java.lang.Long")) - ffi.long_to_int)) - (:as java/lang/Object - (|> bytecode - binary.size - (:as (primitive "java.lang.Long")) - ffi.long_to_int))))] - (java/lang/reflect/Method::invoke loader signature java/lang/ClassLoader::defineClass))) - -(def: #export (new_library _) - (-> Any Library) - (atom.atom (dictionary.new text.hash))) - -(def: #export (memory library) - (-> Library java/lang/ClassLoader) - (with_expansions [<cast> (for {@.old - (<|) - - @.jvm - "jvm object cast"})] - (<| <cast> - (object [] java/lang/ClassLoader [] - [] - (java/lang/ClassLoader (findClass self {class_name java/lang/String}) - (java/lang/Class [? < java/lang/Object]) - #throws [java/lang/ClassNotFoundException] - (let [class_name (:as Text class_name) - classes (|> library atom.read io.run)] - (case (dictionary.get class_name classes) - (#.Some bytecode) - (case (..define class_name bytecode (<| <cast> self)) - (#try.Success class) - (:assume class) - - (#try.Failure error) - (error! (exception.construct ..cannot_define [class_name error]))) - - #.None - (error! (exception.construct ..unknown [class_name (dictionary.keys classes)]))))))))) - -(def: #export (store name bytecode library) - (-> Text Binary Library (IO (Try Any))) - (do {! io.monad} - [library' (atom.read library)] - (if (dictionary.key? library' name) - (wrap (exception.throw ..already_stored name)) - (do ! - [_ (atom.update (dictionary.put name bytecode) library)] - (wrap (#try.Success [])))))) - -(def: #export (load name loader) - (-> Text java/lang/ClassLoader - (IO (Try (java/lang/Class java/lang/Object)))) - (java/lang/ClassLoader::loadClass name loader)) diff --git a/stdlib/source/lux/target/jvm/magic.lux b/stdlib/source/lux/target/jvm/magic.lux deleted file mode 100644 index 370d8e09b..000000000 --- a/stdlib/source/lux/target/jvm/magic.lux +++ /dev/null @@ -1,19 +0,0 @@ -(.module: - [lux #* - [control - ["." try]] - [math - [number (#+ hex)]]] - ["." // #_ - [encoding - ["#." unsigned (#+ U4)]]]) - -(type: #export Magic - U4) - -(def: #export code - Magic - (|> (hex "CAFEBABE") //unsigned.u4 try.assume)) - -(def: #export writer - //unsigned.writer/4) diff --git a/stdlib/source/lux/target/jvm/method.lux b/stdlib/source/lux/target/jvm/method.lux deleted file mode 100644 index 6219a1c1d..000000000 --- a/stdlib/source/lux/target/jvm/method.lux +++ /dev/null @@ -1,103 +0,0 @@ -(.module: - [lux (#- Type static) - [abstract - [equivalence (#+ Equivalence)] - ["." monad (#+ do)]] - [control - ["." try]] - [data - ["." product] - ["." format #_ - ["#" binary (#+ Writer) ("#\." monoid)]] - [collection - ["." row (#+ Row)]]]] - ["." // #_ - ["#." modifier (#+ Modifier modifiers:)] - ["#." index (#+ Index)] - ["#." attribute (#+ Attribute) - ["#/." code]] - ["#." constant (#+ UTF8) - ["#/." pool (#+ Pool Resource)]] - ["#." bytecode (#+ Bytecode) - ["#/." environment (#+ Environment)] - ["#/." instruction]] - ["#." type (#+ Type) - ["#/." category] - ["#." descriptor (#+ Descriptor)]]]) - -(type: #export #rec Method - {#modifier (Modifier Method) - #name (Index UTF8) - #descriptor (Index (Descriptor //type/category.Method)) - #attributes (Row Attribute)}) - -(modifiers: Method - ["0001" public] - ["0002" private] - ["0004" protected] - ["0008" static] - ["0010" final] - ["0020" synchronized] - ["0040" bridge] - ["0080" var_args] - ["0100" native] - ["0400" abstract] - ["0800" strict] - ["1000" synthetic] - ) - -(def: #export (method modifier name type attributes code) - (-> (Modifier Method) UTF8 (Type //type/category.Method) (List (Resource Attribute)) (Maybe (Bytecode Any)) - (Resource Method)) - (do {! //constant/pool.monad} - [@name (//constant/pool.utf8 name) - @descriptor (//constant/pool.descriptor (//type.descriptor type)) - attributes (|> attributes - (monad.seq !) - (\ ! map row.from_list)) - attributes (case code - (#.Some code) - (do ! - [environment (case (if (//modifier.has? static modifier) - (//bytecode/environment.static type) - (//bytecode/environment.virtual type)) - (#try.Success environment) - (wrap environment) - - (#try.Failure error) - (function (_ _) (#try.Failure error))) - [environment exceptions instruction output] (//bytecode.resolve environment code) - #let [bytecode (|> instruction //bytecode/instruction.run format.instance)] - @code (//attribute.code {#//attribute/code.limit (get@ #//bytecode/environment.limit environment) - #//attribute/code.code bytecode - #//attribute/code.exception_table exceptions - #//attribute/code.attributes (row.row)})] - (wrap (row.add @code attributes))) - - #.None - (wrap attributes))] - (wrap {#modifier modifier - #name @name - #descriptor @descriptor - #attributes attributes}))) - -(def: #export equivalence - (Equivalence Method) - ($_ product.equivalence - //modifier.equivalence - //index.equivalence - //index.equivalence - (row.equivalence //attribute.equivalence) - )) - -(def: #export (writer field) - (Writer Method) - (`` ($_ format\compose - (~~ (template [<writer> <slot>] - [(<writer> (get@ <slot> field))] - - [//modifier.writer #modifier] - [//index.writer #name] - [//index.writer #descriptor] - [(format.row/16 //attribute.writer) #attributes])) - ))) diff --git a/stdlib/source/lux/target/jvm/modifier.lux b/stdlib/source/lux/target/jvm/modifier.lux deleted file mode 100644 index 80e353f33..000000000 --- a/stdlib/source/lux/target/jvm/modifier.lux +++ /dev/null @@ -1,87 +0,0 @@ -(.module: - [lux #* - [abstract - ["." equivalence (#+ Equivalence)] - ["." monoid (#+ Monoid)]] - [control - ["." try] - ["<>" parser - ["<c>" code]]] - [data - [format - [".F" binary (#+ Writer)]]] - [macro (#+ with_gensyms) - [syntax (#+ syntax:)] - ["." code]] - [math - ["." number (#+ hex) - ["." i64]]] - [type - abstract]] - ["." // #_ - [encoding - ["#." unsigned]]]) - -(abstract: #export (Modifier of) - //unsigned.U2 - - (def: #export code - (-> (Modifier Any) //unsigned.U2) - (|>> :representation)) - - (implementation: #export equivalence - (All [of] (Equivalence (Modifier of))) - - (def: (= reference sample) - (\ //unsigned.equivalence = - (:representation reference) - (:representation sample)))) - - (template: (!wrap value) - (|> value - //unsigned.u2 - try.assume - :abstraction)) - - (template: (!unwrap value) - (|> value - :representation - //unsigned.value)) - - (def: #export (has? sub super) - (All [of] (-> (Modifier of) (Modifier of) Bit)) - (let [sub (!unwrap sub)] - (|> (!unwrap super) - (i64.and sub) - (\ i64.equivalence = sub)))) - - (implementation: #export monoid - (All [of] (Monoid (Modifier of))) - - (def: identity - (!wrap (hex "0000"))) - - (def: (compose left right) - (!wrap (i64.or (!unwrap left) (!unwrap right))))) - - (def: #export empty - Modifier - (\ ..monoid identity)) - - (def: #export writer - (All [of] (Writer (Modifier of))) - (|>> :representation //unsigned.writer/2)) - - (def: modifier - (-> Nat Modifier) - (|>> !wrap)) - ) - -(syntax: #export (modifiers: ofT {options (<>.many <c>.any)}) - (with_gensyms [g!modifier g!code] - (wrap (list (` (template [(~ g!code) (~ g!modifier)] - [(def: (~' #export) (~ g!modifier) - (..Modifier (~ ofT)) - ((~! ..modifier) ((~! number.hex) (~ g!code))))] - - (~+ options))))))) diff --git a/stdlib/source/lux/target/jvm/modifier/inner.lux b/stdlib/source/lux/target/jvm/modifier/inner.lux deleted file mode 100644 index ff6f5d50e..000000000 --- a/stdlib/source/lux/target/jvm/modifier/inner.lux +++ /dev/null @@ -1,20 +0,0 @@ -(.module: - [lux (#- static) - [type - abstract]] - [// (#+ modifiers:)]) - -(abstract: #export Inner Any) - -(modifiers: Inner - ["0001" public] - ["0002" private] - ["0004" protected] - ["0008" static] - ["0010" final] - ["0200" interface] - ["0400" abstract] - ["1000" synthetic] - ["2000" annotation] - ["4000" enum] - ) diff --git a/stdlib/source/lux/target/jvm/reflection.lux b/stdlib/source/lux/target/jvm/reflection.lux deleted file mode 100644 index 02c6b0ab0..000000000 --- a/stdlib/source/lux/target/jvm/reflection.lux +++ /dev/null @@ -1,381 +0,0 @@ -(.module: - [lux (#- type) - ["." ffi (#+ import:)] - ["." type] - [abstract - ["." monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)] - [parser - ["<t>" text]]] - [data - ["." text ("#\." equivalence) - ["%" format (#+ format)]] - [collection - ["." list ("#\." fold functor)] - ["." array] - ["." dictionary]]] - [math - [number - ["n" nat]]]] - ["." // #_ - [encoding - ["#." name (#+ External)]] - ["/" type - [category (#+ Void Value Return Method Primitive Object Class Array Parameter)] - ["#." lux (#+ Mapping)] - ["#." descriptor] - ["#." reflection] - ["#." parser]]]) - -(import: java/lang/String) - -(import: java/lang/Object - ["#::." - (toString [] java/lang/String) - (getClass [] (java/lang/Class java/lang/Object))]) - -(import: java/lang/reflect/Type - ["#::." - (getTypeName [] java/lang/String)]) - -(import: java/lang/reflect/GenericArrayType - ["#::." - (getGenericComponentType [] java/lang/reflect/Type)]) - -(import: java/lang/reflect/ParameterizedType - ["#::." - (getRawType [] java/lang/reflect/Type) - (getActualTypeArguments [] [java/lang/reflect/Type])]) - -(import: (java/lang/reflect/TypeVariable d) - ["#::." - (getName [] java/lang/String) - (getBounds [] [java/lang/reflect/Type])]) - -(import: (java/lang/reflect/WildcardType d) - ["#::." - (getLowerBounds [] [java/lang/reflect/Type]) - (getUpperBounds [] [java/lang/reflect/Type])]) - -(import: java/lang/reflect/Modifier - ["#::." - (#static isStatic [int] boolean) - (#static isFinal [int] boolean) - (#static isInterface [int] boolean) - (#static isAbstract [int] boolean)]) - -(import: java/lang/annotation/Annotation) - -(import: java/lang/Deprecated) - -(import: java/lang/reflect/Field - ["#::." - (getDeclaringClass [] (java/lang/Class java/lang/Object)) - (getModifiers [] int) - (getGenericType [] java/lang/reflect/Type) - (getDeclaredAnnotations [] [java/lang/annotation/Annotation])]) - -(import: java/lang/reflect/Method - ["#::." - (getName [] java/lang/String) - (getModifiers [] int) - (getDeclaringClass [] (java/lang/Class java/lang/Object)) - (getTypeParameters [] [(java/lang/reflect/TypeVariable java/lang/reflect/Method)]) - (getGenericParameterTypes [] [java/lang/reflect/Type]) - (getGenericReturnType [] java/lang/reflect/Type) - (getGenericExceptionTypes [] [java/lang/reflect/Type])]) - -(import: (java/lang/reflect/Constructor c) - ["#::." - (getModifiers [] int) - (getDeclaringClass [] (java/lang/Class c)) - (getTypeParameters [] [(java/lang/reflect/TypeVariable (java/lang/reflect/Constructor c))]) - (getGenericParameterTypes [] [java/lang/reflect/Type]) - (getGenericExceptionTypes [] [java/lang/reflect/Type])]) - -(import: (java/lang/Class c) - ["#::." - (#static forName [java/lang/String] #try (java/lang/Class java/lang/Object)) - (getName [] java/lang/String) - (getModifiers [] int) - (isAssignableFrom [(java/lang/Class java/lang/Object)] boolean) - (getTypeParameters [] [(java/lang/reflect/TypeVariable (java/lang/Class c))]) - (getGenericInterfaces [] [java/lang/reflect/Type]) - (getGenericSuperclass [] #? java/lang/reflect/Type) - (getDeclaredField [java/lang/String] #try java/lang/reflect/Field) - (getConstructors [] [(java/lang/reflect/Constructor java/lang/Object)]) - (getDeclaredMethods [] [java/lang/reflect/Method])]) - -(exception: #export (unknown_class {class External}) - (exception.report - ["Class" (%.text class)])) - -(template [<name>] - [(exception: #export (<name> {jvm_type java/lang/reflect/Type}) - (exception.report - ["Type" (java/lang/reflect/Type::getTypeName jvm_type)] - ["Class" (|> jvm_type java/lang/Object::getClass java/lang/Object::toString)]))] - - [not_a_class] - [cannot_convert_to_a_lux_type] - ) - -(def: #export (load name) - (-> External (Try (java/lang/Class java/lang/Object))) - (case (java/lang/Class::forName name) - (#try.Success class) - (#try.Success class) - - (#try.Failure _) - (exception.throw ..unknown_class name))) - -(def: #export (sub? super sub) - (-> External External (Try Bit)) - (do try.monad - [super (..load super) - sub (..load sub)] - (wrap (java/lang/Class::isAssignableFrom sub super)))) - -(def: (class' parameter reflection) - (-> (-> java/lang/reflect/Type (Try (/.Type Parameter))) - java/lang/reflect/Type - (Try (/.Type Class))) - (<| (case (ffi.check java/lang/Class reflection) - (#.Some class) - (let [class_name (|> class - (:as (java/lang/Class java/lang/Object)) - java/lang/Class::getName)] - (`` (if (or (~~ (template [<reflection>] - [(text\= (/reflection.reflection <reflection>) - class_name)] - - [/reflection.boolean] - [/reflection.byte] - [/reflection.short] - [/reflection.int] - [/reflection.long] - [/reflection.float] - [/reflection.double] - [/reflection.char])) - (text.starts_with? /descriptor.array_prefix class_name)) - (exception.throw ..not_a_class reflection) - (#try.Success (/.class class_name (list)))))) - _) - (case (ffi.check java/lang/reflect/ParameterizedType reflection) - (#.Some reflection) - (let [raw (java/lang/reflect/ParameterizedType::getRawType reflection)] - (case (ffi.check java/lang/Class raw) - (#.Some raw) - (do {! try.monad} - [paramsT (|> reflection - java/lang/reflect/ParameterizedType::getActualTypeArguments - array.to_list - (monad.map ! parameter))] - (wrap (/.class (|> raw - (:as (java/lang/Class java/lang/Object)) - java/lang/Class::getName) - paramsT))) - - _ - (exception.throw ..not_a_class raw))) - _) - ## else - (exception.throw ..cannot_convert_to_a_lux_type reflection))) - -(def: #export (parameter reflection) - (-> java/lang/reflect/Type (Try (/.Type Parameter))) - (<| (case (ffi.check java/lang/reflect/TypeVariable reflection) - (#.Some reflection) - (#try.Success (/.var (java/lang/reflect/TypeVariable::getName reflection))) - _) - (case (ffi.check java/lang/reflect/WildcardType reflection) - (#.Some reflection) - ## TODO: Instead of having single lower/upper bounds, should - ## allow for multiple ones. - (case [(array.read 0 (java/lang/reflect/WildcardType::getLowerBounds reflection)) - (array.read 0 (java/lang/reflect/WildcardType::getUpperBounds reflection))] - (^template [<pattern> <kind>] - [<pattern> - (case (ffi.check java/lang/reflect/GenericArrayType bound) - (#.Some _) - ## TODO: Array bounds should not be "erased" as they - ## are right now. - (#try.Success /.wildcard) - - _ - (\ try.monad map <kind> (..class' parameter bound)))]) - ([[_ (#.Some bound)] /.upper] - [[(#.Some bound) _] /.lower]) - - _ - (#try.Success /.wildcard)) - _) - (..class' parameter reflection))) - -(def: #export class - (-> java/lang/reflect/Type - (Try (/.Type Class))) - (..class' ..parameter)) - -(def: #export (type reflection) - (-> java/lang/reflect/Type (Try (/.Type Value))) - (<| (case (ffi.check java/lang/Class reflection) - (#.Some reflection) - (let [class_name (|> reflection - (:as (java/lang/Class java/lang/Object)) - java/lang/Class::getName)] - (`` (cond (~~ (template [<reflection> <type>] - [(text\= (/reflection.reflection <reflection>) - class_name) - (#try.Success <type>)] - - [/reflection.boolean /.boolean] - [/reflection.byte /.byte] - [/reflection.short /.short] - [/reflection.int /.int] - [/reflection.long /.long] - [/reflection.float /.float] - [/reflection.double /.double] - [/reflection.char /.char])) - (if (text.starts_with? /descriptor.array_prefix class_name) - (<t>.run /parser.value (|> class_name //name.internal //name.read)) - (#try.Success (/.class class_name (list))))))) - _) - (case (ffi.check java/lang/reflect/GenericArrayType reflection) - (#.Some reflection) - (|> reflection - java/lang/reflect/GenericArrayType::getGenericComponentType - type - (\ try.monad map /.array)) - _) - ## else - (..parameter reflection))) - -(def: #export (return reflection) - (-> java/lang/reflect/Type (Try (/.Type Return))) - (with_expansions [<else> (as_is (..type reflection))] - (case (ffi.check java/lang/Class reflection) - (#.Some class) - (let [class_name (|> reflection - (:as (java/lang/Class java/lang/Object)) - java/lang/Class::getName)] - (if (text\= (/reflection.reflection /reflection.void) - class_name) - (#try.Success /.void) - <else>)) - - #.None - <else>))) - -(exception: #export (cannot_correspond {class (java/lang/Class java/lang/Object)} - {type Type}) - (exception.report - ["Class" (java/lang/Object::toString class)] - ["Type" (%.type type)])) - -(exception: #export (type_parameter_mismatch {expected Nat} - {actual Nat} - {class (java/lang/Class java/lang/Object)} - {type Type}) - (exception.report - ["Expected" (%.nat expected)] - ["Actual" (%.nat actual)] - ["Class" (java/lang/Object::toString class)] - ["Type" (%.type type)])) - -(exception: #export (non_jvm_type {type Type}) - (exception.report - ["Type" (%.type type)])) - -(def: #export (correspond class type) - (-> (java/lang/Class java/lang/Object) Type (Try Mapping)) - (case type - (#.Primitive name params) - (let [class_name (java/lang/Class::getName class) - class_params (array.to_list (java/lang/Class::getTypeParameters class)) - num_class_params (list.size class_params) - num_type_params (list.size params)] - (if (text\= class_name name) - (if (n.= num_class_params num_type_params) - (|> params - (list.zip/2 (list\map (|>> java/lang/reflect/TypeVariable::getName) - class_params)) - (list\fold (function (_ [name paramT] mapping) - (dictionary.put name paramT mapping)) - /lux.fresh) - #try.Success) - (exception.throw ..type_parameter_mismatch [num_class_params num_type_params class type])) - (exception.throw ..cannot_correspond [class type]))) - - (#.Named name anonymousT) - (correspond class anonymousT) - - (#.Apply inputT abstractionT) - (case (type.apply (list inputT) abstractionT) - (#.Some outputT) - (correspond class outputT) - - #.None - (exception.throw ..non_jvm_type [type])) - - _ - (exception.throw ..non_jvm_type [type]))) - -(exception: #export (mistaken_field_owner {field java/lang/reflect/Field} - {owner (java/lang/Class java/lang/Object)} - {target (java/lang/Class java/lang/Object)}) - (exception.report - ["Field" (java/lang/Object::toString field)] - ["Owner" (java/lang/Object::toString owner)] - ["Target" (java/lang/Object::toString target)])) - -(template [<name>] - [(exception: #export (<name> {field Text} - {class (java/lang/Class java/lang/Object)}) - (exception.report - ["Field" (%.text field)] - ["Class" (java/lang/Object::toString class)]))] - - [unknown_field] - [not_a_static_field] - [not_a_virtual_field] - ) - -(def: #export (field field target) - (-> Text (java/lang/Class java/lang/Object) (Try java/lang/reflect/Field)) - (case (java/lang/Class::getDeclaredField field target) - (#try.Success field) - (let [owner (java/lang/reflect/Field::getDeclaringClass field)] - (if (is? owner target) - (#try.Success field) - (exception.throw ..mistaken_field_owner [field owner target]))) - - (#try.Failure _) - (exception.throw ..unknown_field [field target]))) - -(def: #export deprecated? - (-> (array.Array java/lang/annotation/Annotation) Bit) - (|>> array.to_list - (list.all (|>> (ffi.check java/lang/Deprecated))) - list.empty? - not)) - -(template [<name> <exception> <then?> <else?>] - [(def: #export (<name> field class) - (-> Text (java/lang/Class java/lang/Object) (Try [Bit Bit (/.Type Value)])) - (do {! try.monad} - [fieldJ (..field field class) - #let [modifiers (java/lang/reflect/Field::getModifiers fieldJ)]] - (case (java/lang/reflect/Modifier::isStatic modifiers) - <then?> (|> fieldJ - java/lang/reflect/Field::getGenericType - ..type - (\ ! map (|>> [(java/lang/reflect/Modifier::isFinal modifiers) - (..deprecated? (java/lang/reflect/Field::getDeclaredAnnotations fieldJ))]))) - <else?> (exception.throw <exception> [field class]))))] - - [static_field ..not_a_static_field #1 #0] - [virtual_field ..not_a_virtual_field #0 #1] - ) diff --git a/stdlib/source/lux/target/jvm/type.lux b/stdlib/source/lux/target/jvm/type.lux deleted file mode 100644 index 0e3d9be92..000000000 --- a/stdlib/source/lux/target/jvm/type.lux +++ /dev/null @@ -1,204 +0,0 @@ -(.module: - [lux (#- Type int char) - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)]] - [data - ["." maybe] - ["." text - ["%" format (#+ Format)]] - [collection - ["." list ("#\." functor)]]] - [math - [number - ["n" nat]]] - [type - abstract]] - ["." // #_ - [encoding - ["#." name (#+ External)]]] - ["." / #_ - [category (#+ Void Value' Value Return' Return Method Primitive Object Class Array Var Parameter Declaration)] - ["#." signature (#+ Signature)] - ["#." descriptor (#+ Descriptor)] - ["#." reflection (#+ Reflection)]]) - -(abstract: #export (Type category) - [(Signature category) (Descriptor category) (Reflection category)] - - (type: #export Argument - [Text (Type Value)]) - - (type: #export (Typed a) - [(Type Value) a]) - - (type: #export Constraint - {#name Text - #super_class (Type Class) - #super_interfaces (List (Type Class))}) - - (template [<name> <style>] - [(def: #export (<name> type) - (All [category] (-> (Type category) (<style> category))) - (let [[signature descriptor reflection] (:representation type)] - <name>))] - - [signature Signature] - [descriptor Descriptor] - ) - - (def: #export (reflection type) - (All [category] - (-> (Type (<| Return' Value' category)) - (Reflection (<| Return' Value' category)))) - (let [[signature descriptor reflection] (:representation type)] - reflection)) - - (template [<category> <name> <signature> <descriptor> <reflection>] - [(def: #export <name> - (Type <category>) - (:abstraction [<signature> <descriptor> <reflection>]))] - - [Void void /signature.void /descriptor.void /reflection.void] - [Primitive boolean /signature.boolean /descriptor.boolean /reflection.boolean] - [Primitive byte /signature.byte /descriptor.byte /reflection.byte] - [Primitive short /signature.short /descriptor.short /reflection.short] - [Primitive int /signature.int /descriptor.int /reflection.int] - [Primitive long /signature.long /descriptor.long /reflection.long] - [Primitive float /signature.float /descriptor.float /reflection.float] - [Primitive double /signature.double /descriptor.double /reflection.double] - [Primitive char /signature.char /descriptor.char /reflection.char] - ) - - (def: #export (array type) - (-> (Type Value) (Type Array)) - (:abstraction - [(/signature.array (..signature type)) - (/descriptor.array (..descriptor type)) - (/reflection.array (..reflection type))])) - - (def: #export (class name parameters) - (-> External (List (Type Parameter)) (Type Class)) - (:abstraction - [(/signature.class name (list\map ..signature parameters)) - (/descriptor.class name) - (/reflection.class name)])) - - (def: #export (declaration name variables) - (-> External (List (Type Var)) (Type Declaration)) - (:abstraction - [(/signature.declaration name (list\map ..signature variables)) - (/descriptor.declaration name) - (/reflection.declaration name)])) - - (def: #export (as_class type) - (-> (Type Declaration) (Type Class)) - (:abstraction - (let [[signature descriptor reflection] (:representation type)] - [(/signature.as_class signature) - (/descriptor.as_class descriptor) - (/reflection.as_class reflection)]))) - - (def: #export wildcard - (Type Parameter) - (:abstraction - [/signature.wildcard - /descriptor.wildcard - /reflection.wildcard])) - - (def: #export (var name) - (-> Text (Type Var)) - (:abstraction - [(/signature.var name) - /descriptor.var - /reflection.var])) - - (def: #export (lower bound) - (-> (Type Class) (Type Parameter)) - (:abstraction - (let [[signature descriptor reflection] (:representation bound)] - [(/signature.lower signature) - (/descriptor.lower descriptor) - (/reflection.lower reflection)]))) - - (def: #export (upper bound) - (-> (Type Class) (Type Parameter)) - (:abstraction - (let [[signature descriptor reflection] (:representation bound)] - [(/signature.upper signature) - (/descriptor.upper descriptor) - (/reflection.upper reflection)]))) - - (def: #export (method [inputs output exceptions]) - (-> [(List (Type Value)) - (Type Return) - (List (Type Class))] - (Type Method)) - (:abstraction - [(/signature.method [(list\map ..signature inputs) - (..signature output) - (list\map ..signature exceptions)]) - (/descriptor.method [(list\map ..descriptor inputs) - (..descriptor output)]) - (:assume ..void)])) - - (implementation: #export equivalence - (All [category] (Equivalence (Type category))) - - (def: (= parameter subject) - (\ /signature.equivalence = - (..signature parameter) - (..signature subject)))) - - (implementation: #export hash - (All [category] (Hash (Type category))) - - (def: &equivalence ..equivalence) - (def: hash (|>> ..signature (\ /signature.hash hash)))) - - (def: #export (primitive? type) - (-> (Type Value) (Either (Type Object) - (Type Primitive))) - (if (`` (or (~~ (template [<type>] - [(\ ..equivalence = (: (Type Value) <type>) type)] - - [..boolean] - [..byte] - [..short] - [..int] - [..long] - [..float] - [..double] - [..char])))) - (|> type (:as (Type Primitive)) #.Right) - (|> type (:as (Type Object)) #.Left))) - - (def: #export (void? type) - (-> (Type Return) (Either (Type Value) - (Type Void))) - (if (`` (or (~~ (template [<type>] - [(\ ..equivalence = (: (Type Return) <type>) type)] - - [..void])))) - (|> type (:as (Type Void)) #.Right) - (|> type (:as (Type Value)) #.Left))) - ) - -(def: #export (class? type) - (-> (Type Value) (Maybe External)) - (let [repr (|> type ..descriptor /descriptor.descriptor)] - (if (and (text.starts_with? /descriptor.class_prefix repr) - (text.ends_with? /descriptor.class_suffix repr)) - (let [prefix_size (text.size /descriptor.class_prefix) - suffix_size (text.size /descriptor.class_suffix) - name_size (|> (text.size repr) - (n.- prefix_size) - (n.- suffix_size))] - (|> repr - (text.clip prefix_size name_size) - (\ maybe.monad map (|>> //name.internal //name.external)))) - #.None))) - -(def: #export format - (All [a] (Format (Type a))) - (|>> ..signature /signature.signature)) diff --git a/stdlib/source/lux/target/jvm/type/alias.lux b/stdlib/source/lux/target/jvm/type/alias.lux deleted file mode 100644 index e474250ca..000000000 --- a/stdlib/source/lux/target/jvm/type/alias.lux +++ /dev/null @@ -1,115 +0,0 @@ -(.module: - [lux (#- Type int char type primitive) - [abstract - ["." monad (#+ do)]] - [control - ["." try] - ["." exception (#+ exception:)] - ["<>" parser - ["<t>" text (#+ Parser)]]] - [data - ["." maybe] - ["." text - ["%" format (#+ format)]] - [collection - ["." dictionary (#+ Dictionary)]]]] - ["." // (#+ Type) - [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] - ["#." descriptor] - ["#." signature (#+ Signature)] - ["#." reflection] - ["#." parser] - ["/#" // #_ - [encoding - ["#." name]]]]) - -(type: #export Aliasing - (Dictionary Text Text)) - -(def: #export fresh - Aliasing - (dictionary.new text.hash)) - -(def: (var aliasing) - (-> Aliasing (Parser (Type Var))) - (do <>.monad - [var //parser.var'] - (wrap (|> aliasing - (dictionary.get var) - (maybe.default var) - //.var)))) - -(def: (class parameter) - (-> (Parser (Type Parameter)) (Parser (Type Class))) - (|> (do <>.monad - [name //parser.class_name - parameters (|> (<>.some parameter) - (<>.after (<t>.this //signature.parameters_start)) - (<>.before (<t>.this //signature.parameters_end)) - (<>.default (list)))] - (wrap (//.class name parameters))) - (<>.after (<t>.this //descriptor.class_prefix)) - (<>.before (<t>.this //descriptor.class_suffix)))) - -(template [<name> <prefix> <bound> <constructor>] - [(def: <name> - (-> (Parser (Type Class)) (Parser (Type Parameter))) - (|>> (<>.after (<t>.this <prefix>)) - (\ <>.monad map <bound>)))] - - [lower //signature.lower_prefix //.lower ..Lower] - [upper //signature.upper_prefix //.upper ..Upper] - ) - -(def: (parameter aliasing) - (-> Aliasing (Parser (Type Parameter))) - (<>.rec - (function (_ parameter) - (let [class (..class parameter)] - ($_ <>.either - (..var aliasing) - //parser.wildcard - (..lower class) - (..upper class) - class - ))))) - -(def: (value aliasing) - (-> Aliasing (Parser (Type Value))) - (<>.rec - (function (_ value) - ($_ <>.either - //parser.primitive - (parameter aliasing) - (//parser.array' value) - )))) - -(def: (inputs aliasing) - (-> Aliasing (Parser (List (Type Value)))) - (|> (<>.some (..value aliasing)) - (<>.after (<t>.this //signature.arguments_start)) - (<>.before (<t>.this //signature.arguments_end)))) - -(def: (return aliasing) - (-> Aliasing (Parser (Type Return))) - ($_ <>.either - //parser.void - (..value aliasing) - )) - -(def: (exception aliasing) - (-> Aliasing (Parser (Type Class))) - (|> (..class (..parameter aliasing)) - (<>.after (<t>.this //signature.exception_prefix)))) - -(def: #export (method aliasing type) - (-> Aliasing (Type Method) (Type Method)) - (|> type - //.signature - //signature.signature - (<t>.run (do <>.monad - [inputs (..inputs aliasing) - return (..return aliasing) - exceptions (<>.some (..exception aliasing))] - (wrap (//.method [inputs return exceptions])))) - try.assume)) diff --git a/stdlib/source/lux/target/jvm/type/box.lux b/stdlib/source/lux/target/jvm/type/box.lux deleted file mode 100644 index 65816b487..000000000 --- a/stdlib/source/lux/target/jvm/type/box.lux +++ /dev/null @@ -1,18 +0,0 @@ -(.module: - [lux (#- int char)] - [/// - [encoding - [name (#+ External)]]]) - -(template [<name> <box>] - [(def: #export <name> External <box>)] - - [boolean "java.lang.Boolean"] - [byte "java.lang.Byte"] - [short "java.lang.Short"] - [int "java.lang.Integer"] - [long "java.lang.Long"] - [float "java.lang.Float"] - [double "java.lang.Double"] - [char "java.lang.Character"] - ) diff --git a/stdlib/source/lux/target/jvm/type/category.lux b/stdlib/source/lux/target/jvm/type/category.lux deleted file mode 100644 index 5dfb38ddc..000000000 --- a/stdlib/source/lux/target/jvm/type/category.lux +++ /dev/null @@ -1,35 +0,0 @@ -(.module: - [lux #* - [macro - ["." template]] - [type - abstract]]) - -(abstract: #export Void' Any) -(abstract: #export (Value' kind) Any) -(abstract: #export (Return' kind) Any) -(abstract: #export Method Any) - -(type: #export Return (<| Return' Any)) -(type: #export Value (<| Return' Value' Any)) -(type: #export Void (<| Return' Void')) - -(abstract: #export (Object' brand) Any) -(type: #export Object (<| Return' Value' Object' Any)) - -(abstract: #export (Parameter' brand) Any) -(type: #export Parameter (<| Return' Value' Object' Parameter' Any)) - -(template [<parents> <child>] - [(with_expansions [<raw> (template.identifier [<child> "'"])] - (abstract: #export <raw> Any) - (type: #export <child> - (`` (<| Return' Value' (~~ (template.splice <parents>)) <raw>))))] - - [[] Primitive] - [[Object' Parameter'] Var] - [[Object' Parameter'] Class] - [[Object'] Array] - ) - -(abstract: #export Declaration Any) diff --git a/stdlib/source/lux/target/jvm/type/descriptor.lux b/stdlib/source/lux/target/jvm/type/descriptor.lux deleted file mode 100644 index d8d5ea256..000000000 --- a/stdlib/source/lux/target/jvm/type/descriptor.lux +++ /dev/null @@ -1,122 +0,0 @@ -(.module: - [lux (#- int char) - [abstract - [equivalence (#+ Equivalence)]] - [data - ["." maybe] - ["." text ("#\." equivalence) - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)]]] - [math - [number - ["n" nat]]] - [type - abstract]] - ["." // #_ - [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)] - ["/#" // #_ - [encoding - ["#." name (#+ Internal External)]]]]) - -(abstract: #export (Descriptor category) - Text - - (def: #export descriptor - (-> (Descriptor Any) Text) - (|>> :representation)) - - (template [<sigil> <category> <name>] - [(def: #export <name> - (Descriptor <category>) - (:abstraction <sigil>))] - - ["V" Void void] - ["Z" Primitive boolean] - ["B" Primitive byte] - ["S" Primitive short] - ["I" Primitive int] - ["J" Primitive long] - ["F" Primitive float] - ["D" Primitive double] - ["C" Primitive char] - ) - - (def: #export class_prefix "L") - (def: #export class_suffix ";") - - (def: #export class - (-> External (Descriptor Class)) - (|>> ///name.internal - ///name.read - (text.enclose [..class_prefix ..class_suffix]) - :abstraction)) - - (def: #export (declaration name) - (-> External (Descriptor Declaration)) - (:transmutation (..class name))) - - (def: #export as_class - (-> (Descriptor Declaration) (Descriptor Class)) - (|>> :transmutation)) - - (template [<name> <category>] - [(def: #export <name> - (Descriptor <category>) - (:transmutation - (..class "java.lang.Object")))] - - [var Var] - [wildcard Parameter] - ) - - (def: #export (lower descriptor) - (-> (Descriptor Class) (Descriptor Parameter)) - ..wildcard) - - (def: #export upper - (-> (Descriptor Class) (Descriptor Parameter)) - (|>> :transmutation)) - - (def: #export array_prefix "[") - - (def: #export array - (-> (Descriptor Value) - (Descriptor Array)) - (|>> :representation - (format ..array_prefix) - :abstraction)) - - (def: #export (method [inputs output]) - (-> [(List (Descriptor Value)) - (Descriptor Return)] - (Descriptor Method)) - (:abstraction - (format (|> inputs - (list\map ..descriptor) - (text.join_with "") - (text.enclose ["(" ")"])) - (:representation output)))) - - (implementation: #export equivalence - (All [category] (Equivalence (Descriptor category))) - - (def: (= parameter subject) - (text\= (:representation parameter) (:representation subject)))) - - (def: #export class_name - (-> (Descriptor Object) Internal) - (let [prefix_size (text.size ..class_prefix) - suffix_size (text.size ..class_suffix)] - (function (_ descriptor) - (let [repr (:representation descriptor)] - (if (text.starts_with? ..array_prefix repr) - (///name.internal repr) - (|> repr - (text.clip prefix_size - (|> (text.size repr) - (n.- prefix_size) - (n.- suffix_size))) - (\ maybe.monad map ///name.internal) - maybe.assume)))))) - ) diff --git a/stdlib/source/lux/target/jvm/type/lux.lux b/stdlib/source/lux/target/jvm/type/lux.lux deleted file mode 100644 index e42c54610..000000000 --- a/stdlib/source/lux/target/jvm/type/lux.lux +++ /dev/null @@ -1,188 +0,0 @@ -(.module: - [lux (#- int char type primitive) - [abstract - ["." monad (#+ do)]] - [control - ["." try] - ["." exception (#+ exception:)] - ["<>" parser ("#\." monad) - ["<t>" text (#+ Parser)]]] - [data - ["." product] - ["." text ("#\." equivalence) - ["%" format (#+ format)]] - [collection - ["." array] - ["." dictionary (#+ Dictionary)]]] - [type - abstract - ["." check (#+ Check) ("#\." monad)]]] - ["." // - [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] - ["#." descriptor] - ["#." signature] - ["#." reflection] - ["#." parser] - ["/#" // #_ - [encoding - ["#." name]]]]) - -(template [<name>] - [(abstract: #export (<name> class) Any)] - - [Lower] [Upper] - ) - -(type: #export Mapping - (Dictionary Text Type)) - -(def: #export fresh - Mapping - (dictionary.new text.hash)) - -(exception: #export (unknown_var {var Text}) - (exception.report - ["Var" (%.text var)])) - -(def: void - (Parser (Check Type)) - (<>.after //parser.void - (<>\wrap (check\wrap .Any)))) - -(template [<name> <parser> <reflection>] - [(def: <name> - (Parser (Check Type)) - (<>.after <parser> - (<>\wrap (check\wrap (#.Primitive (//reflection.reflection <reflection>) #.Nil)))))] - - [boolean //parser.boolean //reflection.boolean] - [byte //parser.byte //reflection.byte] - [short //parser.short //reflection.short] - [int //parser.int //reflection.int] - [long //parser.long //reflection.long] - [float //parser.float //reflection.float] - [double //parser.double //reflection.double] - [char //parser.char //reflection.char] - ) - -(def: primitive - (Parser (Check Type)) - ($_ <>.either - ..boolean - ..byte - ..short - ..int - ..long - ..float - ..double - ..char - )) - -(def: wildcard - (Parser (Check Type)) - (<>.after //parser.wildcard - (<>\wrap (check\map product.right - check.existential)))) - -(def: (var mapping) - (-> Mapping (Parser (Check Type))) - (do <>.monad - [var //parser.var'] - (wrap (case (dictionary.get var mapping) - #.None - (check.throw ..unknown_var [var]) - - (#.Some type) - (check\wrap type))))) - -(def: (class' parameter) - (-> (Parser (Check Type)) (Parser (Check Type))) - (|> (do <>.monad - [name //parser.class_name - parameters (|> (<>.some parameter) - (<>.after (<t>.this //signature.parameters_start)) - (<>.before (<t>.this //signature.parameters_end)) - (<>.default (list)))] - (wrap (do {! check.monad} - [parameters (monad.seq ! parameters)] - (wrap (#.Primitive name parameters))))) - (<>.after (<t>.this //descriptor.class_prefix)) - (<>.before (<t>.this //descriptor.class_suffix)))) - -(template [<name> <prefix> <constructor>] - [(def: <name> - (-> (Parser (Check Type)) (Parser (Check Type))) - (|> (<>.after (<t>.this <prefix>)) - ## TODO: Re-enable Lower and Upper, instead of using the simplified limit. - ## (<>\map (check\map (|>> <ctor> .type))) - ))] - - [lower //signature.lower_prefix ..Lower] - [upper //signature.upper_prefix ..Upper] - ) - -(def: (parameter mapping) - (-> Mapping (Parser (Check Type))) - (<>.rec - (function (_ parameter) - (let [class (..class' parameter)] - ($_ <>.either - (..var mapping) - ..wildcard - (..lower class) - (..upper class) - class - ))))) - -(def: #export class - (-> Mapping (Parser (Check Type))) - (|>> ..parameter ..class')) - -(def: array - (-> (Parser (Check Type)) (Parser (Check Type))) - (|>> (<>\map (check\map (function (_ elementT) - (case elementT - (#.Primitive name #.Nil) - (if (`` (or (~~ (template [<reflection>] - [(text\= (//reflection.reflection <reflection>) name)] - - [//reflection.boolean] - [//reflection.byte] - [//reflection.short] - [//reflection.int] - [//reflection.long] - [//reflection.float] - [//reflection.double] - [//reflection.char])))) - (#.Primitive (|> name //reflection.class //reflection.array //reflection.reflection) #.Nil) - (|> elementT array.Array .type)) - - _ - (|> elementT array.Array .type))))) - (<>.after (<t>.this //descriptor.array_prefix)))) - -(def: #export (type mapping) - (-> Mapping (Parser (Check Type))) - (<>.rec - (function (_ type) - ($_ <>.either - ..primitive - (parameter mapping) - (..array type) - )))) - -(def: #export (return mapping) - (-> Mapping (Parser (Check Type))) - ($_ <>.either - ..void - (..type mapping) - )) - -(def: #export (check operation input) - (All [a] (-> (Parser (Check a)) Text (Check a))) - (case (<t>.run operation input) - (#try.Success check) - check - - (#try.Failure error) - (check.fail error))) diff --git a/stdlib/source/lux/target/jvm/type/parser.lux b/stdlib/source/lux/target/jvm/type/parser.lux deleted file mode 100644 index 56e992082..000000000 --- a/stdlib/source/lux/target/jvm/type/parser.lux +++ /dev/null @@ -1,252 +0,0 @@ -(.module: - [lux (#- Type int char primitive) - [abstract - [monad (#+ do)]] - [control - ["." try] - ["." function] - ["<>" parser ("#\." monad) - ["<t>" text (#+ Parser)]]] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list]]]] - ["." // (#+ Type) - [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)] - ["#." signature] - ["#." descriptor] - ["." // #_ - [encoding - ["#." name (#+ External)]]]]) - -(template [<category> <name> <signature> <type>] - [(def: #export <name> - (Parser (Type <category>)) - (<>.after (<t>.this (//signature.signature <signature>)) - (<>\wrap <type>)))] - - [Void void //signature.void //.void] - [Primitive boolean //signature.boolean //.boolean] - [Primitive byte //signature.byte //.byte] - [Primitive short //signature.short //.short] - [Primitive int //signature.int //.int] - [Primitive long //signature.long //.long] - [Primitive float //signature.float //.float] - [Primitive double //signature.double //.double] - [Primitive char //signature.char //.char] - [Parameter wildcard //signature.wildcard //.wildcard] - ) - -(def: #export primitive - (Parser (Type Primitive)) - ($_ <>.either - ..boolean - ..byte - ..short - ..int - ..long - ..float - ..double - ..char - )) - -(def: var/head - (format "abcdefghijklmnopqrstuvwxyz" - "ABCDEFGHIJKLMNOPQRSTUVWXYZ" - "_")) - -(def: var/tail - (format var/head - "0123456789$")) - -(def: class/set - (format var/tail //name.internal_separator)) - -(template [<type> <name> <head> <tail> <adapter>] - [(def: #export <name> - (Parser <type>) - (\ <>.functor map <adapter> - (<t>.slice (<t>.and! (<t>.one_of! <head>) - (<t>.some! (<t>.one_of! <tail>))))))] - - [External class_name class/set class/set (|>> //name.internal //name.external)] - [Text var_name var/head var/tail function.identity] - ) - -(def: #export var' - (Parser Text) - (|> ..var_name - (<>.after (<t>.this //signature.var_prefix)) - (<>.before (<t>.this //descriptor.class_suffix)))) - -(def: #export var - (Parser (Type Var)) - (<>\map //.var ..var')) - -(def: #export var? - (-> (Type Value) (Maybe Text)) - (|>> //.signature - //signature.signature - (<t>.run ..var') - try.to_maybe)) - -(def: #export name - (-> (Type Var) Text) - (|>> //.signature - //signature.signature - (<t>.run ..var') - try.assume)) - -(template [<name> <prefix> <constructor>] - [(def: <name> - (-> (Parser (Type Class)) (Parser (Type Parameter))) - (|>> (<>.after (<t>.this <prefix>)) - (<>\map <constructor>)))] - - [lower //signature.lower_prefix //.lower] - [upper //signature.upper_prefix //.upper] - ) - -(def: (class'' parameter) - (-> (Parser (Type Parameter)) (Parser [External (List (Type Parameter))])) - (|> (do <>.monad - [name ..class_name - parameters (|> (<>.some parameter) - (<>.after (<t>.this //signature.parameters_start)) - (<>.before (<t>.this //signature.parameters_end)) - (<>.default (list)))] - (wrap [name parameters])) - (<>.after (<t>.this //descriptor.class_prefix)) - (<>.before (<t>.this //descriptor.class_suffix)))) - -(def: class' - (-> (Parser (Type Parameter)) (Parser (Type Class))) - (|>> ..class'' - (\ <>.monad map (product.uncurry //.class)))) - -(def: #export parameter - (Parser (Type Parameter)) - (<>.rec - (function (_ parameter) - (let [class (..class' parameter)] - ($_ <>.either - ..var - ..wildcard - (..lower class) - (..upper class) - class - ))))) - -(def: #export array' - (-> (Parser (Type Value)) (Parser (Type Array))) - (|>> (<>.after (<t>.this //descriptor.array_prefix)) - (<>\map //.array))) - -(def: #export class - (Parser (Type Class)) - (..class' ..parameter)) - -(template [<name> <prefix> <constructor>] - [(def: #export <name> - (-> (Type Value) (Maybe (Type Class))) - (|>> //.signature - //signature.signature - (<t>.run (<>.after (<t>.this <prefix>) ..class)) - try.to_maybe))] - - [lower? //signature.lower_prefix //.lower] - [upper? //signature.upper_prefix //.upper] - ) - -(def: #export read_class - (-> (Type Class) [External (List (Type Parameter))]) - (|>> //.signature - //signature.signature - (<t>.run (..class'' ..parameter)) - try.assume)) - -(def: #export value - (Parser (Type Value)) - (<>.rec - (function (_ value) - ($_ <>.either - ..primitive - ..parameter - (..array' value) - )))) - -(def: #export array - (Parser (Type Array)) - (..array' ..value)) - -(def: #export object - (Parser (Type Object)) - ($_ <>.either - ..class - ..array)) - -(def: inputs - (|> (<>.some ..value) - (<>.after (<t>.this //signature.arguments_start)) - (<>.before (<t>.this //signature.arguments_end)))) - -(def: #export return - (Parser (Type Return)) - (<>.either ..void - ..value)) - -(def: exception - (Parser (Type Class)) - (|> (..class' ..parameter) - (<>.after (<t>.this //signature.exception_prefix)))) - -(def: #export method - (-> (Type Method) - [(List (Type Value)) (Type Return) (List (Type Class))]) - (let [parser (do <>.monad - [inputs ..inputs - return ..return - exceptions (<>.some ..exception)] - (wrap [inputs return exceptions]))] - (|>> //.signature - //signature.signature - (<t>.run parser) - try.assume))) - -(template [<name> <category> <parser>] - [(def: #export <name> - (-> (Type Value) (Maybe <category>)) - (|>> //.signature - //signature.signature - (<t>.run <parser>) - try.to_maybe))] - - [array? (Type Value) - (do <>.monad - [_ (<t>.this //descriptor.array_prefix)] - ..value)] - [class? [External (List (Type Parameter))] - (..class'' ..parameter)] - - [primitive? (Type Primitive) ..primitive] - [wildcard? (Type Parameter) ..wildcard] - [parameter? (Type Parameter) ..parameter] - [object? (Type Object) ..object] - ) - -(def: #export declaration - (-> (Type Declaration) [External (List (Type Var))]) - (let [declaration' (: (Parser [External (List (Type Var))]) - (|> (<>.and ..class_name - (|> (<>.some ..var) - (<>.after (<t>.this //signature.parameters_start)) - (<>.before (<t>.this //signature.parameters_end)) - (<>.default (list)))) - (<>.after (<t>.this //descriptor.class_prefix)) - (<>.before (<t>.this //descriptor.class_suffix))))] - (|>> //.signature - //signature.signature - (<t>.run declaration') - try.assume))) diff --git a/stdlib/source/lux/target/jvm/type/reflection.lux b/stdlib/source/lux/target/jvm/type/reflection.lux deleted file mode 100644 index 7d775b1f9..000000000 --- a/stdlib/source/lux/target/jvm/type/reflection.lux +++ /dev/null @@ -1,103 +0,0 @@ -(.module: - [lux (#- int char) - [abstract - [equivalence (#+ Equivalence)]] - [data - ["." text ("#\." equivalence) - ["%" format (#+ format)]]] - [type - abstract]] - ["." // #_ - [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)] - ["#." descriptor] - [// - [encoding - ["#." name (#+ External)]]]]) - -(abstract: #export (Reflection category) - Text - - (def: #export reflection - (-> (Reflection Any) Text) - (|>> :representation)) - - (implementation: #export equivalence - (All [category] (Equivalence (Reflection category))) - - (def: (= parameter subject) - (text\= (:representation parameter) (:representation subject)))) - - (template [<category> <name> <reflection>] - [(def: #export <name> - (Reflection <category>) - (:abstraction <reflection>))] - - [Void void "void"] - [Primitive boolean "boolean"] - [Primitive byte "byte"] - [Primitive short "short"] - [Primitive int "int"] - [Primitive long "long"] - [Primitive float "float"] - [Primitive double "double"] - [Primitive char "char"] - ) - - (def: #export class - (-> External (Reflection Class)) - (|>> :abstraction)) - - (def: #export (declaration name) - (-> External (Reflection Declaration)) - (:transmutation (..class name))) - - (def: #export as_class - (-> (Reflection Declaration) (Reflection Class)) - (|>> :transmutation)) - - (def: #export (array element) - (-> (Reflection Value) (Reflection Array)) - (let [element' (:representation element) - elementR (`` (cond (text.starts_with? //descriptor.array_prefix element') - element' - - (~~ (template [<primitive> <descriptor>] - [(\ ..equivalence = <primitive> element) - (//descriptor.descriptor <descriptor>)] - - [..boolean //descriptor.boolean] - [..byte //descriptor.byte] - [..short //descriptor.short] - [..int //descriptor.int] - [..long //descriptor.long] - [..float //descriptor.float] - [..double //descriptor.double] - [..char //descriptor.char])) - - (|> element' - //descriptor.class - //descriptor.descriptor - (text.replace_all //name.internal_separator - //name.external_separator))))] - (|> elementR - (format //descriptor.array_prefix) - :abstraction))) - - (template [<name> <category>] - [(def: #export <name> - (Reflection <category>) - (:transmutation - (..class "java.lang.Object")))] - - [var Var] - [wildcard Parameter] - ) - - (def: #export (lower reflection) - (-> (Reflection Class) (Reflection Parameter)) - ..wildcard) - - (def: #export upper - (-> (Reflection Class) (Reflection Parameter)) - (|>> :transmutation)) - ) diff --git a/stdlib/source/lux/target/jvm/type/signature.lux b/stdlib/source/lux/target/jvm/type/signature.lux deleted file mode 100644 index ab207bc39..000000000 --- a/stdlib/source/lux/target/jvm/type/signature.lux +++ /dev/null @@ -1,133 +0,0 @@ -(.module: - [lux (#- int char) - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)]] - [data - ["." text ("#\." hash) - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)]]] - [type - abstract]] - ["." // #_ - [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)] - ["#." descriptor] - ["/#" // #_ - [encoding - ["#." name (#+ External)]]]]) - -(abstract: #export (Signature category) - Text - - (def: #export signature - (-> (Signature Any) Text) - (|>> :representation)) - - (template [<category> <name> <descriptor>] - [(def: #export <name> - (Signature <category>) - (:abstraction (//descriptor.descriptor <descriptor>)))] - - [Void void //descriptor.void] - [Primitive boolean //descriptor.boolean] - [Primitive byte //descriptor.byte] - [Primitive short //descriptor.short] - [Primitive int //descriptor.int] - [Primitive long //descriptor.long] - [Primitive float //descriptor.float] - [Primitive double //descriptor.double] - [Primitive char //descriptor.char] - ) - - (def: #export array - (-> (Signature Value) (Signature Array)) - (|>> :representation - (format //descriptor.array_prefix) - :abstraction)) - - (def: #export wildcard - (Signature Parameter) - (:abstraction "*")) - - (def: #export var_prefix "T") - - (def: #export var - (-> Text (Signature Var)) - (|>> (text.enclose [..var_prefix //descriptor.class_suffix]) - :abstraction)) - - (def: #export lower_prefix "-") - (def: #export upper_prefix "+") - - (template [<name> <prefix>] - [(def: #export <name> - (-> (Signature Class) (Signature Parameter)) - (|>> :representation (format <prefix>) :abstraction))] - - [lower ..lower_prefix] - [upper ..upper_prefix] - ) - - (def: #export parameters_start "<") - (def: #export parameters_end ">") - - (def: #export (class name parameters) - (-> External (List (Signature Parameter)) (Signature Class)) - (:abstraction - (format //descriptor.class_prefix - (|> name ///name.internal ///name.read) - (case parameters - #.Nil - "" - - _ - (format ..parameters_start - (|> parameters - (list\map ..signature) - (text.join_with "")) - ..parameters_end)) - //descriptor.class_suffix))) - - (def: #export (declaration name variables) - (-> External (List (Signature Var)) (Signature Declaration)) - (:transmutation (..class name variables))) - - (def: #export as_class - (-> (Signature Declaration) (Signature Class)) - (|>> :transmutation)) - - (def: #export arguments_start "(") - (def: #export arguments_end ")") - - (def: #export exception_prefix "^") - - (def: #export (method [inputs output exceptions]) - (-> [(List (Signature Value)) - (Signature Return) - (List (Signature Class))] - (Signature Method)) - (:abstraction - (format (|> inputs - (list\map ..signature) - (text.join_with "") - (text.enclose [..arguments_start - ..arguments_end])) - (:representation output) - (|> exceptions - (list\map (|>> :representation (format ..exception_prefix))) - (text.join_with ""))))) - - (implementation: #export equivalence - (All [category] (Equivalence (Signature category))) - - (def: (= parameter subject) - (text\= (:representation parameter) - (:representation subject)))) - - (implementation: #export hash - (All [category] (Hash (Signature category))) - - (def: &equivalence ..equivalence) - (def: hash (|>> :representation text\hash))) - ) diff --git a/stdlib/source/lux/target/jvm/version.lux b/stdlib/source/lux/target/jvm/version.lux deleted file mode 100644 index 66f97351d..000000000 --- a/stdlib/source/lux/target/jvm/version.lux +++ /dev/null @@ -1,37 +0,0 @@ -(.module: - [lux #* - [control - ["." try]]] - ["." // #_ - [encoding - ["#." unsigned (#+ U2)]]]) - -(type: #export Version U2) -(type: #export Minor Version) -(type: #export Major Version) - -(def: #export default_minor - Minor - (|> 0 //unsigned.u2 try.assume)) - -(template [<number> <name>] - [(def: #export <name> - Major - (|> <number> //unsigned.u2 try.assume))] - - [45 v1_1] - [46 v1_2] - [47 v1_3] - [48 v1_4] - [49 v5_0] - [50 v6_0] - [51 v7] - [52 v8] - [53 v9] - [54 v10] - [55 v11] - [56 v12] - ) - -(def: #export writer - //unsigned.writer/2) diff --git a/stdlib/source/lux/target/lua.lux b/stdlib/source/lux/target/lua.lux deleted file mode 100644 index fe675da0f..000000000 --- a/stdlib/source/lux/target/lua.lux +++ /dev/null @@ -1,415 +0,0 @@ -(.module: - [lux (#- Location Code int if cond function or and not let ^) - ["@" target] - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)] - ["." enum]] - [control - [pipe (#+ case> cond> new>)] - [parser - ["<.>" code]]] - [data - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [macro - [syntax (#+ syntax:)] - ["." template] - ["." code]] - [math - [number - ["n" nat] - ["i" int] - ["f" frac]]] - [type - abstract]]) - -(def: nest - (-> Text Text) - (.let [nested_new_line (format text.new_line text.tab)] - (|>> (format text.new_line) - (text.replace_all text.new_line nested_new_line)))) - -(def: input_separator ", ") - -(abstract: #export (Code brand) - Text - - (implementation: #export equivalence - (All [brand] (Equivalence (Code brand))) - - (def: (= reference subject) - (\ text.equivalence = (:representation reference) (:representation subject)))) - - (implementation: #export hash - (All [brand] (Hash (Code brand))) - - (def: &equivalence ..equivalence) - (def: hash (|>> :representation (\ text.hash hash)))) - - (def: #export manual - (-> Text Code) - (|>> :abstraction)) - - (def: #export code - (-> (Code Any) Text) - (|>> :representation)) - - (template [<type> <super>+] - [(with_expansions [<brand> (template.identifier [<type> "'"])] - (abstract: (<brand> brand) Any) - (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+))))))] - - [Expression [Code]] - [Computation [Expression' Code]] - [Location [Computation' Expression' Code]] - [Statement [Code]] - ) - - (template [<type> <super>+] - [(with_expansions [<brand> (template.identifier [<type> "'"])] - (abstract: #export <brand> Any) - (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+))))))] - - [Literal [Computation' Expression' Code]] - [Var [Location' Computation' Expression' Code]] - [Access [Location' Computation' Expression' Code]] - [Label [Code]] - ) - - (def: #export nil - Literal - (:abstraction "nil")) - - (def: #export bool - (-> Bit Literal) - (|>> (case> #0 "false" - #1 "true") - :abstraction)) - - (def: #export int - (-> Int Literal) - ## Integers must be turned into hexadecimal to avoid quirks in how Lua parses integers. - ## In particular, the number -9223372036854775808 will be incorrectly parsed as a float by Lua. - (.let [to_hex (\ n.hex encode)] - (|>> .nat - to_hex - (format "0x") - :abstraction))) - - (def: #export float - (-> Frac Literal) - (|>> (cond> [(f.= f.positive_infinity)] - [(new> "(1.0/0.0)" [])] - - [(f.= f.negative_infinity)] - [(new> "(-1.0/0.0)" [])] - - [(f.= f.not_a_number)] - [(new> "(0.0/0.0)" [])] - - ## else - [%.frac (text.replace_all "+" "")]) - :abstraction)) - - (def: sanitize - (-> Text Text) - (`` (|>> (~~ (template [<find> <replace>] - [(text.replace_all <find> <replace>)] - - ["\" "\\"] - [text.tab "\t"] - [text.vertical_tab "\v"] - [text.null "\0"] - [text.back_space "\b"] - [text.form_feed "\f"] - [text.new_line "\n"] - [text.carriage_return "\r"] - [text.double_quote (format "\" text.double_quote)] - )) - ))) - - (def: #export string - (-> Text Literal) - (|>> ..sanitize (text.enclose' text.double_quote) :abstraction)) - - (def: #export multi - (-> (List Expression) Literal) - (|>> (list\map ..code) - (text.join_with ..input_separator) - :abstraction)) - - (def: #export array - (-> (List Expression) Literal) - (|>> (list\map ..code) - (text.join_with ..input_separator) - (text.enclose ["{" "}"]) - :abstraction)) - - (def: #export table - (-> (List [Text Expression]) Literal) - (|>> (list\map (.function (_ [key value]) - (format key " = " (:representation value)))) - (text.join_with ..input_separator) - (text.enclose ["{" "}"]) - :abstraction)) - - (def: #export (nth idx array) - (-> Expression Expression Access) - (:abstraction (format (:representation array) "[" (:representation idx) "]"))) - - (def: #export (the field table) - (-> Text Expression Computation) - (:abstraction (format (:representation table) "." field))) - - (def: #export length - (-> Expression Computation) - (|>> :representation - (text.enclose ["#(" ")"]) - :abstraction)) - - (def: #export (apply/* args func) - (-> (List Expression) Expression Computation) - (|> args - (list\map ..code) - (text.join_with ..input_separator) - (text.enclose ["(" ")"]) - (format (:representation func)) - :abstraction)) - - (def: #export (do method args table) - (-> Text (List Expression) Expression Computation) - (|> args - (list\map ..code) - (text.join_with ..input_separator) - (text.enclose ["(" ")"]) - (format (:representation table) ":" method) - :abstraction)) - - (template [<op> <name>] - [(def: #export (<name> parameter subject) - (-> Expression Expression Expression) - (:abstraction (format "(" - (:representation subject) - " " <op> " " - (:representation parameter) - ")")))] - - ["==" =] - ["<" <] - ["<=" <=] - [">" >] - [">=" >=] - ["+" +] - ["-" -] - ["*" *] - ["^" ^] - ["/" /] - ["//" //] - ["%" %] - [".." concat] - - ["or" or] - ["and" and] - ["|" bit_or] - ["&" bit_and] - ["~" bit_xor] - - ["<<" bit_shl] - [">>" bit_shr] - ) - - (template [<name> <unary>] - [(def: #export (<name> subject) - (-> Expression Expression) - (:abstraction (format "(" <unary> " " (:representation subject) ")")))] - - [not "not"] - [negate "-"] - ) - - (template [<name> <type>] - [(def: #export <name> - (-> Text <type>) - (|>> :abstraction))] - - [var Var] - [label Label] - ) - - (def: #export statement - (-> Expression Statement) - (|>> :representation :abstraction)) - - (def: #export (then pre! post!) - (-> Statement Statement Statement) - (:abstraction - (format (:representation pre!) - text.new_line - (:representation post!)))) - - (def: locations - (-> (List Location) Text) - (|>> (list\map ..code) - (text.join_with ..input_separator))) - - (def: #export (local vars) - (-> (List Var) Statement) - (:abstraction (format "local " (..locations vars)))) - - (def: #export (set vars value) - (-> (List Location) Expression Statement) - (:abstraction (format (..locations vars) " = " (:representation value)))) - - (def: #export (let vars value) - (-> (List Var) Expression Statement) - (:abstraction (format "local " (..locations vars) " = " (:representation value)))) - - (def: #export (local/1 var value) - (-> Var Expression Statement) - (:abstraction (format "local " (:representation var) " = " (:representation value)))) - - (def: #export (if test then! else!) - (-> Expression Statement Statement Statement) - (:abstraction (format "if " (:representation test) - text.new_line "then" (..nest (:representation then!)) - text.new_line "else" (..nest (:representation else!)) - text.new_line "end"))) - - (def: #export (when test then!) - (-> Expression Statement Statement) - (:abstraction (format "if " (:representation test) - text.new_line "then" (..nest (:representation then!)) - text.new_line "end"))) - - (def: #export (while test body!) - (-> Expression Statement Statement) - (:abstraction - (format "while " (:representation test) " do" - (..nest (:representation body!)) - text.new_line "end"))) - - (def: #export (repeat until body!) - (-> Expression Statement Statement) - (:abstraction - (format "repeat" - (..nest (:representation body!)) - text.new_line "until " (:representation until)))) - - (def: #export (for_in vars source body!) - (-> (List Var) Expression Statement Statement) - (:abstraction - (format "for " (|> vars - (list\map ..code) - (text.join_with ..input_separator)) - " in " (:representation source) " do" - (..nest (:representation body!)) - text.new_line "end"))) - - (def: #export (for_step var from to step body!) - (-> Var Expression Expression Expression Statement - Statement) - (:abstraction - (format "for " (:representation var) - " = " (:representation from) - ..input_separator (:representation to) - ..input_separator (:representation step) " do" - (..nest (:representation body!)) - text.new_line "end"))) - - (def: #export (return value) - (-> Expression Statement) - (:abstraction (format "return " (:representation value)))) - - (def: #export (closure args body!) - (-> (List Var) Statement Expression) - (|> (format "function " (|> args - ..locations - (text.enclose ["(" ")"])) - (..nest (:representation body!)) - text.new_line "end") - (text.enclose ["(" ")"]) - :abstraction)) - - (template [<name> <code>] - [(def: #export (<name> name args body!) - (-> Var (List Var) Statement Statement) - (:abstraction - (format <code> " " (:representation name) - (|> args - ..locations - (text.enclose ["(" ")"])) - (..nest (:representation body!)) - text.new_line "end")))] - - [function "function"] - [local_function "local function"] - ) - - (def: #export break - Statement - (:abstraction "break")) - - (def: #export (set_label label) - (-> Label Statement) - (:abstraction (format "::" (:representation label) "::"))) - - (def: #export (go_to label) - (-> Label Statement) - (:abstraction (format "goto " (:representation label)))) - ) - -(def: #export (cond clauses else!) - (-> (List [Expression Statement]) Statement Statement) - (list\fold (.function (_ [test then!] next!) - (..if test then! next!)) - else! - (list.reverse clauses))) - -(syntax: (arity_inputs {arity <code>.nat}) - (wrap (case arity - 0 (.list) - _ (|> (dec arity) - (enum.range n.enum 0) - (list\map (|>> %.nat code.local_identifier)))))) - -(syntax: (arity_types {arity <code>.nat}) - (wrap (list.repeat arity (` ..Expression)))) - -(template [<arity> <function>+] - [(with_expansions [<apply> (template.identifier ["apply/" <arity>]) - <inputs> (arity_inputs <arity>) - <types> (arity_types <arity>) - <definitions> (template.splice <function>+)] - (def: #export (<apply> function <inputs>) - (-> Expression <types> Computation) - (..apply/* (.list <inputs>) function)) - - (template [<function>] - [(`` (def: #export (~~ (template.identifier [<function> "/" <arity>])) - (<apply> (..var <function>))))] - - <definitions>))] - - [1 - [["error"] - ["print"] - ["require"] - ["type"] - ["ipairs"]]] - - [2 - [["print"] - ["error"]]] - - [3 - [["print"]]] - - [4 - []] - - [5 - []] - ) diff --git a/stdlib/source/lux/target/php.lux b/stdlib/source/lux/target/php.lux deleted file mode 100644 index f85bf5f03..000000000 --- a/stdlib/source/lux/target/php.lux +++ /dev/null @@ -1,544 +0,0 @@ -(.module: - [lux (#- Location Code Global static int if cond or and not comment for try) - ["@" target] - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)] - ["." enum]] - [control - [pipe (#+ case> cond> new>)] - [parser - ["<.>" code]]] - [data - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [macro - [syntax (#+ syntax:)] - ["." template] - ["." code]] - [math - [number - ["n" nat] - ["f" frac]]] - [type - abstract]]) - -(def: input_separator ", ") -(def: statement_suffix ";") - -(def: nest - (-> Text Text) - (.let [nested_new_line (format text.new_line text.tab)] - (|>> (format text.new_line) - (text.replace_all text.new_line nested_new_line)))) - -(def: block - (-> Text Text) - (|>> ..nest (text.enclose ["{" (format text.new_line "}")]))) - -(def: group - (-> Text Text) - (text.enclose ["(" ")"])) - -(abstract: #export (Code brand) - Text - - (implementation: #export equivalence - (All [brand] (Equivalence (Code brand))) - - (def: (= reference subject) - (\ text.equivalence = (:representation reference) (:representation subject)))) - - (implementation: #export hash - (All [brand] (Hash (Code brand))) - - (def: &equivalence ..equivalence) - (def: hash (|>> :representation (\ text.hash hash)))) - - (def: #export manual - (-> Text Code) - (|>> :abstraction)) - - (def: #export code - (-> (Code Any) Text) - (|>> :representation)) - - (template [<type> <super>+] - [(with_expansions [<brand> (template.identifier [<type> "'"])] - (abstract: (<brand> brand) Any) - (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+))))))] - - [Expression [Code]] - [Computation [Expression' Code]] - [Location [Computation' Expression' Code]] - [Statement [Code]] - ) - - (template [<type> <super>+] - [(with_expansions [<brand> (template.identifier [<type> "'"])] - (abstract: #export <brand> Any) - (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+))))))] - - [Literal [Computation' Expression' Code]] - [Var [Location' Computation' Expression' Code]] - [Access [Location' Computation' Expression' Code]] - [Constant [Location' Computation' Expression' Code]] - [Global [Location' Computation' Expression' Code]] - [Label [Code]] - ) - - (type: #export Argument - {#reference? Bit - #var Var}) - - (def: #export ; - (-> Expression Statement) - (|>> :representation - (text.suffix ..statement_suffix) - :abstraction)) - - (def: #export var - (-> Text Var) - (|>> (format "$") :abstraction)) - - (template [<name> <type>] - [(def: #export <name> - (-> Text <type>) - (|>> :abstraction))] - - [constant Constant] - [label Label] - ) - - (def: #export (set_label label) - (-> Label Statement) - (:abstraction (format (:representation label) ":"))) - - (def: #export (go_to label) - (-> Label Statement) - (:abstraction - (format "goto " (:representation label) ..statement_suffix))) - - (def: #export null - Literal - (:abstraction "NULL")) - - (def: #export bool - (-> Bit Literal) - (|>> (case> #0 "false" - #1 "true") - :abstraction)) - - (def: #export int - (-> Int Literal) - (.let [to_hex (\ n.hex encode)] - (|>> .nat - to_hex - (format "0x") - :abstraction))) - - (def: #export float - (-> Frac Literal) - (|>> (cond> [(f.= f.positive_infinity)] - [(new> "+INF" [])] - - [(f.= f.negative_infinity)] - [(new> "-INF" [])] - - [(f.= f.not_a_number)] - [(new> "NAN" [])] - - ## else - [%.frac]) - :abstraction)) - - (def: sanitize - (-> Text Text) - (`` (|>> (~~ (template [<find> <replace>] - [(text.replace_all <find> <replace>)] - - ["\" "\\"] - [text.tab "\t"] - [text.vertical_tab "\v"] - [text.null "\0"] - [text.back_space "\b"] - [text.form_feed "\f"] - [text.new_line "\n"] - [text.carriage_return "\r"] - [text.double_quote (format "\" text.double_quote)] - ["$" "\$"] - )) - ))) - - (def: #export string - (-> Text Literal) - (|>> ..sanitize - (text.enclose [text.double_quote text.double_quote]) - :abstraction)) - - (def: arguments - (-> (List Expression) Text) - (|>> (list\map ..code) (text.join_with ..input_separator) ..group)) - - (def: #export (apply/* args func) - (-> (List Expression) Expression Computation) - (|> (format (:representation func) (..arguments args)) - :abstraction)) - - ## TODO: Remove when no longer using JPHP. - (def: #export (apply/*' args func) - (-> (List Expression) Expression Computation) - (apply/* (list& func args) (..constant "call_user_func"))) - - (def: parameters - (-> (List Argument) Text) - (|>> (list\map (function (_ [reference? var]) - (.if reference? - (format "&" (:representation var)) - (:representation var)))) - (text.join_with ..input_separator) - ..group)) - - (template [<name> <reference?>] - [(def: #export <name> - (-> Var Argument) - (|>> [<reference?>]))] - - [parameter #0] - [reference #1] - ) - - (def: #export (closure uses arguments body!) - (-> (List Argument) (List Argument) Statement Literal) - (let [uses (case uses - #.Nil - "" - - _ - (format "use " (..parameters uses)))] - (|> (format "function " (..parameters arguments) - " " uses " " - (..block (:representation body!))) - ..group - :abstraction))) - - (syntax: (arity_inputs {arity <code>.nat}) - (wrap (case arity - 0 (.list) - _ (|> (dec arity) - (enum.range n.enum 0) - (list\map (|>> %.nat code.local_identifier)))))) - - (syntax: (arity_types {arity <code>.nat}) - (wrap (list.repeat arity (` ..Expression)))) - - (template [<arity> <function>+] - [(with_expansions [<apply> (template.identifier ["apply/" <arity>]) - <inputs> (arity_inputs <arity>) - <types> (arity_types <arity>) - <definitions> (template.splice <function>+)] - (def: #export (<apply> function [<inputs>]) - (-> Expression [<types>] Computation) - (..apply/* (.list <inputs>) function)) - - (template [<function>] - [(`` (def: #export (~~ (template.identifier [<function> "/" <arity>])) - (<apply> (..constant <function>))))] - - <definitions>))] - - [0 - [["func_num_args"] - ["func_get_args"] - ["time"] - ["phpversion"]]] - - [1 - [["isset"] - ["var_dump"] - ["is_null"] - ["empty"] - ["count"] - ["array_pop"] - ["array_reverse"] - ["intval"] - ["floatval"] - ["strval"] - ["ord"] - ["chr"] - ["print"] - ["exit"] - ["iconv_strlen"] ["strlen"] - ["log"] - ["ceil"] - ["floor"] - ["is_nan"]]] - - [2 - [["intdiv"] - ["fmod"] - ["number_format"] - ["array_key_exists"] - ["call_user_func_array"] - ["array_slice"] - ["array_push"] - ["pack"] - ["unpack"] - ["iconv_strpos"] ["strpos"] - ["pow"] - ["max"]]] - - [3 - [["array_fill"] - ["array_slice"] - ["array_splice"] - ["iconv"] - ["iconv_strpos"] ["strpos"] - ["iconv_substr"] ["substr"]]] - ) - - (def: #export (key_value key value) - (-> Expression Expression Expression) - (:abstraction (format (:representation key) " => " (:representation value)))) - - (def: #export (array/* values) - (-> (List Expression) Literal) - (|> values - (list\map ..code) - (text.join_with ..input_separator) - ..group - (format "array") - :abstraction)) - - (def: #export (array_merge/+ required optionals) - (-> Expression (List Expression) Computation) - (..apply/* (list& required optionals) (..constant "array_merge"))) - - (def: #export (array/** kvs) - (-> (List [Expression Expression]) Literal) - (|> kvs - (list\map (function (_ [key value]) - (format (:representation key) " => " (:representation value)))) - (text.join_with ..input_separator) - ..group - (format "array") - :abstraction)) - - (def: #export (new constructor inputs) - (-> Constant (List Expression) Computation) - (|> (format "new " (:representation constructor) (arguments inputs)) - :abstraction)) - - (def: #export (the field object) - (-> Text Expression Computation) - (|> (format (:representation object) "->" field) - :abstraction)) - - (def: #export (do method inputs object) - (-> Text (List Expression) Expression Computation) - (|> (format (:representation (..the method object)) - (..arguments inputs)) - :abstraction)) - - (def: #export (nth idx array) - (-> Expression Expression Access) - (|> (format (:representation array) "[" (:representation idx) "]") - :abstraction)) - - (def: #export (global name) - (-> Text Global) - (|> (..var "GLOBALS") (..nth (..string name)) :transmutation)) - - (def: #export (? test then else) - (-> Expression Expression Expression Computation) - (|> (format (..group (:representation test)) " ? " - (..group (:representation then)) " : " - (..group (:representation else))) - ..group - :abstraction)) - - (template [<name> <op>] - [(def: #export (<name> parameter subject) - (-> Expression Expression Computation) - (|> (format (:representation subject) " " <op> " " (:representation parameter)) - ..group - :abstraction))] - - [or "||"] - [and "&&"] - [== "=="] - [=== "==="] - [< "<"] - [<= "<="] - [> ">"] - [>= ">="] - [+ "+"] - [- "-"] - [* "*"] - [/ "/"] - [% "%"] - [bit_or "|"] - [bit_and "&"] - [bit_xor "^"] - [bit_shl "<<"] - [bit_shr ">>"] - [concat "."] - ) - - (template [<unary> <name>] - [(def: #export <name> - (-> Computation Computation) - (|>> :representation (format <unary>) :abstraction))] - - ["!" not] - ["~" bit_not] - ["-" negate] - ) - - (def: #export (set var value) - (-> Location Expression Computation) - (|> (format (:representation var) " = " (:representation value)) - ..group - :abstraction)) - - (def: #export (set! var value) - (-> Location Expression Statement) - (:abstraction (format (:representation var) " = " (:representation value) ";"))) - - (def: #export (set? var) - (-> Var Computation) - (..apply/1 [var] (..constant "isset"))) - - (template [<name> <modifier>] - [(def: #export <name> - (-> Var Statement) - (|>> :representation (format <modifier> " ") (text.suffix ..statement_suffix) :abstraction))] - - [define_global "global"] - ) - - (template [<name> <modifier> <location>] - [(def: #export (<name> location value) - (-> <location> Expression Statement) - (:abstraction (format <modifier> " " (:representation location) - " = " (:representation value) - ..statement_suffix)))] - - [define_static "static" Var] - [define_constant "const" Constant] - ) - - (def: #export (if test then! else!) - (-> Expression Statement Statement Statement) - (:abstraction - (format "if" (..group (:representation test)) " " - (..block (:representation then!)) - " else " - (..block (:representation else!))))) - - (def: #export (when test then!) - (-> Expression Statement Statement) - (:abstraction - (format "if" (..group (:representation test)) " " - (..block (:representation then!))))) - - (def: #export (then pre! post!) - (-> Statement Statement Statement) - (:abstraction - (format (:representation pre!) - text.new_line - (:representation post!)))) - - (def: #export (while test body!) - (-> Expression Statement Statement) - (:abstraction - (format "while" (..group (:representation test)) " " - (..block (:representation body!))))) - - (def: #export (do_while test body!) - (-> Expression Statement Statement) - (:abstraction - (format "do " (..block (:representation body!)) - " while" (..group (:representation test)) - ..statement_suffix))) - - (def: #export (for_each array value body!) - (-> Expression Var Statement Statement) - (:abstraction - (format "foreach(" (:representation array) - " as " (:representation value) - ") " (..block (:representation body!))))) - - (type: #export Except - {#class Constant - #exception Var - #handler Statement}) - - (def: (catch except) - (-> Except Text) - (let [declaration (format (:representation (get@ #class except)) - " " (:representation (get@ #exception except)))] - (format "catch" (..group declaration) " " - (..block (:representation (get@ #handler except)))))) - - (def: #export (try body! excepts) - (-> Statement (List Except) Statement) - (:abstraction - (format "try " (..block (:representation body!)) - text.new_line - (|> excepts - (list\map catch) - (text.join_with text.new_line))))) - - (template [<name> <keyword>] - [(def: #export <name> - (-> Expression Statement) - (|>> :representation (format <keyword> " ") (text.suffix ..statement_suffix) :abstraction))] - - [throw "throw"] - [return "return"] - [echo "echo"] - ) - - (def: #export (define name value) - (-> Constant Expression Expression) - (..apply/2 (..constant "define") - [(|> name :representation ..string) - value])) - - (def: #export (define_function name arguments body!) - (-> Constant (List Argument) Statement Statement) - (:abstraction - (format "function " (:representation name) - (..parameters arguments) - " " - (..block (:representation body!))))) - - (template [<name> <keyword>] - [(def: #export <name> - Statement - (|> <keyword> - (text.suffix ..statement_suffix) - :abstraction))] - - [break "break"] - [continue "continue"] - ) - - (def: #export splat - (-> Expression Expression) - (|>> :representation (format "...") :abstraction)) - ) - -(def: #export (cond clauses else!) - (-> (List [Expression Statement]) Statement Statement) - (list\fold (function (_ [test then!] next!) - (..if test then! next!)) - else! - (list.reverse clauses))) - -(def: #export command_line_arguments - Var - (..var "argv")) diff --git a/stdlib/source/lux/target/python.lux b/stdlib/source/lux/target/python.lux deleted file mode 100644 index c4e03914f..000000000 --- a/stdlib/source/lux/target/python.lux +++ /dev/null @@ -1,500 +0,0 @@ -(.module: - [lux (#- Location Code not or and list if cond int comment exec try) - ["@" target] - ["." ffi] - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)] - ["." enum]] - [control - [pipe (#+ new> case> cond>)] - [parser - ["<.>" code]]] - [data - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [macro - [syntax (#+ syntax:)] - ["." template] - ["." code]] - [math - [number - ["n" nat] - ["f" frac]]] - [type - abstract]]) - -(def: expression - (-> Text Text) - (text.enclose ["(" ")"])) - -(for {@.old (as_is (ffi.import: java/lang/CharSequence) - (ffi.import: java/lang/String - ["#::." - (replace [java/lang/CharSequence java/lang/CharSequence] java/lang/String)]))} - (as_is)) - -(def: nest - (-> Text Text) - (.let [nested_new_line (format text.new_line text.tab)] - (for {@.old (|>> (format text.new_line) - (:as java/lang/String) - (java/lang/String::replace (:as java/lang/CharSequence text.new_line) - (:as java/lang/CharSequence nested_new_line)))} - (|>> (format text.new_line) - (text.replace_all text.new_line nested_new_line))))) - -(abstract: #export (Code brand) - Text - - (implementation: #export equivalence - (All [brand] (Equivalence (Code brand))) - - (def: (= reference subject) - (\ text.equivalence = (:representation reference) (:representation subject)))) - - (implementation: #export hash - (All [brand] (Hash (Code brand))) - - (def: &equivalence ..equivalence) - (def: hash (|>> :representation (\ text.hash hash)))) - - (def: #export manual - (-> Text Code) - (|>> :abstraction)) - - (def: #export code - (-> (Code Any) Text) - (|>> :representation)) - - (template [<type> <super>] - [(with_expansions [<brand> (template.identifier [<type> "'"])] - (`` (abstract: #export (<brand> brand) Any)) - (`` (type: #export (<type> brand) - (<super> (<brand> brand)))))] - - [Expression Code] - [Computation Expression] - [Location Computation] - [Var Location] - [Statement Code] - ) - - (template [<type> <super>] - [(with_expansions [<brand> (template.identifier [<type> "'"])] - (`` (abstract: #export <brand> Any)) - (`` (type: #export <type> (<super> <brand>))))] - - [Literal Computation] - [Access Location] - [Loop Statement] - [Label Code] - ) - - (template [<var> <brand>] - [(abstract: #export <brand> Any) - - (type: #export <var> (Var <brand>))] - - [SVar Single] - [PVar Poly] - [KVar Keyword] - ) - - (def: #export var - (-> Text SVar) - (|>> :abstraction)) - - (template [<name> <brand> <prefix>] - [(def: #export <name> - (-> SVar (Var <brand>)) - (|>> :representation (format <prefix>) :abstraction))] - - [poly Poly "*"] - [keyword Keyword "**"] - ) - - (def: #export none - Literal - (:abstraction "None")) - - (def: #export bool - (-> Bit Literal) - (|>> (case> #0 "False" - #1 "True") - :abstraction)) - - (def: #export int - (-> Int Literal) - (|>> %.int :abstraction)) - - (def: #export (long value) - (-> Int Literal) - (:abstraction (format (%.int value) "L"))) - - (def: #export float - (-> Frac Literal) - (`` (|>> (cond> (~~ (template [<test> <python>] - [[<test>] - [(new> (format "float(" text.double_quote <python> text.double_quote ")") [])]] - - [(f.= f.positive_infinity) "inf"] - [(f.= f.negative_infinity) "-inf"] - [f.not_a_number? "nan"] - )) - - ## else - [%.frac]) - :abstraction))) - - (def: sanitize - (-> Text Text) - (`` (|>> (~~ (template [<find> <replace>] - [(text.replace_all <find> <replace>)] - - ["\" "\\"] - [text.tab "\t"] - [text.vertical_tab "\v"] - [text.null "\0"] - [text.back_space "\b"] - [text.form_feed "\f"] - [text.new_line "\n"] - [text.carriage_return "\r"] - [text.double_quote (format "\" text.double_quote)] - )) - ))) - - (def: #export string - (-> Text Literal) - (|>> ..sanitize - (text.enclose [text.double_quote text.double_quote]) - :abstraction)) - - (def: #export unicode - (-> Text Literal) - (|>> ..string - :representation - (format "u") - :abstraction)) - - (def: (composite_literal left_delimiter right_delimiter entry_serializer) - (All [a] - (-> Text Text (-> a Text) - (-> (List a) Literal))) - (function (_ entries) - (<| :abstraction - ## ..expression - (format left_delimiter - (|> entries - (list\map entry_serializer) - (text.join_with ", ")) - right_delimiter)))) - - (template [<name> <pre> <post>] - [(def: #export <name> - (-> (List (Expression Any)) Literal) - (composite_literal <pre> <post> ..code))] - - [tuple "(" ")"] - [list "[" "]"] - ) - - (def: #export (slice from to list) - (-> (Expression Any) (Expression Any) (Expression Any) Access) - (<| :abstraction - ## ..expression - (format (:representation list) "[" (:representation from) ":" (:representation to) "]"))) - - (def: #export (slice_from from list) - (-> (Expression Any) (Expression Any) Access) - (<| :abstraction - ## ..expression - (format (:representation list) "[" (:representation from) ":]"))) - - (def: #export dict - (-> (List [(Expression Any) (Expression Any)]) (Computation Any)) - (composite_literal "{" "}" (.function (_ [k v]) (format (:representation k) " : " (:representation v))))) - - (def: #export (apply/* func args) - (-> (Expression Any) (List (Expression Any)) (Computation Any)) - (<| :abstraction - ## ..expression - (format (:representation func) "(" (text.join_with ", " (list\map ..code args)) ")"))) - - (template [<name> <brand> <prefix>] - [(def: (<name> var) - (-> (Expression Any) Text) - (format <prefix> (:representation var)))] - - [splat_poly Poly "*"] - [splat_keyword Keyword "**"] - ) - - (template [<name> <splat>] - [(def: #export (<name> args extra func) - (-> (List (Expression Any)) (Expression Any) (Expression Any) (Computation Any)) - (<| :abstraction - ## ..expression - (format (:representation func) - (format "(" (|> args - (list\map (function (_ arg) (format (:representation arg) ", "))) - (text.join_with "")) - (<splat> extra) ")"))))] - - [apply_poly splat_poly] - [apply_keyword splat_keyword] - ) - - (def: #export (the name object) - (-> Text (Expression Any) (Computation Any)) - (:abstraction (format (:representation object) "." name))) - - (def: #export (do method args object) - (-> Text (List (Expression Any)) (Expression Any) (Computation Any)) - (..apply/* (..the method object) args)) - - (template [<name> <apply>] - [(def: #export (<name> args extra method) - (-> (List (Expression Any)) (Expression Any) Text - (-> (Expression Any) (Computation Any))) - (|>> (..the method) (<apply> args extra)))] - - [do_poly apply_poly] - [do_keyword apply_keyword] - ) - - (def: #export (nth idx array) - (-> (Expression Any) (Expression Any) Location) - (:abstraction (format (:representation array) "[" (:representation idx) "]"))) - - (def: #export (? test then else) - (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any)) - (<| :abstraction - ..expression - (format (:representation then) " if " (:representation test) " else " (:representation else)))) - - (template [<name> <op>] - [(def: #export (<name> param subject) - (-> (Expression Any) (Expression Any) (Computation Any)) - (<| :abstraction - ..expression - (format (:representation subject) " " <op> " " (:representation param))))] - - [is "is"] - [= "=="] - [< "<"] - [<= "<="] - [> ">"] - [>= ">="] - [+ "+"] - [- "-"] - [* "*"] - [/ "/"] - [// "//"] - [% "%"] - [** "**"] - [bit_or "|"] - [bit_and "&"] - [bit_xor "^"] - [bit_shl "<<"] - [bit_shr ">>"] - - [or "or"] - [and "and"] - ) - - (template [<name> <unary>] - [(def: #export (<name> subject) - (-> (Expression Any) (Computation Any)) - (<| :abstraction - ## ..expression - (format <unary> " " (:representation subject))))] - - [not "not"] - [negate "-"] - ) - - (def: #export (lambda arguments body) - (-> (List (Var Any)) (Expression Any) (Computation Any)) - (<| :abstraction - ..expression - (format "lambda " (|> arguments (list\map ..code) (text.join_with ", ")) ": " - (:representation body)))) - - (def: #export (set vars value) - (-> (List (Location Any)) (Expression Any) (Statement Any)) - (:abstraction - (format (|> vars (list\map ..code) (text.join_with ", ")) - " = " - (:representation value)))) - - (def: #export (delete where) - (-> (Location Any) (Statement Any)) - (:abstraction (format "del " (:representation where)))) - - (def: #export (if test then! else!) - (-> (Expression Any) (Statement Any) (Statement Any) (Statement Any)) - (:abstraction - (format "if " (:representation test) ":" - (..nest (:representation then!)) - text.new_line "else:" - (..nest (:representation else!))))) - - (def: #export (when test then!) - (-> (Expression Any) (Statement Any) (Statement Any)) - (:abstraction - (format "if " (:representation test) ":" - (..nest (:representation then!))))) - - (def: #export (then pre! post!) - (-> (Statement Any) (Statement Any) (Statement Any)) - (:abstraction - (format (:representation pre!) - text.new_line - (:representation post!)))) - - (template [<keyword> <0>] - [(def: #export <0> - (Statement Any) - (:abstraction <keyword>))] - - ["break" break] - ["continue" continue] - ) - - (def: #export (while test body! else!) - (-> (Expression Any) (Statement Any) (Maybe (Statement Any)) Loop) - (:abstraction - (format "while " (:representation test) ":" - (..nest (:representation body!)) - (case else! - (#.Some else!) - (format text.new_line "else:" - (..nest (:representation else!))) - - #.None - "")))) - - (def: #export (for_in var inputs body!) - (-> SVar (Expression Any) (Statement Any) Loop) - (:abstraction - (format "for " (:representation var) " in " (:representation inputs) ":" - (..nest (:representation body!))))) - - (def: #export statement - (-> (Expression Any) (Statement Any)) - (|>> :transmutation)) - - (def: #export pass - (Statement Any) - (:abstraction "pass")) - - (type: #export Except - {#classes (List SVar) - #exception SVar - #handler (Statement Any)}) - - (def: #export (try body! excepts) - (-> (Statement Any) (List Except) (Statement Any)) - (:abstraction - (format "try:" - (..nest (:representation body!)) - (|> excepts - (list\map (function (_ [classes exception catch!]) - (format text.new_line "except (" (text.join_with ", " (list\map ..code classes)) - ") as " (:representation exception) ":" - (..nest (:representation catch!))))) - (text.join_with ""))))) - - (template [<name> <keyword> <pre>] - [(def: #export (<name> value) - (-> (Expression Any) (Statement Any)) - (:abstraction - (format <keyword> (<pre> (:representation value)))))] - - [raise "raise " |>] - [return "return " |>] - [print "print" ..expression] - ) - - (def: #export (exec code globals) - (-> (Expression Any) (Maybe (Expression Any)) (Statement Any)) - (let [extra (case globals - (#.Some globals) - (.list globals) - - #.None - (.list))] - (:abstraction - (format "exec" (:representation (..tuple (list& code extra))))))) - - (def: #export (def name args body) - (-> SVar (List (Ex [k] (Var k))) (Statement Any) (Statement Any)) - (:abstraction - (format "def " (:representation name) - "(" (|> args (list\map ..code) (text.join_with ", ")) "):" - (..nest (:representation body))))) - - (def: #export (import module_name) - (-> Text (Statement Any)) - (:abstraction (format "import " module_name))) - - (def: #export (comment commentary on) - (All [brand] (-> Text (Code brand) (Code brand))) - (:abstraction (format "# " (..sanitize commentary) text.new_line - (:representation on)))) - ) - -(def: #export (cond clauses else!) - (-> (List [(Expression Any) (Statement Any)]) (Statement Any) (Statement Any)) - (list\fold (.function (_ [test then!] next!) - (..if test then! next!)) - else! - (list.reverse clauses))) - -(syntax: (arity_inputs {arity <code>.nat}) - (wrap (case arity - 0 (.list) - _ (|> (dec arity) - (enum.range n.enum 0) - (list\map (|>> %.nat code.local_identifier)))))) - -(syntax: (arity_types {arity <code>.nat}) - (wrap (list.repeat arity (` (Expression Any))))) - -(template [<arity> <function>+] - [(with_expansions [<apply> (template.identifier ["apply/" <arity>]) - <inputs> (arity_inputs <arity>) - <types> (arity_types <arity>) - <definitions> (template.splice <function>+)] - (def: #export (<apply> function <inputs>) - (-> (Expression Any) <types> (Computation Any)) - (..apply/* function (.list <inputs>))) - - (template [<function>] - [(`` (def: #export (~~ (template.identifier [<function> "/" <arity>])) - (<apply> (..var <function>))))] - - <definitions>))] - - [1 - [["str"] - ["ord"] - ["float"] - ["int"] - ["len"] - ["chr"] - ["unichr"] - ["unicode"] - ["repr"] - ["__import__"] - ["Exception"]]] - - [2 - []] - - [3 - []] - ) diff --git a/stdlib/source/lux/target/r.lux b/stdlib/source/lux/target/r.lux deleted file mode 100644 index 40fb28da7..000000000 --- a/stdlib/source/lux/target/r.lux +++ /dev/null @@ -1,385 +0,0 @@ -(.module: - [lux (#- Code or and list if function cond not int) - [control - [pipe (#+ case> cond> new>)] - ["." function] - [parser - ["<.>" code]]] - [data - ["." maybe ("#\." functor)] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [macro - [syntax (#+ syntax:)] - ["." template] - ["." code]] - [math - [number - ["f" frac]]] - [type - abstract]]) - -(abstract: #export (Code kind) - Text - - {} - - (template [<type> <super>+] - [(with_expansions [<kind> (template.identifier [<type> "'"])] - (abstract: #export (<kind> kind) Any) - (`` (type: #export <type> (|> Any <kind> (~~ (template.splice <super>+))))))] - - [Expression [Code]] - ) - - (template [<type> <super>+] - [(with_expansions [<kind> (template.identifier [<type> "'"])] - (abstract: #export (<kind> kind) Any) - (`` (type: #export (<type> <brand>) (|> <brand> <kind> (~~ (template.splice <super>+))))))] - - [Var [Expression' Code]] - ) - - (template [<var> <kind>] - [(abstract: #export <kind> Any) - (type: #export <var> (Var <kind>))] - - [SVar Single] - [PVar Poly] - ) - - (def: #export var - (-> Text SVar) - (|>> :abstraction)) - - (def: #export var_args - PVar - (:abstraction "...")) - - (def: #export manual - (-> Text Code) - (|>> :abstraction)) - - (def: #export code - (-> (Code Any) Text) - (|>> :representation)) - - (def: (self_contained code) - (-> Text Expression) - (:abstraction - (format "(" code ")"))) - - (def: nested_new_line - (format text.new_line text.tab)) - - (def: nest - (-> Text Text) - (|>> (text.replace_all text.new_line ..nested_new_line) - (format ..nested_new_line))) - - (def: (_block expression) - (-> Text Text) - (format "{" (nest expression) text.new_line "}")) - - (def: #export (block expression) - (-> Expression Expression) - (:abstraction - (format "{" - (..nest (:representation expression)) - text.new_line "}"))) - - (template [<name> <r>] - [(def: #export <name> - Expression - (:abstraction <r>))] - - [null "NULL"] - [n/a "NA"] - ) - - (template [<name>] - [(def: #export <name> Expression n/a)] - - [not_available] - [not_applicable] - [no_answer] - ) - - (def: #export bool - (-> Bit Expression) - (|>> (case> #0 "FALSE" - #1 "TRUE") - :abstraction)) - - (def: #export int - (-> Int Expression) - (|>> %.int :abstraction)) - - (def: #export float - (-> Frac Expression) - (|>> (cond> [(f.= f.positive_infinity)] - [(new> "1.0/0.0" [])] - - [(f.= f.negative_infinity)] - [(new> "-1.0/0.0" [])] - - [(f.= f.not_a_number)] - [(new> "0.0/0.0" [])] - - ## else - [%.frac]) - ..self_contained)) - - (def: sanitize - (-> Text Text) - (`` (|>> (~~ (template [<find> <replace>] - [(text.replace_all <find> <replace>)] - - ["\" "\\"] - ["|" "\|"] - [text.alarm "\a"] - [text.back_space "\b"] - [text.tab "\t"] - [text.new_line "\n"] - [text.carriage_return "\r"] - [text.double_quote (format "\" text.double_quote)] - )) - ))) - - (def: #export string - (-> Text Expression) - (|>> ..sanitize %.text :abstraction)) - - (def: #export (slice from to list) - (-> Expression Expression Expression Expression) - (..self_contained - (format (:representation list) - "[" (:representation from) ":" (:representation to) "]"))) - - (def: #export (slice_from from list) - (-> Expression Expression Expression) - (..self_contained - (format (:representation list) - "[-1" ":-" (:representation from) "]"))) - - (def: #export (apply args func) - (-> (List Expression) Expression Expression) - (let [func (:representation func) - spacing (|> " " (list.repeat (text.size func)) (text.join_with ""))] - (:abstraction - (format func "(" - (|> args - (list\map ..code) - (text.join_with (format "," text.new_line)) - ..nest) - ")")))) - - (template [<name> <function>] - [(def: #export (<name> members) - (-> (List Expression) Expression) - (..apply members (..var <function>)))] - - [vector "c"] - [list "list"] - ) - - (def: #export named_list - (-> (List [Text Expression]) Expression) - (|>> (list\map (.function (_ [key value]) - (:abstraction (format key "=" (:representation value))))) - ..list)) - - (def: #export (apply_kw args kw_args func) - (-> (List Expression) (List [Text Expression]) Expression Expression) - (..self_contained - (format (:representation func) - (format "(" - (text.join_with "," (list\map ..code args)) "," - (text.join_with "," (list\map (.function (_ [key val]) - (format key "=" (:representation val))) - kw_args)) - ")")))) - - (syntax: (arity_inputs {arity <code>.nat}) - (wrap (case arity - 0 (.list) - _ (|> arity - list.indices - (list\map (|>> %.nat code.local_identifier)))))) - - (syntax: (arity_types {arity <code>.nat}) - (wrap (list.repeat arity (` ..Expression)))) - - (template [<arity> <function>+] - [(with_expansions [<apply> (template.identifier ["apply/" <arity>]) - <inputs> (arity_inputs <arity>) - <types> (arity_types <arity>) - <definitions> (template.splice <function>+)] - (def: #export (<apply> function [<inputs>]) - (-> Expression [<types>] Expression) - (..apply (.list <inputs>) function)) - - (template [<function>] - [(`` (def: #export (~~ (template.identifier [<function> "/" <arity>])) - (-> [<types>] Expression) - (<apply> (..var <function>))))] - - <definitions>))] - - [0 - [["commandArgs"]]] - [1 - [["intToUtf8"]]] - [2 - [["paste"]]] - ) - - (def: #export as::integer - (-> Expression Expression) - (..apply/1 (..var "as.integer"))) - - (def: #export (nth idx list) - (-> Expression Expression Expression) - (..self_contained - (format (:representation list) "[[" (:representation idx) "]]"))) - - (def: #export (if test then else) - (-> Expression Expression Expression Expression) - (:abstraction - (format "if(" (:representation test) ")" - " " (.._block (:representation then)) - " else " (.._block (:representation else))))) - - (def: #export (when test then) - (-> Expression Expression Expression) - (:abstraction - (format "if(" (:representation test) ") {" - (.._block (:representation then)) - text.new_line "}"))) - - (def: #export (cond clauses else) - (-> (List [Expression Expression]) Expression Expression) - (list\fold (.function (_ [test then] next) - (if test then next)) - else - (list.reverse clauses))) - - (template [<name> <op>] - [(def: #export (<name> param subject) - (-> Expression Expression Expression) - (..self_contained - (format (:representation subject) - " " <op> " " - (:representation param))))] - - [= "=="] - [< "<"] - [<= "<="] - [> ">"] - [>= ">="] - [+ "+"] - [- "-"] - [* "*"] - [/ "/"] - [%% "%%"] - [** "**"] - [or "||"] - [and "&&"] - ) - - (template [<name> <func>] - [(def: #export (<name> param subject) - (-> Expression Expression Expression) - (..apply (.list subject param) (..var <func>)))] - - [bit_or "bitwOr"] - [bit_and "bitwAnd"] - [bit_xor "bitwXor"] - [bit_shl "bitwShiftL"] - [bit_ushr "bitwShiftR"] - ) - - (def: #export (bit_not subject) - (-> Expression Expression) - (..apply (.list subject) (..var "bitwNot"))) - - (template [<name> <op>] - [(def: #export <name> - (-> Expression Expression) - (|>> :representation (format <op>) ..self_contained))] - - [not "!"] - [negate "-"] - ) - - (def: #export (length list) - (-> Expression Expression) - (..apply (.list list) (..var "length"))) - - (def: #export (range from to) - (-> Expression Expression Expression) - (..self_contained - (format (:representation from) ":" (:representation to)))) - - (def: #export (function inputs body) - (-> (List (Ex [k] (Var k))) Expression Expression) - (let [args (|> inputs (list\map ..code) (text.join_with ", "))] - (..self_contained - (format "function(" args ") " - (.._block (:representation body)))))) - - (def: #export (try body warning error finally) - (-> Expression (Maybe Expression) (Maybe Expression) (Maybe Expression) Expression) - (let [optional (: (-> Text (Maybe Expression) (-> Text Text) Text) - (.function (_ parameter value preparation) - (|> value - (maybe\map (|>> :representation preparation (format ", " parameter " = "))) - (maybe.default ""))))] - (..self_contained - (format "tryCatch(" - (.._block (:representation body)) - (optional "warning" warning function.identity) - (optional "error" error function.identity) - (optional "finally" finally .._block) - ")")))) - - (def: #export (while test body) - (-> Expression Expression Expression) - (..self_contained - (format "while (" (:representation test) ") " - (.._block (:representation body))))) - - (def: #export (for_in var inputs body) - (-> SVar Expression Expression Expression) - (..self_contained - (format "for (" (:representation var) " in " (:representation inputs) ")" - (.._block (:representation body))))) - - (template [<name> <keyword>] - [(def: #export (<name> message) - (-> Expression Expression) - (..apply (.list message) (..var <keyword>)))] - - [stop "stop"] - [print "print"] - ) - - (def: #export (set! var value) - (-> SVar Expression Expression) - (..self_contained - (format (:representation var) " <- " (:representation value)))) - - (def: #export (set_nth! idx value list) - (-> Expression Expression SVar Expression) - (..self_contained - (format (:representation list) "[[" (:representation idx) "]] <- " (:representation value)))) - - (def: #export (then pre post) - (-> Expression Expression Expression) - (:abstraction - (format (:representation pre) - text.new_line - (:representation post)))) - ) diff --git a/stdlib/source/lux/target/ruby.lux b/stdlib/source/lux/target/ruby.lux deleted file mode 100644 index e23c64fc0..000000000 --- a/stdlib/source/lux/target/ruby.lux +++ /dev/null @@ -1,472 +0,0 @@ -(.module: - [lux (#- Location Code static int if cond function or and not comment) - ["@" target] - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)] - ["." enum]] - [control - [pipe (#+ case> cond> new>)] - [parser - ["<.>" code]]] - [data - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [macro - [syntax (#+ syntax:)] - ["." template] - ["." code]] - [math - [number - ["n" nat] - ["f" frac]]] - [type - abstract]]) - -(def: input_separator ", ") -(def: statement_suffix ";") - -(def: nest - (-> Text Text) - (.let [nested_new_line (format text.new_line text.tab)] - (|>> (format text.new_line) - (text.replace_all text.new_line nested_new_line)))) - -(abstract: #export (Code brand) - Text - - (implementation: #export code_equivalence - (All [brand] (Equivalence (Code brand))) - - (def: (= reference subject) - (\ text.equivalence = (:representation reference) (:representation subject)))) - - (implementation: #export code_hash - (All [brand] (Hash (Code brand))) - - (def: &equivalence ..code_equivalence) - (def: hash (|>> :representation (\ text.hash hash)))) - - (def: #export manual - (-> Text Code) - (|>> :abstraction)) - - (def: #export code - (-> (Code Any) Text) - (|>> :representation)) - - (template [<type> <super>+] - [(with_expansions [<brand> (template.identifier [<type> "'"])] - (abstract: (<brand> brand) Any) - (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+))))))] - - [Expression [Code]] - [Computation [Expression' Code]] - [Location [Computation' Expression' Code]] - [Var [Location' Computation' Expression' Code]] - [LVar [Var' Location' Computation' Expression' Code]] - [Statement [Code]] - ) - - (template [<type> <super>+] - [(with_expansions [<brand> (template.identifier [<type> "'"])] - (abstract: #export <brand> Any) - (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+))))))] - - [Literal [Computation' Expression' Code]] - [Access [Location' Computation' Expression' Code]] - [GVar [Var' Location' Computation' Expression' Code]] - [IVar [Var' Location' Computation' Expression' Code]] - [SVar [Var' Location' Computation' Expression' Code]] - [LVar* [LVar' Var' Location' Computation' Expression' Code]] - [LVar** [LVar' Var' Location' Computation' Expression' Code]] - ) - - (template [<var> <prefix> <constructor>] - [(def: #export <constructor> - (-> Text <var>) - (|>> (format <prefix>) :abstraction))] - - [GVar "$" global] - [IVar "@" instance] - [SVar "@@" static] - ) - - (def: #export local - (-> Text LVar) - (|>> :abstraction)) - - (template [<var> <prefix> <modifier> <unpacker>] - [(template [<name> <input> <output>] - [(def: #export <name> - (-> <input> <output>) - (|>> :representation (format <prefix>) :abstraction))] - - [<modifier> LVar <var>] - [<unpacker> Expression Computation] - )] - - [LVar* "*" variadic splat] - [LVar** "**" variadic_kv double_splat] - ) - - (template [<ruby_name> <lux_name>] - [(def: #export <lux_name> - (..global <ruby_name>))] - - ["@" latest_error] - ["_" last_string_read] - ["." last_line_number_read] - ["&" last_string_matched] - ["~" last_regexp_match] - ["=" case_insensitivity_flag] - ["/" input_record_separator] - ["\" output_record_separator] - ["0" script_name] - ["$" process_id] - ["?" exit_status] - ) - - (template [<ruby_name> <lux_name>] - [(def: #export <lux_name> - (..local <ruby_name>))] - - ["ARGV" command_line_arguments] - ) - - (def: #export nil - Literal - (:abstraction "nil")) - - (def: #export bool - (-> Bit Literal) - (|>> (case> #0 "false" - #1 "true") - :abstraction)) - - (def: sanitize - (-> Text Text) - (`` (|>> (~~ (template [<find> <replace>] - [(text.replace_all <find> <replace>)] - - ["\" "\\"] - [text.tab "\t"] - [text.vertical_tab "\v"] - [text.null "\0"] - [text.back_space "\b"] - [text.form_feed "\f"] - [text.new_line "\n"] - [text.carriage_return "\r"] - [text.double_quote (format "\" text.double_quote)] - )) - ))) - - (template [<format> <name> <type> <prep>] - [(def: #export <name> - (-> <type> Literal) - (|>> <prep> <format> :abstraction))] - - [%.int int Int (<|)] - [%.text string Text ..sanitize] - [(<|) symbol Text (format ":")] - ) - - (def: #export float - (-> Frac Literal) - (|>> (cond> [(f.= f.positive_infinity)] - [(new> "(+1.0/0.0)" [])] - - [(f.= f.negative_infinity)] - [(new> "(-1.0/0.0)" [])] - - [(f.= f.not_a_number)] - [(new> "(+0.0/-0.0)" [])] - - ## else - [%.frac]) - :abstraction)) - - (def: #export (array_range from to array) - (-> Expression Expression Expression Computation) - (|> (format (:representation from) ".." (:representation to)) - (text.enclose ["[" "]"]) - (format (:representation array)) - :abstraction)) - - (def: #export array - (-> (List Expression) Literal) - (|>> (list\map (|>> :representation)) - (text.join_with ..input_separator) - (text.enclose ["[" "]"]) - :abstraction)) - - (def: #export hash - (-> (List [Expression Expression]) Literal) - (|>> (list\map (.function (_ [k v]) - (format (:representation k) " => " (:representation v)))) - (text.join_with ..input_separator) - (text.enclose ["{" "}"]) - :abstraction)) - - (def: #export (apply/* args func) - (-> (List Expression) Expression Computation) - (|> args - (list\map (|>> :representation)) - (text.join_with ..input_separator) - (text.enclose ["(" ")"]) - (format (:representation func)) - :abstraction)) - - (def: #export (apply_lambda/* args lambda) - (-> (List Expression) Expression Computation) - (|> args - (list\map (|>> :representation)) - (text.join_with ..input_separator) - (text.enclose ["[" "]"]) - (format (:representation lambda)) - :abstraction)) - - (def: #export (the field object) - (-> Text Expression Access) - (:abstraction (format (:representation object) "." field))) - - (def: #export (nth idx array) - (-> Expression Expression Access) - (|> (:representation idx) - (text.enclose ["[" "]"]) - (format (:representation array)) - :abstraction)) - - (def: #export (? test then else) - (-> Expression Expression Expression Computation) - (|> (format (:representation test) " ? " - (:representation then) " : " - (:representation else)) - (text.enclose ["(" ")"]) - :abstraction)) - - (def: #export statement - (-> Expression Statement) - (|>> :representation - (text.suffix ..statement_suffix) - :abstraction)) - - (def: #export (then pre! post!) - (-> Statement Statement Statement) - (:abstraction - (format (:representation pre!) - text.new_line - (:representation post!)))) - - (def: #export (set vars value) - (-> (List Location) Expression Statement) - (:abstraction - (format (|> vars - (list\map (|>> :representation)) - (text.join_with ..input_separator)) - " = " (:representation value) ..statement_suffix))) - - (def: (block content) - (-> Text Text) - (format content - text.new_line "end" ..statement_suffix)) - - (def: #export (if test then! else!) - (-> Expression Statement Statement Statement) - (<| :abstraction - ..block - (format "if " (:representation test) - (..nest (:representation then!)) - text.new_line "else" - (..nest (:representation else!))))) - - (template [<name> <block>] - [(def: #export (<name> test then!) - (-> Expression Statement Statement) - (<| :abstraction - ..block - (format <block> " " (:representation test) - (..nest (:representation then!)))))] - - [when "if"] - [while "while"] - ) - - (def: #export (for_in var array iteration!) - (-> LVar Expression Statement Statement) - (<| :abstraction - ..block - (format "for " (:representation var) - " in " (:representation array) - " do " - (..nest (:representation iteration!))))) - - (type: #export Rescue - {#classes (List Text) - #exception LVar - #rescue Statement}) - - (def: #export (begin body! rescues) - (-> Statement (List Rescue) Statement) - (<| :abstraction - ..block - (format "begin" (..nest (:representation body!)) - (|> rescues - (list\map (.function (_ [classes exception rescue]) - (format text.new_line "rescue " (text.join_with ..input_separator classes) - " => " (:representation exception) - (..nest (:representation rescue))))) - (text.join_with text.new_line))))) - - (def: #export (catch expectation body!) - (-> Expression Statement Statement) - (<| :abstraction - ..block - (format "catch(" (:representation expectation) ") do" - (..nest (:representation body!))))) - - (def: #export (return value) - (-> Expression Statement) - (:abstraction (format "return " (:representation value) ..statement_suffix))) - - (def: #export (raise message) - (-> Expression Computation) - (:abstraction (format "raise " (:representation message)))) - - (template [<name> <keyword>] - [(def: #export <name> - Statement - (|> <keyword> - (text.suffix ..statement_suffix) - :abstraction))] - - [next "next"] - [redo "redo"] - [break "break"] - ) - - (def: #export (function name args body!) - (-> LVar (List LVar) Statement Statement) - (<| :abstraction - ..block - (format "def " (:representation name) - (|> args - (list\map (|>> :representation)) - (text.join_with ..input_separator) - (text.enclose ["(" ")"])) - (..nest (:representation body!))))) - - (def: #export (lambda name args body!) - (-> (Maybe LVar) (List Var) Statement Literal) - (let [proc (|> (format (|> args - (list\map (|>> :representation)) - (text.join_with ..input_separator) - (text.enclose' "|")) - (..nest (:representation body!))) - (text.enclose ["{" "}"]) - (format "lambda "))] - (|> (case name - #.None - proc - - (#.Some name) - (format (:representation name) " = " proc)) - (text.enclose ["(" ")"]) - :abstraction))) - - (template [<op> <name>] - [(def: #export (<name> parameter subject) - (-> Expression Expression Computation) - (:abstraction (format "(" (:representation subject) " " <op> " " (:representation parameter) ")")))] - - ["==" =] - [ "<" <] - ["<=" <=] - [ ">" >] - [">=" >=] - - [ "+" +] - [ "-" -] - [ "*" *] - [ "/" /] - [ "%" %] - ["**" pow] - - ["||" or] - ["&&" and] - [ "|" bit_or] - [ "&" bit_and] - [ "^" bit_xor] - - ["<<" bit_shl] - [">>" bit_shr] - ) - - (template [<unary> <name>] - [(def: #export (<name> subject) - (-> Expression Computation) - (:abstraction (format "(" <unary> (:representation subject) ")")))] - - ["!" not] - ["-" negate] - ) - - (def: #export (comment commentary on) - (All [brand] (-> Text (Code brand) (Code brand))) - (:abstraction (format "# " (..sanitize commentary) text.new_line - (:representation on)))) - ) - -(def: #export (do method args object) - (-> Text (List Expression) Expression Computation) - (|> object (..the method) (..apply/* args))) - -(def: #export (cond clauses else!) - (-> (List [Expression Statement]) Statement Statement) - (list\fold (.function (_ [test then!] next!) - (..if test then! next!)) - else! - (list.reverse clauses))) - -(syntax: (arity_inputs {arity <code>.nat}) - (wrap (case arity - 0 (.list) - _ (|> (dec arity) - (enum.range n.enum 0) - (list\map (|>> %.nat code.local_identifier)))))) - -(syntax: (arity_types {arity <code>.nat}) - (wrap (list.repeat arity (` ..Expression)))) - -(template [<arity> <function>+] - [(with_expansions [<apply> (template.identifier ["apply/" <arity>]) - <inputs> (arity_inputs <arity>) - <types> (arity_types <arity>) - <definitions> (template.splice <function>+)] - (def: #export (<apply> function <inputs>) - (-> Expression <types> Computation) - (..apply/* (.list <inputs>) function)) - - (template [<function>] - [(`` (def: #export (~~ (template.identifier [<function> "/" <arity>])) - (<apply> (..local <function>))))] - - <definitions>))] - - [1 - [["print"] - ["require"]]] - - [2 - [["print"]]] - - [3 - [["print"]]] - ) - -(def: #export throw/1 - (-> Expression Statement) - (|>> (..apply/1 (..local "throw")) - ..statement)) diff --git a/stdlib/source/lux/target/scheme.lux b/stdlib/source/lux/target/scheme.lux deleted file mode 100644 index a34023c6a..000000000 --- a/stdlib/source/lux/target/scheme.lux +++ /dev/null @@ -1,379 +0,0 @@ -(.module: - [lux (#- Code int or and if cond let) - ["@" target] - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)]] - [control - [pipe (#+ new> cond> case>)]] - [data - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold monoid)]]] - [macro - ["." template]] - [math - [number - ["n" nat] - ["f" frac]]] - [type - abstract]]) - -(def: nest - (-> Text Text) - (.let [nested_new_line (format text.new_line text.tab)] - (text.replace_all text.new_line nested_new_line))) - -(abstract: #export (Code k) - Text - - (implementation: #export equivalence - (All [brand] (Equivalence (Code brand))) - - (def: (= reference subject) - (\ text.equivalence = (:representation reference) (:representation subject)))) - - (implementation: #export hash - (All [brand] (Hash (Code brand))) - - (def: &equivalence ..equivalence) - (def: hash (|>> :representation (\ text.hash hash)))) - - (template [<type> <brand> <super>+] - [(abstract: #export (<brand> brand) Any) - (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+)))))] - - [Expression Expression' [Code]] - ) - - (template [<type> <brand> <super>+] - [(abstract: #export <brand> Any) - (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+)))))] - - [Var Var' [Expression' Code]] - [Computation Computation' [Expression' Code]] - ) - - (type: #export Arguments - {#mandatory (List Var) - #rest (Maybe Var)}) - - (def: #export manual - (-> Text Code) - (|>> :abstraction)) - - (def: #export code - (-> (Code Any) Text) - (|>> :representation)) - - (def: #export var - (-> Text Var) - (|>> :abstraction)) - - (def: (arguments [mandatory rest]) - (-> Arguments (Code Any)) - (case rest - (#.Some rest) - (case mandatory - #.Nil - rest - - _ - (|> (format " . " (:representation rest)) - (format (|> mandatory - (list\map ..code) - (text.join_with " "))) - (text.enclose ["(" ")"]) - :abstraction)) - - #.None - (|> mandatory - (list\map ..code) - (text.join_with " ") - (text.enclose ["(" ")"]) - :abstraction))) - - (def: #export nil - Computation - (:abstraction "'()")) - - (def: #export bool - (-> Bit Computation) - (|>> (case> #0 "#f" - #1 "#t") - :abstraction)) - - (def: #export int - (-> Int Computation) - (|>> %.int :abstraction)) - - (def: #export float - (-> Frac Computation) - (|>> (cond> [(f.= f.positive_infinity)] - [(new> "+inf.0" [])] - - [(f.= f.negative_infinity)] - [(new> "-inf.0" [])] - - [f.not_a_number?] - [(new> "+nan.0" [])] - - ## else - [%.frac]) - :abstraction)) - - (def: #export positive_infinity Computation (..float f.positive_infinity)) - (def: #export negative_infinity Computation (..float f.negative_infinity)) - (def: #export not_a_number Computation (..float f.not_a_number)) - - (def: sanitize - (-> Text Text) - (`` (|>> (~~ (template [<find> <replace>] - [(text.replace_all <find> <replace>)] - - ["\" "\\"] - ["|" "\|"] - [text.alarm "\a"] - [text.back_space "\b"] - [text.tab "\t"] - [text.new_line "\n"] - [text.carriage_return "\r"] - [text.double_quote (format "\" text.double_quote)] - )) - ))) - - (def: #export string - (-> Text Computation) - (|>> ..sanitize %.text :abstraction)) - - (def: #export symbol - (-> Text Computation) - (|>> (format "'") :abstraction)) - - (def: form - (-> (List (Code Any)) Code) - (.let [nested_new_line (format text.new_line text.tab)] - (|>> (case> #.Nil - (:abstraction "()") - - (#.Cons head tail) - (|> tail - (list\map (|>> :representation nest)) - (#.Cons (:representation head)) - (text.join_with nested_new_line) - (text.enclose ["(" ")"]) - :abstraction))))) - - (def: #export (apply/* args func) - (-> (List Expression) Expression Computation) - (..form (#.Cons func args))) - - (template [<name> <function>] - [(def: #export (<name> members) - (-> (List Expression) Computation) - (..apply/* members (..var <function>)))] - - [vector/* "vector"] - [list/* "list"] - ) - - (def: #export apply/0 - (-> Expression Computation) - (..apply/* (list))) - - (template [<lux_name> <scheme_name>] - [(def: #export <lux_name> - (apply/0 (..var <scheme_name>)))] - - [newline/0 "newline"] - ) - - (template [<apply> <arg>+ <type>+ <function>+] - [(`` (def: #export (<apply> procedure) - (-> Expression (~~ (template.splice <type>+)) Computation) - (function (_ (~~ (template.splice <arg>+))) - (..apply/* (list (~~ (template.splice <arg>+))) procedure)))) - - (`` (template [<definition> <function>] - [(def: #export <definition> (<apply> (..var <function>)))] - - (~~ (template.splice <function>+))))] - - [apply/1 [_0] [Expression] - [[exact/1 "exact"] - [integer->char/1 "integer->char"] - [char->integer/1 "char->integer"] - [number->string/1 "number->string"] - [string->number/1 "string->number"] - [floor/1 "floor"] - [truncate/1 "truncate"] - [string/1 "string"] - [string?/1 "string?"] - [length/1 "length"] - [values/1 "values"] - [null?/1 "null?"] - [car/1 "car"] - [cdr/1 "cdr"] - [raise/1 "raise"] - [error-object-message/1 "error-object-message"] - [make-vector/1 "make-vector"] - [vector-length/1 "vector-length"] - [not/1 "not"] - [string-hash/1 "string-hash"] - [reverse/1 "reverse"] - [display/1 "display"] - [exit/1 "exit"] - [string-length/1 "string-length"] - [load-relative/1 "load-relative"]]] - - [apply/2 [_0 _1] [Expression Expression] - [[append/2 "append"] - [cons/2 "cons"] - [make-vector/2 "make-vector"] - ## [vector-ref/2 "vector-ref"] - [list-tail/2 "list-tail"] - [map/2 "map"] - [string-ref/2 "string-ref"] - [string-append/2 "string-append"] - [make-string/2 "make-string"]]] - - [apply/3 [_0 _1 _2] [Expression Expression Expression] - [[substring/3 "substring"] - [vector-set!/3 "vector-set!"] - [string-contains/3 "string-contains"]]] - - [apply/5 [_0 _1 _2 _3 _4] [Expression Expression Expression Expression Expression] - [[vector-copy!/5 "vector-copy!"]]] - ) - - ## TODO: define "vector-ref/2" like a normal apply/2 function. - ## "vector-ref/2" as an 'invoke' is problematic, since it only works - ## in Kawa. - ## However, the way Kawa defines "vector-ref" causes trouble, - ## because it does a runtime type-check which throws an error when - ## it checks against custom values/objects/classes made for - ## JVM<->Scheme interop. - ## There are 2 ways to deal with this: - ## 0. To fork Kawa, and get rid of the type-check so the normal - ## "vector-ref" can be used instead. - ## 1. To carry on, and then, when it's time to compile the compiler - ## itself into Scheme, switch from 'invoke' to normal 'vector-ref'. - ## Either way, the 'invoke' needs to go away. - (def: #export (vector-ref/2 vector index) - (-> Expression Expression Computation) - (..form (list (..var "invoke") vector (..symbol "getRaw") index))) - - (template [<lux_name> <scheme_name>] - [(def: #export (<lux_name> param subject) - (-> Expression Expression Computation) - (..apply/2 (..var <scheme_name>) subject param))] - - [=/2 "="] - [eq?/2 "eq?"] - [eqv?/2 "eqv?"] - [</2 "<"] - [<=/2 "<="] - [>/2 ">"] - [>=/2 ">="] - [string=?/2 "string=?"] - [string<?/2 "string<?"] - [+/2 "+"] - [-/2 "-"] - [//2 "/"] - [*/2 "*"] - [expt/2 "expt"] - [remainder/2 "remainder"] - [quotient/2 "quotient"] - [mod/2 "mod"] - [arithmetic-shift/2 "arithmetic-shift"] - [bitwise-and/2 "bitwise-and"] - [bitwise-ior/2 "bitwise-ior"] - [bitwise-xor/2 "bitwise-xor"] - ) - - (template [<lux_name> <scheme_name>] - [(def: #export <lux_name> - (-> (List Expression) Computation) - (|>> (list& (..var <scheme_name>)) ..form))] - - [or "or"] - [and "and"] - ) - - (template [<lux_name> <scheme_name> <var> <pre>] - [(def: #export (<lux_name> bindings body) - (-> (List [<var> Expression]) Expression Computation) - (..form (list (..var <scheme_name>) - (|> bindings - (list\map (function (_ [binding/name binding/value]) - (..form (list (|> binding/name <pre>) - binding/value)))) - ..form) - body)))] - - [let "let" Var (<|)] - [let* "let*" Var (<|)] - [letrec "letrec" Var (<|)] - [let_values "let-values" Arguments ..arguments] - [let*_values "let*-values" Arguments ..arguments] - [letrec_values "letrec-values" Arguments ..arguments] - ) - - (def: #export (if test then else) - (-> Expression Expression Expression Computation) - (..form (list (..var "if") test then else))) - - (def: #export (when test then) - (-> Expression Expression Computation) - (..form (list (..var "when") test then))) - - (def: #export (lambda arguments body) - (-> Arguments Expression Computation) - (..form (list (..var "lambda") - (..arguments arguments) - body))) - - (def: #export (define_function name arguments body) - (-> Var Arguments Expression Computation) - (..form (list (..var "define") - (|> arguments - (update@ #mandatory (|>> (#.Cons name))) - ..arguments) - body))) - - (def: #export (define_constant name value) - (-> Var Expression Computation) - (..form (list (..var "define") name value))) - - (def: #export begin - (-> (List Expression) Computation) - (|>> (#.Cons (..var "begin")) ..form)) - - (def: #export (set! name value) - (-> Var Expression Computation) - (..form (list (..var "set!") name value))) - - (def: #export (with_exception_handler handler body) - (-> Expression Expression Computation) - (..form (list (..var "with-exception-handler") handler body))) - - (def: #export (call_with_current_continuation body) - (-> Expression Computation) - (..form (list (..var "call-with-current-continuation") body))) - - (def: #export (guard variable clauses else body) - (-> Var (List [Expression Expression]) (Maybe Expression) Expression Computation) - (..form (list (..var "guard") - (..form (|> (case else - #.None - (list) - - (#.Some else) - (list (..form (list (..var "else") else)))) - (list\compose (list\map (function (_ [when then]) - (..form (list when then))) - clauses)) - (list& variable))) - body))) - ) diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux deleted file mode 100644 index f246e0df9..000000000 --- a/stdlib/source/lux/test.lux +++ /dev/null @@ -1,418 +0,0 @@ -(.module: {#.doc "Tools for unit & property-based/generative testing."} - [lux (#- and for) - ["." meta] - ["." debug] - [abstract - ["." monad (#+ do)]] - [control - [pipe (#+ case>)] - ["." try] - ["." exception (#+ exception:)] - ["." io] - [concurrency - ["." atom (#+ Atom)] - ["." promise (#+ Promise) ("#\." monad)]] - ["<>" parser - ["<.>" code]]] - [data - ["." maybe] - ["." product] - ["." name] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set (#+ Set)] - ["." dictionary #_ - ["#" ordered (#+ Dictionary)]]]] - [time - ["." instant] - ["." duration (#+ Duration)]] - [math - ["." random (#+ Random) ("#\." monad)] - [number (#+ hex) - ["n" nat] - ["f" frac]]] - [macro - [syntax (#+ syntax:)] - ["." code]] - [world - ["." program]]]) - -(type: #export Tally - {#successes Nat - #failures Nat - #expected_coverage (Set Name) - #actual_coverage (Set Name)}) - -(def: (add_tally parameter subject) - (-> Tally Tally Tally) - {#successes (n.+ (get@ #successes parameter) (get@ #successes subject)) - #failures (n.+ (get@ #failures parameter) (get@ #failures subject)) - #expected_coverage (set.union (get@ #expected_coverage parameter) - (get@ #expected_coverage subject)) - #actual_coverage (set.union (get@ #actual_coverage parameter) - (get@ #actual_coverage subject))}) - -(def: start - Tally - {#successes 0 - #failures 0 - #expected_coverage (set.new name.hash) - #actual_coverage (set.new name.hash)}) - -(template [<name> <category>] - [(def: <name> - Tally - (update@ <category> .inc ..start))] - - [success #successes] - [failure #failures] - ) - -(type: #export Assertion - (Promise [Tally Text])) - -(type: #export Test - (Random Assertion)) - -(def: separator - text.new_line) - -(def: #export (and' left right) - {#.doc "Sequencing combinator."} - (-> Assertion Assertion Assertion) - (let [[read! write!] (: [(Promise [Tally Text]) - (promise.Resolver [Tally Text])] - (promise.promise [])) - _ (|> left - (promise.await (function (_ [l_tally l_documentation]) - (promise.await (function (_ [r_tally r_documentation]) - (write! [(add_tally l_tally r_tally) - (format l_documentation ..separator r_documentation)])) - right))) - io.run)] - read!)) - -(def: #export (and left right) - {#.doc "Sequencing combinator."} - (-> Test Test Test) - (do {! random.monad} - [left left] - (\ ! map (..and' left) right))) - -(def: context_prefix - text.tab) - -(def: #export (context description) - (-> Text Test Test) - (random\map (promise\map (function (_ [tally documentation]) - [tally (|> documentation - (text.split_all_with ..separator) - (list\map (|>> (format context_prefix))) - (text.join_with ..separator) - (format description ..separator))])))) - -(def: failure_prefix "[Failure] ") -(def: success_prefix "[Success] ") - -(def: #export fail - (-> Text Test) - (|>> (format ..failure_prefix) - [..failure] - promise\wrap - random\wrap)) - -(def: #export (assert message condition) - {#.doc "Check that a condition is #1, and fail with the given message otherwise."} - (-> Text Bit Assertion) - (<| promise\wrap - (if condition - [..success (format ..success_prefix message)] - [..failure (format ..failure_prefix message)]))) - -(def: #export (test message condition) - {#.doc "Check that a condition is #1, and fail with the given message otherwise."} - (-> Text Bit Test) - (random\wrap (..assert message condition))) - -(def: #export (lift message random) - (-> Text (Random Bit) Test) - (random\map (..assert message) random)) - -(def: pcg32_magic_inc - Nat - (hex "FEDCBA9876543210")) - -(type: #export Seed - {#.doc "The seed value used for random testing (if that feature is used)."} - Nat) - -(def: #export (seed value test) - (-> Seed Test Test) - (function (_ prng) - (let [[_ result] (random.run (random.pcg32 [..pcg32_magic_inc value]) - test)] - [prng result]))) - -(def: failed? - (-> Tally Bit) - (|>> (get@ #failures) (n.> 0))) - -(def: (times_failure seed documentation) - (-> Seed Text Text) - (format documentation ..separator ..separator - "Failed with this seed: " (%.nat seed))) - -(exception: #export must_try_test_at_least_once) - -(def: #export (times amount test) - (-> Nat Test Test) - (case amount - 0 (..fail (exception.construct ..must_try_test_at_least_once [])) - _ (do random.monad - [seed random.nat] - (function (recur prng) - (let [[prng' instance] (random.run (random.pcg32 [..pcg32_magic_inc seed]) test)] - [prng' (do {! promise.monad} - [[tally documentation] instance] - (if (..failed? tally) - (wrap [tally (times_failure seed documentation)]) - (case amount - 1 instance - _ (|> test - (times (dec amount)) - (random.run prng') - product.right))))]))))) - -(def: (description duration tally) - (-> Duration Tally Text) - (let [successes (get@ #successes tally) - failures (get@ #failures tally) - missing (set.difference (get@ #actual_coverage tally) - (get@ #expected_coverage tally)) - unexpected (set.difference (get@ #expected_coverage tally) - (get@ #actual_coverage tally)) - report (: (-> (Set Name) Text) - (|>> set.to_list - (list.sort (\ name.order <)) - (exception.enumerate %.name))) - expected_definitions_to_cover (set.size (get@ #expected_coverage tally)) - unexpected_definitions_covered (set.size unexpected) - actual_definitions_covered (n.- unexpected_definitions_covered - (set.size (get@ #actual_coverage tally))) - coverage (case expected_definitions_to_cover - 0 "N/A" - expected (let [missing_ratio (f./ (n.frac expected) - (n.frac (set.size missing))) - max_percent +100.0 - done_percent (|> +1.0 - (f.- missing_ratio) - (f.* max_percent))] - (if (f.= max_percent done_percent) - "100%" - (let [raw (|> done_percent - %.frac - (text.replace_once "+" ""))] - (|> raw - (text.clip 0 (if (f.>= +10.0 done_percent) - 5 ## XX.XX - 4 ## X.XX - )) - (maybe.default raw) - (text.suffix "%"))))))] - (exception.report - ["Duration" (%.duration duration)] - ["# Tests" (%.nat (n.+ successes failures))] - ["# Successes" (%.nat successes)] - ["# Failures" (%.nat failures)] - ["# Expected definitions to cover" (%.nat expected_definitions_to_cover)] - ["# Actual definitions covered" (%.nat actual_definitions_covered)] - ["# Pending definitions to cover" (%.nat (n.- actual_definitions_covered - expected_definitions_to_cover))] - ["# Unexpected definitions covered" (%.nat unexpected_definitions_covered)] - ["Coverage" coverage] - ["Pending definitions to cover" (report missing)] - ["Unexpected definitions covered" (report unexpected)]))) - -(def: failure_exit_code +1) -(def: success_exit_code +0) - -(def: #export (run! test) - (-> Test (Promise Nothing)) - (do promise.monad - [pre (promise.future instant.now) - #let [seed (instant.to_millis pre) - prng (random.pcg32 [..pcg32_magic_inc seed])] - [tally documentation] (|> test (random.run prng) product.right) - post (promise.future instant.now) - #let [duration (instant.span pre post) - _ (debug.log! (format documentation text.new_line text.new_line - (..description duration tally) - text.new_line))]] - (promise.future (\ program.default exit - (case (get@ #failures tally) - 0 ..success_exit_code - _ ..failure_exit_code))))) - -(def: (|cover'| coverage condition) - (-> (List Name) Bit Assertion) - (let [message (|> coverage - (list\map %.name) - (text.join_with " & ")) - coverage (set.from_list name.hash coverage)] - (|> (..assert message condition) - (promise\map (function (_ [tally documentation]) - [(update@ #actual_coverage (set.union coverage) tally) - documentation]))))) - -(def: (|cover| coverage condition) - (-> (List Name) Bit Test) - (|> (..|cover'| coverage condition) - random\wrap)) - -(def: (|for| coverage test) - (-> (List Name) Test Test) - (let [context (|> coverage - (list\map %.name) - (text.join_with " & ")) - coverage (set.from_list name.hash coverage)] - (random\map (promise\map (function (_ [tally documentation]) - [(update@ #actual_coverage (set.union coverage) tally) - documentation])) - (..context context test)))) - -(def: (name_code name) - (-> Name Code) - (code.tuple (list (code.text (name.module name)) - (code.text (name.short name))))) - -(syntax: (reference {name <code>.identifier}) - (do meta.monad - [_ (meta.find_export name)] - (wrap (list (name_code name))))) - -(def: coverage_separator - Text - (text.from_code 31)) - -(def: encode_coverage - (-> (List Text) Text) - (list\fold (function (_ short aggregate) - (case aggregate - "" short - _ (format aggregate ..coverage_separator short))) - "")) - -(def: (decode_coverage module encoding) - (-> Text Text (Set Name)) - (loop [remaining encoding - output (set.from_list name.hash (list))] - (case (text.split_with ..coverage_separator remaining) - (#.Some [head tail]) - (recur tail (set.add [module head] output)) - - #.None - (set.add [module remaining] output)))) - -(template [<macro> <function>] - [(syntax: #export (<macro> {coverage (<code>.tuple (<>.many <code>.any))} - condition) - (let [coverage (list\map (function (_ definition) - (` ((~! ..reference) (~ definition)))) - coverage)] - (wrap (list (` ((~! <function>) - (: (.List .Name) - (.list (~+ coverage))) - (~ condition)))))))] - - [cover' ..|cover'|] - [cover ..|cover|] - ) - -(syntax: #export (for {coverage (<code>.tuple (<>.many <code>.any))} - test) - (let [coverage (list\map (function (_ definition) - (` ((~! ..reference) (~ definition)))) - coverage)] - (wrap (list (` ((~! ..|for|) - (: (.List .Name) - (.list (~+ coverage))) - (~ test))))))) - -(def: (covering' module coverage test) - (-> Text Text Test Test) - (let [coverage (..decode_coverage module coverage)] - (|> (..context module test) - (random\map (promise\map (function (_ [tally documentation]) - [(update@ #expected_coverage (set.union coverage) tally) - documentation])))))) - -(syntax: #export (covering {module <code>.identifier} - test) - (do meta.monad - [#let [module (name.module module)] - definitions (meta.definitions module) - #let [coverage (|> definitions - (list\fold (function (_ [short [exported? _]] aggregate) - (if exported? - (#.Cons short aggregate) - aggregate)) - #.Nil) - ..encode_coverage)]] - (wrap (list (` ((~! ..covering') - (~ (code.text module)) - (~ (code.text coverage)) - (~ test))))))) - -(exception: #export (error_during_execution {error Text}) - (exception.report - ["Error" (%.text error)])) - -(def: #export (in_parallel tests) - (-> (List Test) Test) - (case (list.size tests) - 0 - (random\wrap (promise\wrap [..start ""])) - - expected_tests - (do random.monad - [seed random.nat - #let [prng (random.pcg32 [..pcg32_magic_inc seed]) - run! (: (-> Test Assertion) - (|>> (random.run prng) - product.right - (function (_ _)) - "lux try" - (case> (#try.Success output) - output - - (#try.Failure error) - (..assert (exception.construct ..error_during_execution [error]) false)) - io.io - promise.future - promise\join)) - state (: (Atom (Dictionary Nat [Tally Text])) - (atom.atom (dictionary.new n.order))) - [read! write!] (: [Assertion - (promise.Resolver [Tally Text])] - (promise.promise [])) - _ (io.run (monad.map io.monad - (function (_ [index test]) - (promise.await (function (_ assertion) - (do io.monad - [[_ results] (atom.update (dictionary.put index assertion) state)] - (if (n.= expected_tests (dictionary.size results)) - (let [assertions (|> results - dictionary.entries - (list\map product.right))] - (write! [(|> assertions - (list\map product.left) - (list\fold ..add_tally ..start)) - (|> assertions - (list\map product.right) - (text.join_with ..separator))])) - (wrap [])))) - (run! test))) - (list.enumeration tests)))]] - (wrap read!)))) diff --git a/stdlib/source/lux/time.lux b/stdlib/source/lux/time.lux deleted file mode 100644 index 3a737f113..000000000 --- a/stdlib/source/lux/time.lux +++ /dev/null @@ -1,216 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [order (#+ Order)] - [enum (#+ Enum)] - [codec (#+ Codec)] - [monad (#+ Monad do)]] - [control - [pipe (#+ case>)] - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["<>" parser - ["<.>" text (#+ Parser)]]] - [data - ["." text ("#\." monoid)]] - [math - [number - ["n" nat ("#\." decimal)]]] - [type - abstract]] - [/ - ["." duration (#+ Duration)]]) - -(template [<name> <singular> <plural>] - [(def: #export <name> - Nat - (.nat (duration.query <singular> <plural>)))] - - [milli_seconds duration.milli_second duration.second] - [seconds duration.second duration.minute] - [minutes duration.minute duration.hour] - [hours duration.hour duration.day] - ) - -(def: limit - Nat - (.nat (duration.to_millis duration.day))) - -(exception: #export (time_exceeds_a_day {time Nat}) - (exception.report - ["Time (in milli-seconds)" (n\encode time)] - ["Maximum (in milli-seconds)" (n\encode (dec limit))])) - -(def: separator ":") - -(def: parse_section - (Parser Nat) - (<>.codec n.decimal (<text>.exactly 2 <text>.decimal))) - -(def: parse_millis - (Parser Nat) - (<>.either (|> (<text>.at_most 3 <text>.decimal) - (<>.codec n.decimal) - (<>.after (<text>.this "."))) - (\ <>.monad wrap 0))) - -(template [<maximum> <parser> <exception> <sub_parser>] - [(exception: #export (<exception> {value Nat}) - (exception.report - ["Value" (n\encode value)] - ["Minimum" (n\encode 0)] - ["Maximum" (n\encode (dec <maximum>))])) - - (def: <parser> - (Parser Nat) - (do <>.monad - [value <sub_parser>] - (if (n.< <maximum> value) - (wrap value) - (<>.lift (exception.throw <exception> [value])))))] - - [..hours parse_hour invalid_hour ..parse_section] - [..minutes parse_minute invalid_minute ..parse_section] - [..seconds parse_second invalid_second ..parse_section] - ) - -(abstract: #export Time - Nat - - {#.doc "Time is defined as milliseconds since the start of the day (00:00:00.000)."} - - (def: #export midnight - {#.doc "The instant corresponding to the start of the day: 00:00:00.000"} - Time - (:abstraction 0)) - - (def: #export (from_millis milli_seconds) - (-> Nat (Try Time)) - (if (n.< ..limit milli_seconds) - (#try.Success (:abstraction milli_seconds)) - (exception.throw ..time_exceeds_a_day [milli_seconds]))) - - (def: #export to_millis - (-> Time Nat) - (|>> :representation)) - - (implementation: #export equivalence - (Equivalence Time) - - (def: (= param subject) - (n.= (:representation param) (:representation subject)))) - - (implementation: #export order - (Order Time) - - (def: &equivalence ..equivalence) - - (def: (< param subject) - (n.< (:representation param) (:representation subject)))) - - (`` (implementation: #export enum - (Enum Time) - - (def: &order ..order) - - (def: succ - (|>> :representation inc (n.% ..limit) :abstraction)) - - (def: pred - (|>> :representation - (case> 0 ..limit - millis millis) - dec - :abstraction)))) - - (def: #export parser - (Parser Time) - (let [to_millis (: (-> Duration Nat) - (|>> duration.to_millis .nat)) - hour (to_millis duration.hour) - minute (to_millis duration.minute) - second (to_millis duration.second) - millis (to_millis duration.milli_second)] - (do {! <>.monad} - [utc_hour ..parse_hour - _ (<text>.this ..separator) - utc_minute ..parse_minute - _ (<text>.this ..separator) - utc_second ..parse_second - utc_millis ..parse_millis] - (wrap (:abstraction - ($_ n.+ - (n.* utc_hour hour) - (n.* utc_minute minute) - (n.* utc_second second) - (n.* utc_millis millis))))))) - ) - -(def: (pad value) - (-> Nat Text) - (if (n.< 10 value) - (text\compose "0" (n\encode value)) - (n\encode value))) - -(def: (adjust_negative space duration) - (-> Duration Duration Duration) - (if (duration.negative? duration) - (duration.merge space duration) - duration)) - -(def: (encode_millis millis) - (-> Nat Text) - (cond (n.= 0 millis) "" - (n.< 10 millis) ($_ text\compose ".00" (n\encode millis)) - (n.< 100 millis) ($_ text\compose ".0" (n\encode millis)) - ## (n.< 1,000 millis) - ($_ text\compose "." (n\encode millis)))) - -(type: #export Clock - {#hour Nat - #minute Nat - #second Nat - #milli_second Nat}) - -(def: #export (clock time) - (-> Time Clock) - (let [time (|> time ..to_millis .int duration.from_millis) - [hours time] [(duration.query duration.hour time) (duration.frame duration.hour time)] - [minutes time] [(duration.query duration.minute time) (duration.frame duration.minute time)] - [seconds millis] [(duration.query duration.second time) (duration.frame duration.second time)]] - {#hour (.nat hours) - #minute (.nat minutes) - #second (.nat seconds) - #milli_second (|> millis - (..adjust_negative duration.second) - duration.to_millis - .nat)})) - -(def: #export (time clock) - (-> Clock (Try Time)) - (|> ($_ duration.merge - (duration.up (get@ #hour clock) duration.hour) - (duration.up (get@ #minute clock) duration.minute) - (duration.up (get@ #second clock) duration.second) - (duration.from_millis (.int (get@ #milli_second clock)))) - duration.to_millis - .nat - ..from_millis)) - -(def: (encode time) - (-> Time Text) - (let [(^slots [#hour #minute #second #milli_second]) (..clock time)] - ($_ text\compose - (..pad hour) - ..separator (..pad minute) - ..separator (..pad second) - (..encode_millis milli_second)))) - -(implementation: #export codec - {#.doc (doc "Based on ISO 8601." - "For example: 21:14:51.827")} - (Codec Text Time) - - (def: encode ..encode) - (def: decode (<text>.run ..parser))) diff --git a/stdlib/source/lux/time/date.lux b/stdlib/source/lux/time/date.lux deleted file mode 100644 index b8b483cca..000000000 --- a/stdlib/source/lux/time/date.lux +++ /dev/null @@ -1,348 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [order (#+ Order)] - [enum (#+ Enum)] - [codec (#+ Codec)] - [monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["<>" parser - ["<text>" text (#+ Parser)]]] - [data - ["." maybe] - ["." text ("#\." monoid)] - [collection - ["." list ("#\." fold)] - ["." dictionary (#+ Dictionary)]]] - [math - [number - ["n" nat ("#\." decimal)] - ["i" int]]] - [type - abstract]] - ["." // #_ - ["#." year (#+ Year)] - ["#." month (#+ Month)]]) - -(def: month_by_number - (Dictionary Nat Month) - (list\fold (function (_ month mapping) - (dictionary.put (//month.number month) month mapping)) - (dictionary.new n.hash) - //month.year)) - -(def: minimum_day - 1) - -(def: (month_days year month) - (-> Year Month Nat) - (if (//year.leap? year) - (//month.leap_year_days month) - (//month.days month))) - -(def: (day_is_within_limits? year month day) - (-> Year Month Nat Bit) - (and (n.>= ..minimum_day day) - (n.<= (..month_days year month) day))) - -(exception: #export (invalid_day {year Year} {month Month} {day Nat}) - (exception.report - ["Value" (n\encode day)] - ["Minimum" (n\encode ..minimum_day)] - ["Maximum" (n\encode (..month_days year month))] - ["Year" (\ //year.codec encode year)] - ["Month" (n\encode (//month.number month))])) - -(def: (pad value) - (-> Nat Text) - (let [digits (n\encode value)] - (if (n.< 10 value) - (text\compose "0" digits) - digits))) - -(def: separator - "-") - -(abstract: #export Date - {#year Year - #month Month - #day Nat} - - (def: #export (date year month day) - (-> Year Month Nat (Try Date)) - (if (..day_is_within_limits? year month day) - (#try.Success - (:abstraction - {#year year - #month month - #day day})) - (exception.throw ..invalid_day [year month day]))) - - (def: #export epoch - Date - (try.assume (..date //year.epoch - #//month.January - ..minimum_day))) - - (template [<name> <type> <field>] - [(def: #export <name> - (-> Date <type>) - (|>> :representation (get@ <field>)))] - - [year Year #year] - [month Month #month] - [day_of_month Nat #day] - ) - - (implementation: #export equivalence - (Equivalence Date) - - (def: (= reference sample) - (let [reference (:representation reference) - sample (:representation sample)] - (and (\ //year.equivalence = - (get@ #year reference) - (get@ #year sample)) - (\ //month.equivalence = - (get@ #month reference) - (get@ #month sample)) - (n.= (get@ #day reference) - (get@ #day sample)))))) - - (implementation: #export order - (Order Date) - - (def: &equivalence ..equivalence) - - (def: (< reference sample) - (let [reference (:representation reference) - sample (:representation sample)] - (or (\ //year.order < - (get@ #year reference) - (get@ #year sample)) - (and (\ //year.equivalence = - (get@ #year reference) - (get@ #year sample)) - (or (\ //month.order < - (get@ #month reference) - (get@ #month sample)) - (and (\ //month.order = - (get@ #month reference) - (get@ #month sample)) - (n.< (get@ #day reference) - (get@ #day sample))))))))) - ) - -(def: parse_section - (Parser Nat) - (<>.codec n.decimal (<text>.exactly 2 <text>.decimal))) - -(def: parse_millis - (Parser Nat) - (<>.either (|> (<text>.at_most 3 <text>.decimal) - (<>.codec n.decimal) - (<>.after (<text>.this "."))) - (\ <>.monad wrap 0))) - -(template [<minimum> <maximum> <parser> <exception>] - [(exception: #export (<exception> {value Nat}) - (exception.report - ["Value" (n\encode value)] - ["Minimum" (n\encode <minimum>)] - ["Maximum" (n\encode <maximum>)])) - - (def: <parser> - (Parser Nat) - (do <>.monad - [value ..parse_section] - (if (and (n.>= <minimum> value) - (n.<= <maximum> value)) - (wrap value) - (<>.lift (exception.throw <exception> [value])))))] - - [1 12 parse_month invalid_month] - ) - -(def: #export parser - (Parser Date) - (do <>.monad - [utc_year //year.parser - _ (<text>.this ..separator) - utc_month ..parse_month - _ (<text>.this ..separator) - #let [month (maybe.assume (dictionary.get utc_month ..month_by_number))] - utc_day ..parse_section] - (<>.lift (..date utc_year month utc_day)))) - -(def: (encode value) - (-> Date Text) - ($_ text\compose - (\ //year.codec encode (..year value)) - ..separator (..pad (|> value ..month //month.number)) - ..separator (..pad (..day_of_month value)))) - -(implementation: #export codec - {#.doc (doc "Based on ISO 8601." - "For example: 2017-01-15")} - (Codec Text Date) - - (def: encode ..encode) - (def: decode (<text>.run ..parser))) - -(def: days_per_leap - (|> //year.days - (n.* 4) - (n.+ 1))) - -(def: days_per_century - (let [leaps_per_century (n./ //year.leap - //year.century)] - (|> //year.century - (n.* //year.days) - (n.+ leaps_per_century) - (n.- 1)))) - -(def: days_per_era - (let [centuries_per_era (n./ //year.century - //year.era)] - (|> centuries_per_era - (n.* ..days_per_century) - (n.+ 1)))) - -(def: days_since_epoch - (let [years::70 70 - leaps::70 (n./ //year.leap - years::70) - days::70 (|> years::70 - (n.* //year.days) - (n.+ leaps::70)) - ## The epoch is being calculated from March 1st, instead of January 1st. - january_&_february (n.+ (//month.days #//month.January) - (//month.days #//month.February))] - (|> 0 - ## 1600/01/01 - (n.+ (n.* 4 days_per_era)) - ## 1900/01/01 - (n.+ (n.* 3 days_per_century)) - ## 1970/01/01 - (n.+ days::70) - ## 1970/03/01 - (n.- january_&_february)))) - -(def: first_month_of_civil_year 3) - -(with_expansions [<pull> +3 - <push> +9] - (def: (internal_month civil_month) - (-> Nat Int) - (if (n.< ..first_month_of_civil_year civil_month) - (i.+ <push> (.int civil_month)) - (i.- <pull> (.int civil_month)))) - - (def: (civil_month internal_month) - (-> Int Nat) - (.nat (if (i.< +10 internal_month) - (i.+ <pull> internal_month) - (i.- <push> internal_month))))) - -(with_expansions [<up> +153 - <translation> +2 - <down> +5] - (def: day_of_year_from_month - (-> Nat Int) - (|>> ..internal_month - (i.* <up>) - (i.+ <translation>) - (i./ <down>))) - - (def: month_from_day_of_year - (-> Int Nat) - (|>> (i.* <down>) - (i.+ <translation>) - (i./ <up>) - ..civil_month))) - -(def: last_era_leap_day - (.int (dec ..days_per_leap))) - -(def: last_era_day - (.int (dec ..days_per_era))) - -(def: (civil_year utc_month utc_year) - (-> Nat Year Int) - (let [## Coercing, because the year is already in external form. - utc_year (:as Int utc_year)] - (if (n.< ..first_month_of_civil_year utc_month) - (dec utc_year) - utc_year))) - -## http://howardhinnant.github.io/date_algorithms.html -(def: #export (to_days date) - (-> Date Int) - (let [utc_month (|> date ..month //month.number) - civil_year (..civil_year utc_month (..year date)) - era (|> (if (i.< +0 civil_year) - (i.- (.int (dec //year.era)) - civil_year) - civil_year) - (i./ (.int //year.era))) - year_of_era (i.- (i.* (.int //year.era) - era) - civil_year) - day_of_year (|> utc_month - ..day_of_year_from_month - (i.+ (.int (dec (..day_of_month date))))) - day_of_era (|> day_of_year - (i.+ (i.* (.int //year.days) year_of_era)) - (i.+ (i./ (.int //year.leap) year_of_era)) - (i.- (i./ (.int //year.century) year_of_era)))] - (|> (i.* (.int ..days_per_era) era) - (i.+ day_of_era) - (i.- (.int ..days_since_epoch))))) - -## http://howardhinnant.github.io/date_algorithms.html -(def: #export (from_days days) - (-> Int Date) - (let [days (i.+ (.int ..days_since_epoch) days) - era (|> (if (i.< +0 days) - (i.- ..last_era_day days) - days) - (i./ (.int ..days_per_era))) - day_of_era (i.- (i.* (.int ..days_per_era) era) days) - year_of_era (|> day_of_era - (i.- (i./ ..last_era_leap_day day_of_era)) - (i.+ (i./ (.int ..days_per_century) day_of_era)) - (i.- (i./ ..last_era_day day_of_era)) - (i./ (.int //year.days))) - year (i.+ (i.* (.int //year.era) era) - year_of_era) - day_of_year (|> day_of_era - (i.- (i.* (.int //year.days) year_of_era)) - (i.- (i./ (.int //year.leap) year_of_era)) - (i.+ (i./ (.int //year.century) year_of_era))) - month (..month_from_day_of_year day_of_year) - day (|> day_of_year - (i.- (..day_of_year_from_month month)) - (i.+ +1) - .nat) - year (if (n.< ..first_month_of_civil_year month) - (inc year) - year)] - ## Coercing, because the year is already in internal form. - (try.assume (..date (:as Year year) - (maybe.assume (dictionary.get month ..month_by_number)) - day)))) - -(implementation: #export enum - (Enum Date) - - (def: &order ..order) - - (def: succ - (|>> ..to_days inc ..from_days)) - - (def: pred - (|>> ..to_days dec ..from_days))) diff --git a/stdlib/source/lux/time/day.lux b/stdlib/source/lux/time/day.lux deleted file mode 100644 index 57c0fae13..000000000 --- a/stdlib/source/lux/time/day.lux +++ /dev/null @@ -1,120 +0,0 @@ -(.module: - [lux (#- nat) - [abstract - [equivalence (#+ Equivalence)] - [order (#+ Order)] - [enum (#+ Enum)] - [codec (#+ Codec)]] - [control - ["." try] - ["." exception (#+ exception:)]] - [data - ["." text]] - [macro - ["." template]] - [math - [number - ["n" nat]]]]) - -(type: #export Day - #Sunday - #Monday - #Tuesday - #Wednesday - #Thursday - #Friday - #Saturday) - -(implementation: #export equivalence - (Equivalence Day) - - (def: (= reference sample) - (case [reference sample] - (^template [<tag>] - [[<tag> <tag>] - #1]) - ([#Sunday] - [#Monday] - [#Tuesday] - [#Wednesday] - [#Thursday] - [#Friday] - [#Saturday]) - - _ - #0))) - -(def: (nat day) - (-> Day Nat) - (case day - #Sunday 0 - #Monday 1 - #Tuesday 2 - #Wednesday 3 - #Thursday 4 - #Friday 5 - #Saturday 6)) - -(implementation: #export order - (Order Day) - - (def: &equivalence ..equivalence) - - (def: (< reference sample) - (n.< (..nat reference) (..nat sample)))) - -(implementation: #export enum - (Enum Day) - - (def: &order ..order) - - (def: (succ day) - (case day - #Sunday #Monday - #Monday #Tuesday - #Tuesday #Wednesday - #Wednesday #Thursday - #Thursday #Friday - #Friday #Saturday - #Saturday #Sunday)) - - (def: (pred day) - (case day - #Monday #Sunday - #Tuesday #Monday - #Wednesday #Tuesday - #Thursday #Wednesday - #Friday #Thursday - #Saturday #Friday - #Sunday #Saturday))) - -(exception: #export (not_a_day_of_the_week {value Text}) - (exception.report - ["Value" (text.format value)])) - -(implementation: #export codec - (Codec Text Day) - - (def: (encode value) - (case value - (^template [<tag>] - [<tag> (template.text [<tag>])]) - ([#..Monday] - [#..Tuesday] - [#..Wednesday] - [#..Thursday] - [#..Friday] - [#..Saturday] - [#..Sunday]))) - (def: (decode value) - (case value - (^template [<tag>] - [(^ (template.text [<tag>])) (#try.Success <tag>)]) - ([#..Monday] - [#..Tuesday] - [#..Wednesday] - [#..Thursday] - [#..Friday] - [#..Saturday] - [#..Sunday]) - _ (exception.throw ..not_a_day_of_the_week [value])))) diff --git a/stdlib/source/lux/time/duration.lux b/stdlib/source/lux/time/duration.lux deleted file mode 100644 index f1fcd932c..000000000 --- a/stdlib/source/lux/time/duration.lux +++ /dev/null @@ -1,202 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [order (#+ Order)] - [enum (#+ Enum)] - [codec (#+ Codec)] - [monoid (#+ Monoid)] - [monad (#+ do)]] - [control - ["." try] - ["<>" parser - ["<t>" text (#+ Parser)]]] - [data - ["." text ("#\." monoid)]] - [math - [number - ["i" int] - ["." nat ("#\." decimal)]]] - [type - abstract]] - ["." // #_ - ["#." year]]) - -(abstract: #export Duration - Int - - {#.doc "Durations have a resolution of milli-seconds."} - - (def: #export from_millis - (-> Int Duration) - (|>> :abstraction)) - - (def: #export to_millis - (-> Duration Int) - (|>> :representation)) - - (template [<op> <name>] - [(def: #export (<name> param subject) - (-> Duration Duration Duration) - (:abstraction (<op> (:representation param) (:representation subject))))] - - [i.+ merge] - [i.% frame] - ) - - (template [<op> <name>] - [(def: #export (<name> scalar) - (-> Nat Duration Duration) - (|>> :representation (<op> (.int scalar)) :abstraction))] - - [i.* up] - [i./ down] - ) - - (def: #export inverse - (-> Duration Duration) - (|>> :representation (i.* -1) :abstraction)) - - (def: #export (query param subject) - (-> Duration Duration Int) - (i./ (:representation param) (:representation subject))) - - (implementation: #export equivalence - (Equivalence Duration) - - (def: (= param subject) - (i.= (:representation param) (:representation subject)))) - - (implementation: #export order - (Order Duration) - - (def: &equivalence ..equivalence) - (def: (< param subject) - (i.< (:representation param) (:representation subject)))) - - (template [<op> <name>] - [(def: #export <name> - (-> Duration Bit) - (|>> :representation (<op> +0)))] - - [i.> positive?] - [i.< negative?] - [i.= neutral?] - ) - ) - -(def: #export empty - (..from_millis +0)) - -(def: #export milli_second - (..from_millis +1)) - -(template [<name> <scale> <base>] - [(def: #export <name> - (..up <scale> <base>))] - - [second 1,000 milli_second] - [minute 60 second] - [hour 60 minute] - [day 24 hour] - - [week 7 day] - [normal_year //year.days day] - ) - -(def: #export leap_year - (..merge ..day ..normal_year)) - -(implementation: #export monoid - (Monoid Duration) - - (def: identity ..empty) - (def: compose ..merge)) - -(template [<value> <definition>] - [(def: <definition> <value>)] - - ["D" day_suffix] - ["h" hour_suffix] - ["m" minute_suffix] - ["s" second_suffix] - ["ms" milli_second_suffix] - - ["+" positive_sign] - ["-" negative_sign] - ) - -(def: (encode duration) - (if (\ ..equivalence = ..empty duration) - ($_ text\compose - ..positive_sign - (nat\encode 0) - ..milli_second_suffix) - (let [signed? (negative? duration) - [days time_left] [(query day duration) (frame day duration)] - days (if signed? - (i.abs days) - days) - time_left (if signed? - (..inverse time_left) - time_left) - [hours time_left] [(query hour time_left) (frame hour time_left)] - [minutes time_left] [(query minute time_left) (frame minute time_left)] - [seconds time_left] [(query second time_left) (frame second time_left)] - millis (to_millis time_left)] - ($_ text\compose - (if signed? ..negative_sign ..positive_sign) - (if (i.= +0 days) "" (text\compose (nat\encode (.nat days)) ..day_suffix)) - (if (i.= +0 hours) "" (text\compose (nat\encode (.nat hours)) ..hour_suffix)) - (if (i.= +0 minutes) "" (text\compose (nat\encode (.nat minutes)) ..minute_suffix)) - (if (i.= +0 seconds) "" (text\compose (nat\encode (.nat seconds)) ..second_suffix)) - (if (i.= +0 millis) "" (text\compose (nat\encode (.nat millis)) ..milli_second_suffix)) - )))) - -(def: parser - (Parser Duration) - (let [section (: (-> Text Text (Parser Nat)) - (function (_ suffix false_suffix) - (|> (<t>.many <t>.decimal) - (<>.codec nat.decimal) - (<>.before (case false_suffix - "" (<t>.this suffix) - _ (<>.after (<>.not (<t>.this false_suffix)) - (<t>.this suffix)))) - (<>.default 0))))] - (do <>.monad - [sign (<>.or (<t>.this ..negative_sign) - (<t>.this ..positive_sign)) - days (section ..day_suffix "") - hours (section hour_suffix "") - minutes (section ..minute_suffix ..milli_second_suffix) - seconds (section ..second_suffix "") - millis (section ..milli_second_suffix "") - #let [span (|> ..empty - (..merge (..up days ..day)) - (..merge (..up hours ..hour)) - (..merge (..up minutes ..minute)) - (..merge (..up seconds ..second)) - (..merge (..up millis ..milli_second)))]] - (wrap (case sign - (#.Left _) (..inverse span) - (#.Right _) span))))) - -(implementation: #export codec - (Codec Text Duration) - - (def: encode ..encode) - (def: decode (<t>.run ..parser))) - -(def: #export (difference from to) - (-> Duration Duration Duration) - (|> from ..inverse (..merge to))) - -(implementation: #export enum - (Enum Duration) - - (def: &order ..order) - (def: succ - (..merge ..milli_second)) - (def: pred - (..merge (..inverse ..milli_second)))) diff --git a/stdlib/source/lux/time/instant.lux b/stdlib/source/lux/time/instant.lux deleted file mode 100644 index 05f54b30b..000000000 --- a/stdlib/source/lux/time/instant.lux +++ /dev/null @@ -1,234 +0,0 @@ -(.module: - [lux #* - ["@" target] - [abstract - [equivalence (#+ Equivalence)] - [order (#+ Order)] - [enum (#+ Enum)] - [codec (#+ Codec)] - [monad (#+ Monad do)]] - [control - [io (#+ IO io)] - ["." try] - ["." exception (#+ exception:)] - ["<>" parser - ["<.>" text (#+ Parser)]]] - [data - ["." maybe] - ["." text ("#\." monoid)] - [collection - ["." row]]] - [math - [number - ["i" int] - ["f" frac]]] - [type - abstract]] - ["." // (#+ Time) - ["." duration (#+ Duration)] - ["." year (#+ Year)] - ["." month (#+ Month)] - ["." day (#+ Day)] - ["." date (#+ Date)]]) - -(abstract: #export Instant - Int - - {#.doc "Instant is defined as milliseconds since the epoch."} - - (def: #export from_millis - (-> Int Instant) - (|>> :abstraction)) - - (def: #export to_millis - (-> Instant Int) - (|>> :representation)) - - (def: #export (span from to) - (-> Instant Instant Duration) - (duration.from_millis (i.- (:representation from) (:representation to)))) - - (def: #export (shift duration instant) - (-> Duration Instant Instant) - (:abstraction (i.+ (duration.to_millis duration) (:representation instant)))) - - (def: #export (relative instant) - (-> Instant Duration) - (|> instant :representation duration.from_millis)) - - (def: #export (absolute offset) - (-> Duration Instant) - (|> offset duration.to_millis :abstraction)) - - (implementation: #export equivalence - (Equivalence Instant) - - (def: (= param subject) - (\ i.equivalence = (:representation param) (:representation subject)))) - - (implementation: #export order - (Order Instant) - - (def: &equivalence ..equivalence) - (def: (< param subject) - (\ i.order < (:representation param) (:representation subject)))) - - (`` (implementation: #export enum - (Enum Instant) - - (def: &order ..order) - (~~ (template [<name>] - [(def: <name> - (|>> :representation (\ i.enum <name>) :abstraction))] - - [succ] [pred] - )))) - ) - -(def: #export epoch - {#.doc "The instant corresponding to 1970-01-01T00:00:00Z"} - Instant - (..from_millis +0)) - -(def: millis_per_day - (duration.query duration.milli_second duration.day)) - -(def: (split_date_time instant) - (-> Instant [Date Duration]) - (let [offset (..to_millis instant) - bce? (i.< +0 offset) - [days day_time] (if bce? - (let [[days millis] (i./% ..millis_per_day offset)] - (case millis - +0 [days millis] - _ [(dec days) (i.+ ..millis_per_day millis)])) - (i./% ..millis_per_day offset))] - [(date.from_days days) - (duration.from_millis day_time)])) - -(template [<value> <definition>] - [(def: <definition> Text <value>)] - - ["T" date_suffix] - ["Z" time_suffix] - ) - -(def: (clock_time duration) - (-> Duration Time) - (let [time (if (\ duration.order < duration.empty duration) - (duration.merge duration.day duration) - duration)] - (|> time duration.to_millis .nat //.from_millis try.assume))) - -(def: (encode instant) - (-> Instant Text) - (let [[date time] (..split_date_time instant) - time (..clock_time time)] - ($_ text\compose - (\ date.codec encode date) ..date_suffix - (\ //.codec encode time) ..time_suffix))) - -(def: parser - (Parser Instant) - (do {! <>.monad} - [days (\ ! map date.to_days date.parser) - _ (<text>.this ..date_suffix) - time (\ ! map //.to_millis //.parser) - _ (<text>.this ..time_suffix)] - (wrap (|> (if (i.< +0 days) - (|> duration.day - (duration.up (.nat (i.* -1 days))) - duration.inverse) - (duration.up (.nat days) duration.day)) - (duration.merge (duration.up time duration.milli_second)) - ..absolute)))) - -(implementation: #export codec - {#.doc (doc "Based on ISO 8601." - "For example: 2017-01-15T21:14:51.827Z")} - (Codec Text Instant) - - (def: encode ..encode) - (def: decode (<text>.run ..parser))) - -(def: #export now - (IO Instant) - (io (..from_millis (for {@.old ("jvm invokestatic:java.lang.System:currentTimeMillis:") - @.jvm (|> ("jvm member invoke static" [] "java.lang.System" "currentTimeMillis" []) - ("jvm object cast") - (: (primitive "java.lang.Long")) - (:as Int)) - @.js (let [date ("js object new" ("js constant" "Date") [])] - (|> ("js object do" "getTime" date []) - (:as Frac) - "lux f64 i64")) - @.python (let [time ("python import" "time")] - (|> ("python object do" "time" time) - (:as Frac) - (f.* +1,000.0) - "lux f64 i64")) - @.lua (|> ("lua constant" "os.time") - "lua apply" - (:as Int) - (i.* +1,000)) - @.ruby (let [% ("ruby constant" "Time") - % ("ruby object do" "now" %)] - (|> ("ruby object do" "to_f" %) - (:as Frac) - (f.* +1,000.0) - "lux f64 i64")) - @.php (|> ("php constant" "time") - "php apply" - (:as Int) - (i.* +1,000)) - @.scheme (|> ("scheme constant" "current-second") - (:as Int) - (i.* +1,000) - ("scheme apply" ("scheme constant" "exact")) - ("scheme apply" ("scheme constant" "truncate"))) - @.common_lisp (|> ("common_lisp constant" "get-universal-time") - "common_lisp apply" - (:as Int) - (i.* +1,000)) - })))) - -(template [<field> <type> <post_processing>] - [(def: #export (<field> instant) - (-> Instant <type>) - (let [[date time] (..split_date_time instant)] - (|> <field> <post_processing>)))] - - [date Date (|>)] - [time Time ..clock_time] - ) - -(def: #export (day_of_week instant) - (-> Instant Day) - (let [offset (..relative instant) - days (duration.query duration.day offset) - day_time (duration.frame duration.day offset) - days (if (and (duration.negative? offset) - (not (duration.neutral? day_time))) - (dec days) - days) - ## 1970/01/01 was a Thursday - y1970m0d0 +4] - (case (|> y1970m0d0 - (i.+ days) (i.% +7) - ## This is done to turn negative days into positive days. - (i.+ +7) (i.% +7)) - +0 #day.Sunday - +1 #day.Monday - +2 #day.Tuesday - +3 #day.Wednesday - +4 #day.Thursday - +5 #day.Friday - +6 #day.Saturday - _ (undefined)))) - -(def: #export (from_date_time date time) - (-> Date Time Instant) - (|> (date.to_days date) - (i.* (duration.to_millis duration.day)) - (i.+ (.int (//.to_millis time))) - ..from_millis)) diff --git a/stdlib/source/lux/time/month.lux b/stdlib/source/lux/time/month.lux deleted file mode 100644 index 6848f4869..000000000 --- a/stdlib/source/lux/time/month.lux +++ /dev/null @@ -1,224 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)] - [order (#+ Order)] - [enum (#+ Enum)] - [codec (#+ Codec)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["." text]] - [macro - ["." template]] - [math - [number - ["n" nat]]]]) - -(type: #export Month - #January - #February - #March - #April - #May - #June - #July - #August - #September - #October - #November - #December) - -(implementation: #export equivalence - (Equivalence Month) - - (def: (= reference sample) - (case [reference sample] - (^template [<tag>] - [[<tag> <tag>] - true]) - ([#January] - [#February] - [#March] - [#April] - [#May] - [#June] - [#July] - [#August] - [#September] - [#October] - [#November] - [#December]) - - _ - false))) - -(with_expansions [<pairs> (as_is [01 #January] - [02 #February] - [03 #March] - [04 #April] - [05 #May] - [06 #June] - [07 #July] - [08 #August] - [09 #September] - [10 #October] - [11 #November] - [12 #December])] - (def: #export (number month) - (-> Month Nat) - (case month - (^template [<number> <month>] - [<month> <number>]) - (<pairs>))) - - (exception: #export (invalid_month {number Nat}) - (exception.report - ["Number" (\ n.decimal encode number)] - ["Valid range" ($_ "lux text concat" - (\ n.decimal encode (..number #January)) - " ~ " - (\ n.decimal encode (..number #December)))])) - - (def: #export (by_number number) - (-> Nat (Try Month)) - (case number - (^template [<number> <month>] - [<number> (#try.Success <month>)]) - (<pairs>) - _ (exception.throw ..invalid_month [number]))) - ) - -(implementation: #export hash - (Hash Month) - - (def: &equivalence ..equivalence) - (def: hash ..number)) - -(implementation: #export order - (Order Month) - - (def: &equivalence ..equivalence) - - (def: (< reference sample) - (n.< (..number reference) (..number sample)))) - -(implementation: #export enum - (Enum Month) - - (def: &order ..order) - - (def: (succ month) - (case month - #January #February - #February #March - #March #April - #April #May - #May #June - #June #July - #July #August - #August #September - #September #October - #October #November - #November #December - #December #January)) - - (def: (pred month) - (case month - #February #January - #March #February - #April #March - #May #April - #June #May - #July #June - #August #July - #September #August - #October #September - #November #October - #December #November - #January #December))) - -(def: #export (days month) - (-> Month Nat) - (case month - (^template [<days> <month>] - [<month> <days>]) - ([31 #January] - [28 #February] - [31 #March] - - [30 #April] - [31 #May] - [30 #June] - - [31 #July] - [31 #August] - [30 #September] - - [31 #October] - [30 #November] - [31 #December]))) - -(def: #export (leap_year_days month) - (-> Month Nat) - (case month - #February (inc (..days month)) - _ (..days month))) - -(def: #export year - (List Month) - (list #January - #February - #March - #April - #May - #June - #July - #August - #September - #October - #November - #December)) - -(exception: #export (not_a_month_of_the_year {value Text}) - (exception.report - ["Value" (text.format value)])) - -(implementation: #export codec - (Codec Text Month) - - (def: (encode value) - (case value - (^template [<tag>] - [<tag> (template.text [<tag>])]) - ([#..January] - [#..February] - [#..March] - [#..April] - [#..May] - [#..June] - [#..July] - [#..August] - [#..September] - [#..October] - [#..November] - [#..December]))) - (def: (decode value) - (case value - (^template [<tag>] - [(^ (template.text [<tag>])) (#try.Success <tag>)]) - ([#..January] - [#..February] - [#..March] - [#..April] - [#..May] - [#..June] - [#..July] - [#..August] - [#..September] - [#..October] - [#..November] - [#..December]) - _ (exception.throw ..not_a_month_of_the_year [value])))) diff --git a/stdlib/source/lux/time/year.lux b/stdlib/source/lux/time/year.lux deleted file mode 100644 index 633045510..000000000 --- a/stdlib/source/lux/time/year.lux +++ /dev/null @@ -1,141 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)] - [codec (#+ Codec)] - [equivalence (#+ Equivalence)] - [order (#+ Order)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["<>" parser - ["<t>" text (#+ Parser)]]] - [data - ["." text ("#\." monoid)]] - [math - [number - ["n" nat ("#\." decimal)] - ["i" int ("#\." decimal)]]] - [type - abstract]]) - -(def: (internal year) - (-> Int Int) - (if (i.< +0 year) - (inc year) - year)) - -(def: (external year) - (-> Int Int) - (if (i.> +0 year) - year - (dec year))) - -(exception: #export there-is-no-year-0) - -(abstract: #export Year - Int - - (def: #export (year value) - (-> Int (Try Year)) - (case value - +0 (exception.throw ..there-is-no-year-0 []) - _ (#try.Success (:abstraction (..internal value))))) - - (def: #export value - (-> Year Int) - (|>> :representation ..external)) - - (def: #export epoch - Year - (:abstraction +1970)) - ) - -(def: #export days - 365) - -(type: #export Period - Nat) - -(template [<period> <name>] - [(def: #export <name> - Period - <period>)] - - [004 leap] - [100 century] - [400 era] - ) - -(def: (divisible? factor input) - (-> Int Int Bit) - (|> input (i.% factor) (i.= +0))) - -## https://en.wikipedia.org/wiki/Leap_year#Algorithm -(def: #export (leap? year) - (-> Year Bit) - (let [year (|> year ..value ..internal)] - (and (..divisible? (.int ..leap) year) - (or (not (..divisible? (.int ..century) year)) - (..divisible? (.int ..era) year))))) - -(def: (with-year-0-leap year days) - (let [after-year-0? (i.> +0 year)] - (if after-year-0? - (i.+ +1 days) - days))) - -(def: #export (leaps year) - (-> Year Int) - (let [year (|> year ..value ..internal) - limit (if (i.> +0 year) - (dec year) - (inc year))] - (`` (|> +0 - (~~ (template [<polarity> <years>] - [(<polarity> (i./ (.int <years>) limit))] - - [i.+ ..leap] - [i.- ..century] - [i.+ ..era] - )) - (..with-year-0-leap year))))) - -(def: (encode year) - (-> Year Text) - (let [year (..value year)] - (if (i.< +0 year) - (i\encode year) - (n\encode (.nat year))))) - -(def: #export parser - (Parser Year) - (do {! <>.monad} - [sign (<>.or (<t>.this "-") (wrap [])) - digits (<t>.many <t>.decimal) - raw-year (<>.codec i.decimal (wrap (text\compose "+" digits)))] - (<>.lift (..year (case sign - (#.Left _) (i.* -1 raw-year) - (#.Right _) raw-year))))) - -(implementation: #export codec - {#.doc (doc "Based on ISO 8601." - "For example: 2017")} - (Codec Text Year) - - (def: encode ..encode) - (def: decode (<t>.run ..parser))) - -(implementation: #export equivalence - (Equivalence Year) - - (def: (= reference subject) - (i.= (..value reference) (..value subject)))) - -(implementation: #export order - (Order Year) - - (def: &equivalence ..equivalence) - - (def: (< reference subject) - (i.< (..value reference) (..value subject)))) diff --git a/stdlib/source/lux/tool/compiler.lux b/stdlib/source/lux/tool/compiler.lux deleted file mode 100644 index eda74d121..000000000 --- a/stdlib/source/lux/tool/compiler.lux +++ /dev/null @@ -1,46 +0,0 @@ -(.module: - [lux (#- Module Code) - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - [binary (#+ Binary)] - ["." text] - [collection - ["." row (#+ Row)]]] - [world - ["." file (#+ Path)]]] - [/ - [meta - ["." archive (#+ Output Archive) - [key (#+ Key)] - [descriptor (#+ Descriptor Module)] - [document (#+ Document)]]]]) - -(type: #export Code - Text) - -(type: #export Parameter - Text) - -(type: #export Input - {#module Module - #file Path - #hash Nat - #code Code}) - -(type: #export (Compilation s d o) - {#dependencies (List Module) - #process (-> s Archive - (Try [s (Either (Compilation s d o) - [Descriptor (Document d) Output])]))}) - -(type: #export (Compiler s d o) - (-> Input (Compilation s d o))) - -(type: #export (Instancer s d o) - (-> (Key d) (List Parameter) (Compiler s d o))) - -(exception: #export (cannot_compile {module Module}) - (exception.report - ["Module" module])) diff --git a/stdlib/source/lux/tool/compiler/arity.lux b/stdlib/source/lux/tool/compiler/arity.lux deleted file mode 100644 index 72140b6c6..000000000 --- a/stdlib/source/lux/tool/compiler/arity.lux +++ /dev/null @@ -1,15 +0,0 @@ -(.module: - [lux #* - [math - [number - ["n" nat]]]]) - -(type: #export Arity Nat) - -(template [<comparison> <name>] - [(def: #export <name> (-> Arity Bit) (<comparison> 1))] - - [n.< nullary?] - [n.= unary?] - [n.> multiary?] - ) diff --git a/stdlib/source/lux/tool/compiler/default/init.lux b/stdlib/source/lux/tool/compiler/default/init.lux deleted file mode 100644 index 2803398e0..000000000 --- a/stdlib/source/lux/tool/compiler/default/init.lux +++ /dev/null @@ -1,286 +0,0 @@ -(.module: - [lux (#- Module) - ["@" target (#+ Target)] - [abstract - ["." monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - [binary (#+ Binary)] - ["." product] - ["." text ("#\." hash) - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)] - ["." dictionary] - ["." set] - ["." row ("#\." functor)]]] - ["." meta] - [world - ["." file]]] - ["." // #_ - ["/#" // (#+ Instancer) - ["#." phase] - [language - [lux - [program (#+ Program)] - ["#." version] - ["#." syntax (#+ Aliases)] - ["#." synthesis] - ["#." directive (#+ Requirements)] - ["#." generation] - ["#." analysis - [macro (#+ Expander)] - ["#/." evaluation]] - [phase - [".P" synthesis] - [".P" directive] - [".P" analysis - ["." module]] - ["." extension (#+ Extender) - [".E" analysis] - [".E" synthesis] - [directive - [".D" lux]]]]]] - [meta - ["." archive (#+ Archive) - ["." descriptor (#+ Module)] - ["." artifact] - ["." document]]]]]) - -(def: #export (state target module expander host_analysis host generate generation_bundle) - (All [anchor expression directive] - (-> Target - Module - Expander - ///analysis.Bundle - (///generation.Host expression directive) - (///generation.Phase anchor expression directive) - (///generation.Bundle anchor expression directive) - (///directive.State+ anchor expression directive))) - (let [synthesis_state [synthesisE.bundle ///synthesis.init] - generation_state [generation_bundle (///generation.state host module)] - eval (///analysis/evaluation.evaluator expander synthesis_state generation_state generate) - analysis_state [(analysisE.bundle eval host_analysis) - (///analysis.state (///analysis.info ///version.version target))]] - [extension.empty - {#///directive.analysis {#///directive.state analysis_state - #///directive.phase (analysisP.phase expander)} - #///directive.synthesis {#///directive.state synthesis_state - #///directive.phase synthesisP.phase} - #///directive.generation {#///directive.state generation_state - #///directive.phase generate}}])) - -(def: #export (with_default_directives expander host_analysis program anchorT,expressionT,directiveT extender) - (All [anchor expression directive] - (-> Expander - ///analysis.Bundle - (Program expression directive) - [Type Type Type] - Extender - (-> (///directive.State+ anchor expression directive) - (///directive.State+ anchor expression directive)))) - (function (_ [directive_extensions sub_state]) - [(dictionary.merge directive_extensions - (luxD.bundle expander host_analysis program anchorT,expressionT,directiveT extender)) - sub_state])) - -(type: Reader - (-> Source (Either [Source Text] [Source Code]))) - -(def: (reader current_module aliases [location offset source_code]) - (-> Module Aliases Source (///analysis.Operation Reader)) - (function (_ [bundle state]) - (#try.Success [[bundle state] - (///syntax.parse current_module aliases ("lux text size" source_code))]))) - -(def: (read source reader) - (-> Source Reader (///analysis.Operation [Source Code])) - (function (_ [bundle compiler]) - (case (reader source) - (#.Left [source' error]) - (#try.Failure error) - - (#.Right [source' output]) - (let [[location _] output] - (#try.Success [[bundle (|> compiler - (set@ #.source source') - (set@ #.location location))] - [source' output]]))))) - -(type: (Operation a) - (All [anchor expression directive] - (///directive.Operation anchor expression directive a))) - -(type: (Payload directive) - [(///generation.Buffer directive) - artifact.Registry]) - -(def: (begin dependencies hash input) - (-> (List Module) Nat ///.Input - (All [anchor expression directive] - (///directive.Operation anchor expression directive - [Source (Payload directive)]))) - (do ///phase.monad - [#let [module (get@ #///.module input)] - _ (///directive.set_current_module module)] - (///directive.lift_analysis - (do {! ///phase.monad} - [_ (module.create hash module) - _ (monad.map ! module.import dependencies) - #let [source (///analysis.source (get@ #///.module input) (get@ #///.code input))] - _ (///analysis.set_source_code source)] - (wrap [source [///generation.empty_buffer - artifact.empty]]))))) - -(def: (end module) - (-> Module - (All [anchor expression directive] - (///directive.Operation anchor expression directive [.Module (Payload directive)]))) - (do ///phase.monad - [_ (///directive.lift_analysis - (module.set_compiled module)) - analysis_module (<| (: (Operation .Module)) - ///directive.lift_analysis - extension.lift - meta.current_module) - final_buffer (///directive.lift_generation - ///generation.buffer) - final_registry (///directive.lift_generation - ///generation.get_registry)] - (wrap [analysis_module [final_buffer - final_registry]]))) - -## TODO: Inline ASAP -(def: (get_current_payload _) - (All [directive] - (-> (Payload directive) - (All [anchor expression] - (///directive.Operation anchor expression directive - (Payload directive))))) - (do ///phase.monad - [buffer (///directive.lift_generation - ///generation.buffer) - registry (///directive.lift_generation - ///generation.get_registry)] - (wrap [buffer registry]))) - -## TODO: Inline ASAP -(def: (process_directive archive expander pre_payoad code) - (All [directive] - (-> Archive Expander (Payload directive) Code - (All [anchor expression] - (///directive.Operation anchor expression directive - [Requirements (Payload directive)])))) - (do ///phase.monad - [#let [[pre_buffer pre_registry] pre_payoad] - _ (///directive.lift_generation - (///generation.set_buffer pre_buffer)) - _ (///directive.lift_generation - (///generation.set_registry pre_registry)) - requirements (let [execute! (directiveP.phase expander)] - (execute! archive code)) - post_payload (..get_current_payload pre_payoad)] - (wrap [requirements post_payload]))) - -(def: (iteration archive expander reader source pre_payload) - (All [directive] - (-> Archive Expander Reader Source (Payload directive) - (All [anchor expression] - (///directive.Operation anchor expression directive - [Source Requirements (Payload directive)])))) - (do ///phase.monad - [[source code] (///directive.lift_analysis - (..read source reader)) - [requirements post_payload] (process_directive archive expander pre_payload code)] - (wrap [source requirements post_payload]))) - -(def: (iterate archive expander module source pre_payload aliases) - (All [directive] - (-> Archive Expander Module Source (Payload directive) Aliases - (All [anchor expression] - (///directive.Operation anchor expression directive - (Maybe [Source Requirements (Payload directive)]))))) - (do ///phase.monad - [reader (///directive.lift_analysis - (..reader module aliases source))] - (function (_ state) - (case (///phase.run' state (..iteration archive expander reader source pre_payload)) - (#try.Success [state source&requirements&buffer]) - (#try.Success [state (#.Some source&requirements&buffer)]) - - (#try.Failure error) - (if (exception.match? ///syntax.end_of_file error) - (#try.Success [state #.None]) - (exception.with ///.cannot_compile module (#try.Failure error))))))) - -(def: (default_dependencies prelude input) - (-> Module ///.Input (List Module)) - (list& archive.runtime_module - (if (text\= prelude (get@ #///.module input)) - (list) - (list prelude)))) - -(def: module_aliases - (-> .Module Aliases) - (|>> (get@ #.module_aliases) (dictionary.from_list text.hash))) - -(def: #export (compiler expander prelude write_directive) - (All [anchor expression directive] - (-> Expander Module (-> directive Binary) - (Instancer (///directive.State+ anchor expression directive) .Module))) - (let [execute! (directiveP.phase expander)] - (function (_ key parameters input) - (let [dependencies (default_dependencies prelude input)] - {#///.dependencies dependencies - #///.process (function (_ state archive) - (do {! try.monad} - [#let [hash (text\hash (get@ #///.code input))] - [state [source buffer]] (<| (///phase.run' state) - (..begin dependencies hash input)) - #let [module (get@ #///.module input)]] - (loop [iteration (<| (///phase.run' state) - (..iterate archive expander module source buffer ///syntax.no_aliases))] - (do ! - [[state ?source&requirements&temporary_payload] iteration] - (case ?source&requirements&temporary_payload - #.None - (do ! - [[state [analysis_module [final_buffer final_registry]]] (///phase.run' state (..end module)) - #let [descriptor {#descriptor.hash hash - #descriptor.name module - #descriptor.file (get@ #///.file input) - #descriptor.references (set.from_list text.hash dependencies) - #descriptor.state #.Compiled - #descriptor.registry final_registry}]] - (wrap [state - (#.Right [descriptor - (document.write key analysis_module) - (row\map (function (_ [artifact_id directive]) - [artifact_id (write_directive directive)]) - final_buffer)])])) - - (#.Some [source requirements temporary_payload]) - (let [[temporary_buffer temporary_registry] temporary_payload] - (wrap [state - (#.Left {#///.dependencies (|> requirements - (get@ #///directive.imports) - (list\map product.left)) - #///.process (function (_ state archive) - (recur (<| (///phase.run' state) - (do {! ///phase.monad} - [analysis_module (<| (: (Operation .Module)) - ///directive.lift_analysis - extension.lift - meta.current_module) - _ (///directive.lift_generation - (///generation.set_buffer temporary_buffer)) - _ (///directive.lift_generation - (///generation.set_registry temporary_registry)) - _ (|> requirements - (get@ #///directive.referrals) - (monad.map ! (execute! archive))) - temporary_payload (..get_current_payload temporary_payload)] - (..iterate archive expander module source temporary_payload (..module_aliases analysis_module))))))})])) - )))))})))) diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux deleted file mode 100644 index 605f1d1e2..000000000 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ /dev/null @@ -1,601 +0,0 @@ -(.module: - [lux (#- Module) - [type (#+ :share)] - ["." debug] - ["@" target] - [abstract - ["." monad (#+ Monad do)]] - [control - ["." function] - ["." try (#+ Try) ("#\." functor)] - ["." exception (#+ exception:)] - [concurrency - ["." promise (#+ Promise Resolver) ("#\." monad)] - ["." stm (#+ Var STM)]]] - [data - ["." binary (#+ Binary)] - ["." bit] - ["." product] - ["." maybe] - ["." text ("#\." equivalence) - ["%" format (#+ format)]] - [collection - ["." dictionary (#+ Dictionary)] - ["." row (#+ Row) ("#\." fold)] - ["." set (#+ Set)] - ["." list ("#\." monoid functor fold)]] - [format - ["_" binary (#+ Writer)]]] - [world - ["." file (#+ Path)]]] - ["." // #_ - ["#." init] - ["/#" // - ["#." phase (#+ Phase)] - [language - [lux - [program (#+ Program)] - ["$" /] - ["#." version] - ["." syntax] - ["#." analysis - [macro (#+ Expander)]] - ["#." synthesis] - ["#." generation (#+ Buffer)] - ["#." directive] - [phase - ["." extension (#+ Extender)] - [analysis - ["." module]]]]] - [meta - ["." archive (#+ Output Archive) - ["." artifact (#+ Registry)] - ["." descriptor (#+ Descriptor Module)] - ["." document (#+ Document)]] - [io (#+ Context) - ["." context] - ["ioW" archive]]]]] - [program - [compositor - ["." cli (#+ Compilation Library)] - ["." static (#+ Static)] - ["." import (#+ Import)]]]) - -(with_expansions [<type_vars> (as_is anchor expression directive) - <Operation> (as_is ///generation.Operation <type_vars>)] - (type: #export Phase_Wrapper - (All [s i o] (-> (Phase s i o) Any))) - - (type: #export (Platform <type_vars>) - {#&file_system (file.System Promise) - #host (///generation.Host expression directive) - #phase (///generation.Phase <type_vars>) - #runtime (<Operation> [Registry Output]) - #phase_wrapper (-> Archive (<Operation> Phase_Wrapper)) - #write (-> directive Binary)}) - - ## TODO: Get rid of this - (type: (Action a) - (Promise (Try a))) - - ## TODO: Get rid of this - (def: monad - (:as (Monad Action) - (try.with promise.monad))) - - (with_expansions [<Platform> (as_is (Platform <type_vars>)) - <State+> (as_is (///directive.State+ <type_vars>)) - <Bundle> (as_is (///generation.Bundle <type_vars>))] - - (def: writer - (Writer [Descriptor (Document .Module)]) - (_.and descriptor.writer - (document.writer $.writer))) - - (def: (cache_module static platform module_id [descriptor document output]) - (All [<type_vars>] - (-> Static <Platform> archive.ID [Descriptor (Document Any) Output] - (Promise (Try Any)))) - (let [system (get@ #&file_system platform) - write_artifact! (: (-> [artifact.ID Binary] (Action Any)) - (function (_ [artifact_id content]) - (ioW.write system static module_id artifact_id content)))] - (do {! ..monad} - [_ (ioW.prepare system static module_id) - _ (for {@.python (|> output - row.to_list - (list.chunk 128) - (monad.map ! (monad.map ! write_artifact!)) - (: (Action (List (List Any)))))} - (|> output - row.to_list - (monad.map ..monad write_artifact!) - (: (Action (List Any))))) - document (\ promise.monad wrap - (document.check $.key document))] - (ioW.cache system static module_id - (_.run ..writer [descriptor document]))))) - - ## TODO: Inline ASAP - (def: initialize_buffer! - (All [<type_vars>] - (///generation.Operation <type_vars> Any)) - (///generation.set_buffer ///generation.empty_buffer)) - - ## TODO: Inline ASAP - (def: (compile_runtime! platform) - (All [<type_vars>] - (-> <Platform> (///generation.Operation <type_vars> [Registry Output]))) - (do ///phase.monad - [_ ..initialize_buffer!] - (get@ #runtime platform))) - - (def: (runtime_descriptor registry) - (-> Registry Descriptor) - {#descriptor.hash 0 - #descriptor.name archive.runtime_module - #descriptor.file "" - #descriptor.references (set.new text.hash) - #descriptor.state #.Compiled - #descriptor.registry registry}) - - (def: runtime_document - (Document .Module) - (document.write $.key (module.new 0))) - - (def: (process_runtime archive platform) - (All [<type_vars>] - (-> Archive <Platform> - (///directive.Operation <type_vars> - [Archive [Descriptor (Document .Module) Output]]))) - (do ///phase.monad - [[registry payload] (///directive.lift_generation - (..compile_runtime! platform)) - #let [[descriptor document] [(..runtime_descriptor registry) ..runtime_document]] - archive (///phase.lift (if (archive.reserved? archive archive.runtime_module) - (archive.add archive.runtime_module [descriptor document payload] archive) - (do try.monad - [[_ archive] (archive.reserve archive.runtime_module archive)] - (archive.add archive.runtime_module [descriptor document payload] archive))))] - (wrap [archive [descriptor document payload]]))) - - (def: (initialize_state extender - [analysers - synthesizers - generators - directives] - analysis_state - state) - (All [<type_vars>] - (-> Extender - [(Dictionary Text ///analysis.Handler) - (Dictionary Text ///synthesis.Handler) - (Dictionary Text (///generation.Handler <type_vars>)) - (Dictionary Text (///directive.Handler <type_vars>))] - .Lux - <State+> - (Try <State+>))) - (|> (:share [<type_vars>] - <State+> - state - - (///directive.Operation <type_vars> Any) - (do ///phase.monad - [_ (///directive.lift_analysis - (///analysis.install analysis_state)) - _ (///directive.lift_analysis - (extension.with extender analysers)) - _ (///directive.lift_synthesis - (extension.with extender synthesizers)) - _ (///directive.lift_generation - (extension.with extender (:assume generators))) - _ (extension.with extender (:assume directives))] - (wrap []))) - (///phase.run' state) - (\ try.monad map product.left))) - - (def: (phase_wrapper archive platform state) - (All [<type_vars>] - (-> Archive <Platform> <State+> (Try [<State+> Phase_Wrapper]))) - (let [phase_wrapper (get@ #phase_wrapper platform)] - (|> archive - phase_wrapper - ///directive.lift_generation - (///phase.run' state)))) - - (def: (complete_extensions host_directive_bundle phase_wrapper [analysers synthesizers generators directives]) - (All [<type_vars>] - (-> (-> Phase_Wrapper (///directive.Bundle <type_vars>)) - Phase_Wrapper - [(Dictionary Text ///analysis.Handler) - (Dictionary Text ///synthesis.Handler) - (Dictionary Text (///generation.Handler <type_vars>)) - (Dictionary Text (///directive.Handler <type_vars>))] - [(Dictionary Text ///analysis.Handler) - (Dictionary Text ///synthesis.Handler) - (Dictionary Text (///generation.Handler <type_vars>)) - (Dictionary Text (///directive.Handler <type_vars>))])) - [analysers - synthesizers - generators - (dictionary.merge directives (host_directive_bundle phase_wrapper))]) - - (def: #export (initialize static module expander host_analysis platform generation_bundle host_directive_bundle program anchorT,expressionT,directiveT extender - import compilation_sources) - (All [<type_vars>] - (-> Static - Module - Expander - ///analysis.Bundle - <Platform> - <Bundle> - (-> Phase_Wrapper (///directive.Bundle <type_vars>)) - (Program expression directive) - [Type Type Type] (-> Phase_Wrapper Extender) - Import (List Context) - (Promise (Try [<State+> Archive])))) - (do {! (try.with promise.monad)} - [#let [state (//init.state (get@ #static.host static) - module - expander - host_analysis - (get@ #host platform) - (get@ #phase platform) - generation_bundle)] - _ (ioW.enable (get@ #&file_system platform) static) - [archive analysis_state bundles] (ioW.thaw (get@ #host platform) (get@ #&file_system platform) static import compilation_sources) - #let [with_missing_extensions - (: (All [<type_vars>] - (-> <Platform> (Program expression directive) <State+> (Promise (Try <State+>)))) - (function (_ platform program state) - (promise\wrap - (do try.monad - [[state phase_wrapper] (..phase_wrapper archive platform state)] - (|> state - (initialize_state (extender phase_wrapper) - (:assume (..complete_extensions host_directive_bundle phase_wrapper (:assume bundles))) - analysis_state) - (try\map (//init.with_default_directives expander host_analysis program anchorT,expressionT,directiveT (extender phase_wrapper))))))))]] - (if (archive.archived? archive archive.runtime_module) - (do ! - [state (with_missing_extensions platform program state)] - (wrap [state archive])) - (do ! - [[state [archive payload]] (|> (..process_runtime archive platform) - (///phase.run' state) - promise\wrap) - _ (..cache_module static platform 0 payload) - - state (with_missing_extensions platform program state)] - (wrap [state archive]))))) - - (def: compilation_log_separator - (format text.new_line text.tab)) - - (def: (module_compilation_log module) - (All [<type_vars>] - (-> Module <State+> Text)) - (|>> (get@ [#extension.state - #///directive.generation - #///directive.state - #extension.state - #///generation.log]) - (row\fold (function (_ right left) - (format left ..compilation_log_separator right)) - module))) - - (def: with_reset_log - (All [<type_vars>] - (-> <State+> <State+>)) - (set@ [#extension.state - #///directive.generation - #///directive.state - #extension.state - #///generation.log] - row.empty)) - - (def: empty - (Set Module) - (set.new text.hash)) - - (type: Mapping - (Dictionary Module (Set Module))) - - (type: Dependence - {#depends_on Mapping - #depended_by Mapping}) - - (def: independence - Dependence - (let [empty (dictionary.new text.hash)] - {#depends_on empty - #depended_by empty})) - - (def: (depend module import dependence) - (-> Module Module Dependence Dependence) - (let [transitive_dependency (: (-> (-> Dependence Mapping) Module (Set Module)) - (function (_ lens module) - (|> dependence - lens - (dictionary.get module) - (maybe.default ..empty)))) - transitive_depends_on (transitive_dependency (get@ #depends_on) import) - transitive_depended_by (transitive_dependency (get@ #depended_by) module) - update_dependence (: (-> [Module (Set Module)] [Module (Set Module)] - (-> Mapping Mapping)) - (function (_ [source forward] [target backward]) - (function (_ mapping) - (let [with_dependence+transitives - (|> mapping - (dictionary.upsert source ..empty (set.add target)) - (dictionary.update source (set.union forward)))] - (list\fold (function (_ previous) - (dictionary.upsert previous ..empty (set.add target))) - with_dependence+transitives - (set.to_list backward))))))] - (|> dependence - (update@ #depends_on - (update_dependence - [module transitive_depends_on] - [import transitive_depended_by])) - (update@ #depended_by - ((function.flip update_dependence) - [module transitive_depends_on] - [import transitive_depended_by]))))) - - (def: (circular_dependency? module import dependence) - (-> Module Module Dependence Bit) - (let [dependence? (: (-> Module (-> Dependence Mapping) Module Bit) - (function (_ from relationship to) - (let [targets (|> dependence - relationship - (dictionary.get from) - (maybe.default ..empty))] - (set.member? targets to))))] - (or (dependence? import (get@ #depends_on) module) - (dependence? module (get@ #depended_by) import)))) - - (exception: #export (module_cannot_import_itself {module Module}) - (exception.report - ["Module" (%.text module)])) - - (exception: #export (cannot_import_circular_dependency {importer Module} - {importee Module}) - (exception.report - ["Importer" (%.text importer)] - ["importee" (%.text importee)])) - - (def: (verify_dependencies importer importee dependence) - (-> Module Module Dependence (Try Any)) - (cond (text\= importer importee) - (exception.throw ..module_cannot_import_itself [importer]) - - (..circular_dependency? importer importee dependence) - (exception.throw ..cannot_import_circular_dependency [importer importee]) - - ## else - (#try.Success []))) - - (with_expansions [<Context> (as_is [Archive <State+>]) - <Result> (as_is (Try <Context>)) - <Return> (as_is (Promise <Result>)) - <Signal> (as_is (Resolver <Result>)) - <Pending> (as_is [<Return> <Signal>]) - <Importer> (as_is (-> Module Module <Return>)) - <Compiler> (as_is (-> Module <Importer> archive.ID <Context> Module <Return>))] - (def: (parallel initial) - (All [<type_vars>] - (-> <Context> - (-> <Compiler> <Importer>))) - (let [current (stm.var initial) - pending (:share [<type_vars>] - <Context> - initial - - (Var (Dictionary Module <Pending>)) - (:assume (stm.var (dictionary.new text.hash)))) - dependence (: (Var Dependence) - (stm.var ..independence))] - (function (_ compile) - (function (import! importer module) - (do {! promise.monad} - [[return signal] (:share [<type_vars>] - <Context> - initial - - (Promise [<Return> (Maybe [<Context> - archive.ID - <Signal>])]) - (:assume - (stm.commit - (do {! stm.monad} - [dependence (if (text\= archive.runtime_module importer) - (stm.read dependence) - (do ! - [[_ dependence] (stm.update (..depend importer module) dependence)] - (wrap dependence)))] - (case (..verify_dependencies importer module dependence) - (#try.Failure error) - (wrap [(promise.resolved (#try.Failure error)) - #.None]) - - (#try.Success _) - (do ! - [[archive state] (stm.read current)] - (if (archive.archived? archive module) - (wrap [(promise\wrap (#try.Success [archive state])) - #.None]) - (do ! - [@pending (stm.read pending)] - (case (dictionary.get module @pending) - (#.Some [return signal]) - (wrap [return - #.None]) - - #.None - (case (if (archive.reserved? archive module) - (do try.monad - [module_id (archive.id module archive)] - (wrap [module_id archive])) - (archive.reserve module archive)) - (#try.Success [module_id archive]) - (do ! - [_ (stm.write [archive state] current) - #let [[return signal] (:share [<type_vars>] - <Context> - initial - - <Pending> - (promise.promise []))] - _ (stm.update (dictionary.put module [return signal]) pending)] - (wrap [return - (#.Some [[archive state] - module_id - signal])])) - - (#try.Failure error) - (wrap [(promise\wrap (#try.Failure error)) - #.None]))))))))))) - _ (case signal - #.None - (wrap []) - - (#.Some [context module_id resolver]) - (do ! - [result (compile importer import! module_id context module) - result (case result - (#try.Failure error) - (wrap result) - - (#try.Success [resulting_archive resulting_state]) - (stm.commit (do stm.monad - [[_ [merged_archive _]] (stm.update (function (_ [archive state]) - [(archive.merge resulting_archive archive) - state]) - current)] - (wrap (#try.Success [merged_archive resulting_state]))))) - _ (promise.future (resolver result))] - (wrap [])))] - return))))) - - ## TODO: Find a better way, as this only works for the Lux compiler. - (def: (updated_state archive state) - (All [<type_vars>] - (-> Archive <State+> (Try <State+>))) - (do {! try.monad} - [modules (monad.map ! (function (_ module) - (do ! - [[descriptor document output] (archive.find module archive) - lux_module (document.read $.key document)] - (wrap [module lux_module]))) - (archive.archived archive)) - #let [additions (|> modules - (list\map product.left) - (set.from_list text.hash))]] - (wrap (update@ [#extension.state - #///directive.analysis - #///directive.state - #extension.state] - (function (_ analysis_state) - (|> analysis_state - (:as .Lux) - (update@ #.modules (function (_ current) - (list\compose (list.filter (|>> product.left - (set.member? additions) - not) - current) - modules))) - :assume)) - state)))) - - (def: (set_current_module module state) - (All [<type_vars>] - (-> Module <State+> <State+>)) - (|> (///directive.set_current_module module) - (///phase.run' state) - try.assume - product.left)) - - (def: #export (compile import static expander platform compilation context) - (All [<type_vars>] - (-> Import Static Expander <Platform> Compilation <Context> <Return>)) - (let [[compilation_sources compilation_libraries compilation_target compilation_module] compilation - base_compiler (:share [<type_vars>] - <Context> - context - - (///.Compiler <State+> .Module Any) - (:assume - ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list)))) - compiler (..parallel - context - (function (_ importer import! module_id [archive state] module) - (do {! (try.with promise.monad)} - [#let [state (..set_current_module module state)] - input (context.read (get@ #&file_system platform) - importer - import - compilation_sources - (get@ #static.host_module_extension static) - module)] - (loop [[archive state] [archive state] - compilation (base_compiler (:as ///.Input input)) - all_dependencies (: (List Module) - (list))] - (let [new_dependencies (get@ #///.dependencies compilation) - all_dependencies (list\compose new_dependencies all_dependencies) - continue! (:share [<type_vars>] - <Platform> - platform - - (-> <Context> (///.Compilation <State+> .Module Any) (List Module) - (Action [Archive <State+>])) - (:assume - recur))] - (do ! - [[archive state] (case new_dependencies - #.Nil - (wrap [archive state]) - - (#.Cons _) - (do ! - [archive,document+ (|> new_dependencies - (list\map (import! module)) - (monad.seq ..monad)) - #let [archive (|> archive,document+ - (list\map product.left) - (list\fold archive.merge archive))]] - (wrap [archive (try.assume - (..updated_state archive state))])))] - (case ((get@ #///.process compilation) - ## TODO: The "///directive.set_current_module" below shouldn't be necessary. Remove it ASAP. - ## TODO: The context shouldn't need to be re-set either. - (|> (///directive.set_current_module module) - (///phase.run' state) - try.assume - product.left) - archive) - (#try.Success [state more|done]) - (case more|done - (#.Left more) - (continue! [archive state] more all_dependencies) - - (#.Right [descriptor document output]) - (do ! - [#let [_ (debug.log! (..module_compilation_log module state)) - descriptor (set@ #descriptor.references (set.from_list text.hash all_dependencies) descriptor)] - _ (..cache_module static platform module_id [descriptor document output])] - (case (archive.add module [descriptor document output] archive) - (#try.Success archive) - (wrap [archive - (..with_reset_log state)]) - - (#try.Failure error) - (promise\wrap (#try.Failure error))))) - - (#try.Failure error) - (do ! - [_ (ioW.freeze (get@ #&file_system platform) static archive)] - (promise\wrap (#try.Failure error))))))))))] - (compiler archive.runtime_module compilation_module))) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux.lux b/stdlib/source/lux/tool/compiler/language/lux.lux deleted file mode 100644 index 1d507b52f..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux.lux +++ /dev/null @@ -1,106 +0,0 @@ -(.module: - [lux #* - [control - ["<>" parser - ["<b>" binary (#+ Parser)]]] - [data - [format - ["_" binary (#+ Writer)]]]] - ["." / #_ - ["#." version] - [phase - [analysis - ["." module]]] - [/// - [meta - [archive - ["." signature] - ["." key (#+ Key)]]]]]) - -## TODO: Remove #module_hash, #imports & #module_state ASAP. -## TODO: Not just from this parser, but from the lux.Module type. -(def: #export writer - (Writer .Module) - (let [definition (: (Writer Definition) - ($_ _.and _.bit _.type _.code _.any)) - name (: (Writer Name) - (_.and _.text _.text)) - alias (: (Writer Alias) - (_.and _.text _.text)) - global (: (Writer Global) - (_.or alias - definition)) - tag (: (Writer [Nat (List Name) Bit Type]) - ($_ _.and - _.nat - (_.list name) - _.bit - _.type)) - type (: (Writer [(List Name) Bit Type]) - ($_ _.and - (_.list name) - _.bit - _.type))] - ($_ _.and - ## #module_hash - _.nat - ## #module_aliases - (_.list alias) - ## #definitions - (_.list (_.and _.text global)) - ## #imports - (_.list _.text) - ## #tags - (_.list (_.and _.text tag)) - ## #types - (_.list (_.and _.text type)) - ## #module_annotations - (_.maybe _.code) - ## #module_state - _.any))) - -(def: #export parser - (Parser .Module) - (let [definition (: (Parser Definition) - ($_ <>.and <b>.bit <b>.type <b>.code <b>.any)) - name (: (Parser Name) - (<>.and <b>.text <b>.text)) - alias (: (Parser Alias) - (<>.and <b>.text <b>.text)) - global (: (Parser Global) - (<b>.or alias - definition)) - tag (: (Parser [Nat (List Name) Bit Type]) - ($_ <>.and - <b>.nat - (<b>.list name) - <b>.bit - <b>.type)) - type (: (Parser [(List Name) Bit Type]) - ($_ <>.and - (<b>.list name) - <b>.bit - <b>.type))] - ($_ <>.and - ## #module_hash - <b>.nat - ## #module_aliases - (<b>.list alias) - ## #definitions - (<b>.list (<>.and <b>.text global)) - ## #imports - (<b>.list <b>.text) - ## #tags - (<b>.list (<>.and <b>.text tag)) - ## #types - (<b>.list (<>.and <b>.text type)) - ## #module_annotations - (<b>.maybe <b>.code) - ## #module_state - (\ <>.monad wrap #.Cached)))) - -(def: #export key - (Key .Module) - (key.key {#signature.name (name_of ..compiler) - #signature.version /version.version} - (module.new 0))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux deleted file mode 100644 index bbbe43b27..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux +++ /dev/null @@ -1,555 +0,0 @@ -(.module: - [lux (#- nat int rev) - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)] - [monad (#+ do)]] - [control - ["." function] - ["." try] - ["." exception (#+ Exception)]] - [data - ["." product] - ["." maybe] - ["." bit ("#\." equivalence)] - ["." text ("#\." equivalence) - ["%" format (#+ Format format)]] - [collection - ["." list ("#\." functor fold)]]] - [math - [number - ["n" nat] - ["i" int] - ["r" rev] - ["f" frac]]] - [meta - ["." location]]] - [// - [phase - ["." extension (#+ Extension)]] - [/// - [arity (#+ Arity)] - [version (#+ Version)] - ["." phase] - ["." reference (#+ Reference) - ["." variable (#+ Register Variable)]]]]) - -(type: #export #rec Primitive - #Unit - (#Bit Bit) - (#Nat Nat) - (#Int Int) - (#Rev Rev) - (#Frac Frac) - (#Text Text)) - -(type: #export Tag - Nat) - -(type: #export (Variant a) - {#lefts Nat - #right? Bit - #value a}) - -(def: #export (tag lefts right?) - (-> Nat Bit Nat) - (if right? - (inc lefts) - lefts)) - -(def: (lefts tag right?) - (-> Nat Bit Nat) - (if right? - (dec tag) - tag)) - -(def: #export (choice options pick) - (-> Nat Nat [Nat Bit]) - (let [right? (n.= (dec options) pick)] - [(..lefts pick right?) - right?])) - -(type: #export (Tuple a) - (List a)) - -(type: #export (Composite a) - (#Variant (Variant a)) - (#Tuple (Tuple a))) - -(type: #export #rec Pattern - (#Simple Primitive) - (#Complex (Composite Pattern)) - (#Bind Register)) - -(type: #export (Branch' e) - {#when Pattern - #then e}) - -(type: #export (Match' e) - [(Branch' e) (List (Branch' e))]) - -(type: #export (Environment a) - (List a)) - -(type: #export #rec Analysis - (#Primitive Primitive) - (#Structure (Composite Analysis)) - (#Reference Reference) - (#Case Analysis (Match' Analysis)) - (#Function (Environment Analysis) Analysis) - (#Apply Analysis Analysis) - (#Extension (Extension Analysis))) - -(type: #export Branch - (Branch' Analysis)) - -(type: #export Match - (Match' Analysis)) - -(implementation: primitive_equivalence - (Equivalence Primitive) - - (def: (= reference sample) - (case [reference sample] - [#Unit #Unit] - true - - (^template [<tag> <=>] - [[(<tag> reference) (<tag> sample)] - (<=> reference sample)]) - ([#Bit bit\=] - [#Nat n.=] - [#Int i.=] - [#Rev r.=] - [#Frac f.=] - [#Text text\=]) - - _ - false))) - -(implementation: #export (composite_equivalence (^open "/\.")) - (All [a] (-> (Equivalence a) (Equivalence (Composite a)))) - - (def: (= reference sample) - (case [reference sample] - [(#Variant [reference_lefts reference_right? reference_value]) - (#Variant [sample_lefts sample_right? sample_value])] - (and (n.= reference_lefts sample_lefts) - (bit\= reference_right? sample_right?) - (/\= reference_value sample_value)) - - [(#Tuple reference) (#Tuple sample)] - (\ (list.equivalence /\=) = reference sample) - - _ - false))) - -(implementation: #export (composite_hash super) - (All [a] (-> (Hash a) (Hash (Composite a)))) - - (def: &equivalence - (..composite_equivalence (\ super &equivalence))) - - (def: (hash value) - (case value - (#Variant [lefts right? value]) - ($_ n.* 2 - (\ n.hash hash lefts) - (\ bit.hash hash right?) - (\ super hash value)) - - (#Tuple members) - ($_ n.* 3 - (\ (list.hash super) hash members)) - ))) - -(implementation: pattern_equivalence - (Equivalence Pattern) - - (def: (= reference sample) - (case [reference sample] - [(#Simple reference) (#Simple sample)] - (\ primitive_equivalence = reference sample) - - [(#Complex reference) (#Complex sample)] - (\ (composite_equivalence =) = reference sample) - - [(#Bind reference) (#Bind sample)] - (n.= reference sample) - - _ - false))) - -(implementation: (branch_equivalence equivalence) - (-> (Equivalence Analysis) (Equivalence Branch)) - - (def: (= [reference_pattern reference_body] [sample_pattern sample_body]) - (and (\ pattern_equivalence = reference_pattern sample_pattern) - (\ equivalence = reference_body sample_body)))) - -(implementation: #export equivalence - (Equivalence Analysis) - - (def: (= reference sample) - (case [reference sample] - [(#Primitive reference) (#Primitive sample)] - (\ primitive_equivalence = reference sample) - - [(#Structure reference) (#Structure sample)] - (\ (composite_equivalence =) = reference sample) - - [(#Reference reference) (#Reference sample)] - (\ reference.equivalence = reference sample) - - [(#Case [reference_analysis reference_match]) - (#Case [sample_analysis sample_match])] - (and (= reference_analysis sample_analysis) - (\ (list.equivalence (branch_equivalence =)) = (#.Cons reference_match) (#.Cons sample_match))) - - [(#Function [reference_environment reference_analysis]) - (#Function [sample_environment sample_analysis])] - (and (= reference_analysis sample_analysis) - (\ (list.equivalence =) = reference_environment sample_environment)) - - [(#Apply [reference_input reference_abstraction]) - (#Apply [sample_input sample_abstraction])] - (and (= reference_input sample_input) - (= reference_abstraction sample_abstraction)) - - [(#Extension reference) (#Extension sample)] - (\ (extension.equivalence =) = reference sample) - - _ - false))) - -(template [<name> <tag>] - [(template: #export (<name> content) - (<tag> content))] - - [control/case #..Case] - ) - -(template: #export (unit) - (#..Primitive #..Unit)) - -(template [<name> <tag>] - [(template: #export (<name> value) - (#..Primitive (<tag> value)))] - - [bit #..Bit] - [nat #..Nat] - [int #..Int] - [rev #..Rev] - [frac #..Frac] - [text #..Text] - ) - -(type: #export (Abstraction c) - [(Environment c) Arity c]) - -(type: #export (Application c) - [c (List c)]) - -(def: (last? size tag) - (-> Nat Tag Bit) - (n.= (dec size) tag)) - -(template: #export (no_op value) - (|> 1 #variable.Local #reference.Variable #..Reference - (#..Function (list)) - (#..Apply value))) - -(def: #export (apply [abstraction inputs]) - (-> (Application Analysis) Analysis) - (list\fold (function (_ input abstraction') - (#Apply input abstraction')) - abstraction - inputs)) - -(def: #export (application analysis) - (-> Analysis (Application Analysis)) - (loop [abstraction analysis - inputs (list)] - (case abstraction - (#Apply input next) - (recur next (#.Cons input inputs)) - - _ - [abstraction inputs]))) - -(template [<name> <tag>] - [(template: #export (<name> content) - (.<| #..Reference - <tag> - content))] - - [variable #reference.Variable] - [constant #reference.Constant] - - [variable/local reference.local] - [variable/foreign reference.foreign] - ) - -(template [<name> <tag>] - [(template: #export (<name> content) - (.<| #..Complex - <tag> - content))] - - [pattern/variant #..Variant] - [pattern/tuple #..Tuple] - ) - -(template [<name> <tag>] - [(template: #export (<name> content) - (.<| #..Structure - <tag> - content))] - - [variant #..Variant] - [tuple #..Tuple] - ) - -(template: #export (pattern/unit) - (#..Simple #..Unit)) - -(template [<name> <tag>] - [(template: #export (<name> content) - (#..Simple (<tag> content)))] - - [pattern/bit #..Bit] - [pattern/nat #..Nat] - [pattern/int #..Int] - [pattern/rev #..Rev] - [pattern/frac #..Frac] - [pattern/text #..Text] - ) - -(template: #export (pattern/bind register) - (#..Bind register)) - -(def: #export (%analysis analysis) - (Format Analysis) - (case analysis - (#Primitive primitive) - (case primitive - #Unit - "[]" - - (^template [<tag> <format>] - [(<tag> value) - (<format> value)]) - ([#Bit %.bit] - [#Nat %.nat] - [#Int %.int] - [#Rev %.rev] - [#Frac %.frac] - [#Text %.text])) - - (#Structure structure) - (case structure - (#Variant [lefts right? value]) - (format "(" (%.nat lefts) " " (%.bit right?) " " (%analysis value) ")") - - (#Tuple members) - (|> members - (list\map %analysis) - (text.join_with " ") - (text.enclose ["[" "]"]))) - - (#Reference reference) - (reference.format reference) - - (#Case analysis match) - "{?}" - - (#Function environment body) - (|> (%analysis body) - (format " ") - (format (|> environment - (list\map %analysis) - (text.join_with " ") - (text.enclose ["[" "]"]))) - (text.enclose ["(" ")"])) - - (#Apply _) - (|> analysis - ..application - #.Cons - (list\map %analysis) - (text.join_with " ") - (text.enclose ["(" ")"])) - - (#Extension name parameters) - (|> parameters - (list\map %analysis) - (text.join_with " ") - (format (%.text name) " ") - (text.enclose ["(" ")"])))) - -(template [<special> <general>] - [(type: #export <special> - (<general> .Lux Code Analysis))] - - [State+ extension.State] - [Operation extension.Operation] - [Phase extension.Phase] - [Handler extension.Handler] - [Bundle extension.Bundle] - ) - -(def: #export (with_source_code source action) - (All [a] (-> Source (Operation a) (Operation a))) - (function (_ [bundle state]) - (let [old_source (get@ #.source state)] - (case (action [bundle (set@ #.source source state)]) - (#try.Success [[bundle' state'] output]) - (#try.Success [[bundle' (set@ #.source old_source state')] - output]) - - (#try.Failure error) - (#try.Failure error))))) - -(def: fresh_bindings - (All [k v] (Bindings k v)) - {#.counter 0 - #.mappings (list)}) - -(def: fresh_scope - Scope - {#.name (list) - #.inner 0 - #.locals fresh_bindings - #.captured fresh_bindings}) - -(def: #export (with_scope action) - (All [a] (-> (Operation a) (Operation [Scope a]))) - (function (_ [bundle state]) - (case (action [bundle (update@ #.scopes (|>> (#.Cons fresh_scope)) state)]) - (#try.Success [[bundle' state'] output]) - (case (get@ #.scopes state') - (#.Cons head tail) - (#try.Success [[bundle' (set@ #.scopes tail state')] - [head output]]) - - #.Nil - (#try.Failure "Impossible error: Drained scopes!")) - - (#try.Failure error) - (#try.Failure error)))) - -(def: #export (with_current_module name) - (All [a] (-> Text (Operation a) (Operation a))) - (extension.localized (get@ #.current_module) - (set@ #.current_module) - (function.constant (#.Some name)))) - -(def: #export (with_location location action) - (All [a] (-> Location (Operation a) (Operation a))) - (if (text\= "" (product.left location)) - action - (function (_ [bundle state]) - (let [old_location (get@ #.location state)] - (case (action [bundle (set@ #.location location state)]) - (#try.Success [[bundle' state'] output]) - (#try.Success [[bundle' (set@ #.location old_location state')] - output]) - - (#try.Failure error) - (#try.Failure error)))))) - -(def: (locate_error location error) - (-> Location Text Text) - (format (%.location location) text.new_line - error)) - -(def: #export (fail error) - (-> Text Operation) - (function (_ [bundle state]) - (#try.Failure (locate_error (get@ #.location state) error)))) - -(def: #export (throw exception parameters) - (All [e] (-> (Exception e) e Operation)) - (..fail (exception.construct exception parameters))) - -(def: #export (assert exception parameters condition) - (All [e] (-> (Exception e) e Bit (Operation Any))) - (if condition - (\ phase.monad wrap []) - (..throw exception parameters))) - -(def: #export (fail' error) - (-> Text (phase.Operation Lux)) - (function (_ state) - (#try.Failure (locate_error (get@ #.location state) error)))) - -(def: #export (throw' exception parameters) - (All [e] (-> (Exception e) e (phase.Operation Lux))) - (..fail' (exception.construct exception parameters))) - -(def: #export (with_stack exception message action) - (All [e o] (-> (Exception e) e (Operation o) (Operation o))) - (function (_ bundle,state) - (case (exception.with exception message - (action bundle,state)) - (#try.Success output) - (#try.Success output) - - (#try.Failure error) - (let [[bundle state] bundle,state] - (#try.Failure (locate_error (get@ #.location state) error)))))) - -(def: #export (install state) - (-> .Lux (Operation Any)) - (function (_ [bundle _]) - (#try.Success [[bundle state] - []]))) - -(template [<name> <type> <field> <value>] - [(def: #export (<name> value) - (-> <type> (Operation Any)) - (extension.update (set@ <field> <value>)))] - - [set_source_code Source #.source value] - [set_current_module Text #.current_module (#.Some value)] - [set_location Location #.location value] - ) - -(def: #export (location file) - (-> Text Location) - [file 1 0]) - -(def: #export (source file code) - (-> Text Text Source) - [(location file) 0 code]) - -(def: dummy_source - Source - [location.dummy 0 ""]) - -(def: type_context - Type_Context - {#.ex_counter 0 - #.var_counter 0 - #.var_bindings (list)}) - -(def: #export (info version host) - (-> Version Text Info) - {#.target host - #.version (%.nat version) - #.mode #.Build}) - -(def: #export (state info) - (-> Info Lux) - {#.info info - #.source ..dummy_source - #.location location.dummy - #.current_module #.None - #.modules (list) - #.scopes (list) - #.type_context ..type_context - #.expected #.None - #.seed 0 - #.scope_type_vars (list) - #.extensions [] - #.host []}) diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux deleted file mode 100644 index 521c88a23..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux +++ /dev/null @@ -1,56 +0,0 @@ -(.module: - [lux (#- Module) - ["." meta] - [abstract - [monad (#+ do)]] - [control - ["." try]] - [math - [number - ["n" nat]]]] - [// (#+ Operation) - [macro (#+ Expander)] - [// - [phase - [".P" extension] - [".P" synthesis] - [".P" analysis - ["." type]] - [// - ["." synthesis] - ["." generation (#+ Context)] - [/// - ["." phase] - [meta - [archive (#+ Archive) - [descriptor (#+ Module)]]]]]]]]) - -(type: #export Eval - (-> Archive Nat Type Code (Operation Any))) - -(def: (context [module_id artifact_id]) - (-> Context Context) - ## TODO: Find a better way that doesn't rely on clever tricks. - [(n.- module_id 0) artifact_id]) - -(def: #export (evaluator expander synthesis_state generation_state generate) - (All [anchor expression artifact] - (-> Expander - synthesis.State+ - (generation.State+ anchor expression artifact) - (generation.Phase anchor expression artifact) - Eval)) - (let [analyze (analysisP.phase expander)] - (function (eval archive count type exprC) - (do phase.monad - [exprA (type.with_type type - (analyze archive exprC)) - module (extensionP.lift - meta.current_module_name)] - (phase.lift (do try.monad - [exprS (|> exprA (synthesisP.phase archive) (phase.run synthesis_state))] - (phase.run generation_state - (do phase.monad - [exprO (generate archive exprS) - module_id (generation.module_id module archive)] - (generation.evaluate! (..context [module_id count]) exprO))))))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis/macro.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis/macro.lux deleted file mode 100644 index 9a84c0259..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/analysis/macro.lux +++ /dev/null @@ -1,51 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["." text - ["%" format (#+ format)]]] - ["." meta]] - [///// - ["." phase]]) - -(exception: #export (expansion_failed {macro Name} {inputs (List Code)} {error Text}) - (exception.report - ["Macro" (%.name macro)] - ["Inputs" (exception.enumerate %.code inputs)] - ["Error" error])) - -(exception: #export (must_have_single_expansion {macro Name} {inputs (List Code)} {outputs (List Code)}) - (exception.report - ["Macro" (%.name macro)] - ["Inputs" (exception.enumerate %.code inputs)] - ["Outputs" (exception.enumerate %.code outputs)])) - -(type: #export Expander - (-> Macro (List Code) Lux (Try (Try [Lux (List Code)])))) - -(def: #export (expand expander name macro inputs) - (-> Expander Name Macro (List Code) (Meta (List Code))) - (function (_ state) - (do try.monad - [output (expander macro inputs state)] - (case output - (#try.Success output) - (#try.Success output) - - (#try.Failure error) - ((meta.fail (exception.construct ..expansion_failed [name inputs error])) state))))) - -(def: #export (expand_one expander name macro inputs) - (-> Expander Name Macro (List Code) (Meta Code)) - (do meta.monad - [expansion (expand expander name macro inputs)] - (case expansion - (^ (list single)) - (wrap single) - - _ - (meta.fail (exception.construct ..must_have_single_expansion [name inputs expansion]))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/directive.lux b/stdlib/source/lux/tool/compiler/language/lux/directive.lux deleted file mode 100644 index 896a9a1cb..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/directive.lux +++ /dev/null @@ -1,82 +0,0 @@ -(.module: - [lux (#- Module) - [abstract - [monad (#+ do)]] - [data - [collection - ["." list ("#\." monoid)]]]] - [// - ["." analysis] - ["." synthesis] - ["." generation] - [phase - ["." extension]] - [/// - ["." phase] - [meta - [archive - [descriptor (#+ Module)]]]]]) - -(type: #export (Component state phase) - {#state state - #phase phase}) - -(type: #export (State anchor expression directive) - {#analysis (Component analysis.State+ - analysis.Phase) - #synthesis (Component synthesis.State+ - synthesis.Phase) - #generation (Component (generation.State+ anchor expression directive) - (generation.Phase anchor expression directive))}) - -(type: #export Import - {#module Module - #alias Text}) - -(type: #export Requirements - {#imports (List Import) - #referrals (List Code)}) - -(def: #export no_requirements - Requirements - {#imports (list) - #referrals (list)}) - -(def: #export (merge_requirements left right) - (-> Requirements Requirements Requirements) - {#imports (list\compose (get@ #imports left) (get@ #imports right)) - #referrals (list\compose (get@ #referrals left) (get@ #referrals right))}) - -(template [<special> <general>] - [(type: #export (<special> anchor expression directive) - (<general> (..State anchor expression directive) Code Requirements))] - - [State+ extension.State] - [Operation extension.Operation] - [Phase extension.Phase] - [Handler extension.Handler] - [Bundle extension.Bundle] - ) - -(template [<name> <component> <operation>] - [(def: #export <name> - (All [anchor expression directive output] - (-> (<operation> output) - (Operation anchor expression directive output))) - (|>> (phase.sub [(get@ [<component> #..state]) - (set@ [<component> #..state])]) - extension.lift))] - - [lift_analysis #..analysis analysis.Operation] - [lift_synthesis #..synthesis synthesis.Operation] - [lift_generation #..generation (generation.Operation anchor expression directive)] - ) - -(def: #export (set_current_module module) - (All [anchor expression directive] - (-> Module (Operation anchor expression directive Any))) - (do phase.monad - [_ (..lift_analysis - (analysis.set_current_module module))] - (..lift_generation - (generation.enter_module module)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/generation.lux b/stdlib/source/lux/tool/compiler/language/lux/generation.lux deleted file mode 100644 index 372ed2c17..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/generation.lux +++ /dev/null @@ -1,335 +0,0 @@ -(.module: - [lux (#- Module) - [abstract - [monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["." function]] - [data - [binary (#+ Binary)] - ["." product] - ["." name] - ["." text ("#\." equivalence) - ["%" format (#+ format)]] - [collection - ["." row (#+ Row)] - ["." list ("#\." functor)]]] - [math - [number - ["n" nat]]]] - [// - [synthesis (#+ Synthesis)] - [phase - ["." extension]] - [/// - ["." phase] - [meta - ["." archive (#+ Archive) - ["." descriptor (#+ Module)] - ["." artifact]]]]]) - -(type: #export Context - [archive.ID artifact.ID]) - -(type: #export (Buffer directive) - (Row [artifact.ID directive])) - -(exception: #export (cannot_interpret {error Text}) - (exception.report - ["Error" error])) - -(template [<name>] - [(exception: #export (<name> {artifact_id artifact.ID}) - (exception.report - ["Artifact ID" (%.nat artifact_id)]))] - - [cannot_overwrite_output] - [no_buffer_for_saving_code] - ) - -(interface: #export (Host expression directive) - (: (-> Context expression (Try Any)) - evaluate!) - (: (-> directive (Try Any)) - execute!) - (: (-> Context expression (Try [Text Any directive])) - define!) - - (: (-> Context Binary directive) - ingest) - (: (-> Context directive (Try Any)) - re_learn) - (: (-> Context directive (Try Any)) - re_load)) - -(type: #export (State anchor expression directive) - {#module Module - #anchor (Maybe anchor) - #host (Host expression directive) - #buffer (Maybe (Buffer directive)) - #registry artifact.Registry - #counter Nat - #context (Maybe artifact.ID) - #log (Row Text)}) - -(template [<special> <general>] - [(type: #export (<special> anchor expression directive) - (<general> (State anchor expression directive) Synthesis expression))] - - [State+ extension.State] - [Operation extension.Operation] - [Phase extension.Phase] - [Handler extension.Handler] - [Bundle extension.Bundle] - [Extender extension.Extender] - ) - -(def: #export (state host module) - (All [anchor expression directive] - (-> (Host expression directive) - Module - (..State anchor expression directive))) - {#module module - #anchor #.None - #host host - #buffer #.None - #registry artifact.empty - #counter 0 - #context #.None - #log row.empty}) - -(def: #export empty_buffer Buffer row.empty) - -(template [<tag> - <with_declaration> <with_type> <with_value> - <set> <get> <get_type> <exception>] - [(exception: #export <exception>) - - (def: #export <with_declaration> - (All [anchor expression directive output] <with_type>) - (function (_ body) - (function (_ [bundle state]) - (case (body [bundle (set@ <tag> (#.Some <with_value>) state)]) - (#try.Success [[bundle' state'] output]) - (#try.Success [[bundle' (set@ <tag> (get@ <tag> state) state')] - output]) - - (#try.Failure error) - (#try.Failure error))))) - - (def: #export <get> - (All [anchor expression directive] - (Operation anchor expression directive <get_type>)) - (function (_ (^@ stateE [bundle state])) - (case (get@ <tag> state) - (#.Some output) - (#try.Success [stateE output]) - - #.None - (exception.throw <exception> [])))) - - (def: #export (<set> value) - (All [anchor expression directive] - (-> <get_type> (Operation anchor expression directive Any))) - (function (_ [bundle state]) - (#try.Success [[bundle (set@ <tag> (#.Some value) state)] - []])))] - - [#anchor - (with_anchor anchor) - (-> anchor (Operation anchor expression directive output) - (Operation anchor expression directive output)) - anchor - set_anchor anchor anchor no_anchor] - - [#buffer - with_buffer - (-> (Operation anchor expression directive output) - (Operation anchor expression directive output)) - ..empty_buffer - set_buffer buffer (Buffer directive) no_active_buffer] - ) - -(def: #export get_registry - (All [anchor expression directive] - (Operation anchor expression directive artifact.Registry)) - (function (_ (^@ stateE [bundle state])) - (#try.Success [stateE (get@ #registry state)]))) - -(def: #export (set_registry value) - (All [anchor expression directive] - (-> artifact.Registry (Operation anchor expression directive Any))) - (function (_ [bundle state]) - (#try.Success [[bundle (set@ #registry value state)] - []]))) - -(def: #export next - (All [anchor expression directive] - (Operation anchor expression directive Nat)) - (do phase.monad - [count (extension.read (get@ #counter)) - _ (extension.update (update@ #counter inc))] - (wrap count))) - -(def: #export (gensym prefix) - (All [anchor expression directive] - (-> Text (Operation anchor expression directive Text))) - (\ phase.monad map (|>> %.nat (format prefix)) ..next)) - -(def: #export (enter_module module) - (All [anchor expression directive] - (-> Module (Operation anchor expression directive Any))) - (extension.update (set@ #module module))) - -(def: #export module - (All [anchor expression directive] - (Operation anchor expression directive Module)) - (extension.read (get@ #module))) - -(def: #export (evaluate! label code) - (All [anchor expression directive] - (-> Context expression (Operation anchor expression directive Any))) - (function (_ (^@ state+ [bundle state])) - (case (\ (get@ #host state) evaluate! label code) - (#try.Success output) - (#try.Success [state+ output]) - - (#try.Failure error) - (exception.throw ..cannot_interpret error)))) - -(def: #export (execute! code) - (All [anchor expression directive] - (-> directive (Operation anchor expression directive Any))) - (function (_ (^@ state+ [bundle state])) - (case (\ (get@ #host state) execute! code) - (#try.Success output) - (#try.Success [state+ output]) - - (#try.Failure error) - (exception.throw ..cannot_interpret error)))) - -(def: #export (define! context code) - (All [anchor expression directive] - (-> Context expression (Operation anchor expression directive [Text Any directive]))) - (function (_ (^@ stateE [bundle state])) - (case (\ (get@ #host state) define! context code) - (#try.Success output) - (#try.Success [stateE output]) - - (#try.Failure error) - (exception.throw ..cannot_interpret error)))) - -(def: #export (save! artifact_id code) - (All [anchor expression directive] - (-> artifact.ID directive (Operation anchor expression directive Any))) - (do {! phase.monad} - [?buffer (extension.read (get@ #buffer))] - (case ?buffer - (#.Some buffer) - ## TODO: Optimize by no longer checking for overwrites... - (if (row.any? (|>> product.left (n.= artifact_id)) buffer) - (phase.throw ..cannot_overwrite_output [artifact_id]) - (extension.update (set@ #buffer (#.Some (row.add [artifact_id code] buffer))))) - - #.None - (phase.throw ..no_buffer_for_saving_code [artifact_id])))) - -(template [<name> <artifact>] - [(def: #export (<name> name) - (All [anchor expression directive] - (-> Text (Operation anchor expression directive artifact.ID))) - (function (_ (^@ stateE [bundle state])) - (let [[id registry'] (<artifact> name (get@ #registry state))] - (#try.Success [[bundle (set@ #registry registry' state)] - id]))))] - - [learn artifact.definition] - [learn_analyser artifact.analyser] - [learn_synthesizer artifact.synthesizer] - [learn_generator artifact.generator] - [learn_directive artifact.directive] - ) - -(exception: #export (unknown_definition {name Name} - {known_definitions (List Text)}) - (exception.report - ["Definition" (name.short name)] - ["Module" (name.module name)] - ["Known Definitions" (exception.enumerate function.identity known_definitions)])) - -(def: #export (remember archive name) - (All [anchor expression directive] - (-> Archive Name (Operation anchor expression directive Context))) - (function (_ (^@ stateE [bundle state])) - (let [[_module _name] name] - (do try.monad - [module_id (archive.id _module archive) - registry (if (text\= (get@ #module state) _module) - (#try.Success (get@ #registry state)) - (do try.monad - [[descriptor document] (archive.find _module archive)] - (#try.Success (get@ #descriptor.registry descriptor))))] - (case (artifact.remember _name registry) - #.None - (exception.throw ..unknown_definition [name (artifact.definitions registry)]) - - (#.Some id) - (#try.Success [stateE [module_id id]])))))) - -(exception: #export no_context) - -(def: #export (module_id module archive) - (All [anchor expression directive] - (-> Module Archive (Operation anchor expression directive archive.ID))) - (function (_ (^@ stateE [bundle state])) - (do try.monad - [module_id (archive.id module archive)] - (wrap [stateE module_id])))) - -(def: #export (context archive) - (All [anchor expression directive] - (-> Archive (Operation anchor expression directive Context))) - (function (_ (^@ stateE [bundle state])) - (case (get@ #context state) - #.None - (exception.throw ..no_context []) - - (#.Some id) - (do try.monad - [module_id (archive.id (get@ #module state) archive)] - (wrap [stateE [module_id id]]))))) - -(def: #export (with_context id body) - (All [anchor expression directive a] - (-> artifact.ID - (Operation anchor expression directive a) - (Operation anchor expression directive a))) - (function (_ [bundle state]) - (do try.monad - [[[bundle' state'] output] (body [bundle (set@ #context (#.Some id) state)])] - (wrap [[bundle' (set@ #context (get@ #context state) state')] - output])))) - -(def: #export (with_new_context archive body) - (All [anchor expression directive a] - (-> Archive (Operation anchor expression directive a) - (Operation anchor expression directive [Context a]))) - (function (_ (^@ stateE [bundle state])) - (let [[id registry'] (artifact.resource (get@ #registry state))] - (do try.monad - [[[bundle' state'] output] (body [bundle (|> state - (set@ #registry registry') - (set@ #context (#.Some id)))]) - module_id (archive.id (get@ #module state) archive)] - (wrap [[bundle' (set@ #context (get@ #context state) state')] - [[module_id id] - output]]))))) - -(def: #export (log! message) - (All [anchor expression directive a] - (-> Text (Operation anchor expression directive Any))) - (function (_ [bundle state]) - (#try.Success [[bundle - (update@ #log (row.add message) state)] - []]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis.lux deleted file mode 100644 index 9e0748422..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis.lux +++ /dev/null @@ -1,143 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." exception (#+ exception:)]] - [data - [text - ["%" format (#+ format)]]] - ["." meta - ["." location]]] - ["." / #_ - ["#." type] - ["#." primitive] - ["#." structure] - ["#." reference] - ["#." case] - ["#." function] - ["/#" // #_ - ["#." extension] - ["/#" // #_ - ["/" analysis (#+ Analysis Operation Phase) - ["#." macro (#+ Expander)]] - [/// - ["//" phase] - ["." reference] - [meta - [archive (#+ Archive)]]]]]]) - -(exception: #export (unrecognized_syntax {code Code}) - (exception.report ["Code" (%.code code)])) - -## TODO: Had to split the 'compile' function due to compilation issues -## with old-luxc. Must re-combine all the code ASAP - -(type: (Fix a) - (-> a a)) - -(def: (compile|primitive else code') - (Fix (-> (Code' (Ann Location)) (Operation Analysis))) - (case code' - (^template [<tag> <analyser>] - [(<tag> value) - (<analyser> value)]) - ([#.Bit /primitive.bit] - [#.Nat /primitive.nat] - [#.Int /primitive.int] - [#.Rev /primitive.rev] - [#.Frac /primitive.frac] - [#.Text /primitive.text]) - - _ - (else code'))) - -(def: (compile|structure archive compile else code') - (-> Archive Phase (Fix (-> (Code' (Ann Location)) (Operation Analysis)))) - (case code' - (^ (#.Form (list& [_ (#.Tag tag)] - values))) - (case values - (#.Cons value #.Nil) - (/structure.tagged_sum compile tag archive value) - - _ - (/structure.tagged_sum compile tag archive (` [(~+ values)]))) - - (^ (#.Form (list& [_ (#.Nat lefts)] [_ (#.Bit right?)] - values))) - (case values - (#.Cons value #.Nil) - (/structure.sum compile lefts right? archive value) - - _ - (/structure.sum compile lefts right? archive (` [(~+ values)]))) - - (#.Tag tag) - (/structure.tagged_sum compile tag archive (' [])) - - (^ (#.Tuple (list))) - /primitive.unit - - (^ (#.Tuple (list singleton))) - (compile archive singleton) - - (^ (#.Tuple elems)) - (/structure.product archive compile elems) - - (^ (#.Record pairs)) - (/structure.record archive compile pairs) - - _ - (else code'))) - -(def: (compile|others expander archive compile code') - (-> Expander Archive Phase (-> (Code' (Ann Location)) (Operation Analysis))) - (case code' - (#.Identifier reference) - (/reference.reference reference) - - (^ (#.Form (list [_ (#.Record branches)] input))) - (/case.case compile branches archive input) - - (^ (#.Form (list& [_ (#.Text extension_name)] extension_args))) - (//extension.apply archive compile [extension_name extension_args]) - - (^ (#.Form (list [_ (#.Tuple (list [_ (#.Identifier ["" function_name])] - [_ (#.Identifier ["" arg_name])]))] - body))) - (/function.function compile function_name arg_name archive body) - - (^ (#.Form (list& functionC argsC+))) - (do {! //.monad} - [[functionT functionA] (/type.with_inference - (compile archive functionC))] - (case functionA - (#/.Reference (#reference.Constant def_name)) - (do ! - [?macro (//extension.lift (meta.find_macro def_name))] - (case ?macro - (#.Some macro) - (do ! - [expansion (//extension.lift (/macro.expand_one expander def_name macro argsC+))] - (compile archive expansion)) - - _ - (/function.apply compile argsC+ functionT functionA archive functionC))) - - _ - (/function.apply compile argsC+ functionT functionA archive functionC))) - - _ - (//.throw ..unrecognized_syntax [location.dummy code']))) - -(def: #export (phase expander) - (-> Expander Phase) - (function (compile archive code) - (let [[location code'] code] - ## The location must be set in the state for the sake - ## of having useful error messages. - (/.with_location location - (compile|primitive (compile|structure archive compile - (compile|others expander archive compile)) - code'))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case.lux deleted file mode 100644 index 41fad7934..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case.lux +++ /dev/null @@ -1,324 +0,0 @@ -(.module: - [lux (#- case) - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["." try] - ["." exception (#+ exception:)]] - [data - ["." product] - ["." maybe] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." fold monoid functor)]]] - [math - [number - ["n" nat]]] - [macro - ["." code]] - ["." type - ["." check]]] - ["." / #_ - ["#." coverage (#+ Coverage)] - ["/#" // #_ - ["#." scope] - ["#." type] - ["#." structure] - ["/#" // #_ - ["#." extension] - [// - ["/" analysis (#+ Pattern Analysis Operation Phase)] - [/// - ["#" phase]]]]]]) - -(exception: #export (cannot_match_with_pattern {type Type} {pattern Code}) - (exception.report - ["Type" (%.type type)] - ["Pattern" (%.code pattern)])) - -(exception: #export (sum_has_no_case {case Nat} {type Type}) - (exception.report - ["Case" (%.nat case)] - ["Type" (%.type type)])) - -(exception: #export (not_a_pattern {code Code}) - (exception.report ["Code" (%.code code)])) - -(exception: #export (cannot_simplify_for_pattern_matching {type Type}) - (exception.report ["Type" (%.type type)])) - -(exception: #export (non_exhaustive_pattern_matching {input Code} {branches (List [Code Code])} {coverage Coverage}) - (exception.report - ["Input" (%.code input)] - ["Branches" (%.code (code.record branches))] - ["Coverage" (/coverage.%coverage coverage)])) - -(exception: #export (cannot_have_empty_branches {message Text}) - message) - -(def: (re_quantify envs baseT) - (-> (List (List Type)) Type Type) - (.case envs - #.Nil - baseT - - (#.Cons head tail) - (re_quantify tail (#.UnivQ head baseT)))) - -## Type-checking on the input value is done during the analysis of a -## "case" expression, to ensure that the patterns being used make -## sense for the type of the input value. -## Sometimes, that input value is complex, by depending on -## type-variables or quantifications. -## This function makes it easier for "case" analysis to properly -## type-check the input with respect to the patterns. -(def: (simplify_case caseT) - (-> Type (Operation Type)) - (loop [envs (: (List (List Type)) - (list)) - caseT caseT] - (.case caseT - (#.Var id) - (do ///.monad - [?caseT' (//type.with_env - (check.read id))] - (.case ?caseT' - (#.Some caseT') - (recur envs caseT') - - _ - (/.throw ..cannot_simplify_for_pattern_matching caseT))) - - (#.Named name unnamedT) - (recur envs unnamedT) - - (#.UnivQ env unquantifiedT) - (recur (#.Cons env envs) unquantifiedT) - - (#.ExQ _) - (do ///.monad - [[var_id varT] (//type.with_env - check.var)] - (recur envs (maybe.assume (type.apply (list varT) caseT)))) - - (#.Apply inputT funcT) - (.case funcT - (#.Var funcT_id) - (do ///.monad - [funcT' (//type.with_env - (do check.monad - [?funct' (check.read funcT_id)] - (.case ?funct' - (#.Some funct') - (wrap funct') - - _ - (check.throw ..cannot_simplify_for_pattern_matching caseT))))] - (recur envs (#.Apply inputT funcT'))) - - _ - (.case (type.apply (list inputT) funcT) - (#.Some outputT) - (recur envs outputT) - - #.None - (/.throw ..cannot_simplify_for_pattern_matching caseT))) - - (#.Product _) - (|> caseT - type.flatten_tuple - (list\map (re_quantify envs)) - type.tuple - (\ ///.monad wrap)) - - _ - (\ ///.monad wrap (re_quantify envs caseT))))) - -(def: (analyse_primitive type inputT location output next) - (All [a] (-> Type Type Location Pattern (Operation a) (Operation [Pattern a]))) - (/.with_location location - (do ///.monad - [_ (//type.with_env - (check.check inputT type)) - outputA next] - (wrap [output outputA])))) - -## This function handles several concerns at once, but it must be that -## way because those concerns are interleaved when doing -## pattern-matching and they cannot be separated. -## The pattern is analysed in order to get a general feel for what is -## expected of the input value. This, in turn, informs the -## type-checking of the input. -## A kind of "continuation" value is passed around which signifies -## what needs to be done _after_ analysing a pattern. -## In general, this is done to analyse the "body" expression -## associated to a particular pattern _in the context of_ said -## pattern. -## The reason why *context* is important is because patterns may bind -## values to local variables, which may in turn be referenced in the -## body expressions. -## That is why the body must be analysed in the context of the -## pattern, and not separately. -(def: (analyse_pattern num_tags inputT pattern next) - (All [a] (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a]))) - (.case pattern - [location (#.Identifier ["" name])] - (/.with_location location - (do ///.monad - [outputA (//scope.with_local [name inputT] - next) - idx //scope.next_local] - (wrap [(#/.Bind idx) outputA]))) - - (^template [<type> <input> <output>] - [[location <input>] - (analyse_primitive <type> inputT location (#/.Simple <output>) next)]) - ([Bit (#.Bit pattern_value) (#/.Bit pattern_value)] - [Nat (#.Nat pattern_value) (#/.Nat pattern_value)] - [Int (#.Int pattern_value) (#/.Int pattern_value)] - [Rev (#.Rev pattern_value) (#/.Rev pattern_value)] - [Frac (#.Frac pattern_value) (#/.Frac pattern_value)] - [Text (#.Text pattern_value) (#/.Text pattern_value)] - [Any (#.Tuple #.Nil) #/.Unit]) - - (^ [location (#.Tuple (list singleton))]) - (analyse_pattern #.None inputT singleton next) - - [location (#.Tuple sub_patterns)] - (/.with_location location - (do {! ///.monad} - [inputT' (simplify_case inputT)] - (.case inputT' - (#.Product _) - (let [subs (type.flatten_tuple inputT') - num_subs (maybe.default (list.size subs) - num_tags) - num_sub_patterns (list.size sub_patterns) - matches (cond (n.< num_subs num_sub_patterns) - (let [[prefix suffix] (list.split (dec num_sub_patterns) subs)] - (list.zip/2 (list\compose prefix (list (type.tuple suffix))) sub_patterns)) - - (n.> num_subs num_sub_patterns) - (let [[prefix suffix] (list.split (dec num_subs) sub_patterns)] - (list.zip/2 subs (list\compose prefix (list (code.tuple suffix))))) - - ## (n.= num_subs num_sub_patterns) - (list.zip/2 subs sub_patterns))] - (do ! - [[memberP+ thenA] (list\fold (: (All [a] - (-> [Type Code] (Operation [(List Pattern) a]) - (Operation [(List Pattern) a]))) - (function (_ [memberT memberC] then) - (do ! - [[memberP [memberP+ thenA]] ((:as (All [a] (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a]))) - analyse_pattern) - #.None memberT memberC then)] - (wrap [(list& memberP memberP+) thenA])))) - (do ! - [nextA next] - (wrap [(list) nextA])) - (list.reverse matches))] - (wrap [(/.pattern/tuple memberP+) - thenA]))) - - _ - (/.throw ..cannot_match_with_pattern [inputT' pattern]) - ))) - - [location (#.Record record)] - (do ///.monad - [record (//structure.normalize record) - [members recordT] (//structure.order record) - _ (.case inputT - (#.Var _id) - (//type.with_env - (check.check inputT recordT)) - - _ - (wrap []))] - (analyse_pattern (#.Some (list.size members)) inputT [location (#.Tuple members)] next)) - - [location (#.Tag tag)] - (/.with_location location - (analyse_pattern #.None inputT (` ((~ pattern))) next)) - - (^ [location (#.Form (list& [_ (#.Nat lefts)] [_ (#.Bit right?)] values))]) - (/.with_location location - (do ///.monad - [inputT' (simplify_case inputT)] - (.case inputT' - (#.Sum _) - (let [flat_sum (type.flatten_variant inputT') - size_sum (list.size flat_sum) - num_cases (maybe.default size_sum num_tags) - idx (/.tag lefts right?)] - (.case (list.nth idx flat_sum) - (^multi (#.Some caseT) - (n.< num_cases idx)) - (do ///.monad - [[testP nextA] (if (and (n.> num_cases size_sum) - (n.= (dec num_cases) idx)) - (analyse_pattern #.None - (type.variant (list.drop (dec num_cases) flat_sum)) - (` [(~+ values)]) - next) - (analyse_pattern #.None caseT (` [(~+ values)]) next))] - (wrap [(/.pattern/variant [lefts right? testP]) - nextA])) - - _ - (/.throw ..sum_has_no_case [idx inputT]))) - - (#.UnivQ _) - (do ///.monad - [[ex_id exT] (//type.with_env - check.existential)] - (analyse_pattern num_tags - (maybe.assume (type.apply (list exT) inputT')) - pattern - next)) - - _ - (/.throw ..cannot_match_with_pattern [inputT' pattern])))) - - (^ [location (#.Form (list& [_ (#.Tag tag)] values))]) - (/.with_location location - (do ///.monad - [tag (///extension.lift (meta.normalize tag)) - [idx group variantT] (///extension.lift (meta.resolve_tag tag)) - _ (//type.with_env - (check.check inputT variantT)) - #let [[lefts right?] (/.choice (list.size group) idx)]] - (analyse_pattern (#.Some (list.size group)) inputT (` ((~ (code.nat lefts)) (~ (code.bit right?)) (~+ values))) next))) - - _ - (/.throw ..not_a_pattern pattern) - )) - -(def: #export (case analyse branches archive inputC) - (-> Phase (List [Code Code]) Phase) - (.case branches - (#.Cons [patternH bodyH] branchesT) - (do {! ///.monad} - [[inputT inputA] (//type.with_inference - (analyse archive inputC)) - outputH (analyse_pattern #.None inputT patternH (analyse archive bodyH)) - outputT (monad.map ! - (function (_ [patternT bodyT]) - (analyse_pattern #.None inputT patternT (analyse archive bodyT))) - branchesT) - outputHC (|> outputH product.left /coverage.determine) - outputTC (monad.map ! (|>> product.left /coverage.determine) outputT) - _ (.case (monad.fold try.monad /coverage.merge outputHC outputTC) - (#try.Success coverage) - (///.assert non_exhaustive_pattern_matching [inputC branches coverage] - (/coverage.exhaustive? coverage)) - - (#try.Failure error) - (/.fail error))] - (wrap (#/.Case inputA [outputH outputT]))) - - #.Nil - (/.throw ..cannot_have_empty_branches ""))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux deleted file mode 100644 index 4a3afc3f5..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux +++ /dev/null @@ -1,372 +0,0 @@ -(.module: - [lux #* - [abstract - equivalence - ["." monad (#+ do)]] - [control - ["." try (#+ Try) ("#\." monad)] - ["ex" exception (#+ exception:)]] - [data - ["." bit ("#\." equivalence)] - ["." maybe] - ["." text - ["%" format (#+ Format format)]] - [collection - ["." list ("#\." functor fold)] - ["." dictionary (#+ Dictionary)]]] - [math - [number - ["n" nat]]]] - ["." //// #_ - [// - ["/" analysis (#+ Pattern Variant Operation)] - [/// - ["#" phase ("#\." monad)]]]]) - -(exception: #export (invalid_tuple_pattern) - "Tuple size must be >= 2") - -(def: cases - (-> (Maybe Nat) Nat) - (|>> (maybe.default 0))) - -(def: known_cases? - (-> Nat Bit) - (n.> 0)) - -## The coverage of a pattern-matching expression summarizes how well -## all the possible values of an input are being covered by the -## different patterns involved. -## Ideally, the pattern-matching has "exhaustive" coverage, which just -## means that every possible value can be matched by at least 1 -## pattern. -## Every other coverage is considered partial, and it would be valued -## as insuficient (since it could lead to runtime errors due to values -## not being handled by any pattern). -## The #Partial tag covers arbitrary partial coverages in a general -## way, while the other tags cover more specific cases for bits -## and variants. -(type: #export #rec Coverage - #Partial - (#Bit Bit) - (#Variant (Maybe Nat) (Dictionary Nat Coverage)) - (#Seq Coverage Coverage) - (#Alt Coverage Coverage) - #Exhaustive) - -(def: #export (exhaustive? coverage) - (-> Coverage Bit) - (case coverage - (#Exhaustive _) - #1 - - _ - #0)) - -(def: #export (%coverage value) - (Format Coverage) - (case value - #Partial - "#Partial" - - (#Bit value') - (|> value' - %.bit - (text.enclose ["(#Bit " ")"])) - - (#Variant ?max_cases cases) - (|> cases - dictionary.entries - (list\map (function (_ [idx coverage]) - (format (%.nat idx) " " (%coverage coverage)))) - (text.join_with " ") - (text.enclose ["{" "}"]) - (format (%.nat (..cases ?max_cases)) " ") - (text.enclose ["(#Variant " ")"])) - - (#Seq left right) - (format "(#Seq " (%coverage left) " " (%coverage right) ")") - - (#Alt left right) - (format "(#Alt " (%coverage left) " " (%coverage right) ")") - - #Exhaustive - "#Exhaustive")) - -(def: #export (determine pattern) - (-> Pattern (Operation Coverage)) - (case pattern - (^or (#/.Simple #/.Unit) - (#/.Bind _)) - (////\wrap #Exhaustive) - - ## Primitive patterns always have partial coverage because there - ## are too many possibilities as far as values go. - (^template [<tag>] - [(#/.Simple (<tag> _)) - (////\wrap #Partial)]) - ([#/.Nat] - [#/.Int] - [#/.Rev] - [#/.Frac] - [#/.Text]) - - ## Bits are the exception, since there is only "#1" and - ## "#0", which means it is possible for bit - ## pattern-matching to become exhaustive if complementary parts meet. - (#/.Simple (#/.Bit value)) - (////\wrap (#Bit value)) - - ## Tuple patterns can be exhaustive if there is exhaustiveness for all of - ## their sub-patterns. - (#/.Complex (#/.Tuple membersP+)) - (case (list.reverse membersP+) - (^or #.Nil (#.Cons _ #.Nil)) - (/.throw ..invalid_tuple_pattern []) - - (#.Cons lastP prevsP+) - (do ////.monad - [lastC (determine lastP)] - (monad.fold ////.monad - (function (_ leftP rightC) - (do ////.monad - [leftC (determine leftP)] - (case rightC - #Exhaustive - (wrap leftC) - - _ - (wrap (#Seq leftC rightC))))) - lastC prevsP+))) - - ## Variant patterns can be shown to be exhaustive if all the possible - ## cases are handled exhaustively. - (#/.Complex (#/.Variant [lefts right? value])) - (do ////.monad - [value_coverage (determine value) - #let [idx (if right? - (inc lefts) - lefts)]] - (wrap (#Variant (if right? - (#.Some idx) - #.None) - (|> (dictionary.new n.hash) - (dictionary.put idx value_coverage))))))) - -(def: (xor left right) - (-> Bit Bit Bit) - (or (and left (not right)) - (and (not left) right))) - -## The coverage checker not only verifies that pattern-matching is -## exhaustive, but also that there are no redundant patterns. -## Redundant patterns will never be executed, since there will -## always be a pattern prior to them that would match the input. -## Because of that, the presence of redundant patterns is assumed to -## be a bug, likely due to programmer carelessness. -(exception: #export (redundant_pattern {so_far Coverage} {addition Coverage}) - (ex.report ["Coverage so-far" (%coverage so_far)] - ["Coverage addition" (%coverage addition)])) - -(def: (flatten_alt coverage) - (-> Coverage (List Coverage)) - (case coverage - (#Alt left right) - (list& left (flatten_alt right)) - - _ - (list coverage))) - -(implementation: equivalence (Equivalence Coverage) - (def: (= reference sample) - (case [reference sample] - [#Exhaustive #Exhaustive] - #1 - - [(#Bit sideR) (#Bit sideS)] - (bit\= sideR sideS) - - [(#Variant allR casesR) (#Variant allS casesS)] - (and (n.= (cases allR) - (cases allS)) - (\ (dictionary.equivalence =) = casesR casesS)) - - [(#Seq leftR rightR) (#Seq leftS rightS)] - (and (= leftR leftS) - (= rightR rightS)) - - [(#Alt _) (#Alt _)] - (let [flatR (flatten_alt reference) - flatS (flatten_alt sample)] - (and (n.= (list.size flatR) (list.size flatS)) - (list.every? (function (_ [coverageR coverageS]) - (= coverageR coverageS)) - (list.zip/2 flatR flatS)))) - - _ - #0))) - -(open: "coverage/." ..equivalence) - -(exception: #export (variants_do_not_match {addition_cases Nat} {so_far_cases Nat}) - (ex.report ["So-far Cases" (%.nat so_far_cases)] - ["Addition Cases" (%.nat addition_cases)])) - -## After determining the coverage of each individual pattern, it is -## necessary to merge them all to figure out if the entire -## pattern-matching expression is exhaustive and whether it contains -## redundant patterns. -(def: #export (merge addition so_far) - (-> Coverage Coverage (Try Coverage)) - (case [addition so_far] - [#Partial #Partial] - (try\wrap #Partial) - - ## 2 bit coverages are exhaustive if they complement one another. - (^multi [(#Bit sideA) (#Bit sideSF)] - (xor sideA sideSF)) - (try\wrap #Exhaustive) - - [(#Variant allA casesA) (#Variant allSF casesSF)] - (let [addition_cases (cases allSF) - so_far_cases (cases allA)] - (cond (and (known_cases? addition_cases) - (known_cases? so_far_cases) - (not (n.= addition_cases so_far_cases))) - (ex.throw ..variants_do_not_match [addition_cases so_far_cases]) - - (\ (dictionary.equivalence ..equivalence) = casesSF casesA) - (ex.throw ..redundant_pattern [so_far addition]) - - ## else - (do {! try.monad} - [casesM (monad.fold ! - (function (_ [tagA coverageA] casesSF') - (case (dictionary.get tagA casesSF') - (#.Some coverageSF) - (do ! - [coverageM (merge coverageA coverageSF)] - (wrap (dictionary.put tagA coverageM casesSF'))) - - #.None - (wrap (dictionary.put tagA coverageA casesSF')))) - casesSF (dictionary.entries casesA))] - (wrap (if (and (or (known_cases? addition_cases) - (known_cases? so_far_cases)) - (n.= (inc (n.max addition_cases so_far_cases)) - (dictionary.size casesM)) - (list.every? exhaustive? (dictionary.values casesM))) - #Exhaustive - (#Variant (case allSF - (#.Some _) - allSF - - _ - allA) - casesM)))))) - - [(#Seq leftA rightA) (#Seq leftSF rightSF)] - (case [(coverage/= leftSF leftA) (coverage/= rightSF rightA)] - ## Same prefix - [#1 #0] - (do try.monad - [rightM (merge rightA rightSF)] - (if (exhaustive? rightM) - ## If all that follows is exhaustive, then it can be safely dropped - ## (since only the "left" part would influence whether the - ## merged coverage is exhaustive or not). - (wrap leftSF) - (wrap (#Seq leftSF rightM)))) - - ## Same suffix - [#0 #1] - (do try.monad - [leftM (merge leftA leftSF)] - (wrap (#Seq leftM rightA))) - - ## The 2 sequences cannot possibly be merged. - [#0 #0] - (try\wrap (#Alt so_far addition)) - - ## There is nothing the addition adds to the coverage. - [#1 #1] - (ex.throw ..redundant_pattern [so_far addition])) - - ## The addition cannot possibly improve the coverage. - [_ #Exhaustive] - (ex.throw ..redundant_pattern [so_far addition]) - - ## The addition completes the coverage. - [#Exhaustive _] - (try\wrap #Exhaustive) - - ## The left part will always match, so the addition is redundant. - (^multi [(#Seq left right) single] - (coverage/= left single)) - (ex.throw ..redundant_pattern [so_far addition]) - - ## The right part is not necessary, since it can always match the left. - (^multi [single (#Seq left right)] - (coverage/= left single)) - (try\wrap single) - - ## When merging a new coverage against one based on Alt, it may be - ## that one of the many coverages in the Alt is complementary to - ## the new one, so effort must be made to fuse carefully, to match - ## the right coverages together. - ## If one of the Alt sub-coverages matches the new one, the cycle - ## must be repeated, in case the resulting coverage can now match - ## other ones in the original Alt. - ## This process must be repeated until no further productive - ## merges can be done. - [_ (#Alt leftS rightS)] - (do {! try.monad} - [#let [fuse_once (: (-> Coverage (List Coverage) - (Try [(Maybe Coverage) - (List Coverage)])) - (function (_ coverageA possibilitiesSF) - (loop [altsSF possibilitiesSF] - (case altsSF - #.Nil - (wrap [#.None (list coverageA)]) - - (#.Cons altSF altsSF') - (case (merge coverageA altSF) - (#try.Success altMSF) - (case altMSF - (#Alt _) - (do ! - [[success altsSF+] (recur altsSF')] - (wrap [success (#.Cons altSF altsSF+)])) - - _ - (wrap [(#.Some altMSF) altsSF'])) - - (#try.Failure error) - (try.fail error)) - ))))] - [successA possibilitiesSF] (fuse_once addition (flatten_alt so_far))] - (loop [successA successA - possibilitiesSF possibilitiesSF] - (case successA - (#.Some coverageA') - (do ! - [[successA' possibilitiesSF'] (fuse_once coverageA' possibilitiesSF)] - (recur successA' possibilitiesSF')) - - #.None - (case (list.reverse possibilitiesSF) - (#.Cons last prevs) - (wrap (list\fold (function (_ left right) (#Alt left right)) - last - prevs)) - - #.Nil - (undefined))))) - - _ - (if (coverage/= so_far addition) - ## The addition cannot possibly improve the coverage. - (ex.throw ..redundant_pattern [so_far addition]) - ## There are now 2 alternative paths. - (try\wrap (#Alt so_far addition))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/function.lux deleted file mode 100644 index 3b654fffd..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/function.lux +++ /dev/null @@ -1,112 +0,0 @@ -(.module: - [lux (#- function) - [abstract - monad] - [control - ["ex" exception (#+ exception:)]] - [data - ["." maybe] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." fold monoid monad)]]] - ["." type - ["." check]] - ["." meta]] - ["." // #_ - ["#." scope] - ["#." type] - ["#." inference] - ["/#" // #_ - ["#." extension] - [// - ["/" analysis (#+ Analysis Operation Phase)] - [/// - ["#" phase] - [reference (#+) - [variable (#+)]]]]]]) - -(exception: #export (cannot_analyse {expected Type} {function Text} {argument Text} {body Code}) - (ex.report ["Type" (%.type expected)] - ["Function" function] - ["Argument" argument] - ["Body" (%.code body)])) - -(exception: #export (cannot_apply {functionT Type} {functionC Code} {arguments (List Code)}) - (ex.report ["Function type" (%.type functionT)] - ["Function" (%.code functionC)] - ["Arguments" (|> arguments - list.enumeration - (list\map (.function (_ [idx argC]) - (format (%.nat idx) " " (%.code argC)))) - (text.join_with text.new_line))])) - -(def: #export (function analyse function_name arg_name archive body) - (-> Phase Text Text Phase) - (do {! ///.monad} - [functionT (///extension.lift meta.expected_type)] - (loop [expectedT functionT] - (/.with_stack ..cannot_analyse [expectedT function_name arg_name body] - (case expectedT - (#.Named name unnamedT) - (recur unnamedT) - - (#.Apply argT funT) - (case (type.apply (list argT) funT) - (#.Some value) - (recur value) - - #.None - (/.fail (ex.construct cannot_analyse [expectedT function_name arg_name body]))) - - (^template [<tag> <instancer>] - [(<tag> _) - (do ! - [[_ instanceT] (//type.with_env <instancer>)] - (recur (maybe.assume (type.apply (list instanceT) expectedT))))]) - ([#.UnivQ check.existential] - [#.ExQ check.var]) - - (#.Var id) - (do ! - [?expectedT' (//type.with_env - (check.read id))] - (case ?expectedT' - (#.Some expectedT') - (recur expectedT') - - ## Inference - _ - (do ! - [[input_id inputT] (//type.with_env check.var) - [output_id outputT] (//type.with_env check.var) - #let [functionT (#.Function inputT outputT)] - functionA (recur functionT) - _ (//type.with_env - (check.check expectedT functionT))] - (wrap functionA)) - )) - - (#.Function inputT outputT) - (<| (\ ! map (.function (_ [scope bodyA]) - (#/.Function (list\map (|>> /.variable) - (//scope.environment scope)) - bodyA))) - /.with_scope - ## Functions have access not only to their argument, but - ## also to themselves, through a local variable. - (//scope.with_local [function_name expectedT]) - (//scope.with_local [arg_name inputT]) - (//type.with_type outputT) - (analyse archive body)) - - _ - (/.fail "") - ))))) - -(def: #export (apply analyse argsC+ functionT functionA archive functionC) - (-> Phase (List Code) Type Analysis Phase) - (<| (/.with_stack ..cannot_apply [functionT functionC argsC+]) - (do ///.monad - [[applyT argsA+] (//inference.general archive analyse functionT argsC+)]) - (wrap (/.apply [functionA argsA+])))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux deleted file mode 100644 index 31a5cb912..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux +++ /dev/null @@ -1,300 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." exception (#+ exception:)]] - [data - ["." maybe] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)]]] - [math - [number - ["n" nat]]] - ["." type - ["." check]] - ["." meta]] - ["." // #_ - ["#." type] - ["/#" // #_ - ["#." extension] - [// - ["/" analysis (#+ Tag Analysis Operation Phase)] - [/// - ["#" phase ("#\." monad)] - [meta - [archive (#+ Archive)]]]]]]) - -(exception: #export (variant_tag_out_of_bounds {size Nat} {tag Tag} {type Type}) - (exception.report - ["Tag" (%.nat tag)] - ["Variant size" (%.int (.int size))] - ["Variant type" (%.type type)])) - -(exception: #export (cannot_infer {type Type} {args (List Code)}) - (exception.report - ["Type" (%.type type)] - ["Arguments" (exception.enumerate %.code args)])) - -(exception: #export (cannot_infer_argument {inferred Type} {argument Code}) - (exception.report - ["Inferred Type" (%.type inferred)] - ["Argument" (%.code argument)])) - -(exception: #export (smaller_variant_than_expected {expected Nat} {actual Nat}) - (exception.report - ["Expected" (%.int (.int expected))] - ["Actual" (%.int (.int actual))])) - -(template [<name>] - [(exception: #export (<name> {type Type}) - (%.type type))] - - [not_a_variant_type] - [not_a_record_type] - [invalid_type_application] - ) - -(def: (replace parameter_idx replacement type) - (-> Nat Type Type Type) - (case type - (#.Primitive name params) - (#.Primitive name (list\map (replace parameter_idx replacement) params)) - - (^template [<tag>] - [(<tag> left right) - (<tag> (replace parameter_idx replacement left) - (replace parameter_idx replacement right))]) - ([#.Sum] - [#.Product] - [#.Function] - [#.Apply]) - - (#.Parameter idx) - (if (n.= parameter_idx idx) - replacement - type) - - (^template [<tag>] - [(<tag> env quantified) - (<tag> (list\map (replace parameter_idx replacement) env) - (replace (n.+ 2 parameter_idx) replacement quantified))]) - ([#.UnivQ] - [#.ExQ]) - - _ - type)) - -(def: (named_type location id) - (-> Location Nat Type) - (let [name (format "{New Type " (%.location location) " " (%.nat id) "}")] - (#.Primitive name (list)))) - -(def: new_named_type - (Operation Type) - (do ///.monad - [location (///extension.lift meta.location) - [ex_id _] (//type.with_env check.existential)] - (wrap (named_type location ex_id)))) - -## Type-inference works by applying some (potentially quantified) type -## to a sequence of values. -## Function types are used for this, although inference is not always -## done for function application (alternative uses may be records and -## tagged variants). -## But, so long as the type being used for the inference can be treated -## as a function type, this method of inference should work. -(def: #export (general archive analyse inferT args) - (-> Archive Phase Type (List Code) (Operation [Type (List Analysis)])) - (case args - #.Nil - (do ///.monad - [_ (//type.infer inferT)] - (wrap [inferT (list)])) - - (#.Cons argC args') - (case inferT - (#.Named name unnamedT) - (general archive analyse unnamedT args) - - (#.UnivQ _) - (do ///.monad - [[var_id varT] (//type.with_env check.var)] - (general archive analyse (maybe.assume (type.apply (list varT) inferT)) args)) - - (#.ExQ _) - (do {! ///.monad} - [[var_id varT] (//type.with_env check.var) - output (general archive analyse - (maybe.assume (type.apply (list varT) inferT)) - args) - bound? (//type.with_env - (check.bound? var_id)) - _ (if bound? - (wrap []) - (do ! - [newT new_named_type] - (//type.with_env - (check.check varT newT))))] - (wrap output)) - - (#.Apply inputT transT) - (case (type.apply (list inputT) transT) - (#.Some outputT) - (general archive analyse outputT args) - - #.None - (/.throw ..invalid_type_application inferT)) - - ## Arguments are inferred back-to-front because, by convention, - ## Lux functions take the most important arguments *last*, which - ## means that the most information for doing proper inference is - ## located in the last arguments to a function call. - ## By inferring back-to-front, a lot of type-annotations can be - ## avoided in Lux code, since the inference algorithm can piece - ## things together more easily. - (#.Function inputT outputT) - (do ///.monad - [[outputT' args'A] (general archive analyse outputT args') - argA (<| (/.with_stack ..cannot_infer_argument [inputT argC]) - (//type.with_type inputT) - (analyse archive argC))] - (wrap [outputT' (list& argA args'A)])) - - (#.Var infer_id) - (do ///.monad - [?inferT' (//type.with_env (check.read infer_id))] - (case ?inferT' - (#.Some inferT') - (general archive analyse inferT' args) - - _ - (/.throw ..cannot_infer [inferT args]))) - - _ - (/.throw ..cannot_infer [inferT args])) - )) - -(def: (substitute_bound target sub) - (-> Nat Type Type Type) - (function (recur base) - (case base - (#.Primitive name parameters) - (#.Primitive name (list\map recur parameters)) - - (^template [<tag>] - [(<tag> left right) - (<tag> (recur left) (recur right))]) - ([#.Sum] [#.Product] [#.Function] [#.Apply]) - - (#.Parameter index) - (if (n.= target index) - sub - base) - - (^template [<tag>] - [(<tag> environment quantified) - (<tag> (list\map recur environment) quantified)]) - ([#.UnivQ] [#.ExQ]) - - _ - base))) - -## Turns a record type into the kind of function type suitable for inference. -(def: (record' target originalT inferT) - (-> Nat Type Type (Operation Type)) - (case inferT - (#.Named name unnamedT) - (record' target originalT unnamedT) - - (^template [<tag>] - [(<tag> env bodyT) - (do ///.monad - [bodyT+ (record' (n.+ 2 target) originalT bodyT)] - (wrap (<tag> env bodyT+)))]) - ([#.UnivQ] - [#.ExQ]) - - (#.Apply inputT funcT) - (case (type.apply (list inputT) funcT) - (#.Some outputT) - (record' target originalT outputT) - - #.None - (/.throw ..invalid_type_application inferT)) - - (#.Product _) - (///\wrap (|> inferT - (type.function (type.flatten_tuple inferT)) - (substitute_bound target originalT))) - - _ - (/.throw ..not_a_record_type inferT))) - -(def: #export (record inferT) - (-> Type (Operation Type)) - (record' (n.- 2 0) inferT inferT)) - -## Turns a variant type into the kind of function type suitable for inference. -(def: #export (variant tag expected_size inferT) - (-> Nat Nat Type (Operation Type)) - (loop [depth 0 - currentT inferT] - (case currentT - (#.Named name unnamedT) - (do ///.monad - [unnamedT+ (recur depth unnamedT)] - (wrap unnamedT+)) - - (^template [<tag>] - [(<tag> env bodyT) - (do ///.monad - [bodyT+ (recur (inc depth) bodyT)] - (wrap (<tag> env bodyT+)))]) - ([#.UnivQ] - [#.ExQ]) - - (#.Sum _) - (let [cases (type.flatten_variant currentT) - actual_size (list.size cases) - boundary (dec expected_size)] - (cond (or (n.= expected_size actual_size) - (and (n.> expected_size actual_size) - (n.< boundary tag))) - (case (list.nth tag cases) - (#.Some caseT) - (///\wrap (if (n.= 0 depth) - (type.function (list caseT) currentT) - (let [replace' (replace (|> depth dec (n.* 2)) inferT)] - (type.function (list (replace' caseT)) - (replace' currentT))))) - - #.None - (/.throw ..variant_tag_out_of_bounds [expected_size tag inferT])) - - (n.< expected_size actual_size) - (/.throw ..smaller_variant_than_expected [expected_size actual_size]) - - (n.= boundary tag) - (let [caseT (type.variant (list.drop boundary cases))] - (///\wrap (if (n.= 0 depth) - (type.function (list caseT) currentT) - (let [replace' (replace (|> depth dec (n.* 2)) inferT)] - (type.function (list (replace' caseT)) - (replace' currentT)))))) - - ## else - (/.throw ..variant_tag_out_of_bounds [expected_size tag inferT]))) - - (#.Apply inputT funcT) - (case (type.apply (list inputT) funcT) - (#.Some outputT) - (variant tag expected_size outputT) - - #.None - (/.throw ..invalid_type_application inferT)) - - _ - (/.throw ..not_a_variant_type inferT)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/module.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/module.lux deleted file mode 100644 index 1d7e5dc27..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/module.lux +++ /dev/null @@ -1,274 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - pipe - ["." try] - ["." exception (#+ exception:)]] - [data - ["." text ("#\." equivalence) - ["%" format (#+ format)]] - [collection - ["." list ("#\." fold functor)] - [dictionary - ["." plist]]]] - ["." meta]] - ["." /// #_ - ["#." extension] - [// - ["/" analysis (#+ Operation)] - [/// - ["#" phase]]]]) - -(type: #export Tag Text) - -(exception: #export (unknown_module {module Text}) - (exception.report - ["Module" module])) - -(exception: #export (cannot_declare_tag_twice {module Text} {tag Text}) - (exception.report - ["Module" module] - ["Tag" tag])) - -(template [<name>] - [(exception: #export (<name> {tags (List Text)} {owner Type}) - (exception.report - ["Tags" (text.join_with " " tags)] - ["Type" (%.type owner)]))] - - [cannot_declare_tags_for_unnamed_type] - [cannot_declare_tags_for_foreign_type] - ) - -(exception: #export (cannot_define_more_than_once {name Name} {already_existing Global}) - (exception.report - ["Definition" (%.name name)] - ["Original" (case already_existing - (#.Alias alias) - (format "alias " (%.name alias)) - - (#.Definition definition) - (format "definition " (%.name name)))])) - -(exception: #export (can_only_change_state_of_active_module {module Text} {state Module_State}) - (exception.report - ["Module" module] - ["Desired state" (case state - #.Active "Active" - #.Compiled "Compiled" - #.Cached "Cached")])) - -(exception: #export (cannot_set_module_annotations_more_than_once {module Text} {old Code} {new Code}) - (exception.report - ["Module" module] - ["Old annotations" (%.code old)] - ["New annotations" (%.code new)])) - -(def: #export (new hash) - (-> Nat Module) - {#.module_hash hash - #.module_aliases (list) - #.definitions (list) - #.imports (list) - #.tags (list) - #.types (list) - #.module_annotations #.None - #.module_state #.Active}) - -(def: #export (set_annotations annotations) - (-> Code (Operation Any)) - (///extension.lift - (do ///.monad - [self_name meta.current_module_name - self meta.current_module] - (case (get@ #.module_annotations self) - #.None - (function (_ state) - (#try.Success [(update@ #.modules - (plist.put self_name (set@ #.module_annotations (#.Some annotations) self)) - state) - []])) - - (#.Some old) - (/.throw' cannot_set_module_annotations_more_than_once [self_name old annotations]))))) - -(def: #export (import module) - (-> Text (Operation Any)) - (///extension.lift - (do ///.monad - [self_name meta.current_module_name] - (function (_ state) - (#try.Success [(update@ #.modules - (plist.update self_name (update@ #.imports (function (_ current) - (if (list.any? (text\= module) - current) - current - (#.Cons module current))))) - state) - []]))))) - -(def: #export (alias alias module) - (-> Text Text (Operation Any)) - (///extension.lift - (do ///.monad - [self_name meta.current_module_name] - (function (_ state) - (#try.Success [(update@ #.modules - (plist.update self_name (update@ #.module_aliases (: (-> (List [Text Text]) (List [Text Text])) - (|>> (#.Cons [alias module]))))) - state) - []]))))) - -(def: #export (exists? module) - (-> Text (Operation Bit)) - (///extension.lift - (function (_ state) - (|> state - (get@ #.modules) - (plist.get module) - (case> (#.Some _) #1 #.None #0) - [state] #try.Success)))) - -(def: #export (define name definition) - (-> Text Global (Operation Any)) - (///extension.lift - (do ///.monad - [self_name meta.current_module_name - self meta.current_module] - (function (_ state) - (case (plist.get name (get@ #.definitions self)) - #.None - (#try.Success [(update@ #.modules - (plist.put self_name - (update@ #.definitions - (: (-> (List [Text Global]) (List [Text Global])) - (|>> (#.Cons [name definition]))) - self)) - state) - []]) - - (#.Some already_existing) - ((/.throw' ..cannot_define_more_than_once [[self_name name] already_existing]) state)))))) - -(def: #export (create hash name) - (-> Nat Text (Operation Any)) - (///extension.lift - (function (_ state) - (#try.Success [(update@ #.modules - (plist.put name (new hash)) - state) - []])))) - -(def: #export (with_module hash name action) - (All [a] (-> Nat Text (Operation a) (Operation [Module a]))) - (do ///.monad - [_ (create hash name) - output (/.with_current_module name - action) - module (///extension.lift (meta.find_module name))] - (wrap [module output]))) - -(template [<setter> <asker> <tag>] - [(def: #export (<setter> module_name) - (-> Text (Operation Any)) - (///extension.lift - (function (_ state) - (case (|> state (get@ #.modules) (plist.get module_name)) - (#.Some module) - (let [active? (case (get@ #.module_state module) - #.Active #1 - _ #0)] - (if active? - (#try.Success [(update@ #.modules - (plist.put module_name (set@ #.module_state <tag> module)) - state) - []]) - ((/.throw' can_only_change_state_of_active_module [module_name <tag>]) - state))) - - #.None - ((/.throw' unknown_module module_name) state))))) - - (def: #export (<asker> module_name) - (-> Text (Operation Bit)) - (///extension.lift - (function (_ state) - (case (|> state (get@ #.modules) (plist.get module_name)) - (#.Some module) - (#try.Success [state - (case (get@ #.module_state module) - <tag> #1 - _ #0)]) - - #.None - ((/.throw' unknown_module module_name) state)))))] - - [set_active active? #.Active] - [set_compiled compiled? #.Compiled] - [set_cached cached? #.Cached] - ) - -(template [<name> <tag> <type>] - [(def: (<name> module_name) - (-> Text (Operation <type>)) - (///extension.lift - (function (_ state) - (case (|> state (get@ #.modules) (plist.get module_name)) - (#.Some module) - (#try.Success [state (get@ <tag> module)]) - - #.None - ((/.throw' unknown_module module_name) state)))))] - - [tags #.tags (List [Text [Nat (List Name) Bit Type]])] - [types #.types (List [Text [(List Name) Bit Type]])] - [hash #.module_hash Nat] - ) - -(def: (ensure_undeclared_tags module_name tags) - (-> Text (List Tag) (Operation Any)) - (do {! ///.monad} - [bindings (..tags module_name) - _ (monad.map ! - (function (_ tag) - (case (plist.get tag bindings) - #.None - (wrap []) - - (#.Some _) - (/.throw ..cannot_declare_tag_twice [module_name tag]))) - tags)] - (wrap []))) - -(def: #export (declare_tags tags exported? type) - (-> (List Tag) Bit Type (Operation Any)) - (do ///.monad - [self_name (///extension.lift meta.current_module_name) - [type_module type_name] (case type - (#.Named type_name _) - (wrap type_name) - - _ - (/.throw ..cannot_declare_tags_for_unnamed_type [tags type])) - _ (ensure_undeclared_tags self_name tags) - _ (///.assert cannot_declare_tags_for_foreign_type [tags type] - (text\= self_name type_module))] - (///extension.lift - (function (_ state) - (case (|> state (get@ #.modules) (plist.get self_name)) - (#.Some module) - (let [namespaced_tags (list\map (|>> [self_name]) tags)] - (#try.Success [(update@ #.modules - (plist.update self_name - (|>> (update@ #.tags (function (_ tag_bindings) - (list\fold (function (_ [idx tag] table) - (plist.put tag [idx namespaced_tags exported? type] table)) - tag_bindings - (list.enumeration tags)))) - (update@ #.types (plist.put type_name [namespaced_tags exported? type])))) - state) - []])) - #.None - ((/.throw' unknown_module self_name) state)))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/primitive.lux deleted file mode 100644 index dfdb7e314..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/primitive.lux +++ /dev/null @@ -1,32 +0,0 @@ -(.module: - [lux (#- nat int rev) - [abstract - monad]] - ["." // #_ - ["#." type] - ["/#" // #_ - [// - ["/" analysis (#+ Analysis Operation)] - [/// - ["#" phase]]]]]) - -(template [<name> <type> <tag>] - [(def: #export (<name> value) - (-> <type> (Operation Analysis)) - (do ///.monad - [_ (//type.infer <type>)] - (wrap (#/.Primitive (<tag> value)))))] - - [bit .Bit #/.Bit] - [nat .Nat #/.Nat] - [int .Int #/.Int] - [rev .Rev #/.Rev] - [frac .Frac #/.Frac] - [text .Text #/.Text] - ) - -(def: #export unit - (Operation Analysis) - (do ///.monad - [_ (//type.infer .Any)] - (wrap (#/.Primitive #/.Unit)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/reference.lux deleted file mode 100644 index a3653935f..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/reference.lux +++ /dev/null @@ -1,84 +0,0 @@ -(.module: - [lux #* - [abstract - monad] - [control - ["." exception (#+ exception:)]] - ["." meta] - [data - ["." text ("#\." equivalence) - ["%" format (#+ format)]]]] - ["." // #_ - ["#." scope] - ["#." type] - ["/#" // #_ - ["#." extension] - [// - ["/" analysis (#+ Analysis Operation)] - [/// - ["#." reference] - ["#" phase]]]]]) - -(exception: #export (foreign_module_has_not_been_imported {current Text} {foreign Text}) - (exception.report - ["Current" current] - ["Foreign" foreign])) - -(exception: #export (definition_has_not_been_exported {definition Name}) - (exception.report - ["Definition" (%.name definition)])) - -(def: (definition def_name) - (-> Name (Operation Analysis)) - (with_expansions [<return> (wrap (|> def_name ///reference.constant #/.Reference))] - (do {! ///.monad} - [constant (///extension.lift (meta.find_def def_name))] - (case constant - (#.Left real_def_name) - (definition real_def_name) - - (#.Right [exported? actualT def_anns _]) - (do ! - [_ (//type.infer actualT) - (^@ def_name [::module ::name]) (///extension.lift (meta.normalize def_name)) - current (///extension.lift meta.current_module_name)] - (if (text\= current ::module) - <return> - (if exported? - (do ! - [imported! (///extension.lift (meta.imported_by? ::module current))] - (if imported! - <return> - (/.throw foreign_module_has_not_been_imported [current ::module]))) - (/.throw definition_has_not_been_exported def_name)))))))) - -(def: (variable var_name) - (-> Text (Operation (Maybe Analysis))) - (do {! ///.monad} - [?var (//scope.find var_name)] - (case ?var - (#.Some [actualT ref]) - (do ! - [_ (//type.infer actualT)] - (wrap (#.Some (|> ref ///reference.variable #/.Reference)))) - - #.None - (wrap #.None)))) - -(def: #export (reference reference) - (-> Name (Operation Analysis)) - (case reference - ["" simple_name] - (do {! ///.monad} - [?var (variable simple_name)] - (case ?var - (#.Some varA) - (wrap varA) - - #.None - (do ! - [this_module (///extension.lift meta.current_module_name)] - (definition [this_module simple_name])))) - - _ - (definition reference))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/scope.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/scope.lux deleted file mode 100644 index beee6a1b7..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/scope.lux +++ /dev/null @@ -1,205 +0,0 @@ -(.module: - [lux #* - [abstract - monad] - [control - ["." try] - ["." exception (#+ exception:)]] - [data - ["." text ("#\." equivalence)] - ["." maybe ("#\." monad)] - ["." product] - [collection - ["." list ("#\." functor fold monoid)] - [dictionary - ["." plist]]]]] - ["." /// #_ - ["#." extension] - [// - ["/" analysis (#+ Operation Phase)] - [/// - [reference - ["." variable (#+ Register Variable)]] - ["#" phase]]]]) - -(type: Local (Bindings Text [Type Register])) -(type: Foreign (Bindings Text [Type Variable])) - -(def: (local? name scope) - (-> Text Scope Bit) - (|> scope - (get@ [#.locals #.mappings]) - (plist.contains? name))) - -(def: (local name scope) - (-> Text Scope (Maybe [Type Variable])) - (|> scope - (get@ [#.locals #.mappings]) - (plist.get name) - (maybe\map (function (_ [type value]) - [type (#variable.Local value)])))) - -(def: (captured? name scope) - (-> Text Scope Bit) - (|> scope - (get@ [#.captured #.mappings]) - (plist.contains? name))) - -(def: (captured name scope) - (-> Text Scope (Maybe [Type Variable])) - (loop [idx 0 - mappings (get@ [#.captured #.mappings] scope)] - (case mappings - (#.Cons [_name [_source_type _source_ref]] mappings') - (if (text\= name _name) - (#.Some [_source_type (#variable.Foreign idx)]) - (recur (inc idx) mappings')) - - #.Nil - #.None))) - -(def: (reference? name scope) - (-> Text Scope Bit) - (or (local? name scope) - (captured? name scope))) - -(def: (reference name scope) - (-> Text Scope (Maybe [Type Variable])) - (case (..local name scope) - (#.Some type) - (#.Some type) - - _ - (..captured name scope))) - -(def: #export (find name) - (-> Text (Operation (Maybe [Type Variable]))) - (///extension.lift - (function (_ state) - (let [[inner outer] (|> state - (get@ #.scopes) - (list.split_with (|>> (reference? name) not)))] - (case outer - #.Nil - (#.Right [state #.None]) - - (#.Cons top_outer _) - (let [[ref_type init_ref] (maybe.default (undefined) - (..reference name top_outer)) - [ref inner'] (list\fold (: (-> Scope [Variable (List Scope)] [Variable (List Scope)]) - (function (_ scope ref+inner) - [(#variable.Foreign (get@ [#.captured #.counter] scope)) - (#.Cons (update@ #.captured - (: (-> Foreign Foreign) - (|>> (update@ #.counter inc) - (update@ #.mappings (plist.put name [ref_type (product.left ref+inner)])))) - scope) - (product.right ref+inner))])) - [init_ref #.Nil] - (list.reverse inner)) - scopes (list\compose inner' outer)] - (#.Right [(set@ #.scopes scopes state) - (#.Some [ref_type ref])])) - ))))) - -(exception: #export cannot_create_local_binding_without_a_scope) -(exception: #export invalid_scope_alteration) - -(def: #export (with_local [name type] action) - (All [a] (-> [Text Type] (Operation a) (Operation a))) - (function (_ [bundle state]) - (case (get@ #.scopes state) - (#.Cons head tail) - (let [old_mappings (get@ [#.locals #.mappings] head) - new_var_id (get@ [#.locals #.counter] head) - new_head (update@ #.locals - (: (-> Local Local) - (|>> (update@ #.counter inc) - (update@ #.mappings (plist.put name [type new_var_id])))) - head)] - (case (///.run' [bundle (set@ #.scopes (#.Cons new_head tail) state)] - action) - (#try.Success [[bundle' state'] output]) - (case (get@ #.scopes state') - (#.Cons head' tail') - (let [scopes' (#.Cons (set@ #.locals (get@ #.locals head) head') - tail')] - (#try.Success [[bundle' (set@ #.scopes scopes' state')] - output])) - - _ - (exception.throw ..invalid_scope_alteration [])) - - (#try.Failure error) - (#try.Failure error))) - - _ - (exception.throw ..cannot_create_local_binding_without_a_scope [])) - )) - -(template [<name> <val_type>] - [(def: <name> - (Bindings Text [Type <val_type>]) - {#.counter 0 - #.mappings (list)})] - - [init_locals Nat] - [init_captured Variable] - ) - -(def: (scope parent_name child_name) - (-> (List Text) Text Scope) - {#.name (list& child_name parent_name) - #.inner 0 - #.locals init_locals - #.captured init_captured}) - -(def: #export (with_scope name action) - (All [a] (-> Text (Operation a) (Operation a))) - (function (_ [bundle state]) - (let [parent_name (case (get@ #.scopes state) - #.Nil - (list) - - (#.Cons top _) - (get@ #.name top))] - (case (action [bundle (update@ #.scopes - (|>> (#.Cons (scope parent_name name))) - state)]) - (#try.Success [[bundle' state'] output]) - (#try.Success [[bundle' (update@ #.scopes - (|>> list.tail (maybe.default (list))) - state')] - output]) - - (#try.Failure error) - (#try.Failure error))) - )) - -(exception: #export cannot_get_next_reference_when_there_is_no_scope) - -(def: #export next_local - (Operation Register) - (///extension.lift - (function (_ state) - (case (get@ #.scopes state) - (#.Cons top _) - (#try.Success [state (get@ [#.locals #.counter] top)]) - - #.Nil - (exception.throw ..cannot_get_next_reference_when_there_is_no_scope []))))) - -(def: (ref_to_variable ref) - (-> Ref Variable) - (case ref - (#.Local register) - (#variable.Local register) - - (#.Captured register) - (#variable.Foreign register))) - -(def: #export (environment scope) - (-> Scope (List Variable)) - (|> scope - (get@ [#.captured #.mappings]) - (list\map (function (_ [_ [_ ref]]) (ref_to_variable ref))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/structure.lux deleted file mode 100644 index dadc61c2d..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/structure.lux +++ /dev/null @@ -1,360 +0,0 @@ -(.module: - [lux #* - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["ex" exception (#+ exception:)] - ["." state]] - [data - ["." name] - ["." product] - ["." maybe] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)] - ["." dictionary (#+ Dictionary)]]] - [macro - ["." code]] - [math - [number - ["n" nat]]] - ["." type - ["." check]]] - ["." // #_ - ["#." type] - ["#." primitive] - ["#." inference] - ["/#" // #_ - ["#." extension] - [// - ["/" analysis (#+ Tag Analysis Operation Phase)] - [/// - ["#" phase] - [meta - [archive (#+ Archive)]]]]]]) - -(exception: #export (invalid_variant_type {type Type} {tag Tag} {code Code}) - (ex.report ["Type" (%.type type)] - ["Tag" (%.nat tag)] - ["Expression" (%.code code)])) - -(template [<name>] - [(exception: #export (<name> {type Type} {members (List Code)}) - (ex.report ["Type" (%.type type)] - ["Expression" (%.code (` [(~+ members)]))]))] - - [invalid_tuple_type] - [cannot_analyse_tuple] - ) - -(exception: #export (not_a_quantified_type {type Type}) - (%.type type)) - -(template [<name>] - [(exception: #export (<name> {type Type} {tag Tag} {code Code}) - (ex.report ["Type" (%.type type)] - ["Tag" (%.nat tag)] - ["Expression" (%.code code)]))] - - [cannot_analyse_variant] - [cannot_infer_numeric_tag] - ) - -(exception: #export (record_keys_must_be_tags {key Code} {record (List [Code Code])}) - (ex.report ["Key" (%.code key)] - ["Record" (%.code (code.record record))])) - -(template [<name>] - [(exception: #export (<name> {key Name} {record (List [Name Code])}) - (ex.report ["Tag" (%.code (code.tag key))] - ["Record" (%.code (code.record (list\map (function (_ [keyI valC]) - [(code.tag keyI) valC]) - record)))]))] - - [cannot_repeat_tag] - ) - -(exception: #export (tag_does_not_belong_to_record {key Name} {type Type}) - (ex.report ["Tag" (%.code (code.tag key))] - ["Type" (%.type type)])) - -(exception: #export (record_size_mismatch {expected Nat} {actual Nat} {type Type} {record (List [Name Code])}) - (ex.report ["Expected" (%.nat expected)] - ["Actual" (%.nat actual)] - ["Type" (%.type type)] - ["Expression" (%.code (|> record - (list\map (function (_ [keyI valueC]) - [(code.tag keyI) valueC])) - code.record))])) - -(def: #export (sum analyse lefts right? archive) - (-> Phase Nat Bit Phase) - (let [tag (/.tag lefts right?)] - (function (recur valueC) - (do {! ///.monad} - [expectedT (///extension.lift meta.expected_type) - expectedT' (//type.with_env - (check.clean expectedT))] - (/.with_stack ..cannot_analyse_variant [expectedT' tag valueC] - (case expectedT - (#.Sum _) - (let [flat (type.flatten_variant expectedT)] - (case (list.nth tag flat) - (#.Some variant_type) - (do ! - [valueA (//type.with_type variant_type - (analyse archive valueC))] - (wrap (/.variant [lefts right? valueA]))) - - #.None - (/.throw //inference.variant_tag_out_of_bounds [(list.size flat) tag expectedT]))) - - (#.Named name unnamedT) - (//type.with_type unnamedT - (recur valueC)) - - (#.Var id) - (do ! - [?expectedT' (//type.with_env - (check.read id))] - (case ?expectedT' - (#.Some expectedT') - (//type.with_type expectedT' - (recur valueC)) - - ## Cannot do inference when the tag is numeric. - ## This is because there is no way of knowing how many - ## cases the inferred sum type would have. - _ - (/.throw ..cannot_infer_numeric_tag [expectedT tag valueC]))) - - (^template [<tag> <instancer>] - [(<tag> _) - (do ! - [[instance_id instanceT] (//type.with_env <instancer>)] - (//type.with_type (maybe.assume (type.apply (list instanceT) expectedT)) - (recur valueC)))]) - ([#.UnivQ check.existential] - [#.ExQ check.var]) - - (#.Apply inputT funT) - (case funT - (#.Var funT_id) - (do ! - [?funT' (//type.with_env (check.read funT_id))] - (case ?funT' - (#.Some funT') - (//type.with_type (#.Apply inputT funT') - (recur valueC)) - - _ - (/.throw ..invalid_variant_type [expectedT tag valueC]))) - - _ - (case (type.apply (list inputT) funT) - (#.Some outputT) - (//type.with_type outputT - (recur valueC)) - - #.None - (/.throw ..not_a_quantified_type funT))) - - _ - (/.throw ..invalid_variant_type [expectedT tag valueC]))))))) - -(def: (typed_product archive analyse members) - (-> Archive Phase (List Code) (Operation Analysis)) - (do {! ///.monad} - [expectedT (///extension.lift meta.expected_type) - membersA+ (: (Operation (List Analysis)) - (loop [membersT+ (type.flatten_tuple expectedT) - membersC+ members] - (case [membersT+ membersC+] - [(#.Cons memberT #.Nil) _] - (//type.with_type memberT - (\ ! map (|>> list) (analyse archive (code.tuple membersC+)))) - - [_ (#.Cons memberC #.Nil)] - (//type.with_type (type.tuple membersT+) - (\ ! map (|>> list) (analyse archive memberC))) - - [(#.Cons memberT membersT+') (#.Cons memberC membersC+')] - (do ! - [memberA (//type.with_type memberT - (analyse archive memberC)) - memberA+ (recur membersT+' membersC+')] - (wrap (#.Cons memberA memberA+))) - - _ - (/.throw ..cannot_analyse_tuple [expectedT members]))))] - (wrap (/.tuple membersA+)))) - -(def: #export (product archive analyse membersC) - (-> Archive Phase (List Code) (Operation Analysis)) - (do {! ///.monad} - [expectedT (///extension.lift meta.expected_type)] - (/.with_stack ..cannot_analyse_tuple [expectedT membersC] - (case expectedT - (#.Product _) - (..typed_product archive analyse membersC) - - (#.Named name unnamedT) - (//type.with_type unnamedT - (product archive analyse membersC)) - - (#.Var id) - (do ! - [?expectedT' (//type.with_env - (check.read id))] - (case ?expectedT' - (#.Some expectedT') - (//type.with_type expectedT' - (product archive analyse membersC)) - - _ - ## Must do inference... - (do ! - [membersTA (monad.map ! (|>> (analyse archive) //type.with_inference) - membersC) - _ (//type.with_env - (check.check expectedT - (type.tuple (list\map product.left membersTA))))] - (wrap (/.tuple (list\map product.right membersTA)))))) - - (^template [<tag> <instancer>] - [(<tag> _) - (do ! - [[instance_id instanceT] (//type.with_env <instancer>)] - (//type.with_type (maybe.assume (type.apply (list instanceT) expectedT)) - (product archive analyse membersC)))]) - ([#.UnivQ check.existential] - [#.ExQ check.var]) - - (#.Apply inputT funT) - (case funT - (#.Var funT_id) - (do ! - [?funT' (//type.with_env (check.read funT_id))] - (case ?funT' - (#.Some funT') - (//type.with_type (#.Apply inputT funT') - (product archive analyse membersC)) - - _ - (/.throw ..invalid_tuple_type [expectedT membersC]))) - - _ - (case (type.apply (list inputT) funT) - (#.Some outputT) - (//type.with_type outputT - (product archive analyse membersC)) - - #.None - (/.throw ..not_a_quantified_type funT))) - - _ - (/.throw ..invalid_tuple_type [expectedT membersC]) - )))) - -(def: #export (tagged_sum analyse tag archive valueC) - (-> Phase Name Phase) - (do {! ///.monad} - [tag (///extension.lift (meta.normalize tag)) - [idx group variantT] (///extension.lift (meta.resolve_tag tag)) - #let [case_size (list.size group) - [lefts right?] (/.choice case_size idx)] - expectedT (///extension.lift meta.expected_type)] - (case expectedT - (#.Var _) - (do ! - [inferenceT (//inference.variant idx case_size variantT) - [inferredT valueA+] (//inference.general archive analyse inferenceT (list valueC))] - (wrap (/.variant [lefts right? (|> valueA+ list.head maybe.assume)]))) - - _ - (..sum analyse lefts right? archive valueC)))) - -## There cannot be any ambiguity or improper syntax when analysing -## records, so they must be normalized for further analysis. -## Normalization just means that all the tags get resolved to their -## canonical form (with their corresponding module identified). -(def: #export (normalize record) - (-> (List [Code Code]) (Operation (List [Name Code]))) - (monad.map ///.monad - (function (_ [key val]) - (case key - [_ (#.Tag key)] - (do ///.monad - [key (///extension.lift (meta.normalize key))] - (wrap [key val])) - - _ - (/.throw ..record_keys_must_be_tags [key record]))) - record)) - -## Lux already possesses the means to analyse tuples, so -## re-implementing the same functionality for records makes no sense. -## Records, thus, get transformed into tuples by ordering the elements. -(def: #export (order record) - (-> (List [Name Code]) (Operation [(List Code) Type])) - (case record - ## empty_record = empty_tuple = unit = [] - #.Nil - (\ ///.monad wrap [(list) Any]) - - (#.Cons [head_k head_v] _) - (do {! ///.monad} - [head_k (///extension.lift (meta.normalize head_k)) - [_ tag_set recordT] (///extension.lift (meta.resolve_tag head_k)) - #let [size_record (list.size record) - size_ts (list.size tag_set)] - _ (if (n.= size_ts size_record) - (wrap []) - (/.throw ..record_size_mismatch [size_ts size_record recordT record])) - #let [tuple_range (list.indices size_ts) - tag->idx (dictionary.from_list name.hash (list.zip/2 tag_set tuple_range))] - idx->val (monad.fold ! - (function (_ [key val] idx->val) - (do ! - [key (///extension.lift (meta.normalize key))] - (case (dictionary.get key tag->idx) - (#.Some idx) - (if (dictionary.key? idx->val idx) - (/.throw ..cannot_repeat_tag [key record]) - (wrap (dictionary.put idx val idx->val))) - - #.None - (/.throw ..tag_does_not_belong_to_record [key recordT])))) - (: (Dictionary Nat Code) - (dictionary.new n.hash)) - record) - #let [ordered_tuple (list\map (function (_ idx) (maybe.assume (dictionary.get idx idx->val))) - tuple_range)]] - (wrap [ordered_tuple recordT])) - )) - -(def: #export (record archive analyse members) - (-> Archive Phase (List [Code Code]) (Operation Analysis)) - (case members - (^ (list)) - //primitive.unit - - (^ (list [_ singletonC])) - (analyse archive singletonC) - - _ - (do {! ///.monad} - [members (normalize members) - [membersC recordT] (order members) - expectedT (///extension.lift meta.expected_type)] - (case expectedT - (#.Var _) - (do ! - [inferenceT (//inference.record recordT) - [inferredT membersA] (//inference.general archive analyse inferenceT membersC)] - (wrap (/.tuple membersA))) - - _ - (..product archive analyse membersC))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/type.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/type.lux deleted file mode 100644 index f72ec593b..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/type.lux +++ /dev/null @@ -1,55 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." function] - ["." try]] - [type - ["." check (#+ Check)]] - ["." meta]] - ["." /// #_ - ["#." extension] - [// - ["/" analysis (#+ Operation)] - [/// - ["#" phase]]]]) - -(def: #export (with_type expected) - (All [a] (-> Type (Operation a) (Operation a))) - (///extension.localized (get@ #.expected) (set@ #.expected) - (function.constant (#.Some expected)))) - -(def: #export (with_env action) - (All [a] (-> (Check a) (Operation a))) - (function (_ (^@ stateE [bundle state])) - (case (action (get@ #.type_context state)) - (#try.Success [context' output]) - (#try.Success [[bundle (set@ #.type_context context' state)] - output]) - - (#try.Failure error) - ((/.fail error) stateE)))) - -(def: #export with_fresh_env - (All [a] (-> (Operation a) (Operation a))) - (///extension.localized (get@ #.type_context) (set@ #.type_context) - (function.constant check.fresh_context))) - -(def: #export (infer actualT) - (-> Type (Operation Any)) - (do ///.monad - [expectedT (///extension.lift meta.expected_type)] - (with_env - (check.check expectedT actualT)))) - -(def: #export (with_inference action) - (All [a] (-> (Operation a) (Operation [Type a]))) - (do ///.monad - [[_ varT] (..with_env - check.var) - output (with_type varT - action) - knownT (..with_env - (check.clean varT))] - (wrap [knownT output]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/directive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/directive.lux deleted file mode 100644 index 088bed17a..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/directive.lux +++ /dev/null @@ -1,78 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." exception (#+ exception:)]] - [data - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." fold monoid)]]] - ["." meta]] - ["." // #_ - ["#." extension] - ["#." analysis - ["#/." type]] - ["/#" // #_ - ["/" directive (#+ Phase)] - ["#." analysis - ["#/." macro (#+ Expander)]] - [/// - ["//" phase] - [reference (#+) - [variable (#+)]]]]]) - -(exception: #export (not_a_directive {code Code}) - (exception.report - ["Directive" (%.code code)])) - -(exception: #export (invalid_macro_call {code Code}) - (exception.report - ["Code" (%.code code)])) - -(exception: #export (macro_was_not_found {name Name}) - (exception.report - ["Name" (%.name name)])) - -(with_expansions [<lux_def_module> (as_is [|form_location| (#.Form (list& [|text_location| (#.Text "lux def module")] annotations))])] - (def: #export (phase expander) - (-> Expander Phase) - (let [analyze (//analysis.phase expander)] - (function (recur archive code) - (case code - (^ [_ (#.Form (list& [_ (#.Text name)] inputs))]) - (//extension.apply archive recur [name inputs]) - - (^ [_ (#.Form (list& macro inputs))]) - (do {! //.monad} - [expansion (/.lift_analysis - (do ! - [macroA (//analysis/type.with_type Macro - (analyze archive macro))] - (case macroA - (^ (///analysis.constant macro_name)) - (do ! - [?macro (//extension.lift (meta.find_macro macro_name)) - macro (case ?macro - (#.Some macro) - (wrap macro) - - #.None - (//.throw ..macro_was_not_found macro_name))] - (//extension.lift (///analysis/macro.expand expander macro_name macro inputs))) - - _ - (//.throw ..invalid_macro_call code))))] - (case expansion - (^ (list& <lux_def_module> referrals)) - (|> (recur archive <lux_def_module>) - (\ ! map (update@ #/.referrals (list\compose referrals)))) - - _ - (|> expansion - (monad.map ! (recur archive)) - (\ ! map (list\fold /.merge_requirements /.no_requirements))))) - - _ - (//.throw ..not_a_directive code)))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux deleted file mode 100644 index 7004b8d1a..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux +++ /dev/null @@ -1,176 +0,0 @@ -(.module: - [lux (#- Name) - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)] - ["." monad (#+ do)]] - [control - ["." function] - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["." product] - ["." text ("#\." order) - ["%" format (#+ Format format)]] - [collection - ["." list] - ["." dictionary (#+ Dictionary)]]]] - [///// - ["//" phase] - [meta - [archive (#+ Archive)]]]) - -(type: #export Name - Text) - -(type: #export (Extension a) - [Name (List a)]) - -(def: #export equivalence - (All [a] (-> (Equivalence a) (Equivalence (Extension a)))) - (|>> list.equivalence - (product.equivalence text.equivalence))) - -(def: #export hash - (All [a] (-> (Hash a) (Hash (Extension a)))) - (|>> list.hash - (product.hash text.hash))) - -(with_expansions [<Bundle> (as_is (Dictionary Name (Handler s i o)))] - (type: #export (Handler s i o) - (-> Name - (//.Phase [<Bundle> s] i o) - (//.Phase [<Bundle> s] (List i) o))) - - (type: #export (Bundle s i o) - <Bundle>)) - -(def: #export empty - Bundle - (dictionary.new text.hash)) - -(type: #export (State s i o) - {#bundle (Bundle s i o) - #state s}) - -(type: #export (Operation s i o v) - (//.Operation (State s i o) v)) - -(type: #export (Phase s i o) - (//.Phase (State s i o) i o)) - -(exception: #export (cannot_overwrite {name Name}) - (exception.report - ["Extension" (%.text name)])) - -(exception: #export (incorrect_arity {name Name} {arity Nat} {args Nat}) - (exception.report - ["Extension" (%.text name)] - ["Expected" (%.nat arity)] - ["Actual" (%.nat args)])) - -(exception: #export [a] (invalid_syntax {name Name} {%format (Format a)} {inputs (List a)}) - (exception.report - ["Extension" (%.text name)] - ["Inputs" (exception.enumerate %format inputs)])) - -(exception: #export [s i o] (unknown {name Name} {bundle (Bundle s i o)}) - (exception.report - ["Extension" (%.text name)] - ["Available" (|> bundle - dictionary.keys - (list.sort text\<) - (exception.enumerate %.text))])) - -(type: #export (Extender s i o) - (-> Any (Handler s i o))) - -(def: #export (install extender name handler) - (All [s i o] - (-> (Extender s i o) Text (Handler s i o) (Operation s i o Any))) - (function (_ [bundle state]) - (case (dictionary.get name bundle) - #.None - (#try.Success [[(dictionary.put name (extender handler) bundle) state] - []]) - - _ - (exception.throw ..cannot_overwrite name)))) - -(def: #export (with extender extensions) - (All [s i o] - (-> Extender (Bundle s i o) (Operation s i o Any))) - (|> extensions - dictionary.entries - (monad.fold //.monad - (function (_ [extension handle] output) - (..install extender extension handle)) - []))) - -(def: #export (apply archive phase [name parameters]) - (All [s i o] - (-> Archive (Phase s i o) (Extension i) (Operation s i o o))) - (function (_ (^@ stateE [bundle state])) - (case (dictionary.get name bundle) - (#.Some handler) - (((handler name phase) archive parameters) - stateE) - - #.None - (exception.throw ..unknown [name bundle])))) - -(def: #export (localized get set transform) - (All [s s' i o v] - (-> (-> s s') (-> s' s s) (-> s' s') - (-> (Operation s i o v) (Operation s i o v)))) - (function (_ operation) - (function (_ [bundle state]) - (let [old (get state)] - (case (operation [bundle (set (transform old) state)]) - (#try.Success [[bundle' state'] output]) - (#try.Success [[bundle' (set old state')] output]) - - (#try.Failure error) - (#try.Failure error)))))) - -(def: #export (temporary transform) - (All [s i o v] - (-> (-> s s) - (-> (Operation s i o v) (Operation s i o v)))) - (function (_ operation) - (function (_ [bundle state]) - (case (operation [bundle (transform state)]) - (#try.Success [[bundle' state'] output]) - (#try.Success [[bundle' state] output]) - - (#try.Failure error) - (#try.Failure error))))) - -(def: #export (with_state state) - (All [s i o v] - (-> s (-> (Operation s i o v) (Operation s i o v)))) - (..temporary (function.constant state))) - -(def: #export (read get) - (All [s i o v] - (-> (-> s v) (Operation s i o v))) - (function (_ [bundle state]) - (#try.Success [[bundle state] (get state)]))) - -(def: #export (update transform) - (All [s i o] - (-> (-> s s) (Operation s i o Any))) - (function (_ [bundle state]) - (#try.Success [[bundle (transform state)] []]))) - -(def: #export (lift action) - (All [s i o v] - (-> (//.Operation s v) - (//.Operation [(Bundle s i o) s] v))) - (function (_ [bundle state]) - (case (action state) - (#try.Success [state' output]) - (#try.Success [[bundle state'] output]) - - (#try.Failure error) - (#try.Failure error)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis.lux deleted file mode 100644 index 0f38bce97..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis.lux +++ /dev/null @@ -1,15 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - [//// - [analysis (#+ Bundle) - [evaluation (#+ Eval)]]] - ["." / #_ - ["#." lux]]) - -(def: #export (bundle eval host-specific) - (-> Eval Bundle Bundle) - (dictionary.merge host-specific - (/lux.bundle eval))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux deleted file mode 100644 index 887d639f1..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux +++ /dev/null @@ -1,34 +0,0 @@ -(.module: - [lux #* - ["." ffi] - [abstract - ["." monad (#+ do)]] - [control - ["<>" parser - ["<c>" code (#+ Parser)]]] - [data - [collection - ["." array (#+ Array)] - ["." dictionary] - ["." list]]] - ["." type - ["." check]] - ["@" target - ["_" common_lisp]]] - [// - ["/" lux (#+ custom)] - [// - ["." bundle] - [// - ["." analysis #_ - ["#/." type]] - [// - ["." analysis (#+ Analysis Operation Phase Handler Bundle)] - [/// - ["." phase]]]]]]) - -(def: #export bundle - Bundle - (<| (bundle.prefix "common_lisp") - (|> bundle.empty - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux deleted file mode 100644 index d36dcd1ef..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux +++ /dev/null @@ -1,217 +0,0 @@ -(.module: - [lux #* - ["." ffi] - [abstract - ["." monad (#+ do)]] - [control - ["<>" parser - ["<c>" code (#+ Parser)]]] - [data - [collection - ["." array (#+ Array)] - ["." dictionary] - ["." list]]] - ["." type - ["." check]] - ["@" target - ["_" js]]] - [// - ["/" lux (#+ custom)] - [// - ["." bundle] - [// - ["." analysis #_ - ["#/." type]] - [// - ["." analysis (#+ Analysis Operation Phase Handler Bundle)] - [/// - ["." phase]]]]]]) - -(def: array::new - Handler - (custom - [<c>.any - (function (_ extension phase archive lengthC) - (do phase.monad - [lengthA (analysis/type.with_type Nat - (phase archive lengthC)) - [var_id varT] (analysis/type.with_env check.var) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list lengthA)))))])) - -(def: array::length - Handler - (custom - [<c>.any - (function (_ extension phase archive arrayC) - (do phase.monad - [[var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer Nat)] - (wrap (#analysis.Extension extension (list arrayA)))))])) - -(def: array::read - Handler - (custom - [(<>.and <c>.any <c>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer varT)] - (wrap (#analysis.Extension extension (list indexA arrayA)))))])) - -(def: array::write - Handler - (custom - [($_ <>.and <c>.any <c>.any <c>.any) - (function (_ extension phase archive [indexC valueC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - valueA (analysis/type.with_type varT - (phase archive valueC)) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))])) - -(def: array::delete - Handler - (custom - [($_ <>.and <c>.any <c>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list indexA arrayA)))))])) - -(def: bundle::array - Bundle - (<| (bundle.prefix "array") - (|> bundle.empty - (bundle.install "new" array::new) - (bundle.install "length" array::length) - (bundle.install "read" array::read) - (bundle.install "write" array::write) - (bundle.install "delete" array::delete) - ))) - -(def: object::new - Handler - (custom - [($_ <>.and <c>.any (<c>.tuple (<>.some <c>.any))) - (function (_ extension phase archive [constructorC inputsC]) - (do {! phase.monad} - [constructorA (analysis/type.with_type Any - (phase archive constructorC)) - inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list& constructorA inputsA)))))])) - -(def: object::get - Handler - (custom - [($_ <>.and <c>.text <c>.any) - (function (_ extension phase archive [fieldC objectC]) - (do phase.monad - [objectA (analysis/type.with_type Any - (phase archive objectC)) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list (analysis.text fieldC) - objectA)))))])) - -(def: object::do - Handler - (custom - [($_ <>.and <c>.text <c>.any (<c>.tuple (<>.some <c>.any))) - (function (_ extension phase archive [methodC objectC inputsC]) - (do {! phase.monad} - [objectA (analysis/type.with_type Any - (phase archive objectC)) - inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list& (analysis.text methodC) - objectA - inputsA)))))])) - -(def: bundle::object - Bundle - (<| (bundle.prefix "object") - (|> bundle.empty - (bundle.install "new" object::new) - (bundle.install "get" object::get) - (bundle.install "do" object::do) - (bundle.install "null" (/.nullary Any)) - (bundle.install "null?" (/.unary Any Bit)) - (bundle.install "undefined" (/.nullary Any)) - (bundle.install "undefined?" (/.unary Any Bit)) - ))) - -(def: js::constant - Handler - (custom - [<c>.text - (function (_ extension phase archive name) - (do phase.monad - [_ (analysis/type.infer Any)] - (wrap (#analysis.Extension extension (list (analysis.text name))))))])) - -(def: js::apply - Handler - (custom - [($_ <>.and <c>.any (<>.some <c>.any)) - (function (_ extension phase archive [abstractionC inputsC]) - (do {! phase.monad} - [abstractionA (analysis/type.with_type Any - (phase archive abstractionC)) - inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer Any)] - (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))])) - -(def: js::type_of - Handler - (custom - [<c>.any - (function (_ extension phase archive objectC) - (do phase.monad - [objectA (analysis/type.with_type Any - (phase archive objectC)) - _ (analysis/type.infer .Text)] - (wrap (#analysis.Extension extension (list objectA)))))])) - -(def: js::function - Handler - (custom - [($_ <>.and <c>.nat <c>.any) - (function (_ extension phase archive [arity abstractionC]) - (do phase.monad - [#let [inputT (type.tuple (list.repeat arity Any))] - abstractionA (analysis/type.with_type (-> inputT Any) - (phase archive abstractionC)) - _ (analysis/type.infer (for {@.js ffi.Function} - Any))] - (wrap (#analysis.Extension extension (list (analysis.nat arity) - abstractionA)))))])) - -(def: #export bundle - Bundle - (<| (bundle.prefix "js") - (|> bundle.empty - (dictionary.merge bundle::array) - (dictionary.merge bundle::object) - - (bundle.install "constant" js::constant) - (bundle.install "apply" js::apply) - (bundle.install "type-of" js::type_of) - (bundle.install "function" js::function) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux deleted file mode 100644 index 0d67b2224..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux +++ /dev/null @@ -1,2075 +0,0 @@ -(.module: - [lux (#- Type Module primitive type char int) - ["." ffi (#+ import:)] - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - pipe - ["." try (#+ Try) ("#\." monad)] - ["." exception (#+ exception:)] - ["<>" parser - ["<.>" code (#+ Parser)] - ["<.>" text]]] - [data - ["." maybe] - ["." product] - ["." text ("#\." equivalence) - ["%" format (#+ format)]] - [collection - ["." list ("#\." fold monad monoid)] - ["." array] - ["." dictionary (#+ Dictionary)]]] - [math - [number - ["n" nat]]] - [target - ["." jvm #_ - [".!" reflection] - [encoding - [name (#+ External)]] - ["#" type (#+ Type Argument Typed) ("#\." equivalence) - ["." category (#+ Void Value' Value Return' Return Primitive Object Class Array Var Parameter Method)] - ["." box] - ["." reflection] - ["." descriptor] - ["." signature] - ["#_." parser] - ["#_." alias (#+ Aliasing)] - [".T" lux (#+ Mapping)]]]] - ["." type - ["." check (#+ Check) ("#\." monad)]]] - ["." // #_ - ["#." lux (#+ custom)] - ["/#" // - ["#." bundle] - ["/#" // #_ - [analysis - [".A" type] - [".A" inference] - ["." scope]] - ["/#" // #_ - ["#." analysis (#+ Analysis Operation Phase Handler Bundle)] - ["#." synthesis] - [/// - ["." phase ("#\." monad)] - [meta - [archive (#+ Archive) - [descriptor (#+ Module)]]]]]]]]) - -(import: java/lang/Object - ["#::." - (equals [java/lang/Object] boolean)]) - -(import: java/lang/reflect/Type) - -(import: (java/lang/reflect/TypeVariable d) - ["#::." - (getName [] java/lang/String) - (getBounds [] [java/lang/reflect/Type])]) - -(import: java/lang/reflect/Modifier - ["#::." - (#static isStatic [int] boolean) - (#static isFinal [int] boolean) - (#static isInterface [int] boolean) - (#static isAbstract [int] boolean)]) - -(import: java/lang/annotation/Annotation) - -(import: java/lang/reflect/Method - ["#::." - (getName [] java/lang/String) - (getModifiers [] int) - (getDeclaringClass [] (java/lang/Class java/lang/Object)) - (getTypeParameters [] [(java/lang/reflect/TypeVariable java/lang/reflect/Method)]) - (getGenericParameterTypes [] [java/lang/reflect/Type]) - (getGenericReturnType [] java/lang/reflect/Type) - (getGenericExceptionTypes [] [java/lang/reflect/Type]) - (getDeclaredAnnotations [] [java/lang/annotation/Annotation])]) - -(import: (java/lang/reflect/Constructor c) - ["#::." - (getModifiers [] int) - (getDeclaringClass [] (java/lang/Class c)) - (getTypeParameters [] [(java/lang/reflect/TypeVariable (java/lang/reflect/Constructor c))]) - (getGenericParameterTypes [] [java/lang/reflect/Type]) - (getGenericExceptionTypes [] [java/lang/reflect/Type]) - (getDeclaredAnnotations [] [java/lang/annotation/Annotation])]) - -(import: (java/lang/Class c) - ["#::." - (#static forName [java/lang/String] #try (java/lang/Class java/lang/Object)) - (getName [] java/lang/String) - (getModifiers [] int) - (isAssignableFrom [(java/lang/Class java/lang/Object)] boolean) - (getTypeParameters [] [(java/lang/reflect/TypeVariable (java/lang/Class c))]) - (getGenericInterfaces [] [java/lang/reflect/Type]) - (getGenericSuperclass [] #? java/lang/reflect/Type) - (getDeclaredField [java/lang/String] #try java/lang/reflect/Field) - (getConstructors [] [(java/lang/reflect/Constructor java/lang/Object)]) - (getDeclaredMethods [] [java/lang/reflect/Method]) - (getDeclaredAnnotations [] [java/lang/annotation/Annotation])]) - -(template [<name>] - [(exception: #export (<name> {class External} {field Text}) - (exception.report - ["Class" (%.text class)] - ["Field" (%.text field)]))] - - [cannot_set_a_final_field] - [deprecated_field] - ) - -(exception: #export (deprecated_method {class External} {method Text} {type .Type}) - (exception.report - ["Class" (%.text class)] - ["Method" (%.text method)] - ["Type" (%.type type)])) - -(exception: #export (deprecated_class {class External}) - (exception.report - ["Class" (%.text class)])) - -(def: (ensure_fresh_class! name) - (-> External (Operation Any)) - (do phase.monad - [class (phase.lift (reflection!.load name))] - (phase.assert ..deprecated_class [name] - (|> class - java/lang/Class::getDeclaredAnnotations - reflection!.deprecated? - not)))) - -(def: reflection - (All [category] - (-> (Type (<| Return' Value' category)) Text)) - (|>> jvm.reflection reflection.reflection)) - -(def: signature (|>> jvm.signature signature.signature)) - -(def: object_class - External - "java.lang.Object") - -(def: inheritance_relationship_type_name "_jvm_inheritance") -(def: #export (inheritance_relationship_type class super_class super_interfaces) - (-> .Type .Type (List .Type) .Type) - (#.Primitive ..inheritance_relationship_type_name - (list& class super_class super_interfaces))) - -## TODO: Get rid of this template block and use the definition in -## lux/ffi.jvm.lux ASAP -(template [<name> <class>] - [(def: #export <name> .Type (#.Primitive <class> #.Nil))] - - ## Boxes - [Boolean box.boolean] - [Byte box.byte] - [Short box.short] - [Integer box.int] - [Long box.long] - [Float box.float] - [Double box.double] - [Character box.char] - [String "java.lang.String"] - - ## Primitives - [boolean (reflection.reflection reflection.boolean)] - [byte (reflection.reflection reflection.byte)] - [short (reflection.reflection reflection.short)] - [int (reflection.reflection reflection.int)] - [long (reflection.reflection reflection.long)] - [float (reflection.reflection reflection.float)] - [double (reflection.reflection reflection.double)] - [char (reflection.reflection reflection.char)] - ) - -(type: Member - {#class External - #member Text}) - -(def: member - (Parser Member) - ($_ <>.and <code>.text <code>.text)) - -(type: Method_Signature - {#method .Type - #deprecated? Bit - #exceptions (List .Type)}) - -(template [<name>] - [(exception: #export (<name> {type .Type}) - (exception.report - ["Type" (%.type type)]))] - - [non_object] - [non_array] - [non_parameter] - [non_jvm_type] - ) - -(template [<name>] - [(exception: #export (<name> {class External}) - (exception.report - ["Class/type" (%.text class)]))] - - [non_interface] - [non_throwable] - [primitives_are_not_objects] - ) - -(template [<name>] - [(exception: #export (<name> {class External} - {method Text} - {inputsJT (List (Type Value))} - {hints (List Method_Signature)}) - (exception.report - ["Class" class] - ["Method" method] - ["Arguments" (exception.enumerate ..signature inputsJT)] - ["Hints" (exception.enumerate %.type (list\map product.left hints))]))] - - [no_candidates] - [too_many_candidates] - ) - -(exception: #export (cannot_cast {from .Type} {to .Type} {value Code}) - (exception.report - ["From" (%.type from)] - ["To" (%.type to)] - ["Value" (%.code value)])) - -(template [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [primitives_cannot_have_type_parameters] - - [cannot_possibly_be_an_instance] - - [unknown_type_var] - ) - -(def: bundle::conversion - Bundle - (<| (///bundle.prefix "conversion") - (|> ///bundle.empty - (///bundle.install "double-to-float" (//lux.unary ..double ..float)) - (///bundle.install "double-to-int" (//lux.unary ..double ..int)) - (///bundle.install "double-to-long" (//lux.unary ..double ..long)) - (///bundle.install "float-to-double" (//lux.unary ..float ..double)) - (///bundle.install "float-to-int" (//lux.unary ..float ..int)) - (///bundle.install "float-to-long" (//lux.unary ..float ..long)) - (///bundle.install "int-to-byte" (//lux.unary ..int ..byte)) - (///bundle.install "int-to-char" (//lux.unary ..int ..char)) - (///bundle.install "int-to-double" (//lux.unary ..int ..double)) - (///bundle.install "int-to-float" (//lux.unary ..int ..float)) - (///bundle.install "int-to-long" (//lux.unary ..int ..long)) - (///bundle.install "int-to-short" (//lux.unary ..int ..short)) - (///bundle.install "long-to-double" (//lux.unary ..long ..double)) - (///bundle.install "long-to-float" (//lux.unary ..long ..float)) - (///bundle.install "long-to-int" (//lux.unary ..long ..int)) - (///bundle.install "long-to-short" (//lux.unary ..long ..short)) - (///bundle.install "long-to-byte" (//lux.unary ..long ..byte)) - (///bundle.install "char-to-byte" (//lux.unary ..char ..byte)) - (///bundle.install "char-to-short" (//lux.unary ..char ..short)) - (///bundle.install "char-to-int" (//lux.unary ..char ..int)) - (///bundle.install "char-to-long" (//lux.unary ..char ..long)) - (///bundle.install "byte-to-long" (//lux.unary ..byte ..long)) - (///bundle.install "short-to-long" (//lux.unary ..short ..long)) - ))) - -(template [<name> <prefix> <type>] - [(def: <name> - Bundle - (<| (///bundle.prefix (reflection.reflection <prefix>)) - (|> ///bundle.empty - (///bundle.install "+" (//lux.binary <type> <type> <type>)) - (///bundle.install "-" (//lux.binary <type> <type> <type>)) - (///bundle.install "*" (//lux.binary <type> <type> <type>)) - (///bundle.install "/" (//lux.binary <type> <type> <type>)) - (///bundle.install "%" (//lux.binary <type> <type> <type>)) - (///bundle.install "=" (//lux.binary <type> <type> Bit)) - (///bundle.install "<" (//lux.binary <type> <type> Bit)) - (///bundle.install "and" (//lux.binary <type> <type> <type>)) - (///bundle.install "or" (//lux.binary <type> <type> <type>)) - (///bundle.install "xor" (//lux.binary <type> <type> <type>)) - (///bundle.install "shl" (//lux.binary ..int <type> <type>)) - (///bundle.install "shr" (//lux.binary ..int <type> <type>)) - (///bundle.install "ushr" (//lux.binary ..int <type> <type>)) - )))] - - [bundle::int reflection.int ..int] - [bundle::long reflection.long ..long] - ) - -(template [<name> <prefix> <type>] - [(def: <name> - Bundle - (<| (///bundle.prefix (reflection.reflection <prefix>)) - (|> ///bundle.empty - (///bundle.install "+" (//lux.binary <type> <type> <type>)) - (///bundle.install "-" (//lux.binary <type> <type> <type>)) - (///bundle.install "*" (//lux.binary <type> <type> <type>)) - (///bundle.install "/" (//lux.binary <type> <type> <type>)) - (///bundle.install "%" (//lux.binary <type> <type> <type>)) - (///bundle.install "=" (//lux.binary <type> <type> Bit)) - (///bundle.install "<" (//lux.binary <type> <type> Bit)) - )))] - - [bundle::float reflection.float ..float] - [bundle::double reflection.double ..double] - ) - -(def: bundle::char - Bundle - (<| (///bundle.prefix (reflection.reflection reflection.char)) - (|> ///bundle.empty - (///bundle.install "=" (//lux.binary ..char ..char Bit)) - (///bundle.install "<" (//lux.binary ..char ..char Bit)) - ))) - -(def: #export boxes - (Dictionary External [External (Type Primitive)]) - (|> (list [(reflection.reflection reflection.boolean) [box.boolean jvm.boolean]] - [(reflection.reflection reflection.byte) [box.byte jvm.byte]] - [(reflection.reflection reflection.short) [box.short jvm.short]] - [(reflection.reflection reflection.int) [box.int jvm.int]] - [(reflection.reflection reflection.long) [box.long jvm.long]] - [(reflection.reflection reflection.float) [box.float jvm.float]] - [(reflection.reflection reflection.double) [box.double jvm.double]] - [(reflection.reflection reflection.char) [box.char jvm.char]]) - (dictionary.from_list text.hash))) - -(def: (jvm_type luxT) - (-> .Type (Operation (Type Value))) - (case luxT - (#.Named name anonymousT) - (jvm_type anonymousT) - - (#.Apply inputT abstractionT) - (case (type.apply (list inputT) abstractionT) - (#.Some outputT) - (jvm_type outputT) - - #.None - (/////analysis.throw ..non_jvm_type luxT)) - - (^ (#.Primitive (static array.type_name) (list elemT))) - (phase\map jvm.array (jvm_type elemT)) - - (#.Primitive class parametersT) - (case (dictionary.get class ..boxes) - (#.Some [_ primitive_type]) - (case parametersT - #.Nil - (phase\wrap primitive_type) - - _ - (/////analysis.throw ..primitives_cannot_have_type_parameters class)) - - #.None - (do {! phase.monad} - [parametersJT (: (Operation (List (Type Parameter))) - (monad.map ! - (function (_ parameterT) - (do phase.monad - [parameterJT (jvm_type parameterT)] - (case (jvm_parser.parameter? parameterJT) - (#.Some parameterJT) - (wrap parameterJT) - - #.None - (/////analysis.throw ..non_parameter parameterT)))) - parametersT))] - (wrap (jvm.class class parametersJT)))) - - (#.Ex _) - (phase\wrap (jvm.class ..object_class (list))) - - _ - (/////analysis.throw ..non_jvm_type luxT))) - -(def: (jvm_array_type objectT) - (-> .Type (Operation (Type Array))) - (do phase.monad - [objectJ (jvm_type objectT)] - (|> objectJ - ..signature - (<text>.run jvm_parser.array) - phase.lift))) - -(def: (primitive_array_length_handler primitive_type) - (-> (Type Primitive) Handler) - (function (_ extension_name analyse archive args) - (case args - (^ (list arrayC)) - (do phase.monad - [_ (typeA.infer ..int) - arrayA (typeA.with_type (#.Primitive (|> (jvm.array primitive_type) - ..reflection) - (list)) - (analyse archive arrayC))] - (wrap (#/////analysis.Extension extension_name (list arrayA)))) - - _ - (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)])))) - -(def: array::length::object - Handler - (function (_ extension_name analyse archive args) - (case args - (^ (list arrayC)) - (do phase.monad - [_ (typeA.infer ..int) - [var_id varT] (typeA.with_env check.var) - arrayA (typeA.with_type (.type (array.Array varT)) - (analyse archive arrayC)) - varT (typeA.with_env (check.clean varT)) - arrayJT (jvm_array_type (.type (array.Array varT)))] - (wrap (#/////analysis.Extension extension_name (list (/////analysis.text (..signature arrayJT)) - arrayA)))) - - _ - (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)])))) - -(def: (new_primitive_array_handler primitive_type) - (-> (Type Primitive) Handler) - (function (_ extension_name analyse archive args) - (case args - (^ (list lengthC)) - (do phase.monad - [lengthA (typeA.with_type ..int - (analyse archive lengthC)) - _ (typeA.infer (#.Primitive (|> (jvm.array primitive_type) ..reflection) - (list)))] - (wrap (#/////analysis.Extension extension_name (list lengthA)))) - - _ - (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)])))) - -(def: array::new::object - Handler - (function (_ extension_name analyse archive args) - (case args - (^ (list lengthC)) - (do phase.monad - [lengthA (typeA.with_type ..int - (analyse archive lengthC)) - expectedT (///.lift meta.expected_type) - expectedJT (jvm_array_type expectedT) - elementJT (case (jvm_parser.array? expectedJT) - (#.Some elementJT) - (wrap elementJT) - - #.None - (/////analysis.throw ..non_array expectedT))] - (wrap (#/////analysis.Extension extension_name (list (/////analysis.text (..signature elementJT)) - lengthA)))) - - _ - (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)])))) - -(def: (check_parameter objectT) - (-> .Type (Operation (Type Parameter))) - (case objectT - (^ (#.Primitive (static array.type_name) - (list elementT))) - (/////analysis.throw ..non_parameter objectT) - - (#.Primitive name parameters) - (`` (cond (or (~~ (template [<type>] - [(text\= (..reflection <type>) name)] - - [jvm.boolean] - [jvm.byte] - [jvm.short] - [jvm.int] - [jvm.long] - [jvm.float] - [jvm.double] - [jvm.char])) - (text.starts_with? descriptor.array_prefix name)) - (/////analysis.throw ..non_parameter objectT) - - ## else - (phase\wrap (jvm.class name (list))))) - - (#.Named name anonymous) - (check_parameter anonymous) - - (^template [<tag>] - [(<tag> id) - (phase\wrap (jvm.class ..object_class (list)))]) - ([#.Var] - [#.Ex]) - - (^template [<tag>] - [(<tag> env unquantified) - (check_parameter unquantified)]) - ([#.UnivQ] - [#.ExQ]) - - (#.Apply inputT abstractionT) - (case (type.apply (list inputT) abstractionT) - (#.Some outputT) - (check_parameter outputT) - - #.None - (/////analysis.throw ..non_parameter objectT)) - - _ - (/////analysis.throw ..non_parameter objectT))) - -(def: (check_jvm objectT) - (-> .Type (Operation (Type Value))) - (case objectT - (#.Primitive name #.Nil) - (`` (cond (~~ (template [<type>] - [(text\= (..reflection <type>) name) - (phase\wrap <type>)] - - [jvm.boolean] - [jvm.byte] - [jvm.short] - [jvm.int] - [jvm.long] - [jvm.float] - [jvm.double] - [jvm.char])) - - (~~ (template [<type>] - [(text\= (..reflection (jvm.array <type>)) name) - (phase\wrap (jvm.array <type>))] - - [jvm.boolean] - [jvm.byte] - [jvm.short] - [jvm.int] - [jvm.long] - [jvm.float] - [jvm.double] - [jvm.char])) - - (text.starts_with? descriptor.array_prefix name) - (let [[_ unprefixed] (maybe.assume (text.split_with descriptor.array_prefix name))] - (\ phase.monad map jvm.array - (check_jvm (#.Primitive unprefixed (list))))) - - ## else - (phase\wrap (jvm.class name (list))))) - - (^ (#.Primitive (static array.type_name) - (list elementT))) - (|> elementT - check_jvm - (phase\map jvm.array)) - - (#.Primitive name parameters) - (do {! phase.monad} - [parameters (monad.map ! check_parameter parameters)] - (phase\wrap (jvm.class name parameters))) - - (#.Named name anonymous) - (check_jvm anonymous) - - (^template [<tag>] - [(<tag> env unquantified) - (check_jvm unquantified)]) - ([#.UnivQ] - [#.ExQ]) - - (#.Apply inputT abstractionT) - (case (type.apply (list inputT) abstractionT) - (#.Some outputT) - (check_jvm outputT) - - #.None - (/////analysis.throw ..non_object objectT)) - - _ - (check_parameter objectT))) - -(def: (check_object objectT) - (-> .Type (Operation External)) - (do {! phase.monad} - [name (\ ! map ..reflection (check_jvm objectT))] - (if (dictionary.key? ..boxes name) - (/////analysis.throw ..primitives_are_not_objects [name]) - (phase\wrap name)))) - -(def: (check_return type) - (-> .Type (Operation (Type Return))) - (if (is? .Any type) - (phase\wrap jvm.void) - (check_jvm type))) - -(def: (read_primitive_array_handler lux_type jvm_type) - (-> .Type (Type Primitive) Handler) - (function (_ extension_name analyse archive args) - (case args - (^ (list idxC arrayC)) - (do phase.monad - [_ (typeA.infer lux_type) - idxA (typeA.with_type ..int - (analyse archive idxC)) - arrayA (typeA.with_type (#.Primitive (|> (jvm.array jvm_type) ..reflection) - (list)) - (analyse archive arrayC))] - (wrap (#/////analysis.Extension extension_name (list idxA arrayA)))) - - _ - (/////analysis.throw ///.incorrect_arity [extension_name 2 (list.size args)])))) - -(def: array::read::object - Handler - (function (_ extension_name analyse archive args) - (case args - (^ (list idxC arrayC)) - (do phase.monad - [[var_id varT] (typeA.with_env check.var) - _ (typeA.infer varT) - arrayA (typeA.with_type (.type (array.Array varT)) - (analyse archive arrayC)) - varT (typeA.with_env - (check.clean varT)) - arrayJT (jvm_array_type (.type (array.Array varT))) - idxA (typeA.with_type ..int - (analyse archive idxC))] - (wrap (#/////analysis.Extension extension_name (list (/////analysis.text (..signature arrayJT)) - idxA - arrayA)))) - - _ - (/////analysis.throw ///.incorrect_arity [extension_name 2 (list.size args)])))) - -(def: (write_primitive_array_handler lux_type jvm_type) - (-> .Type (Type Primitive) Handler) - (let [array_type (#.Primitive (|> (jvm.array jvm_type) ..reflection) - (list))] - (function (_ extension_name analyse archive args) - (case args - (^ (list idxC valueC arrayC)) - (do phase.monad - [_ (typeA.infer array_type) - idxA (typeA.with_type ..int - (analyse archive idxC)) - valueA (typeA.with_type lux_type - (analyse archive valueC)) - arrayA (typeA.with_type array_type - (analyse archive arrayC))] - (wrap (#/////analysis.Extension extension_name (list idxA - valueA - arrayA)))) - - _ - (/////analysis.throw ///.incorrect_arity [extension_name 3 (list.size args)]))))) - -(def: array::write::object - Handler - (function (_ extension_name analyse archive args) - (case args - (^ (list idxC valueC arrayC)) - (do phase.monad - [[var_id varT] (typeA.with_env check.var) - _ (typeA.infer (.type (array.Array varT))) - arrayA (typeA.with_type (.type (array.Array varT)) - (analyse archive arrayC)) - varT (typeA.with_env - (check.clean varT)) - arrayJT (jvm_array_type (.type (array.Array varT))) - idxA (typeA.with_type ..int - (analyse archive idxC)) - valueA (typeA.with_type varT - (analyse archive valueC))] - (wrap (#/////analysis.Extension extension_name (list (/////analysis.text (..signature arrayJT)) - idxA - valueA - arrayA)))) - - _ - (/////analysis.throw ///.incorrect_arity [extension_name 3 (list.size args)])))) - -(def: bundle::array - Bundle - (<| (///bundle.prefix "array") - (|> ///bundle.empty - (dictionary.merge (<| (///bundle.prefix "length") - (|> ///bundle.empty - (///bundle.install (reflection.reflection reflection.boolean) (primitive_array_length_handler jvm.boolean)) - (///bundle.install (reflection.reflection reflection.byte) (primitive_array_length_handler jvm.byte)) - (///bundle.install (reflection.reflection reflection.short) (primitive_array_length_handler jvm.short)) - (///bundle.install (reflection.reflection reflection.int) (primitive_array_length_handler jvm.int)) - (///bundle.install (reflection.reflection reflection.long) (primitive_array_length_handler jvm.long)) - (///bundle.install (reflection.reflection reflection.float) (primitive_array_length_handler jvm.float)) - (///bundle.install (reflection.reflection reflection.double) (primitive_array_length_handler jvm.double)) - (///bundle.install (reflection.reflection reflection.char) (primitive_array_length_handler jvm.char)) - (///bundle.install "object" array::length::object)))) - (dictionary.merge (<| (///bundle.prefix "new") - (|> ///bundle.empty - (///bundle.install (reflection.reflection reflection.boolean) (new_primitive_array_handler jvm.boolean)) - (///bundle.install (reflection.reflection reflection.byte) (new_primitive_array_handler jvm.byte)) - (///bundle.install (reflection.reflection reflection.short) (new_primitive_array_handler jvm.short)) - (///bundle.install (reflection.reflection reflection.int) (new_primitive_array_handler jvm.int)) - (///bundle.install (reflection.reflection reflection.long) (new_primitive_array_handler jvm.long)) - (///bundle.install (reflection.reflection reflection.float) (new_primitive_array_handler jvm.float)) - (///bundle.install (reflection.reflection reflection.double) (new_primitive_array_handler jvm.double)) - (///bundle.install (reflection.reflection reflection.char) (new_primitive_array_handler jvm.char)) - (///bundle.install "object" array::new::object)))) - (dictionary.merge (<| (///bundle.prefix "read") - (|> ///bundle.empty - (///bundle.install (reflection.reflection reflection.boolean) (read_primitive_array_handler ..boolean jvm.boolean)) - (///bundle.install (reflection.reflection reflection.byte) (read_primitive_array_handler ..byte jvm.byte)) - (///bundle.install (reflection.reflection reflection.short) (read_primitive_array_handler ..short jvm.short)) - (///bundle.install (reflection.reflection reflection.int) (read_primitive_array_handler ..int jvm.int)) - (///bundle.install (reflection.reflection reflection.long) (read_primitive_array_handler ..long jvm.long)) - (///bundle.install (reflection.reflection reflection.float) (read_primitive_array_handler ..float jvm.float)) - (///bundle.install (reflection.reflection reflection.double) (read_primitive_array_handler ..double jvm.double)) - (///bundle.install (reflection.reflection reflection.char) (read_primitive_array_handler ..char jvm.char)) - (///bundle.install "object" array::read::object)))) - (dictionary.merge (<| (///bundle.prefix "write") - (|> ///bundle.empty - (///bundle.install (reflection.reflection reflection.boolean) (write_primitive_array_handler ..boolean jvm.boolean)) - (///bundle.install (reflection.reflection reflection.byte) (write_primitive_array_handler ..byte jvm.byte)) - (///bundle.install (reflection.reflection reflection.short) (write_primitive_array_handler ..short jvm.short)) - (///bundle.install (reflection.reflection reflection.int) (write_primitive_array_handler ..int jvm.int)) - (///bundle.install (reflection.reflection reflection.long) (write_primitive_array_handler ..long jvm.long)) - (///bundle.install (reflection.reflection reflection.float) (write_primitive_array_handler ..float jvm.float)) - (///bundle.install (reflection.reflection reflection.double) (write_primitive_array_handler ..double jvm.double)) - (///bundle.install (reflection.reflection reflection.char) (write_primitive_array_handler ..char jvm.char)) - (///bundle.install "object" array::write::object)))) - ))) - -(def: object::null - Handler - (function (_ extension_name analyse archive args) - (case args - (^ (list)) - (do phase.monad - [expectedT (///.lift meta.expected_type) - _ (check_object expectedT)] - (wrap (#/////analysis.Extension extension_name (list)))) - - _ - (/////analysis.throw ///.incorrect_arity [extension_name 0 (list.size args)])))) - -(def: object::null? - Handler - (function (_ extension_name analyse archive args) - (case args - (^ (list objectC)) - (do phase.monad - [_ (typeA.infer Bit) - [objectT objectA] (typeA.with_inference - (analyse archive objectC)) - _ (check_object objectT)] - (wrap (#/////analysis.Extension extension_name (list objectA)))) - - _ - (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)])))) - -(def: object::synchronized - Handler - (function (_ extension_name analyse archive args) - (case args - (^ (list monitorC exprC)) - (do phase.monad - [[monitorT monitorA] (typeA.with_inference - (analyse archive monitorC)) - _ (check_object monitorT) - exprA (analyse archive exprC)] - (wrap (#/////analysis.Extension extension_name (list monitorA exprA)))) - - _ - (/////analysis.throw ///.incorrect_arity [extension_name 2 (list.size args)])))) - -(def: object::throw - Handler - (function (_ extension_name analyse archive args) - (case args - (^ (list exceptionC)) - (do phase.monad - [_ (typeA.infer Nothing) - [exceptionT exceptionA] (typeA.with_inference - (analyse archive exceptionC)) - exception_class (check_object exceptionT) - ? (phase.lift (reflection!.sub? "java.lang.Throwable" exception_class)) - _ (: (Operation Any) - (if ? - (wrap []) - (/////analysis.throw non_throwable exception_class)))] - (wrap (#/////analysis.Extension extension_name (list exceptionA)))) - - _ - (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)])))) - -(def: object::class - Handler - (function (_ extension_name analyse archive args) - (case args - (^ (list classC)) - (case classC - [_ (#.Text class)] - (do phase.monad - [_ (..ensure_fresh_class! class) - _ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list))))) - _ (phase.lift (reflection!.load class))] - (wrap (#/////analysis.Extension extension_name (list (/////analysis.text class))))) - - _ - (/////analysis.throw ///.invalid_syntax [extension_name %.code args])) - - _ - (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)])))) - -(def: object::instance? - Handler - (..custom - [($_ <>.and <code>.text <code>.any) - (function (_ extension_name analyse archive [sub_class objectC]) - (do phase.monad - [_ (..ensure_fresh_class! sub_class) - _ (typeA.infer Bit) - [objectT objectA] (typeA.with_inference - (analyse archive objectC)) - object_class (check_object objectT) - ? (phase.lift (reflection!.sub? object_class sub_class))] - (if ? - (wrap (#/////analysis.Extension extension_name (list (/////analysis.text sub_class) objectA))) - (/////analysis.throw cannot_possibly_be_an_instance (format sub_class " !<= " object_class)))))])) - -(template [<name> <category> <parser>] - [(def: (<name> mapping typeJ) - (-> Mapping (Type <category>) (Operation .Type)) - (case (|> typeJ ..signature (<text>.run (<parser> mapping))) - (#try.Success check) - (typeA.with_env - check) - - (#try.Failure error) - (phase.fail error)))] - - [reflection_type Value luxT.type] - [reflection_return Return luxT.return] - ) - -(def: (class_candidate_parents from_name fromT to_name to_class) - (-> External .Type External (java/lang/Class java/lang/Object) (Operation (List [[Text .Type] Bit]))) - (do {! phase.monad} - [from_class (phase.lift (reflection!.load from_name)) - mapping (phase.lift (reflection!.correspond from_class fromT))] - (monad.map ! - (function (_ superJT) - (do ! - [superJT (phase.lift (reflection!.type superJT)) - #let [super_name (|> superJT ..reflection)] - super_class (phase.lift (reflection!.load super_name)) - superT (reflection_type mapping superJT)] - (wrap [[super_name superT] (java/lang/Class::isAssignableFrom super_class to_class)]))) - (case (java/lang/Class::getGenericSuperclass from_class) - (#.Some super) - (list& super (array.to_list (java/lang/Class::getGenericInterfaces from_class))) - - #.None - (if (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers from_class)) - (#.Cons (:as java/lang/reflect/Type (ffi.class_for java/lang/Object)) - (array.to_list (java/lang/Class::getGenericInterfaces from_class))) - (array.to_list (java/lang/Class::getGenericInterfaces from_class))))))) - -(def: (inheritance_candidate_parents fromT to_class toT fromC) - (-> .Type (java/lang/Class java/lang/Object) .Type Code (Operation (List [[Text .Type] Bit]))) - (case fromT - (^ (#.Primitive _ (list& self_classT super_classT super_interfacesT+))) - (monad.map phase.monad - (function (_ superT) - (do {! phase.monad} - [super_name (\ ! map ..reflection (check_jvm superT)) - super_class (phase.lift (reflection!.load super_name))] - (wrap [[super_name superT] - (java/lang/Class::isAssignableFrom super_class to_class)]))) - (list& super_classT super_interfacesT+)) - - _ - (/////analysis.throw ..cannot_cast [fromT toT fromC]))) - -(def: object::cast - Handler - (function (_ extension_name analyse archive args) - (case args - (^ (list fromC)) - (do {! phase.monad} - [toT (///.lift meta.expected_type) - to_name (\ ! map ..reflection (check_jvm toT)) - [fromT fromA] (typeA.with_inference - (analyse archive fromC)) - from_name (\ ! map ..reflection (check_jvm fromT)) - can_cast? (: (Operation Bit) - (`` (cond (~~ (template [<primitive> <object>] - [(let [=primitive (reflection.reflection <primitive>)] - (or (and (text\= =primitive from_name) - (or (text\= <object> to_name) - (text\= =primitive to_name))) - (and (text\= <object> from_name) - (text\= =primitive to_name)))) - (wrap true)] - - [reflection.boolean box.boolean] - [reflection.byte box.byte] - [reflection.short box.short] - [reflection.int box.int] - [reflection.long box.long] - [reflection.float box.float] - [reflection.double box.double] - [reflection.char box.char])) - - ## else - (do ! - [_ (phase.assert ..primitives_are_not_objects [from_name] - (not (dictionary.key? ..boxes from_name))) - _ (phase.assert ..primitives_are_not_objects [to_name] - (not (dictionary.key? ..boxes to_name))) - to_class (phase.lift (reflection!.load to_name)) - _ (if (text\= ..inheritance_relationship_type_name from_name) - (wrap []) - (do ! - [from_class (phase.lift (reflection!.load from_name))] - (phase.assert ..cannot_cast [fromT toT fromC] - (java/lang/Class::isAssignableFrom from_class to_class))))] - (loop [[current_name currentT] [from_name fromT]] - (if (text\= to_name current_name) - (wrap true) - (do ! - [candidate_parents (: (Operation (List [[Text .Type] Bit])) - (if (text\= ..inheritance_relationship_type_name current_name) - (inheritance_candidate_parents currentT to_class toT fromC) - (class_candidate_parents current_name currentT to_name to_class)))] - (case (|> candidate_parents - (list.filter product.right) - (list\map product.left)) - (#.Cons [next_name nextT] _) - (recur [next_name nextT]) - - #.Nil - (wrap false)))))))))] - (if can_cast? - (wrap (#/////analysis.Extension extension_name (list (/////analysis.text from_name) - (/////analysis.text to_name) - fromA))) - (/////analysis.throw ..cannot_cast [fromT toT fromC]))) - - _ - (/////analysis.throw ///.invalid_syntax [extension_name %.code args])))) - -(def: bundle::object - Bundle - (<| (///bundle.prefix "object") - (|> ///bundle.empty - (///bundle.install "null" object::null) - (///bundle.install "null?" object::null?) - (///bundle.install "synchronized" object::synchronized) - (///bundle.install "throw" object::throw) - (///bundle.install "class" object::class) - (///bundle.install "instance?" object::instance?) - (///bundle.install "cast" object::cast) - ))) - -(def: get::static - Handler - (..custom - [..member - (function (_ extension_name analyse archive [class field]) - (do phase.monad - [_ (..ensure_fresh_class! class) - [final? deprecated? fieldJT] (phase.lift - (do try.monad - [class (reflection!.load class)] - (reflection!.static_field field class))) - _ (phase.assert ..deprecated_field [class field] - (not deprecated?)) - fieldT (reflection_type luxT.fresh fieldJT) - _ (typeA.infer fieldT)] - (wrap (<| (#/////analysis.Extension extension_name) - (list (/////analysis.text class) - (/////analysis.text field) - (/////analysis.text (|> fieldJT ..reflection)))))))])) - -(def: put::static - Handler - (..custom - [($_ <>.and ..member <code>.any) - (function (_ extension_name analyse archive [[class field] valueC]) - (do phase.monad - [_ (..ensure_fresh_class! class) - _ (typeA.infer Any) - [final? deprecated? fieldJT] (phase.lift - (do try.monad - [class (reflection!.load class)] - (reflection!.static_field field class))) - _ (phase.assert ..deprecated_field [class field] - (not deprecated?)) - _ (phase.assert ..cannot_set_a_final_field [class field] - (not final?)) - fieldT (reflection_type luxT.fresh fieldJT) - valueA (typeA.with_type fieldT - (analyse archive valueC))] - (wrap (<| (#/////analysis.Extension extension_name) - (list (/////analysis.text class) - (/////analysis.text field) - valueA)))))])) - -(def: get::virtual - Handler - (..custom - [($_ <>.and ..member <code>.any) - (function (_ extension_name analyse archive [[class field] objectC]) - (do phase.monad - [_ (..ensure_fresh_class! class) - [objectT objectA] (typeA.with_inference - (analyse archive objectC)) - [deprecated? mapping fieldJT] (phase.lift - (do try.monad - [class (reflection!.load class) - [final? deprecated? fieldJT] (reflection!.virtual_field field class) - mapping (reflection!.correspond class objectT)] - (wrap [deprecated? mapping fieldJT]))) - _ (phase.assert ..deprecated_field [class field] - (not deprecated?)) - fieldT (reflection_type mapping fieldJT) - _ (typeA.infer fieldT)] - (wrap (<| (#/////analysis.Extension extension_name) - (list (/////analysis.text class) - (/////analysis.text field) - objectA)))))])) - -(def: put::virtual - Handler - (..custom - [($_ <>.and ..member <code>.any <code>.any) - (function (_ extension_name analyse archive [[class field] valueC objectC]) - (do phase.monad - [_ (..ensure_fresh_class! class) - [objectT objectA] (typeA.with_inference - (analyse archive objectC)) - _ (typeA.infer objectT) - [final? deprecated? mapping fieldJT] (phase.lift - (do try.monad - [class (reflection!.load class) - [final? deprecated? fieldJT] (reflection!.virtual_field field class) - mapping (reflection!.correspond class objectT)] - (wrap [final? deprecated? mapping fieldJT]))) - _ (phase.assert ..deprecated_field [class field] - (not deprecated?)) - _ (phase.assert ..cannot_set_a_final_field [class field] - (not final?)) - fieldT (reflection_type mapping fieldJT) - valueA (typeA.with_type fieldT - (analyse archive valueC))] - (wrap (<| (#/////analysis.Extension extension_name) - (list (/////analysis.text class) - (/////analysis.text field) - valueA - objectA)))))])) - -(type: Method_Style - #Static - #Abstract - #Virtual - #Special - #Interface) - -(def: (check_method aliasing class method_name method_style inputsJT method) - (-> Aliasing (java/lang/Class java/lang/Object) Text Method_Style (List (Type Value)) java/lang/reflect/Method (Operation Bit)) - (do phase.monad - [parameters (|> (java/lang/reflect/Method::getGenericParameterTypes method) - array.to_list - (monad.map try.monad reflection!.type) - phase.lift) - #let [modifiers (java/lang/reflect/Method::getModifiers method) - correct_class? (java/lang/Object::equals class (java/lang/reflect/Method::getDeclaringClass method)) - correct_method? (text\= method_name (java/lang/reflect/Method::getName method)) - static_matches? (case method_style - #Static - (java/lang/reflect/Modifier::isStatic modifiers) - - _ - true) - special_matches? (case method_style - #Special - (not (or (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers class)) - (java/lang/reflect/Modifier::isAbstract modifiers))) - - _ - true) - arity_matches? (n.= (list.size inputsJT) (list.size parameters)) - inputs_match? (and arity_matches? - (list\fold (function (_ [expectedJC actualJC] prev) - (and prev - (jvm\= expectedJC (: (Type Value) - (case (jvm_parser.var? actualJC) - (#.Some name) - (|> aliasing - (dictionary.get name) - (maybe.default name) - jvm.var) - - #.None - actualJC))))) - true - (list.zip/2 parameters inputsJT)))]] - (wrap (and correct_class? - correct_method? - static_matches? - special_matches? - arity_matches? - inputs_match?)))) - -(def: (check_constructor aliasing class inputsJT constructor) - (-> Aliasing (java/lang/Class java/lang/Object) (List (Type Value)) (java/lang/reflect/Constructor java/lang/Object) (Operation Bit)) - (do phase.monad - [parameters (|> (java/lang/reflect/Constructor::getGenericParameterTypes constructor) - array.to_list - (monad.map try.monad reflection!.type) - phase.lift)] - (wrap (and (java/lang/Object::equals class (java/lang/reflect/Constructor::getDeclaringClass constructor)) - (n.= (list.size inputsJT) (list.size parameters)) - (list\fold (function (_ [expectedJC actualJC] prev) - (and prev - (jvm\= expectedJC (: (Type Value) - (case (jvm_parser.var? actualJC) - (#.Some name) - (|> aliasing - (dictionary.get name) - (maybe.default name) - jvm.var) - - #.None - actualJC))))) - true - (list.zip/2 parameters inputsJT)))))) - -(def: idx_to_parameter - (-> Nat .Type) - (|>> (n.* 2) inc #.Parameter)) - -(def: (jvm_type_var_mapping owner_tvars method_tvars) - (-> (List Text) (List Text) [(List .Type) Mapping]) - (let [jvm_tvars (list\compose owner_tvars method_tvars) - lux_tvars (|> jvm_tvars - list.reverse - list.enumeration - (list\map (function (_ [idx name]) - [name (idx_to_parameter idx)])) - list.reverse) - num_owner_tvars (list.size owner_tvars) - owner_tvarsT (|> lux_tvars (list.take num_owner_tvars) (list\map product.right)) - mapping (dictionary.from_list text.hash lux_tvars)] - [owner_tvarsT mapping])) - -(def: (method_signature method_style method) - (-> Method_Style java/lang/reflect/Method (Operation Method_Signature)) - (let [owner (java/lang/reflect/Method::getDeclaringClass method) - owner_tvars (case method_style - #Static - (list) - - _ - (|> (java/lang/Class::getTypeParameters owner) - array.to_list - (list\map (|>> java/lang/reflect/TypeVariable::getName)))) - method_tvars (|> (java/lang/reflect/Method::getTypeParameters method) - array.to_list - (list\map (|>> java/lang/reflect/TypeVariable::getName))) - [owner_tvarsT mapping] (jvm_type_var_mapping owner_tvars method_tvars)] - (do {! phase.monad} - [inputsT (|> (java/lang/reflect/Method::getGenericParameterTypes method) - array.to_list - (monad.map ! (|>> reflection!.type phase.lift)) - (phase\map (monad.map ! (..reflection_type mapping))) - phase\join) - outputT (|> method - java/lang/reflect/Method::getGenericReturnType - reflection!.return - phase.lift - (phase\map (..reflection_return mapping)) - phase\join) - exceptionsT (|> (java/lang/reflect/Method::getGenericExceptionTypes method) - array.to_list - (monad.map ! (|>> reflection!.type phase.lift)) - (phase\map (monad.map ! (..reflection_type mapping))) - phase\join) - #let [methodT (<| (type.univ_q (dictionary.size mapping)) - (type.function (case method_style - #Static - inputsT - - _ - (list& (#.Primitive (java/lang/Class::getName owner) owner_tvarsT) - inputsT))) - outputT)]] - (wrap [methodT - (reflection!.deprecated? (java/lang/reflect/Method::getDeclaredAnnotations method)) - exceptionsT])))) - -(def: (constructor_signature constructor) - (-> (java/lang/reflect/Constructor java/lang/Object) (Operation Method_Signature)) - (let [owner (java/lang/reflect/Constructor::getDeclaringClass constructor) - owner_tvars (|> (java/lang/Class::getTypeParameters owner) - array.to_list - (list\map (|>> java/lang/reflect/TypeVariable::getName))) - method_tvars (|> (java/lang/reflect/Constructor::getTypeParameters constructor) - array.to_list - (list\map (|>> java/lang/reflect/TypeVariable::getName))) - [owner_tvarsT mapping] (jvm_type_var_mapping owner_tvars method_tvars)] - (do {! phase.monad} - [inputsT (|> (java/lang/reflect/Constructor::getGenericParameterTypes constructor) - array.to_list - (monad.map ! (|>> reflection!.type phase.lift)) - (phase\map (monad.map ! (reflection_type mapping))) - phase\join) - exceptionsT (|> (java/lang/reflect/Constructor::getGenericExceptionTypes constructor) - array.to_list - (monad.map ! (|>> reflection!.type phase.lift)) - (phase\map (monad.map ! (reflection_type mapping))) - phase\join) - #let [objectT (#.Primitive (java/lang/Class::getName owner) owner_tvarsT) - constructorT (<| (type.univ_q (dictionary.size mapping)) - (type.function inputsT) - objectT)]] - (wrap [constructorT - (reflection!.deprecated? (java/lang/reflect/Constructor::getDeclaredAnnotations constructor)) - exceptionsT])))) - -(type: Evaluation - (#Pass Method_Signature) - (#Hint Method_Signature)) - -(template [<name> <tag>] - [(def: <name> - (-> Evaluation (Maybe Method_Signature)) - (|>> (case> (<tag> output) - (#.Some output) - - _ - #.None)))] - - [pass! #Pass] - [hint! #Hint] - ) - -(template [<name> <type> <method>] - [(def: <name> - (-> <type> (List (Type Var))) - (|>> <method> - array.to_list - (list\map (|>> java/lang/reflect/TypeVariable::getName jvm.var))))] - - [class_type_variables (java/lang/Class java/lang/Object) java/lang/Class::getTypeParameters] - [constructor_type_variables (java/lang/reflect/Constructor java/lang/Object) java/lang/reflect/Constructor::getTypeParameters] - [method_type_variables java/lang/reflect/Method java/lang/reflect/Method::getTypeParameters] - ) - -(def: (aliasing expected actual) - (-> (List (Type Var)) (List (Type Var)) Aliasing) - (|> (list.zip/2 (list\map jvm_parser.name actual) - (list\map jvm_parser.name expected)) - (dictionary.from_list text.hash))) - -(def: (method_candidate actual_class_tvars class_name actual_method_tvars method_name method_style inputsJT) - (-> (List (Type Var)) External (List (Type Var)) Text Method_Style (List (Type Value)) (Operation Method_Signature)) - (do {! phase.monad} - [class (phase.lift (reflection!.load class_name)) - #let [expected_class_tvars (class_type_variables class)] - candidates (|> class - java/lang/Class::getDeclaredMethods - array.to_list - (list.filter (|>> java/lang/reflect/Method::getName (text\= method_name))) - (monad.map ! (: (-> java/lang/reflect/Method (Operation Evaluation)) - (function (_ method) - (do ! - [#let [expected_method_tvars (method_type_variables method) - aliasing (dictionary.merge (..aliasing expected_class_tvars actual_class_tvars) - (..aliasing expected_method_tvars actual_method_tvars))] - passes? (check_method aliasing class method_name method_style inputsJT method)] - (\ ! map (if passes? - (|>> #Pass) - (|>> #Hint)) - (method_signature method_style method)))))))] - (case (list.all pass! candidates) - (#.Cons method #.Nil) - (wrap method) - - #.Nil - (/////analysis.throw ..no_candidates [class_name method_name inputsJT (list.all hint! candidates)]) - - candidates - (/////analysis.throw ..too_many_candidates [class_name method_name inputsJT candidates])))) - -(def: constructor_method - "<init>") - -(def: (constructor_candidate actual_class_tvars class_name actual_method_tvars inputsJT) - (-> (List (Type Var)) External (List (Type Var)) (List (Type Value)) (Operation Method_Signature)) - (do {! phase.monad} - [class (phase.lift (reflection!.load class_name)) - #let [expected_class_tvars (class_type_variables class)] - candidates (|> class - java/lang/Class::getConstructors - array.to_list - (monad.map ! (function (_ constructor) - (do ! - [#let [expected_method_tvars (constructor_type_variables constructor) - aliasing (dictionary.merge (..aliasing expected_class_tvars actual_class_tvars) - (..aliasing expected_method_tvars actual_method_tvars))] - passes? (check_constructor aliasing class inputsJT constructor)] - (\ ! map - (if passes? (|>> #Pass) (|>> #Hint)) - (constructor_signature constructor))))))] - (case (list.all pass! candidates) - (#.Cons constructor #.Nil) - (wrap constructor) - - #.Nil - (/////analysis.throw ..no_candidates [class_name ..constructor_method inputsJT (list.all hint! candidates)]) - - candidates - (/////analysis.throw ..too_many_candidates [class_name ..constructor_method inputsJT candidates])))) - -(template [<name> <category> <parser>] - [(def: #export <name> - (Parser (Type <category>)) - (<text>.embed <parser> <code>.text))] - - [var Var jvm_parser.var] - [class Class jvm_parser.class] - [type Value jvm_parser.value] - [return Return jvm_parser.return] - ) - -(def: input - (Parser (Typed Code)) - (<code>.tuple (<>.and ..type <code>.any))) - -(def: (decorate_inputs typesT inputsA) - (-> (List (Type Value)) (List Analysis) (List Analysis)) - (|> inputsA - (list.zip/2 (list\map (|>> ..signature /////analysis.text) typesT)) - (list\map (function (_ [type value]) - (/////analysis.tuple (list type value)))))) - -(def: type_vars - (<code>.tuple (<>.some ..var))) - -(def: invoke::static - Handler - (..custom - [($_ <>.and ..type_vars ..member ..type_vars (<>.some ..input)) - (function (_ extension_name analyse archive [class_tvars [class method] method_tvars argsTC]) - (do phase.monad - [_ (..ensure_fresh_class! class) - #let [argsT (list\map product.left argsTC)] - [methodT deprecated? exceptionsT] (..method_candidate class_tvars class method_tvars method #Static argsT) - _ (phase.assert ..deprecated_method [class method methodT] - (not deprecated?)) - [outputT argsA] (inferenceA.general archive analyse methodT (list\map product.right argsTC)) - outputJT (check_return outputT)] - (wrap (#/////analysis.Extension extension_name (list& (/////analysis.text (..signature (jvm.class class (list)))) - (/////analysis.text method) - (/////analysis.text (..signature outputJT)) - (decorate_inputs argsT argsA))))))])) - -(def: invoke::virtual - Handler - (..custom - [($_ <>.and ..type_vars ..member ..type_vars <code>.any (<>.some ..input)) - (function (_ extension_name analyse archive [class_tvars [class method] method_tvars objectC argsTC]) - (do phase.monad - [_ (..ensure_fresh_class! class) - #let [argsT (list\map product.left argsTC)] - [methodT deprecated? exceptionsT] (..method_candidate class_tvars class method_tvars method #Virtual argsT) - _ (phase.assert ..deprecated_method [class method methodT] - (not deprecated?)) - [outputT allA] (inferenceA.general archive analyse methodT (list& objectC (list\map product.right argsTC))) - #let [[objectA argsA] (case allA - (#.Cons objectA argsA) - [objectA argsA] - - _ - (undefined))] - outputJT (check_return outputT)] - (wrap (#/////analysis.Extension extension_name (list& (/////analysis.text (..signature (jvm.class class (list)))) - (/////analysis.text method) - (/////analysis.text (..signature outputJT)) - objectA - (decorate_inputs argsT argsA))))))])) - -(def: invoke::special - Handler - (..custom - [($_ <>.and ..type_vars ..member ..type_vars <code>.any (<>.some ..input)) - (function (_ extension_name analyse archive [class_tvars [class method] method_tvars objectC argsTC]) - (do phase.monad - [_ (..ensure_fresh_class! class) - #let [argsT (list\map product.left argsTC)] - [methodT deprecated? exceptionsT] (..method_candidate class_tvars class method_tvars method #Special argsT) - _ (phase.assert ..deprecated_method [class method methodT] - (not deprecated?)) - [outputT argsA] (inferenceA.general archive analyse methodT (list& objectC (list\map product.right argsTC))) - outputJT (check_return outputT)] - (wrap (#/////analysis.Extension extension_name (list& (/////analysis.text (..signature (jvm.class class (list)))) - (/////analysis.text method) - (/////analysis.text (..signature outputJT)) - (decorate_inputs argsT argsA))))))])) - -(def: invoke::interface - Handler - (..custom - [($_ <>.and ..type_vars ..member ..type_vars <code>.any (<>.some ..input)) - (function (_ extension_name analyse archive [class_tvars [class_name method] method_tvars objectC argsTC]) - (do phase.monad - [_ (..ensure_fresh_class! class_name) - #let [argsT (list\map product.left argsTC)] - class (phase.lift (reflection!.load class_name)) - _ (phase.assert non_interface class_name - (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers class))) - [methodT deprecated? exceptionsT] (..method_candidate class_tvars class_name method_tvars method #Interface argsT) - _ (phase.assert ..deprecated_method [class_name method methodT] - (not deprecated?)) - [outputT allA] (inferenceA.general archive analyse methodT (list& objectC (list\map product.right argsTC))) - #let [[objectA argsA] (case allA - (#.Cons objectA argsA) - [objectA argsA] - - _ - (undefined))] - outputJT (check_return outputT)] - (wrap (#/////analysis.Extension extension_name - (list& (/////analysis.text (..signature (jvm.class class_name (list)))) - (/////analysis.text method) - (/////analysis.text (..signature outputJT)) - objectA - (decorate_inputs argsT argsA))))))])) - -(def: invoke::constructor - (..custom - [($_ <>.and ..type_vars <code>.text ..type_vars (<>.some ..input)) - (function (_ extension_name analyse archive [class_tvars class method_tvars argsTC]) - (do phase.monad - [_ (..ensure_fresh_class! class) - #let [argsT (list\map product.left argsTC)] - [methodT deprecated? exceptionsT] (..constructor_candidate class_tvars class method_tvars argsT) - _ (phase.assert ..deprecated_method [class ..constructor_method methodT] - (not deprecated?)) - [outputT argsA] (inferenceA.general archive analyse methodT (list\map product.right argsTC))] - (wrap (#/////analysis.Extension extension_name (list& (/////analysis.text (..signature (jvm.class class (list)))) - (decorate_inputs argsT argsA))))))])) - -(def: bundle::member - Bundle - (<| (///bundle.prefix "member") - (|> ///bundle.empty - (dictionary.merge (<| (///bundle.prefix "get") - (|> ///bundle.empty - (///bundle.install "static" get::static) - (///bundle.install "virtual" get::virtual)))) - (dictionary.merge (<| (///bundle.prefix "put") - (|> ///bundle.empty - (///bundle.install "static" put::static) - (///bundle.install "virtual" put::virtual)))) - (dictionary.merge (<| (///bundle.prefix "invoke") - (|> ///bundle.empty - (///bundle.install "static" invoke::static) - (///bundle.install "virtual" invoke::virtual) - (///bundle.install "special" invoke::special) - (///bundle.install "interface" invoke::interface) - (///bundle.install "constructor" invoke::constructor) - ))) - ))) - -(type: #export (Annotation_Parameter a) - [Text a]) - -(def: annotation_parameter - (Parser (Annotation_Parameter Code)) - (<code>.tuple (<>.and <code>.text <code>.any))) - -(type: #export (Annotation a) - [Text (List (Annotation_Parameter a))]) - -(def: #export annotation - (Parser (Annotation Code)) - (<code>.form (<>.and <code>.text (<>.some ..annotation_parameter)))) - -(def: #export argument - (Parser Argument) - (<code>.tuple (<>.and <code>.text ..type))) - -(def: (annotation_parameter_analysis [name value]) - (-> (Annotation_Parameter Analysis) Analysis) - (/////analysis.tuple (list (/////analysis.text name) value))) - -(def: (annotation_analysis [name parameters]) - (-> (Annotation Analysis) Analysis) - (/////analysis.tuple (list& (/////analysis.text name) - (list\map annotation_parameter_analysis parameters)))) - -(template [<name> <category>] - [(def: <name> - (-> (Type <category>) Analysis) - (|>> ..signature /////analysis.text))] - - [var_analysis Var] - [class_analysis Class] - [value_analysis Value] - [return_analysis Return] - ) - -(def: (typed_analysis [type term]) - (-> (Typed Analysis) Analysis) - (/////analysis.tuple (list (value_analysis type) term))) - -(def: (argument_analysis [argument argumentJT]) - (-> Argument Analysis) - (/////analysis.tuple - (list (/////analysis.text argument) - (value_analysis argumentJT)))) - -(template [<name> <filter>] - [(def: <name> - (-> (java/lang/Class java/lang/Object) - (Try (List [Text (Type Method)]))) - (|>> java/lang/Class::getDeclaredMethods - array.to_list - <filter> - (monad.map try.monad - (function (_ method) - (do {! try.monad} - [inputs (|> (java/lang/reflect/Method::getGenericParameterTypes method) - array.to_list - (monad.map ! reflection!.type)) - return (|> method - java/lang/reflect/Method::getGenericReturnType - reflection!.return) - exceptions (|> (java/lang/reflect/Method::getGenericExceptionTypes method) - array.to_list - (monad.map ! reflection!.class))] - (wrap [(java/lang/reflect/Method::getName method) - (jvm.method [inputs return exceptions])]))))))] - - [abstract_methods (list.filter (|>> java/lang/reflect/Method::getModifiers java/lang/reflect/Modifier::isAbstract))] - [methods (<|)] - ) - -(def: jvm_package_separator ".") - -(template [<name> <methods>] - [(def: <name> - (-> (List (Type Class)) (Try (List [Text (Type Method)]))) - (|>> (monad.map try.monad (|>> ..reflection reflection!.load)) - (try\map (monad.map try.monad <methods>)) - try\join - (try\map list\join)))] - - [all_abstract_methods ..abstract_methods] - [all_methods ..methods] - ) - -(template [<name>] - [(exception: #export (<name> {methods (List [Text (Type Method)])}) - (exception.report - ["Methods" (exception.enumerate - (function (_ [name type]) - (format (%.text name) " " (..signature type))) - methods)]))] - - [missing_abstract_methods] - [invalid_overriden_methods] - ) - -(type: #export Visibility - #Public - #Private - #Protected - #Default) - -(type: #export Finality Bit) -(type: #export Strictness Bit) - -(def: #export public_tag "public") -(def: #export private_tag "private") -(def: #export protected_tag "protected") -(def: #export default_tag "default") - -(def: #export visibility - (Parser Visibility) - ($_ <>.or - (<code>.text! ..public_tag) - (<code>.text! ..private_tag) - (<code>.text! ..protected_tag) - (<code>.text! ..default_tag))) - -(def: #export (visibility_analysis visibility) - (-> Visibility Analysis) - (/////analysis.text (case visibility - #Public ..public_tag - #Private ..private_tag - #Protected ..protected_tag - #Default ..default_tag))) - -(type: #export (Constructor a) - [Visibility - Strictness - (List (Annotation a)) - (List (Type Var)) - (List (Type Class)) ## Exceptions - Text - (List Argument) - (List (Typed a)) - a]) - -(def: #export constructor_tag "init") - -(def: #export constructor_definition - (Parser (Constructor Code)) - (<| <code>.form - (<>.after (<code>.text! ..constructor_tag)) - ($_ <>.and - ..visibility - <code>.bit - (<code>.tuple (<>.some ..annotation)) - (<code>.tuple (<>.some ..var)) - (<code>.tuple (<>.some ..class)) - <code>.text - (<code>.tuple (<>.some ..argument)) - (<code>.tuple (<>.some ..input)) - <code>.any))) - -(def: #export (analyse_constructor_method analyse archive selfT mapping method) - (-> Phase Archive .Type Mapping (Constructor Code) (Operation Analysis)) - (let [[visibility strict_fp? - annotations vars exceptions - self_name arguments super_arguments body] method] - (do {! phase.monad} - [annotationsA (monad.map ! (function (_ [name parameters]) - (do ! - [parametersA (monad.map ! (function (_ [name value]) - (do ! - [valueA (analyse archive value)] - (wrap [name valueA]))) - parameters)] - (wrap [name parametersA]))) - annotations) - super_arguments (monad.map ! (function (_ [jvmT super_argC]) - (do ! - [luxT (reflection_type mapping jvmT) - super_argA (typeA.with_type luxT - (analyse archive super_argC))] - (wrap [jvmT super_argA]))) - super_arguments) - arguments' (monad.map ! - (function (_ [name jvmT]) - (do ! - [luxT (reflection_type mapping jvmT)] - (wrap [name luxT]))) - arguments) - [scope bodyA] (|> arguments' - (#.Cons [self_name selfT]) - list.reverse - (list\fold scope.with_local (analyse archive body)) - (typeA.with_type .Any) - /////analysis.with_scope)] - (wrap (/////analysis.tuple (list (/////analysis.text ..constructor_tag) - (visibility_analysis visibility) - (/////analysis.bit strict_fp?) - (/////analysis.tuple (list\map annotation_analysis annotationsA)) - (/////analysis.tuple (list\map var_analysis vars)) - (/////analysis.text self_name) - (/////analysis.tuple (list\map ..argument_analysis arguments)) - (/////analysis.tuple (list\map class_analysis exceptions)) - (/////analysis.tuple (list\map typed_analysis super_arguments)) - (#/////analysis.Function - (list\map (|>> /////analysis.variable) - (scope.environment scope)) - (/////analysis.tuple (list bodyA))) - )))))) - -(type: #export (Virtual_Method a) - [Text - Visibility - Finality - Strictness - (List (Annotation a)) - (List (Type Var)) - Text - (List Argument) - (Type Return) - (List (Type Class)) ## Exceptions - a]) - -(def: virtual_tag "virtual") - -(def: #export virtual_method_definition - (Parser (Virtual_Method Code)) - (<| <code>.form - (<>.after (<code>.text! ..virtual_tag)) - ($_ <>.and - <code>.text - ..visibility - <code>.bit - <code>.bit - (<code>.tuple (<>.some ..annotation)) - (<code>.tuple (<>.some ..var)) - <code>.text - (<code>.tuple (<>.some ..argument)) - ..return - (<code>.tuple (<>.some ..class)) - <code>.any))) - -(def: #export (analyse_virtual_method analyse archive selfT mapping method) - (-> Phase Archive .Type Mapping (Virtual_Method Code) (Operation Analysis)) - (let [[method_name visibility - final? strict_fp? annotations vars - self_name arguments return exceptions - body] method] - (do {! phase.monad} - [annotationsA (monad.map ! (function (_ [name parameters]) - (do ! - [parametersA (monad.map ! (function (_ [name value]) - (do ! - [valueA (analyse archive value)] - (wrap [name valueA]))) - parameters)] - (wrap [name parametersA]))) - annotations) - returnT (reflection_return mapping return) - arguments' (monad.map ! - (function (_ [name jvmT]) - (do ! - [luxT (reflection_type mapping jvmT)] - (wrap [name luxT]))) - arguments) - [scope bodyA] (|> arguments' - (#.Cons [self_name selfT]) - list.reverse - (list\fold scope.with_local (analyse archive body)) - (typeA.with_type returnT) - /////analysis.with_scope)] - (wrap (/////analysis.tuple (list (/////analysis.text ..virtual_tag) - (/////analysis.text method_name) - (visibility_analysis visibility) - (/////analysis.bit final?) - (/////analysis.bit strict_fp?) - (/////analysis.tuple (list\map annotation_analysis annotationsA)) - (/////analysis.tuple (list\map var_analysis vars)) - (/////analysis.text self_name) - (/////analysis.tuple (list\map ..argument_analysis arguments)) - (return_analysis return) - (/////analysis.tuple (list\map class_analysis exceptions)) - (#/////analysis.Function - (list\map (|>> /////analysis.variable) - (scope.environment scope)) - (/////analysis.tuple (list bodyA))) - )))))) - -(type: #export (Static_Method a) - [Text - Visibility - Strictness - (List (Annotation a)) - (List (Type Var)) - (List (Type Class)) ## Exceptions - (List Argument) - (Type Return) - a]) - -(def: #export static_tag "static") - -(def: #export static_method_definition - (Parser (Static_Method Code)) - (<| <code>.form - (<>.after (<code>.text! ..static_tag)) - ($_ <>.and - <code>.text - ..visibility - <code>.bit - (<code>.tuple (<>.some ..annotation)) - (<code>.tuple (<>.some ..var)) - (<code>.tuple (<>.some ..class)) - (<code>.tuple (<>.some ..argument)) - ..return - <code>.any))) - -(def: #export (analyse_static_method analyse archive mapping method) - (-> Phase Archive Mapping (Static_Method Code) (Operation Analysis)) - (let [[method_name visibility - strict_fp? annotations vars exceptions - arguments return - body] method] - (do {! phase.monad} - [annotationsA (monad.map ! (function (_ [name parameters]) - (do ! - [parametersA (monad.map ! (function (_ [name value]) - (do ! - [valueA (analyse archive value)] - (wrap [name valueA]))) - parameters)] - (wrap [name parametersA]))) - annotations) - returnT (reflection_return mapping return) - arguments' (monad.map ! - (function (_ [name jvmT]) - (do ! - [luxT (reflection_type mapping jvmT)] - (wrap [name luxT]))) - arguments) - [scope bodyA] (|> arguments' - list.reverse - (list\fold scope.with_local (analyse archive body)) - (typeA.with_type returnT) - /////analysis.with_scope)] - (wrap (/////analysis.tuple (list (/////analysis.text ..static_tag) - (/////analysis.text method_name) - (visibility_analysis visibility) - (/////analysis.bit strict_fp?) - (/////analysis.tuple (list\map annotation_analysis annotationsA)) - (/////analysis.tuple (list\map var_analysis vars)) - (/////analysis.tuple (list\map ..argument_analysis arguments)) - (return_analysis return) - (/////analysis.tuple (list\map class_analysis - exceptions)) - (#/////analysis.Function - (list\map (|>> /////analysis.variable) - (scope.environment scope)) - (/////analysis.tuple (list bodyA))) - )))))) - -(type: #export (Overriden_Method a) - [(Type Class) - Text - Bit - (List (Annotation a)) - (List (Type Var)) - Text - (List Argument) - (Type Return) - (List (Type Class)) - a]) - -(def: #export overriden_tag "override") - -(def: #export overriden_method_definition - (Parser (Overriden_Method Code)) - (<| <code>.form - (<>.after (<code>.text! ..overriden_tag)) - ($_ <>.and - ..class - <code>.text - <code>.bit - (<code>.tuple (<>.some ..annotation)) - (<code>.tuple (<>.some ..var)) - <code>.text - (<code>.tuple (<>.some ..argument)) - ..return - (<code>.tuple (<>.some ..class)) - <code>.any - ))) - -(def: #export (analyse_overriden_method analyse archive selfT mapping method) - (-> Phase Archive .Type Mapping (Overriden_Method Code) (Operation Analysis)) - (let [[parent_type method_name - strict_fp? annotations vars - self_name arguments return exceptions - body] method] - (do {! phase.monad} - [annotationsA (monad.map ! (function (_ [name parameters]) - (do ! - [parametersA (monad.map ! (function (_ [name value]) - (do ! - [valueA (analyse archive value)] - (wrap [name valueA]))) - parameters)] - (wrap [name parametersA]))) - annotations) - returnT (reflection_return mapping return) - arguments' (monad.map ! - (function (_ [name jvmT]) - (do ! - [luxT (reflection_type mapping jvmT)] - (wrap [name luxT]))) - arguments) - [scope bodyA] (|> arguments' - (#.Cons [self_name selfT]) - list.reverse - (list\fold scope.with_local (analyse archive body)) - (typeA.with_type returnT) - /////analysis.with_scope)] - (wrap (/////analysis.tuple (list (/////analysis.text ..overriden_tag) - (class_analysis parent_type) - (/////analysis.text method_name) - (/////analysis.bit strict_fp?) - (/////analysis.tuple (list\map annotation_analysis annotationsA)) - (/////analysis.tuple (list\map var_analysis vars)) - (/////analysis.text self_name) - (/////analysis.tuple (list\map ..argument_analysis arguments)) - (return_analysis return) - (/////analysis.tuple (list\map class_analysis - exceptions)) - (#/////analysis.Function - (list\map (|>> /////analysis.variable) - (scope.environment scope)) - (/////analysis.tuple (list bodyA))) - )))))) - -(type: #export (Method_Definition a) - (#Overriden_Method (Overriden_Method a))) - -(def: #export parameter_types - (-> (List (Type Var)) (Check (List [(Type Var) .Type]))) - (monad.map check.monad - (function (_ parameterJ) - (do check.monad - [[_ parameterT] check.existential] - (wrap [parameterJ parameterT]))))) - -(def: (mismatched_methods super_set sub_set) - (-> (List [Text (Type Method)]) - (List [Text (Type Method)]) - (List [Text (Type Method)])) - (list.filter (function (_ [sub_name subJT]) - (|> super_set - (list.filter (function (_ [super_name superJT]) - (and (text\= super_name sub_name) - (jvm\= superJT subJT)))) - list.size - (n.= 1) - not)) - sub_set)) - -(exception: #export (class_parameter_mismatch {expected (List Text)} - {actual (List (Type Parameter))}) - (exception.report - ["Expected (amount)" (%.nat (list.size expected))] - ["Expected (parameters)" (exception.enumerate %.text expected)] - ["Actual (amount)" (%.nat (list.size actual))] - ["Actual (parameters)" (exception.enumerate ..signature actual)])) - -(def: (super_aliasing class) - (-> (Type Class) (Operation Aliasing)) - (do phase.monad - [#let [[name actual_parameters] (jvm_parser.read_class class)] - class (phase.lift (reflection!.load name)) - #let [expected_parameters (|> (java/lang/Class::getTypeParameters class) - array.to_list - (list\map (|>> java/lang/reflect/TypeVariable::getName)))] - _ (phase.assert ..class_parameter_mismatch [expected_parameters actual_parameters] - (n.= (list.size expected_parameters) - (list.size actual_parameters)))] - (wrap (|> (list.zip/2 expected_parameters actual_parameters) - (list\fold (function (_ [expected actual] mapping) - (case (jvm_parser.var? actual) - (#.Some actual) - (dictionary.put actual expected mapping) - - #.None - mapping)) - jvm_alias.fresh))))) - -(def: (anonymous_class_name module id) - (-> Module Nat Text) - (let [global (text.replace_all .module_separator ..jvm_package_separator module) - local (format "anonymous-class" (%.nat id))] - (format global ..jvm_package_separator local))) - -(def: class::anonymous - Handler - (..custom - [($_ <>.and - (<code>.tuple (<>.some ..var)) - ..class - (<code>.tuple (<>.some ..class)) - (<code>.tuple (<>.some ..input)) - (<code>.tuple (<>.some ..overriden_method_definition))) - (function (_ extension_name analyse archive [parameters - super_class - super_interfaces - constructor_args - methods]) - (do {! phase.monad} - [_ (..ensure_fresh_class! (..reflection super_class)) - _ (monad.map ! (|>> ..reflection ..ensure_fresh_class!) super_interfaces) - parameters (typeA.with_env - (..parameter_types parameters)) - #let [mapping (list\fold (function (_ [parameterJ parameterT] mapping) - (dictionary.put (jvm_parser.name parameterJ) - parameterT - mapping)) - luxT.fresh - parameters)] - super_classT (typeA.with_env - (luxT.check (luxT.class mapping) (..signature super_class))) - super_interfaceT+ (typeA.with_env - (monad.map check.monad - (|>> ..signature (luxT.check (luxT.class mapping))) - super_interfaces)) - selfT (///.lift (do meta.monad - [where meta.current_module_name - id meta.count] - (wrap (inheritance_relationship_type (#.Primitive (..anonymous_class_name where id) (list)) - super_classT - super_interfaceT+)))) - _ (typeA.infer selfT) - constructor_argsA+ (monad.map ! (function (_ [type term]) - (do ! - [argT (reflection_type mapping type) - termA (typeA.with_type argT - (analyse archive term))] - (wrap [type termA]))) - constructor_args) - methodsA (monad.map ! (analyse_overriden_method analyse archive selfT mapping) methods) - required_abstract_methods (phase.lift (all_abstract_methods (list& super_class super_interfaces))) - available_methods (phase.lift (all_methods (list& super_class super_interfaces))) - overriden_methods (monad.map ! (function (_ [parent_type method_name - strict_fp? annotations vars - self_name arguments return exceptions - body]) - (do ! - [aliasing (super_aliasing parent_type)] - (wrap [method_name (|> (jvm.method [(list\map product.right arguments) - return - exceptions]) - (jvm_alias.method aliasing))]))) - methods) - #let [missing_abstract_methods (mismatched_methods overriden_methods required_abstract_methods) - invalid_overriden_methods (mismatched_methods available_methods overriden_methods)] - _ (phase.assert ..missing_abstract_methods missing_abstract_methods - (list.empty? missing_abstract_methods)) - _ (phase.assert ..invalid_overriden_methods invalid_overriden_methods - (list.empty? invalid_overriden_methods))] - (wrap (#/////analysis.Extension extension_name - (list (class_analysis super_class) - (/////analysis.tuple (list\map class_analysis super_interfaces)) - (/////analysis.tuple (list\map typed_analysis constructor_argsA+)) - (/////analysis.tuple methodsA))))))])) - -(def: bundle::class - Bundle - (<| (///bundle.prefix "class") - (|> ///bundle.empty - (///bundle.install "anonymous" class::anonymous) - ))) - -(def: #export bundle - Bundle - (<| (///bundle.prefix "jvm") - (|> ///bundle.empty - (dictionary.merge bundle::conversion) - (dictionary.merge bundle::int) - (dictionary.merge bundle::long) - (dictionary.merge bundle::float) - (dictionary.merge bundle::double) - (dictionary.merge bundle::char) - (dictionary.merge bundle::array) - (dictionary.merge bundle::object) - (dictionary.merge bundle::member) - (dictionary.merge bundle::class) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux deleted file mode 100644 index 8f97d1ba9..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux +++ /dev/null @@ -1,251 +0,0 @@ -(.module: - [lux #* - ["." ffi] - [abstract - ["." monad (#+ do)]] - [control - ["<>" parser - ["<.>" code (#+ Parser)]]] - [data - [collection - ["." array (#+ Array)] - ["." dictionary] - ["." list]]] - ["." type - ["." check]] - ["@" target - ["_" lua]]] - [// - ["/" lux (#+ custom)] - [// - ["." bundle] - [// - ["." analysis #_ - ["#/." type]] - [// - ["." analysis (#+ Analysis Operation Phase Handler Bundle)] - [/// - ["." phase]]]]]]) - -(def: Nil - (for {@.lua ffi.Nil} - Any)) - -(def: Object - (for {@.lua (type (ffi.Object Any))} - Any)) - -(def: Function - (for {@.lua ffi.Function} - Any)) - -(def: array::new - Handler - (custom - [<code>.any - (function (_ extension phase archive lengthC) - (do phase.monad - [lengthA (analysis/type.with_type Nat - (phase archive lengthC)) - [var_id varT] (analysis/type.with_env check.var) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list lengthA)))))])) - -(def: array::length - Handler - (custom - [<code>.any - (function (_ extension phase archive arrayC) - (do phase.monad - [[var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer Nat)] - (wrap (#analysis.Extension extension (list arrayA)))))])) - -(def: array::read - Handler - (custom - [(<>.and <code>.any <code>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer varT)] - (wrap (#analysis.Extension extension (list indexA arrayA)))))])) - -(def: array::write - Handler - (custom - [($_ <>.and <code>.any <code>.any <code>.any) - (function (_ extension phase archive [indexC valueC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - valueA (analysis/type.with_type varT - (phase archive valueC)) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))])) - -(def: array::delete - Handler - (custom - [($_ <>.and <code>.any <code>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list indexA arrayA)))))])) - -(def: bundle::array - Bundle - (<| (bundle.prefix "array") - (|> bundle.empty - (bundle.install "new" array::new) - (bundle.install "length" array::length) - (bundle.install "read" array::read) - (bundle.install "write" array::write) - (bundle.install "delete" array::delete) - ))) - -(def: object::get - Handler - (custom - [($_ <>.and <code>.text <code>.any) - (function (_ extension phase archive [fieldC objectC]) - (do phase.monad - [objectA (analysis/type.with_type ..Object - (phase archive objectC)) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list (analysis.text fieldC) - objectA)))))])) - -(def: object::do - Handler - (custom - [($_ <>.and <code>.text <code>.any (<>.some <code>.any)) - (function (_ extension phase archive [methodC objectC inputsC]) - (do {! phase.monad} - [objectA (analysis/type.with_type ..Object - (phase archive objectC)) - inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list& (analysis.text methodC) - objectA - inputsA)))))])) - -(def: bundle::object - Bundle - (<| (bundle.prefix "object") - (|> bundle.empty - (bundle.install "get" object::get) - (bundle.install "do" object::do) - (bundle.install "nil" (/.nullary ..Nil)) - (bundle.install "nil?" (/.unary Any Bit)) - ))) - -(template [<name> <fromT> <toT>] - [(def: <name> - Handler - (custom - [<code>.any - (function (_ extension phase archive inputC) - (do {! phase.monad} - [inputA (analysis/type.with_type (type <fromT>) - (phase archive inputC)) - _ (analysis/type.infer (type <toT>))] - (wrap (#analysis.Extension extension (list inputA)))))]))] - - [utf8::encode Text (array.Array (I64 Any))] - [utf8::decode (array.Array (I64 Any)) Text] - ) - -(def: bundle::utf8 - Bundle - (<| (bundle.prefix "utf8") - (|> bundle.empty - (bundle.install "encode" utf8::encode) - (bundle.install "decode" utf8::decode) - ))) - -(def: lua::constant - Handler - (custom - [<code>.text - (function (_ extension phase archive name) - (do phase.monad - [_ (analysis/type.infer Any)] - (wrap (#analysis.Extension extension (list (analysis.text name))))))])) - -(def: lua::apply - Handler - (custom - [($_ <>.and <code>.any (<>.some <code>.any)) - (function (_ extension phase archive [abstractionC inputsC]) - (do {! phase.monad} - [abstractionA (analysis/type.with_type ..Function - (phase archive abstractionC)) - inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer Any)] - (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))])) - -(def: lua::power - Handler - (custom - [($_ <>.and <code>.any <code>.any) - (function (_ extension phase archive [powerC baseC]) - (do {! phase.monad} - [powerA (analysis/type.with_type Frac - (phase archive powerC)) - baseA (analysis/type.with_type Frac - (phase archive baseC)) - _ (analysis/type.infer Frac)] - (wrap (#analysis.Extension extension (list powerA baseA)))))])) - -(def: lua::import - Handler - (custom - [<code>.text - (function (_ extension phase archive name) - (do phase.monad - [_ (analysis/type.infer ..Object)] - (wrap (#analysis.Extension extension (list (analysis.text name))))))])) - -(def: lua::function - Handler - (custom - [($_ <>.and <code>.nat <code>.any) - (function (_ extension phase archive [arity abstractionC]) - (do phase.monad - [#let [inputT (type.tuple (list.repeat arity Any))] - abstractionA (analysis/type.with_type (-> inputT Any) - (phase archive abstractionC)) - _ (analysis/type.infer ..Function)] - (wrap (#analysis.Extension extension (list (analysis.nat arity) - abstractionA)))))])) - -(def: #export bundle - Bundle - (<| (bundle.prefix "lua") - (|> bundle.empty - (dictionary.merge bundle::array) - (dictionary.merge bundle::object) - (dictionary.merge bundle::utf8) - - (bundle.install "constant" lua::constant) - (bundle.install "apply" lua::apply) - (bundle.install "power" lua::power) - (bundle.install "import" lua::import) - (bundle.install "function" lua::function) - (bundle.install "script universe" (/.nullary .Bit)) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux deleted file mode 100644 index a86295b2a..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux +++ /dev/null @@ -1,300 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." try] - ["." exception (#+ exception:)] - ["<>" parser - ["<.>" code (#+ Parser)]]] - [data - ["." maybe] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)] - ["." dictionary (#+ Dictionary)]]] - [math - [number - ["n" nat]]] - [type - ["." check]] - ["." meta]] - ["." /// - ["#." bundle] - ["/#" // #_ - [analysis - [".A" type]] - [// - ["#." analysis (#+ Analysis Operation Phase Handler Bundle) - [evaluation (#+ Eval)]] - [/// - ["#" phase] - [meta - [archive (#+ Archive)]]]]]]) - -(def: #export (custom [syntax handler]) - (All [s] - (-> [(Parser s) - (-> Text Phase Archive s (Operation Analysis))] - Handler)) - (function (_ extension_name analyse archive args) - (case (<code>.run syntax args) - (#try.Success inputs) - (handler extension_name analyse archive inputs) - - (#try.Failure _) - (////analysis.throw ///.invalid_syntax [extension_name %.code args])))) - -(def: (simple inputsT+ outputT) - (-> (List Type) Type Handler) - (let [num_expected (list.size inputsT+)] - (function (_ extension_name analyse archive args) - (let [num_actual (list.size args)] - (if (n.= num_expected num_actual) - (do {! ////.monad} - [_ (typeA.infer outputT) - argsA (monad.map ! - (function (_ [argT argC]) - (typeA.with_type argT - (analyse archive argC))) - (list.zip/2 inputsT+ args))] - (wrap (#////analysis.Extension extension_name argsA))) - (////analysis.throw ///.incorrect_arity [extension_name num_expected num_actual])))))) - -(def: #export (nullary valueT) - (-> Type Handler) - (simple (list) valueT)) - -(def: #export (unary inputT outputT) - (-> Type Type Handler) - (simple (list inputT) outputT)) - -(def: #export (binary subjectT paramT outputT) - (-> Type Type Type Handler) - (simple (list subjectT paramT) outputT)) - -(def: #export (trinary subjectT param0T param1T outputT) - (-> Type Type Type Type Handler) - (simple (list subjectT param0T param1T) outputT)) - -## TODO: Get rid of this ASAP -(as_is - (exception: #export (char_text_must_be_size_1 {text Text}) - (exception.report - ["Text" (%.text text)])) - - (def: text_char - (Parser text.Char) - (do <>.monad - [raw <code>.text] - (case (text.size raw) - 1 (wrap (|> raw (text.nth 0) maybe.assume)) - _ (<>.fail (exception.construct ..char_text_must_be_size_1 [raw]))))) - - (def: lux::syntax_char_case! - (..custom - [($_ <>.and - <code>.any - (<code>.tuple (<>.some (<>.and (<code>.tuple (<>.many ..text_char)) - <code>.any))) - <code>.any) - (function (_ extension_name phase archive [input conditionals else]) - (do {! ////.monad} - [input (typeA.with_type text.Char - (phase archive input)) - expectedT (///.lift meta.expected_type) - conditionals (monad.map ! (function (_ [cases branch]) - (do ! - [branch (typeA.with_type expectedT - (phase archive branch))] - (wrap [cases branch]))) - conditionals) - else (typeA.with_type expectedT - (phase archive else))] - (wrap (|> conditionals - (list\map (function (_ [cases branch]) - (////analysis.tuple - (list (////analysis.tuple (list\map (|>> ////analysis.nat) cases)) - branch)))) - (list& input else) - (#////analysis.Extension extension_name)))))]))) - -## "lux is" represents reference/pointer equality. -(def: lux::is - Handler - (function (_ extension_name analyse archive args) - (do ////.monad - [[var_id varT] (typeA.with_env check.var)] - ((binary varT varT Bit extension_name) - analyse archive args)))) - -## "lux try" provides a simple way to interact with the host platform's -## error_handling facilities. -(def: lux::try - Handler - (function (_ extension_name analyse archive args) - (case args - (^ (list opC)) - (do ////.monad - [[var_id varT] (typeA.with_env check.var) - _ (typeA.infer (type (Either Text varT))) - opA (typeA.with_type (type (-> .Any varT)) - (analyse archive opC))] - (wrap (#////analysis.Extension extension_name (list opA)))) - - _ - (////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)])))) - -(def: lux::in_module - Handler - (function (_ extension_name analyse archive argsC+) - (case argsC+ - (^ (list [_ (#.Text module_name)] exprC)) - (////analysis.with_current_module module_name - (analyse archive exprC)) - - _ - (////analysis.throw ///.invalid_syntax [extension_name %.code argsC+])))) - -(def: (lux::type::check eval) - (-> Eval Handler) - (function (_ extension_name analyse archive args) - (case args - (^ (list typeC valueC)) - (do {! ////.monad} - [count (///.lift meta.count) - actualT (\ ! map (|>> (:as Type)) - (eval archive count Type typeC)) - _ (typeA.infer actualT)] - (typeA.with_type actualT - (analyse archive valueC))) - - _ - (////analysis.throw ///.incorrect_arity [extension_name 2 (list.size args)])))) - -(def: (lux::type::as eval) - (-> Eval Handler) - (function (_ extension_name analyse archive args) - (case args - (^ (list typeC valueC)) - (do {! ////.monad} - [count (///.lift meta.count) - actualT (\ ! map (|>> (:as Type)) - (eval archive count Type typeC)) - _ (typeA.infer actualT) - [valueT valueA] (typeA.with_inference - (analyse archive valueC))] - (wrap valueA)) - - _ - (////analysis.throw ///.incorrect_arity [extension_name 2 (list.size args)])))) - -(def: (caster input output) - (-> Type Type Handler) - (..custom - [<code>.any - (function (_ extension_name phase archive valueC) - (do {! ////.monad} - [_ (typeA.infer output)] - (typeA.with_type input - (phase archive valueC))))])) - -(def: lux::macro - Handler - (..custom - [<code>.any - (function (_ extension_name phase archive valueC) - (do {! ////.monad} - [_ (typeA.infer .Macro) - input_type (loop [input_name (name_of .Macro')] - (do ! - [input_type (///.lift (meta.find_def (name_of .Macro')))] - (case input_type - (#.Definition [exported? def_type def_data def_value]) - (wrap (:as Type def_value)) - - (#.Alias real_name) - (recur real_name))))] - (typeA.with_type input_type - (phase archive valueC))))])) - -(def: (bundle::lux eval) - (-> Eval Bundle) - (|> ///bundle.empty - (///bundle.install "syntax char case!" lux::syntax_char_case!) - (///bundle.install "is" lux::is) - (///bundle.install "try" lux::try) - (///bundle.install "type check" (lux::type::check eval)) - (///bundle.install "type as" (lux::type::as eval)) - (///bundle.install "macro" ..lux::macro) - (///bundle.install "type check type" (..caster .Type .Type)) - (///bundle.install "in-module" lux::in_module))) - -(def: bundle::io - Bundle - (<| (///bundle.prefix "io") - (|> ///bundle.empty - (///bundle.install "log" (unary Text Any)) - (///bundle.install "error" (unary Text Nothing)) - (///bundle.install "exit" (unary Int Nothing))))) - -(def: I64* (type (I64 Any))) - -(def: bundle::i64 - Bundle - (<| (///bundle.prefix "i64") - (|> ///bundle.empty - (///bundle.install "and" (binary I64* I64* I64)) - (///bundle.install "or" (binary I64* I64* I64)) - (///bundle.install "xor" (binary I64* I64* I64)) - (///bundle.install "left-shift" (binary Nat I64* I64)) - (///bundle.install "right-shift" (binary Nat I64* I64)) - (///bundle.install "=" (binary I64* I64* Bit)) - (///bundle.install "<" (binary Int Int Bit)) - (///bundle.install "+" (binary I64* I64* I64)) - (///bundle.install "-" (binary I64* I64* I64)) - (///bundle.install "*" (binary Int Int Int)) - (///bundle.install "/" (binary Int Int Int)) - (///bundle.install "%" (binary Int Int Int)) - (///bundle.install "f64" (unary Int Frac)) - (///bundle.install "char" (unary Int Text))))) - -(def: bundle::f64 - Bundle - (<| (///bundle.prefix "f64") - (|> ///bundle.empty - (///bundle.install "+" (binary Frac Frac Frac)) - (///bundle.install "-" (binary Frac Frac Frac)) - (///bundle.install "*" (binary Frac Frac Frac)) - (///bundle.install "/" (binary Frac Frac Frac)) - (///bundle.install "%" (binary Frac Frac Frac)) - (///bundle.install "=" (binary Frac Frac Bit)) - (///bundle.install "<" (binary Frac Frac Bit)) - (///bundle.install "i64" (unary Frac Int)) - (///bundle.install "encode" (unary Frac Text)) - (///bundle.install "decode" (unary Text (type (Maybe Frac))))))) - -(def: bundle::text - Bundle - (<| (///bundle.prefix "text") - (|> ///bundle.empty - (///bundle.install "=" (binary Text Text Bit)) - (///bundle.install "<" (binary Text Text Bit)) - (///bundle.install "concat" (binary Text Text Text)) - (///bundle.install "index" (trinary Nat Text Text (type (Maybe Nat)))) - (///bundle.install "size" (unary Text Nat)) - (///bundle.install "char" (binary Nat Text Nat)) - (///bundle.install "clip" (trinary Nat Nat Text Text)) - ))) - -(def: #export (bundle eval) - (-> Eval Bundle) - (<| (///bundle.prefix "lux") - (|> ///bundle.empty - (dictionary.merge (bundle::lux eval)) - (dictionary.merge bundle::i64) - (dictionary.merge bundle::f64) - (dictionary.merge bundle::text) - (dictionary.merge bundle::io) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux deleted file mode 100644 index 19aea38fa..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux +++ /dev/null @@ -1,213 +0,0 @@ -(.module: - [lux #* - ["." ffi] - [abstract - ["." monad (#+ do)]] - [control - ["<>" parser - ["<c>" code (#+ Parser)]]] - [data - [collection - ["." array (#+ Array)] - ["." dictionary] - ["." list]]] - ["." type - ["." check]] - ["@" target - ["_" php]]] - [// - ["/" lux (#+ custom)] - [// - ["." bundle] - [// - ["." analysis #_ - ["#/." type]] - [// - ["." analysis (#+ Analysis Operation Phase Handler Bundle)] - [/// - ["." phase]]]]]]) - -(def: array::new - Handler - (custom - [<c>.any - (function (_ extension phase archive lengthC) - (do phase.monad - [lengthA (analysis/type.with_type Nat - (phase archive lengthC)) - [var_id varT] (analysis/type.with_env check.var) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list lengthA)))))])) - -(def: array::length - Handler - (custom - [<c>.any - (function (_ extension phase archive arrayC) - (do phase.monad - [[var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer Nat)] - (wrap (#analysis.Extension extension (list arrayA)))))])) - -(def: array::read - Handler - (custom - [(<>.and <c>.any <c>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer varT)] - (wrap (#analysis.Extension extension (list indexA arrayA)))))])) - -(def: array::write - Handler - (custom - [($_ <>.and <c>.any <c>.any <c>.any) - (function (_ extension phase archive [indexC valueC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - valueA (analysis/type.with_type varT - (phase archive valueC)) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))])) - -(def: array::delete - Handler - (custom - [($_ <>.and <c>.any <c>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list indexA arrayA)))))])) - -(def: bundle::array - Bundle - (<| (bundle.prefix "array") - (|> bundle.empty - (bundle.install "new" array::new) - (bundle.install "length" array::length) - (bundle.install "read" array::read) - (bundle.install "write" array::write) - (bundle.install "delete" array::delete) - ))) - -(def: Null - (for {@.php ffi.Null} - Any)) - -(def: Object - (for {@.php (type (ffi.Object Any))} - Any)) - -(def: Function - (for {@.php ffi.Function} - Any)) - -(def: object::new - Handler - (custom - [($_ <>.and <c>.text (<>.some <c>.any)) - (function (_ extension phase archive [constructor inputsC]) - (do {! phase.monad} - [inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list& (analysis.text constructor) inputsA)))))])) - -(def: object::get - Handler - (custom - [($_ <>.and <c>.text <c>.any) - (function (_ extension phase archive [fieldC objectC]) - (do phase.monad - [objectA (analysis/type.with_type ..Object - (phase archive objectC)) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list (analysis.text fieldC) - objectA)))))])) - -(def: object::do - Handler - (custom - [($_ <>.and <c>.text <c>.any (<>.some <c>.any)) - (function (_ extension phase archive [methodC objectC inputsC]) - (do {! phase.monad} - [objectA (analysis/type.with_type ..Object - (phase archive objectC)) - inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list& (analysis.text methodC) - objectA - inputsA)))))])) - -(def: bundle::object - Bundle - (<| (bundle.prefix "object") - (|> bundle.empty - (bundle.install "new" object::new) - (bundle.install "get" object::get) - (bundle.install "do" object::do) - (bundle.install "null" (/.nullary ..Null)) - (bundle.install "null?" (/.unary Any Bit)) - ))) - -(def: php::constant - Handler - (custom - [<c>.text - (function (_ extension phase archive name) - (do phase.monad - [_ (analysis/type.infer Any)] - (wrap (#analysis.Extension extension (list (analysis.text name))))))])) - -(def: php::apply - Handler - (custom - [($_ <>.and <c>.any (<>.some <c>.any)) - (function (_ extension phase archive [abstractionC inputsC]) - (do {! phase.monad} - [abstractionA (analysis/type.with_type ..Function - (phase archive abstractionC)) - inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer Any)] - (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))])) - -(def: php::pack - Handler - (custom - [($_ <>.and <c>.any <c>.any) - (function (_ extension phase archive [formatC dataC]) - (do {! phase.monad} - [formatA (analysis/type.with_type Text - (phase archive formatC)) - dataA (analysis/type.with_type (type (Array (I64 Any))) - (phase archive dataC)) - _ (analysis/type.infer Text)] - (wrap (#analysis.Extension extension (list formatA dataA)))))])) - -(def: #export bundle - Bundle - (<| (bundle.prefix "php") - (|> bundle.empty - (dictionary.merge bundle::array) - (dictionary.merge bundle::object) - - (bundle.install "constant" php::constant) - (bundle.install "apply" php::apply) - (bundle.install "pack" php::pack) - (bundle.install "script universe" (/.nullary .Bit)) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/python.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/python.lux deleted file mode 100644 index 53e6c0b05..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/python.lux +++ /dev/null @@ -1,230 +0,0 @@ -(.module: - [lux #* - ["." ffi] - [abstract - ["." monad (#+ do)]] - [control - ["<>" parser - ["<.>" code (#+ Parser)]]] - [data - [collection - ["." array (#+ Array)] - ["." dictionary] - ["." list]]] - ["." type - ["." check]] - ["@" target - ["_" python]]] - [// - ["/" lux (#+ custom)] - [// - ["." bundle] - [// - ["." analysis #_ - ["#/." type]] - [// - ["." analysis (#+ Analysis Operation Phase Handler Bundle)] - [/// - ["." phase]]]]]]) - -(def: array::new - Handler - (custom - [<code>.any - (function (_ extension phase archive lengthC) - (do phase.monad - [lengthA (analysis/type.with_type Nat - (phase archive lengthC)) - [var_id varT] (analysis/type.with_env check.var) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list lengthA)))))])) - -(def: array::length - Handler - (custom - [<code>.any - (function (_ extension phase archive arrayC) - (do phase.monad - [[var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer Nat)] - (wrap (#analysis.Extension extension (list arrayA)))))])) - -(def: array::read - Handler - (custom - [(<>.and <code>.any <code>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer varT)] - (wrap (#analysis.Extension extension (list indexA arrayA)))))])) - -(def: array::write - Handler - (custom - [($_ <>.and <code>.any <code>.any <code>.any) - (function (_ extension phase archive [indexC valueC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - valueA (analysis/type.with_type varT - (phase archive valueC)) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))])) - -(def: array::delete - Handler - (custom - [($_ <>.and <code>.any <code>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list indexA arrayA)))))])) - -(def: bundle::array - Bundle - (<| (bundle.prefix "array") - (|> bundle.empty - (bundle.install "new" array::new) - (bundle.install "length" array::length) - (bundle.install "read" array::read) - (bundle.install "write" array::write) - (bundle.install "delete" array::delete) - ))) - -(def: None - (for {@.python - ffi.None} - Any)) - -(def: Object - (for {@.python (type (ffi.Object Any))} - Any)) - -(def: Function - (for {@.python ffi.Function} - Any)) - -(def: Dict - (for {@.python ffi.Dict} - Any)) - -(def: object::get - Handler - (custom - [($_ <>.and <code>.text <code>.any) - (function (_ extension phase archive [fieldC objectC]) - (do phase.monad - [objectA (analysis/type.with_type ..Object - (phase archive objectC)) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list (analysis.text fieldC) - objectA)))))])) - -(def: object::do - Handler - (custom - [($_ <>.and <code>.text <code>.any (<>.some <code>.any)) - (function (_ extension phase archive [methodC objectC inputsC]) - (do {! phase.monad} - [objectA (analysis/type.with_type ..Object - (phase archive objectC)) - inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list& (analysis.text methodC) - objectA - inputsA)))))])) - -(def: bundle::object - Bundle - (<| (bundle.prefix "object") - (|> bundle.empty - (bundle.install "get" object::get) - (bundle.install "do" object::do) - (bundle.install "none" (/.nullary ..None)) - (bundle.install "none?" (/.unary Any Bit)) - ))) - -(def: python::constant - Handler - (custom - [<code>.text - (function (_ extension phase archive name) - (do phase.monad - [_ (analysis/type.infer Any)] - (wrap (#analysis.Extension extension (list (analysis.text name))))))])) - -(def: python::import - Handler - (custom - [<code>.text - (function (_ extension phase archive name) - (do phase.monad - [_ (analysis/type.infer ..Object)] - (wrap (#analysis.Extension extension (list (analysis.text name))))))])) - -(def: python::apply - Handler - (custom - [($_ <>.and <code>.any (<>.some <code>.any)) - (function (_ extension phase archive [abstractionC inputsC]) - (do {! phase.monad} - [abstractionA (analysis/type.with_type ..Function - (phase archive abstractionC)) - inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer Any)] - (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))])) - -(def: python::function - Handler - (custom - [($_ <>.and <code>.nat <code>.any) - (function (_ extension phase archive [arity abstractionC]) - (do phase.monad - [#let [inputT (type.tuple (list.repeat arity Any))] - abstractionA (analysis/type.with_type (-> inputT Any) - (phase archive abstractionC)) - _ (analysis/type.infer ..Function)] - (wrap (#analysis.Extension extension (list (analysis.nat arity) - abstractionA)))))])) - -(def: python::exec - Handler - (custom - [($_ <>.and <code>.any <code>.any) - (function (_ extension phase archive [codeC globalsC]) - (do phase.monad - [codeA (analysis/type.with_type Text - (phase archive codeC)) - globalsA (analysis/type.with_type ..Dict - (phase archive globalsC)) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list codeA globalsA)))))])) - -(def: #export bundle - Bundle - (<| (bundle.prefix "python") - (|> bundle.empty - (dictionary.merge bundle::array) - (dictionary.merge bundle::object) - - (bundle.install "constant" python::constant) - (bundle.install "import" python::import) - (bundle.install "apply" python::apply) - (bundle.install "function" python::function) - (bundle.install "exec" python::exec) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux deleted file mode 100644 index 12f578ed2..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux +++ /dev/null @@ -1,34 +0,0 @@ -(.module: - [lux #* - ["." ffi] - [abstract - ["." monad (#+ do)]] - [control - ["<>" parser - ["<c>" code (#+ Parser)]]] - [data - [collection - ["." array (#+ Array)] - ["." dictionary] - ["." list]]] - ["." type - ["." check]] - ["@" target - ["_" r]]] - [// - ["/" lux (#+ custom)] - [// - ["." bundle] - [// - ["." analysis #_ - ["#/." type]] - [// - ["." analysis (#+ Analysis Operation Phase Handler Bundle)] - [/// - ["." phase]]]]]]) - -(def: #export bundle - Bundle - (<| (bundle.prefix "r") - (|> bundle.empty - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/ruby.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/ruby.lux deleted file mode 100644 index 0fda869e9..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/ruby.lux +++ /dev/null @@ -1,198 +0,0 @@ -(.module: - [lux #* - ["." ffi] - [abstract - ["." monad (#+ do)]] - [control - ["<>" parser - ["<c>" code (#+ Parser)]]] - [data - [collection - ["." array (#+ Array)] - ["." dictionary] - ["." list]]] - ["." type - ["." check]] - ["@" target - ["_" ruby]]] - [// - ["/" lux (#+ custom)] - [// - ["." bundle] - [// - ["." analysis #_ - ["#/." type]] - [// - ["." analysis (#+ Analysis Operation Phase Handler Bundle)] - [/// - ["." phase]]]]]]) - -(def: array::new - Handler - (custom - [<c>.any - (function (_ extension phase archive lengthC) - (do phase.monad - [lengthA (analysis/type.with_type Nat - (phase archive lengthC)) - [var_id varT] (analysis/type.with_env check.var) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list lengthA)))))])) - -(def: array::length - Handler - (custom - [<c>.any - (function (_ extension phase archive arrayC) - (do phase.monad - [[var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer Nat)] - (wrap (#analysis.Extension extension (list arrayA)))))])) - -(def: array::read - Handler - (custom - [(<>.and <c>.any <c>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer varT)] - (wrap (#analysis.Extension extension (list indexA arrayA)))))])) - -(def: array::write - Handler - (custom - [($_ <>.and <c>.any <c>.any <c>.any) - (function (_ extension phase archive [indexC valueC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - valueA (analysis/type.with_type varT - (phase archive valueC)) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))])) - -(def: array::delete - Handler - (custom - [($_ <>.and <c>.any <c>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list indexA arrayA)))))])) - -(def: bundle::array - Bundle - (<| (bundle.prefix "array") - (|> bundle.empty - (bundle.install "new" array::new) - (bundle.install "length" array::length) - (bundle.install "read" array::read) - (bundle.install "write" array::write) - (bundle.install "delete" array::delete) - ))) - -(def: Nil - (for {@.ruby ffi.Nil} - Any)) - -(def: Object - (for {@.ruby (type (ffi.Object Any))} - Any)) - -(def: Function - (for {@.ruby ffi.Function} - Any)) - -(def: object::get - Handler - (custom - [($_ <>.and <c>.text <c>.any) - (function (_ extension phase archive [fieldC objectC]) - (do phase.monad - [objectA (analysis/type.with_type ..Object - (phase archive objectC)) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list (analysis.text fieldC) - objectA)))))])) - -(def: object::do - Handler - (custom - [($_ <>.and <c>.text <c>.any (<>.some <c>.any)) - (function (_ extension phase archive [methodC objectC inputsC]) - (do {! phase.monad} - [objectA (analysis/type.with_type ..Object - (phase archive objectC)) - inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list& (analysis.text methodC) - objectA - inputsA)))))])) - -(def: bundle::object - Bundle - (<| (bundle.prefix "object") - (|> bundle.empty - (bundle.install "get" object::get) - (bundle.install "do" object::do) - (bundle.install "nil" (/.nullary ..Nil)) - (bundle.install "nil?" (/.unary Any Bit)) - ))) - -(def: ruby::constant - Handler - (custom - [<c>.text - (function (_ extension phase archive name) - (do phase.monad - [_ (analysis/type.infer Any)] - (wrap (#analysis.Extension extension (list (analysis.text name))))))])) - -(def: ruby::apply - Handler - (custom - [($_ <>.and <c>.any (<>.some <c>.any)) - (function (_ extension phase archive [abstractionC inputsC]) - (do {! phase.monad} - [abstractionA (analysis/type.with_type ..Function - (phase archive abstractionC)) - inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer Any)] - (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))])) - -(def: ruby::import - Handler - (custom - [<c>.text - (function (_ extension phase archive name) - (do phase.monad - [_ (analysis/type.infer Bit)] - (wrap (#analysis.Extension extension (list (analysis.text name))))))])) - -(def: #export bundle - Bundle - (<| (bundle.prefix "ruby") - (|> bundle.empty - (dictionary.merge bundle::array) - (dictionary.merge bundle::object) - - (bundle.install "constant" ruby::constant) - (bundle.install "apply" ruby::apply) - (bundle.install "import" ruby::import) - (bundle.install "script universe" (/.nullary .Bit)) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux deleted file mode 100644 index 86db4170f..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux +++ /dev/null @@ -1,157 +0,0 @@ -(.module: - [lux #* - ["." ffi] - [abstract - ["." monad (#+ do)]] - [control - ["<>" parser - ["<c>" code (#+ Parser)]]] - [data - [collection - ["." array (#+ Array)] - ["." dictionary] - ["." list]]] - ["." type - ["." check]] - ["@" target - ["_" scheme]]] - [// - ["/" lux (#+ custom)] - [// - ["." bundle] - [// - ["." analysis #_ - ["#/." type]] - [// - ["." analysis (#+ Analysis Operation Phase Handler Bundle)] - [/// - ["." phase]]]]]]) - -(def: array::new - Handler - (custom - [<c>.any - (function (_ extension phase archive lengthC) - (do phase.monad - [lengthA (analysis/type.with_type Nat - (phase archive lengthC)) - [var_id varT] (analysis/type.with_env check.var) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list lengthA)))))])) - -(def: array::length - Handler - (custom - [<c>.any - (function (_ extension phase archive arrayC) - (do phase.monad - [[var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer Nat)] - (wrap (#analysis.Extension extension (list arrayA)))))])) - -(def: array::read - Handler - (custom - [(<>.and <c>.any <c>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer varT)] - (wrap (#analysis.Extension extension (list indexA arrayA)))))])) - -(def: array::write - Handler - (custom - [($_ <>.and <c>.any <c>.any <c>.any) - (function (_ extension phase archive [indexC valueC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - valueA (analysis/type.with_type varT - (phase archive valueC)) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))])) - -(def: array::delete - Handler - (custom - [($_ <>.and <c>.any <c>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list indexA arrayA)))))])) - -(def: bundle::array - Bundle - (<| (bundle.prefix "array") - (|> bundle.empty - (bundle.install "new" array::new) - (bundle.install "length" array::length) - (bundle.install "read" array::read) - (bundle.install "write" array::write) - (bundle.install "delete" array::delete) - ))) - -(def: Nil - (for {@.scheme - ffi.Nil} - Any)) - -(def: Function - (for {@.scheme ffi.Function} - Any)) - -(def: bundle::object - Bundle - (<| (bundle.prefix "object") - (|> bundle.empty - (bundle.install "nil" (/.nullary ..Nil)) - (bundle.install "nil?" (/.unary Any Bit)) - ))) - -(def: scheme::constant - Handler - (custom - [<c>.text - (function (_ extension phase archive name) - (do phase.monad - [_ (analysis/type.infer Any)] - (wrap (#analysis.Extension extension (list (analysis.text name))))))])) - -(def: scheme::apply - Handler - (custom - [($_ <>.and <c>.any (<>.some <c>.any)) - (function (_ extension phase archive [abstractionC inputsC]) - (do {! phase.monad} - [abstractionA (analysis/type.with_type ..Function - (phase archive abstractionC)) - inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer Any)] - (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))])) - -(def: #export bundle - Bundle - (<| (bundle.prefix "scheme") - (|> bundle.empty - (dictionary.merge bundle::array) - (dictionary.merge bundle::object) - - (bundle.install "constant" scheme::constant) - (bundle.install "apply" scheme::apply) - (bundle.install "script universe" (/.nullary .Bit)) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/bundle.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/bundle.lux deleted file mode 100644 index 147904b62..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/bundle.lux +++ /dev/null @@ -1,28 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [data - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)] - ["." dictionary (#+ Dictionary)]]]] - [// (#+ Handler Bundle)]) - -(def: #export empty - Bundle - (dictionary.new text.hash)) - -(def: #export (install name anonymous) - (All [s i o] - (-> Text (Handler s i o) - (-> (Bundle s i o) (Bundle s i o)))) - (dictionary.put name anonymous)) - -(def: #export (prefix prefix) - (All [s i o] - (-> Text (-> (Bundle s i o) (Bundle s i o)))) - (|>> dictionary.entries - (list\map (function (_ [key val]) [(format prefix " " key) val])) - (dictionary.from_list text.hash))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux deleted file mode 100644 index a00fe5273..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux +++ /dev/null @@ -1,306 +0,0 @@ -(.module: - [lux (#- Type Definition) - ["." host] - [abstract - ["." monad (#+ do)]] - [control - [pipe (#+ case>)] - ["<>" parser ("#\." monad) - ["<c>" code (#+ Parser)] - ["<t>" text]]] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." dictionary] - ["." row]]] - [macro - ["." template]] - [math - [number - ["." i32]]] - [target - [jvm - ["_" bytecode (#+ Bytecode)] - ["." modifier (#+ Modifier) ("#\." monoid)] - ["." attribute] - ["." field] - ["." version] - ["." class] - ["." constant - ["." pool (#+ Resource)]] - [encoding - ["." name]] - ["." type (#+ Type Constraint Argument Typed) - [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] - [".T" lux (#+ Mapping)] - ["." signature] - ["." descriptor (#+ Descriptor)] - ["." parser]]]] - [tool - [compiler - ["." analysis] - ["." synthesis] - ["." generation] - ["." directive (#+ Handler Bundle)] - ["." phase - [analysis - [".A" type]] - ["." generation - [jvm - [runtime (#+ Anchor Definition)]]] - ["." extension - ["." bundle] - [analysis - ["." jvm]] - [directive - ["/" lux]]]]]] - [type - ["." check (#+ Check)]]]) - -(type: Operation - (directive.Operation Anchor (Bytecode Any) Definition)) - -(def: signature (|>> type.signature signature.signature)) - -(type: Declaration - [Text (List (Type Var))]) - -(def: declaration - (Parser Declaration) - (<c>.form (<>.and <c>.text (<>.some jvm.var)))) - -(def: visibility - (Parser (Modifier field.Field)) - (`` ($_ <>.either - (~~ (template [<label> <modifier>] - [(<>.after (<c>.text! <label>) (<>\wrap <modifier>))] - - ["public" field.public] - ["private" field.private] - ["protected" field.protected] - ["default" modifier.empty]))))) - -(def: inheritance - (Parser (Modifier class.Class)) - (`` ($_ <>.either - (~~ (template [<label> <modifier>] - [(<>.after (<c>.text! <label>) (<>\wrap <modifier>))] - - ["final" class.final] - ["abstract" class.abstract] - ["default" modifier.empty]))))) - -(def: state - (Parser (Modifier field.Field)) - (`` ($_ <>.either - (~~ (template [<label> <modifier>] - [(<>.after (<c>.text! <label>) (<>\wrap <modifier>))] - - ["volatile" field.volatile] - ["final" field.final] - ["default" modifier.empty]))))) - -(type: Annotation Any) - -(def: annotation - (Parser Annotation) - <c>.any) - -(def: field-type - (Parser (Type Value)) - (<t>.embed parser.value <c>.text)) - -(type: Constant - [Text (List Annotation) (Type Value) Code]) - -(def: constant - (Parser Constant) - (<| <c>.form - (<>.after (<c>.text! "constant")) - ($_ <>.and - <c>.text - (<c>.tuple (<>.some ..annotation)) - ..field-type - <c>.any - ))) - -(type: Variable - [Text (Modifier field.Field) (Modifier field.Field) (List Annotation) (Type Value)]) - -(def: variable - (Parser Variable) - (<| <c>.form - (<>.after (<c>.text! "variable")) - ($_ <>.and - <c>.text - ..visibility - ..state - (<c>.tuple (<>.some ..annotation)) - ..field-type - ))) - -(type: Field - (#Constant Constant) - (#Variable Variable)) - -(def: field - (Parser Field) - ($_ <>.or - ..constant - ..variable - )) - -(type: Method-Definition - (#Constructor (jvm.Constructor Code)) - (#Virtual-Method (jvm.Virtual-Method Code)) - (#Static-Method (jvm.Static-Method Code)) - (#Overriden-Method (jvm.Overriden-Method Code))) - -(def: method - (Parser Method-Definition) - ($_ <>.or - jvm.constructor-definition - jvm.virtual-method-definition - jvm.static-method-definition - jvm.overriden-method-definition - )) - -(def: (constraint name) - (-> Text Constraint) - {#type.name name - #type.super-class (type.class "java.lang.Object" (list)) - #type.super-interfaces (list)}) - -(def: constant::modifier - (Modifier field.Field) - ($_ modifier\compose - field.public - field.static - field.final)) - -(def: (field-definition field) - (-> Field (Resource field.Field)) - (case field - ## TODO: Handle annotations. - (#Constant [name annotations type value]) - (case value - (^template [<tag> <type> <constant>] - [[_ (<tag> value)] - (do pool.monad - [constant (`` (|> value (~~ (template.splice <constant>)))) - attribute (attribute.constant constant)] - (field.field ..constant::modifier name <type> (row.row attribute)))]) - ([#.Bit type.boolean [(case> #0 +0 #1 +1) .i64 i32.i32 constant.integer pool.integer]] - [#.Int type.byte [.i64 i32.i32 constant.integer pool.integer]] - [#.Int type.short [.i64 i32.i32 constant.integer pool.integer]] - [#.Int type.int [.i64 i32.i32 constant.integer pool.integer]] - [#.Int type.long [constant.long pool.long]] - [#.Frac type.float [host.double-to-float constant.float pool.float]] - [#.Frac type.double [constant.double pool.double]] - [#.Nat type.char [.i64 i32.i32 constant.integer pool.integer]] - [#.Text (type.class "java.lang.String" (list)) [pool.string]] - ) - - ## TODO: Tighten this pattern-matching so this catch-all clause isn't necessary. - _ - (undefined)) - - ## TODO: Handle annotations. - (#Variable [name visibility state annotations type]) - (field.field (modifier\compose visibility state) - name type (row.row)))) - -(def: (method-definition [mapping selfT] [analyse synthesize generate]) - (-> [Mapping .Type] - [analysis.Phase - synthesis.Phase - (generation.Phase Anchor (Bytecode Any) Definition)] - (-> Method-Definition (Operation synthesis.Synthesis))) - (function (_ methodC) - (do phase.monad - [methodA (: (Operation analysis.Analysis) - (directive.lift-analysis - (case methodC - (#Constructor method) - (jvm.analyse-constructor-method analyse selfT mapping method) - - (#Virtual-Method method) - (jvm.analyse-virtual-method analyse selfT mapping method) - - (#Static-Method method) - (jvm.analyse-static-method analyse mapping method) - - (#Overriden-Method method) - (jvm.analyse-overriden-method analyse selfT mapping method))))] - (directive.lift-synthesis - (synthesize methodA))))) - -(def: jvm::class - (Handler Anchor (Bytecode Any) Definition) - (/.custom - [($_ <>.and - ..declaration - jvm.class - (<c>.tuple (<>.some jvm.class)) - ..inheritance - (<c>.tuple (<>.some ..annotation)) - (<c>.tuple (<>.some ..field)) - (<c>.tuple (<>.some ..method))) - (function (_ extension phase - [[name parameters] - super-class - super-interfaces - inheritance - ## TODO: Handle annotations. - annotations - fields - methods]) - (do {! phase.monad} - [parameters (directive.lift-analysis - (typeA.with-env - (jvm.parameter-types parameters))) - #let [mapping (list\fold (function (_ [parameterJ parameterT] mapping) - (dictionary.put (parser.name parameterJ) parameterT mapping)) - luxT.fresh - parameters)] - super-classT (directive.lift-analysis - (typeA.with-env - (luxT.check (luxT.class mapping) (..signature super-class)))) - super-interfaceT+ (directive.lift-analysis - (typeA.with-env - (monad.map check.monad - (|>> ..signature (luxT.check (luxT.class mapping))) - super-interfaces))) - #let [selfT (jvm.inheritance-relationship-type (#.Primitive name (list\map product.right parameters)) - super-classT - super-interfaceT+)] - state (extension.lift phase.get-state) - #let [analyse (get@ [#directive.analysis #directive.phase] state) - synthesize (get@ [#directive.synthesis #directive.phase] state) - generate (get@ [#directive.generation #directive.phase] state)] - methods (monad.map ! (..method-definition [mapping selfT] [analyse synthesize generate]) - methods) - ## _ (directive.lift-generation - ## (generation.save! true ["" name] - ## [name - ## (class.class version.v6_0 - ## (modifier\compose class.public inheritance) - ## (name.internal name) (list\map (|>> product.left parser.name ..constraint) parameters) - ## super-class super-interfaces - ## (list\map ..field-definition fields) - ## (list) ## TODO: Add methods - ## (row.row))])) - _ (directive.lift-generation - (generation.log! (format "Class " name)))] - (wrap directive.no-requirements)))])) - -(def: #export bundle - (Bundle Anchor (Bytecode Any) Definition) - (<| (bundle.prefix "jvm") - (|> bundle.empty - ## TODO: Finish handling methods and un-comment. - ## (dictionary.put "class" jvm::class) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux deleted file mode 100644 index 9e405eb78..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux +++ /dev/null @@ -1,450 +0,0 @@ -(.module: - [lux #* - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - [io (#+ IO)] - ["." try] - ["." exception (#+ exception:)] - ["p" parser - ["s" code (#+ Parser)]]] - [data - ["." product] - ["." maybe] - ["." text - ["%" format (#+ format)]] - [collection - ["." dictionary]]] - [macro - ["." code]] - [math - [number - ["n" nat]]] - ["." type (#+ :share) - ["." check]]] - ["." /// (#+ Extender) - ["#." bundle] - ["#." analysis] - ["/#" // #_ - [analysis - ["." module] - [".A" type]] - ["/#" // #_ - ["#." analysis - [macro (#+ Expander)] - ["#/." evaluation]] - ["#." synthesis (#+ Synthesis)] - ["#." generation (#+ Context)] - ["#." directive (#+ Import Requirements Phase Operation Handler Bundle)] - ["#." program (#+ Program)] - [/// - ["." phase] - [meta - ["." archive (#+ Archive)]]]]]]) - -(def: #export (custom [syntax handler]) - (All [anchor expression directive s] - (-> [(Parser s) - (-> Text - (Phase anchor expression directive) - Archive - s - (Operation anchor expression directive Requirements))] - (Handler anchor expression directive))) - (function (_ extension_name phase archive inputs) - (case (s.run syntax inputs) - (#try.Success inputs) - (handler extension_name phase archive inputs) - - (#try.Failure error) - (phase.throw ///.invalid_syntax [extension_name %.code inputs])))) - -(def: (context [module_id artifact_id]) - (-> Context Context) - ## TODO: Find a better way that doesn't rely on clever tricks. - [module_id (n.- (inc artifact_id) 0)]) - -## TODO: Inline "evaluate!'" into "evaluate!" ASAP -(def: (evaluate!' archive generate code//type codeS) - (All [anchor expression directive] - (-> Archive - (/////generation.Phase anchor expression directive) - Type - Synthesis - (Operation anchor expression directive [Type expression Any]))) - (/////directive.lift_generation - (do phase.monad - [module /////generation.module - id /////generation.next - codeG (generate archive codeS) - module_id (/////generation.module_id module archive) - codeV (/////generation.evaluate! (..context [module_id id]) codeG)] - (wrap [code//type codeG codeV])))) - -(def: #export (evaluate! archive type codeC) - (All [anchor expression directive] - (-> Archive Type Code (Operation anchor expression directive [Type expression Any]))) - (do phase.monad - [state (///.lift phase.get_state) - #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state) - synthesize (get@ [#/////directive.synthesis #/////directive.phase] state) - generate (get@ [#/////directive.generation #/////directive.phase] state)] - [_ codeA] (/////directive.lift_analysis - (/////analysis.with_scope - (typeA.with_fresh_env - (typeA.with_type type - (analyse archive codeC))))) - codeS (/////directive.lift_synthesis - (synthesize archive codeA))] - (evaluate!' archive generate type codeS))) - -## TODO: Inline "definition'" into "definition" ASAP -(def: (definition' archive generate [module name] code//type codeS) - (All [anchor expression directive] - (-> Archive - (/////generation.Phase anchor expression directive) - Name - Type - Synthesis - (Operation anchor expression directive [Type expression Any]))) - (/////directive.lift_generation - (do phase.monad - [codeG (generate archive codeS) - id (/////generation.learn name) - module_id (phase.lift (archive.id module archive)) - [target_name value directive] (/////generation.define! [module_id id] codeG) - _ (/////generation.save! id directive)] - (wrap [code//type codeG value])))) - -(def: (definition archive name expected codeC) - (All [anchor expression directive] - (-> Archive Name (Maybe Type) Code - (Operation anchor expression directive [Type expression Any]))) - (do {! phase.monad} - [state (///.lift phase.get_state) - #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state) - synthesize (get@ [#/////directive.synthesis #/////directive.phase] state) - generate (get@ [#/////directive.generation #/////directive.phase] state)] - [_ code//type codeA] (/////directive.lift_analysis - (/////analysis.with_scope - (typeA.with_fresh_env - (case expected - #.None - (do ! - [[code//type codeA] (typeA.with_inference - (analyse archive codeC)) - code//type (typeA.with_env - (check.clean code//type))] - (wrap [code//type codeA])) - - (#.Some expected) - (do ! - [codeA (typeA.with_type expected - (analyse archive codeC))] - (wrap [expected codeA])))))) - codeS (/////directive.lift_synthesis - (synthesize archive codeA))] - (definition' archive generate name code//type codeS))) - -(template [<full> <partial> <learn>] - [## TODO: Inline "<partial>" into "<full>" ASAP - (def: (<partial> archive generate extension codeT codeS) - (All [anchor expression directive] - (-> Archive - (/////generation.Phase anchor expression directive) - Text - Type - Synthesis - (Operation anchor expression directive [expression Any]))) - (do phase.monad - [current_module (/////directive.lift_analysis - (///.lift meta.current_module_name))] - (/////directive.lift_generation - (do phase.monad - [codeG (generate archive codeS) - module_id (phase.lift (archive.id current_module archive)) - id (<learn> extension) - [target_name value directive] (/////generation.define! [module_id id] codeG) - _ (/////generation.save! id directive)] - (wrap [codeG value]))))) - - (def: #export (<full> archive extension codeT codeC) - (All [anchor expression directive] - (-> Archive Text Type Code - (Operation anchor expression directive [expression Any]))) - (do phase.monad - [state (///.lift phase.get_state) - #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state) - synthesize (get@ [#/////directive.synthesis #/////directive.phase] state) - generate (get@ [#/////directive.generation #/////directive.phase] state)] - [_ codeA] (/////directive.lift_analysis - (/////analysis.with_scope - (typeA.with_fresh_env - (typeA.with_type codeT - (analyse archive codeC))))) - codeS (/////directive.lift_synthesis - (synthesize archive codeA))] - (<partial> archive generate extension codeT codeS)))] - - [analyser analyser' /////generation.learn_analyser] - [synthesizer synthesizer' /////generation.learn_synthesizer] - [generator generator' /////generation.learn_generator] - [directive directive' /////generation.learn_directive] - ) - -(def: (refresh expander host_analysis) - (All [anchor expression directive] - (-> Expander /////analysis.Bundle (Operation anchor expression directive Any))) - (do phase.monad - [[bundle state] phase.get_state - #let [eval (/////analysis/evaluation.evaluator expander - (get@ [#/////directive.synthesis #/////directive.state] state) - (get@ [#/////directive.generation #/////directive.state] state) - (get@ [#/////directive.generation #/////directive.phase] state))]] - (phase.set_state [bundle - (update@ [#/////directive.analysis #/////directive.state] - (: (-> /////analysis.State+ /////analysis.State+) - (|>> product.right - [(///analysis.bundle eval host_analysis)])) - state)]))) - -(def: (announce_definition! short type) - (All [anchor expression directive] - (-> Text Type (Operation anchor expression directive Any))) - (/////directive.lift_generation - (/////generation.log! (format short " : " (%.type type))))) - -(def: (lux::def expander host_analysis) - (-> Expander /////analysis.Bundle Handler) - (function (_ extension_name phase archive inputsC+) - (case inputsC+ - (^ (list [_ (#.Identifier ["" short_name])] valueC annotationsC [_ (#.Bit exported?)])) - (do phase.monad - [current_module (/////directive.lift_analysis - (///.lift meta.current_module_name)) - #let [full_name [current_module short_name]] - [type valueT value] (..definition archive full_name #.None valueC) - [_ annotationsT annotations] (evaluate! archive Code annotationsC) - _ (/////directive.lift_analysis - (module.define short_name (#.Right [exported? type (:as Code annotations) value]))) - _ (..refresh expander host_analysis) - _ (..announce_definition! short_name type)] - (wrap /////directive.no_requirements)) - - _ - (phase.throw ///.invalid_syntax [extension_name %.code inputsC+])))) - -(def: (def::type_tagged expander host_analysis) - (-> Expander /////analysis.Bundle Handler) - (..custom - [($_ p.and s.local_identifier s.any s.any (s.tuple (p.some s.text)) s.bit) - (function (_ extension_name phase archive [short_name valueC annotationsC tags exported?]) - (do phase.monad - [current_module (/////directive.lift_analysis - (///.lift meta.current_module_name)) - #let [full_name [current_module short_name]] - [_ annotationsT annotations] (evaluate! archive Code annotationsC) - #let [annotations (:as Code annotations)] - [type valueT value] (..definition archive full_name (#.Some .Type) valueC) - _ (/////directive.lift_analysis - (do phase.monad - [_ (module.define short_name (#.Right [exported? type annotations value]))] - (module.declare_tags tags exported? (:as Type value)))) - _ (..refresh expander host_analysis) - _ (..announce_definition! short_name type)] - (wrap /////directive.no_requirements)))])) - -(def: imports - (Parser (List Import)) - (|> (s.tuple (p.and s.text s.text)) - p.some - s.tuple)) - -(def: def::module - Handler - (..custom - [($_ p.and s.any ..imports) - (function (_ extension_name phase archive [annotationsC imports]) - (do {! phase.monad} - [[_ annotationsT annotationsV] (evaluate! archive Code annotationsC) - #let [annotationsV (:as Code annotationsV)] - _ (/////directive.lift_analysis - (do ! - [_ (monad.map ! (function (_ [module alias]) - (do ! - [_ (module.import module)] - (case alias - "" (wrap []) - _ (module.alias alias module)))) - imports)] - (module.set_annotations annotationsV)))] - (wrap {#/////directive.imports imports - #/////directive.referrals (list)})))])) - -(exception: #export (cannot_alias_an_alias {local Alias} {foreign Alias} {target Name}) - (exception.report - ["Local alias" (%.name local)] - ["Foreign alias" (%.name foreign)] - ["Target definition" (%.name target)])) - -(def: (define_alias alias original) - (-> Text Name (/////analysis.Operation Any)) - (do phase.monad - [current_module (///.lift meta.current_module_name) - constant (///.lift (meta.find_def original))] - (case constant - (#.Left de_aliased) - (phase.throw ..cannot_alias_an_alias [[current_module alias] original de_aliased]) - - (#.Right [exported? original_type original_annotations original_value]) - (module.define alias (#.Left original))))) - -(def: def::alias - Handler - (..custom - [($_ p.and s.local_identifier s.identifier) - (function (_ extension_name phase archive [alias def_name]) - (do phase.monad - [_ (///.lift - (phase.sub [(get@ [#/////directive.analysis #/////directive.state]) - (set@ [#/////directive.analysis #/////directive.state])] - (define_alias alias def_name)))] - (wrap /////directive.no_requirements)))])) - -(template [<description> <mame> <def_type> <type> <scope> <definer>] - [(def: (<mame> [anchorT expressionT directiveT] extender) - (All [anchor expression directive] - (-> [Type Type Type] Extender - (Handler anchor expression directive))) - (function (handler extension_name phase archive inputsC+) - (case inputsC+ - (^ (list nameC valueC)) - (do phase.monad - [[_ _ name] (evaluate! archive Text nameC) - [_ handlerV] (<definer> archive (:as Text name) - (type <def_type>) - valueC) - _ (<| <scope> - (///.install extender (:as Text name)) - (:share [anchor expression directive] - (Handler anchor expression directive) - handler - - <type> - (:assume handlerV))) - _ (/////directive.lift_generation - (/////generation.log! (format <description> " " (%.text (:as Text name)))))] - (wrap /////directive.no_requirements)) - - _ - (phase.throw ///.invalid_syntax [extension_name %.code inputsC+]))))] - - ["Analysis" - def::analysis - /////analysis.Handler /////analysis.Handler - /////directive.lift_analysis - ..analyser] - ["Synthesis" - def::synthesis - /////synthesis.Handler /////synthesis.Handler - /////directive.lift_synthesis - ..synthesizer] - ["Generation" - def::generation - (/////generation.Handler anchorT expressionT directiveT) (/////generation.Handler anchor expression directive) - /////directive.lift_generation - ..generator] - ["Directive" - def::directive - (/////directive.Handler anchorT expressionT directiveT) (/////directive.Handler anchor expression directive) - (<|) - ..directive] - ) - -## TODO; Both "prepare-program" and "define-program" exist only -## because the old compiler couldn't handle a fully-inlined definition -## for "def::program". Inline them ASAP. -(def: (prepare_program archive analyse synthesize programC) - (All [anchor expression directive output] - (-> Archive - /////analysis.Phase - /////synthesis.Phase - Code - (Operation anchor expression directive Synthesis))) - (do phase.monad - [[_ programA] (/////directive.lift_analysis - (/////analysis.with_scope - (typeA.with_fresh_env - (typeA.with_type (type (-> (List Text) (IO Any))) - (analyse archive programC)))))] - (/////directive.lift_synthesis - (synthesize archive programA)))) - -(def: (define_program archive module_id generate program programS) - (All [anchor expression directive output] - (-> Archive - archive.ID - (/////generation.Phase anchor expression directive) - (Program expression directive) - Synthesis - (/////generation.Operation anchor expression directive Any))) - (do phase.monad - [programG (generate archive programS) - artifact_id (/////generation.learn /////program.name)] - (/////generation.save! artifact_id (program [module_id artifact_id] programG)))) - -(def: (def::program program) - (All [anchor expression directive] - (-> (Program expression directive) (Handler anchor expression directive))) - (function (handler extension_name phase archive inputsC+) - (case inputsC+ - (^ (list programC)) - (do phase.monad - [state (///.lift phase.get_state) - #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state) - synthesize (get@ [#/////directive.synthesis #/////directive.phase] state) - generate (get@ [#/////directive.generation #/////directive.phase] state)] - programS (prepare_program archive analyse synthesize programC) - current_module (/////directive.lift_analysis - (///.lift meta.current_module_name)) - module_id (phase.lift (archive.id current_module archive)) - _ (/////directive.lift_generation - (define_program archive module_id generate program programS))] - (wrap /////directive.no_requirements)) - - _ - (phase.throw ///.invalid_syntax [extension_name %.code inputsC+])))) - -(def: (bundle::def expander host_analysis program anchorT,expressionT,directiveT extender) - (All [anchor expression directive] - (-> Expander - /////analysis.Bundle - (Program expression directive) - [Type Type Type] - Extender - (Bundle anchor expression directive))) - (<| (///bundle.prefix "def") - (|> ///bundle.empty - (dictionary.put "module" def::module) - (dictionary.put "alias" def::alias) - (dictionary.put "type tagged" (def::type_tagged expander host_analysis)) - (dictionary.put "analysis" (def::analysis anchorT,expressionT,directiveT extender)) - (dictionary.put "synthesis" (def::synthesis anchorT,expressionT,directiveT extender)) - (dictionary.put "generation" (def::generation anchorT,expressionT,directiveT extender)) - (dictionary.put "directive" (def::directive anchorT,expressionT,directiveT extender)) - (dictionary.put "program" (def::program program)) - ))) - -(def: #export (bundle expander host_analysis program anchorT,expressionT,directiveT extender) - (All [anchor expression directive] - (-> Expander - /////analysis.Bundle - (Program expression directive) - [Type Type Type] - Extender - (Bundle anchor expression directive))) - (<| (///bundle.prefix "lux") - (|> ///bundle.empty - (dictionary.put "def" (lux::def expander host_analysis)) - (dictionary.merge (..bundle::def expander host_analysis program anchorT,expressionT,directiveT extender))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux deleted file mode 100644 index dc81d4b18..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - ["." / #_ - ["#." common] - ["#." host] - [//// - [generation - [common_lisp - [runtime (#+ Bundle)]]]]]) - -(def: #export bundle - Bundle - (dictionary.merge /common.bundle - /host.bundle)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux deleted file mode 100644 index d1ad7bd99..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux +++ /dev/null @@ -1,179 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["." try] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." dictionary] - ["." set] - ["." list ("#\." functor fold)]]] - [math - [number - ["f" frac]]] - ["@" target - ["_" common_lisp (#+ Expression)]]] - ["." //// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["." reference] - ["//" common_lisp #_ - ["#." runtime (#+ Operation Phase Handler Bundle Generator)] - ["#." case]]] - [// - ["." synthesis (#+ %synthesis)] - ["." generation] - [/// - ["#" phase]]]]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text (Generator s))] - Handler)) - (function (_ extension_name phase archive input) - (case (<s>.run parser input) - (#try.Success input') - (handler extension_name phase archive input') - - (#try.Failure error) - (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) - -(template: (!unary function) - (|>> list _.apply/* (|> (_.constant function)))) - -## ## TODO: Get rid of this ASAP -## (def: lux::syntax_char_case! -## (..custom [($_ <>.and -## <s>.any -## <s>.any -## (<>.some (<s>.tuple ($_ <>.and -## (<s>.tuple (<>.many <s>.i64)) -## <s>.any)))) -## (function (_ extension_name phase archive [input else conditionals]) -## (do {! /////.monad} -## [@input (\ ! map _.var (generation.gensym "input")) -## inputG (phase archive input) -## elseG (phase archive else) -## conditionalsG (: (Operation (List [Expression Expression])) -## (monad.map ! (function (_ [chars branch]) -## (do ! -## [branchG (phase archive branch)] -## (wrap [(|> chars (list\map (|>> .int _.int (_.=/2 @input))) _.or) -## branchG]))) -## conditionals))] -## (wrap (_.let (list [@input inputG]) -## (list (list\fold (function (_ [test then] else) -## (_.if test then else)) -## elseG -## conditionalsG))))))])) - -(def: lux_procs - Bundle - (|> /.empty - ## (/.install "syntax char case!" lux::syntax_char_case!) - (/.install "is" (binary _.eq/2)) - ## (/.install "try" (unary //runtime.lux//try)) - )) - -## (def: (capped operation parameter subject) -## (-> (-> Expression Expression Expression) -## (-> Expression Expression Expression)) -## (//runtime.i64//64 (operation parameter subject))) - -(def: i64_procs - Bundle - (<| (/.prefix "i64") - (|> /.empty - (/.install "and" (binary _.logand/2)) - (/.install "or" (binary _.logior/2)) - (/.install "xor" (binary _.logxor/2)) - (/.install "left-shift" (binary _.ash/2)) - (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) - (/.install "=" (binary _.=/2)) - (/.install "<" (binary _.</2)) - (/.install "+" (binary _.+/2)) - (/.install "-" (binary _.-/2)) - (/.install "*" (binary _.*/2)) - (/.install "/" (binary _.floor/2)) - (/.install "%" (binary _.rem/2)) - ## (/.install "f64" (unary (_.//2 (_.float +1.0)))) - (/.install "char" (unary (|>> _.code-char/1 _.string/1))) - ))) - -(def: f64_procs - Bundle - (<| (/.prefix "f64") - (|> /.empty - ## (/.install "=" (binary (product.uncurry _.=/2))) - ## (/.install "<" (binary (product.uncurry _.</2))) - ## (/.install "+" (binary (product.uncurry _.+/2))) - ## (/.install "-" (binary (product.uncurry _.-/2))) - ## (/.install "*" (binary (product.uncurry _.*/2))) - ## (/.install "/" (binary (product.uncurry _.//2))) - ## (/.install "%" (binary (product.uncurry _.rem/2))) - ## (/.install "i64" (unary _.truncate/1)) - (/.install "encode" (unary _.write-to-string/1)) - ## (/.install "decode" (unary //runtime.f64//decode)) - ))) - -(def: (text//index [offset sub text]) - (Trinary (Expression Any)) - (//runtime.text//index offset sub text)) - -(def: (text//clip [offset length text]) - (Trinary (Expression Any)) - (//runtime.text//clip offset length text)) - -(def: (text//char [index text]) - (Binary (Expression Any)) - (_.char-code/1 (_.char/2 [text index]))) - -(def: text_procs - Bundle - (<| (/.prefix "text") - (|> /.empty - (/.install "=" (binary _.string=/2)) - ## (/.install "<" (binary (product.uncurry _.string<?/2))) - (/.install "concat" (binary (function (_ [left right]) - (_.concatenate/3 [(_.symbol "string") left right])))) - (/.install "index" (trinary ..text//index)) - (/.install "size" (unary _.length/1)) - (/.install "char" (binary ..text//char)) - (/.install "clip" (trinary ..text//clip)) - ))) - -(def: (io//log! message) - (Unary (Expression Any)) - (_.progn (list (_.write-line/1 message) - //runtime.unit))) - -(def: io_procs - Bundle - (<| (/.prefix "io") - (|> /.empty - (/.install "log" (unary ..io//log!)) - (/.install "error" (unary _.error/1)) - ))) - -(def: #export bundle - Bundle - (<| (/.prefix "lux") - (|> /.empty - (dictionary.merge lux_procs) - (dictionary.merge i64_procs) - (dictionary.merge f64_procs) - (dictionary.merge text_procs) - (dictionary.merge io_procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux deleted file mode 100644 index f6d164404..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux +++ /dev/null @@ -1,39 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - [collection - ["." dictionary] - ["." list]] - [text - ["%" format (#+ format)]]] - [target - ["_" common_lisp (#+ Var Expression)]]] - ["." // #_ - ["#." common (#+ custom)] - ["//#" /// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["." reference] - ["//" common_lisp #_ - ["#." runtime (#+ Operation Phase Handler Bundle - with_vars)]]] - ["/#" // #_ - ["." generation] - ["//#" /// #_ - ["#." phase]]]]]]) - -(def: #export bundle - Bundle - (<| (/.prefix "common_lisp") - (|> /.empty - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js.lux deleted file mode 100644 index 81d2fe57b..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - ["." / #_ - ["#." common] - ["#." host] - [//// - [generation - [js - [runtime (#+ Bundle)]]]]]) - -(def: #export bundle - Bundle - (dictionary.merge /common.bundle - /host.bundle)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux deleted file mode 100644 index deffe31d8..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux +++ /dev/null @@ -1,190 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." try] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - ["." product] - [collection - ["." list ("#\." functor)] - ["." dictionary]]] - [math - [number - ["f" frac]]] - ["@" target - ["_" js (#+ Literal Expression Statement)]]] - ["." //// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["//" js #_ - ["#." runtime (#+ Operation Phase Handler Bundle Generator)] - ["#." primitive]]] - [// - [synthesis (#+ %synthesis)] - [/// - ["#" phase]]]]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text (Generator s))] - Handler)) - (function (_ extension_name phase archive input) - (case (<s>.run parser input) - (#try.Success input') - (handler extension_name phase archive input') - - (#try.Failure error) - (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) - -## [Procedures] -## [[Bits]] -(template [<name> <op>] - [(def: (<name> [paramG subjectG]) - (Binary Expression) - (<op> subjectG (//runtime.i64//to_number paramG)))] - - [i64//left_shift //runtime.i64//left_shift] - [i64//right_shift //runtime.i64//right_shift] - ) - -## [[Numbers]] -(def: f64//decode - (Unary Expression) - (|>> list - (_.apply/* (_.var "parseFloat")) - _.return - (_.closure (list)) - //runtime.lux//try)) - -(def: i64//char - (Unary Expression) - (|>> //runtime.i64//to_number - (list) - (_.apply/* (_.var "String.fromCharCode")))) - -## [[Text]] -(def: (text//concat [leftG rightG]) - (Binary Expression) - (|> leftG (_.do "concat" (list rightG)))) - -(def: (text//clip [startG endG subjectG]) - (Trinary Expression) - (//runtime.text//clip startG endG subjectG)) - -(def: (text//index [startG partG subjectG]) - (Trinary Expression) - (//runtime.text//index startG partG subjectG)) - -## [[IO]] -(def: (io//log messageG) - (Unary Expression) - ($_ _., - (//runtime.io//log messageG) - //runtime.unit)) - -## TODO: Get rid of this ASAP -(def: lux::syntax_char_case! - (..custom [($_ <>.and - <s>.any - <s>.any - (<>.some (<s>.tuple ($_ <>.and - (<s>.tuple (<>.many <s>.i64)) - <s>.any)))) - (function (_ extension_name phase archive [input else conditionals]) - (do {! /////.monad} - [inputG (phase archive input) - elseG (phase archive else) - conditionalsG (: (Operation (List [(List Literal) - Statement])) - (monad.map ! (function (_ [chars branch]) - (do ! - [branchG (phase archive branch)] - (wrap [(list\map (|>> .int _.int) chars) - (_.return branchG)]))) - conditionals))] - (wrap (_.apply/* (_.closure (list) - (_.switch (_.the //runtime.i64_low_field inputG) - conditionalsG - (#.Some (_.return elseG)))) - (list)))))])) - -## [Bundles] -(def: lux_procs - Bundle - (|> /.empty - (/.install "syntax char case!" lux::syntax_char_case!) - (/.install "is" (binary (product.uncurry _.=))) - (/.install "try" (unary //runtime.lux//try)))) - -(def: i64_procs - Bundle - (<| (/.prefix "i64") - (|> /.empty - (/.install "and" (binary (product.uncurry //runtime.i64//and))) - (/.install "or" (binary (product.uncurry //runtime.i64//or))) - (/.install "xor" (binary (product.uncurry //runtime.i64//xor))) - (/.install "left-shift" (binary i64//left_shift)) - (/.install "right-shift" (binary i64//right_shift)) - (/.install "=" (binary (product.uncurry //runtime.i64//=))) - (/.install "<" (binary (product.uncurry //runtime.i64//<))) - (/.install "+" (binary (product.uncurry //runtime.i64//+))) - (/.install "-" (binary (product.uncurry //runtime.i64//-))) - (/.install "*" (binary (product.uncurry //runtime.i64//*))) - (/.install "/" (binary (product.uncurry //runtime.i64///))) - (/.install "%" (binary (product.uncurry //runtime.i64//%))) - (/.install "f64" (unary //runtime.i64//to_number)) - (/.install "char" (unary i64//char)) - ))) - -(def: f64_procs - Bundle - (<| (/.prefix "f64") - (|> /.empty - (/.install "+" (binary (product.uncurry _.+))) - (/.install "-" (binary (product.uncurry _.-))) - (/.install "*" (binary (product.uncurry _.*))) - (/.install "/" (binary (product.uncurry _./))) - (/.install "%" (binary (product.uncurry _.%))) - (/.install "=" (binary (product.uncurry _.=))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "i64" (unary //runtime.i64//from_number)) - (/.install "encode" (unary (_.do "toString" (list)))) - (/.install "decode" (unary f64//decode))))) - -(def: text_procs - Bundle - (<| (/.prefix "text") - (|> /.empty - (/.install "=" (binary (product.uncurry _.=))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "concat" (binary text//concat)) - (/.install "index" (trinary text//index)) - (/.install "size" (unary (|>> (_.the "length") //runtime.i64//from_number))) - (/.install "char" (binary (product.uncurry //runtime.text//char))) - (/.install "clip" (trinary text//clip)) - ))) - -(def: io_procs - Bundle - (<| (/.prefix "io") - (|> /.empty - (/.install "log" (unary io//log)) - (/.install "error" (unary //runtime.io//error))))) - -(def: #export bundle - Bundle - (<| (/.prefix "lux") - (|> lux_procs - (dictionary.merge i64_procs) - (dictionary.merge f64_procs) - (dictionary.merge text_procs) - (dictionary.merge io_procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux deleted file mode 100644 index 45fb3e5d2..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux +++ /dev/null @@ -1,159 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - [collection - ["." dictionary] - ["." list]]] - [target - ["_" js (#+ Var Expression)]]] - ["." // #_ - ["#." common (#+ custom)] - ["//#" /// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["//" js #_ - ["#." runtime (#+ Operation Phase Handler Bundle - with_vars)]]] - ["/#" // #_ - ["." generation] - ["//#" /// #_ - ["#." phase]]]]]]) - -(def: array::new - (Unary Expression) - (|>> (_.the //runtime.i64_low_field) list (_.new (_.var "Array")))) - -(def: array::length - (Unary Expression) - (|>> (_.the "length") //runtime.i64//from_number)) - -(def: (array::read [indexG arrayG]) - (Binary Expression) - (_.at (_.the //runtime.i64_low_field indexG) - arrayG)) - -(def: (array::write [indexG valueG arrayG]) - (Trinary Expression) - (//runtime.array//write indexG valueG arrayG)) - -(def: (array::delete [indexG arrayG]) - (Binary Expression) - (//runtime.array//delete indexG arrayG)) - -(def: array - Bundle - (<| (/.prefix "array") - (|> /.empty - (/.install "new" (unary array::new)) - (/.install "length" (unary array::length)) - (/.install "read" (binary array::read)) - (/.install "write" (trinary array::write)) - (/.install "delete" (binary array::delete)) - ))) - -(def: object::new - (custom - [($_ <>.and <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [constructorS inputsS]) - (do {! ////////phase.monad} - [constructorG (phase archive constructorS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.new constructorG inputsG))))])) - -(def: object::get - Handler - (custom - [($_ <>.and <s>.text <s>.any) - (function (_ extension phase archive [fieldS objectS]) - (do ////////phase.monad - [objectG (phase archive objectS)] - (wrap (_.the fieldS objectG))))])) - -(def: object::do - Handler - (custom - [($_ <>.and <s>.text <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [methodS objectS inputsS]) - (do {! ////////phase.monad} - [objectG (phase archive objectS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.do methodS inputsG objectG))))])) - -(template [<!> <?> <unit>] - [(def: <!> (Nullary Expression) (function.constant <unit>)) - (def: <?> (Unary Expression) (_.= <unit>))] - - [object::null object::null? _.null] - [object::undefined object::undefined? _.undefined] - ) - -(def: object - Bundle - (<| (/.prefix "object") - (|> /.empty - (/.install "new" object::new) - (/.install "get" object::get) - (/.install "do" object::do) - (/.install "null" (nullary object::null)) - (/.install "null?" (unary object::null?)) - (/.install "undefined" (nullary object::undefined)) - (/.install "undefined?" (unary object::undefined?)) - ))) - -(def: js::constant - (custom - [<s>.text - (function (_ extension phase archive name) - (\ ////////phase.monad wrap (_.var name)))])) - -(def: js::apply - (custom - [($_ <>.and <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [abstractionS inputsS]) - (do {! ////////phase.monad} - [abstractionG (phase archive abstractionS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.apply/* abstractionG inputsG))))])) - -(def: js::function - (custom - [($_ <>.and <s>.i64 <s>.any) - (function (_ extension phase archive [arity abstractionS]) - (do {! ////////phase.monad} - [abstractionG (phase archive abstractionS) - #let [variable (: (-> Text (Operation Var)) - (|>> generation.gensym - (\ ! map _.var)))] - g!inputs (monad.map ! (function (_ _) (variable "input")) - (list.repeat (.nat arity) [])) - g!abstraction (variable "abstraction")] - (wrap (_.closure g!inputs - ($_ _.then - (_.define g!abstraction abstractionG) - (_.return (case (.nat arity) - 0 (_.apply/1 g!abstraction //runtime.unit) - 1 (_.apply/* g!abstraction g!inputs) - _ (_.apply/1 g!abstraction (_.array g!inputs)))))))))])) - -(def: #export bundle - Bundle - (<| (/.prefix "js") - (|> /.empty - (dictionary.merge ..array) - (dictionary.merge ..object) - - (/.install "constant" js::constant) - (/.install "apply" js::apply) - (/.install "type-of" (unary _.type_of)) - (/.install "function" js::function) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm.lux deleted file mode 100644 index 93816d128..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm.lux +++ /dev/null @@ -1,19 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - ["." / #_ - ["#." common] - ["#." host] - [//// - [generation - [jvm - [runtime (#+ Bundle)]]]]]) - -(def: #export bundle - Bundle - ($_ dictionary.merge - /common.bundle - /host.bundle - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux deleted file mode 100644 index 24f82d1ef..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux +++ /dev/null @@ -1,413 +0,0 @@ -(.module: - [lux (#- Type) - [abstract - ["." monad (#+ do)]] - [control - ["." try] - ["." exception (#+ exception:)] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - ["." product] - [number - ["." i32] - ["f" frac]] - [collection - ["." list ("#\." monad)] - ["." dictionary]]] - [target - [jvm - ["_" bytecode (#+ Label Bytecode) ("#\." monad)] - [encoding - ["." signed (#+ S4)]] - ["." type (#+ Type) - [category (#+ Primitive Class)]]]]] - ["." ///// #_ - [generation - [extension (#+ Nullary Unary Binary Trinary Variadic - nullary unary binary trinary variadic)] - ["///" jvm #_ - ["#." value] - ["#." runtime (#+ Operation Phase Bundle Handler)] - ["#." function #_ - ["#" abstract]]]] - [extension - ["#extension" /] - ["#." bundle]] - [// - ["/#." synthesis (#+ Synthesis %synthesis)] - [/// - ["#" phase] - [meta - [archive (#+ Archive)]]]]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text Phase Archive s (Operation (Bytecode Any)))] - Handler)) - (function (_ extension-name phase archive input) - (case (<s>.run parser input) - (#try.Success input') - (handler extension-name phase archive input') - - (#try.Failure error) - (/////.throw /////extension.invalid-syntax [extension-name //////synthesis.%synthesis input])))) - -(def: $Boolean (type.class "java.lang.Boolean" (list))) -(def: $Double (type.class "java.lang.Double" (list))) -(def: $Character (type.class "java.lang.Character" (list))) -(def: $String (type.class "java.lang.String" (list))) -(def: $CharSequence (type.class "java.lang.CharSequence" (list))) -(def: $Object (type.class "java.lang.Object" (list))) -(def: $PrintStream (type.class "java.io.PrintStream" (list))) -(def: $System (type.class "java.lang.System" (list))) -(def: $Error (type.class "java.lang.Error" (list))) - -(def: lux-int - (Bytecode Any) - ($_ _.compose - _.i2l - (///value.wrap type.long))) - -(def: jvm-int - (Bytecode Any) - ($_ _.compose - (///value.unwrap type.long) - _.l2i)) - -(def: ensure-string - (Bytecode Any) - (_.checkcast $String)) - -(def: (predicate bytecode) - (-> (-> Label (Bytecode Any)) - (Bytecode Any)) - (do _.monad - [@then _.new-label - @end _.new-label] - ($_ _.compose - (bytecode @then) - (_.getstatic $Boolean "FALSE" $Boolean) - (_.goto @end) - (_.set-label @then) - (_.getstatic $Boolean "TRUE" $Boolean) - (_.set-label @end) - ))) - -## TODO: Get rid of this ASAP -(def: lux::syntax-char-case! - (..custom [($_ <>.and - <s>.any - <s>.any - (<>.some (<s>.tuple ($_ <>.and - (<s>.tuple (<>.many <s>.i64)) - <s>.any)))) - (function (_ extension-name phase archive [inputS elseS conditionalsS]) - (do {! /////.monad} - [@end ///runtime.forge-label - inputG (phase archive inputS) - elseG (phase archive elseS) - conditionalsG+ (: (Operation (List [(List [S4 Label]) - (Bytecode Any)])) - (monad.map ! (function (_ [chars branch]) - (do ! - [branchG (phase archive branch) - @branch ///runtime.forge-label] - (wrap [(list\map (function (_ char) - [(try.assume (signed.s4 (.int char))) @branch]) - chars) - ($_ _.compose - (_.set-label @branch) - branchG - (_.goto @end))]))) - conditionalsS)) - #let [table (|> conditionalsG+ - (list\map product.left) - list\join) - conditionalsG (|> conditionalsG+ - (list\map product.right) - (monad.seq _.monad))]] - (wrap (do _.monad - [@else _.new-label] - ($_ _.compose - inputG (///value.unwrap type.long) _.l2i - (_.lookupswitch @else table) - conditionalsG - (_.set-label @else) - elseG - (_.set-label @end) - )))))])) - -(def: (lux::is [referenceG sampleG]) - (Binary (Bytecode Any)) - ($_ _.compose - referenceG - sampleG - (..predicate _.if-acmpeq))) - -(def: (lux::try riskyG) - (Unary (Bytecode Any)) - ($_ _.compose - riskyG - (_.checkcast ///function.class) - ///runtime.try)) - -(def: bundle::lux - Bundle - (|> (: Bundle /////bundle.empty) - (/////bundle.install "syntax char case!" ..lux::syntax-char-case!) - (/////bundle.install "is" (binary ..lux::is)) - (/////bundle.install "try" (unary ..lux::try)))) - -(template [<name> <op>] - [(def: (<name> [maskG inputG]) - (Binary (Bytecode Any)) - ($_ _.compose - inputG (///value.unwrap type.long) - maskG (///value.unwrap type.long) - <op> (///value.wrap type.long)))] - - [i64::and _.land] - [i64::or _.lor] - [i64::xor _.lxor] - ) - -(template [<name> <op>] - [(def: (<name> [shiftG inputG]) - (Binary (Bytecode Any)) - ($_ _.compose - inputG (///value.unwrap type.long) - shiftG ..jvm-int - <op> (///value.wrap type.long)))] - - [i64::left-shift _.lshl] - [i64::right-shift _.lushr] - ) - -(template [<name> <type> <op>] - [(def: (<name> [paramG subjectG]) - (Binary (Bytecode Any)) - ($_ _.compose - subjectG (///value.unwrap <type>) - paramG (///value.unwrap <type>) - <op> (///value.wrap <type>)))] - - [i64::+ type.long _.ladd] - [i64::- type.long _.lsub] - [i64::* type.long _.lmul] - [i64::/ type.long _.ldiv] - [i64::% type.long _.lrem] - - [f64::+ type.double _.dadd] - [f64::- type.double _.dsub] - [f64::* type.double _.dmul] - [f64::/ type.double _.ddiv] - [f64::% type.double _.drem] - ) - -(template [<eq> <lt> <type> <cmp>] - [(template [<name> <reference>] - [(def: (<name> [paramG subjectG]) - (Binary (Bytecode Any)) - ($_ _.compose - subjectG (///value.unwrap <type>) - paramG (///value.unwrap <type>) - <cmp> - <reference> - (..predicate _.if-icmpeq)))] - - [<eq> _.iconst-0] - [<lt> _.iconst-m1])] - - [i64::= i64::< type.long _.lcmp] - [f64::= f64::< type.double _.dcmpg] - ) - -(def: (to-string class from) - (-> (Type Class) (Type Primitive) (Bytecode Any)) - (_.invokestatic class "toString" (type.method [(list from) ..$String (list)]))) - -(template [<name> <prepare> <transform>] - [(def: (<name> inputG) - (Unary (Bytecode Any)) - ($_ _.compose - inputG - <prepare> - <transform>))] - - [i64::f64 - (///value.unwrap type.long) - ($_ _.compose - _.l2d - (///value.wrap type.double))] - - [i64::char - (///value.unwrap type.long) - ($_ _.compose - _.l2i - _.i2c - (..to-string ..$Character type.char))] - - [f64::i64 - (///value.unwrap type.double) - ($_ _.compose - _.d2l - (///value.wrap type.long))] - - [f64::encode - (///value.unwrap type.double) - (..to-string ..$Double type.double)] - - [f64::decode - ..ensure-string - ///runtime.decode-frac] - ) - -(def: bundle::i64 - Bundle - (<| (/////bundle.prefix "i64") - (|> (: Bundle /////bundle.empty) - (/////bundle.install "and" (binary ..i64::and)) - (/////bundle.install "or" (binary ..i64::or)) - (/////bundle.install "xor" (binary ..i64::xor)) - (/////bundle.install "left-shift" (binary ..i64::left-shift)) - (/////bundle.install "right-shift" (binary ..i64::right-shift)) - (/////bundle.install "=" (binary ..i64::=)) - (/////bundle.install "<" (binary ..i64::<)) - (/////bundle.install "+" (binary ..i64::+)) - (/////bundle.install "-" (binary ..i64::-)) - (/////bundle.install "*" (binary ..i64::*)) - (/////bundle.install "/" (binary ..i64::/)) - (/////bundle.install "%" (binary ..i64::%)) - (/////bundle.install "f64" (unary ..i64::f64)) - (/////bundle.install "char" (unary ..i64::char))))) - -(def: bundle::f64 - Bundle - (<| (/////bundle.prefix "f64") - (|> (: Bundle /////bundle.empty) - (/////bundle.install "+" (binary ..f64::+)) - (/////bundle.install "-" (binary ..f64::-)) - (/////bundle.install "*" (binary ..f64::*)) - (/////bundle.install "/" (binary ..f64::/)) - (/////bundle.install "%" (binary ..f64::%)) - (/////bundle.install "=" (binary ..f64::=)) - (/////bundle.install "<" (binary ..f64::<)) - (/////bundle.install "i64" (unary ..f64::i64)) - (/////bundle.install "encode" (unary ..f64::encode)) - (/////bundle.install "decode" (unary ..f64::decode))))) - -(def: (text::size inputG) - (Unary (Bytecode Any)) - ($_ _.compose - inputG - ..ensure-string - (_.invokevirtual ..$String "length" (type.method [(list) type.int (list)])) - ..lux-int)) - -(def: no-op (Bytecode Any) (_\wrap [])) - -(template [<name> <pre-subject> <pre-param> <op> <post>] - [(def: (<name> [paramG subjectG]) - (Binary (Bytecode Any)) - ($_ _.compose - subjectG <pre-subject> - paramG <pre-param> - <op> <post>))] - - [text::= ..no-op ..no-op - (_.invokevirtual ..$Object "equals" (type.method [(list ..$Object) type.boolean (list)])) - (///value.wrap type.boolean)] - [text::< ..ensure-string ..ensure-string - (_.invokevirtual ..$String "compareTo" (type.method [(list ..$String) type.int (list)])) - (..predicate _.iflt)] - [text::char ..ensure-string ..jvm-int - (_.invokevirtual ..$String "charAt" (type.method [(list type.int) type.char (list)])) - ..lux-int] - ) - -(def: (text::concat [leftG rightG]) - (Binary (Bytecode Any)) - ($_ _.compose - leftG ..ensure-string - rightG ..ensure-string - (_.invokevirtual ..$String "concat" (type.method [(list ..$String) ..$String (list)])))) - -(def: (text::clip [startG endG subjectG]) - (Trinary (Bytecode Any)) - ($_ _.compose - subjectG ..ensure-string - startG ..jvm-int - endG ..jvm-int - (_.invokevirtual ..$String "substring" (type.method [(list type.int type.int) ..$String (list)])))) - -(def: index-method (type.method [(list ..$String type.int) type.int (list)])) -(def: (text::index [startG partG textG]) - (Trinary (Bytecode Any)) - (do _.monad - [@not-found _.new-label - @end _.new-label] - ($_ _.compose - textG ..ensure-string - partG ..ensure-string - startG ..jvm-int - (_.invokevirtual ..$String "indexOf" index-method) - _.dup - _.iconst-m1 - (_.if-icmpeq @not-found) - ..lux-int - ///runtime.some-injection - (_.goto @end) - (_.set-label @not-found) - _.pop - ///runtime.none-injection - (_.set-label @end)))) - -(def: bundle::text - Bundle - (<| (/////bundle.prefix "text") - (|> (: Bundle /////bundle.empty) - (/////bundle.install "=" (binary ..text::=)) - (/////bundle.install "<" (binary ..text::<)) - (/////bundle.install "concat" (binary ..text::concat)) - (/////bundle.install "index" (trinary ..text::index)) - (/////bundle.install "size" (unary ..text::size)) - (/////bundle.install "char" (binary ..text::char)) - (/////bundle.install "clip" (trinary ..text::clip))))) - -(def: string-method (type.method [(list ..$String) type.void (list)])) -(def: (io::log messageG) - (Unary (Bytecode Any)) - ($_ _.compose - (_.getstatic ..$System "out" ..$PrintStream) - messageG - ..ensure-string - (_.invokevirtual ..$PrintStream "println" ..string-method) - ///runtime.unit)) - -(def: (io::error messageG) - (Unary (Bytecode Any)) - ($_ _.compose - (_.new ..$Error) - _.dup - messageG - ..ensure-string - (_.invokespecial ..$Error "<init>" ..string-method) - _.athrow)) - -(def: bundle::io - Bundle - (<| (/////bundle.prefix "io") - (|> (: Bundle /////bundle.empty) - (/////bundle.install "log" (unary ..io::log)) - (/////bundle.install "error" (unary ..io::error))))) - -(def: #export bundle - Bundle - (<| (/////bundle.prefix "lux") - (|> bundle::lux - (dictionary.merge ..bundle::i64) - (dictionary.merge ..bundle::f64) - (dictionary.merge ..bundle::text) - (dictionary.merge ..bundle::io)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux deleted file mode 100644 index 03ec04853..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux +++ /dev/null @@ -1,1105 +0,0 @@ -(.module: - [lux (#- Type) - [abstract - ["." monad (#+ do)]] - [control - ["." try] - ["." exception (#+ exception:)] - ["<>" parser - ["<t>" text] - ["<s>" synthesis (#+ Parser)]]] - [data - ["." product] - ["." maybe] - ["." text ("#\." equivalence) - ["%" format (#+ format)]] - [number - ["." i32]] - [collection - ["." list ("#\." monad)] - ["." dictionary (#+ Dictionary)] - ["." set] - ["." row]] - ["." format #_ - ["#" binary]]] - [target - [jvm - ["." version] - ["." modifier ("#\." monoid)] - ["." method (#+ Method)] - ["." class (#+ Class)] - [constant - [pool (#+ Resource)]] - [encoding - ["." name]] - ["_" bytecode (#+ Label Bytecode) ("#\." monad) - ["__" instruction (#+ Primitive-Array-Type)]] - ["." type (#+ Type Typed Argument) - ["." category (#+ Void Value' Value Return' Return Primitive Object Array Var Parameter)] - ["." box] - ["." reflection] - ["." signature] - ["." parser]]]]] - ["." // #_ - [common (#+ custom)] - ["///#" //// #_ - [generation - [extension (#+ Nullary Unary Binary Trinary Variadic - nullary unary binary trinary variadic)] - ["///" jvm - ["#." runtime (#+ Operation Bundle Phase Handler)] - ["#." reference] - [function - [field - [variable - ["." foreign]]]]]] - [extension - ["#." bundle] - [analysis - ["/" jvm]]] - ["/#" // #_ - [analysis (#+ Environment)] - ["#." synthesis (#+ Synthesis Path %synthesis)] - ["#." generation] - [/// - ["#" phase] - [reference - ["#." variable (#+ Variable)]] - [meta - ["." archive (#+ Archive)]]]]]]) - -(template [<name> <0> <1>] - [(def: <name> - (Bytecode Any) - ($_ _.compose - <0> - <1>))] - - [l2s _.l2i _.i2s] - [l2b _.l2i _.i2b] - [l2c _.l2i _.i2c] - ) - -(template [<conversion> <name>] - [(def: (<name> inputG) - (Unary (Bytecode Any)) - (if (is? _.nop <conversion>) - inputG - ($_ _.compose - inputG - <conversion>)))] - - [_.d2f conversion::double-to-float] - [_.d2i conversion::double-to-int] - [_.d2l conversion::double-to-long] - [_.f2d conversion::float-to-double] - [_.f2i conversion::float-to-int] - [_.f2l conversion::float-to-long] - [_.i2b conversion::int-to-byte] - [_.i2c conversion::int-to-char] - [_.i2d conversion::int-to-double] - [_.i2f conversion::int-to-float] - [_.i2l conversion::int-to-long] - [_.i2s conversion::int-to-short] - [_.l2d conversion::long-to-double] - [_.l2f conversion::long-to-float] - [_.l2i conversion::long-to-int] - [..l2s conversion::long-to-short] - [..l2b conversion::long-to-byte] - [..l2c conversion::long-to-char] - [_.i2b conversion::char-to-byte] - [_.i2s conversion::char-to-short] - [_.nop conversion::char-to-int] - [_.i2l conversion::char-to-long] - [_.i2l conversion::byte-to-long] - [_.i2l conversion::short-to-long] - ) - -(def: bundle::conversion - Bundle - (<| (/////bundle.prefix "conversion") - (|> (: Bundle /////bundle.empty) - (/////bundle.install "double-to-float" (unary conversion::double-to-float)) - (/////bundle.install "double-to-int" (unary conversion::double-to-int)) - (/////bundle.install "double-to-long" (unary conversion::double-to-long)) - (/////bundle.install "float-to-double" (unary conversion::float-to-double)) - (/////bundle.install "float-to-int" (unary conversion::float-to-int)) - (/////bundle.install "float-to-long" (unary conversion::float-to-long)) - (/////bundle.install "int-to-byte" (unary conversion::int-to-byte)) - (/////bundle.install "int-to-char" (unary conversion::int-to-char)) - (/////bundle.install "int-to-double" (unary conversion::int-to-double)) - (/////bundle.install "int-to-float" (unary conversion::int-to-float)) - (/////bundle.install "int-to-long" (unary conversion::int-to-long)) - (/////bundle.install "int-to-short" (unary conversion::int-to-short)) - (/////bundle.install "long-to-double" (unary conversion::long-to-double)) - (/////bundle.install "long-to-float" (unary conversion::long-to-float)) - (/////bundle.install "long-to-int" (unary conversion::long-to-int)) - (/////bundle.install "long-to-short" (unary conversion::long-to-short)) - (/////bundle.install "long-to-byte" (unary conversion::long-to-byte)) - (/////bundle.install "long-to-char" (unary conversion::long-to-char)) - (/////bundle.install "char-to-byte" (unary conversion::char-to-byte)) - (/////bundle.install "char-to-short" (unary conversion::char-to-short)) - (/////bundle.install "char-to-int" (unary conversion::char-to-int)) - (/////bundle.install "char-to-long" (unary conversion::char-to-long)) - (/////bundle.install "byte-to-long" (unary conversion::byte-to-long)) - (/////bundle.install "short-to-long" (unary conversion::short-to-long)) - ))) - -(template [<name> <op>] - [(def: (<name> [xG yG]) - (Binary (Bytecode Any)) - ($_ _.compose - xG - yG - <op>))] - - [int::+ _.iadd] - [int::- _.isub] - [int::* _.imul] - [int::/ _.idiv] - [int::% _.irem] - [int::and _.iand] - [int::or _.ior] - [int::xor _.ixor] - [int::shl _.ishl] - [int::shr _.ishr] - [int::ushr _.iushr] - - [long::+ _.ladd] - [long::- _.lsub] - [long::* _.lmul] - [long::/ _.ldiv] - [long::% _.lrem] - [long::and _.land] - [long::or _.lor] - [long::xor _.lxor] - [long::shl _.lshl] - [long::shr _.lshr] - [long::ushr _.lushr] - - [float::+ _.fadd] - [float::- _.fsub] - [float::* _.fmul] - [float::/ _.fdiv] - [float::% _.frem] - - [double::+ _.dadd] - [double::- _.dsub] - [double::* _.dmul] - [double::/ _.ddiv] - [double::% _.drem] - ) - -(def: $Boolean (type.class box.boolean (list))) -(def: falseG (_.getstatic ..$Boolean "FALSE" ..$Boolean)) -(def: trueG (_.getstatic ..$Boolean "TRUE" ..$Boolean)) - -(template [<name> <op>] - [(def: (<name> [xG yG]) - (Binary (Bytecode Any)) - (do _.monad - [@then _.new-label - @end _.new-label] - ($_ _.compose - xG - yG - (<op> @then) - falseG - (_.goto @end) - (_.set-label @then) - trueG - (_.set-label @end))))] - - [int::= _.if-icmpeq] - [int::< _.if-icmplt] - - [char::= _.if-icmpeq] - [char::< _.if-icmplt] - ) - -(template [<name> <op> <reference>] - [(def: (<name> [xG yG]) - (Binary (Bytecode Any)) - (do _.monad - [@then _.new-label - @end _.new-label] - ($_ _.compose - xG - yG - <op> - (_.int (i32.i32 (.i64 <reference>))) - (_.if-icmpeq @then) - falseG - (_.goto @end) - (_.set-label @then) - trueG - (_.set-label @end))))] - - [long::= _.lcmp +0] - [long::< _.lcmp -1] - - [float::= _.fcmpg +0] - [float::< _.fcmpg -1] - - [double::= _.dcmpg +0] - [double::< _.dcmpg -1] - ) - -(def: bundle::int - Bundle - (<| (/////bundle.prefix (reflection.reflection reflection.int)) - (|> (: Bundle /////bundle.empty) - (/////bundle.install "+" (binary int::+)) - (/////bundle.install "-" (binary int::-)) - (/////bundle.install "*" (binary int::*)) - (/////bundle.install "/" (binary int::/)) - (/////bundle.install "%" (binary int::%)) - (/////bundle.install "=" (binary int::=)) - (/////bundle.install "<" (binary int::<)) - (/////bundle.install "and" (binary int::and)) - (/////bundle.install "or" (binary int::or)) - (/////bundle.install "xor" (binary int::xor)) - (/////bundle.install "shl" (binary int::shl)) - (/////bundle.install "shr" (binary int::shr)) - (/////bundle.install "ushr" (binary int::ushr)) - ))) - -(def: bundle::long - Bundle - (<| (/////bundle.prefix (reflection.reflection reflection.long)) - (|> (: Bundle /////bundle.empty) - (/////bundle.install "+" (binary long::+)) - (/////bundle.install "-" (binary long::-)) - (/////bundle.install "*" (binary long::*)) - (/////bundle.install "/" (binary long::/)) - (/////bundle.install "%" (binary long::%)) - (/////bundle.install "=" (binary long::=)) - (/////bundle.install "<" (binary long::<)) - (/////bundle.install "and" (binary long::and)) - (/////bundle.install "or" (binary long::or)) - (/////bundle.install "xor" (binary long::xor)) - (/////bundle.install "shl" (binary long::shl)) - (/////bundle.install "shr" (binary long::shr)) - (/////bundle.install "ushr" (binary long::ushr)) - ))) - -(def: bundle::float - Bundle - (<| (/////bundle.prefix (reflection.reflection reflection.float)) - (|> (: Bundle /////bundle.empty) - (/////bundle.install "+" (binary float::+)) - (/////bundle.install "-" (binary float::-)) - (/////bundle.install "*" (binary float::*)) - (/////bundle.install "/" (binary float::/)) - (/////bundle.install "%" (binary float::%)) - (/////bundle.install "=" (binary float::=)) - (/////bundle.install "<" (binary float::<)) - ))) - -(def: bundle::double - Bundle - (<| (/////bundle.prefix (reflection.reflection reflection.double)) - (|> (: Bundle /////bundle.empty) - (/////bundle.install "+" (binary double::+)) - (/////bundle.install "-" (binary double::-)) - (/////bundle.install "*" (binary double::*)) - (/////bundle.install "/" (binary double::/)) - (/////bundle.install "%" (binary double::%)) - (/////bundle.install "=" (binary double::=)) - (/////bundle.install "<" (binary double::<)) - ))) - -(def: bundle::char - Bundle - (<| (/////bundle.prefix (reflection.reflection reflection.char)) - (|> (: Bundle /////bundle.empty) - (/////bundle.install "=" (binary char::=)) - (/////bundle.install "<" (binary char::<)) - ))) - -(template [<name> <category> <parser>] - [(def: #export <name> - (Parser (Type <category>)) - (<t>.embed <parser> <s>.text))] - - [var Var parser.var] - [class category.Class parser.class] - [object Object parser.object] - [value Value parser.value] - [return Return parser.return] - ) - -(exception: #export (not-an-object-array {arrayJT (Type Array)}) - (exception.report - ["JVM Type" (|> arrayJT type.signature signature.signature)])) - -(def: #export object-array - (Parser (Type Object)) - (do <>.monad - [arrayJT (<t>.embed parser.array <s>.text)] - (case (parser.array? arrayJT) - (#.Some elementJT) - (case (parser.object? elementJT) - (#.Some elementJT) - (wrap elementJT) - - #.None - (<>.fail (exception.construct ..not-an-object-array arrayJT))) - - #.None - (undefined)))) - -(def: (primitive-array-length-handler jvm-primitive) - (-> (Type Primitive) Handler) - (..custom - [<s>.any - (function (_ extension-name generate archive arrayS) - (do //////.monad - [arrayG (generate archive arrayS)] - (wrap ($_ _.compose - arrayG - (_.checkcast (type.array jvm-primitive)) - _.arraylength))))])) - -(def: array::length::object - Handler - (..custom - [($_ <>.and ..object-array <s>.any) - (function (_ extension-name generate archive [elementJT arrayS]) - (do //////.monad - [arrayG (generate archive arrayS)] - (wrap ($_ _.compose - arrayG - (_.checkcast (type.array elementJT)) - _.arraylength))))])) - -(def: (new-primitive-array-handler jvm-primitive) - (-> Primitive-Array-Type Handler) - (..custom - [<s>.any - (function (_ extension-name generate archive [lengthS]) - (do //////.monad - [lengthG (generate archive lengthS)] - (wrap ($_ _.compose - lengthG - (_.newarray jvm-primitive)))))])) - -(def: array::new::object - Handler - (..custom - [($_ <>.and ..object <s>.any) - (function (_ extension-name generate archive [objectJT lengthS]) - (do //////.monad - [lengthG (generate archive lengthS)] - (wrap ($_ _.compose - lengthG - (_.anewarray objectJT)))))])) - -(def: (read-primitive-array-handler jvm-primitive loadG) - (-> (Type Primitive) (Bytecode Any) Handler) - (..custom - [($_ <>.and <s>.any <s>.any) - (function (_ extension-name generate archive [idxS arrayS]) - (do //////.monad - [arrayG (generate archive arrayS) - idxG (generate archive idxS)] - (wrap ($_ _.compose - arrayG - (_.checkcast (type.array jvm-primitive)) - idxG - loadG))))])) - -(def: array::read::object - Handler - (..custom - [($_ <>.and ..object-array <s>.any <s>.any) - (function (_ extension-name generate archive [elementJT idxS arrayS]) - (do //////.monad - [arrayG (generate archive arrayS) - idxG (generate archive idxS)] - (wrap ($_ _.compose - arrayG - (_.checkcast (type.array elementJT)) - idxG - _.aaload))))])) - -(def: (write-primitive-array-handler jvm-primitive storeG) - (-> (Type Primitive) (Bytecode Any) Handler) - (..custom - [($_ <>.and <s>.any <s>.any <s>.any) - (function (_ extension-name generate archive [idxS valueS arrayS]) - (do //////.monad - [arrayG (generate archive arrayS) - idxG (generate archive idxS) - valueG (generate archive valueS)] - (wrap ($_ _.compose - arrayG - (_.checkcast (type.array jvm-primitive)) - _.dup - idxG - valueG - storeG))))])) - -(def: array::write::object - Handler - (..custom - [($_ <>.and ..object-array <s>.any <s>.any <s>.any) - (function (_ extension-name generate archive [elementJT idxS valueS arrayS]) - (do //////.monad - [arrayG (generate archive arrayS) - idxG (generate archive idxS) - valueG (generate archive valueS)] - (wrap ($_ _.compose - arrayG - (_.checkcast (type.array elementJT)) - _.dup - idxG - valueG - _.aastore))))])) - -(def: bundle::array - Bundle - (<| (/////bundle.prefix "array") - (|> /////bundle.empty - (dictionary.merge (<| (/////bundle.prefix "length") - (|> /////bundle.empty - (/////bundle.install (reflection.reflection reflection.boolean) (primitive-array-length-handler type.boolean)) - (/////bundle.install (reflection.reflection reflection.byte) (primitive-array-length-handler type.byte)) - (/////bundle.install (reflection.reflection reflection.short) (primitive-array-length-handler type.short)) - (/////bundle.install (reflection.reflection reflection.int) (primitive-array-length-handler type.int)) - (/////bundle.install (reflection.reflection reflection.long) (primitive-array-length-handler type.long)) - (/////bundle.install (reflection.reflection reflection.float) (primitive-array-length-handler type.float)) - (/////bundle.install (reflection.reflection reflection.double) (primitive-array-length-handler type.double)) - (/////bundle.install (reflection.reflection reflection.char) (primitive-array-length-handler type.char)) - (/////bundle.install "object" array::length::object)))) - (dictionary.merge (<| (/////bundle.prefix "new") - (|> /////bundle.empty - (/////bundle.install (reflection.reflection reflection.boolean) (new-primitive-array-handler __.t-boolean)) - (/////bundle.install (reflection.reflection reflection.byte) (new-primitive-array-handler __.t-byte)) - (/////bundle.install (reflection.reflection reflection.short) (new-primitive-array-handler __.t-short)) - (/////bundle.install (reflection.reflection reflection.int) (new-primitive-array-handler __.t-int)) - (/////bundle.install (reflection.reflection reflection.long) (new-primitive-array-handler __.t-long)) - (/////bundle.install (reflection.reflection reflection.float) (new-primitive-array-handler __.t-float)) - (/////bundle.install (reflection.reflection reflection.double) (new-primitive-array-handler __.t-double)) - (/////bundle.install (reflection.reflection reflection.char) (new-primitive-array-handler __.t-char)) - (/////bundle.install "object" array::new::object)))) - (dictionary.merge (<| (/////bundle.prefix "read") - (|> /////bundle.empty - (/////bundle.install (reflection.reflection reflection.boolean) (read-primitive-array-handler type.boolean _.baload)) - (/////bundle.install (reflection.reflection reflection.byte) (read-primitive-array-handler type.byte _.baload)) - (/////bundle.install (reflection.reflection reflection.short) (read-primitive-array-handler type.short _.saload)) - (/////bundle.install (reflection.reflection reflection.int) (read-primitive-array-handler type.int _.iaload)) - (/////bundle.install (reflection.reflection reflection.long) (read-primitive-array-handler type.long _.laload)) - (/////bundle.install (reflection.reflection reflection.float) (read-primitive-array-handler type.float _.faload)) - (/////bundle.install (reflection.reflection reflection.double) (read-primitive-array-handler type.double _.daload)) - (/////bundle.install (reflection.reflection reflection.char) (read-primitive-array-handler type.char _.caload)) - (/////bundle.install "object" array::read::object)))) - (dictionary.merge (<| (/////bundle.prefix "write") - (|> /////bundle.empty - (/////bundle.install (reflection.reflection reflection.boolean) (write-primitive-array-handler type.boolean _.bastore)) - (/////bundle.install (reflection.reflection reflection.byte) (write-primitive-array-handler type.byte _.bastore)) - (/////bundle.install (reflection.reflection reflection.short) (write-primitive-array-handler type.short _.sastore)) - (/////bundle.install (reflection.reflection reflection.int) (write-primitive-array-handler type.int _.iastore)) - (/////bundle.install (reflection.reflection reflection.long) (write-primitive-array-handler type.long _.lastore)) - (/////bundle.install (reflection.reflection reflection.float) (write-primitive-array-handler type.float _.fastore)) - (/////bundle.install (reflection.reflection reflection.double) (write-primitive-array-handler type.double _.dastore)) - (/////bundle.install (reflection.reflection reflection.char) (write-primitive-array-handler type.char _.castore)) - (/////bundle.install "object" array::write::object)))) - ))) - -(def: (object::null _) - (Nullary (Bytecode Any)) - _.aconst-null) - -(def: (object::null? objectG) - (Unary (Bytecode Any)) - (do _.monad - [@then _.new-label - @end _.new-label] - ($_ _.compose - objectG - (_.ifnull @then) - ..falseG - (_.goto @end) - (_.set-label @then) - ..trueG - (_.set-label @end)))) - -(def: (object::synchronized [monitorG exprG]) - (Binary (Bytecode Any)) - ($_ _.compose - monitorG - _.dup - _.monitorenter - exprG - _.swap - _.monitorexit)) - -(def: (object::throw exceptionG) - (Unary (Bytecode Any)) - ($_ _.compose - exceptionG - _.athrow)) - -(def: $Class (type.class "java.lang.Class" (list))) -(def: $String (type.class "java.lang.String" (list))) - -(def: object::class - Handler - (..custom - [<s>.text - (function (_ extension-name generate archive [class]) - (do //////.monad - [] - (wrap ($_ _.compose - (_.string class) - (_.invokestatic ..$Class "forName" (type.method [(list ..$String) ..$Class (list)]))))))])) - -(def: object::instance? - Handler - (..custom - [($_ <>.and <s>.text <s>.any) - (function (_ extension-name generate archive [class objectS]) - (do //////.monad - [objectG (generate archive objectS)] - (wrap ($_ _.compose - objectG - (_.instanceof (type.class class (list))) - (_.invokestatic ..$Boolean "valueOf" (type.method [(list type.boolean) ..$Boolean (list)]))))))])) - -(def: reflection - (All [category] - (-> (Type (<| Return' Value' category)) Text)) - (|>> type.reflection reflection.reflection)) - -(def: object::cast - Handler - (..custom - [($_ <>.and <s>.text <s>.text <s>.any) - (function (_ extension-name generate archive [from to valueS]) - (do //////.monad - [valueG (generate archive valueS)] - (wrap (`` (cond (~~ (template [<object> <type> <unwrap>] - [(and (text\= (..reflection <type>) - from) - (text\= <object> - to)) - (let [$<object> (type.class <object> (list))] - ($_ _.compose - valueG - (_.invokestatic $<object> "valueOf" (type.method [(list <type>) $<object> (list)])))) - - (and (text\= <object> - from) - (text\= (..reflection <type>) - to)) - (let [$<object> (type.class <object> (list))] - ($_ _.compose - valueG - (_.checkcast $<object>) - (_.invokevirtual $<object> <unwrap> (type.method [(list) <type> (list)]))))] - - [box.boolean type.boolean "booleanValue"] - [box.byte type.byte "byteValue"] - [box.short type.short "shortValue"] - [box.int type.int "intValue"] - [box.long type.long "longValue"] - [box.float type.float "floatValue"] - [box.double type.double "doubleValue"] - [box.char type.char "charValue"])) - ## else - valueG)))))])) - -(def: bundle::object - Bundle - (<| (/////bundle.prefix "object") - (|> (: Bundle /////bundle.empty) - (/////bundle.install "null" (nullary object::null)) - (/////bundle.install "null?" (unary object::null?)) - (/////bundle.install "synchronized" (binary object::synchronized)) - (/////bundle.install "throw" (unary object::throw)) - (/////bundle.install "class" object::class) - (/////bundle.install "instance?" object::instance?) - (/////bundle.install "cast" object::cast) - ))) - -(def: primitives - (Dictionary Text (Type Primitive)) - (|> (list [(reflection.reflection reflection.boolean) type.boolean] - [(reflection.reflection reflection.byte) type.byte] - [(reflection.reflection reflection.short) type.short] - [(reflection.reflection reflection.int) type.int] - [(reflection.reflection reflection.long) type.long] - [(reflection.reflection reflection.float) type.float] - [(reflection.reflection reflection.double) type.double] - [(reflection.reflection reflection.char) type.char]) - (dictionary.from-list text.hash))) - -(def: get::static - Handler - (..custom - [($_ <>.and <s>.text <s>.text <s>.text) - (function (_ extension-name generate archive [class field unboxed]) - (do //////.monad - [#let [$class (type.class class (list))]] - (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (wrap (_.getstatic $class field primitive)) - - #.None - (wrap (_.getstatic $class field (type.class unboxed (list)))))))])) - -(def: unitG (_.string //////synthesis.unit)) - -(def: put::static - Handler - (..custom - [($_ <>.and <s>.text <s>.text <s>.text <s>.any) - (function (_ extension-name generate archive [class field unboxed valueS]) - (do //////.monad - [valueG (generate archive valueS) - #let [$class (type.class class (list))]] - (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (wrap ($_ _.compose - valueG - (_.putstatic $class field primitive) - ..unitG)) - - #.None - (wrap ($_ _.compose - valueG - (_.checkcast $class) - (_.putstatic $class field $class) - ..unitG)))))])) - -(def: get::virtual - Handler - (..custom - [($_ <>.and <s>.text <s>.text <s>.text <s>.any) - (function (_ extension-name generate archive [class field unboxed objectS]) - (do //////.monad - [objectG (generate archive objectS) - #let [$class (type.class class (list)) - getG (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (_.getfield $class field primitive) - - #.None - (_.getfield $class field (type.class unboxed (list))))]] - (wrap ($_ _.compose - objectG - (_.checkcast $class) - getG))))])) - -(def: put::virtual - Handler - (..custom - [($_ <>.and <s>.text <s>.text <s>.text <s>.any <s>.any) - (function (_ extension-name generate archive [class field unboxed valueS objectS]) - (do //////.monad - [valueG (generate archive valueS) - objectG (generate archive objectS) - #let [$class (type.class class (list)) - putG (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (_.putfield $class field primitive) - - #.None - (let [$unboxed (type.class unboxed (list))] - ($_ _.compose - (_.checkcast $unboxed) - (_.putfield $class field $unboxed))))]] - (wrap ($_ _.compose - objectG - (_.checkcast $class) - _.dup - valueG - putG))))])) - -(type: Input (Typed Synthesis)) - -(def: input - (Parser Input) - (<s>.tuple (<>.and ..value <s>.any))) - -(def: (generate-input generate archive [valueT valueS]) - (-> Phase Archive Input (Operation (Typed (Bytecode Any)))) - (do //////.monad - [valueG (generate archive valueS)] - (case (type.primitive? valueT) - (#.Right valueT) - (wrap [valueT valueG]) - - (#.Left valueT) - (wrap [valueT ($_ _.compose - valueG - (_.checkcast valueT))])))) - -(def: (prepare-output outputT) - (-> (Type Return) (Bytecode Any)) - (case (type.void? outputT) - (#.Right outputT) - ..unitG - - (#.Left outputT) - (\ _.monad wrap []))) - -(def: invoke::static - Handler - (..custom - [($_ <>.and ..class <s>.text ..return (<>.some ..input)) - (function (_ extension-name generate archive [class method outputT inputsTS]) - (do {! //////.monad} - [inputsTG (monad.map ! (generate-input generate archive) inputsTS)] - (wrap ($_ _.compose - (monad.map _.monad product.right inputsTG) - (_.invokestatic class method (type.method [(list\map product.left inputsTG) outputT (list)])) - (prepare-output outputT)))))])) - -(template [<name> <invoke>] - [(def: <name> - Handler - (..custom - [($_ <>.and ..class <s>.text ..return <s>.any (<>.some ..input)) - (function (_ extension-name generate archive [class method outputT objectS inputsTS]) - (do {! //////.monad} - [objectG (generate archive objectS) - inputsTG (monad.map ! (generate-input generate archive) inputsTS)] - (wrap ($_ _.compose - objectG - (_.checkcast class) - (monad.map _.monad product.right inputsTG) - (<invoke> class method (type.method [(list\map product.left inputsTG) outputT (list)])) - (prepare-output outputT)))))]))] - - [invoke::virtual _.invokevirtual] - [invoke::special _.invokespecial] - [invoke::interface _.invokeinterface] - ) - -(def: invoke::constructor - Handler - (..custom - [($_ <>.and ..class (<>.some ..input)) - (function (_ extension-name generate archive [class inputsTS]) - (do {! //////.monad} - [inputsTG (monad.map ! (generate-input generate archive) inputsTS)] - (wrap ($_ _.compose - (_.new class) - _.dup - (monad.map _.monad product.right inputsTG) - (_.invokespecial class "<init>" (type.method [(list\map product.left inputsTG) type.void (list)]))))))])) - -(def: bundle::member - Bundle - (<| (/////bundle.prefix "member") - (|> (: Bundle /////bundle.empty) - (dictionary.merge (<| (/////bundle.prefix "get") - (|> (: Bundle /////bundle.empty) - (/////bundle.install "static" get::static) - (/////bundle.install "virtual" get::virtual)))) - (dictionary.merge (<| (/////bundle.prefix "put") - (|> (: Bundle /////bundle.empty) - (/////bundle.install "static" put::static) - (/////bundle.install "virtual" put::virtual)))) - (dictionary.merge (<| (/////bundle.prefix "invoke") - (|> (: Bundle /////bundle.empty) - (/////bundle.install "static" invoke::static) - (/////bundle.install "virtual" invoke::virtual) - (/////bundle.install "special" invoke::special) - (/////bundle.install "interface" invoke::interface) - (/////bundle.install "constructor" invoke::constructor)))) - ))) - -(def: annotation-parameter - (Parser (/.Annotation-Parameter Synthesis)) - (<s>.tuple (<>.and <s>.text <s>.any))) - -(def: annotation - (Parser (/.Annotation Synthesis)) - (<s>.tuple (<>.and <s>.text (<>.some ..annotation-parameter)))) - -(def: argument - (Parser Argument) - (<s>.tuple (<>.and <s>.text ..value))) - -(def: overriden-method-definition - (Parser [(Environment Synthesis) (/.Overriden-Method Synthesis)]) - (<s>.tuple (do <>.monad - [_ (<s>.text! /.overriden-tag) - ownerT ..class - name <s>.text - strict-fp? <s>.bit - annotations (<s>.tuple (<>.some ..annotation)) - vars (<s>.tuple (<>.some ..var)) - self-name <s>.text - arguments (<s>.tuple (<>.some ..argument)) - returnT ..return - exceptionsT (<s>.tuple (<>.some ..class)) - [environment body] (<s>.function 1 - (<s>.tuple <s>.any))] - (wrap [environment - [ownerT name - strict-fp? annotations vars - self-name arguments returnT exceptionsT - body]])))) - -(def: (normalize-path normalize) - (-> (-> Synthesis Synthesis) - (-> Path Path)) - (function (recur path) - (case path - (^ (//////synthesis.path/then bodyS)) - (//////synthesis.path/then (normalize bodyS)) - - (^template [<tag>] - [(^ (<tag> leftP rightP)) - (<tag> (recur leftP) (recur rightP))]) - ([#//////synthesis.Alt] - [#//////synthesis.Seq]) - - (^template [<tag>] - [(^ (<tag> value)) - path]) - ([#//////synthesis.Pop] - [#//////synthesis.Bind] - [#//////synthesis.Access]) - - _ - (undefined)))) - -(def: (normalize-method-body mapping) - (-> (Dictionary Variable Variable) Synthesis Synthesis) - (function (recur body) - (case body - (^template [<tag>] - [(^ (<tag> value)) - body]) - ([#//////synthesis.Primitive] - [//////synthesis.constant]) - - (^ (//////synthesis.variant [lefts right? sub])) - (//////synthesis.variant [lefts right? (recur sub)]) - - (^ (//////synthesis.tuple members)) - (//////synthesis.tuple (list\map recur members)) - - (^ (//////synthesis.variable var)) - (|> mapping - (dictionary.get var) - (maybe.default var) - //////synthesis.variable) - - (^ (//////synthesis.branch/case [inputS pathS])) - (//////synthesis.branch/case [(recur inputS) (normalize-path recur pathS)]) - - (^ (//////synthesis.branch/let [inputS register outputS])) - (//////synthesis.branch/let [(recur inputS) register (recur outputS)]) - - (^ (//////synthesis.branch/if [testS thenS elseS])) - (//////synthesis.branch/if [(recur testS) (recur thenS) (recur elseS)]) - - (^ (//////synthesis.branch/get [path recordS])) - (//////synthesis.branch/get [path (recur recordS)]) - - (^ (//////synthesis.loop/scope [offset initsS+ bodyS])) - (//////synthesis.loop/scope [offset (list\map recur initsS+) (recur bodyS)]) - - (^ (//////synthesis.loop/recur updatesS+)) - (//////synthesis.loop/recur (list\map recur updatesS+)) - - (^ (//////synthesis.function/abstraction [environment arity bodyS])) - (//////synthesis.function/abstraction [(list\map (function (_ local) - (case local - (^ (//////synthesis.variable local)) - (|> mapping - (dictionary.get local) - (maybe.default local) - //////synthesis.variable) - - _ - local)) - environment) - arity - bodyS]) - - (^ (//////synthesis.function/apply [functionS inputsS+])) - (//////synthesis.function/apply [(recur functionS) (list\map recur inputsS+)]) - - (#//////synthesis.Extension [name inputsS+]) - (#//////synthesis.Extension [name (list\map recur inputsS+)])))) - -(def: $Object (type.class "java.lang.Object" (list))) - -(def: (anonymous-init-method env) - (-> (Environment Synthesis) (Type category.Method)) - (type.method [(list.repeat (list.size env) ..$Object) - type.void - (list)])) - -(def: (with-anonymous-init class env super-class inputsTG) - (-> (Type category.Class) (Environment Synthesis) (Type category.Class) (List (Typed (Bytecode Any))) (Resource Method)) - (let [store-capturedG (|> env - list.size - list.indices - (monad.map _.monad (.function (_ register) - ($_ _.compose - (_.aload 0) - (_.aload (inc register)) - (_.putfield class (///reference.foreign-name register) $Object)))))] - (method.method method.public "<init>" (anonymous-init-method env) - (list) - (#.Some ($_ _.compose - (_.aload 0) - (monad.map _.monad product.right inputsTG) - (_.invokespecial super-class "<init>" (type.method [(list\map product.left inputsTG) type.void (list)])) - store-capturedG - _.return))))) - -(def: (anonymous-instance generate archive class env) - (-> Phase Archive (Type category.Class) (Environment Synthesis) (Operation (Bytecode Any))) - (do {! //////.monad} - [captureG+ (monad.map ! (generate archive) env)] - (wrap ($_ _.compose - (_.new class) - _.dup - (monad.seq _.monad captureG+) - (_.invokespecial class "<init>" (anonymous-init-method env)))))) - -(def: (returnG returnT) - (-> (Type Return) (Bytecode Any)) - (case (type.void? returnT) - (#.Right returnT) - _.return - - (#.Left returnT) - (case (type.primitive? returnT) - (#.Left returnT) - ($_ _.compose - (_.checkcast returnT) - _.areturn) - - (#.Right returnT) - (cond (or (\ type.equivalence = type.boolean returnT) - (\ type.equivalence = type.byte returnT) - (\ type.equivalence = type.short returnT) - (\ type.equivalence = type.int returnT) - (\ type.equivalence = type.char returnT)) - _.ireturn - - (\ type.equivalence = type.long returnT) - _.lreturn - - (\ type.equivalence = type.float returnT) - _.freturn - - ## (\ type.equivalence = type.double returnT) - _.dreturn)))) - -(def: class::anonymous - Handler - (..custom - [($_ <>.and - ..class - (<s>.tuple (<>.some ..class)) - (<s>.tuple (<>.some ..input)) - (<s>.tuple (<>.some ..overriden-method-definition))) - (function (_ extension-name generate archive [super-class super-interfaces - inputsTS - overriden-methods]) - (do {! //////.monad} - [[context _] (//////generation.with-new-context archive (wrap [])) - #let [[module-id artifact-id] context - anonymous-class-name (///runtime.class-name context) - class (type.class anonymous-class-name (list)) - total-environment (|> overriden-methods - ## Get all the environments. - (list\map product.left) - ## Combine them. - list\join - ## Remove duplicates. - (set.from-list //////synthesis.hash) - set.to-list) - global-mapping (|> total-environment - ## Give them names as "foreign" variables. - list.enumeration - (list\map (function (_ [id capture]) - [capture (#//////variable.Foreign id)])) - (dictionary.from-list //////variable.hash)) - normalized-methods (list\map (function (_ [environment - [ownerT name - strict-fp? annotations vars - self-name arguments returnT exceptionsT - body]]) - (let [local-mapping (|> environment - list.enumeration - (list\map (function (_ [foreign-id capture]) - [(#//////variable.Foreign foreign-id) - (|> global-mapping - (dictionary.get capture) - maybe.assume)])) - (dictionary.from-list //////variable.hash))] - [ownerT name - strict-fp? annotations vars - self-name arguments returnT exceptionsT - (normalize-method-body local-mapping body)])) - overriden-methods)] - inputsTI (monad.map ! (generate-input generate archive) inputsTS) - method-definitions (monad.map ! (function (_ [ownerT name - strict-fp? annotations vars - self-name arguments returnT exceptionsT - bodyS]) - (do ! - [bodyG (//////generation.with-context artifact-id - (generate archive bodyS))] - (wrap (method.method ($_ modifier\compose - method.public - method.final - (if strict-fp? - method.strict - modifier\identity)) - name - (type.method [(list\map product.right arguments) - returnT - exceptionsT]) - (list) - (#.Some ($_ _.compose - bodyG - (returnG returnT))))))) - normalized-methods) - bytecode (<| (\ ! map (format.run class.writer)) - //////.lift - (class.class version.v6_0 ($_ modifier\compose class.public class.final) - (name.internal anonymous-class-name) - (name.internal (..reflection super-class)) - (list\map (|>> ..reflection name.internal) super-interfaces) - (foreign.variables total-environment) - (list& (..with-anonymous-init class total-environment super-class inputsTI) - method-definitions) - (row.row))) - _ (//////generation.execute! [anonymous-class-name bytecode]) - _ (//////generation.save! (%.nat artifact-id) [anonymous-class-name bytecode])] - (anonymous-instance generate archive class total-environment)))])) - -(def: bundle::class - Bundle - (<| (/////bundle.prefix "class") - (|> (: Bundle /////bundle.empty) - (/////bundle.install "anonymous" class::anonymous) - ))) - -(def: #export bundle - Bundle - (<| (/////bundle.prefix "jvm") - (|> ..bundle::conversion - (dictionary.merge ..bundle::int) - (dictionary.merge ..bundle::long) - (dictionary.merge ..bundle::float) - (dictionary.merge ..bundle::double) - (dictionary.merge ..bundle::char) - (dictionary.merge ..bundle::array) - (dictionary.merge ..bundle::object) - (dictionary.merge ..bundle::member) - (dictionary.merge ..bundle::class) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua.lux deleted file mode 100644 index ab0d0d555..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - ["." / #_ - ["#." common] - ["#." host] - [//// - [generation - [lua - [runtime (#+ Bundle)]]]]]) - -(def: #export bundle - Bundle - (dictionary.merge /common.bundle - /host.bundle)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux deleted file mode 100644 index b22dd6d53..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux +++ /dev/null @@ -1,180 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["." try] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." dictionary] - ["." list ("#\." functor fold)]]] - [math - [number - ["f" frac]]] - ["@" target - ["_" lua (#+ Expression)]]] - ["." //// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["//" lua #_ - ["#." runtime (#+ Operation Phase Handler Bundle Generator)]]] - [// - [synthesis (#+ %synthesis)] - ["." generation] - [/// - ["#" phase]]]]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text (Generator s))] - Handler)) - (function (_ extension_name phase archive input) - (case (<s>.run parser input) - (#try.Success input') - (handler extension_name phase archive input') - - (#try.Failure error) - (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) - -(template: (!unary function) - (|>> list _.apply/* (|> (_.var function)))) - -## TODO: Get rid of this ASAP -(def: lux::syntax_char_case! - (..custom [($_ <>.and - <s>.any - <s>.any - (<>.some (<s>.tuple ($_ <>.and - (<s>.tuple (<>.many <s>.i64)) - <s>.any)))) - (function (_ extension_name phase archive [input else conditionals]) - (do {! /////.monad} - [inputG (phase archive input) - elseG (phase archive else) - @input (\ ! map _.var (generation.gensym "input")) - conditionalsG (: (Operation (List [Expression Expression])) - (monad.map ! (function (_ [chars branch]) - (do ! - [branchG (phase archive branch)] - (wrap [(|> chars - (list\map (|>> .int _.int (_.= @input))) - (list\fold (function (_ clause total) - (if (is? _.nil total) - clause - (_.or clause total))) - _.nil)) - branchG]))) - conditionals)) - #let [closure (_.closure (list @input) - (list\fold (function (_ [test then] else) - (_.if test (_.return then) else)) - (_.return elseG) - conditionalsG))]] - (wrap (_.apply/1 closure inputG))))])) - -(def: lux_procs - Bundle - (|> /.empty - (/.install "syntax char case!" lux::syntax_char_case!) - (/.install "is" (binary (product.uncurry _.=))) - (/.install "try" (unary //runtime.lux//try)))) - -(def: i64_procs - Bundle - (<| (/.prefix "i64") - (|> /.empty - (/.install "and" (binary (product.uncurry _.bit_and))) - (/.install "or" (binary (product.uncurry _.bit_or))) - (/.install "xor" (binary (product.uncurry _.bit_xor))) - (/.install "left-shift" (binary (product.uncurry //runtime.i64//left_shift))) - (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) - (/.install "=" (binary (product.uncurry _.=))) - (/.install "+" (binary (product.uncurry _.+))) - (/.install "-" (binary (product.uncurry _.-))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "*" (binary (product.uncurry _.*))) - (/.install "/" (binary (product.uncurry //runtime.i64//division))) - (/.install "%" (binary (product.uncurry //runtime.i64//remainder))) - (/.install "f64" (unary (_./ (_.float +1.0)))) - (/.install "char" (unary (_.apply/1 (_.var "utf8.char")))) - ))) - -(def: f64//decode - (Unary Expression) - (|>> list _.apply/* (|> (_.var "tonumber")) _.return (_.closure (list)) //runtime.lux//try)) - -(def: f64_procs - Bundle - (<| (/.prefix "f64") - (|> /.empty - (/.install "+" (binary (product.uncurry _.+))) - (/.install "-" (binary (product.uncurry _.-))) - (/.install "*" (binary (product.uncurry _.*))) - (/.install "/" (binary (product.uncurry _./))) - (/.install "%" (binary (product.uncurry (function.flip (_.apply/2 (_.var "math.fmod")))))) - (/.install "=" (binary (product.uncurry _.=))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "i64" (unary (!unary "math.floor"))) - (/.install "encode" (unary (_.apply/2 (_.var "string.format") (_.string "%.17g")))) - (/.install "decode" (unary ..f64//decode))))) - -(def: (text//char [paramO subjectO]) - (Binary Expression) - (//runtime.text//char (_.+ (_.int +1) paramO) subjectO)) - -(def: (text//clip [paramO extraO subjectO]) - (Trinary Expression) - (//runtime.text//clip subjectO paramO extraO)) - -(def: (text//index [startO partO textO]) - (Trinary Expression) - (//runtime.text//index textO partO startO)) - -(def: text_procs - Bundle - (<| (/.prefix "text") - (|> /.empty - (/.install "=" (binary (product.uncurry _.=))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "concat" (binary (product.uncurry (function.flip _.concat)))) - (/.install "index" (trinary ..text//index)) - (/.install "size" (unary //runtime.text//size)) - ## TODO: Use version below once the Lua compiler becomes self-hosted. - ## (/.install "size" (unary (for {@.lua (!unary "utf8.len")} - ## (!unary "string.len")))) - (/.install "char" (binary ..text//char)) - (/.install "clip" (trinary ..text//clip)) - ))) - -(def: (io//log! messageO) - (Unary Expression) - (|> (_.apply/* (list messageO) (_.var "print")) - (_.or //runtime.unit))) - -(def: io_procs - Bundle - (<| (/.prefix "io") - (|> /.empty - (/.install "log" (unary ..io//log!)) - (/.install "error" (unary (!unary "error")))))) - -(def: #export bundle - Bundle - (<| (/.prefix "lux") - (|> lux_procs - (dictionary.merge i64_procs) - (dictionary.merge f64_procs) - (dictionary.merge text_procs) - (dictionary.merge io_procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux deleted file mode 100644 index c9c5acec8..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux +++ /dev/null @@ -1,199 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - [collection - ["." dictionary] - ["." list]] - [text - ["%" format (#+ format)]]] - [target - ["_" lua (#+ Var Expression)]]] - ["." // #_ - ["#." common (#+ custom)] - ["//#" /// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["." reference] - ["//" lua #_ - ["#." runtime (#+ Operation Phase Handler Bundle - with_vars)]]] - ["/#" // #_ - ["." generation] - ["//#" /// #_ - ["#." phase]]]]]]) - -(def: array::new - (Unary Expression) - (|>> ["n"] list _.table)) - -(def: array::length - (Unary Expression) - (_.the "n")) - -(def: (array::read [indexG arrayG]) - (Binary Expression) - (_.nth (_.+ (_.int +1) indexG) arrayG)) - -(def: (array::write [indexG valueG arrayG]) - (Trinary Expression) - (//runtime.array//write indexG valueG arrayG)) - -(def: (array::delete [indexG arrayG]) - (Binary Expression) - (//runtime.array//write indexG _.nil arrayG)) - -(def: array - Bundle - (<| (/.prefix "array") - (|> /.empty - (/.install "new" (unary array::new)) - (/.install "length" (unary array::length)) - (/.install "read" (binary array::read)) - (/.install "write" (trinary array::write)) - (/.install "delete" (binary array::delete)) - ))) - -(def: object::get - Handler - (custom - [($_ <>.and <s>.text <s>.any) - (function (_ extension phase archive [fieldS objectS]) - (do ////////phase.monad - [objectG (phase archive objectS)] - (wrap (_.the fieldS objectG))))])) - -(def: object::do - Handler - (custom - [($_ <>.and <s>.text <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [methodS objectS inputsS]) - (do {! ////////phase.monad} - [objectG (phase archive objectS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.do methodS inputsG objectG))))])) - -(template [<!> <?> <unit>] - [(def: <!> (Nullary Expression) (function.constant <unit>)) - (def: <?> (Unary Expression) (_.= <unit>))] - - [object::nil object::nil? _.nil] - ) - -(def: object - Bundle - (<| (/.prefix "object") - (|> /.empty - (/.install "get" object::get) - (/.install "do" object::do) - (/.install "nil" (nullary object::nil)) - (/.install "nil?" (unary object::nil?)) - ))) - -(def: $input - (_.var "input")) - -(def: utf8::encode - (custom - [<s>.any - (function (_ extension phase archive inputS) - (do {! ////////phase.monad} - [inputG (phase archive inputS)] - (wrap (_.apply/1 (<| (_.closure (list $input)) - (_.return (|> (_.var "string.byte") - (_.apply/* (list $input (_.int +1) (_.length $input))) - (_.apply/1 (_.var "table.pack"))))) - inputG))))])) - -(def: utf8::decode - (custom - [<s>.any - (function (_ extension phase archive inputS) - (do {! ////////phase.monad} - [inputG (phase archive inputS)] - (wrap (|> inputG - (_.apply/1 (_.var "table.unpack")) - (_.apply/1 (_.var "string.char"))))))])) - -(def: utf8 - Bundle - (<| (/.prefix "utf8") - (|> /.empty - (/.install "encode" utf8::encode) - (/.install "decode" utf8::decode) - ))) - -(def: lua::constant - (custom - [<s>.text - (function (_ extension phase archive name) - (\ ////////phase.monad wrap (_.var name)))])) - -(def: lua::apply - (custom - [($_ <>.and <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [abstractionS inputsS]) - (do {! ////////phase.monad} - [abstractionG (phase archive abstractionS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.apply/* inputsG abstractionG))))])) - -(def: lua::power - (custom - [($_ <>.and <s>.any <s>.any) - (function (_ extension phase archive [powerS baseS]) - (do {! ////////phase.monad} - [powerG (phase archive powerS) - baseG (phase archive baseS)] - (wrap (_.^ powerG baseG))))])) - -(def: lua::import - (custom - [<s>.text - (function (_ extension phase archive module) - (\ ////////phase.monad wrap - (_.require/1 (_.string module))))])) - -(def: lua::function - (custom - [($_ <>.and <s>.i64 <s>.any) - (function (_ extension phase archive [arity abstractionS]) - (do {! ////////phase.monad} - [abstractionG (phase archive abstractionS) - #let [variable (: (-> Text (Operation Var)) - (|>> generation.gensym - (\ ! map _.var)))] - g!inputs (monad.map ! (function (_ _) - (variable "input")) - (list.repeat (.nat arity) []))] - (wrap (<| (_.closure g!inputs) - _.statement - (case (.nat arity) - 0 (_.apply/1 abstractionG //runtime.unit) - 1 (_.apply/* g!inputs abstractionG) - _ (_.apply/1 abstractionG (_.array g!inputs)))))))])) - -(def: #export bundle - Bundle - (<| (/.prefix "lua") - (|> /.empty - (dictionary.merge ..array) - (dictionary.merge ..object) - (dictionary.merge ..utf8) - - (/.install "constant" lua::constant) - (/.install "apply" lua::apply) - (/.install "power" lua::power) - (/.install "import" lua::import) - (/.install "function" lua::function) - (/.install "script universe" (nullary (function.constant (_.bool reference.universe)))) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php.lux deleted file mode 100644 index 2f2d75c31..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - ["." / #_ - ["#." common] - ["#." host] - [//// - [generation - [php - [runtime (#+ Bundle)]]]]]) - -(def: #export bundle - Bundle - (dictionary.merge /common.bundle - /host.bundle)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux deleted file mode 100644 index ce4ab223c..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux +++ /dev/null @@ -1,191 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["." try] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." dictionary] - ["." set] - ["." list ("#\." functor fold)]]] - [math - [number - ["f" frac]]] - ["@" target - ["_" php (#+ Expression)]]] - ["." //// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["." reference] - ["//" php #_ - ["#." runtime (#+ Operation Phase Handler Bundle Generator)] - ["#." case]]] - [// - ["." synthesis (#+ %synthesis)] - ["." generation] - [/// - ["#" phase]]]]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text (Generator s))] - Handler)) - (function (_ extension_name phase archive input) - (case (<s>.run parser input) - (#try.Success input') - (handler extension_name phase archive input') - - (#try.Failure error) - (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) - -(template: (!unary function) - (|>> list _.apply/* (|> (_.constant function)))) - -## TODO: Get rid of this ASAP -(def: lux::syntax_char_case! - (..custom [($_ <>.and - <s>.any - <s>.any - (<>.some (<s>.tuple ($_ <>.and - (<s>.tuple (<>.many <s>.i64)) - <s>.any)))) - (function (_ extension_name phase archive [input else conditionals]) - (do {! /////.monad} - [inputG (phase archive input) - [[context_module context_artifact] elseG] (generation.with_new_context archive - (phase archive else)) - @input (\ ! map _.var (generation.gensym "input")) - conditionalsG (: (Operation (List [Expression Expression])) - (monad.map ! (function (_ [chars branch]) - (do ! - [branchG (phase archive branch)] - (wrap [(|> chars - (list\map (|>> .int _.int (_.=== @input))) - (list\fold (function (_ clause total) - (if (is? _.null total) - clause - (_.or clause total))) - _.null)) - branchG]))) - conditionals)) - #let [foreigns (|> conditionals - (list\map (|>> product.right synthesis.path/then //case.dependencies)) - (list& (//case.dependencies (synthesis.path/then else))) - list.concat - (set.from_list _.hash) - set.to_list) - @expression (_.constant (reference.artifact [context_module context_artifact])) - directive (_.define_function @expression (list& (_.parameter @input) (list\map _.reference foreigns)) - (list\fold (function (_ [test then] else) - (_.if test (_.return then) else)) - (_.return elseG) - conditionalsG))] - _ (generation.execute! directive) - _ (generation.save! context_artifact directive)] - (wrap (_.apply/* (list& inputG foreigns) @expression))))])) - -(def: lux_procs - Bundle - (|> /.empty - (/.install "syntax char case!" lux::syntax_char_case!) - (/.install "is" (binary (product.uncurry _.===))) - (/.install "try" (unary //runtime.lux//try)) - )) - -(def: (left_shift [parameter subject]) - (Binary Expression) - (_.bit_shl (_.% (_.int +64) parameter) subject)) - -(def: i64_procs - Bundle - (<| (/.prefix "i64") - (|> /.empty - (/.install "and" (binary (product.uncurry _.bit_and))) - (/.install "or" (binary (product.uncurry _.bit_or))) - (/.install "xor" (binary (product.uncurry _.bit_xor))) - (/.install "left-shift" (binary ..left_shift)) - (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) - (/.install "=" (binary (product.uncurry _.==))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "+" (binary (product.uncurry //runtime.i64//+))) - (/.install "-" (binary (product.uncurry //runtime.i64//-))) - (/.install "*" (binary (product.uncurry //runtime.i64//*))) - (/.install "/" (binary (function (_ [parameter subject]) - (_.intdiv/2 [subject parameter])))) - (/.install "%" (binary (product.uncurry _.%))) - (/.install "f64" (unary (_./ (_.float +1.0)))) - (/.install "char" (unary //runtime.i64//char)) - ))) - -(def: (f64//% [parameter subject]) - (Binary Expression) - (_.fmod/2 [subject parameter])) - -(def: (f64//encode subject) - (Unary Expression) - (_.number_format/2 [subject (_.int +17)])) - -(def: f64_procs - Bundle - (<| (/.prefix "f64") - (|> /.empty - (/.install "=" (binary (product.uncurry _.==))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "+" (binary (product.uncurry _.+))) - (/.install "-" (binary (product.uncurry _.-))) - (/.install "*" (binary (product.uncurry _.*))) - (/.install "/" (binary (product.uncurry _./))) - (/.install "%" (binary ..f64//%)) - (/.install "i64" (unary _.intval/1)) - (/.install "encode" (unary ..f64//encode)) - (/.install "decode" (unary //runtime.f64//decode))))) - -(def: (text//clip [paramO extraO subjectO]) - (Trinary Expression) - (//runtime.text//clip paramO extraO subjectO)) - -(def: (text//index [startO partO textO]) - (Trinary Expression) - (//runtime.text//index textO partO startO)) - -(def: text_procs - Bundle - (<| (/.prefix "text") - (|> /.empty - (/.install "=" (binary (product.uncurry _.==))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "concat" (binary (product.uncurry (function.flip _.concat)))) - (/.install "index" (trinary ..text//index)) - (/.install "size" (unary //runtime.text//size)) - (/.install "char" (binary (product.uncurry //runtime.text//char))) - (/.install "clip" (trinary ..text//clip)) - ))) - -(def: io_procs - Bundle - (<| (/.prefix "io") - (|> /.empty - (/.install "log" (unary //runtime.io//log!)) - (/.install "error" (unary //runtime.io//throw!))))) - -(def: #export bundle - Bundle - (<| (/.prefix "lux") - (|> /.empty - (dictionary.merge lux_procs) - (dictionary.merge i64_procs) - (dictionary.merge f64_procs) - (dictionary.merge text_procs) - (dictionary.merge io_procs)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux deleted file mode 100644 index d93fd04ff..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux +++ /dev/null @@ -1,142 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - [collection - ["." dictionary] - ["." list]] - [text - ["%" format (#+ format)]]] - [target - ["_" php (#+ Var Expression)]]] - ["." // #_ - ["#." common (#+ custom)] - ["//#" /// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["." reference] - ["//" php #_ - ["#." runtime (#+ Operation Phase Handler Bundle - with_vars)]]] - ["/#" // #_ - ["." generation] - ["//#" /// #_ - ["#." phase]]]]]]) - -(def: (array::new size) - (Unary Expression) - (//runtime.tuple//make size (_.array_fill/3 [(_.int +0) size _.null]))) - -(def: (array::read [indexG arrayG]) - (Binary Expression) - (_.nth indexG arrayG)) - -(def: (array::write [indexG valueG arrayG]) - (Trinary Expression) - (//runtime.array//write indexG valueG arrayG)) - -(def: (array::delete [indexG arrayG]) - (Binary Expression) - (//runtime.array//write indexG _.null arrayG)) - -(def: array - Bundle - (<| (/.prefix "array") - (|> /.empty - (/.install "new" (unary array::new)) - (/.install "length" (unary //runtime.array//length)) - (/.install "read" (binary array::read)) - (/.install "write" (trinary array::write)) - (/.install "delete" (binary array::delete)) - ))) - -(def: object::new - (custom - [($_ <>.and <s>.text (<>.some <s>.any)) - (function (_ extension phase archive [constructor inputsS]) - (do {! ////////phase.monad} - [inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.new (_.constant constructor) inputsG))))])) - -(def: object::get - Handler - (custom - [($_ <>.and <s>.text <s>.any) - (function (_ extension phase archive [fieldS objectS]) - (do ////////phase.monad - [objectG (phase archive objectS)] - (wrap (_.the fieldS objectG))))])) - -(def: object::do - Handler - (custom - [($_ <>.and <s>.text <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [methodS objectS inputsS]) - (do {! ////////phase.monad} - [objectG (phase archive objectS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.do methodS inputsG objectG))))])) - -(template [<!> <?> <unit>] - [(def: <!> (Nullary Expression) (function.constant <unit>)) - (def: <?> (Unary Expression) (_.=== <unit>))] - - [object::null object::null? _.null] - ) - -(def: object - Bundle - (<| (/.prefix "object") - (|> /.empty - (/.install "new" object::new) - (/.install "get" object::get) - (/.install "do" object::do) - (/.install "null" (nullary object::null)) - (/.install "null?" (unary object::null?)) - ))) - -(def: php::constant - (custom - [<s>.text - (function (_ extension phase archive name) - (\ ////////phase.monad wrap (_.constant name)))])) - -(def: php::apply - (custom - [($_ <>.and <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [abstractionS inputsS]) - (do {! ////////phase.monad} - [abstractionG (phase archive abstractionS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.apply/* inputsG abstractionG))))])) - -(def: php::pack - (custom - [($_ <>.and <s>.any <s>.any) - (function (_ extension phase archive [formatS dataS]) - (do {! ////////phase.monad} - [formatG (phase archive formatS) - dataG (phase archive dataS)] - (wrap (_.pack/2 [formatG (_.splat dataG)]))))])) - -(def: #export bundle - Bundle - (<| (/.prefix "php") - (|> /.empty - (dictionary.merge ..array) - (dictionary.merge ..object) - - (/.install "constant" php::constant) - (/.install "apply" php::apply) - (/.install "pack" php::pack) - (/.install "script universe" (nullary (function.constant (_.bool reference.universe)))) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python.lux deleted file mode 100644 index 5639551c6..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - ["." / #_ - ["#." common] - ["#." host] - [//// - [generation - [python - [runtime (#+ Bundle)]]]]]) - -(def: #export bundle - Bundle - (dictionary.merge /common.bundle - /host.bundle)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux deleted file mode 100644 index 61a154efc..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux +++ /dev/null @@ -1,170 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["." try] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." dictionary] - ["." list ("#\." functor fold)]]] - [math - [number - ["f" frac]]] - [target - ["_" python (#+ Expression)]]] - ["." //// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["//" python #_ - ["#." runtime (#+ Operation Phase Handler Bundle Generator)]]] - [// - [synthesis (#+ %synthesis)] - ["." generation] - [/// - ["#" phase]]]]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text (Generator s))] - Handler)) - (function (_ extension_name phase archive input) - (case (<s>.run parser input) - (#try.Success input') - (handler extension_name phase archive input') - - (#try.Failure error) - (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) - -## TODO: Get rid of this ASAP -(def: lux::syntax_char_case! - (..custom [($_ <>.and - <s>.any - <s>.any - (<>.some (<s>.tuple ($_ <>.and - (<s>.tuple (<>.many <s>.i64)) - <s>.any)))) - (function (_ extension_name phase archive [input else conditionals]) - (do {! /////.monad} - [inputG (phase archive input) - elseG (phase archive else) - @input (\ ! map _.var (generation.gensym "input")) - conditionalsG (: (Operation (List [(Expression Any) - (Expression Any)])) - (monad.map ! (function (_ [chars branch]) - (do ! - [branchG (phase archive branch)] - (wrap [(|> chars - (list\map (|>> .int _.int (_.= @input))) - (list\fold (function (_ clause total) - (if (is? _.none total) - clause - (_.or clause total))) - _.none)) - branchG]))) - conditionals)) - #let [closure (_.lambda (list @input) - (list\fold (function (_ [test then] else) - (_.? test then else)) - elseG - conditionalsG))]] - (wrap (_.apply/* closure (list inputG)))))])) - -(def: lux_procs - Bundle - (|> /.empty - (/.install "syntax char case!" lux::syntax_char_case!) - (/.install "is" (binary (product.uncurry _.is))) - (/.install "try" (unary //runtime.lux::try)))) - -(def: (capped operation parameter subject) - (-> (-> (Expression Any) (Expression Any) (Expression Any)) - (-> (Expression Any) (Expression Any) (Expression Any))) - (//runtime.i64::64 (operation parameter subject))) - -(def: i64_procs - Bundle - (<| (/.prefix "i64") - (|> /.empty - (/.install "and" (binary (product.uncurry //runtime.i64::and))) - (/.install "or" (binary (product.uncurry //runtime.i64::or))) - (/.install "xor" (binary (product.uncurry //runtime.i64::xor))) - (/.install "left-shift" (binary (product.uncurry //runtime.i64::left_shift))) - (/.install "right-shift" (binary (product.uncurry //runtime.i64::right_shift))) - - (/.install "<" (binary (product.uncurry _.<))) - (/.install "=" (binary (product.uncurry _.=))) - (/.install "+" (binary (product.uncurry (..capped _.+)))) - (/.install "-" (binary (product.uncurry (..capped _.-)))) - (/.install "*" (binary (product.uncurry (..capped _.*)))) - (/.install "/" (binary (product.uncurry //runtime.i64::division))) - (/.install "%" (binary (product.uncurry //runtime.i64::remainder))) - (/.install "f64" (unary _.float/1)) - (/.install "char" (unary //runtime.i64::char)) - ))) - -(def: f64_procs - Bundle - (<| (/.prefix "f64") - (|> /.empty - (/.install "+" (binary (product.uncurry _.+))) - (/.install "-" (binary (product.uncurry _.-))) - (/.install "*" (binary (product.uncurry _.*))) - (/.install "/" (binary (product.uncurry //runtime.f64::/))) - (/.install "%" (binary (function (_ [parameter subject]) - (|> (_.__import__/1 (_.unicode "math")) - (_.do "fmod" (list subject parameter)))))) - (/.install "=" (binary (product.uncurry _.=))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "i64" (unary _.int/1)) - (/.install "encode" (unary _.repr/1)) - (/.install "decode" (unary //runtime.f64::decode))))) - -(def: (text::clip [paramO extraO subjectO]) - (Trinary (Expression Any)) - (//runtime.text::clip paramO extraO subjectO)) - -(def: (text::index [startO partO textO]) - (Trinary (Expression Any)) - (//runtime.text::index startO partO textO)) - -(def: text_procs - Bundle - (<| (/.prefix "text") - (|> /.empty - (/.install "=" (binary (product.uncurry _.=))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "concat" (binary (product.uncurry (function.flip _.+)))) - (/.install "index" (trinary ..text::index)) - (/.install "size" (unary _.len/1)) - (/.install "char" (binary (product.uncurry //runtime.text::char))) - (/.install "clip" (trinary ..text::clip)) - ))) - -(def: io_procs - Bundle - (<| (/.prefix "io") - (|> /.empty - (/.install "log" (unary //runtime.io::log!)) - (/.install "error" (unary //runtime.io::throw!))))) - -(def: #export bundle - Bundle - (<| (/.prefix "lux") - (|> lux_procs - (dictionary.merge i64_procs) - (dictionary.merge f64_procs) - (dictionary.merge text_procs) - (dictionary.merge io_procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/host.lux deleted file mode 100644 index a46bbb9cc..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/host.lux +++ /dev/null @@ -1,164 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - [collection - ["." dictionary] - ["." list]]] - [target - ["_" python (#+ Expression SVar)]]] - ["." // #_ - ["#." common (#+ custom)] - ["//#" /// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["//" python #_ - ["#." runtime (#+ Operation Phase Handler Bundle - with_vars)]]] - ["/#" // #_ - ["." generation] - ["//#" /// #_ - ["#." phase]]]]]]) - -(def: (array::new size) - (Unary (Expression Any)) - (|> (list _.none) - _.list - (_.* size))) - -(def: array::length - (Unary (Expression Any)) - (|>> _.len/1 //runtime.i64::64)) - -(def: (array::read [indexG arrayG]) - (Binary (Expression Any)) - (_.nth indexG arrayG)) - -(def: (array::write [indexG valueG arrayG]) - (Trinary (Expression Any)) - (//runtime.array::write indexG valueG arrayG)) - -(def: (array::delete [indexG arrayG]) - (Binary (Expression Any)) - (//runtime.array::write indexG _.none arrayG)) - -(def: array - Bundle - (<| (/.prefix "array") - (|> /.empty - (/.install "new" (unary array::new)) - (/.install "length" (unary array::length)) - (/.install "read" (binary array::read)) - (/.install "write" (trinary array::write)) - (/.install "delete" (binary array::delete)) - ))) - -(def: object::get - Handler - (custom - [($_ <>.and <s>.text <s>.any) - (function (_ extension phase archive [fieldS objectS]) - (do ////////phase.monad - [objectG (phase archive objectS)] - (wrap (_.the fieldS objectG))))])) - -(def: object::do - Handler - (custom - [($_ <>.and <s>.text <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [methodS objectS inputsS]) - (do {! ////////phase.monad} - [objectG (phase archive objectS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.do methodS inputsG objectG))))])) - -(template [<!> <?> <unit>] - [(def: <!> (Nullary (Expression Any)) (function.constant <unit>)) - (def: <?> (Unary (Expression Any)) (_.= <unit>))] - - [object::none object::none? _.none] - ) - -(def: object - Bundle - (<| (/.prefix "object") - (|> /.empty - (/.install "get" object::get) - (/.install "do" object::do) - (/.install "none" (nullary object::none)) - (/.install "none?" (unary object::none?)) - ))) - -(def: python::constant - (custom - [<s>.text - (function (_ extension phase archive name) - (do ////////phase.monad - [] - (wrap (_.var name))))])) - -(def: python::import - (custom - [<s>.text - (function (_ extension phase archive module) - (do ////////phase.monad - [] - (wrap (_.apply/* (_.var "__import__") (list (_.string module))))))])) - -(def: python::apply - (custom - [($_ <>.and <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [abstractionS inputsS]) - (do {! ////////phase.monad} - [abstractionG (phase archive abstractionS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.apply/* abstractionG inputsG))))])) - -(def: python::function - (custom - [($_ <>.and <s>.i64 <s>.any) - (function (_ extension phase archive [arity abstractionS]) - (do {! ////////phase.monad} - [abstractionG (phase archive abstractionS) - #let [variable (: (-> Text (Operation SVar)) - (|>> generation.gensym - (\ ! map _.var)))] - g!inputs (monad.map ! (function (_ _) (variable "input")) - (list.repeat (.nat arity) []))] - (wrap (_.lambda g!inputs - (case (.nat arity) - 0 (_.apply/1 abstractionG //runtime.unit) - 1 (_.apply/* abstractionG g!inputs) - _ (_.apply/1 abstractionG (_.list g!inputs)))))))])) - -(def: python::exec - (custom - [($_ <>.and <s>.any <s>.any) - (function (_ extension phase archive [codeS globalsS]) - (do {! ////////phase.monad} - [codeG (phase archive codeS) - globalsG (phase archive globalsS)] - (wrap (//runtime.lux::exec codeG globalsG))))])) - -(def: #export bundle - Bundle - (<| (/.prefix "python") - (|> /.empty - (dictionary.merge ..array) - (dictionary.merge ..object) - - (/.install "constant" python::constant) - (/.install "import" python::import) - (/.install "apply" python::apply) - (/.install "function" python::function) - (/.install "exec" python::exec) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r.lux deleted file mode 100644 index cd0f6b7cc..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - ["." / #_ - ["#." common] - ["#." host] - [//// - [generation - [r - [runtime (#+ Bundle)]]]]]) - -(def: #export bundle - Bundle - (dictionary.merge /common.bundle - /host.bundle)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux deleted file mode 100644 index d9178d8c2..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux +++ /dev/null @@ -1,178 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["." try] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." dictionary] - ["." set] - ["." list ("#\." functor fold)]]] - [math - [number - ["f" frac]]] - ["@" target - ["_" r (#+ Expression)]]] - ["." //// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["." reference] - ["//" r #_ - ["#." runtime (#+ Operation Phase Handler Bundle Generator)] - ["#." case]]] - [// - ["." synthesis (#+ %synthesis)] - ["." generation] - [/// - ["#" phase]]]]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text (Generator s))] - Handler)) - (function (_ extension_name phase archive input) - (case (<s>.run parser input) - (#try.Success input') - (handler extension_name phase archive input') - - (#try.Failure error) - (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) - -## (template: (!unary function) -## (|>> list _.apply/* (|> (_.constant function)))) - -## ## ## TODO: Get rid of this ASAP -## ## (def: lux::syntax_char_case! -## ## (..custom [($_ <>.and -## ## <s>.any -## ## <s>.any -## ## (<>.some (<s>.tuple ($_ <>.and -## ## (<s>.tuple (<>.many <s>.i64)) -## ## <s>.any)))) -## ## (function (_ extension_name phase archive [input else conditionals]) -## ## (do {! /////.monad} -## ## [@input (\ ! map _.var (generation.gensym "input")) -## ## inputG (phase archive input) -## ## elseG (phase archive else) -## ## conditionalsG (: (Operation (List [Expression Expression])) -## ## (monad.map ! (function (_ [chars branch]) -## ## (do ! -## ## [branchG (phase archive branch)] -## ## (wrap [(|> chars (list\map (|>> .int _.int (_.=/2 @input))) _.or) -## ## branchG]))) -## ## conditionals))] -## ## (wrap (_.let (list [@input inputG]) -## ## (list (list\fold (function (_ [test then] else) -## ## (_.if test then else)) -## ## elseG -## ## conditionalsG))))))])) - -## (def: lux_procs -## Bundle -## (|> /.empty -## ## (/.install "syntax char case!" lux::syntax_char_case!) -## (/.install "is" (binary _.eq/2)) -## ## (/.install "try" (unary //runtime.lux//try)) -## )) - -## ## (def: (capped operation parameter subject) -## ## (-> (-> Expression Expression Expression) -## ## (-> Expression Expression Expression)) -## ## (//runtime.i64//64 (operation parameter subject))) - -(def: i64_procs - Bundle - (<| (/.prefix "i64") - (|> /.empty - ## (/.install "and" (binary _.logand/2)) - ## (/.install "or" (binary _.logior/2)) - ## (/.install "xor" (binary _.logxor/2)) - ## (/.install "left-shift" (binary _.ash/2)) - ## (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) - ## (/.install "=" (binary _.=/2)) - ## (/.install "<" (binary _.</2)) - ## (/.install "+" (binary _.+/2)) - ## (/.install "-" (binary _.-/2)) - ## (/.install "*" (binary _.*/2)) - ## (/.install "/" (binary _.floor/2)) - ## (/.install "%" (binary _.rem/2)) - ## (/.install "f64" (unary (_.//2 (_.float +1.0)))) - (/.install "char" (unary (|>> //runtime.i64_low _.intToUtf8/1))) - ))) - -## (def: f64_procs -## Bundle -## (<| (/.prefix "f64") -## (|> /.empty -## ## (/.install "=" (binary (product.uncurry _.=/2))) -## ## (/.install "<" (binary (product.uncurry _.</2))) -## ## (/.install "+" (binary (product.uncurry _.+/2))) -## ## (/.install "-" (binary (product.uncurry _.-/2))) -## ## (/.install "*" (binary (product.uncurry _.*/2))) -## ## (/.install "/" (binary (product.uncurry _.//2))) -## ## (/.install "%" (binary (product.uncurry _.rem/2))) -## ## (/.install "i64" (unary _.truncate/1)) -## (/.install "encode" (unary _.write-to-string/1)) -## ## (/.install "decode" (unary //runtime.f64//decode)) -## ))) - -## (def: (text//index [offset sub text]) -## (Trinary (Expression Any)) -## (//runtime.text//index offset sub text)) - -## (def: (text//clip [offset length text]) -## (Trinary (Expression Any)) -## (//runtime.text//clip offset length text)) - -## (def: (text//char [index text]) -## (Binary (Expression Any)) -## (_.char-code/1 (_.char/2 [text index]))) - -(def: text_procs - Bundle - (<| (/.prefix "text") - (|> /.empty - ## (/.install "=" (binary _.string=/2)) - ## (/.install "<" (binary (product.uncurry _.string<?/2))) - (/.install "concat" (binary _.paste/2)) - ## (/.install "index" (trinary ..text//index)) - ## (/.install "size" (unary _.length/1)) - ## (/.install "char" (binary ..text//char)) - ## (/.install "clip" (trinary ..text//clip)) - ))) - -## (def: (io//log! message) -## (Unary (Expression Any)) -## (_.progn (list (_.write-line/1 message) -## //runtime.unit))) - -## (def: io_procs -## Bundle -## (<| (/.prefix "io") -## (|> /.empty -## (/.install "log" (unary ..io//log!)) -## (/.install "error" (unary _.error/1)) -## ))) - -(def: #export bundle - Bundle - (<| (/.prefix "lux") - (|> /.empty - ## (dictionary.merge lux_procs) - (dictionary.merge i64_procs) - ## (dictionary.merge f64_procs) - (dictionary.merge text_procs) - ## (dictionary.merge io_procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux deleted file mode 100644 index 2d9148dda..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux +++ /dev/null @@ -1,39 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - [collection - ["." dictionary] - ["." list]] - [text - ["%" format (#+ format)]]] - [target - ["_" r (#+ Var Expression)]]] - ["." // #_ - ["#." common (#+ custom)] - ["//#" /// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["." reference] - ["//" r #_ - ["#." runtime (#+ Operation Phase Handler Bundle - with_vars)]]] - ["/#" // #_ - ["." generation] - ["//#" /// #_ - ["#." phase]]]]]]) - -(def: #export bundle - Bundle - (<| (/.prefix "r") - (|> /.empty - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby.lux deleted file mode 100644 index 12bcfc9b1..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - ["." / #_ - ["#." common] - ["#." host] - [//// - [generation - [ruby - [runtime (#+ Bundle)]]]]]) - -(def: #export bundle - Bundle - (dictionary.merge /common.bundle - /host.bundle)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux deleted file mode 100644 index 030b3b239..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux +++ /dev/null @@ -1,185 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["." try] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." dictionary] - ["." list ("#\." functor fold)]]] - [math - [number - ["f" frac]]] - [target - ["_" ruby (#+ Expression)]]] - ["." //// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["//" ruby #_ - ["#." runtime (#+ Operation Phase Handler Bundle Generator)]]] - [// - [synthesis (#+ %synthesis)] - ["." generation] - [/// - ["#" phase]]]]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text (Generator s))] - Handler)) - (function (_ extension_name phase archive input) - (case (<s>.run parser input) - (#try.Success input') - (handler extension_name phase archive input') - - (#try.Failure error) - (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) - -## TODO: Get rid of this ASAP -(def: lux::syntax_char_case! - (..custom [($_ <>.and - <s>.any - <s>.any - (<>.some (<s>.tuple ($_ <>.and - (<s>.tuple (<>.many <s>.i64)) - <s>.any)))) - (function (_ extension_name phase archive [input else conditionals]) - (do {! /////.monad} - [inputG (phase archive input) - elseG (phase archive else) - @input (\ ! map _.local (generation.gensym "input")) - conditionalsG (: (Operation (List [Expression Expression])) - (monad.map ! (function (_ [chars branch]) - (do ! - [branchG (phase archive branch)] - (wrap [(|> chars - (list\map (|>> .int _.int (_.= @input))) - (list\fold (function (_ clause total) - (if (is? _.nil total) - clause - (_.or clause total))) - _.nil)) - branchG]))) - conditionals)) - #let [closure (_.lambda #.None (list @input) - (list\fold (function (_ [test then] else) - (_.if test (_.return then) else)) - (_.return elseG) - conditionalsG))]] - (wrap (_.apply_lambda/* (list inputG) closure))))])) - -(def: lux_procs - Bundle - (|> /.empty - (/.install "syntax char case!" lux::syntax_char_case!) - (/.install "is" (binary (function (_ [reference subject]) - (_.do "equal?" (list reference) subject)))) - (/.install "try" (unary //runtime.lux//try)))) - -(def: (capped operation parameter subject) - (-> (-> Expression Expression Expression) - (-> Expression Expression Expression)) - (//runtime.i64//64 (operation parameter subject))) - -(def: i64_procs - Bundle - (<| (/.prefix "i64") - (|> /.empty - (/.install "and" (binary (product.uncurry //runtime.i64//and))) - (/.install "or" (binary (product.uncurry //runtime.i64//or))) - (/.install "xor" (binary (product.uncurry //runtime.i64//xor))) - (/.install "left-shift" (binary (product.uncurry //runtime.i64//left_shift))) - (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) - - (/.install "<" (binary (product.uncurry _.<))) - (/.install "=" (binary (product.uncurry _.=))) - (/.install "+" (binary (product.uncurry (..capped _.+)))) - (/.install "-" (binary (product.uncurry (..capped _.-)))) - (/.install "*" (binary (product.uncurry (..capped _.*)))) - (/.install "/" (binary (product.uncurry //runtime.i64//division))) - (/.install "%" (binary (function (_ [parameter subject]) - (_.do "remainder" (list parameter) subject)))) - - (/.install "f64" (unary (_./ (_.float +1.0)))) - (/.install "char" (unary (_.do "chr" (list (_.string "UTF-8"))))) - ))) - -(def: f64_procs - Bundle - (<| (/.prefix "f64") - (|> /.empty - (/.install "+" (binary (product.uncurry _.+))) - (/.install "-" (binary (product.uncurry _.-))) - (/.install "*" (binary (product.uncurry _.*))) - (/.install "/" (binary (product.uncurry _./))) - (/.install "%" (binary (function (_ [parameter subject]) - (_.do "remainder" (list parameter) subject)))) - (/.install "=" (binary (product.uncurry _.=))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "i64" (unary (_.do "floor" (list)))) - (/.install "encode" (unary (_.do "to_s" (list)))) - (/.install "decode" (unary //runtime.f64//decode))))) - -(def: (text//char [subjectO paramO]) - (Binary Expression) - (//runtime.text//char subjectO paramO)) - -(def: (text//clip [paramO extraO subjectO]) - (Trinary Expression) - (//runtime.text//clip paramO extraO subjectO)) - -(def: (text//index [startO partO textO]) - (Trinary Expression) - (//runtime.text//index textO partO startO)) - -(def: text_procs - Bundle - (<| (/.prefix "text") - (|> /.empty - (/.install "=" (binary (product.uncurry _.=))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "concat" (binary (product.uncurry (function.flip _.+)))) - (/.install "index" (trinary text//index)) - (/.install "size" (unary (_.the "length"))) - (/.install "char" (binary (product.uncurry //runtime.text//char))) - (/.install "clip" (trinary text//clip)) - ))) - -(def: (io//log! messageG) - (Unary Expression) - (|> (_.print/2 messageG (_.string text.new_line)) - (_.or //runtime.unit))) - -(def: io//error! - (Unary Expression) - _.raise) - -(def: io_procs - Bundle - (<| (/.prefix "io") - (|> /.empty - (/.install "log" (unary ..io//log!)) - (/.install "error" (unary ..io//error!)) - ))) - -(def: #export bundle - Bundle - (<| (/.prefix "lux") - (|> lux_procs - (dictionary.merge ..i64_procs) - (dictionary.merge ..f64_procs) - (dictionary.merge ..text_procs) - (dictionary.merge ..io_procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/host.lux deleted file mode 100644 index 206034cd7..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/host.lux +++ /dev/null @@ -1,135 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - [collection - ["." dictionary] - ["." list]] - [text - ["%" format (#+ format)]]] - [target - ["_" ruby (#+ Var Expression)]]] - ["." // #_ - ["#." common (#+ custom)] - ["//#" /// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["." reference] - ["//" ruby #_ - ["#." runtime (#+ Operation Phase Handler Bundle - with_vars)]]] - ["/#" // #_ - ["." generation] - ["//#" /// #_ - ["#." phase]]]]]]) - -(def: (array::new [size]) - (Unary Expression) - (_.do "new" (list size) (_.local "Array"))) - -(def: array::length - (Unary Expression) - (_.the "size")) - -(def: (array::read [indexG arrayG]) - (Binary Expression) - (_.nth indexG arrayG)) - -(def: (array::write [indexG valueG arrayG]) - (Trinary Expression) - (//runtime.array//write indexG valueG arrayG)) - -(def: (array::delete [indexG arrayG]) - (Binary Expression) - (//runtime.array//write indexG _.nil arrayG)) - -(def: array - Bundle - (<| (/.prefix "array") - (|> /.empty - (/.install "new" (unary array::new)) - (/.install "length" (unary array::length)) - (/.install "read" (binary array::read)) - (/.install "write" (trinary array::write)) - (/.install "delete" (binary array::delete)) - ))) - -(def: object::get - Handler - (custom - [($_ <>.and <s>.text <s>.any) - (function (_ extension phase archive [fieldS objectS]) - (do ////////phase.monad - [objectG (phase archive objectS)] - (wrap (_.the fieldS objectG))))])) - -(def: object::do - Handler - (custom - [($_ <>.and <s>.text <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [methodS objectS inputsS]) - (do {! ////////phase.monad} - [objectG (phase archive objectS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.do methodS inputsG objectG))))])) - -(template [<!> <?> <unit>] - [(def: <!> (Nullary Expression) (function.constant <unit>)) - (def: <?> (Unary Expression) (_.= <unit>))] - - [object::nil object::nil? _.nil] - ) - -(def: object - Bundle - (<| (/.prefix "object") - (|> /.empty - (/.install "get" object::get) - (/.install "do" object::do) - (/.install "nil" (nullary object::nil)) - (/.install "nil?" (unary object::nil?)) - ))) - -(def: ruby::constant - (custom - [<s>.text - (function (_ extension phase archive name) - (\ ////////phase.monad wrap (_.local name)))])) - -(def: ruby::apply - (custom - [($_ <>.and <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [abstractionS inputsS]) - (do {! ////////phase.monad} - [abstractionG (phase archive abstractionS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.apply/* inputsG abstractionG))))])) - -(def: ruby::import - (custom - [<s>.text - (function (_ extension phase archive module) - (\ ////////phase.monad wrap - (_.require/1 (_.string module))))])) - -(def: #export bundle - Bundle - (<| (/.prefix "ruby") - (|> /.empty - (dictionary.merge ..array) - (dictionary.merge ..object) - - (/.install "constant" ruby::constant) - (/.install "apply" ruby::apply) - (/.install "import" ruby::import) - (/.install "script universe" (nullary (function.constant (_.bool reference.universe)))) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux deleted file mode 100644 index 945e90e57..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - ["." / #_ - ["#." common] - ["#." host] - [//// - [generation - [scheme - [runtime (#+ Bundle)]]]]]) - -(def: #export bundle - Bundle - (dictionary.merge /common.bundle - /host.bundle)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux deleted file mode 100644 index 4f1258794..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux +++ /dev/null @@ -1,174 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["." try] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." dictionary] - ["." set] - ["." list ("#\." functor fold)]]] - [math - [number - ["f" frac]]] - ["@" target - ["_" scheme (#+ Expression)]]] - ["." //// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["." reference] - ["//" scheme #_ - ["#." runtime (#+ Operation Phase Handler Bundle Generator)] - ["#." case]]] - [// - ["." synthesis (#+ %synthesis)] - ["." generation] - [/// - ["#" phase]]]]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text (Generator s))] - Handler)) - (function (_ extension_name phase archive input) - (case (<s>.run parser input) - (#try.Success input') - (handler extension_name phase archive input') - - (#try.Failure error) - (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) - -(template: (!unary function) - (|>> list _.apply/* (|> (_.constant function)))) - -## TODO: Get rid of this ASAP -(def: lux::syntax_char_case! - (..custom [($_ <>.and - <s>.any - <s>.any - (<>.some (<s>.tuple ($_ <>.and - (<s>.tuple (<>.many <s>.i64)) - <s>.any)))) - (function (_ extension_name phase archive [input else conditionals]) - (do {! /////.monad} - [@input (\ ! map _.var (generation.gensym "input")) - inputG (phase archive input) - elseG (phase archive else) - conditionalsG (: (Operation (List [Expression Expression])) - (monad.map ! (function (_ [chars branch]) - (do ! - [branchG (phase archive branch)] - (wrap [(|> chars (list\map (|>> .int _.int (_.=/2 @input))) _.or) - branchG]))) - conditionals))] - (wrap (_.let (list [@input inputG]) - (list\fold (function (_ [test then] else) - (_.if test then else)) - elseG - conditionalsG)))))])) - -(def: lux_procs - Bundle - (|> /.empty - (/.install "syntax char case!" lux::syntax_char_case!) - (/.install "is" (binary (product.uncurry _.eq?/2))) - (/.install "try" (unary //runtime.lux//try)) - )) - -(def: (capped operation parameter subject) - (-> (-> Expression Expression Expression) - (-> Expression Expression Expression)) - (//runtime.i64//64 (operation parameter subject))) - -(def: i64_procs - Bundle - (<| (/.prefix "i64") - (|> /.empty - (/.install "and" (binary (product.uncurry //runtime.i64//and))) - (/.install "or" (binary (product.uncurry //runtime.i64//or))) - (/.install "xor" (binary (product.uncurry //runtime.i64//xor))) - (/.install "left-shift" (binary (product.uncurry //runtime.i64//left_shift))) - (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) - (/.install "=" (binary (product.uncurry _.=/2))) - (/.install "<" (binary (product.uncurry _.</2))) - (/.install "+" (binary (product.uncurry (..capped _.+/2)))) - (/.install "-" (binary (product.uncurry (..capped _.-/2)))) - (/.install "*" (binary (product.uncurry (..capped _.*/2)))) - (/.install "/" (binary (product.uncurry //runtime.i64//division))) - (/.install "%" (binary (product.uncurry _.remainder/2))) - (/.install "f64" (unary (_.//2 (_.float +1.0)))) - (/.install "char" (unary (|>> _.integer->char/1 (_.make-string/2 (_.int +1))))) - ))) - -(def: f64_procs - Bundle - (<| (/.prefix "f64") - (|> /.empty - (/.install "=" (binary (product.uncurry _.=/2))) - (/.install "<" (binary (product.uncurry _.</2))) - (/.install "+" (binary (product.uncurry _.+/2))) - (/.install "-" (binary (product.uncurry _.-/2))) - (/.install "*" (binary (product.uncurry _.*/2))) - (/.install "/" (binary (product.uncurry _.//2))) - (/.install "%" (binary (product.uncurry _.remainder/2))) - (/.install "i64" (unary _.truncate/1)) - (/.install "encode" (unary _.number->string/1)) - (/.install "decode" (unary //runtime.f64//decode))))) - -(def: (text//index [offset sub text]) - (Trinary Expression) - (//runtime.text//index offset sub text)) - -(def: (text//clip [paramO extraO subjectO]) - (Trinary Expression) - (//runtime.text//clip paramO extraO subjectO)) - -(def: text_procs - Bundle - (<| (/.prefix "text") - (|> /.empty - (/.install "=" (binary (product.uncurry _.string=?/2))) - (/.install "<" (binary (product.uncurry _.string<?/2))) - (/.install "concat" (binary (product.uncurry _.string-append/2))) - (/.install "index" (trinary ..text//index)) - (/.install "size" (unary _.string-length/1)) - (/.install "char" (binary (product.uncurry //runtime.text//char))) - (/.install "clip" (trinary ..text//clip)) - ))) - -(def: (io//log! message) - (Unary Expression) - (_.begin (list (_.display/1 message) - (_.display/1 (_.string text.new_line)) - //runtime.unit))) - -(def: io_procs - Bundle - (<| (/.prefix "io") - (|> /.empty - (/.install "log" (unary ..io//log!)) - (/.install "error" (unary _.raise/1)) - ))) - -(def: #export bundle - Bundle - (<| (/.prefix "lux") - (|> /.empty - (dictionary.merge lux_procs) - (dictionary.merge i64_procs) - (dictionary.merge f64_procs) - (dictionary.merge text_procs) - (dictionary.merge io_procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux deleted file mode 100644 index 6072d29e5..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux +++ /dev/null @@ -1,108 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - [collection - ["." dictionary] - ["." list]] - [text - ["%" format (#+ format)]]] - [target - ["_" scheme (#+ Var Expression)]]] - ["." // #_ - ["#." common (#+ custom)] - ["//#" /// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["." reference] - ["//" scheme #_ - ["#." runtime (#+ Operation Phase Handler Bundle - with_vars)]]] - ["/#" // #_ - ["." generation] - ["//#" /// #_ - ["#." phase]]]]]]) - -(def: (array::new size) - (Unary Expression) - (_.make-vector/2 size _.nil)) - -(def: array::length - (Unary Expression) - _.vector-length/1) - -(def: (array::read [indexG arrayG]) - (Binary Expression) - (_.vector-ref/2 arrayG indexG)) - -(def: (array::write [indexG valueG arrayG]) - (Trinary Expression) - (//runtime.array//write indexG valueG arrayG)) - -(def: (array::delete [indexG arrayG]) - (Binary Expression) - (//runtime.array//write indexG _.nil arrayG)) - -(def: array - Bundle - (<| (/.prefix "array") - (|> /.empty - (/.install "new" (unary array::new)) - (/.install "length" (unary array::length)) - (/.install "read" (binary array::read)) - (/.install "write" (trinary array::write)) - (/.install "delete" (binary array::delete)) - ))) - -(template [<!> <?> <unit>] - [(def: <!> (Nullary Expression) (function.constant <unit>)) - (def: <?> (Unary Expression) (_.eq?/2 <unit>))] - - [object::nil object::nil? _.nil] - ) - -(def: object - Bundle - (<| (/.prefix "object") - (|> /.empty - (/.install "nil" (nullary object::nil)) - (/.install "nil?" (unary object::nil?)) - ))) - -(def: scheme::constant - (custom - [<s>.text - (function (_ extension phase archive name) - (do ////////phase.monad - [] - (wrap (_.var name))))])) - -(def: scheme::apply - (custom - [($_ <>.and <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [abstractionS inputsS]) - (do {! ////////phase.monad} - [abstractionG (phase archive abstractionS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.apply/* inputsG abstractionG))))])) - -(def: #export bundle - Bundle - (<| (/.prefix "scheme") - (|> /.empty - (dictionary.merge ..array) - (dictionary.merge ..object) - - (/.install "constant" scheme::constant) - (/.install "apply" scheme::apply) - (/.install "script universe" (nullary (function.constant (_.bool reference.universe)))) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/synthesis.lux deleted file mode 100644 index 40fb4f89e..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/synthesis.lux +++ /dev/null @@ -1,10 +0,0 @@ -(.module: - [lux #*] - [// - ["." bundle] - [/// - [synthesis (#+ Bundle)]]]) - -(def: #export bundle - Bundle - bundle.empty) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux deleted file mode 100644 index 7b81d9d4a..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux +++ /dev/null @@ -1,56 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]]] - ["." / #_ - [runtime (#+ Phase)] - ["#." primitive] - ["#." structure] - ["#." reference] - ["#." case] - ["#." loop] - ["#." function] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." extension] - ["/#" // #_ - [analysis (#+)] - ["#." synthesis] - ["//#" /// #_ - ["#." phase ("#\." monad)] - [reference (#+) - [variable (#+)]]]]]]]) - -(def: #export (generate archive synthesis) - Phase - (case synthesis - (^template [<tag> <generator>] - [(^ (<tag> value)) - (//////phase\wrap (<generator> value))]) - ([////synthesis.bit /primitive.bit] - [////synthesis.i64 /primitive.i64] - [////synthesis.f64 /primitive.f64] - [////synthesis.text /primitive.text]) - - (#////synthesis.Reference value) - (//reference.reference /reference.system archive value) - - (^template [<tag> <generator>] - [(^ (<tag> value)) - (<generator> generate archive value)]) - ([////synthesis.variant /structure.variant] - [////synthesis.tuple /structure.tuple] - [////synthesis.branch/let /case.let] - [////synthesis.branch/if /case.if] - [////synthesis.branch/get /case.get] - [////synthesis.function/apply /function.apply] - - [////synthesis.branch/case /case.case] - [////synthesis.loop/scope /loop.scope] - [////synthesis.loop/recur /loop.recur] - [////synthesis.function/abstraction /function.function]) - - (#////synthesis.Extension extension) - (///extension.apply archive generate extension) - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux deleted file mode 100644 index 2896e0030..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux +++ /dev/null @@ -1,261 +0,0 @@ -(.module: - [lux (#- case let if) - [abstract - ["." monad (#+ do)]] - [control - ["." exception (#+ exception:)]] - [data - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold monoid)] - ["." set]]] - [math - [number - ["n" nat]]] - [target - ["_" common_lisp (#+ Expression Var/1)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." reference] - ["#." primitive] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." synthesis #_ - ["#/." case]] - ["/#" // #_ - ["#." synthesis (#+ Member Synthesis Path)] - ["#." generation] - ["//#" /// #_ - [reference - ["#." variable (#+ Register)]] - ["#." phase ("#\." monad)] - [meta - [archive (#+ Archive)]]]]]]]) - -(def: #export register - (-> Register Var/1) - (|>> (///reference.local //reference.system) :assume)) - -(def: #export capture - (-> Register Var/1) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: #export (let expression archive [valueS register bodyS]) - (Generator [Synthesis Register Synthesis]) - (do ///////phase.monad - [valueG (expression archive valueS) - bodyG (expression archive bodyS)] - (wrap (_.let (list [(..register register) valueG]) - (list bodyG))))) - -(def: #export (if expression archive [testS thenS elseS]) - (Generator [Synthesis Synthesis Synthesis]) - (do ///////phase.monad - [testG (expression archive testS) - thenG (expression archive thenS) - elseG (expression archive elseS)] - (wrap (_.if testG thenG elseG)))) - -(def: #export (get expression archive [pathP valueS]) - (Generator [(List Member) Synthesis]) - (do ///////phase.monad - [valueG (expression archive valueS)] - (wrap (list\fold (function (_ side source) - (.let [method (.case side - (^template [<side> <accessor>] - [(<side> lefts) - (<accessor> (_.int (.int lefts)))]) - ([#.Left //runtime.tuple//left] - [#.Right //runtime.tuple//right]))] - (method source))) - valueG - pathP)))) - -(def: @savepoint (_.var "lux_pm_savepoint")) -(def: @cursor (_.var "lux_pm_cursor")) -(def: @temp (_.var "lux_pm_temp")) -(def: @variant (_.var "lux_pm_variant")) - -(def: (push! value) - (-> (Expression Any) (Expression Any)) - (_.setq @cursor (_.cons/2 [value @cursor]))) - -(def: pop! - (Expression Any) - (_.setq @cursor (_.cdr/1 @cursor))) - -(def: peek - (Expression Any) - (_.car/1 @cursor)) - -(def: save! - (Expression Any) - (_.setq @savepoint (_.cons/2 [@cursor @savepoint]))) - -(def: restore! - (List (Expression Any)) - (list (_.setq @cursor (_.car/1 @savepoint)) - (_.setq @savepoint (_.cdr/1 @savepoint)))) - -(def: (multi_pop! pops) - (-> Nat (Expression Any)) - (_.setq @cursor (_.nthcdr/2 [(_.int (.int pops)) @cursor]))) - -(template [<name> <flag> <prep>] - [(def: (<name> @fail simple? idx next!) - (-> _.Tag Bit Nat (Maybe (Expression Any)) (Expression Any)) - (.let [<failure_condition> (_.eq/2 [@variant @temp])] - (_.let (list [@variant ..peek]) - (list& (_.setq @temp (|> idx <prep> .int _.int (//runtime.sum//get @variant <flag>))) - (.if simple? - (_.when <failure_condition> - (_.go @fail)) - (_.if <failure_condition> - (_.go @fail) - (..push! @temp))) - (.case next! - (#.Some next!) - (list next!) - - #.None - (list))))))] - - [left_choice _.nil (<|)] - [right_choice (_.string "") inc] - ) - -(def: (alternation @otherwise pre! post!) - (-> _.Tag (Expression Any) (Expression Any) (Expression Any)) - (_.tagbody ($_ list\compose - (list ..save! - pre! - @otherwise) - ..restore! - (list post!)))) - -(def: (pattern_matching' expression archive) - (Generator [Var/1 _.Tag _.Tag Path]) - (function (recur [$output @done @fail pathP]) - (.case pathP - (^ (/////synthesis.path/then bodyS)) - (\ ///////phase.monad map - (function (_ outputV) - (_.progn (list (_.setq $output outputV) - (_.go @done)))) - (expression archive bodyS)) - - #/////synthesis.Pop - (///////phase\wrap ..pop!) - - (#/////synthesis.Bind register) - (///////phase\wrap (_.setq (..register register) ..peek)) - - (#/////synthesis.Bit_Fork when thenP elseP) - (do {! ///////phase.monad} - [then! (recur [$output @done @fail thenP]) - else! (.case elseP - (#.Some elseP) - (recur [$output @done @fail elseP]) - - #.None - (wrap (_.go @fail)))] - (wrap (.if when - (_.if ..peek - then! - else!) - (_.if ..peek - else! - then!)))) - - (^template [<tag> <format> <=>] - [(<tag> cons) - (do {! ///////phase.monad} - [clauses (monad.map ! (function (_ [match then]) - (do ! - [then! (recur [$output @done @fail then])] - (wrap [(<=> [(|> match <format>) - ..peek]) - then!]))) - (#.Cons cons))] - (wrap (list\fold (function (_ [when then] else) - (_.if when then else)) - (_.go @fail) - clauses)))]) - ([#/////synthesis.I64_Fork //primitive.i64 _.=/2] - [#/////synthesis.F64_Fork //primitive.f64 _.=/2] - [#/////synthesis.Text_Fork //primitive.text _.string=/2]) - - (^template [<complex> <simple> <choice>] - [(^ (<complex> idx)) - (///////phase\wrap (<choice> @fail false idx #.None)) - - (^ (<simple> idx nextP)) - (|> nextP - [$output @done @fail] recur - (\ ///////phase.monad map (|>> #.Some (<choice> @fail true idx))))]) - ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice] - [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice]) - - (^ (/////synthesis.member/left 0)) - (///////phase\wrap (..push! (_.elt/2 [..peek (_.int +0)]))) - - (^template [<pm> <getter>] - [(^ (<pm> lefts)) - (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))]) - ([/////synthesis.member/left //runtime.tuple//left] - [/////synthesis.member/right //runtime.tuple//right]) - - (^ (/////synthesis.!multi_pop nextP)) - (.let [[extra_pops nextP'] (////synthesis/case.count_pops nextP)] - (do ///////phase.monad - [next! (recur [$output @done @fail nextP'])] - (///////phase\wrap (_.progn (list (..multi_pop! (n.+ 2 extra_pops)) - next!))))) - - (^ (/////synthesis.path/alt preP postP)) - (do {! ///////phase.monad} - [@otherwise (\ ! map (|>> %.nat (format "lux_case_otherwise") _.tag) /////generation.next) - pre! (recur [$output @done @otherwise preP]) - post! (recur [$output @done @fail postP])] - (wrap (..alternation @otherwise pre! post!))) - - (^ (/////synthesis.path/seq preP postP)) - (do ///////phase.monad - [pre! (recur [$output @done @fail preP]) - post! (recur [$output @done @fail postP])] - (wrap (_.progn (list pre! post!))))))) - -(def: (pattern_matching $output expression archive pathP) - (-> Var/1 (Generator Path)) - (do {! ///////phase.monad} - [@done (\ ! map (|>> %.nat (format "lux_case_done") _.tag) /////generation.next) - @fail (\ ! map (|>> %.nat (format "lux_case_fail") _.tag) /////generation.next) - pattern_matching! (pattern_matching' expression archive [$output @done @fail pathP])] - (wrap (_.tagbody - (list pattern_matching! - @fail - (_.error/1 (_.string ////synthesis/case.pattern_matching_error)) - @done))))) - -(def: #export (case expression archive [valueS pathP]) - (Generator [Synthesis Path]) - (do {! ///////phase.monad} - [initG (expression archive valueS) - $output (\ ! map (|>> %.nat (format "lux_case_output") _.var) /////generation.next) - pattern_matching! (pattern_matching $output expression archive pathP) - #let [storage (|> pathP - ////synthesis/case.storage - (get@ #////synthesis/case.bindings) - set.to_list - (list\map (function (_ register) - [(..register register) - _.nil])))]] - (wrap (_.let (list& [@cursor (_.list/* (list initG))] - [@savepoint (_.list/* (list))] - [@temp _.nil] - [$output _.nil] - storage) - (list pattern_matching! - $output))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux deleted file mode 100644 index 3bc0a0887..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux +++ /dev/null @@ -1,13 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - [// - [runtime (#+ Bundle)]] - [/ - ["." common]]) - -(def: #export bundle - Bundle - common.bundle) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux deleted file mode 100644 index 574995de9..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux +++ /dev/null @@ -1,136 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function]] - [data - ["." product] - [number - ["f" frac]] - [collection - ["." dictionary]]] - [target - ["_" common-lisp (#+ Expression)]]] - ["." /// #_ - ["#." runtime (#+ Operation Phase Handler Bundle)] - ["#." primitive] - [// - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - [// - [extension - ["." bundle]]]]]) - -(def: lux-procs - Bundle - (|> bundle.empty - (bundle.install "is" (binary (product.uncurry _.eq))) - (bundle.install "try" (unary ///runtime.lux//try)))) - -(def: (i64//left-shift [paramG subjectG]) - (Binary (Expression Any)) - (_.ash (_.rem (_.int +64) paramG) subjectG)) - -(def: (i64//arithmetic-right-shift [paramG subjectG]) - (Binary (Expression Any)) - (_.ash (|> paramG (_.rem (_.int +64)) (_.* (_.int -1))) - subjectG)) - -(def: (i64//logic-right-shift [paramG subjectG]) - (Binary (Expression Any)) - (///runtime.i64//logic-right-shift (_.rem (_.int +64) paramG) subjectG)) - -(def: i64-procs - Bundle - (<| (bundle.prefix "i64") - (|> bundle.empty - (bundle.install "and" (binary (product.uncurry _.logand))) - (bundle.install "or" (binary (product.uncurry _.logior))) - (bundle.install "xor" (binary (product.uncurry _.logxor))) - (bundle.install "left-shift" (binary i64//left-shift)) - (bundle.install "logical-right-shift" (binary i64//logic-right-shift)) - (bundle.install "arithmetic-right-shift" (binary i64//arithmetic-right-shift)) - (bundle.install "=" (binary (product.uncurry _.=))) - (bundle.install "<" (binary (product.uncurry _.<))) - (bundle.install "+" (binary (product.uncurry _.+))) - (bundle.install "-" (binary (product.uncurry _.-))) - (bundle.install "*" (binary (product.uncurry _.*))) - (bundle.install "/" (binary (product.uncurry _.floor))) - (bundle.install "%" (binary (product.uncurry _.rem))) - (bundle.install "f64" (unary (function (_ value) - (_.coerce/2 [value (_.symbol "double-float")])))) - (bundle.install "char" (unary (|>> _.code-char/1 _.string/1))) - ))) - -(def: f64-procs - Bundle - (<| (bundle.prefix "f64") - (|> bundle.empty - (bundle.install "+" (binary (product.uncurry _.+))) - (bundle.install "-" (binary (product.uncurry _.-))) - (bundle.install "*" (binary (product.uncurry _.*))) - (bundle.install "/" (binary (product.uncurry _./))) - (bundle.install "%" (binary (product.uncurry _.mod))) - (bundle.install "=" (binary (product.uncurry _.=))) - (bundle.install "<" (binary (product.uncurry _.<))) - (bundle.install "i64" (unary _.floor/1)) - (bundle.install "encode" (unary _.write-to-string/1)) - (bundle.install "decode" (unary (let [@temp (_.var "temp")] - (function (_ input) - (_.let (list [@temp (_.read-from-string/1 input)]) - (_.if (_.equal (_.symbol "DOUBLE-FLOAT") - (_.type-of/1 @temp)) - (///runtime.some @temp) - ///runtime.none))))))))) - -(def: (text//< [paramG subjectG]) - (Binary (Expression Any)) - (|> (_.string< paramG subjectG) - _.null/1 - _.not/1)) - -(def: (text//clip [paramO extraO subjectO]) - (Trinary (Expression Any)) - (///runtime.text//clip subjectO paramO extraO)) - -(def: (text//index [startO partO textO]) - (Trinary (Expression Any)) - (///runtime.text//index textO partO startO)) - -(def: text-procs - Bundle - (<| (bundle.prefix "text") - (|> bundle.empty - (bundle.install "=" (binary (product.uncurry _.string=))) - (bundle.install "<" (binary text//<)) - (bundle.install "concat" (binary _.concatenate/2|string)) - (bundle.install "index" (trinary text//index)) - (bundle.install "size" (unary _.length/1)) - (bundle.install "char" (binary (|>> _.char/2 _.char-int/1))) - (bundle.install "clip" (trinary text//clip)) - ))) - -(def: (void code) - (-> (Expression Any) (Expression Any)) - ($_ _.progn - code - ///runtime.unit)) - -(def: io-procs - Bundle - (<| (bundle.prefix "io") - (|> bundle.empty - (bundle.install "log" (unary (|>> _.print/1 ..void))) - (bundle.install "error" (unary _.error/1)) - ))) - -(def: #export bundle - Bundle - (<| (bundle.prefix "lux") - (|> lux-procs - (dictionary.merge i64-procs) - (dictionary.merge f64-procs) - (dictionary.merge text-procs) - (dictionary.merge io-procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux deleted file mode 100644 index 2a5896e92..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux +++ /dev/null @@ -1,102 +0,0 @@ -(.module: - [lux (#- function) - [abstract - ["." monad (#+ do)]] - [control - pipe] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [target - ["_" common_lisp (#+ Expression Var/1)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." reference] - ["#." case] - ["/#" // #_ - ["#." reference] - ["//#" /// #_ - [analysis (#+ Variant Tuple Abstraction Application Analysis)] - [synthesis (#+ Synthesis)] - ["#." generation (#+ Context)] - ["//#" /// #_ - [arity (#+ Arity)] - ["#." phase ("#\." monad)] - [reference - [variable (#+ Register Variable)]]]]]]) - -(def: #export (apply expression archive [functionS argsS+]) - (Generator (Application Synthesis)) - (do {! ///////phase.monad} - [functionG (expression archive functionS) - argsG+ (monad.map ! (expression archive) argsS+)] - (wrap (_.funcall/+ [functionG argsG+])))) - -(def: capture - (-> Register Var/1) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: (with_closure inits function_definition) - (-> (List (Expression Any)) (Expression Any) (Operation (Expression Any))) - (case inits - #.Nil - (\ ///////phase.monad wrap function_definition) - - _ - (do {! ///////phase.monad} - [@closure (\ ! map _.var (/////generation.gensym "closure"))] - (wrap (_.labels (list [@closure [(|> (list.enumeration inits) - (list\map (|>> product.left ..capture)) - _.args) - function_definition]]) - (_.funcall/+ [(_.function/1 @closure) inits])))))) - -(def: input - (|>> inc //case.register)) - -(def: #export (function expression archive [environment arity bodyS]) - (Generator (Abstraction Synthesis)) - (do {! ///////phase.monad} - [@scope (\ ! map (|>> %.nat (format "function_scope") _.tag) /////generation.next) - @output (\ ! map (|>> %.nat (format "loop_output") _.var) /////generation.next) - [function_name bodyG] (/////generation.with_new_context archive - (/////generation.with_anchor [@scope 1] - (expression archive bodyS))) - closureG+ (monad.map ! (expression archive) environment) - #let [@curried (_.var "curried") - @missing (_.var "missing") - arityG (|> arity .int _.int) - @num_args (_.var "num_args") - @self (_.var (///reference.artifact function_name)) - initialize_self! [(//case.register 0) (_.function/1 @self)] - initialize! [(|> (list.indices arity) - (list\map ..input) - _.args) - @curried]]] - (with_closure closureG+ - (_.labels (list [@self [(_.args& (list) @curried) - (_.let (list [@num_args (_.length/1 @curried)]) - (list (_.cond (list [(_.=/2 [arityG @num_args]) - (_.let (list [@output _.nil] - initialize_self!) - (list (_.destructuring-bind initialize! - (list (_.tagbody - (list @scope - (_.setq @output bodyG))) - @output))))] - - [(_.>/2 [arityG @num_args]) - (let [arity_inputs (_.subseq/3 [@curried (_.int +0) arityG]) - extra_inputs (_.subseq/3 [@curried arityG @num_args])] - (_.apply/2 [(_.apply/2 [(_.function/1 @self) - arity_inputs]) - extra_inputs]))]) - ## (|> @num_args (_.< arityG)) - (_.lambda (_.args& (list) @missing) - (_.apply/2 [(_.function/1 @self) - (_.append/2 [@curried @missing])])))))]]) - (_.function/1 @self))) - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux deleted file mode 100644 index 7256e926d..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux +++ /dev/null @@ -1,69 +0,0 @@ -(.module: - [lux (#- Scope) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)]]] - [math - [number - ["n" nat]]] - [target - ["_" common_lisp (#+ Expression)]]] - ["." // #_ - [runtime (#+ Operation Phase Generator)] - ["#." case] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - [synthesis - ["." case]] - ["/#" // #_ - ["."synthesis (#+ Scope Synthesis)] - ["#." generation] - ["//#" /// #_ - ["#." phase] - [meta - [archive (#+ Archive)]] - [reference - [variable (#+ Register)]]]]]]]) - -(def: #export (scope expression archive [start initsS+ bodyS]) - (Generator (Scope Synthesis)) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [@scope (\ ! map (|>> %.nat (format "loop_scope") _.tag) /////generation.next) - @output (\ ! map (|>> %.nat (format "loop_output") _.var) /////generation.next) - initsG+ (monad.map ! (expression archive) initsS+) - bodyG (/////generation.with_anchor [@scope start] - (expression archive bodyS))] - (wrap (_.let (|> initsG+ - list.enumeration - (list\map (function (_ [idx init]) - [(|> idx (n.+ start) //case.register) - init])) - (list& [@output _.nil])) - (list (_.tagbody (list @scope - (_.setq @output bodyG))) - @output)))))) - -(def: #export (recur expression archive argsS+) - (Generator (List Synthesis)) - (do {! ///////phase.monad} - [[tag offset] /////generation.anchor - argsO+ (monad.map ! (expression archive) argsS+) - #let [bindings (|> argsO+ - list.enumeration - (list\map (|>> product.left (n.+ offset) //case.register)) - _.args)]] - (wrap (_.progn (list (_.multiple-value-setq bindings (_.values/* argsO+)) - (_.go tag)))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux deleted file mode 100644 index 9357156f2..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux +++ /dev/null @@ -1,20 +0,0 @@ -(.module: - [lux (#- i64) - [target - ["_" common_lisp (#+ Expression)]]]) - -(def: #export bit - (-> Bit (Expression Any)) - _.bool) - -(def: #export i64 - (-> (I64 Any) (Expression Any)) - (|>> .int _.int)) - -(def: #export f64 - (-> Frac (Expression Any)) - _.double) - -(def: #export text - (-> Text (Expression Any)) - _.string) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux deleted file mode 100644 index 2e4488b00..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux +++ /dev/null @@ -1,12 +0,0 @@ -(.module: - [lux #* - [target - ["_" common_lisp (#+ Expression)]]] - [/// - [reference (#+ System)]]) - -(implementation: #export system - (System (Expression Any)) - - (def: constant _.var) - (def: variable _.var)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux deleted file mode 100644 index fd7ffc48b..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux +++ /dev/null @@ -1,292 +0,0 @@ -(.module: - [lux (#- Location inc) - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<.>" code]]] - [data - ["." product] - ["." text ("#\." hash) - ["%" format (#+ format)] - ["." encoding]] - [collection - ["." list ("#\." functor monoid)] - ["." row]]] - ["." macro - [syntax (#+ syntax:)] - ["." code]] - [math - [number (#+ hex) - ["." i64]]] - ["@" target - ["_" common_lisp (#+ Expression Computation Literal)]]] - ["." /// #_ - ["#." reference] - ["//#" /// #_ - [analysis (#+ Variant)] - ["#." synthesis (#+ Synthesis)] - ["#." generation] - ["//#" /// - ["#." phase] - [reference - [variable (#+ Register)]] - [meta - [archive (#+ Output Archive) - ["." artifact (#+ Registry)]]]]]]) - -(def: module_id - 0) - -(template [<name> <base>] - [(type: #export <name> - (<base> [_.Tag Register] (Expression Any) (Expression Any)))] - - [Operation /////generation.Operation] - [Phase /////generation.Phase] - [Handler /////generation.Handler] - [Bundle /////generation.Bundle] - ) - -(type: #export (Generator i) - (-> Phase Archive i (Operation (Expression Any)))) - -(def: #export unit - (_.string /////synthesis.unit)) - -(def: (flag value) - (-> Bit Literal) - (if value - (_.string "") - _.nil)) - -(def: (variant' tag last? value) - (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any)) - (_.list/* (list tag last? value))) - -(def: #export (variant [lefts right? value]) - (-> (Variant (Expression Any)) (Computation Any)) - (variant' (_.int (.int lefts)) (flag right?) value)) - -(def: #export none - (Computation Any) - (|> ..unit [0 #0] ..variant)) - -(def: #export some - (-> (Expression Any) (Computation Any)) - (|>> [1 #1] ..variant)) - -(def: #export left - (-> (Expression Any) (Computation Any)) - (|>> [0 #0] ..variant)) - -(def: #export right - (-> (Expression Any) (Computation Any)) - (|>> [1 #1] ..variant)) - -(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} - body) - (do {! meta.monad} - [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] - (wrap (list (` (let [(~+ (|> vars - (list.zip/2 ids) - (list\map (function (_ [id var]) - (list (code.local_identifier var) - (` (_.var (~ (code.text (format "v" (%.nat id))))))))) - list.concat))] - (~ body))))))) - -(syntax: (runtime: {declaration (<>.or <code>.local_identifier - (<code>.form (<>.and <code>.local_identifier - (<>.some <code>.local_identifier))))} - code) - (do meta.monad - [runtime_id meta.count] - (macro.with_gensyms [g!_] - (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id])) - runtime_name (` (_.var (~ (code.text (%.code runtime)))))] - (case declaration - (#.Left name) - (let [g!name (code.local_identifier name) - code_nameC (code.local_identifier (format "@" name))] - (wrap (list (` (def: #export (~ g!name) - _.Var/1 - (~ runtime_name))) - - (` (def: (~ code_nameC) - (_.Expression Any) - (_.defparameter (~ runtime_name) (~ code))))))) - - (#.Right [name inputs]) - (let [g!name (code.local_identifier name) - code_nameC (code.local_identifier (format "@" name)) - - inputsC (list\map code.local_identifier inputs) - inputs_typesC (list\map (function.constant (` (_.Expression Any))) - inputs)] - (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) - (-> (~+ inputs_typesC) (_.Computation Any)) - (_.call/* (~ runtime_name) (list (~+ inputsC))))) - - (` (def: (~ code_nameC) - (_.Expression Any) - (..with_vars [(~+ inputsC)] - (_.defun (~ runtime_name) (_.args (list (~+ inputsC))) - (~ code))))))))))))) - -(runtime: (lux//try op) - (with_vars [error] - (_.handler-case - (list [(_.bool true) error - (..left (_.format/3 [_.nil (_.string "~A") error]))]) - (..right (_.funcall/+ [op (list ..unit)]))))) - -## TODO: Use Common Lisp's swiss-army loop macro instead. -(runtime: (lux//program_args inputs) - (with_vars [loop input tail] - (_.labels (list [loop [(_.args (list input tail)) - (_.if (_.null/1 input) - tail - (_.funcall/+ [(_.function/1 loop) - (list (_.cdr/1 input) - (..some (_.vector/* (list (_.car/1 input) tail))))]))]]) - (_.funcall/+ [(_.function/1 loop) - (list (_.reverse/1 inputs) - ..none)])))) - -(def: runtime//lux - (List (Expression Any)) - (list @lux//try - @lux//program_args)) - -(def: last_index - (|>> _.length/1 [(_.int +1)] _.-/2)) - -(with_expansions [<recur> (as_is ($_ _.then - (_.; (_.set lefts (_.-/2 [last_index_right lefts]))) - (_.; (_.set tuple (_.nth last_index_right tuple)))))] - (template: (!recur <side>) - (<side> (_.-/2 [last_index_right lefts]) - (_.elt/2 [tuple last_index_right]))) - - (runtime: (tuple//left lefts tuple) - (with_vars [last_index_right] - (_.let (list [last_index_right (..last_index tuple)]) - (list (_.if (_.>/2 [lefts last_index_right]) - ## No need for recursion - (_.elt/2 [tuple lefts]) - ## Needs recursion - (!recur tuple//left)))))) - - (runtime: (tuple//right lefts tuple) - (with_vars [last_index_right right_index] - (_.let (list [last_index_right (..last_index tuple)] - [right_index (_.+/2 [(_.int +1) lefts])]) - (list (_.cond (list [(_.=/2 [last_index_right right_index]) - (_.elt/2 [tuple right_index])] - [(_.>/2 [last_index_right right_index]) - ## Needs recursion. - (!recur tuple//right)]) - (_.subseq/3 [tuple right_index (_.length/1 tuple)]))))))) - -## TODO: Find a way to extract parts of the sum without "nth", which -## does a linear search, and is thus expensive. -(runtime: (sum//get sum wantsLast wantedTag) - (with_vars [sum_tag sum_flag] - (let [no_match! (_.return sum) - sum_value (_.nth/2 [(_.int +2) sum]) - test_recursion! (_.if sum_flag - ## Must iterate. - (_.progn (list (_.setq wantedTag (_.-/2 [sum_tag wantedTag])) - (_.setq sum sum_value))) - no_match!)] - (_.while (_.bool true) - (_.let (list [sum_tag (_.nth/2 [(_.int +0) sum])] - [sum_flag (_.nth/2 [(_.int +1) sum])]) - (list (_.cond (list [(_.=/2 [sum_tag wantedTag]) - (_.if (_.equal/2 [wantsLast sum_flag]) - (_.return sum_value) - test_recursion!)] - - [(_.>/2 [sum_tag wantedTag]) - test_recursion!] - - [(_.and (_.</2 [sum_tag wantedTag]) - wantsLast) - (_.return (variant' (_.-/2 [wantedTag sum_tag]) sum_flag sum_value))]) - - no_match!))))))) - -(def: runtime//adt - (List (Expression Any)) - (list @tuple//left - @tuple//right - @sum//get)) - -(runtime: (i64//right_shift shift input) - (_.if (_.=/2 [(_.int +0) shift]) - input - (let [anti_shift (_.-/2 [shift (_.int +64)]) - mask (|> (_.int +1) - [anti_shift] _.ash/2 - [(_.int +1)] _.-/2)] - (|> input - [(_.*/2 [(_.int -1) shift])] _.ash/2 - [mask] _.logand/2)))) - -(def: runtime//i64 - (List (Expression Any)) - (list @i64//right_shift)) - -(runtime: (text//clip offset length text) - (_.subseq/3 [text offset (_.+/2 [offset length])])) - -(runtime: (text//index offset sub text) - (with_vars [index] - (_.let (list [index (_.search/3 [sub text offset])]) - (list (_.if index - (..some index) - ..none))))) - -(def: runtime//text - (List (Expression Any)) - (list @text//index - @text//clip)) - -(runtime: (io//exit code) - (_.progn (list (_.conditional+ (list "sbcl") - (_.call/* (_.var "sb-ext:quit") (list code))) - (_.conditional+ (list "clisp") - (_.call/* (_.var "ext:exit") (list code))) - (_.conditional+ (list "ccl") - (_.call/* (_.var "ccl:quit") (list code))) - (_.conditional+ (list "allegro") - (_.call/* (_.var "excl:exit") (list code))) - (_.call/* (_.var "cl-user::quit") (list code))))) - -(def: runtime//io - (List (Expression Any)) - (list @io//exit)) - -(def: runtime - (_.progn ($_ list\compose - runtime//adt - runtime//lux - runtime//i64 - runtime//text - runtime//io))) - -(def: #export generate - (Operation [Registry Output]) - (do ///////phase.monad - [_ (/////generation.execute! ..runtime) - _ (/////generation.save! (%.nat ..module_id) ..runtime)] - (wrap [(|> artifact.empty - artifact.resource - product.right) - (row.row [(%.nat ..module_id) - (|> ..runtime - _.code - (\ encoding.utf8 encode))])]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux deleted file mode 100644 index 566fc148e..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux +++ /dev/null @@ -1,36 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [target - ["_" common_lisp (#+ Expression)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." primitive] - ["///#" //// #_ - [analysis (#+ Variant Tuple)] - ["#." synthesis (#+ Synthesis)] - ["//#" /// #_ - ["#." phase ("#\." monad)]]]]) - -(def: #export (tuple expression archive elemsS+) - (Generator (Tuple Synthesis)) - (case elemsS+ - #.Nil - (///////phase\wrap (//primitive.text /////synthesis.unit)) - - (#.Cons singletonS #.Nil) - (expression archive singletonS) - - _ - (|> elemsS+ - (monad.map ///////phase.monad (expression archive)) - (///////phase\map _.vector/*)))) - -(def: #export (variant expression archive [lefts right? valueS]) - (Generator (Variant Synthesis)) - (let [tag (if right? - (inc lefts) - lefts)] - (///////phase\map (|>> [tag right?] //runtime.variant) - (expression archive valueS)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/extension.lux deleted file mode 100644 index 051b6357b..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/extension.lux +++ /dev/null @@ -1,65 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - [parser - ["s" code]]] - [data - [collection - ["." list ("#\." functor)]]] - ["." meta] - ["." macro (#+ with_gensyms) - ["." code] - [syntax (#+ syntax:)]]] - ["." /// #_ - ["#." extension] - [// - [synthesis (#+ Synthesis)] - ["." generation] - [/// - ["#" phase]]]]) - -(syntax: (Vector {size s.nat} elemT) - (wrap (list (` [(~+ (list.repeat size elemT))])))) - -(type: #export (Nullary of) (-> (Vector 0 of) of)) -(type: #export (Unary of) (-> (Vector 1 of) of)) -(type: #export (Binary of) (-> (Vector 2 of) of)) -(type: #export (Trinary of) (-> (Vector 3 of) of)) -(type: #export (Variadic of) (-> (List of) of)) - -(syntax: (arity: {arity s.nat} {name s.local_identifier} type) - (with_gensyms [g!_ g!extension g!name g!phase g!archive g!inputs g!of g!anchor g!expression g!directive] - (do {! meta.monad} - [g!input+ (monad.seq ! (list.repeat arity (macro.gensym "input")))] - (wrap (list (` (def: #export ((~ (code.local_identifier name)) (~ g!extension)) - (All [(~ g!anchor) (~ g!expression) (~ g!directive)] - (-> ((~ type) (~ g!expression)) - (generation.Handler (~ g!anchor) (~ g!expression) (~ g!directive)))) - (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!archive) (~ g!inputs)) - (case (~ g!inputs) - (^ (list (~+ g!input+))) - (do ///.monad - [(~+ (|> g!input+ - (list\map (function (_ g!input) - (list g!input (` ((~ g!phase) (~ g!archive) (~ g!input)))))) - list.concat))] - ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) - - (~' _) - (///.throw ///extension.incorrect_arity [(~ g!name) 1 (list.size (~ g!inputs))])))))))))) - -(arity: 0 nullary ..Nullary) -(arity: 1 unary ..Unary) -(arity: 2 binary ..Binary) -(arity: 3 trinary ..Trinary) - -(def: #export (variadic extension) - (All [anchor expression directive] - (-> (Variadic expression) (generation.Handler anchor expression directive))) - (function (_ extension_name) - (function (_ phase archive inputsS) - (do {! ///.monad} - [inputsI (monad.map ! (phase archive) inputsS)] - (wrap (extension inputsI)))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux deleted file mode 100644 index ab89ff708..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux +++ /dev/null @@ -1,116 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." exception (#+ exception:)]] - [target - ["_" js]]] - ["." / #_ - [runtime (#+ Phase Phase!)] - ["#." primitive] - ["#." structure] - ["#." reference] - ["#." case] - ["#." loop] - ["#." function] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." extension] - ["/#" // #_ - [analysis (#+)] - ["." synthesis] - ["//#" /// #_ - ["#." phase ("#\." monad)] - [reference (#+) - [variable (#+)]]]]]]]) - -(def: (statement expression archive synthesis) - Phase! - (case synthesis - (^template [<tag>] - [(^ (<tag> value)) - (//////phase\map _.return (expression archive synthesis))]) - ([synthesis.bit] - [synthesis.i64] - [synthesis.f64] - [synthesis.text] - [synthesis.variant] - [synthesis.tuple] - [#synthesis.Reference] - [synthesis.branch/get] - [synthesis.function/apply] - [#synthesis.Extension]) - - (^ (synthesis.branch/case case)) - (/case.case! statement expression archive case) - - (^ (synthesis.branch/let let)) - (/case.let! statement expression archive let) - - (^ (synthesis.branch/if if)) - (/case.if! statement expression archive if) - - (^ (synthesis.loop/scope scope)) - (/loop.scope! statement expression archive scope) - - (^ (synthesis.loop/recur updates)) - (/loop.recur! statement expression archive updates) - - (^ (synthesis.function/abstraction abstraction)) - (//////phase\map _.return (/function.function statement expression archive abstraction)) - )) - -(exception: #export cannot-recur-as-an-expression) - -(def: (expression archive synthesis) - Phase - (case synthesis - (^template [<tag> <generator>] - [(^ (<tag> value)) - (//////phase\wrap (<generator> value))]) - ([synthesis.bit /primitive.bit] - [synthesis.i64 /primitive.i64] - [synthesis.f64 /primitive.f64] - [synthesis.text /primitive.text]) - - (^ (synthesis.variant variantS)) - (/structure.variant expression archive variantS) - - (^ (synthesis.tuple members)) - (/structure.tuple expression archive members) - - (#synthesis.Reference value) - (//reference.reference /reference.system archive value) - - (^ (synthesis.branch/case case)) - (/case.case ..statement expression archive case) - - (^ (synthesis.branch/let let)) - (/case.let expression archive let) - - (^ (synthesis.branch/if if)) - (/case.if expression archive if) - - (^ (synthesis.branch/get get)) - (/case.get expression archive get) - - (^ (synthesis.loop/scope scope)) - (/loop.scope ..statement expression archive scope) - - (^ (synthesis.loop/recur updates)) - (//////phase.throw ..cannot-recur-as-an-expression []) - - (^ (synthesis.function/abstraction abstraction)) - (/function.function ..statement expression archive abstraction) - - (^ (synthesis.function/apply application)) - (/function.apply expression archive application) - - (#synthesis.Extension extension) - (///extension.apply archive expression extension))) - -(def: #export generate - Phase - ..expression) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux deleted file mode 100644 index 50e3ba008..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux +++ /dev/null @@ -1,321 +0,0 @@ -(.module: - [lux (#- case let if) - [abstract - ["." monad (#+ do)]] - [data - ["." maybe] - ["." text] - [collection - ["." list ("#\." functor fold)]]] - [math - [number - ["n" nat]]] - [target - ["_" js (#+ Expression Computation Var Statement)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Phase! Generator Generator!)] - ["#." reference] - ["#." primitive] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." synthesis #_ - ["#/." case]] - ["/#" // #_ - ["#." synthesis (#+ Member Synthesis Path)] - ["//#" /// #_ - [reference - [variable (#+ Register)]] - ["#." phase ("#\." monad)] - [meta - [archive (#+ Archive)]]]]]]]) - -(def: #export register - (-> Register Var) - (|>> (///reference.local //reference.system) :assume)) - -(def: #export (let expression archive [valueS register bodyS]) - (Generator [Synthesis Register Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS) - bodyO (expression archive bodyS)] - ## TODO: Find some way to do 'let' without paying the price of the closure. - (wrap (_.apply/* (_.closure (list (..register register)) - (_.return bodyO)) - (list valueO))))) - -(def: #export (let! statement expression archive [valueS register bodyS]) - (Generator! [Synthesis Register Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS) - bodyO (statement expression archive bodyS)] - (wrap ($_ _.then - (_.define (..register register) valueO) - bodyO)))) - -(def: #export (if expression archive [testS thenS elseS]) - (Generator [Synthesis Synthesis Synthesis]) - (do ///////phase.monad - [testO (expression archive testS) - thenO (expression archive thenS) - elseO (expression archive elseS)] - (wrap (_.? testO thenO elseO)))) - -(def: #export (if! statement expression archive [testS thenS elseS]) - (Generator! [Synthesis Synthesis Synthesis]) - (do ///////phase.monad - [testO (expression archive testS) - thenO (statement expression archive thenS) - elseO (statement expression archive elseS)] - (wrap (_.if testO - thenO - elseO)))) - -(def: #export (get expression archive [pathP valueS]) - (Generator [(List Member) Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS)] - (wrap (list\fold (function (_ side source) - (.let [method (.case side - (^template [<side> <accessor>] - [(<side> lefts) - (<accessor> (_.i32 (.int lefts)))]) - ([#.Left //runtime.tuple//left] - [#.Right //runtime.tuple//right]))] - (method source))) - valueO - (list.reverse pathP))))) - -(def: @savepoint (_.var "lux_pm_cursor_savepoint")) -(def: @cursor (_.var "lux_pm_cursor")) -(def: @temp (_.var "lux_pm_temp")) - -(def: (push_cursor! value) - (-> Expression Statement) - (_.statement (|> @cursor (_.do "push" (list value))))) - -(def: peek_and_pop_cursor - Expression - (|> @cursor (_.do "pop" (list)))) - -(def: pop_cursor! - Statement - (_.statement ..peek_and_pop_cursor)) - -(def: length - (|>> (_.the "length"))) - -(def: last_index - (|>> ..length (_.- (_.i32 +1)))) - -(def: peek_cursor - Expression - (|> @cursor (_.at (last_index @cursor)))) - -(def: save_cursor! - Statement - (.let [cursor (|> @cursor (_.do "slice" (list)))] - (_.statement (|> @savepoint (_.do "push" (list cursor)))))) - -(def: restore_cursor! - Statement - (_.set @cursor (|> @savepoint (_.do "pop" (list))))) - -(def: fail_pm! _.break) - -(def: (multi_pop_cursor! pops) - (-> Nat Statement) - (.let [popsJS (_.i32 (.int pops))] - (_.statement (|> @cursor (_.do "splice" (list (|> @cursor ..length (_.- popsJS)) - popsJS)))))) - -(template [<name> <flag> <prep>] - [(def: (<name> simple? idx) - (-> Bit Nat Statement) - ($_ _.then - (_.set @temp (|> idx <prep> .int _.i32 (//runtime.sum//get ..peek_cursor <flag>))) - (.if simple? - (_.when (_.= _.null @temp) - ..fail_pm!) - (_.if (_.= _.null @temp) - ..fail_pm! - (push_cursor! @temp)))))] - - [left_choice _.null (<|)] - [right_choice (_.string "") inc] - ) - -(def: (alternation pre! post!) - (-> Statement Statement Statement) - ($_ _.then - (_.do_while (_.boolean false) - ($_ _.then - ..save_cursor! - pre!)) - ($_ _.then - ..restore_cursor! - post!))) - -(def: (optimized_pattern_matching recur pathP) - (-> (-> Path (Operation Statement)) - (-> Path (Operation (Maybe Statement)))) - (.case pathP - (^template [<simple> <choice>] - [(^ (<simple> idx nextP)) - (|> nextP - recur - (\ ///////phase.monad map (|>> (_.then (<choice> true idx)) #.Some)))]) - ([/////synthesis.simple_left_side ..left_choice] - [/////synthesis.simple_right_side ..right_choice]) - - (^ (/////synthesis.member/left 0)) - (///////phase\wrap (#.Some (push_cursor! (_.at (_.i32 +0) ..peek_cursor)))) - - ## Extra optimization - (^ (/////synthesis.path/seq - (/////synthesis.member/left 0) - (/////synthesis.!bind_top register thenP))) - (do ///////phase.monad - [then! (recur thenP)] - (wrap (#.Some ($_ _.then - (_.define (..register register) (_.at (_.i32 +0) ..peek_cursor)) - then!)))) - - ## Extra optimization - (^template [<pm> <getter>] - [(^ (/////synthesis.path/seq - (<pm> lefts) - (/////synthesis.!bind_top register thenP))) - (do ///////phase.monad - [then! (recur thenP)] - (wrap (#.Some ($_ _.then - (_.define (..register register) (<getter> (_.i32 (.int lefts)) ..peek_cursor)) - then!))))]) - ([/////synthesis.member/left //runtime.tuple//left] - [/////synthesis.member/right //runtime.tuple//right]) - - (^ (/////synthesis.!bind_top register thenP)) - (do ///////phase.monad - [then! (recur thenP)] - (wrap (#.Some ($_ _.then - (_.define (..register register) ..peek_and_pop_cursor) - then!)))) - - (^ (/////synthesis.!multi_pop nextP)) - (.let [[extra_pops nextP'] (////synthesis/case.count_pops nextP)] - (do ///////phase.monad - [next! (recur nextP')] - (wrap (#.Some ($_ _.then - (multi_pop_cursor! (n.+ 2 extra_pops)) - next!))))) - - _ - (///////phase\wrap #.None))) - -(def: (pattern_matching' statement expression archive) - (-> Phase! Phase Archive - (-> Path (Operation Statement))) - (function (recur pathP) - (do ///////phase.monad - [outcome (optimized_pattern_matching recur pathP)] - (.case outcome - (#.Some outcome) - (wrap outcome) - - #.None - (.case pathP - (#/////synthesis.Then bodyS) - (statement expression archive bodyS) - - #/////synthesis.Pop - (///////phase\wrap pop_cursor!) - - (#/////synthesis.Bind register) - (///////phase\wrap (_.define (..register register) ..peek_cursor)) - - (#/////synthesis.Bit_Fork when thenP elseP) - (do {! ///////phase.monad} - [then! (recur thenP) - else! (.case elseP - (#.Some elseP) - (recur elseP) - - #.None - (wrap ..fail_pm!))] - (wrap (.if when - (_.if ..peek_cursor - then! - else!) - (_.if ..peek_cursor - else! - then!)))) - - (#/////synthesis.I64_Fork cons) - (do {! ///////phase.monad} - [clauses (monad.map ! (function (_ [match then]) - (do ! - [then! (recur then)] - (wrap [(//runtime.i64//= (//primitive.i64 (.int match)) - ..peek_cursor) - then!]))) - (#.Cons cons))] - (wrap (_.cond clauses ..fail_pm!))) - - (^template [<tag> <format>] - [(<tag> cons) - (do {! ///////phase.monad} - [cases (monad.map ! (function (_ [match then]) - (\ ! map (|>> [(list (<format> match))]) (recur then))) - (#.Cons cons))] - (wrap (_.switch ..peek_cursor - cases - (#.Some ..fail_pm!))))]) - ([#/////synthesis.F64_Fork //primitive.f64] - [#/////synthesis.Text_Fork //primitive.text]) - - (^template [<complex> <choice>] - [(^ (<complex> idx)) - (///////phase\wrap (<choice> false idx))]) - ([/////synthesis.side/left ..left_choice] - [/////synthesis.side/right ..right_choice]) - - (^template [<pm> <getter>] - [(^ (<pm> lefts)) - (///////phase\wrap (push_cursor! (<getter> (_.i32 (.int lefts)) ..peek_cursor)))]) - ([/////synthesis.member/left //runtime.tuple//left] - [/////synthesis.member/right //runtime.tuple//right]) - - (^template [<tag> <combinator>] - [(^ (<tag> leftP rightP)) - (do ///////phase.monad - [left! (recur leftP) - right! (recur rightP)] - (wrap (<combinator> left! right!)))]) - ([/////synthesis.path/seq _.then] - [/////synthesis.path/alt ..alternation])))))) - -(def: (pattern_matching statement expression archive pathP) - (-> Phase! Phase Archive Path (Operation Statement)) - (do ///////phase.monad - [pattern_matching! (pattern_matching' statement expression archive pathP)] - (wrap ($_ _.then - (_.do_while (_.boolean false) - pattern_matching!) - (_.throw (_.string ////synthesis/case.pattern_matching_error)))))) - -(def: #export (case! statement expression archive [valueS pathP]) - (Generator! [Synthesis Path]) - (do ///////phase.monad - [stack_init (expression archive valueS) - pattern_matching! (pattern_matching statement expression archive pathP)] - (wrap ($_ _.then - (_.declare @temp) - (_.define @cursor (_.array (list stack_init))) - (_.define @savepoint (_.array (list))) - pattern_matching!)))) - -(def: #export (case statement expression archive [valueS pathP]) - (-> Phase! (Generator [Synthesis Path])) - (do ///////phase.monad - [pattern_matching! (..case! statement expression archive [valueS pathP])] - (wrap (_.apply/* (_.closure (list) pattern_matching!) (list))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux deleted file mode 100644 index 660ac4991..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux +++ /dev/null @@ -1,122 +0,0 @@ -(.module: - [lux (#- function) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [target - ["_" js (#+ Expression Computation Var Statement)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Phase! Generator)] - ["#." reference] - ["#." case] - ["/#" // #_ - ["#." reference] - ["//#" /// #_ - [analysis (#+ Variant Tuple Abstraction Application Analysis)] - [synthesis (#+ Synthesis)] - ["#." generation (#+ Context)] - ["//#" /// #_ - [arity (#+ Arity)] - ["#." phase ("#\." monad)] - [reference - [variable (#+ Register Variable)]]]]]]) - -(def: #export (apply expression archive [functionS argsS+]) - (Generator (Application Synthesis)) - (do {! ///////phase.monad} - [functionO (expression archive functionS) - argsO+ (monad.map ! (expression archive) argsS+)] - (wrap (_.apply/* functionO argsO+)))) - -(def: capture - (-> Register Var) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: (with_closure @self inits body!) - (-> Var (List Expression) Statement [Statement Expression]) - (case inits - #.Nil - [(_.function! @self (list) body!) - @self] - - _ - [(_.function! @self - (|> (list.enumeration inits) - (list\map (|>> product.left ..capture))) - (_.return (_.function @self (list) body!))) - (_.apply/* @self inits)])) - -(def: @curried - (_.var "curried")) - -(def: input - (|>> inc //case.register)) - -(def: @@arguments - (_.var "arguments")) - -(def: (@scope function_name) - (-> Context Text) - (format (///reference.artifact function_name) "_scope")) - -(def: #export (function statement expression archive [environment arity bodyS]) - (-> Phase! (Generator (Abstraction Synthesis))) - (do {! ///////phase.monad} - [[function_name body!] (/////generation.with_new_context archive - (do ! - [scope (\ ! map ..@scope - (/////generation.context archive))] - (/////generation.with_anchor [1 scope] - (statement expression archive bodyS)))) - #let [arityO (|> arity .int _.i32) - @num_args (_.var "num_args") - @scope (..@scope function_name) - @self (_.var (///reference.artifact function_name)) - apply_poly (.function (_ args func) - (|> func (_.do "apply" (list _.null args)))) - initialize_self! (_.define (//case.register 0) @self) - initialize! (list\fold (.function (_ post pre!) - ($_ _.then - pre! - (_.define (..input post) (_.at (_.i32 (.int post)) @@arguments)))) - initialize_self! - (list.indices arity))] - environment (monad.map ! (expression archive) environment) - #let [[definition instantiation] (with_closure @self environment - ($_ _.then - (_.define @num_args (_.the "length" @@arguments)) - (_.cond (list [(|> @num_args (_.= arityO)) - ($_ _.then - initialize! - (_.with_label (_.label @scope) - (_.do_while (_.boolean true) - body!)))] - [(|> @num_args (_.> arityO)) - (let [arity_inputs (|> (_.array (list)) - (_.the "slice") - (_.do "call" (list @@arguments (_.i32 +0) arityO))) - extra_inputs (|> (_.array (list)) - (_.the "slice") - (_.do "call" (list @@arguments arityO)))] - (_.return (|> @self - (apply_poly arity_inputs) - (apply_poly extra_inputs))))]) - ## (|> @num_args (_.< arityO)) - (let [all_inputs (|> (_.array (list)) - (_.the "slice") - (_.do "call" (list @@arguments)))] - ($_ _.then - (_.define @curried all_inputs) - (_.return (_.closure (list) - (let [@missing all_inputs] - (_.return (apply_poly (_.do "concat" (list @missing) @curried) - @self)))))))) - ))] - _ (/////generation.execute! definition) - _ (/////generation.save! (product.right function_name) definition)] - (wrap instantiation))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/loop.lux deleted file mode 100644 index 135cfeb74..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/loop.lux +++ /dev/null @@ -1,90 +0,0 @@ -(.module: - [lux (#- Scope) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [math - [number - ["n" nat]]] - [target - ["_" js (#+ Computation Var Expression Statement)]]] - ["." // #_ - [runtime (#+ Operation Phase Phase! Generator Generator!)] - ["#." case] - ["///#" //// #_ - [synthesis (#+ Scope Synthesis)] - ["#." generation] - ["//#" /// #_ - ["#." phase] - [reference - [variable (#+ Register)]]]]]) - -(def: @scope - (-> Nat Text) - (|>> %.nat (format "scope"))) - -(def: (setup initial? offset bindings body) - (-> Bit Register (List Expression) Statement Statement) - (|> bindings - list.enumeration - (list\map (function (_ [register value]) - (let [variable (//case.register (n.+ offset register))] - (if initial? - (_.define variable value) - (_.set variable value))))) - list.reverse - (list\fold _.then body))) - -(def: #export (scope! statement expression archive [start initsS+ bodyS]) - (Generator! (Scope Synthesis)) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (statement expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [@scope (\ ! map ..@scope /////generation.next) - initsO+ (monad.map ! (expression archive) initsS+) - body! (/////generation.with_anchor [start @scope] - (statement expression archive bodyS))] - (wrap (..setup true start initsO+ - (_.with_label (_.label @scope) - (_.do_while (_.boolean true) - body!))))))) - -(def: #export (scope statement expression archive [start initsS+ bodyS]) - (-> Phase! (Generator (Scope Synthesis))) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [loop! (scope! statement expression archive [start initsS+ bodyS])] - (wrap (_.apply/* (_.closure (list) loop!) (list)))))) - -(def: @temp - (_.var "lux_recur_values")) - -(def: #export (recur! statement expression archive argsS+) - (Generator! (List Synthesis)) - (do {! ///////phase.monad} - [[offset @scope] /////generation.anchor - argsO+ (monad.map ! (expression archive) argsS+)] - (wrap ($_ _.then - (_.define @temp (_.array argsO+)) - (..setup false offset - (|> argsO+ - list.enumeration - (list\map (function (_ [idx _]) - (_.at (_.i32 (.int idx)) @temp)))) - (_.continue_at (_.label @scope))))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/primitive.lux deleted file mode 100644 index db00d6439..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/primitive.lux +++ /dev/null @@ -1,20 +0,0 @@ -(.module: - [lux (#- i64) - [target - ["_" js (#+ Computation)]]] - ["." // #_ - ["#." runtime]]) - -(def: #export bit - _.boolean) - -(def: #export (i64 value) - (-> (I64 Any) Computation) - (//runtime.i64 (|> value //runtime.high .int _.i32) - (|> value //runtime.low .int _.i32))) - -(def: #export f64 - _.number) - -(def: #export text - _.string) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/reference.lux deleted file mode 100644 index 6361e3d09..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/reference.lux +++ /dev/null @@ -1,12 +0,0 @@ -(.module: - [lux #* - [target - ["_" js (#+ Expression)]]] - [/// - [reference (#+ System)]]) - -(implementation: #export system - (System Expression) - - (def: constant _.var) - (def: variable _.var)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux deleted file mode 100644 index c307f4302..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux +++ /dev/null @@ -1,784 +0,0 @@ -(.module: - [lux (#- i64) - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<.>" code]]] - [data - ["." product] - ["." text ("#\." hash) - ["%" format (#+ format)] - [encoding - ["." utf8]]] - [collection - ["." list ("#\." functor)] - ["." row]]] - ["." macro - [syntax (#+ syntax:)] - ["." code]] - [math - [number (#+ hex) - ["." i64]]] - [target - ["_" js (#+ Expression Var Computation Statement)]] - [tool - [compiler - [language - [lux - ["$" version]]]]]] - ["." /// #_ - ["#." reference] - ["//#" /// #_ - ["#." synthesis (#+ Synthesis)] - ["#." generation] - ["//#" /// - ["#." phase] - [reference - [variable (#+ Register)]] - [meta - [archive (#+ Output Archive) - ["." artifact (#+ Registry)]]]]]]) - -(template [<name> <base>] - [(type: #export <name> - (<base> [Register Text] Expression Statement))] - - [Operation /////generation.Operation] - [Phase /////generation.Phase] - [Handler /////generation.Handler] - [Bundle /////generation.Bundle] - ) - -(type: #export (Generator i) - (-> Phase Archive i (Operation Expression))) - -(type: #export Phase! - (-> Phase Archive Synthesis (Operation Statement))) - -(type: #export (Generator! i) - (-> Phase! Phase Archive i (Operation Statement))) - -(def: #export high - (-> (I64 Any) (I64 Any)) - (i64.right_shift 32)) - -(def: #export low - (-> (I64 Any) (I64 Any)) - (let [mask (dec (i64.left_shift 32 1))] - (|>> (i64.and mask)))) - -(def: #export unit - Computation - (_.string /////synthesis.unit)) - -(def: #export (flag value) - (-> Bit Computation) - (if value - (_.string "") - _.null)) - -(def: (feature name definition) - (-> Var (-> Var Expression) Statement) - (_.define name (definition name))) - -(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} - body) - (do {! meta.monad} - [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] - (wrap (list (` (let [(~+ (|> vars - (list.zip/2 ids) - (list\map (function (_ [id var]) - (list (code.local_identifier var) - (` (_.var (~ (code.text (format "v" (%.nat id))))))))) - list.concat))] - (~ body))))))) - -(syntax: (runtime: {declaration (<>.or <code>.local_identifier - (<code>.form (<>.and <code>.local_identifier - (<>.some <code>.local_identifier))))} - code) - (macro.with_gensyms [g!_ runtime] - (let [runtime_name (` (_.var (~ (code.text (%.code runtime)))))] - (case declaration - (#.Left name) - (let [g!name (code.local_identifier name)] - (wrap (list (` (def: #export (~ g!name) - Var - (~ runtime_name))) - - (` (def: (~ (code.local_identifier (format "@" name))) - Statement - (..feature (~ runtime_name) - (function ((~ g!_) (~ g!name)) - (~ code)))))))) - - (#.Right [name inputs]) - (let [g!name (code.local_identifier name) - inputsC (list\map code.local_identifier inputs) - inputs_typesC (list\map (function.constant (` _.Expression)) inputs)] - (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) - (-> (~+ inputs_typesC) Computation) - (_.apply/* (~ runtime_name) (list (~+ inputsC))))) - - (` (def: (~ (code.local_identifier (format "@" name))) - Statement - (..feature (~ runtime_name) - (function ((~ g!_) (~ g!_)) - (..with_vars [(~+ inputsC)] - (_.function (~ g!_) (list (~+ inputsC)) - (~ code)))))))))))))) - -(def: length - (-> Expression Computation) - (_.the "length")) - -(def: last_index - (-> Expression Computation) - (|>> ..length (_.- (_.i32 +1)))) - -(def: (last_element tuple) - (_.at (..last_index tuple) - tuple)) - -(with_expansions [<recur> (as_is ($_ _.then - (_.set lefts (_.- last_index_right lefts)) - (_.set tuple (_.at last_index_right tuple))))] - (runtime: (tuple//left lefts tuple) - (with_vars [last_index_right] - (<| (_.while (_.boolean true)) - ($_ _.then - (_.define last_index_right (..last_index tuple)) - (_.if (_.> lefts last_index_right) - ## No need for recursion - (_.return (_.at lefts tuple)) - ## Needs recursion - <recur>))))) - - (runtime: (tuple//right lefts tuple) - (with_vars [last_index_right right_index] - (<| (_.while (_.boolean true)) - ($_ _.then - (_.define last_index_right (..last_index tuple)) - (_.define right_index (_.+ (_.i32 +1) lefts)) - (_.cond (list [(_.= last_index_right right_index) - (_.return (_.at right_index tuple))] - [(_.> last_index_right right_index) - ## Needs recursion. - <recur>]) - (_.return (_.do "slice" (list right_index) tuple))) - ))))) - -(def: #export variant_tag_field "_lux_tag") -(def: #export variant_flag_field "_lux_flag") -(def: #export variant_value_field "_lux_value") - -(runtime: variant//new - (let [@this (_.var "this")] - (with_vars [tag is_last value] - (_.closure (list tag is_last value) - ($_ _.then - (_.set (_.the ..variant_tag_field @this) tag) - (_.set (_.the ..variant_flag_field @this) is_last) - (_.set (_.the ..variant_value_field @this) value) - ))))) - -(def: #export (variant tag last? value) - (-> Expression Expression Expression Computation) - (_.new ..variant//new (list tag last? value))) - -(runtime: (sum//get sum wants_last wanted_tag) - (let [no_match! (_.return _.null) - sum_tag (|> sum (_.the ..variant_tag_field)) - sum_flag (|> sum (_.the ..variant_flag_field)) - sum_value (|> sum (_.the ..variant_value_field)) - is_last? (_.= ..unit sum_flag) - extact_match! (_.return sum_value) - test_recursion! (_.if is_last? - ## Must recurse. - ($_ _.then - (_.set wanted_tag (_.- sum_tag wanted_tag)) - (_.set sum sum_value)) - no_match!) - extrac_sub_variant! (_.return (..variant (_.- wanted_tag sum_tag) sum_flag sum_value))] - (<| (_.while (_.boolean true)) - (_.cond (list [(_.= wanted_tag sum_tag) - (_.if (_.= wants_last sum_flag) - extact_match! - test_recursion!)] - [(_.< wanted_tag sum_tag) - test_recursion!] - [(_.= ..unit wants_last) - extrac_sub_variant!]) - no_match!)))) - -(def: none - Computation - (..variant (_.i32 +0) (flag #0) unit)) - -(def: some - (-> Expression Computation) - (..variant (_.i32 +1) (flag #1))) - -(def: left - (-> Expression Computation) - (..variant (_.i32 +0) (flag #0))) - -(def: right - (-> Expression Computation) - (..variant (_.i32 +1) (flag #1))) - -(def: runtime//structure - Statement - ($_ _.then - @tuple//left - @tuple//right - @variant//new - @sum//get - )) - -(runtime: (lux//try op) - (with_vars [ex] - (_.try (_.return (..right (_.apply/1 op ..unit))) - [ex (_.return (..left (|> ex (_.do "toString" (list)))))]))) - -(runtime: (lux//program_args inputs) - (with_vars [output idx] - ($_ _.then - (_.define output ..none) - (_.for idx - (..last_index inputs) - (_.>= (_.i32 +0) idx) - (_.-- idx) - (_.set output (..some (_.array (list (_.at idx inputs) - output))))) - (_.return output)))) - -(def: runtime//lux - Statement - ($_ _.then - @lux//try - @lux//program_args - )) - -(def: #export i64_low_field Text "_lux_low") -(def: #export i64_high_field Text "_lux_high") - -(runtime: i64//new - (let [@this (_.var "this")] - (with_vars [high low] - (_.closure (list high low) - ($_ _.then - (_.set (_.the ..i64_high_field @this) high) - (_.set (_.the ..i64_low_field @this) low) - ))))) - -(def: #export (i64 high low) - (-> Expression Expression Computation) - (_.new ..i64//new (list high low))) - -(runtime: i64//2^16 - (_.left_shift (_.i32 +16) (_.i32 +1))) - -(runtime: i64//2^32 - (_.* i64//2^16 i64//2^16)) - -(runtime: i64//2^64 - (_.* i64//2^32 i64//2^32)) - -(runtime: i64//2^63 - (|> i64//2^64 (_./ (_.i32 +2)))) - -(runtime: (i64//unsigned_low i64) - (_.return (_.? (|> i64 (_.the ..i64_low_field) (_.>= (_.i32 +0))) - (|> i64 (_.the ..i64_low_field)) - (|> i64 (_.the ..i64_low_field) (_.+ i64//2^32))))) - -(runtime: (i64//to_number i64) - (_.return (|> i64 - (_.the ..i64_high_field) - (_.* i64//2^32) - (_.+ (i64//unsigned_low i64))))) - -(runtime: i64//zero - (..i64 (_.i32 +0) (_.i32 +0))) - -(runtime: i64//min - (..i64 (_.i32 (.int (hex "80,00,00,00"))) - (_.i32 +0))) - -(runtime: i64//max - (..i64 (_.i32 (.int (hex "7F,FF,FF,FF"))) - (_.i32 (.int (hex "FF,FF,FF,FF"))))) - -(runtime: i64//one - (..i64 (_.i32 +0) (_.i32 +1))) - -(runtime: (i64//= reference sample) - (_.return (_.and (_.= (_.the ..i64_high_field reference) - (_.the ..i64_high_field sample)) - (_.= (_.the ..i64_low_field reference) - (_.the ..i64_low_field sample))))) - -(runtime: (i64//+ parameter subject) - (let [up_16 (_.left_shift (_.i32 +16)) - high_16 (_.logic_right_shift (_.i32 +16)) - low_16 (_.bit_and (_.i32 (.int (hex "FFFF")))) - hh (|>> (_.the ..i64_high_field) high_16) - hl (|>> (_.the ..i64_high_field) low_16) - lh (|>> (_.the ..i64_low_field) high_16) - ll (|>> (_.the ..i64_low_field) low_16)] - (with_vars [l48 l32 l16 l00 - r48 r32 r16 r00 - x48 x32 x16 x00] - ($_ _.then - (_.define l48 (hh subject)) - (_.define l32 (hl subject)) - (_.define l16 (lh subject)) - (_.define l00 (ll subject)) - - (_.define r48 (hh parameter)) - (_.define r32 (hl parameter)) - (_.define r16 (lh parameter)) - (_.define r00 (ll parameter)) - - (_.define x00 (_.+ l00 r00)) - - (_.define x16 (|> (high_16 x00) - (_.+ l16) - (_.+ r16))) - (_.set x00 (low_16 x00)) - - (_.define x32 (|> (high_16 x16) - (_.+ l32) - (_.+ r32))) - (_.set x16 (low_16 x16)) - - (_.define x48 (|> (high_16 x32) - (_.+ l48) - (_.+ r48) - low_16)) - (_.set x32 (low_16 x32)) - - (_.return (..i64 (_.bit_or (up_16 x48) x32) - (_.bit_or (up_16 x16) x00))) - )))) - -(template [<name> <op>] - [(runtime: (<name> subject parameter) - (_.return (..i64 (<op> (_.the ..i64_high_field subject) - (_.the ..i64_high_field parameter)) - (<op> (_.the ..i64_low_field subject) - (_.the ..i64_low_field parameter)))))] - - [i64//xor _.bit_xor] - [i64//or _.bit_or] - [i64//and _.bit_and] - ) - -(runtime: (i64//not value) - (_.return (..i64 (_.bit_not (_.the ..i64_high_field value)) - (_.bit_not (_.the ..i64_low_field value))))) - -(runtime: (i64//negate value) - (_.return (_.? (i64//= i64//min value) - i64//min - (i64//+ i64//one (i64//not value))))) - -(runtime: i64//-one - (i64//negate i64//one)) - -(runtime: (i64//from_number value) - (_.return (<| (_.? (_.not_a_number? value) - i64//zero) - (_.? (_.<= (_.negate i64//2^63) value) - i64//min) - (_.? (|> value (_.+ (_.i32 +1)) (_.>= i64//2^63)) - i64//max) - (_.? (|> value (_.< (_.i32 +0))) - (|> value _.negate i64//from_number i64//negate)) - (..i64 (|> value (_./ i64//2^32) _.to_i32) - (|> value (_.% i64//2^32) _.to_i32))))) - -(def: (cap_shift! shift) - (-> Var Statement) - (_.set shift (|> shift (_.bit_and (_.i32 +63))))) - -(def: (no_shift! shift input) - (-> Var Var (-> Expression Expression)) - (_.? (|> shift (_.= (_.i32 +0))) - input)) - -(def: small_shift? - (-> Var Expression) - (|>> (_.< (_.i32 +32)))) - -(runtime: (i64//left_shift input shift) - ($_ _.then - (..cap_shift! shift) - (_.return (<| (..no_shift! shift input) - (_.? (..small_shift? shift) - (let [high (_.bit_or (|> input (_.the ..i64_high_field) (_.left_shift shift)) - (|> input (_.the ..i64_low_field) (_.logic_right_shift (_.- shift (_.i32 +32))))) - low (|> input (_.the ..i64_low_field) (_.left_shift shift))] - (..i64 high low))) - (let [high (|> input (_.the ..i64_low_field) (_.left_shift (_.- (_.i32 +32) shift)))] - (..i64 high (_.i32 +0))))) - )) - -(runtime: (i64//arithmetic_right_shift input shift) - ($_ _.then - (..cap_shift! shift) - (_.return (<| (..no_shift! shift input) - (_.? (..small_shift? shift) - (let [high (|> input (_.the ..i64_high_field) (_.arithmetic_right_shift shift)) - low (|> input (_.the ..i64_low_field) (_.logic_right_shift shift) - (_.bit_or (|> input (_.the ..i64_high_field) (_.left_shift (_.- shift (_.i32 +32))))))] - (..i64 high low))) - (let [high (_.? (|> input (_.the ..i64_high_field) (_.>= (_.i32 +0))) - (_.i32 +0) - (_.i32 -1)) - low (|> input (_.the ..i64_high_field) (_.arithmetic_right_shift (_.- (_.i32 +32) shift)))] - (..i64 high low)))))) - -(runtime: (i64//right_shift input shift) - ($_ _.then - (..cap_shift! shift) - (_.return (<| (..no_shift! shift input) - (_.? (..small_shift? shift) - (let [high (|> input (_.the ..i64_high_field) (_.logic_right_shift shift)) - low (|> input (_.the ..i64_low_field) (_.logic_right_shift shift) - (_.bit_or (|> input (_.the ..i64_high_field) (_.left_shift (_.- shift (_.i32 +32))))))] - (..i64 high low))) - (_.? (|> shift (_.= (_.i32 +32))) - (..i64 (_.i32 +0) (|> input (_.the ..i64_high_field)))) - (..i64 (_.i32 +0) - (|> input (_.the ..i64_high_field) (_.logic_right_shift (_.- (_.i32 +32) shift)))))))) - -(def: runtime//bit - Statement - ($_ _.then - @i64//and - @i64//or - @i64//xor - @i64//not - @i64//left_shift - @i64//arithmetic_right_shift - @i64//right_shift - )) - -(runtime: (i64//- parameter subject) - (_.return (i64//+ (i64//negate parameter) subject))) - -(runtime: (i64//* parameter subject) - (let [up_16 (_.left_shift (_.i32 +16)) - high_16 (_.logic_right_shift (_.i32 +16)) - low_16 (_.bit_and (_.i32 (.int (hex "FFFF")))) - hh (|>> (_.the ..i64_high_field) high_16) - hl (|>> (_.the ..i64_high_field) low_16) - lh (|>> (_.the ..i64_low_field) high_16) - ll (|>> (_.the ..i64_low_field) low_16)] - (with_vars [l48 l32 l16 l00 - r48 r32 r16 r00 - x48 x32 x16 x00] - ($_ _.then - (_.define l48 (hh subject)) - (_.define l32 (hl subject)) - (_.define l16 (lh subject)) - (_.define l00 (ll subject)) - - (_.define r48 (hh parameter)) - (_.define r32 (hl parameter)) - (_.define r16 (lh parameter)) - (_.define r00 (ll parameter)) - - (_.define x00 (_.* l00 r00)) - (_.define x16 (high_16 x00)) - (_.set x00 (low_16 x00)) - - (_.set x16 (|> x16 (_.+ (_.* l16 r00)))) - (_.define x32 (high_16 x16)) (_.set x16 (low_16 x16)) - (_.set x16 (|> x16 (_.+ (_.* l00 r16)))) - (_.set x32 (|> x32 (_.+ (high_16 x16)))) (_.set x16 (low_16 x16)) - - (_.set x32 (|> x32 (_.+ (_.* l32 r00)))) - (_.define x48 (high_16 x32)) (_.set x32 (low_16 x32)) - (_.set x32 (|> x32 (_.+ (_.* l16 r16)))) - (_.set x48 (|> x48 (_.+ (high_16 x32)))) (_.set x32 (low_16 x32)) - (_.set x32 (|> x32 (_.+ (_.* l00 r32)))) - (_.set x48 (|> x48 (_.+ (high_16 x32)))) (_.set x32 (low_16 x32)) - - (_.set x48 (|> x48 - (_.+ (_.* l48 r00)) - (_.+ (_.* l32 r16)) - (_.+ (_.* l16 r32)) - (_.+ (_.* l00 r48)) - low_16)) - - (_.return (..i64 (_.bit_or (up_16 x48) x32) - (_.bit_or (up_16 x16) x00))) - )))) - -(runtime: (i64//< parameter subject) - (let [negative? (|>> (_.the ..i64_high_field) (_.< (_.i32 +0)))] - (with_vars [-subject? -parameter?] - ($_ _.then - (_.define -subject? (negative? subject)) - (_.define -parameter? (negative? parameter)) - (_.return (<| (_.? (_.and -subject? (_.not -parameter?)) - (_.boolean true)) - (_.? (_.and (_.not -subject?) -parameter?) - (_.boolean false)) - (negative? (i64//- parameter subject)))) - )))) - -(def: (i64//<= param subject) - (-> Expression Expression Expression) - (|> (i64//< param subject) - (_.or (i64//= param subject)))) - -(runtime: (i64/// parameter subject) - (let [negative? (function (_ value) - (i64//< i64//zero value)) - valid_division_check [(i64//= i64//zero parameter) - (_.throw (_.string "Cannot divide by zero!"))] - short_circuit_check [(i64//= i64//zero subject) - (_.return i64//zero)]] - (_.cond (list valid_division_check - short_circuit_check - - [(i64//= i64//min subject) - (_.cond (list [(_.or (i64//= i64//one parameter) - (i64//= i64//-one parameter)) - (_.return i64//min)] - [(i64//= i64//min parameter) - (_.return i64//one)]) - (with_vars [approximation] - (let [subject/2 (..i64//arithmetic_right_shift subject (_.i32 +1))] - ($_ _.then - (_.define approximation (i64//left_shift (i64/// parameter - subject/2) - (_.i32 +1))) - (_.if (i64//= i64//zero approximation) - (_.return (_.? (negative? parameter) - i64//one - i64//-one)) - (let [remainder (i64//- (i64//* approximation - parameter) - subject)] - (_.return (i64//+ (i64/// parameter - remainder) - approximation))))))))] - [(i64//= i64//min parameter) - (_.return i64//zero)] - - [(negative? subject) - (_.return (_.? (negative? parameter) - (i64/// (i64//negate parameter) - (i64//negate subject)) - (i64//negate (i64/// parameter - (i64//negate subject)))))] - - [(negative? parameter) - (_.return (i64//negate (i64/// (i64//negate parameter) subject)))]) - (with_vars [result remainder] - ($_ _.then - (_.define result i64//zero) - (_.define remainder subject) - (_.while (i64//<= remainder parameter) - (with_vars [approximate approximate_result approximate_remainder log2 delta] - (let [approximate_result' (i64//from_number approximate) - approx_remainder (i64//* parameter approximate_result)] - ($_ _.then - (_.define approximate (|> (i64//to_number remainder) - (_./ (i64//to_number parameter)) - (_.apply/1 (_.var "Math.floor")) - (_.apply/2 (_.var "Math.max") (_.i32 +1)))) - (_.define log2 (|> approximate - (_.apply/1 (_.var "Math.log")) - (_./ (_.var "Math.LN2")) - (_.apply/1 (_.var "Math.ceil")))) - (_.define delta (_.? (_.<= (_.i32 +48) log2) - (_.i32 +1) - (_.apply/2 (_.var "Math.pow") - (_.i32 +2) - (_.- (_.i32 +48) - log2)))) - (_.define approximate_result approximate_result') - (_.define approximate_remainder approx_remainder) - (_.while (_.or (negative? approximate_remainder) - (i64//< approximate_remainder - remainder)) - ($_ _.then - (_.set approximate (_.- delta approximate)) - (_.set approximate_result approximate_result') - (_.set approximate_remainder approx_remainder))) - (_.set result (i64//+ (_.? (i64//= i64//zero approximate_result) - i64//one - approximate_result) - result)) - (_.set remainder (i64//- approximate_remainder remainder)))))) - (_.return result))) - ))) - -(runtime: (i64//% parameter subject) - (let [flat (|> subject - (i64/// parameter) - (i64//* parameter))] - (_.return (i64//- flat subject)))) - -(def: runtime//i64 - Statement - ($_ _.then - @i64//2^16 - @i64//2^32 - @i64//2^64 - @i64//2^63 - @i64//unsigned_low - @i64//new - @i64//zero - @i64//min - @i64//max - @i64//one - @i64//= - @i64//+ - @i64//negate - @i64//to_number - @i64//from_number - @i64//- - @i64//* - @i64//< - @i64/// - @i64//% - runtime//bit - )) - -(runtime: (text//index start part text) - (with_vars [idx] - ($_ _.then - (_.define idx (|> text (_.do "indexOf" (list part (i64//to_number start))))) - (_.return (_.? (_.= (_.i32 -1) idx) - ..none - (..some (i64//from_number idx))))))) - -(runtime: (text//clip offset length text) - (_.return (|> text (_.do "substring" (list (_.the ..i64_low_field offset) - (_.+ (_.the ..i64_low_field offset) - (_.the ..i64_low_field length))))))) - -(runtime: (text//char idx text) - (with_vars [result] - ($_ _.then - (_.define result (|> text (_.do "charCodeAt" (list (_.the ..i64_low_field idx))))) - (_.if (_.not_a_number? result) - (_.throw (_.string "[Lux Error] Cannot get char from text.")) - (_.return (i64//from_number result)))))) - -(def: runtime//text - Statement - ($_ _.then - @text//index - @text//clip - @text//char - )) - -(runtime: (io//log message) - (let [console (_.var "console") - print (_.var "print") - end! (_.return ..unit)] - (_.cond (list [(|> console _.type_of (_.= (_.string "undefined")) _.not - (_.and (_.the "log" console))) - ($_ _.then - (_.statement (|> console (_.do "log" (list message)))) - end!)] - [(|> print _.type_of (_.= (_.string "undefined")) _.not) - ($_ _.then - (_.statement (_.apply/1 print (_.? (_.= (_.string "string") - (_.type_of message)) - message - (_.apply/1 (_.var "JSON.stringify") message)))) - end!)]) - end!))) - -(runtime: (io//error message) - (_.throw message)) - -(def: runtime//io - Statement - ($_ _.then - @io//log - @io//error - )) - -(runtime: (js//get object field) - (with_vars [temp] - ($_ _.then - (_.define temp (_.at field object)) - (_.return (_.? (_.= _.undefined temp) - ..none - (..some temp)))))) - -(runtime: (js//set object field input) - ($_ _.then - (_.set (_.at field object) input) - (_.return object))) - -(runtime: (js//delete object field) - ($_ _.then - (_.delete (_.at field object)) - (_.return object))) - -(def: runtime//js - Statement - ($_ _.then - @js//get - @js//set - @js//delete - )) - -(runtime: (array//write idx value array) - ($_ _.then - (_.set (_.at (_.the ..i64_low_field idx) array) value) - (_.return array))) - -(runtime: (array//delete idx array) - ($_ _.then - (_.delete (_.at (_.the ..i64_low_field idx) array)) - (_.return array))) - -(def: runtime//array - Statement - ($_ _.then - @array//write - @array//delete - )) - -(def: runtime - Statement - ($_ _.then - runtime//structure - runtime//i64 - runtime//text - runtime//io - runtime//js - runtime//array - runtime//lux - )) - -(def: module_id - 0) - -(def: #export generate - (Operation [Registry Output]) - (do ///////phase.monad - [_ (/////generation.execute! ..runtime) - _ (/////generation.save! ..module_id ..runtime)] - (wrap [(|> artifact.empty - artifact.resource - product.right) - (row.row [..module_id - (|> ..runtime - _.code - (\ utf8.codec encode))])]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/structure.lux deleted file mode 100644 index a90b81f7d..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/structure.lux +++ /dev/null @@ -1,37 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [target - ["_" js (#+ Expression)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." primitive] - ["///#" //// #_ - [analysis (#+ Variant Tuple)] - ["#." synthesis (#+ Synthesis)] - ["//#" /// - ["#." phase ("#\." monad)]]]]) - -(def: #export (tuple generate archive elemsS+) - (Generator (Tuple Synthesis)) - (case elemsS+ - #.Nil - (///////phase\wrap //runtime.unit) - - (#.Cons singletonS #.Nil) - (generate archive singletonS) - - _ - (do {! ///////phase.monad} - [elemsT+ (monad.map ! (generate archive) elemsS+)] - (wrap (_.array elemsT+))))) - -(def: #export (variant generate archive [lefts right? valueS]) - (Generator (Variant Synthesis)) - (let [tag (if right? - (inc lefts) - lefts)] - (///////phase\map (//runtime.variant (_.i32 (.int tag)) - (//runtime.flag right?)) - (generate archive valueS)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux deleted file mode 100644 index bb908e4c9..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux +++ /dev/null @@ -1,72 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]]] - ["." / #_ - [runtime (#+ Phase)] - ["#." primitive] - ["#." structure] - ["#." reference] - ["#." function] - ["#." case] - ["#." loop] - ["//#" /// #_ - ["#." extension] - [// - ["." synthesis] - [/// - ["." reference] - ["#" phase ("#\." monad)]]]]]) - -(def: #export (generate archive synthesis) - Phase - (case synthesis - (^template [<tag> <generator>] - [(^ (<tag> value)) - (///\wrap (<generator> value))]) - ([synthesis.bit /primitive.bit] - [synthesis.i64 /primitive.i64] - [synthesis.f64 /primitive.f64] - [synthesis.text /primitive.text]) - - (^ (synthesis.variant variantS)) - (/structure.variant generate archive variantS) - - (^ (synthesis.tuple members)) - (/structure.tuple generate archive members) - - (#synthesis.Reference reference) - (case reference - (#reference.Variable variable) - (/reference.variable archive variable) - - (#reference.Constant constant) - (/reference.constant archive constant)) - - (^ (synthesis.branch/case [valueS pathS])) - (/case.case generate archive [valueS pathS]) - - (^ (synthesis.branch/let [inputS register bodyS])) - (/case.let generate archive [inputS register bodyS]) - - (^ (synthesis.branch/if [conditionS thenS elseS])) - (/case.if generate archive [conditionS thenS elseS]) - - (^ (synthesis.branch/get [path recordS])) - (/case.get generate archive [path recordS]) - - (^ (synthesis.loop/scope scope)) - (/loop.scope generate archive scope) - - (^ (synthesis.loop/recur updates)) - (/loop.recur generate archive updates) - - (^ (synthesis.function/abstraction abstraction)) - (/function.abstraction generate archive abstraction) - - (^ (synthesis.function/apply application)) - (/function.apply generate archive application) - - (#synthesis.Extension extension) - (///extension.apply archive generate extension) - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux deleted file mode 100644 index 010f97349..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux +++ /dev/null @@ -1,265 +0,0 @@ -(.module: - [lux (#- Type if let case int) - [abstract - ["." monad (#+ do)]] - [control - ["." function]] - [data - [number - ["." i32] - ["n" nat]] - [collection - ["." list ("#\." fold)]]] - [target - [jvm - ["_" bytecode (#+ Label Bytecode) ("#\." monad)] - ["." type (#+ Type) - [category (#+ Method)]]]]] - ["." // #_ - ["#." type] - ["#." runtime (#+ Operation Phase Generator)] - ["#." value] - ["#." structure] - [//// - ["." synthesis (#+ Path Synthesis)] - ["." generation] - [/// - ["." phase ("operation\." monad)] - [reference - [variable (#+ Register)]]]]]) - -(def: equals-name - "equals") - -(def: equals-type - (type.method [(list //type.value) type.boolean (list)])) - -(def: (pop-alt stack-depth) - (-> Nat (Bytecode Any)) - (.case stack-depth - 0 (_\wrap []) - 1 _.pop - 2 _.pop2 - _ ## (n.> 2) - ($_ _.compose - _.pop2 - (pop-alt (n.- 2 stack-depth))))) - -(def: int - (-> (I64 Any) (Bytecode Any)) - (|>> .i64 i32.i32 _.int)) - -(def: long - (-> (I64 Any) (Bytecode Any)) - (|>> .int _.long)) - -(def: double - (-> Frac (Bytecode Any)) - (|>> _.double)) - -(def: peek - (Bytecode Any) - ($_ _.compose - _.dup - (//runtime.get //runtime.stack-head))) - -(def: pop - (Bytecode Any) - ($_ _.compose - (//runtime.get //runtime.stack-tail) - (_.checkcast //type.stack))) - -(def: (left-projection lefts) - (-> Nat (Bytecode Any)) - ($_ _.compose - (_.checkcast //type.tuple) - (..int lefts) - (.case lefts - 0 - _.aaload - - lefts - //runtime.left-projection))) - -(def: (right-projection lefts) - (-> Nat (Bytecode Any)) - ($_ _.compose - (_.checkcast //type.tuple) - (..int lefts) - //runtime.right-projection)) - -(def: (path' stack-depth @else @end phase archive path) - (-> Nat Label Label (Generator Path)) - (.case path - #synthesis.Pop - (operation\wrap ..pop) - - (#synthesis.Bind register) - (operation\wrap ($_ _.compose - ..peek - (_.astore register))) - - (#synthesis.Then bodyS) - (do phase.monad - [bodyG (phase archive bodyS)] - (wrap ($_ _.compose - (..pop-alt stack-depth) - bodyG - (_.goto @end)))) - - (^template [<pattern> <right?>] - [(^ (<pattern> lefts)) - (operation\wrap - (do _.monad - [@success _.new-label - @fail _.new-label] - ($_ _.compose - ..peek - (_.checkcast //type.variant) - (//structure.tag lefts <right?>) - (//structure.flag <right?>) - //runtime.case - _.dup - (_.ifnull @fail) - (_.goto @success) - (_.set-label @fail) - _.pop - (_.goto @else) - (_.set-label @success) - //runtime.push)))]) - ([synthesis.side/left false] - [synthesis.side/right true]) - - (^template [<pattern> <projection>] - [(^ (<pattern> lefts)) - (operation\wrap ($_ _.compose - ..peek - (<projection> lefts) - //runtime.push))]) - ([synthesis.member/left ..left-projection] - [synthesis.member/right ..right-projection]) - - ## Extra optimization - (^ (synthesis.path/seq - (synthesis.member/left 0) - (synthesis.!bind-top register thenP))) - (do phase.monad - [thenG (path' stack-depth @else @end phase archive thenP)] - (wrap ($_ _.compose - ..peek - (_.checkcast //type.tuple) - _.iconst-0 - _.aaload - (_.astore register) - thenG))) - - ## Extra optimization - (^template [<pm> <projection>] - [(^ (synthesis.path/seq - (<pm> lefts) - (synthesis.!bind-top register thenP))) - (do phase.monad - [then! (path' stack-depth @else @end phase archive thenP)] - (wrap ($_ _.compose - ..peek - (_.checkcast //type.tuple) - (..int lefts) - <projection> - (_.astore register) - then!)))]) - ([synthesis.member/left //runtime.left-projection] - [synthesis.member/right //runtime.right-projection]) - - (#synthesis.Alt leftP rightP) - (do phase.monad - [@alt-else //runtime.forge-label - left! (path' (inc stack-depth) @alt-else @end phase archive leftP) - right! (path' stack-depth @else @end phase archive rightP)] - (wrap ($_ _.compose - _.dup - left! - (_.set-label @alt-else) - _.pop - right!))) - - (#synthesis.Seq leftP rightP) - (do phase.monad - [left! (path' stack-depth @else @end phase archive leftP) - right! (path' stack-depth @else @end phase archive rightP)] - (wrap ($_ _.compose - left! - right!))) - - _ - (undefined) - )) - -(def: (path @end phase archive path) - (-> Label (Generator Path)) - (do phase.monad - [@else //runtime.forge-label - pathG (..path' 1 @else @end phase archive path)] - (wrap ($_ _.compose - pathG - (_.set-label @else) - _.pop - //runtime.pm-failure - _.aconst-null - (_.goto @end))))) - -(def: #export (if phase archive [conditionS thenS elseS]) - (Generator [Synthesis Synthesis Synthesis]) - (do phase.monad - [conditionG (phase archive conditionS) - thenG (phase archive thenS) - elseG (phase archive elseS)] - (wrap (do _.monad - [@else _.new-label - @end _.new-label] - ($_ _.compose - conditionG - (//value.unwrap type.boolean) - (_.ifeq @else) - thenG - (_.goto @end) - (_.set-label @else) - elseG - (_.set-label @end)))))) - -(def: #export (let phase archive [inputS register bodyS]) - (Generator [Synthesis Register Synthesis]) - (do phase.monad - [inputG (phase archive inputS) - bodyG (phase archive bodyS)] - (wrap ($_ _.compose - inputG - (_.astore register) - bodyG)))) - -(def: #export (get phase archive [path recordS]) - (Generator [(List synthesis.Member) Synthesis]) - (do phase.monad - [recordG (phase archive recordS)] - (wrap (list\fold (function (_ step so-far) - (.let [next (.case step - (#.Left lefts) - (..left-projection lefts) - - (#.Right lefts) - (..right-projection lefts))] - (_.compose so-far next))) - recordG - (list.reverse path))))) - -(def: #export (case phase archive [valueS path]) - (Generator [Synthesis Path]) - (do phase.monad - [@end //runtime.forge-label - valueG (phase archive valueS) - pathG (..path @end phase archive path)] - (wrap ($_ _.compose - _.aconst-null - valueG - //runtime.push - pathG - (_.set-label @end))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/debug.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/debug.lux deleted file mode 100644 index 659dc0799..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/debug.lux +++ /dev/null @@ -1,30 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." io (#+ IO)] - ["." try (#+ Try)]] - [data - [binary (#+ Binary)] - [text - ["%" format (#+ format)]]] - [world - ["." file (#+ File)]]]) - -(def: extension ".class") - -(def: #export (write-class! name bytecode) - (-> Text Binary (IO Text)) - (let [file-path (format name ..extension)] - (do io.monad - [outcome (do (try.with @) - [file (: (IO (Try (File IO))) - (file.get-file io.monad file.default file-path))] - (\ file over-write bytecode))] - (wrap (case outcome - (#try.Success definition) - file-path - - (#try.Failure error) - error))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux deleted file mode 100644 index a456644b8..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux +++ /dev/null @@ -1,134 +0,0 @@ -(.module: - [lux (#- Type) - [abstract - ["." monad (#+ do)]] - [data - [number - ["." i32] - ["n" nat]] - [collection - ["." list ("#\." monoid functor)] - ["." row]] - ["." format #_ - ["#" binary]]] - [target - [jvm - ["." version] - ["." modifier (#+ Modifier) ("#\." monoid)] - ["." field (#+ Field)] - ["." method (#+ Method)] - ["_" bytecode (#+ Label Bytecode) ("#\." monad)] - ["." class (#+ Class)] - ["." type (#+ Type) - [category (#+ Return' Value')] - ["." reflection]] - ["." constant - [pool (#+ Resource)]] - [encoding - ["." name (#+ External Internal)] - ["." unsigned]]]] - [tool - [compiler - [meta - ["." archive (#+ Archive)]]]]] - ["." / #_ - ["#." abstract] - [field - [constant - ["#." arity]] - [variable - ["#." foreign] - ["#." partial]]] - [method - ["#." init] - ["#." new] - ["#." implementation] - ["#." reset] - ["#." apply]] - ["/#" // #_ - ["#." runtime (#+ Operation Phase Generator)] - [//// - [analysis (#+ Environment)] - [synthesis (#+ Synthesis Abstraction Apply)] - ["." generation] - [/// - ["." arity (#+ Arity)] - ["." phase] - [reference - [variable (#+ Register)]]]]]]) - -(def: #export (with generate archive @begin class environment arity body) - (-> Phase Archive Label External (Environment Synthesis) Arity (Bytecode Any) - (Operation [(List (Resource Field)) - (List (Resource Method)) - (Bytecode Any)])) - (let [classT (type.class class (list)) - fields (: (List (Resource Field)) - (list& /arity.constant - (list\compose (/foreign.variables environment) - (/partial.variables arity)))) - methods (: (List (Resource Method)) - (list& (/init.method classT environment arity) - (/reset.method classT environment arity) - (if (arity.multiary? arity) - (|> (n.min arity /arity.maximum) - list.indices - (list\map (|>> inc (/apply.method classT environment arity @begin body))) - (list& (/implementation.method arity @begin body))) - (list (/implementation.method' //runtime.apply::name arity @begin body)))))] - (do phase.monad - [instance (/new.instance generate archive classT environment arity)] - (wrap [fields methods instance])))) - -(def: modifier - (Modifier Class) - ($_ modifier\compose - class.public - class.final)) - -(def: this-offset 1) - -(def: internal - (All [category] - (-> (Type (<| Return' Value' category)) - Internal)) - (|>> type.reflection reflection.reflection name.internal)) - -(def: #export (abstraction generate archive [environment arity bodyS]) - (Generator Abstraction) - (do phase.monad - [@begin //runtime.forge-label - [function-context bodyG] (generation.with-new-context archive - (generation.with-anchor [@begin ..this-offset] - (generate archive bodyS))) - #let [function-class (//runtime.class-name function-context)] - [fields methods instance] (..with generate archive @begin function-class environment arity bodyG) - class (phase.lift (class.class version.v6_0 - ..modifier - (name.internal function-class) - (..internal /abstract.class) (list) - fields - methods - (row.row))) - #let [bytecode (format.run class.writer class)] - _ (generation.execute! [function-class bytecode]) - _ (generation.save! function-class [function-class bytecode])] - (wrap instance))) - -(def: #export (apply generate archive [abstractionS inputsS]) - (Generator Apply) - (do {! phase.monad} - [abstractionG (generate archive abstractionS) - inputsG (monad.map ! (generate archive) inputsS)] - (wrap ($_ _.compose - abstractionG - (|> inputsG - (list.chunk /arity.maximum) - (monad.map _.monad - (function (_ batchG) - ($_ _.compose - (_.checkcast /abstract.class) - (monad.seq _.monad batchG) - (_.invokevirtual /abstract.class //runtime.apply::name (//runtime.apply::type (list.size batchG))) - )))) - )))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/abstract.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/abstract.lux deleted file mode 100644 index 0b4885180..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/abstract.lux +++ /dev/null @@ -1,23 +0,0 @@ -(.module: - [lux (#- Type) - [data - [text - ["%" format]]] - [target - [jvm - ["." type (#+ Type) - [category (#+ Method)]]]]] - [// - [field - [constant - ["." arity]]]]) - -(def: #export artifact_id - 1) - -(def: #export class - (type.class (%.nat artifact_id) (list))) - -(def: #export init - (Type Method) - (type.method [(list arity.type) type.void (list)])) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant.lux deleted file mode 100644 index f3b4a4720..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant.lux +++ /dev/null @@ -1,25 +0,0 @@ -(.module: - [lux (#- Type type) - [data - [collection - ["." row]]] - [target - [jvm - ["." field (#+ Field)] - ["." modifier (#+ Modifier) ("#\." monoid)] - [type (#+ Type) - [category (#+ Value)]] - [constant - [pool (#+ Resource)]]]]]) - -(def: modifier - (Modifier Field) - ($_ modifier\compose - field.public - field.static - field.final - )) - -(def: #export (constant name type) - (-> Text (Type Value) (Resource Field)) - (field.field ..modifier name type (row.row))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux deleted file mode 100644 index 011535ce9..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux +++ /dev/null @@ -1,21 +0,0 @@ -(.module: - [lux (#- type) - [target - [jvm - ["." type] - ["." field (#+ Field)] - [constant - [pool (#+ Resource)]]]]] - ["." // - [///////// - [arity (#+ Arity)]]]) - -(def: #export name "arity") -(def: #export type type.int) - -(def: #export minimum Arity 1) -(def: #export maximum Arity 8) - -(def: #export constant - (Resource Field) - (//.constant ..name ..type)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux deleted file mode 100644 index 478f9d454..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux +++ /dev/null @@ -1,55 +0,0 @@ -(.module: - [lux (#- Type type) - [data - [collection - ["." list ("#\." functor)] - ["." row]]] - [target - [jvm - ["." modifier (#+ Modifier) ("#\." monoid)] - ["." field (#+ Field)] - ["_" bytecode (#+ Bytecode)] - [type (#+ Type) - [category (#+ Value Class)]] - [constant - [pool (#+ Resource)]]]]] - ["." //// #_ - ["#." type] - ["#." reference] - [////// - [reference - [variable (#+ Register)]]]]) - -(def: #export type ////type.value) - -(def: #export (get class name) - (-> (Type Class) Text (Bytecode Any)) - ($_ _.compose - ////reference.this - (_.getfield class name ..type) - )) - -(def: #export (put naming class register value) - (-> (-> Register Text) (Type Class) Register (Bytecode Any) (Bytecode Any)) - ($_ _.compose - ////reference.this - value - (_.putfield class (naming register) ..type))) - -(def: modifier - (Modifier Field) - ($_ modifier\compose - field.private - field.final - )) - -(def: #export (variable name type) - (-> Text (Type Value) (Resource Field)) - (field.field ..modifier name type (row.row))) - -(def: #export (variables naming amount) - (-> (-> Register Text) Nat (List (Resource Field))) - (|> amount - list.indices - (list\map (function (_ register) - (..variable (naming register) ..type))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux deleted file mode 100644 index 1c6bf6455..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux +++ /dev/null @@ -1,39 +0,0 @@ -(.module: - [lux (#- Type) - [data - [collection - ["." list] - ["." row]]] - [target - [jvm - ["_" bytecode (#+ Bytecode)] - ["." field (#+ Field)] - [constant - [pool (#+ Resource)]] - [type (#+ Type) - [category (#+ Value Class)]]]]] - ["." // - ["///#" //// #_ - ["#." reference] - [//// - [analysis (#+ Environment)] - [synthesis (#+ Synthesis)] - [/// - [reference - [variable (#+ Register)]]]]]]) - -(def: #export (closure environment) - (-> (Environment Synthesis) (List (Type Value))) - (list.repeat (list.size environment) //.type)) - -(def: #export (get class register) - (-> (Type Class) Register (Bytecode Any)) - (//.get class (/////reference.foreign-name register))) - -(def: #export (put class register value) - (-> (Type Class) Register (Bytecode Any) (Bytecode Any)) - (//.put /////reference.foreign-name class register value)) - -(def: #export variables - (-> (Environment Synthesis) (List (Resource Field))) - (|>> list.size (//.variables /////reference.foreign-name))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux deleted file mode 100644 index ff1599a0c..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux +++ /dev/null @@ -1,58 +0,0 @@ -(.module: - [lux (#- Type) - [abstract - ["." monad]] - [data - [number - ["n" nat]] - [collection - ["." list ("#\." functor)] - ["." row]]] - [target - [jvm - ["." field (#+ Field)] - ["_" bytecode (#+ Label Bytecode) ("#\." monad)] - [type (#+ Type) - [category (#+ Class)]] - [constant - [pool (#+ Resource)]]]]] - ["." / #_ - ["#." count] - ["/#" // - ["/#" // #_ - [constant - ["#." arity]] - ["//#" /// #_ - ["#." reference] - [////// - ["." arity (#+ Arity)] - [reference - [variable (#+ Register)]]]]]]]) - -(def: #export (initial amount) - (-> Nat (Bytecode Any)) - ($_ _.compose - (|> _.aconst-null - (list.repeat amount) - (monad.seq _.monad)) - (_\wrap []))) - -(def: #export (get class register) - (-> (Type Class) Register (Bytecode Any)) - (//.get class (/////reference.partial-name register))) - -(def: #export (put class register value) - (-> (Type Class) Register (Bytecode Any) (Bytecode Any)) - (//.put /////reference.partial-name class register value)) - -(def: #export variables - (-> Arity (List (Resource Field))) - (|>> (n.- ///arity.minimum) (//.variables /////reference.partial-name))) - -(def: #export (new arity) - (-> Arity (Bytecode Any)) - (if (arity.multiary? arity) - ($_ _.compose - /count.initial - (initial (n.- ///arity.minimum arity))) - (_\wrap []))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial/count.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial/count.lux deleted file mode 100644 index dbafd7ee5..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial/count.lux +++ /dev/null @@ -1,30 +0,0 @@ -(.module: - [lux (#- type) - [control - ["." try]] - [target - [jvm - ["_" bytecode (#+ Bytecode)] - [encoding - [name (#+ External)] - ["." signed]] - ["." type]]]] - ["." ///// #_ - ["#." abstract]]) - -(def: #export field "partials") -(def: #export type type.int) - -(def: #export initial - (Bytecode Any) - (|> +0 signed.s1 try.assume _.bipush)) - -(def: this - _.aload_0) - -(def: #export value - (Bytecode Any) - ($_ _.compose - ..this - (_.getfield /////abstract.class ..field ..type) - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method.lux deleted file mode 100644 index a6de97cc3..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method.lux +++ /dev/null @@ -1,13 +0,0 @@ -(.module: - [lux #* - [target - [jvm - ["." modifier (#+ Modifier) ("#\." monoid)] - ["." method (#+ Method)]]]]) - -(def: #export modifier - (Modifier Method) - ($_ modifier\compose - method.public - method.strict - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux deleted file mode 100644 index 581cce970..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux +++ /dev/null @@ -1,156 +0,0 @@ -(.module: - [lux (#- Type type) - [abstract - ["." monad (#+ do)]] - [control - ["." try]] - [data - [number - ["n" nat] - ["i" int] - ["." i32]] - [collection - ["." list ("#\." monoid functor)]]] - [target - [jvm - ["_" bytecode (#+ Label Bytecode) ("#\." monad)] - ["." method (#+ Method)] - [constant - [pool (#+ Resource)]] - [encoding - ["." signed]] - ["." type (#+ Type) - ["." category (#+ Class)]]]]] - ["." // - ["#." reset] - ["#." implementation] - ["#." init] - ["/#" // #_ - ["#." abstract] - [field - [constant - ["#." arity]] - [variable - ["#." partial - ["#/." count]] - ["#." foreign]]] - ["/#" // #_ - ["#." runtime] - ["#." value] - ["#." reference] - [//// - [analysis (#+ Environment)] - [synthesis (#+ Synthesis)] - [/// - [arity (#+ Arity)] - [reference - [variable (#+ Register)]]]]]]]) - -(def: (increment by) - (-> Nat (Bytecode Any)) - ($_ _.compose - (<| _.int .i64 by) - _.iadd)) - -(def: (inputs offset amount) - (-> Register Nat (Bytecode Any)) - ($_ _.compose - (|> amount - list.indices - (monad.map _.monad (|>> (n.+ offset) _.aload))) - (_\wrap []) - )) - -(def: (apply offset amount) - (-> Register Nat (Bytecode Any)) - (let [arity (n.min amount ///arity.maximum)] - ($_ _.compose - (_.checkcast ///abstract.class) - (..inputs offset arity) - (_.invokevirtual ///abstract.class ////runtime.apply::name (////runtime.apply::type arity)) - (if (n.> ///arity.maximum amount) - (apply (n.+ ///arity.maximum offset) - (n.- ///arity.maximum amount)) - (_\wrap [])) - ))) - -(def: this-offset 1) - -(def: #export (method class environment function-arity @begin body apply-arity) - (-> (Type Class) (Environment Synthesis) Arity Label (Bytecode Any) Arity (Resource Method)) - (let [num-partials (dec function-arity) - over-extent (i.- (.int apply-arity) - (.int function-arity))] - (method.method //.modifier ////runtime.apply::name - (////runtime.apply::type apply-arity) - (list) - (#.Some (case num-partials - 0 ($_ _.compose - ////reference.this - (..inputs ..this-offset apply-arity) - (_.invokevirtual class //implementation.name (//implementation.type function-arity)) - _.areturn) - _ (do _.monad - [@default _.new-label - @labelsH _.new-label - @labelsT (|> _.new-label - (list.repeat (dec num-partials)) - (monad.seq _.monad)) - #let [cases (|> (list\compose (#.Cons [@labelsH @labelsT]) - (list @default)) - list.enumeration - (list\map (function (_ [stage @case]) - (let [current-partials (|> (list.indices stage) - (list\map (///partial.get class)) - (monad.seq _.monad)) - already-partial? (n.> 0 stage) - exact-match? (i.= over-extent (.int stage)) - has-more-than-necessary? (i.> over-extent (.int stage))] - ($_ _.compose - (_.set-label @case) - (cond exact-match? - ($_ _.compose - ////reference.this - (if already-partial? - (_.invokevirtual class //reset.name (//reset.type class)) - (_\wrap [])) - current-partials - (..inputs ..this-offset apply-arity) - (_.invokevirtual class //implementation.name (//implementation.type function-arity)) - _.areturn) - - has-more-than-necessary? - (let [inputs-to-completion (|> function-arity (n.- stage)) - inputs-left (|> apply-arity (n.- inputs-to-completion))] - ($_ _.compose - ////reference.this - (_.invokevirtual class //reset.name (//reset.type class)) - current-partials - (..inputs ..this-offset inputs-to-completion) - (_.invokevirtual class //implementation.name (//implementation.type function-arity)) - (apply (n.+ ..this-offset inputs-to-completion) inputs-left) - _.areturn)) - - ## (i.< over-extent (.int stage)) - (let [current-environment (|> (list.indices (list.size environment)) - (list\map (///foreign.get class)) - (monad.seq _.monad)) - missing-partials (|> _.aconst-null - (list.repeat (|> num-partials (n.- apply-arity) (n.- stage))) - (monad.seq _.monad))] - ($_ _.compose - (_.new class) - _.dup - current-environment - ///partial/count.value - (..increment apply-arity) - current-partials - (..inputs ..this-offset apply-arity) - missing-partials - (_.invokevirtual class //init.name (//init.type environment function-arity)) - _.areturn))))))) - (monad.seq _.monad))]] - ($_ _.compose - ///partial/count.value - (_.tableswitch (try.assume (signed.s4 +0)) @default [@labelsH @labelsT]) - cases))))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux deleted file mode 100644 index 000bdf569..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux +++ /dev/null @@ -1,41 +0,0 @@ -(.module: - [lux (#- Type type) - [data - [collection - ["." list]]] - [target - [jvm - ["." method (#+ Method)] - ["_" bytecode (#+ Label Bytecode)] - [constant - [pool (#+ Resource)]] - ["." type (#+ Type) - ["." category]]]]] - ["." // - ["//#" /// #_ - ["#." type] - [////// - [arity (#+ Arity)]]]]) - -(def: #export name "impl") - -(def: #export (type arity) - (-> Arity (Type category.Method)) - (type.method [(list.repeat arity ////type.value) - ////type.value - (list)])) - -(def: #export (method' name arity @begin body) - (-> Text Arity Label (Bytecode Any) (Resource Method)) - (method.method //.modifier name - (..type arity) - (list) - (#.Some ($_ _.compose - (_.set-label @begin) - body - _.areturn - )))) - -(def: #export method - (-> Arity Label (Bytecode Any) (Resource Method)) - (method' ..name)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux deleted file mode 100644 index fe8b824c9..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux +++ /dev/null @@ -1,97 +0,0 @@ -(.module: - [lux (#- Type type) - [abstract - ["." monad]] - [control - ["." try]] - [data - [number - ["n" nat]] - [collection - ["." list ("#\." monoid functor)]]] - [target - [jvm - ["_" bytecode (#+ Bytecode)] - ["." method (#+ Method)] - [encoding - ["." unsigned]] - [constant - [pool (#+ Resource)]] - ["." type (#+ Type) - ["." category (#+ Class Value)]]]]] - ["." // - ["#." implementation] - ["/#" // #_ - ["#." abstract] - [field - [constant - ["#." arity]] - [variable - ["#." foreign] - ["#." partial]]] - ["/#" // #_ - ["#." type] - ["#." reference] - [//// - [analysis (#+ Environment)] - [synthesis (#+ Synthesis)] - [/// - ["." arity (#+ Arity)] - [reference - [variable (#+ Register)]]]]]]]) - -(def: #export name "<init>") - -(def: (partials arity) - (-> Arity (List (Type Value))) - (list.repeat (dec arity) ////type.value)) - -(def: #export (type environment arity) - (-> (Environment Synthesis) Arity (Type category.Method)) - (type.method [(list\compose (///foreign.closure environment) - (if (arity.multiary? arity) - (list& ///arity.type (..partials arity)) - (list))) - type.void - (list)])) - -(def: no-partials (|> 0 unsigned.u1 try.assume _.bipush)) - -(def: #export (super environment-size arity) - (-> Nat Arity (Bytecode Any)) - (let [arity-register (inc environment-size)] - ($_ _.compose - (if (arity.unary? arity) - ..no-partials - (_.iload arity-register)) - (_.invokespecial ///abstract.class ..name ///abstract.init)))) - -(def: (store-all amount put offset) - (-> Nat - (-> Register (Bytecode Any) (Bytecode Any)) - (-> Register Register) - (Bytecode Any)) - (|> (list.indices amount) - (list\map (function (_ register) - (put register - (_.aload (offset register))))) - (monad.seq _.monad))) - -(def: #export (method class environment arity) - (-> (Type Class) (Environment Synthesis) Arity (Resource Method)) - (let [environment-size (list.size environment) - offset-foreign (: (-> Register Register) - (n.+ 1)) - offset-arity (: (-> Register Register) - (|>> offset-foreign (n.+ environment-size))) - offset-partial (: (-> Register Register) - (|>> offset-arity (n.+ 1)))] - (method.method //.modifier ..name - (..type environment arity) - (list) - (#.Some ($_ _.compose - ////reference.this - (..super environment-size arity) - (store-all environment-size (///foreign.put class) offset-foreign) - (store-all (dec arity) (///partial.put class) offset-partial) - _.return))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux deleted file mode 100644 index 7bf1b0bd8..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux +++ /dev/null @@ -1,80 +0,0 @@ -(.module: - [lux (#- Type type) - [abstract - ["." monad (#+ do)]] - [data - [number - ["n" nat]] - [collection - ["." list]]] - [target - [jvm - ["." field (#+ Field)] - ["." method (#+ Method)] - ["_" bytecode (#+ Bytecode)] - ["." constant - [pool (#+ Resource)]] - [type (#+ Type) - ["." category (#+ Class Value Return)]]]] - [tool - [compiler - [meta - ["." archive (#+ Archive)]]]]] - ["." // - ["#." init] - ["#." implementation] - ["/#" // #_ - [field - [constant - ["#." arity]] - [variable - ["#." foreign] - ["#." partial]]] - ["/#" // #_ - [runtime (#+ Operation Phase)] - ["#." value] - ["#." reference] - [//// - [analysis (#+ Environment)] - [synthesis (#+ Synthesis)] - [/// - ["." arity (#+ Arity)] - ["." phase]]]]]]) - -(def: #export (instance' foreign-setup class environment arity) - (-> (List (Bytecode Any)) (Type Class) (Environment Synthesis) Arity (Bytecode Any)) - ($_ _.compose - (_.new class) - _.dup - (monad.seq _.monad foreign-setup) - (///partial.new arity) - (_.invokespecial class //init.name (//init.type environment arity)))) - -(def: #export (instance generate archive class environment arity) - (-> Phase Archive (Type Class) (Environment Synthesis) Arity (Operation (Bytecode Any))) - (do {! phase.monad} - [foreign* (monad.map ! (generate archive) environment)] - (wrap (instance' foreign* class environment arity)))) - -(def: #export (method class environment arity) - (-> (Type Class) (Environment Synthesis) Arity (Resource Method)) - (let [after-this (: (-> Nat Nat) - (n.+ 1)) - environment-size (list.size environment) - after-environment (: (-> Nat Nat) - (|>> after-this (n.+ environment-size))) - after-arity (: (-> Nat Nat) - (|>> after-environment (n.+ 1)))] - (method.method //.modifier //init.name - (//init.type environment arity) - (list) - (#.Some ($_ _.compose - ////reference.this - (//init.super environment-size arity) - (monad.map _.monad (function (_ register) - (///foreign.put class register (_.aload (after-this register)))) - (list.indices environment-size)) - (monad.map _.monad (function (_ register) - (///partial.put class register (_.aload (after-arity register)))) - (list.indices (n.- ///arity.minimum arity))) - _.areturn))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/reset.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/reset.lux deleted file mode 100644 index 9793da801..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/reset.lux +++ /dev/null @@ -1,49 +0,0 @@ -(.module: - [lux (#- Type type) - [data - [collection - ["." list ("#\." functor)]]] - [target - [jvm - ["." method (#+ Method)] - ["_" bytecode (#+ Bytecode)] - [constant - [pool (#+ Resource)]] - ["." type (#+ Type) - ["." category (#+ Class)]]]]] - ["." // - ["#." new] - ["/#" // #_ - [field - [variable - ["#." foreign]]] - ["/#" // #_ - ["#." reference] - [//// - [analysis (#+ Environment)] - [synthesis (#+ Synthesis)] - [/// - ["." arity (#+ Arity)]]]]]]) - -(def: #export name "reset") - -(def: #export (type class) - (-> (Type Class) (Type category.Method)) - (type.method [(list) class (list)])) - -(def: (current-environment class) - (-> (Type Class) (Environment Synthesis) (List (Bytecode Any))) - (|>> list.size - list.indices - (list\map (///foreign.get class)))) - -(def: #export (method class environment arity) - (-> (Type Class) (Environment Synthesis) Arity (Resource Method)) - (method.method //.modifier ..name - (..type class) - (list) - (#.Some ($_ _.compose - (if (arity.multiary? arity) - (//new.instance' (..current-environment class environment) class environment arity) - ////reference.this) - _.areturn)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/host.lux deleted file mode 100644 index 0e7a2c776..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/host.lux +++ /dev/null @@ -1,160 +0,0 @@ -(.module: - [lux (#- Definition) - ["." ffi (#+ import: do-to object)] - [abstract - [monad (#+ do)]] - [control - pipe - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["." io (#+ IO io)] - [concurrency - ["." atom (#+ Atom atom)]]] - [data - [binary (#+ Binary)] - ["." product] - ["." text ("#\." hash) - ["%" format (#+ format)]] - [collection - ["." array] - ["." dictionary (#+ Dictionary)] - ["." row]] - ["." format #_ - ["#" binary]]] - [target - [jvm - ["." loader (#+ Library)] - ["_" bytecode (#+ Bytecode)] - ["." modifier (#+ Modifier) ("#\." monoid)] - ["." field (#+ Field)] - ["." method (#+ Method)] - ["." version] - ["." class (#+ Class)] - ["." encoding #_ - ["#/." name]] - ["." type - ["." descriptor]]]] - [tool - [compiler - ["." name]]]] - ["." // #_ - ["#." runtime (#+ Definition)]] - ) - -(import: java/lang/reflect/Field - (get [#? java/lang/Object] #try #? java/lang/Object)) - -(import: (java/lang/Class a) - (getField [java/lang/String] #try java/lang/reflect/Field)) - -(import: java/lang/Object - (getClass [] (java/lang/Class java/lang/Object))) - -(import: java/lang/ClassLoader) - -(def: value::field "value") -(def: value::type (type.class "java.lang.Object" (list))) -(def: value::modifier ($_ modifier\compose field.public field.final field.static)) - -(def: init::type (type.method [(list) type.void (list)])) -(def: init::modifier ($_ modifier\compose method.public method.static method.strict)) - -(exception: #export (cannot-load {class Text} {error Text}) - (exception.report - ["Class" class] - ["Error" error])) - -(exception: #export (invalid-field {class Text} {field Text} {error Text}) - (exception.report - ["Class" class] - ["Field" field] - ["Error" error])) - -(exception: #export (invalid-value {class Text}) - (exception.report - ["Class" class])) - -(def: (class-value class-name class) - (-> Text (java/lang/Class java/lang/Object) (Try Any)) - (case (java/lang/Class::getField ..value::field class) - (#try.Success field) - (case (java/lang/reflect/Field::get #.None field) - (#try.Success ?value) - (case ?value - (#.Some value) - (#try.Success value) - - #.None - (exception.throw ..invalid-value [class-name])) - - (#try.Failure error) - (exception.throw ..cannot-load [class-name error])) - - (#try.Failure error) - (exception.throw ..invalid-field [class-name ..value::field error]))) - -(def: class-path-separator ".") - -(def: (evaluate! library loader eval-class valueG) - (-> Library java/lang/ClassLoader Text (Bytecode Any) (Try [Any Definition])) - (let [bytecode-name (text.replace-all class-path-separator .module-separator eval-class) - bytecode (class.class version.v6_0 - class.public - (encoding/name.internal bytecode-name) - (encoding/name.internal "java.lang.Object") (list) - (list (field.field ..value::modifier ..value::field ..value::type (row.row))) - (list (method.method ..init::modifier "<clinit>" ..init::type - (list) - (#.Some - ($_ _.compose - valueG - (_.putstatic (type.class bytecode-name (list)) ..value::field ..value::type) - _.return)))) - (row.row))] - (io.run (do {! (try.with io.monad)} - [bytecode (\ ! map (format.run class.writer) - (io.io bytecode)) - _ (loader.store eval-class bytecode library) - class (loader.load eval-class loader) - value (\ io.monad wrap (class-value eval-class class))] - (wrap [value - [eval-class bytecode]]))))) - -(def: (execute! library loader temp-label [class-name class-bytecode]) - (-> Library java/lang/ClassLoader Text Definition (Try Any)) - (io.run (do (try.with io.monad) - [existing-class? (|> (atom.read library) - (\ io.monad map (function (_ library) - (dictionary.key? library class-name))) - (try.lift io.monad) - (: (IO (Try Bit)))) - _ (if existing-class? - (wrap []) - (loader.store class-name class-bytecode library))] - (loader.load class-name loader)))) - -(def: (define! library loader [module name] valueG) - (-> Library java/lang/ClassLoader Name (Bytecode Any) (Try [Text Any Definition])) - (let [class-name (format (text.replace-all .module-separator class-path-separator module) - class-path-separator (name.normalize name) - "___" (%.nat (text\hash name)))] - (do try.monad - [[value definition] (evaluate! library loader class-name valueG)] - (wrap [class-name value definition])))) - -(def: #export host - (IO //runtime.Host) - (io (let [library (loader.new-library []) - loader (loader.memory library)] - (: //runtime.Host - (implementation - (def: (evaluate! temp-label valueG) - (let [eval-class (|> temp-label name.normalize (text.replace-all " " "$"))] - (\ try.monad map product.left - (..evaluate! library loader eval-class valueG)))) - - (def: execute! - (..execute! library loader)) - - (def: define! - (..define! library loader))))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux deleted file mode 100644 index 2640f28ce..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux +++ /dev/null @@ -1,89 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function]] - [data - ["." product] - [number - ["n" nat]] - [collection - ["." list ("#\." functor)]]] - [target - [jvm - ["_" bytecode (#+ Label Bytecode) ("#\." monad)]]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." value] - [//// - ["." synthesis (#+ Path Synthesis)] - ["." generation] - [/// - ["." phase] - [reference - [variable (#+ Register)]]]]]) - -(def: (invariant? register changeS) - (-> Register Synthesis Bit) - (case changeS - (^ (synthesis.variable/local var)) - (n.= register var) - - _ - false)) - -(def: no-op - (_\wrap [])) - -(def: #export (recur translate archive updatesS) - (Generator (List Synthesis)) - (do {! phase.monad} - [[@begin offset] generation.anchor - updatesG (|> updatesS - list.enumeration - (list\map (function (_ [index updateS]) - [(n.+ offset index) updateS])) - (monad.map ! (function (_ [register updateS]) - (if (invariant? register updateS) - (wrap [..no-op - ..no-op]) - (do ! - [fetchG (translate archive updateS) - #let [storeG (_.astore register)]] - (wrap [fetchG storeG]))))))] - (wrap ($_ _.compose - ## It may look weird that first I fetch all the values separately, - ## and then I store them all. - ## It must be done that way in order to avoid a potential bug. - ## Let's say that you'll recur with 2 expressions: X and Y. - ## If Y depends on the value of X, and you don't perform fetches - ## and stores separately, then by the time Y is evaluated, it - ## will refer to the new value of X, instead of the old value, as - ## should be the case. - (|> updatesG - (list\map product.left) - (monad.seq _.monad)) - (|> updatesG - list.reverse - (list\map product.right) - (monad.seq _.monad)) - (_.goto @begin))))) - -(def: #export (scope translate archive [offset initsS+ iterationS]) - (Generator [Nat (List Synthesis) Synthesis]) - (do {! phase.monad} - [@begin //runtime.forge-label - initsI+ (monad.map ! (translate archive) initsS+) - iterationG (generation.with-anchor [@begin offset] - (translate archive iterationS)) - #let [initializationG (|> (list.enumeration initsI+) - (list\map (function (_ [index initG]) - ($_ _.compose - initG - (_.astore (n.+ offset index))))) - (monad.seq _.monad))]] - (wrap ($_ _.compose - initializationG - (_.set-label @begin) - iterationG)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/primitive.lux deleted file mode 100644 index b23d41726..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/primitive.lux +++ /dev/null @@ -1,120 +0,0 @@ -(.module: - [lux (#- i64) - ["." ffi (#+ import:)] - [abstract - [monad (#+ do)]] - [target - [jvm - ["_" bytecode (#+ Bytecode)] - ["." type] - [encoding - ["." signed]]]]] - ["." // #_ - ["#." runtime]]) - -(def: $Boolean (type.class "java.lang.Boolean" (list))) -(def: $Long (type.class "java.lang.Long" (list))) -(def: $Double (type.class "java.lang.Double" (list))) - -(def: #export (bit value) - (-> Bit (Bytecode Any)) - (_.getstatic $Boolean (if value "TRUE" "FALSE") $Boolean)) - -(def: wrap-i64 - (_.invokestatic $Long "valueOf" (type.method [(list type.long) $Long (list)]))) - -(def: #export (i64 value) - (-> (I64 Any) (Bytecode Any)) - (case (.int value) - (^template [<int> <instruction>] - [<int> - (do _.monad - [_ <instruction>] - ..wrap-i64)]) - ([+0 _.lconst-0] - [+1 _.lconst-1]) - - (^template [<int> <instruction>] - [<int> - (do _.monad - [_ <instruction> - _ _.i2l] - ..wrap-i64)]) - ([-1 _.iconst-m1] - ## [+0 _.iconst-0] - ## [+1 _.iconst-1] - [+2 _.iconst-2] - [+3 _.iconst-3] - [+4 _.iconst-4] - [+5 _.iconst-5]) - - value - (case (signed.s1 value) - (#try.Success value) - (do _.monad - [_ (_.bipush value) - _ _.i2l] - ..wrap-i64) - - (#try.Failure _) - (case (signed.s2 value) - (#try.Success value) - (do _.monad - [_ (_.sipush value) - _ _.i2l] - ..wrap-i64) - - (#try.Failure _) - (do _.monad - [_ (_.long value)] - ..wrap-i64))))) - -(def: wrap-f64 - (_.invokestatic $Double "valueOf" (type.method [(list type.double) $Double (list)]))) - -(import: java/lang/Double - (#static doubleToRawLongBits #manual [double] int)) - -(def: #export (f64 value) - (-> Frac (Bytecode Any)) - (case value - (^template [<int> <instruction>] - [<int> - (do _.monad - [_ <instruction>] - ..wrap-f64)]) - ([+1.0 _.dconst-1]) - - (^template [<int> <instruction>] - [<int> - (do _.monad - [_ <instruction> - _ _.f2d] - ..wrap-f64)]) - ([+2.0 _.fconst-2]) - - (^template [<int> <instruction>] - [<int> - (do _.monad - [_ <instruction> - _ _.i2d] - ..wrap-f64)]) - ([-1.0 _.iconst-m1] - ## [+0.0 _.iconst-0] - ## [+1.0 _.iconst-1] - [+2.0 _.iconst-2] - [+3.0 _.iconst-3] - [+4.0 _.iconst-4] - [+5.0 _.iconst-5]) - - _ - (let [constantI (if (i.= ..d0-bits - (java/lang/Double::doubleToRawLongBits (:as java/lang/Double value))) - _.dconst-0 - (_.double value))] - (do _.monad - [_ constantI] - ..wrap-f64)))) - -(def: #export text - _.string) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/program.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/program.lux deleted file mode 100644 index 6166f14c1..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/program.lux +++ /dev/null @@ -1,143 +0,0 @@ -(.module: - [lux (#- Definition) - [abstract - [monad (#+ do)]] - [control - ["." try]] - [data - [collection - ["." row]] - ["." format #_ - ["#" binary]]] - [target - [jvm - ["_" bytecode (#+ Bytecode)] - ["." modifier (#+ Modifier) ("#\." monoid)] - ["." method (#+ Method)] - ["." version] - ["." class (#+ Class)] - [encoding - ["." name]] - ["." type - ["." reflection]]]]] - ["." // - ["#." runtime (#+ Definition)] - ["#." function/abstract]]) - -(def: #export class "LuxProgram") - -(def: ^Object (type.class "java.lang.Object" (list))) -(def: ^String (type.class "java.lang.String" (list))) -(def: ^Args (type.array ^String)) - -(def: main::type (type.method [(list ..^Args) type.void (list)])) - -(def: main::modifier - (Modifier Method) - ($_ modifier\compose - method.public - method.static - method.strict - )) - -(def: program::modifier - (Modifier Class) - ($_ modifier\compose - class.public - class.final - )) - -(def: nil //runtime.none-injection) - -(def: amount-of-inputs - (Bytecode Any) - ($_ _.compose - _.aload-0 - _.arraylength)) - -(def: decrease - (Bytecode Any) - ($_ _.compose - _.iconst-1 - _.isub)) - -(def: head - (Bytecode Any) - ($_ _.compose - _.dup - _.aload-0 - _.swap - _.aaload - _.swap - _.dup-x2 - _.pop)) - -(def: pair - (Bytecode Any) - ($_ _.compose - _.iconst-2 - (_.anewarray ^Object) - _.dup-x1 - _.swap - _.iconst-0 - _.swap - _.aastore - _.dup-x1 - _.swap - _.iconst-1 - _.swap - _.aastore)) - -(def: cons //runtime.right-injection) - -(def: input-list - (Bytecode Any) - (do _.monad - [@loop _.new-label - @end _.new-label] - ($_ _.compose - ..nil - ..amount-of-inputs - (_.set-label @loop) - ..decrease - _.dup - (_.iflt @end) - ..head - ..pair - ..cons - _.swap - (_.goto @loop) - (_.set-label @end) - _.pop))) - -(def: feed-inputs //runtime.apply) - -(def: run-io - (Bytecode Any) - ($_ _.compose - (_.checkcast //function/abstract.class) - _.aconst-null - //runtime.apply)) - -(def: #export (program program) - (-> (Bytecode Any) Definition) - (let [super-class (|> ..^Object type.reflection reflection.reflection name.internal) - main (method.method ..main::modifier "main" ..main::type - (list) - (#.Some ($_ _.compose - program - ..input-list - ..feed-inputs - ..run-io - _.return)))] - [..class - (<| (format.run class.writer) - try.assume - (class.class version.v6_0 - ..program::modifier - (name.internal ..class) - super-class - (list) - (list) - (list main) - (row.row)))])) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux deleted file mode 100644 index edffd87ff..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux +++ /dev/null @@ -1,66 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [data - [text - ["%" format (#+ format)]]] - [target - [jvm - ["_" bytecode (#+ Bytecode)] - ["." type] - [encoding - ["." unsigned]]]]] - ["." // #_ - ["#." runtime (#+ Operation)] - ["#." value] - ["#." type] - ["//#" /// #_ - [// - ["." generation] - [/// - ["#" phase ("operation\." monad)] - [reference - ["." variable (#+ Register Variable)]] - [meta - [archive (#+ Archive)]]]]]]) - -(def: #export this - (Bytecode Any) - _.aload-0) - -(template [<name> <prefix>] - [(def: #export <name> - (-> Register Text) - (|>> %.nat (format <prefix>)))] - - [foreign-name "f"] - [partial-name "p"] - ) - -(def: (foreign archive variable) - (-> Archive Register (Operation (Bytecode Any))) - (do {! ////.monad} - [bytecode-name (\ ! map //runtime.class-name - (generation.context archive))] - (wrap ($_ _.compose - ..this - (_.getfield (type.class bytecode-name (list)) - (..foreign-name variable) - //type.value))))) - -(def: #export (variable archive variable) - (-> Archive Variable (Operation (Bytecode Any))) - (case variable - (#variable.Local variable) - (operation\wrap (_.aload variable)) - - (#variable.Foreign variable) - (..foreign archive variable))) - -(def: #export (constant archive name) - (-> Archive Name (Operation (Bytecode Any))) - (do {! ////.monad} - [bytecode-name (\ ! map //runtime.class-name - (generation.remember archive name))] - (wrap (_.getstatic (type.class bytecode-name (list)) //value.field //type.value)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux deleted file mode 100644 index 1c31c7ed9..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux +++ /dev/null @@ -1,610 +0,0 @@ -(.module: - [lux (#- Type Definition case false true try) - [abstract - ["." monad (#+ do)] - ["." enum]] - [control - ["." try]] - [data - [binary (#+ Binary)] - [collection - ["." list ("#\." functor)] - ["." row]] - ["." format #_ - ["#" binary]] - [text - ["%" format (#+ format)]]] - [math - [number - ["n" nat] - ["." i32] - ["." i64]]] - [target - ["." jvm #_ - ["_" bytecode (#+ Label Bytecode)] - ["." modifier (#+ Modifier) ("#\." monoid)] - ["." field (#+ Field)] - ["." method (#+ Method)] - ["#/." version] - ["." class (#+ Class)] - ["." constant - [pool (#+ Resource)]] - [encoding - ["." name]] - ["." type (#+ Type) - ["." category (#+ Return' Value')] - ["." reflection]]]]] - ["." // #_ - ["#." type] - ["#." value] - ["#." function #_ - ["#" abstract] - [field - [constant - ["#/." arity]] - [variable - [partial - ["#/." count]]]]] - ["//#" /// #_ - [// - ["." version] - ["." synthesis] - ["." generation] - [/// - ["#" phase] - [arity (#+ Arity)] - [reference - [variable (#+ Register)]] - [meta - [io (#+ lux_context)] - [archive (#+ Archive)]]]]]]) - -(type: #export Byte_Code Binary) - -(type: #export Definition [Text Byte_Code]) - -(type: #export Anchor [Label Register]) - -(template [<name> <base>] - [(type: #export <name> - (<base> Anchor (Bytecode Any) Definition))] - - [Operation generation.Operation] - [Phase generation.Phase] - [Handler generation.Handler] - [Bundle generation.Bundle] - ) - -(type: #export (Generator i) - (-> Phase Archive i (Operation (Bytecode Any)))) - -(type: #export Host - (generation.Host (Bytecode Any) Definition)) - -(def: #export (class_name [module id]) - (-> generation.Context Text) - (format lux_context - "/" (%.nat version.version) - "/" (%.nat module) - "/" (%.nat id))) - -(def: artifact_id - 0) - -(def: #export class - (type.class (%.nat ..artifact_id) (list))) - -(def: procedure - (-> Text (Type category.Method) (Bytecode Any)) - (_.invokestatic ..class)) - -(def: modifier - (Modifier Method) - ($_ modifier\compose - method.public - method.static - method.strict - )) - -(def: this - (Bytecode Any) - _.aload_0) - -(def: #export (get index) - (-> (Bytecode Any) (Bytecode Any)) - ($_ _.compose - index - _.aaload)) - -(def: (set! index value) - (-> (Bytecode Any) (Bytecode Any) (Bytecode Any)) - ($_ _.compose - ## A - _.dup ## AA - index ## AAI - value ## AAIV - _.aastore ## A - )) - -(def: #export unit (_.string synthesis.unit)) - -(def: variant::name "variant") -(def: variant::type (type.method [(list //type.tag //type.flag //type.value) //type.variant (list)])) -(def: #export variant (..procedure ..variant::name ..variant::type)) - -(def: variant_tag _.iconst_0) -(def: variant_last? _.iconst_1) -(def: variant_value _.iconst_2) - -(def: variant::method - (let [new_variant ($_ _.compose - _.iconst_3 - (_.anewarray //type.value)) - $tag ($_ _.compose - _.iload_0 - (//value.wrap type.int)) - $last? _.aload_1 - $value _.aload_2] - (method.method ..modifier ..variant::name - ..variant::type - (list) - (#.Some ($_ _.compose - new_variant ## A[3] - (..set! ..variant_tag $tag) ## A[3] - (..set! ..variant_last? $last?) ## A[3] - (..set! ..variant_value $value) ## A[3] - _.areturn))))) - -(def: #export left_flag _.aconst_null) -(def: #export right_flag ..unit) - -(def: #export left_injection - (Bytecode Any) - ($_ _.compose - _.iconst_0 - ..left_flag - _.dup2_x1 - _.pop2 - ..variant)) - -(def: #export right_injection - (Bytecode Any) - ($_ _.compose - _.iconst_1 - ..right_flag - _.dup2_x1 - _.pop2 - ..variant)) - -(def: #export some_injection ..right_injection) - -(def: #export none_injection - (Bytecode Any) - ($_ _.compose - _.iconst_0 - ..left_flag - ..unit - ..variant)) - -(def: (risky $unsafe) - (-> (Bytecode Any) (Bytecode Any)) - (do _.monad - [@try _.new_label - @handler _.new_label] - ($_ _.compose - (_.try @try @handler @handler //type.error) - (_.set_label @try) - $unsafe - ..some_injection - _.areturn - (_.set_label @handler) - ..none_injection - _.areturn - ))) - -(def: decode_frac::name "decode_frac") -(def: decode_frac::type (type.method [(list //type.text) //type.variant (list)])) -(def: #export decode_frac (..procedure ..decode_frac::name ..decode_frac::type)) - -(def: decode_frac::method - (method.method ..modifier ..decode_frac::name - ..decode_frac::type - (list) - (#.Some - (..risky - ($_ _.compose - _.aload_0 - (_.invokestatic //type.frac "parseDouble" (type.method [(list //type.text) type.double (list)])) - (//value.wrap type.double) - ))))) - -(def: #export log! - (Bytecode Any) - (let [^PrintStream (type.class "java.io.PrintStream" (list)) - ^System (type.class "java.lang.System" (list)) - out (_.getstatic ^System "out" ^PrintStream) - print_type (type.method [(list //type.value) type.void (list)]) - print! (function (_ method) (_.invokevirtual ^PrintStream method print_type))] - ($_ _.compose - out (_.string "LUX LOG: ") (print! "print") - out _.swap (print! "println")))) - -(def: exception_constructor (type.method [(list //type.text) type.void (list)])) -(def: (illegal_state_exception message) - (-> Text (Bytecode Any)) - (let [^IllegalStateException (type.class "java.lang.IllegalStateException" (list))] - ($_ _.compose - (_.new ^IllegalStateException) - _.dup - (_.string message) - (_.invokespecial ^IllegalStateException "<init>" ..exception_constructor)))) - -(def: failure::type - (type.method [(list) type.void (list)])) - -(def: (failure name message) - (-> Text Text (Resource Method)) - (method.method ..modifier name - ..failure::type - (list) - (#.Some - ($_ _.compose - (..illegal_state_exception message) - _.athrow)))) - -(def: pm_failure::name "pm_failure") -(def: #export pm_failure (..procedure ..pm_failure::name ..failure::type)) - -(def: pm_failure::method - (..failure ..pm_failure::name "Invalid expression for pattern-matching.")) - -(def: #export stack_head _.iconst_0) -(def: #export stack_tail _.iconst_1) - -(def: push::name "push") -(def: push::type (type.method [(list //type.stack //type.value) //type.stack (list)])) -(def: #export push (..procedure ..push::name ..push::type)) - -(def: push::method - (method.method ..modifier ..push::name - ..push::type - (list) - (#.Some - (let [new_stack_frame! ($_ _.compose - _.iconst_2 - (_.anewarray //type.value)) - $head _.aload_1 - $tail _.aload_0] - ($_ _.compose - new_stack_frame! - (..set! ..stack_head $head) - (..set! ..stack_tail $tail) - _.areturn))))) - -(def: case::name "case") -(def: case::type (type.method [(list //type.variant //type.tag //type.flag) //type.value (list)])) -(def: #export case (..procedure ..case::name ..case::type)) - -(def: case::method - (method.method ..modifier ..case::name ..case::type - (list) - (#.Some - (do _.monad - [@loop _.new_label - @perfect_match! _.new_label - @tags_match! _.new_label - @maybe_nested _.new_label - @mismatch! _.new_label - #let [::tag ($_ _.compose - (..get ..variant_tag) - (//value.unwrap type.int)) - ::last? (..get ..variant_last?) - ::value (..get ..variant_value) - - $variant _.aload_0 - $tag _.iload_1 - $last? _.aload_2 - - not_found _.aconst_null - - update_$tag _.isub - update_$variant ($_ _.compose - $variant ::value - (_.checkcast //type.variant) - _.astore_0) - recur (: (-> Label (Bytecode Any)) - (function (_ @loop_start) - ($_ _.compose - ## tag, sumT - update_$variant ## tag, sumT - update_$tag ## sub_tag - (_.goto @loop_start)))) - - super_nested_tag ($_ _.compose - ## tag, sumT - _.swap ## sumT, tag - _.isub) - super_nested ($_ _.compose - ## tag, sumT - super_nested_tag ## super_tag - $variant ::last? ## super_tag, super_last - $variant ::value ## super_tag, super_last, super_value - ..variant)]] - ($_ _.compose - $tag - (_.set_label @loop) - $variant ::tag - _.dup2 (_.if_icmpeq @tags_match!) - _.dup2 (_.if_icmpgt @maybe_nested) - $last? (_.ifnull @mismatch!) ## tag, sumT - super_nested ## super_variant - _.areturn - (_.set_label @tags_match!) ## tag, sumT - $last? ## tag, sumT, wants_last? - $variant ::last? ## tag, sumT, wants_last?, is_last? - (_.if_acmpeq @perfect_match!) ## tag, sumT - (_.set_label @maybe_nested) ## tag, sumT - $variant ::last? ## tag, sumT, last? - (_.ifnull @mismatch!) ## tag, sumT - (recur @loop) - (_.set_label @perfect_match!) ## tag, sumT - ## _.pop2 - $variant ::value - _.areturn - (_.set_label @mismatch!) ## tag, sumT - ## _.pop2 - not_found - _.areturn - ))))) - -(def: projection_type (type.method [(list //type.tuple //type.offset) //type.value (list)])) - -(def: left_projection::name "left") -(def: #export left_projection (..procedure ..left_projection::name ..projection_type)) - -(def: right_projection::name "right") -(def: #export right_projection (..procedure ..right_projection::name ..projection_type)) - -(def: projection::method2 - [(Resource Method) (Resource Method)] - (let [$tuple _.aload_0 - $tuple::size ($_ _.compose - $tuple _.arraylength) - - $lefts _.iload_1 - - $last_right ($_ _.compose - $tuple::size _.iconst_1 _.isub) - - update_$lefts ($_ _.compose - $lefts $last_right _.isub - _.istore_1) - update_$tuple ($_ _.compose - $tuple $last_right _.aaload (_.checkcast //type.tuple) - _.astore_0) - recur (: (-> Label (Bytecode Any)) - (function (_ @loop) - ($_ _.compose - update_$lefts - update_$tuple - (_.goto @loop)))) - - left_projection::method - (method.method ..modifier ..left_projection::name ..projection_type - (list) - (#.Some - (do _.monad - [@loop _.new_label - @recursive _.new_label - #let [::left ($_ _.compose - $lefts _.aaload)]] - ($_ _.compose - (_.set_label @loop) - $lefts $last_right (_.if_icmpge @recursive) - $tuple ::left - _.areturn - (_.set_label @recursive) - ## Recursive - (recur @loop))))) - - right_projection::method - (method.method ..modifier ..right_projection::name ..projection_type - (list) - (#.Some - (do _.monad - [@loop _.new_label - @not_tail _.new_label - @slice _.new_label - #let [$right ($_ _.compose - $lefts - _.iconst_1 - _.iadd) - $::nested ($_ _.compose - $tuple _.swap _.aaload) - super_nested ($_ _.compose - $tuple - $right - $tuple::size - (_.invokestatic (type.class "java.util.Arrays" (list)) "copyOfRange" - (type.method [(list //type.tuple //type.index //type.index) //type.tuple (list)])))]] - ($_ _.compose - (_.set_label @loop) - $last_right $right - _.dup2 (_.if_icmpne @not_tail) - ## _.pop - $::nested - _.areturn - (_.set_label @not_tail) - (_.if_icmpgt @slice) - ## Must recurse - (recur @loop) - (_.set_label @slice) - super_nested - _.areturn))))] - [left_projection::method - right_projection::method])) - -(def: #export apply::name "apply") - -(def: #export (apply::type arity) - (-> Arity (Type category.Method)) - (type.method [(list.repeat arity //type.value) //type.value (list)])) - -(def: #export apply - (_.invokevirtual //function.class ..apply::name (..apply::type 1))) - -(def: try::name "try") -(def: try::type (type.method [(list //function.class) //type.variant (list)])) -(def: #export try (..procedure ..try::name ..try::type)) - -(def: false _.iconst_0) -(def: true _.iconst_1) - -(def: try::method - (method.method ..modifier ..try::name ..try::type - (list) - (#.Some - (do _.monad - [@try _.new_label - @handler _.new_label - #let [$unsafe ..this - unit _.aconst_null - - ^StringWriter (type.class "java.io.StringWriter" (list)) - string_writer ($_ _.compose - (_.new ^StringWriter) - _.dup - (_.invokespecial ^StringWriter "<init>" (type.method [(list) type.void (list)]))) - - ^PrintWriter (type.class "java.io.PrintWriter" (list)) - print_writer ($_ _.compose - ## WTW - (_.new ^PrintWriter) ## WTWP - _.dup_x1 ## WTPWP - _.swap ## WTPPW - ..true ## WTPPWZ - (_.invokespecial ^PrintWriter "<init>" (type.method [(list (type.class "java.io.Writer" (list)) type.boolean) type.void (list)])) - ## WTP - )]] - ($_ _.compose - (_.try @try @handler @handler //type.error) - (_.set_label @try) - $unsafe unit ..apply - ..right_injection _.areturn - (_.set_label @handler) ## T - string_writer ## TW - _.dup_x1 ## WTW - print_writer ## WTP - (_.invokevirtual //type.error "printStackTrace" (type.method [(list ^PrintWriter) type.void (list)])) ## W - (_.invokevirtual ^StringWriter "toString" (type.method [(list) //type.text (list)])) ## S - ..left_injection _.areturn - ))))) - -(def: reflection - (All [category] - (-> (Type (<| Return' Value' category)) Text)) - (|>> type.reflection reflection.reflection)) - -(def: ^Object (type.class "java.lang.Object" (list))) - -(def: generate_runtime - (Operation Any) - (let [class (..reflection ..class) - modifier (: (Modifier Class) - ($_ modifier\compose - class.public - class.final)) - bytecode (<| (format.run class.writer) - try.assume - (class.class jvm/version.v6_0 - modifier - (name.internal class) - (name.internal (..reflection ^Object)) (list) - (list) - (let [[left_projection::method right_projection::method] projection::method2] - (list ..decode_frac::method - ..variant::method - - ..pm_failure::method - - ..push::method - ..case::method - left_projection::method - right_projection::method - - ..try::method)) - (row.row)))] - (do ////.monad - [_ (generation.execute! [class bytecode])] - (generation.save! ..artifact_id [class bytecode])))) - -(def: generate_function - (Operation Any) - (let [apply::method+ (|> (enum.range n.enum - (inc //function/arity.minimum) - //function/arity.maximum) - (list\map (function (_ arity) - (method.method method.public ..apply::name (..apply::type arity) - (list) - (#.Some - (let [previous_inputs (|> arity - list.indices - (monad.map _.monad _.aload))] - ($_ _.compose - previous_inputs - (_.invokevirtual //function.class ..apply::name (..apply::type (dec arity))) - (_.checkcast //function.class) - (_.aload arity) - (_.invokevirtual //function.class ..apply::name (..apply::type //function/arity.minimum)) - _.areturn)))))) - (list& (method.method (modifier\compose method.public method.abstract) - ..apply::name (..apply::type //function/arity.minimum) - (list) - #.None))) - <init>::method (method.method method.public "<init>" //function.init - (list) - (#.Some - (let [$partials _.iload_1] - ($_ _.compose - ..this - (_.invokespecial ^Object "<init>" (type.method [(list) type.void (list)])) - ..this - $partials - (_.putfield //function.class //function/count.field //function/count.type) - _.return)))) - modifier (: (Modifier Class) - ($_ modifier\compose - class.public - class.abstract)) - class (..reflection //function.class) - partial_count (: (Resource Field) - (field.field (modifier\compose field.public field.final) - //function/count.field - //function/count.type - (row.row))) - bytecode (<| (format.run class.writer) - try.assume - (class.class jvm/version.v6_0 - modifier - (name.internal class) - (name.internal (..reflection ^Object)) (list) - (list partial_count) - (list& <init>::method apply::method+) - (row.row)))] - (do ////.monad - [_ (generation.execute! [class bytecode])] - (generation.save! //function.artifact_id [class bytecode])))) - -(def: #export generate - (Operation Any) - (do ////.monad - [_ ..generate_runtime] - ..generate_function)) - -(def: #export forge_label - (Operation Label) - (let [shift (n./ 4 i64.width)] - ## This shift is done to avoid the possibility of forged labels - ## to be in the range of the labels that are generated automatically - ## during the evaluation of Bytecode expressions. - (\ ////.monad map (i64.left_shift shift) generation.next))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/structure.lux deleted file mode 100644 index b89bbca35..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/structure.lux +++ /dev/null @@ -1,94 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [data - [number - ["." i32]] - [collection - ["." list]]] - [target - [jvm - ["_" bytecode (#+ Bytecode)] - ["." type] - [encoding - ["." signed]]]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." primitive] - ["///#" //// #_ - [analysis (#+ Variant Tuple)] - ["#." synthesis (#+ Synthesis)] - [/// - ["." phase]]]]) - -(def: $Object - (type.class "java.lang.Object" (list))) - -(def: #export (tuple generate archive membersS) - (Generator (Tuple Synthesis)) - (case membersS - #.Nil - (\ phase.monad wrap //runtime.unit) - - (#.Cons singletonS #.Nil) - (generate archive singletonS) - - _ - (do {! phase.monad} - [membersI (|> membersS - list.enumeration - (monad.map ! (function (_ [idx member]) - (do ! - [memberI (generate archive member)] - (wrap (do _.monad - [_ _.dup - _ (_.int (.i64 idx)) - _ memberI] - _.aastore))))))] - (wrap (do {! _.monad} - [_ (_.int (.i64 (list.size membersS))) - _ (_.anewarray $Object)] - (monad.seq ! membersI)))))) - -(def: #export (tag lefts right?) - (-> Nat Bit (Bytecode Any)) - (case (if right? - (.inc lefts) - lefts) - 0 _.iconst-0 - 1 _.iconst-1 - 2 _.iconst-2 - 3 _.iconst-3 - 4 _.iconst-4 - 5 _.iconst-5 - tag (case (signed.s1 (.int tag)) - (#try.Success value) - (_.bipush value) - - (#try.Failure _) - (case (signed.s2 (.int tag)) - (#try.Success value) - (_.sipush value) - - (#try.Failure _) - (_.int (.i64 tag)))))) - -(def: #export (flag right?) - (-> Bit (Bytecode Any)) - (if right? - //runtime.right-flag - //runtime.left-flag)) - -(def: #export (variant generate archive [lefts right? valueS]) - (Generator (Variant Synthesis)) - (do phase.monad - [valueI (generate archive valueS)] - (wrap (do _.monad - [_ (..tag lefts right?) - _ (..flag right?) - _ valueI] - (_.invokestatic //runtime.class "variant" - (type.method [(list type.int $Object $Object) - (type.array $Object) - (list)])))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/type.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/type.lux deleted file mode 100644 index 954740d2d..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/type.lux +++ /dev/null @@ -1,22 +0,0 @@ -(.module: - [lux #* - [target - [jvm - ["." type]]]]) - -(def: #export frac (type.class "java.lang.Double" (list))) -(def: #export text (type.class "java.lang.String" (list))) - -(def: #export value (type.class "java.lang.Object" (list))) - -(def: #export tag type.int) -(def: #export flag ..value) -(def: #export variant (type.array ..value)) - -(def: #export offset type.int) -(def: #export index ..offset) -(def: #export tuple (type.array ..value)) - -(def: #export stack (type.array ..value)) - -(def: #export error (type.class "java.lang.Throwable" (list))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/value.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/value.lux deleted file mode 100644 index 206af53b8..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/value.lux +++ /dev/null @@ -1,48 +0,0 @@ -(.module: - [lux (#- Type type) - [target - [jvm - ["_" bytecode (#+ Bytecode)] - ["." type (#+ Type) ("#\." equivalence) - [category (#+ Primitive)] - ["." box]]]]]) - -(def: #export field "value") - -(template [<name> <boolean> <byte> <short> <int> <long> <float> <double> <char>] - [(def: (<name> type) - (-> (Type Primitive) Text) - (`` (cond (~~ (template [<type> <output>] - [(type\= <type> type) <output>] - - [type.boolean <boolean>] - [type.byte <byte>] - [type.short <short>] - [type.int <int>] - [type.long <long>] - [type.float <float>] - [type.double <double>] - [type.char <char>])) - ## else - (undefined))))] - - [primitive-wrapper - box.boolean box.byte box.short box.int - box.long box.float box.double box.char] - [primitive-unwrap - "booleanValue" "byteValue" "shortValue" "intValue" - "longValue" "floatValue" "doubleValue" "charValue"] - ) - -(def: #export (wrap type) - (-> (Type Primitive) (Bytecode Any)) - (let [wrapper (type.class (primitive-wrapper type) (list))] - (_.invokestatic wrapper "valueOf" - (type.method [(list type) wrapper (list)])))) - -(def: #export (unwrap type) - (-> (Type Primitive) (Bytecode Any)) - (let [wrapper (type.class (primitive-wrapper type) (list))] - ($_ _.compose - (_.checkcast wrapper) - (_.invokevirtual wrapper (primitive-unwrap type) (type.method [(list) type (list)]))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua.lux deleted file mode 100644 index 3f64c53bf..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua.lux +++ /dev/null @@ -1,118 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." exception (#+ exception:)]] - [target - ["_" lua]]] - ["." / #_ - [runtime (#+ Phase Phase!)] - ["#." primitive] - ["#." structure] - ["#." reference] - ["#." case] - ["#." loop] - ["#." function] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." extension] - ["/#" // #_ - [analysis (#+)] - ["." synthesis] - ["//#" /// #_ - ["#." phase ("#\." monad)] - [reference (#+) - [variable (#+)]]]]]]]) - -(def: (statement expression archive synthesis) - Phase! - (case synthesis - (^template [<tag>] - [(^ (<tag> value)) - (//////phase\map _.return (expression archive synthesis))]) - ([synthesis.bit] - [synthesis.i64] - [synthesis.f64] - [synthesis.text] - [synthesis.variant] - [synthesis.tuple] - [#synthesis.Reference] - [synthesis.branch/get] - [synthesis.function/apply] - [#synthesis.Extension]) - - (^ (synthesis.branch/case case)) - (/case.case! statement expression archive case) - - (^ (synthesis.branch/let let)) - (/case.let! statement expression archive let) - - (^ (synthesis.branch/if if)) - (/case.if! statement expression archive if) - - (^ (synthesis.loop/scope scope)) - (do //////phase.monad - [[inits scope!] (/loop.scope! statement expression archive false scope)] - (wrap scope!)) - - (^ (synthesis.loop/recur updates)) - (/loop.recur! statement expression archive updates) - - (^ (synthesis.function/abstraction abstraction)) - (//////phase\map _.return (/function.function statement expression archive abstraction)) - )) - -(exception: #export cannot-recur-as-an-expression) - -(def: (expression archive synthesis) - Phase - (case synthesis - (^template [<tag> <generator>] - [(^ (<tag> value)) - (//////phase\wrap (<generator> value))]) - ([synthesis.bit /primitive.bit] - [synthesis.i64 /primitive.i64] - [synthesis.f64 /primitive.f64] - [synthesis.text /primitive.text]) - - (^ (synthesis.variant variantS)) - (/structure.variant expression archive variantS) - - (^ (synthesis.tuple members)) - (/structure.tuple expression archive members) - - (#synthesis.Reference value) - (//reference.reference /reference.system archive value) - - (^ (synthesis.branch/case case)) - (/case.case ..statement expression archive case) - - (^ (synthesis.branch/let let)) - (/case.let expression archive let) - - (^ (synthesis.branch/if if)) - (/case.if expression archive if) - - (^ (synthesis.branch/get get)) - (/case.get expression archive get) - - (^ (synthesis.loop/scope scope)) - (/loop.scope ..statement expression archive scope) - - (^ (synthesis.loop/recur updates)) - (//////phase.throw ..cannot-recur-as-an-expression []) - - (^ (synthesis.function/abstraction abstraction)) - (/function.function ..statement expression archive abstraction) - - (^ (synthesis.function/apply application)) - (/function.apply expression archive application) - - (#synthesis.Extension extension) - (///extension.apply archive expression extension))) - -(def: #export generate - Phase - ..expression) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/case.lux deleted file mode 100644 index 6a2101fe3..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/case.lux +++ /dev/null @@ -1,279 +0,0 @@ -(.module: - [lux (#- case let if) - [abstract - ["." monad (#+ do)]] - [data - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set]]] - [target - ["_" lua (#+ Expression Var Statement)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Phase! Generator Generator!)] - ["#." reference] - ["#." primitive] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." synthesis #_ - ["#/." case]] - ["/#" // #_ - ["#." synthesis (#+ Member Synthesis Path)] - ["#." generation] - ["//#" /// #_ - [reference - ["#." variable (#+ Register)]] - ["#." phase ("#\." monad)] - [meta - [archive (#+ Archive)]]]]]]]) - -(def: #export register - (-> Register Var) - (|>> (///reference.local //reference.system) :assume)) - -(def: #export capture - (-> Register Var) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: #export (let expression archive [valueS register bodyS]) - (Generator [Synthesis Register Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS) - bodyO (expression archive bodyS)] - ## TODO: Find some way to do 'let' without paying the price of the closure. - (wrap (|> bodyO - _.return - (_.closure (list (..register register))) - (_.apply/* (list valueO)))))) - -(def: #export (let! statement expression archive [valueS register bodyS]) - (Generator! [Synthesis Register Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS) - bodyO (statement expression archive bodyS)] - (wrap ($_ _.then - (_.local/1 (..register register) valueO) - bodyO)))) - -(def: #export (get expression archive [pathP valueS]) - (Generator [(List Member) Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS)] - (wrap (list\fold (function (_ side source) - (.let [method (.case side - (^template [<side> <accessor>] - [(<side> lefts) - (<accessor> (_.int (.int lefts)))]) - ([#.Left //runtime.tuple//left] - [#.Right //runtime.tuple//right]))] - (method source))) - valueO - (list.reverse pathP))))) - -(def: #export (if expression archive [testS thenS elseS]) - (Generator [Synthesis Synthesis Synthesis]) - (do ///////phase.monad - [testO (expression archive testS) - thenO (expression archive thenS) - elseO (expression archive elseS)] - (wrap (|> (_.if testO - (_.return thenO) - (_.return elseO)) - (_.closure (list)) - (_.apply/* (list)))))) - -(def: #export (if! statement expression archive [testS thenS elseS]) - (Generator! [Synthesis Synthesis Synthesis]) - (do ///////phase.monad - [testO (expression archive testS) - thenO (statement expression archive thenS) - elseO (statement expression archive elseS)] - (wrap (_.if testO - thenO - elseO)))) - -(def: @savepoint (_.var "lux_pm_savepoint")) -(def: @cursor (_.var "lux_pm_cursor")) -(def: @temp (_.var "lux_pm_temp")) - -(def: (push! value) - (-> Expression Statement) - (_.statement (|> (_.var "table.insert") (_.apply/* (list @cursor value))))) - -(def: peek_and_pop - Expression - (|> (_.var "table.remove") (_.apply/* (list @cursor)))) - -(def: pop! - Statement - (_.statement ..peek_and_pop)) - -(def: peek - Expression - (_.nth (_.length @cursor) @cursor)) - -(def: save! - Statement - (_.statement (|> (_.var "table.insert") - (_.apply/* (list @savepoint - (_.apply/* (list @cursor - (_.int +1) - (_.length @cursor) - (_.int +1) - (_.table (list))) - (_.var "table.move"))))))) - -(def: restore! - Statement - (_.set (list @cursor) (|> (_.var "table.remove") (_.apply/* (list @savepoint))))) - -(def: fail! _.break) - -(template [<name> <flag> <prep>] - [(def: (<name> simple? idx) - (-> Bit Nat Statement) - ($_ _.then - (_.set (list @temp) (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>))) - (.if simple? - (_.when (_.= _.nil @temp) - fail!) - (_.if (_.= _.nil @temp) - fail! - (..push! @temp)))))] - - [left_choice _.nil (<|)] - [right_choice (_.string "") inc] - ) - -(def: (alternation pre! post!) - (-> Statement Statement Statement) - ($_ _.then - (_.while (_.bool true) - ($_ _.then - ..save! - pre!)) - ($_ _.then - ..restore! - post!))) - -(def: (pattern_matching' statement expression archive) - (-> Phase! Phase Archive Path (Operation Statement)) - (function (recur pathP) - (.case pathP - (#/////synthesis.Then bodyS) - (statement expression archive bodyS) - - #/////synthesis.Pop - (///////phase\wrap ..pop!) - - (#/////synthesis.Bind register) - (///////phase\wrap (_.local/1 (..register register) ..peek)) - - (#/////synthesis.Bit_Fork when thenP elseP) - (do {! ///////phase.monad} - [then! (recur thenP) - else! (.case elseP - (#.Some elseP) - (recur elseP) - - #.None - (wrap ..fail!))] - (wrap (.if when - (_.if ..peek - then! - else!) - (_.if ..peek - else! - then!)))) - - (^template [<tag> <format>] - [(<tag> cons) - (do {! ///////phase.monad} - [clauses (monad.map ! (function (_ [match then]) - (do ! - [then! (recur then)] - (wrap [(_.= (|> match <format>) - ..peek) - then!]))) - (#.Cons cons))] - (wrap (_.cond clauses ..fail!)))]) - ([#/////synthesis.I64_Fork (<| _.int .int)] - [#/////synthesis.F64_Fork _.float] - [#/////synthesis.Text_Fork _.string]) - - (^template [<complex> <simple> <choice>] - [(^ (<complex> idx)) - (///////phase\wrap (<choice> false idx)) - - (^ (<simple> idx nextP)) - (///////phase\map (_.then (<choice> true idx)) (recur nextP))]) - ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice] - [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice]) - - (^ (/////synthesis.member/left 0)) - (///////phase\wrap (|> ..peek (_.nth (_.int +1)) ..push!)) - - (^template [<pm> <getter>] - [(^ (<pm> lefts)) - (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))]) - ([/////synthesis.member/left //runtime.tuple//left] - [/////synthesis.member/right //runtime.tuple//right]) - - (^ (/////synthesis.!bind_top register thenP)) - (do ///////phase.monad - [then! (recur thenP)] - (///////phase\wrap ($_ _.then - (_.local/1 (..register register) ..peek_and_pop) - then!))) - - (^template [<tag> <combinator>] - [(^ (<tag> preP postP)) - (do ///////phase.monad - [pre! (recur preP) - post! (recur postP)] - (wrap (<combinator> pre! post!)))]) - ([/////synthesis.path/seq _.then] - [/////synthesis.path/alt ..alternation])))) - -(def: (pattern_matching statement expression archive pathP) - (-> Phase! Phase Archive Path (Operation Statement)) - (do ///////phase.monad - [pattern_matching! (pattern_matching' statement expression archive pathP)] - (wrap ($_ _.then - (_.while (_.bool true) - pattern_matching!) - (_.statement (|> (_.var "error") (_.apply/* (list (_.string ////synthesis/case.pattern_matching_error))))))))) - -(def: #export dependencies - (-> Path (List Var)) - (|>> ////synthesis/case.storage - (get@ #////synthesis/case.dependencies) - set.to_list - (list\map (function (_ variable) - (.case variable - (#///////variable.Local register) - (..register register) - - (#///////variable.Foreign register) - (..capture register)))))) - -(def: #export (case! statement expression archive [valueS pathP]) - (Generator! [Synthesis Path]) - (do ///////phase.monad - [stack_init (expression archive valueS) - pattern_matching! (pattern_matching statement expression archive pathP)] - (wrap ($_ _.then - (_.local (list @temp)) - (_.local/1 @cursor (_.array (list stack_init))) - (_.local/1 @savepoint (_.array (list))) - pattern_matching!)))) - -(def: #export (case statement expression archive [valueS pathP]) - (-> Phase! (Generator [Synthesis Path])) - (|> [valueS pathP] - (..case! statement expression archive) - (\ ///////phase.monad map - (|>> (_.closure (list)) - (_.apply/* (list)))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux deleted file mode 100644 index 55490d3f2..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux +++ /dev/null @@ -1,136 +0,0 @@ -(.module: - [lux (#- function) - [abstract - ["." monad (#+ do)]] - [control - pipe] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [target - ["_" lua (#+ Var Expression Label Statement)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Phase! Generator)] - ["#." reference] - ["#." case] - ["/#" // #_ - ["#." reference] - ["//#" /// #_ - [analysis (#+ Variant Tuple Abstraction Application Analysis)] - [synthesis (#+ Synthesis)] - ["#." generation (#+ Context)] - ["//#" /// #_ - [arity (#+ Arity)] - ["#." phase ("#\." monad)] - [reference - [variable (#+ Register Variable)]]]]]]) - -(def: #export (apply expression archive [functionS argsS+]) - (Generator (Application Synthesis)) - (do {! ///////phase.monad} - [functionO (expression archive functionS) - argsO+ (monad.map ! (expression archive) argsS+)] - (wrap (_.apply/* argsO+ functionO)))) - -(def: capture - (-> Register Var) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: (with_closure inits @self @args body!) - (-> (List Expression) Var (List Var) Statement [Statement Expression]) - (case inits - #.Nil - [(_.function @self @args body!) - @self] - - _ - (let [@inits (|> (list.enumeration inits) - (list\map (|>> product.left ..capture)))] - [(_.function @self @inits - ($_ _.then - (_.local_function @self @args body!) - (_.return @self))) - (_.apply/* inits @self)]))) - -(def: input - (|>> inc //case.register)) - -(def: (@scope function_name) - (-> Context Label) - (_.label (format (///reference.artifact function_name) "_scope"))) - -(def: #export (function statement expression archive [environment arity bodyS]) - (-> Phase! (Generator (Abstraction Synthesis))) - (do {! ///////phase.monad} - [[function_name body!] (/////generation.with_new_context archive - (do ! - [@scope (\ ! map ..@scope - (/////generation.context archive))] - (/////generation.with_anchor [1 @scope] - (statement expression archive bodyS)))) - closureO+ (monad.map ! (expression archive) environment) - #let [@curried (_.var "curried") - arityO (|> arity .int _.int) - @num_args (_.var "num_args") - @scope (..@scope function_name) - @self (_.var (///reference.artifact function_name)) - initialize_self! (_.local/1 (//case.register 0) @self) - initialize! (list\fold (.function (_ post pre!) - ($_ _.then - pre! - (_.local/1 (..input post) (_.nth (|> post inc .int _.int) @curried)))) - initialize_self! - (list.indices arity)) - pack (|>> (list) _.array) - unpack (_.apply/1 (_.var "table.unpack")) - @var_args (_.var "...")] - #let [[definition instantiation] (with_closure closureO+ @self (list @var_args) - ($_ _.then - (_.local/1 @curried (pack @var_args)) - (_.local/1 @num_args (_.length @curried)) - (_.cond (list [(|> @num_args (_.= arityO)) - ($_ _.then - initialize! - (_.set_label @scope) - body!)] - [(|> @num_args (_.> arityO)) - (let [arity_inputs (_.apply/5 (_.var "table.move") - @curried - (_.int +1) - arityO - (_.int +1) - (_.array (list))) - extra_inputs (_.apply/5 (_.var "table.move") - @curried - (_.+ (_.int +1) arityO) - @num_args - (_.int +1) - (_.array (list)))] - (_.return (|> @self - (_.apply/* (list (unpack arity_inputs))) - (_.apply/* (list (unpack extra_inputs))))))]) - ## (|> @num_args (_.< arityO)) - (_.return (_.closure (list @var_args) - (let [@extra_args (_.var "extra_args")] - ($_ _.then - (_.local/1 @extra_args (pack @var_args)) - (_.return (|> (_.array (list)) - (_.apply/5 (_.var "table.move") - @curried - (_.int +1) - @num_args - (_.int +1)) - (_.apply/5 (_.var "table.move") - @extra_args - (_.int +1) - (_.length @extra_args) - (_.+ (_.int +1) @num_args)) - unpack - (_.apply/1 @self)))))))) - ))] - _ (/////generation.execute! definition) - _ (/////generation.save! (product.right function_name) definition)] - (wrap instantiation))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux deleted file mode 100644 index e95fc0f49..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux +++ /dev/null @@ -1,118 +0,0 @@ -(.module: - [lux (#- Scope) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)] - ["." set]]] - [math - [number - ["n" nat]]] - [target - ["_" lua (#+ Var Expression Label Statement)]]] - ["." // #_ - [runtime (#+ Operation Phase Phase! Generator Generator!)] - ["#." case] - ["/#" // #_ - ["#." reference] - ["//#" /// #_ - ["."synthesis (#+ Scope Synthesis)] - ["#." generation] - ["//#" /// #_ - ["#." phase] - [meta - [archive (#+ Archive)]] - [reference - [variable (#+ Register)]]]]]]) - -(def: @scope - (-> Nat Label) - (|>> %.nat (format "scope") _.label)) - -(def: (setup initial? offset bindings as_expression? body) - (-> Bit Register (List Expression) Bit Statement Statement) - (let [variables (|> bindings - list.enumeration - (list\map (|>> product.left (n.+ offset) //case.register)))] - (if as_expression? - body - ($_ _.then - (if initial? - (_.let variables (_.multi bindings)) - (_.set variables (_.multi bindings))) - body)))) - -(def: #export (scope! statement expression archive as_expression? [start initsS+ bodyS]) - ## (Generator! (Scope Synthesis)) - (-> Phase! Phase Archive Bit (Scope Synthesis) - (Operation [(List Expression) Statement])) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (|> bodyS - (statement expression archive) - (\ ///////phase.monad map (|>> [(list)]))) - - ## true loop - _ - (do {! ///////phase.monad} - [@scope (\ ! map ..@scope /////generation.next) - initsO+ (monad.map ! (expression archive) initsS+) - body! (/////generation.with_anchor [start @scope] - (statement expression archive bodyS))] - (wrap [initsO+ - (..setup true start initsO+ as_expression? - ($_ _.then - (_.set_label @scope) - body!))])))) - -(def: #export (scope statement expression archive [start initsS+ bodyS]) - (-> Phase! (Generator (Scope Synthesis))) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [[[artifact_module artifact_id] [initsO+ scope!]] (/////generation.with_new_context archive - (scope! statement expression archive true [start initsS+ bodyS])) - #let [@loop (_.var (///reference.artifact [artifact_module artifact_id])) - locals (|> initsO+ - list.enumeration - (list\map (|>> product.left (n.+ start) //case.register))) - [directive instantiation] (: [Statement Expression] - (case (|> (synthesis.path/then bodyS) - //case.dependencies - (set.from_list _.hash) - (set.difference (set.from_list _.hash locals)) - set.to_list) - #.Nil - [(_.function @loop locals - scope!) - @loop] - - foreigns - (let [@context (_.var (format (_.code @loop) "_context"))] - [(_.function @context foreigns - ($_ _.then - (<| (_.local_function @loop locals) - scope!) - (_.return @loop) - )) - (|> @context (_.apply/* foreigns))])))] - _ (/////generation.execute! directive) - _ (/////generation.save! artifact_id directive)] - (wrap (|> instantiation (_.apply/* initsO+)))))) - -(def: #export (recur! statement expression archive argsS+) - (Generator! (List Synthesis)) - (do {! ///////phase.monad} - [[offset @scope] /////generation.anchor - argsO+ (monad.map ! (expression archive) argsS+)] - (wrap (..setup false offset argsO+ false (_.go_to @scope))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/primitive.lux deleted file mode 100644 index 6cce70f05..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/primitive.lux +++ /dev/null @@ -1,15 +0,0 @@ -(.module: - [lux (#- i64) - [target - ["_" lua (#+ Literal)]]]) - -(template [<name> <type> <implementation>] - [(def: #export <name> - (-> <type> Literal) - <implementation>)] - - [bit Bit _.bool] - [i64 (I64 Any) (|>> .int _.int)] - [f64 Frac _.float] - [text Text _.string] - ) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux deleted file mode 100644 index 72a54569c..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux +++ /dev/null @@ -1,12 +0,0 @@ -(.module: - [lux #* - [target - ["_" lua (#+ Expression)]]] - [/// - [reference (#+ System)]]) - -(implementation: #export system - (System Expression) - - (def: constant _.var) - (def: variable _.var)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux deleted file mode 100644 index 0da87ff6a..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux +++ /dev/null @@ -1,431 +0,0 @@ -(.module: - [lux (#- Location inc) - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<.>" code]]] - [data - ["." product] - ["." text ("#\." hash) - ["%" format (#+ format)] - [encoding - ["." utf8]]] - [collection - ["." list ("#\." functor)] - ["." row]]] - ["." macro - [syntax (#+ syntax:)] - ["." code]] - [math - [number (#+ hex) - ["." i64]]] - ["@" target - ["_" lua (#+ Expression Location Var Computation Literal Label Statement)]]] - ["." /// #_ - ["#." reference] - ["//#" /// #_ - ["#." synthesis (#+ Synthesis)] - ["#." generation] - ["//#" /// - ["#." phase] - [reference - [variable (#+ Register)]] - [meta - [archive (#+ Output Archive) - ["." artifact (#+ Registry)]]]]]]) - -(template [<name> <base>] - [(type: #export <name> - (<base> [Register Label] Expression Statement))] - - [Operation /////generation.Operation] - [Phase /////generation.Phase] - [Handler /////generation.Handler] - [Bundle /////generation.Bundle] - ) - -(type: #export (Generator i) - (-> Phase Archive i (Operation Expression))) - -(type: #export Phase! - (-> Phase Archive Synthesis (Operation Statement))) - -(type: #export (Generator! i) - (-> Phase! Phase Archive i (Operation Statement))) - -(def: #export unit - (_.string /////synthesis.unit)) - -(def: (flag value) - (-> Bit Literal) - (if value - ..unit - _.nil)) - -(def: #export variant_tag_field "_lux_tag") -(def: #export variant_flag_field "_lux_flag") -(def: #export variant_value_field "_lux_value") - -(def: (variant' tag last? value) - (-> Expression Expression Expression Literal) - (_.table (list [..variant_tag_field tag] - [..variant_flag_field last?] - [..variant_value_field value]))) - -(def: #export (variant tag last? value) - (-> Nat Bit Expression Literal) - (variant' (_.int (.int tag)) - (flag last?) - value)) - -(def: #export none - Literal - (..variant 0 #0 ..unit)) - -(def: #export some - (-> Expression Literal) - (..variant 1 #1)) - -(def: #export left - (-> Expression Literal) - (..variant 0 #0)) - -(def: #export right - (-> Expression Literal) - (..variant 1 #1)) - -(def: (feature name definition) - (-> Var (-> Var Statement) Statement) - (definition name)) - -(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} - body) - (do {! meta.monad} - [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] - (wrap (list (` (let [(~+ (|> vars - (list.zip/2 ids) - (list\map (function (_ [id var]) - (list (code.local_identifier var) - (` (_.var (~ (code.text (format "v" (%.nat id))))))))) - list.concat))] - (~ body))))))) - -(def: module_id - 0) - -(syntax: (runtime: {declaration (<>.or <code>.local_identifier - (<code>.form (<>.and <code>.local_identifier - (<>.some <code>.local_identifier))))} - code) - (do meta.monad - [runtime_id meta.count] - (macro.with_gensyms [g!_] - (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id])) - runtime_name (` (_.var (~ (code.text (%.code runtime)))))] - (case declaration - (#.Left name) - (macro.with_gensyms [g!_] - (let [g!name (code.local_identifier name)] - (wrap (list (` (def: #export (~ g!name) - Var - (~ runtime_name))) - - (` (def: (~ (code.local_identifier (format "@" name))) - Statement - (..feature (~ runtime_name) - (function ((~ g!_) (~ g!name)) - (_.set (~ g!name) (~ code)))))))))) - - (#.Right [name inputs]) - (macro.with_gensyms [g!_] - (let [g!name (code.local_identifier name) - inputsC (list\map code.local_identifier inputs) - inputs_typesC (list\map (function.constant (` _.Expression)) - inputs)] - (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) - (-> (~+ inputs_typesC) Computation) - (_.apply/* (list (~+ inputsC)) (~ runtime_name)))) - - (` (def: (~ (code.local_identifier (format "@" name))) - Statement - (..feature (~ runtime_name) - (function ((~ g!_) (~ g!_)) - (..with_vars [(~+ inputsC)] - (_.function (~ g!_) (list (~+ inputsC)) - (~ code)))))))))))))))) - -(def: (nth index table) - (-> Expression Expression Location) - (_.nth (_.+ (_.int +1) index) table)) - -(def: last_index - (|>> _.length (_.- (_.int +1)))) - -(with_expansions [<recur> (as_is ($_ _.then - (_.set (list lefts) (_.- last_index_right lefts)) - (_.set (list tuple) (..nth last_index_right tuple))))] - (runtime: (tuple//left lefts tuple) - (with_vars [last_index_right] - (<| (_.while (_.bool true)) - ($_ _.then - (_.local/1 last_index_right (..last_index tuple)) - (_.if (_.> lefts last_index_right) - ## No need for recursion - (_.return (..nth lefts tuple)) - ## Needs recursion - <recur>))))) - - (runtime: (tuple//right lefts tuple) - (with_vars [last_index_right right_index] - (<| (_.while (_.bool true)) - ($_ _.then - (_.local/1 last_index_right (..last_index tuple)) - (_.local/1 right_index (_.+ (_.int +1) lefts)) - (_.cond (list [(_.= last_index_right right_index) - (_.return (..nth right_index tuple))] - [(_.> last_index_right right_index) - ## Needs recursion. - <recur>]) - (_.return (_.apply/* (list tuple - (_.+ (_.int +1) right_index) - (_.length tuple) - (_.int +1) - (_.array (list))) - (_.var "table.move")))) - ))))) - -(runtime: (sum//get sum wants_last wanted_tag) - (let [no_match! (_.return _.nil) - sum_tag (_.the ..variant_tag_field sum) - sum_flag (_.the ..variant_flag_field sum) - sum_value (_.the ..variant_value_field sum) - is_last? (_.= ..unit sum_flag) - extact_match! (_.return sum_value) - test_recursion! (_.if is_last? - ## Must recurse. - ($_ _.then - (_.set (list wanted_tag) (_.- sum_tag wanted_tag)) - (_.set (list sum) sum_value)) - no_match!) - extrac_sub_variant! (_.return (variant' (_.- wanted_tag sum_tag) sum_flag sum_value))] - (<| (_.while (_.bool true)) - (_.cond (list [(_.= sum_tag wanted_tag) - (_.if (_.= wants_last sum_flag) - extact_match! - test_recursion!)] - [(_.< wanted_tag sum_tag) - test_recursion!] - [(_.= ..unit wants_last) - extrac_sub_variant!]) - no_match!)))) - -(def: runtime//adt - Statement - ($_ _.then - @tuple//left - @tuple//right - @sum//get - )) - -(runtime: (lux//try risky) - (with_vars [success value] - ($_ _.then - (_.let (list success value) (|> risky (_.apply/* (list ..unit)) - _.return (_.closure (list)) - list _.apply/* (|> (_.var "pcall")))) - (_.if success - (_.return (..right value)) - (_.return (..left value)))))) - -(runtime: (lux//program_args raw) - (with_vars [tail head idx] - ($_ _.then - (_.let (list tail) ..none) - (<| (_.for_step idx (_.length raw) (_.int +1) (_.int -1)) - (_.set (list tail) (..some (_.array (list (_.nth idx raw) - tail))))) - (_.return tail)))) - -(def: runtime//lux - Statement - ($_ _.then - @lux//try - @lux//program_args - )) - -(def: cap_shift - (_.% (_.int +64))) - -(runtime: (i64//left_shift param subject) - (_.return (_.bit_shl (..cap_shift param) subject))) - -(runtime: (i64//right_shift param subject) - (let [mask (|> (_.int +1) - (_.bit_shl (_.- param (_.int +64))) - (_.- (_.int +1)))] - ($_ _.then - (_.set (list param) (..cap_shift param)) - (_.return (|> subject - (_.bit_shr param) - (_.bit_and mask)))))) - -(runtime: (i64//division param subject) - (with_vars [floored] - ($_ _.then - (_.local/1 floored (_.// param subject)) - (let [potentially_floored? (_.< (_.int +0) floored) - inexact? (|> subject - (_.% param) - (_.= (_.int +0)) - _.not)] - (_.if (_.and potentially_floored? - inexact?) - (_.return (_.+ (_.int +1) floored)) - (_.return floored)))))) - -(runtime: (i64//remainder param subject) - (_.return (_.- (|> subject (..i64//division param) (_.* param)) - subject))) - -(def: runtime//i64 - Statement - ($_ _.then - @i64//left_shift - @i64//right_shift - @i64//division - @i64//remainder - )) - -(def: (find_byte_index subject param start) - (-> Expression Expression Expression Expression) - (_.apply/4 (_.var "string.find") subject param start (_.bool #1))) - -(def: (char_index subject byte_index) - (-> Expression Expression Expression) - (|> byte_index - (_.apply/3 (_.var "utf8.len") subject (_.int +1)))) - -(def: (byte_index subject char_index) - (-> Expression Expression Expression) - (|> char_index - (_.+ (_.int +1)) - (_.apply/2 (_.var "utf8.offset") subject))) - -(def: lux_index - (-> Expression Expression) - (_.- (_.int +1))) - -## TODO: Remove this once the Lua compiler becomes self-hosted. -(def: on_rembulan? - (_.= (_.string "Lua 5.3") - (_.var "_VERSION"))) - -(runtime: (text//index subject param start) - (with_expansions [<rembulan> ($_ _.then - (_.local/1 byte_index (|> start - (_.+ (_.int +1)) - (..find_byte_index subject param))) - (_.if (_.= _.nil byte_index) - (_.return ..none) - (_.return (..some (..lux_index byte_index))))) - <normal> ($_ _.then - (_.local/1 byte_index (|> start - (..byte_index subject) - (..find_byte_index subject param))) - (_.if (_.= _.nil byte_index) - (_.return ..none) - (_.return (..some (|> byte_index - (..char_index subject) - ..lux_index)))))] - (with_vars [byte_index] - (for {@.lua <normal>} - (_.if ..on_rembulan? - <rembulan> - <normal>))))) - -(runtime: (text//clip text offset length) - (with_expansions [<rembulan> (_.return (_.apply/3 (_.var "string.sub") text (_.+ (_.int +1) offset) (_.+ offset length))) - <normal> (_.return (_.apply/3 (_.var "string.sub") - text - (..byte_index text offset) - (|> (_.+ offset length) - ## (_.+ (_.int +1)) - (..byte_index text) - (_.- (_.int +1)))))] - (for {@.lua <normal>} - (_.if ..on_rembulan? - <rembulan> - <normal>)))) - -(runtime: (text//size subject) - (with_expansions [<rembulan> (_.return (_.apply/1 (_.var "string.len") subject)) - <normal> (_.return (_.apply/1 (_.var "utf8.len") subject))] - (for {@.lua <normal>} - (_.if ..on_rembulan? - <rembulan> - <normal>)))) - -(runtime: (text//char idx text) - (with_expansions [<rembulan> (with_vars [char] - ($_ _.then - (_.local/1 char (_.apply/* (list text idx) - (_.var "string.byte"))) - (_.if (_.= _.nil char) - (_.statement (_.error/1 (_.string "[Lux Error] Cannot get char from text."))) - (_.return char)))) - <normal> (with_vars [offset char] - ($_ _.then - (_.local/1 offset (_.apply/2 (_.var "utf8.offset") text idx)) - (_.if (_.= _.nil offset) - (_.statement (_.error/1 (_.string "[Lux Error] Cannot get char from text."))) - (_.return (_.apply/2 (_.var "utf8.codepoint") text offset)))))] - (for {@.lua <normal>} - (_.if ..on_rembulan? - <rembulan> - <normal>)))) - -(def: runtime//text - Statement - ($_ _.then - @text//index - @text//clip - @text//size - @text//char - )) - -(runtime: (array//write idx value array) - ($_ _.then - (_.set (list (..nth idx array)) value) - (_.return array))) - -(def: runtime//array - Statement - ($_ _.then - @array//write - )) - -(def: runtime - Statement - ($_ _.then - ..runtime//adt - ..runtime//lux - ..runtime//i64 - ..runtime//text - ..runtime//array - )) - -(def: #export generate - (Operation [Registry Output]) - (do ///////phase.monad - [_ (/////generation.execute! ..runtime) - _ (/////generation.save! ..module_id ..runtime)] - (wrap [(|> artifact.empty - artifact.resource - product.right) - (row.row [..module_id - (|> ..runtime - _.code - (\ utf8.codec encode))])]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux deleted file mode 100644 index 0d96fe6df..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux +++ /dev/null @@ -1,36 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [target - ["_" lua (#+ Expression)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." primitive] - ["///#" //// #_ - [analysis (#+ Variant Tuple)] - ["#." synthesis (#+ Synthesis)] - ["//#" /// #_ - ["#." phase ("#\." monad)]]]]) - -(def: #export (tuple generate archive elemsS+) - (Generator (Tuple Synthesis)) - (case elemsS+ - #.Nil - (///////phase\wrap (//primitive.text /////synthesis.unit)) - - (#.Cons singletonS #.Nil) - (generate archive singletonS) - - _ - (|> elemsS+ - (monad.map ///////phase.monad (generate archive)) - (///////phase\map _.array)))) - -(def: #export (variant generate archive [lefts right? valueS]) - (Generator (Variant Synthesis)) - (let [tag (if right? - (inc lefts) - lefts)] - (///////phase\map (//runtime.variant tag right?) - (generate archive valueS)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php.lux deleted file mode 100644 index 654c07bdf..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php.lux +++ /dev/null @@ -1,102 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." exception (#+ exception:)]] - [target - ["_" php]]] - ["." / #_ - [runtime (#+ Phase Phase!)] - ["#." primitive] - ["#." structure] - ["#." reference] - ["#." case] - ["#." loop] - ["#." function] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." extension] - ["/#" // #_ - [analysis (#+)] - ["#." synthesis] - ["//#" /// #_ - ["#." phase ("#\." monad)] - [reference (#+) - [variable (#+)]]]]]]]) - -(def: (statement expression archive synthesis) - Phase! - (case synthesis - (^template [<tag>] - [(^ (<tag> value)) - (//////phase\map _.return (expression archive synthesis))]) - ([////synthesis.bit] - [////synthesis.i64] - [////synthesis.f64] - [////synthesis.text] - [////synthesis.variant] - [////synthesis.tuple] - [#////synthesis.Reference] - [////synthesis.branch/get] - [////synthesis.function/apply] - [#////synthesis.Extension]) - - (^ (////synthesis.branch/case case)) - (/case.case! statement expression archive case) - - (^template [<tag> <generator>] - [(^ (<tag> value)) - (<generator> statement expression archive value)]) - ([////synthesis.branch/let /case.let!] - [////synthesis.branch/if /case.if!] - [////synthesis.loop/scope /loop.scope!] - [////synthesis.loop/recur /loop.recur!]) - - (^ (////synthesis.function/abstraction abstraction)) - (//////phase\map _.return (/function.function statement expression archive abstraction)) - )) - -(exception: #export cannot-recur-as-an-expression) - -(def: #export (expression archive synthesis) - Phase - (case synthesis - (^template [<tag> <generator>] - [(^ (<tag> value)) - (//////phase\wrap (<generator> value))]) - ([////synthesis.bit /primitive.bit] - [////synthesis.i64 /primitive.i64] - [////synthesis.f64 /primitive.f64] - [////synthesis.text /primitive.text]) - - (#////synthesis.Reference value) - (//reference.reference /reference.system archive value) - - (^template [<tag> <generator>] - [(^ (<tag> value)) - (<generator> expression archive value)]) - ([////synthesis.variant /structure.variant] - [////synthesis.tuple /structure.tuple] - [////synthesis.branch/let /case.let] - [////synthesis.branch/if /case.if] - [////synthesis.branch/get /case.get] - [////synthesis.function/apply /function.apply]) - - (^template [<tag> <generator>] - [(^ (<tag> value)) - (<generator> statement expression archive value)]) - ([////synthesis.branch/case /case.case] - [////synthesis.loop/scope /loop.scope] - [////synthesis.function/abstraction /function.function]) - - (^ (////synthesis.loop/recur _)) - (//////phase.throw ..cannot-recur-as-an-expression []) - - (#////synthesis.Extension extension) - (///extension.apply archive expression extension))) - -(def: #export generate - Phase - ..expression) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/case.lux deleted file mode 100644 index 728902418..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/case.lux +++ /dev/null @@ -1,297 +0,0 @@ -(.module: - [lux (#- case let if) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set]]] - [math - [number - ["i" int]]] - [target - ["_" php (#+ Expression Var Statement)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Phase! Generator Generator!)] - ["#." reference] - ["#." primitive] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." synthesis #_ - ["#/." case]] - ["/#" // #_ - ["#." synthesis (#+ Member Synthesis Path)] - ["#." generation] - ["//#" /// #_ - [reference - ["#." variable (#+ Register)]] - ["#." phase ("#\." monad)] - [meta - [archive (#+ Archive)]]]]]]]) - -(def: #export register - (-> Register Var) - (|>> (///reference.local //reference.system) :assume)) - -(def: #export capture - (-> Register Var) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: #export (let expression archive [valueS register bodyS]) - (Generator [Synthesis Register Synthesis]) - (do ///////phase.monad - [valueG (expression archive valueS) - bodyG (expression archive bodyS)] - (wrap (|> bodyG - (list (_.set (..register register) valueG)) - _.array/* - (_.nth (_.int +1)))))) - -(def: #export (let! statement expression archive [valueS register bodyS]) - (Generator! [Synthesis Register Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS) - body! (statement expression archive bodyS)] - (wrap ($_ _.then - (_.set! (..register register) valueO) - body!)))) - -(def: #export (if expression archive [testS thenS elseS]) - (Generator [Synthesis Synthesis Synthesis]) - (do ///////phase.monad - [testG (expression archive testS) - thenG (expression archive thenS) - elseG (expression archive elseS)] - (wrap (_.? testG thenG elseG)))) - -(def: #export (if! statement expression archive [testS thenS elseS]) - (Generator! [Synthesis Synthesis Synthesis]) - (do ///////phase.monad - [test! (expression archive testS) - then! (statement expression archive thenS) - else! (statement expression archive elseS)] - (wrap (_.if test! - then! - else!)))) - -(def: #export (get expression archive [pathP valueS]) - (Generator [(List Member) Synthesis]) - (do ///////phase.monad - [valueG (expression archive valueS)] - (wrap (list\fold (function (_ side source) - (.let [method (.case side - (^template [<side> <accessor>] - [(<side> lefts) - (<accessor> (_.int (.int lefts)))]) - ([#.Left //runtime.tuple//left] - [#.Right //runtime.tuple//right]))] - (method source))) - valueG - (list.reverse pathP))))) - -(def: @savepoint (_.var "lux_pm_savepoint")) -(def: @cursor (_.var "lux_pm_cursor")) -(def: @temp (_.var "lux_pm_temp")) - -(def: (push! value) - (-> Expression Statement) - (_.; (_.array_push/2 [@cursor value]))) - -(def: peek_and_pop - Expression - (_.array_pop/1 @cursor)) - -(def: pop! - Statement - (_.; ..peek_and_pop)) - -(def: peek - Expression - (_.nth (|> @cursor _.count/1 (_.- (_.int +1))) - @cursor)) - -(def: save! - Statement - (.let [cursor (_.array_slice/2 [@cursor (_.int +0)])] - (_.; (_.array_push/2 [@savepoint cursor])))) - -(def: restore! - Statement - (_.set! @cursor (_.array_pop/1 @savepoint))) - -(def: fail! _.break) - -(def: (multi_pop! pops) - (-> Nat Statement) - (_.; (_.array_splice/3 [@cursor - (_.int +0) - (_.int (i.* -1 (.int pops)))]))) - -(template [<name> <flag> <prep>] - [(def: (<name> simple? idx) - (-> Bit Nat Statement) - ($_ _.then - (_.set! @temp (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>))) - (.if simple? - (_.when (_.is_null/1 @temp) - fail!) - (_.if (_.is_null/1 @temp) - fail! - (..push! @temp)))))] - - [left_choice _.null (<|)] - [right_choice (_.string "") inc] - ) - -(def: (alternation pre! post!) - (-> Statement Statement Statement) - ($_ _.then - (_.do_while (_.bool false) - ($_ _.then - ..save! - pre!)) - ($_ _.then - ..restore! - post!))) - -(def: (pattern_matching' statement expression archive) - (Generator! Path) - (function (recur pathP) - (.case pathP - (#/////synthesis.Then bodyS) - (statement expression archive bodyS) - - #/////synthesis.Pop - (///////phase\wrap ..pop!) - - (#/////synthesis.Bind register) - (///////phase\wrap (_.set! (..register register) ..peek)) - - (#/////synthesis.Bit_Fork when thenP elseP) - (do {! ///////phase.monad} - [then! (recur thenP) - else! (.case elseP - (#.Some elseP) - (recur elseP) - - #.None - (wrap ..fail!))] - (wrap (.if when - (_.if ..peek - then! - else!) - (_.if ..peek - else! - then!)))) - - (^template [<tag> <format>] - [(<tag> cons) - (do {! ///////phase.monad} - [clauses (monad.map ! (function (_ [match then]) - (do ! - [then! (recur then)] - (wrap [(_.=== (|> match <format>) - ..peek) - then!]))) - (#.Cons cons))] - (wrap (_.cond clauses ..fail!)))]) - ([#/////synthesis.I64_Fork //primitive.i64] - [#/////synthesis.F64_Fork //primitive.f64] - [#/////synthesis.Text_Fork //primitive.text]) - - (^template [<complex> <simple> <choice>] - [(^ (<complex> idx)) - (///////phase\wrap (<choice> false idx)) - - (^ (<simple> idx nextP)) - (|> nextP - recur - (\ ///////phase.monad map (_.then (<choice> true idx))))]) - ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice] - [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice]) - - (^ (/////synthesis.member/left 0)) - (///////phase\wrap (|> ..peek (_.nth (_.int +0)) ..push!)) - - (^template [<pm> <getter>] - [(^ (<pm> lefts)) - (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))]) - ([/////synthesis.member/left //runtime.tuple//left] - [/////synthesis.member/right //runtime.tuple//right]) - - (^ (/////synthesis.!bind_top register thenP)) - (do ///////phase.monad - [then! (recur thenP)] - (///////phase\wrap ($_ _.then - (_.set! (..register register) ..peek_and_pop) - then!))) - - ## (^ (/////synthesis.!multi_pop nextP)) - ## (.let [[extra_pops nextP'] (////synthesis/case.count_pops nextP)] - ## (do ///////phase.monad - ## [next! (recur nextP')] - ## (///////phase\wrap ($_ _.then - ## (..multi_pop! (n.+ 2 extra_pops)) - ## next!)))) - - (^template [<tag> <combinator>] - [(^ (<tag> preP postP)) - (do ///////phase.monad - [pre! (recur preP) - post! (recur postP)] - (wrap (<combinator> pre! post!)))]) - ([/////synthesis.path/seq _.then] - [/////synthesis.path/alt ..alternation])))) - -(def: (pattern_matching statement expression archive pathP) - (Generator! Path) - (do ///////phase.monad - [iteration! (pattern_matching' statement expression archive pathP)] - (wrap ($_ _.then - (_.do_while (_.bool false) - iteration!) - (_.throw (_.new (_.constant "Exception") (list (_.string ////synthesis/case.pattern_matching_error)))))))) - -(def: (gensym prefix) - (-> Text (Operation Text)) - (\ ///////phase.monad map (|>> %.nat (format prefix)) /////generation.next)) - -(def: #export dependencies - (-> Path (List Var)) - (|>> ////synthesis/case.storage - (get@ #////synthesis/case.dependencies) - set.to_list - (list\map (function (_ variable) - (.case variable - (#///////variable.Local register) - (..register register) - - (#///////variable.Foreign register) - (..capture register)))))) - -(def: #export (case! statement expression archive [valueS pathP]) - (Generator! [Synthesis Path]) - (do ///////phase.monad - [stack_init (expression archive valueS) - pattern_matching! (pattern_matching statement expression archive pathP)] - (wrap ($_ _.then - (_.set! @cursor (_.array/* (list stack_init))) - (_.set! @savepoint (_.array/* (list))) - pattern_matching!)))) - -(def: #export (case statement expression archive [valueS pathP]) - (-> Phase! (Generator [Synthesis Path])) - (do {! ///////phase.monad} - [[[case_module case_artifact] case!] (/////generation.with_new_context archive - (case! statement expression archive [valueS pathP])) - #let [@case (_.constant (///reference.artifact [case_module case_artifact])) - @dependencies+ (..dependencies (/////synthesis.path/seq (/////synthesis.path/then valueS) - pathP)) - directive (_.define_function @case (list\map _.parameter @dependencies+) case!)] - _ (/////generation.execute! directive) - _ (/////generation.save! case_artifact directive)] - (wrap (_.apply/* @dependencies+ @case)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/extension.lux deleted file mode 100644 index 3bc0a0887..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/extension.lux +++ /dev/null @@ -1,13 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - [// - [runtime (#+ Bundle)]] - [/ - ["." common]]) - -(def: #export bundle - Bundle - common.bundle) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/extension/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/extension/common.lux deleted file mode 100644 index 2a4c4c50d..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/extension/common.lux +++ /dev/null @@ -1,111 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function]] - [data - ["." product] - ["." text] - [number - ["f" frac]] - [collection - ["." dictionary]]] - [target - ["_" php (#+ Expression)]]] - ["." /// #_ - ["#." runtime (#+ Operation Phase Handler Bundle)] - ["#." primitive] - [// - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - [// - [extension - ["." bundle]]]]]) - -(def: lux-procs - Bundle - (|> bundle.empty - (bundle.install "is" (binary (product.uncurry _.=))) - (bundle.install "try" (unary ///runtime.lux//try)))) - -(def: i64-procs - Bundle - (<| (bundle.prefix "i64") - (|> bundle.empty - (bundle.install "and" (binary (product.uncurry _.bit-and))) - (bundle.install "or" (binary (product.uncurry _.bit-or))) - (bundle.install "xor" (binary (product.uncurry _.bit-xor))) - (bundle.install "left-shift" (binary (product.uncurry _.bit-shl))) - (bundle.install "logical-right-shift" (binary (product.uncurry ///runtime.i64//logic-right-shift))) - (bundle.install "arithmetic-right-shift" (binary (product.uncurry _.bit-shr))) - (bundle.install "=" (binary (product.uncurry _.=))) - (bundle.install "+" (binary (product.uncurry _.+))) - (bundle.install "-" (binary (product.uncurry _.-))) - ))) - -(def: int-procs - Bundle - (<| (bundle.prefix "int") - (|> bundle.empty - (bundle.install "<" (binary (product.uncurry _.<))) - (bundle.install "*" (binary (product.uncurry _.*))) - (bundle.install "/" (binary (product.uncurry _./))) - (bundle.install "%" (binary (product.uncurry _.%))) - (bundle.install "frac" (unary _.floatval/1)) - (bundle.install "char" (unary _.chr/1))))) - -(def: frac-procs - Bundle - (<| (bundle.prefix "frac") - (|> bundle.empty - (bundle.install "+" (binary (product.uncurry _.+))) - (bundle.install "-" (binary (product.uncurry _.-))) - (bundle.install "*" (binary (product.uncurry _.*))) - (bundle.install "/" (binary (product.uncurry _./))) - (bundle.install "%" (binary (product.uncurry _.%))) - (bundle.install "=" (binary (product.uncurry _.=))) - (bundle.install "<" (binary (product.uncurry _.<))) - (bundle.install "int" (unary _.intval/1)) - (bundle.install "encode" (unary _.strval/1)) - (bundle.install "decode" (unary (|>> _.floatval/1 ///runtime.some))) - ))) - -(def: (text//index [startO partO textO]) - (Trinary (Expression Any)) - (///runtime.text//index textO partO startO)) - -(def: text-procs - Bundle - (<| (bundle.prefix "text") - (|> bundle.empty - (bundle.install "=" (binary (product.uncurry _.=))) - (bundle.install "<" (binary (product.uncurry _.<))) - (bundle.install "concat" (binary (product.uncurry _.concat))) - (bundle.install "index" (trinary text//index)) - (bundle.install "size" (unary _.strlen/1)) - (bundle.install "char" (binary (function (text//char [text idx]) - (|> text (_.nth idx) _.ord/1)))) - (bundle.install "clip" (trinary (function (text//clip [from to text]) - (_.substr/3 [text from (_.- from to)])))) - ))) - -(def: io-procs - Bundle - (<| (bundle.prefix "io") - (|> bundle.empty - (bundle.install "log" (unary (|>> (_.concat (_.string text.new-line)) _.print/1))) - (bundle.install "error" (unary ///runtime.io//throw!)) - (bundle.install "exit" (unary _.exit/1)) - (bundle.install "current-time" (nullary (|>> _.time/0 (_.* (_.int +1,000)))))))) - -(def: #export bundle - Bundle - (<| (bundle.prefix "lux") - (|> lux-procs - (dictionary.merge i64-procs) - (dictionary.merge int-procs) - (dictionary.merge frac-procs) - (dictionary.merge text-procs) - (dictionary.merge io-procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/function.lux deleted file mode 100644 index 1194cfe9a..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/function.lux +++ /dev/null @@ -1,115 +0,0 @@ -(.module: - [lux (#- Global function) - [abstract - ["." monad (#+ do)]] - [control - pipe] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [target - ["_" php (#+ Var Global Expression Argument Label Statement)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Phase! Generator)] - ["#." reference] - ["#." case] - ["/#" // #_ - ["#." reference] - ["//#" /// #_ - [analysis (#+ Variant Tuple Abstraction Application Analysis)] - [synthesis (#+ Synthesis)] - ["#." generation (#+ Context)] - ["//#" /// #_ - [arity (#+ Arity)] - ["#." phase ("#\." monad)] - [reference - [variable (#+ Register Variable)]]]]]]) - -(def: #export (apply expression archive [functionS argsS+]) - (Generator (Application Synthesis)) - (do {! ///////phase.monad} - [functionG (expression archive functionS) - argsG+ (monad.map ! (expression archive) argsS+)] - (wrap (_.apply/*' argsG+ functionG)))) - -(def: capture - (-> Register Var) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: input - (|>> inc //case.register)) - -(def: (@scope function_name) - (-> Context Label) - (_.label (format (///reference.artifact function_name) "_scope"))) - -(def: (with_closure inits @selfG @selfL body!) - (-> (List Expression) Global Var Statement [Statement Expression]) - (case inits - #.Nil - [($_ _.then - (_.set! @selfL (_.closure (list (_.reference @selfL)) (list) body!)) - (_.set! @selfG @selfL)) - @selfG] - - _ - (let [@inits (|> (list.enumeration inits) - (list\map (|>> product.left ..capture)))] - [(_.set! @selfG (_.closure (list) (list\map _.parameter @inits) - ($_ _.then - (_.set! @selfL (_.closure (list& (_.reference @selfL) (list\map _.reference @inits)) - (list) - body!)) - (_.return @selfL)))) - (_.apply/* inits @selfG)]))) - -(def: #export (function statement expression archive [environment arity bodyS]) - (-> Phase! (Generator (Abstraction Synthesis))) - (do {! ///////phase.monad} - [[function_name body!] (/////generation.with_new_context archive - (do ! - [@scope (\ ! map ..@scope - (/////generation.context archive))] - (/////generation.with_anchor [1 @scope] - (statement expression archive bodyS)))) - closureG+ (monad.map ! (expression archive) environment) - #let [@curried (_.var "curried") - arityG (|> arity .int _.int) - @num_args (_.var "num_args") - @scope (..@scope function_name) - @selfG (_.global (///reference.artifact function_name)) - @selfL (_.var (///reference.artifact function_name)) - initialize_self! (_.set! (//case.register 0) @selfL) - initialize! (list\fold (.function (_ post pre!) - ($_ _.then - pre! - (_.set! (..input post) (_.nth (|> post .int _.int) @curried)))) - initialize_self! - (list.indices arity))] - #let [[definition instantiation] (..with_closure closureG+ @selfG @selfL - ($_ _.then - (_.set! @num_args (_.func_num_args/0 [])) - (_.set! @curried (_.func_get_args/0 [])) - (_.cond (list [(|> @num_args (_.=== arityG)) - ($_ _.then - initialize! - (_.set_label @scope) - body!)] - [(|> @num_args (_.> arityG)) - (let [arity_inputs (_.array_slice/3 [@curried (_.int +0) arityG]) - extra_inputs (_.array_slice/2 [@curried arityG]) - next (_.call_user_func_array/2 [@selfL arity_inputs])] - (_.return (_.call_user_func_array/2 [next extra_inputs])))]) - ## (|> @num_args (_.< arityG)) - (let [@missing (_.var "missing")] - (_.return (<| (_.closure (list (_.reference @selfL) (_.reference @curried)) (list)) - ($_ _.then - (_.set! @missing (_.func_get_args/0 [])) - (_.return (_.call_user_func_array/2 [@selfL (_.array_merge/+ @curried (list @missing))]))))))) - ))] - _ (/////generation.execute! definition) - _ (/////generation.save! (product.right function_name) definition)] - (wrap instantiation))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/loop.lux deleted file mode 100644 index b1fb94050..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/loop.lux +++ /dev/null @@ -1,121 +0,0 @@ -(.module: - [lux (#- Scope) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set (#+ Set)]]] - [math - [number - ["n" nat]]] - [target - ["_" php (#+ Var Expression Label Statement)]]] - ["." // #_ - [runtime (#+ Operation Phase Phase! Generator Generator!)] - ["#." case] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - [synthesis - ["." case]] - ["/#" // #_ - ["."synthesis (#+ Scope Synthesis)] - ["#." generation] - ["//#" /// #_ - ["#." phase] - [meta - [archive (#+ Archive)]] - [reference - [variable (#+ Register)]]]]]]]) - -(def: @scope - (-> Nat Label) - (|>> %.nat (format "scope") _.label)) - -(def: (setup offset bindings body) - (-> Register (List Expression) Statement Statement) - (|> bindings - list.enumeration - (list\map (function (_ [register value]) - (let [variable (//case.register (n.+ offset register))] - (_.set! variable value)))) - list.reverse - (list\fold _.then body))) - -(def: #export (scope! statement expression archive [start initsS+ bodyS]) - (Generator! (Scope Synthesis)) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (statement expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [@scope (\ ! map ..@scope /////generation.next) - initsO+ (monad.map ! (expression archive) initsS+) - body! (/////generation.with_anchor [start @scope] - (statement expression archive bodyS))] - (wrap (..setup start initsO+ - ($_ _.then - (_.set_label @scope) - body!)))))) - -(def: #export (scope statement expression archive [start initsS+ bodyS]) - (-> Phase! (Generator (Scope Synthesis))) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [[[loop_module loop_artifact] scope!] (/////generation.with_new_context archive - (..scope! statement expression archive [start initsS+ bodyS])) - #let [locals (|> initsS+ - list.enumeration - (list\map (|>> product.left (n.+ start) //case.register _.parameter))) - @loop (_.constant (///reference.artifact [loop_module loop_artifact])) - loop_variables (set.from_list _.hash (list\map product.right locals)) - referenced_variables (: (-> Synthesis (Set Var)) - (|>> synthesis.path/then - //case.dependencies - (set.from_list _.hash))) - [directive instantiation] (: [Statement Expression] - (case (|> (list\map referenced_variables initsS+) - (list\fold set.union (referenced_variables bodyS)) - (set.difference loop_variables) - set.to_list) - #.Nil - [(_.define_function @loop (list) scope!) - @loop] - - foreigns - [(<| (_.define_function @loop (list\map _.parameter foreigns)) - (_.return (_.closure (list\map _.parameter foreigns) (list) scope!))) - (_.apply/* foreigns @loop)]))] - _ (/////generation.execute! directive) - _ (/////generation.save! loop_artifact directive)] - (wrap (_.apply/* (list) instantiation))))) - -(def: @temp - (_.var "lux_recur_values")) - -(def: #export (recur! statement expression archive argsS+) - (Generator! (List Synthesis)) - (do {! ///////phase.monad} - [[offset @scope] /////generation.anchor - argsO+ (monad.map ! (expression archive) argsS+)] - (wrap ($_ _.then - (_.set! @temp (_.array/* argsO+)) - (..setup offset - (|> argsO+ - list.enumeration - (list\map (function (_ [idx _]) - (_.nth (_.int (.int idx)) @temp)))) - (_.go_to @scope)))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux deleted file mode 100644 index 242519aa9..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux +++ /dev/null @@ -1,31 +0,0 @@ -(.module: - [lux (#- i64) - [control - [pipe (#+ cond> new>)]] - [math - [number - ["." frac]]] - [target - ["_" php (#+ Literal Expression)]]] - ["." // #_ - ["#." runtime]]) - -(def: #export bit - (-> Bit Literal) - _.bool) - -(def: #export (i64 value) - (-> (I64 Any) Expression) - (let [h32 (|> value //runtime.high .int _.int) - l32 (|> value //runtime.low .int _.int)] - (|> h32 - (_.bit_shl (_.int +32)) - (_.bit_or l32)))) - -(def: #export f64 - (-> Frac Literal) - _.float) - -(def: #export text - (-> Text Literal) - _.string) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/reference.lux deleted file mode 100644 index de532a9dc..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/reference.lux +++ /dev/null @@ -1,12 +0,0 @@ -(.module: - [lux #* - [target - ["_" php (#+ Expression)]]] - [/// - [reference (#+ System)]]) - -(implementation: #export system - (System Expression) - - (def: constant _.global) - (def: variable _.var)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux deleted file mode 100644 index 041993fb5..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux +++ /dev/null @@ -1,609 +0,0 @@ -(.module: - [lux (#- Location inc) - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<.>" code]]] - [data - ["." product] - ["." text ("#\." hash) - ["%" format (#+ format)] - [encoding - ["." utf8]]] - [collection - ["." list ("#\." functor)] - ["." row]]] - ["." macro - [syntax (#+ syntax:)] - ["." code]] - [math - [number (#+ hex) - ["." i64]]] - ["@" target - ["_" php (#+ Expression Label Constant Var Computation Literal Statement)]]] - ["." /// #_ - ["#." reference] - ["//#" /// #_ - ["#." synthesis (#+ Synthesis)] - ["#." generation] - ["//#" /// - ["#." phase] - [reference - [variable (#+ Register)]] - [meta - [archive (#+ Output Archive) - ["." artifact (#+ Registry)]]]]]]) - -(template [<name> <base>] - [(type: #export <name> - (<base> [Nat Label] Expression Statement))] - - [Operation /////generation.Operation] - [Phase /////generation.Phase] - [Handler /////generation.Handler] - [Bundle /////generation.Bundle] - ) - -(type: #export (Generator i) - (-> Phase Archive i (Operation Expression))) - -(type: #export Phase! - (-> Phase Archive Synthesis (Operation Statement))) - -(type: #export (Generator! i) - (-> Phase! Phase Archive i (Operation Statement))) - -(def: #export unit - (_.string /////synthesis.unit)) - -(def: (flag value) - (-> Bit Literal) - (if value - ..unit - _.null)) - -(def: (feature name definition) - (-> Constant (-> Constant Statement) Statement) - (definition name)) - -(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} - body) - (do {! meta.monad} - [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] - (wrap (list (` (let [(~+ (|> vars - (list.zip/2 ids) - (list\map (function (_ [id var]) - (list (code.local_identifier var) - (` (_.var (~ (code.text (format "v" (%.nat id))))))))) - list.concat))] - (~ body))))))) - -(def: module_id - 0) - -(syntax: (runtime: {declaration (<>.or <code>.local_identifier - (<code>.form (<>.and <code>.local_identifier - (<>.some <code>.local_identifier))))} - code) - (do meta.monad - [runtime_id meta.count] - (macro.with_gensyms [g!_] - (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id])) - runtime_name (` (_.constant (~ (code.text (%.code runtime)))))] - (case declaration - (#.Left name) - (macro.with_gensyms [g!_] - (let [g!name (code.local_identifier name)] - (wrap (list (` (def: #export (~ g!name) - Var - (~ runtime_name))) - - (` (def: (~ (code.local_identifier (format "@" name))) - Statement - (..feature (~ runtime_name) - (function ((~ g!_) (~ g!name)) - (_.define (~ g!name) (~ code)))))))))) - - (#.Right [name inputs]) - (macro.with_gensyms [g!_] - (let [g!name (code.local_identifier name) - inputsC (list\map code.local_identifier inputs) - inputs_typesC (list\map (function.constant (` _.Expression)) - inputs)] - (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) - (-> (~+ inputs_typesC) Computation) - (_.apply/* (list (~+ inputsC)) (~ runtime_name)))) - - (` (def: (~ (code.local_identifier (format "@" name))) - Statement - (..feature (~ runtime_name) - (function ((~ g!_) (~ g!_)) - (..with_vars [(~+ inputsC)] - (_.define_function (~ g!_) - (list (~+ (list\map (|>> (~) [false] (`)) inputsC))) - (~ code)))))))))))))))) - -(runtime: (io//log! message) - ($_ _.then - (_.echo message) - (_.echo (_.string text.new_line)) - (_.return ..unit))) - -(runtime: (io//throw! message) - ($_ _.then - (_.throw (_.new (_.constant "Exception") (list message))) - (_.return ..unit))) - -(def: runtime//io - Statement - ($_ _.then - @io//log! - @io//throw! - )) - -(def: #export tuple_size_field - "_lux_size") - -(def: tuple_size - (_.nth (_.string ..tuple_size_field))) - -(def: jphp? - (_.=== (_.string "5.6.99") (_.phpversion/0 []))) - -(runtime: (array//length array) - ## TODO: Get rid of this as soon as JPHP is no longer necessary. - (_.if ..jphp? - (_.return (..tuple_size array)) - (_.return (_.count/1 array)))) - -(runtime: (array//write idx value array) - ($_ _.then - (_.set! (_.nth idx array) value) - (_.return array))) - -(def: runtime//array - Statement - ($_ _.then - @array//length - @array//write - )) - -(def: jphp_last_index - (|>> ..tuple_size (_.- (_.int +1)))) - -(def: normal_last_index - (|>> _.count/1 (_.- (_.int +1)))) - -(with_expansions [<recur> (as_is ($_ _.then - (_.set! lefts (_.- last_index_right lefts)) - (_.set! tuple (_.nth last_index_right tuple))))] - (runtime: (tuple//make size values) - (_.if ..jphp? - ($_ _.then - (_.set! (..tuple_size values) size) - (_.return values)) - ## https://www.php.net/manual/en/language.operators.assignment.php - ## https://www.php.net/manual/en/language.references.php - ## https://www.php.net/manual/en/functions.arguments.php - ## https://www.php.net/manual/en/language.oop5.references.php - ## https://www.php.net/manual/en/class.arrayobject.php - (_.return (_.new (_.constant "ArrayObject") (list values))))) - - (runtime: (tuple//left lefts tuple) - (with_vars [last_index_right] - (<| (_.while (_.bool true)) - ($_ _.then - (_.if ..jphp? - (_.set! last_index_right (..jphp_last_index tuple)) - (_.set! last_index_right (..normal_last_index tuple))) - (_.if (_.> lefts last_index_right) - ## No need for recursion - (_.return (_.nth lefts tuple)) - ## Needs recursion - <recur>))))) - - ## TODO: Get rid of this as soon as JPHP is no longer necessary. - (runtime: (tuple//slice offset input) - (with_vars [size index output] - ($_ _.then - (_.set! size (..array//length input)) - (_.set! index (_.int +0)) - (_.set! output (_.array/* (list))) - (<| (_.while (|> index (_.+ offset) (_.< size))) - ($_ _.then - (_.set! (_.nth index output) (_.nth (_.+ offset index) input)) - (_.set! index (_.+ (_.int +1) index)) - )) - (_.return (..tuple//make (_.- offset size) output)) - ))) - - (runtime: (tuple//right lefts tuple) - (with_vars [last_index_right right_index] - (<| (_.while (_.bool true)) - ($_ _.then - (_.if ..jphp? - (_.set! last_index_right (..jphp_last_index tuple)) - (_.set! last_index_right (..normal_last_index tuple))) - (_.set! right_index (_.+ (_.int +1) lefts)) - (_.cond (list [(_.=== last_index_right right_index) - (_.return (_.nth right_index tuple))] - [(_.> last_index_right right_index) - ## Needs recursion. - <recur>]) - (_.if ..jphp? - (_.return (..tuple//make (_.- right_index (..tuple_size tuple)) - (..tuple//slice right_index tuple))) - (_.return (..tuple//make (_.- right_index (_.count/1 tuple)) - (_.array_slice/2 [(_.do "getArrayCopy" (list) tuple) right_index]))))) - ))))) - -(def: #export variant_tag_field "_lux_tag") -(def: #export variant_flag_field "_lux_flag") -(def: #export variant_value_field "_lux_value") - -(runtime: (sum//make tag last? value) - (_.return (_.array/** (list [(_.string ..variant_tag_field) tag] - [(_.string ..variant_flag_field) last?] - [(_.string ..variant_value_field) value])))) - -(def: #export (variant tag last? value) - (-> Nat Bit Expression Computation) - (sum//make (_.int (.int tag)) - (..flag last?) - value)) - -(def: #export none - Computation - (..variant 0 #0 ..unit)) - -(def: #export some - (-> Expression Computation) - (..variant 1 #1)) - -(def: #export left - (-> Expression Computation) - (..variant 0 #0)) - -(def: #export right - (-> Expression Computation) - (..variant 1 #1)) - -(runtime: (sum//get sum wantsLast wantedTag) - (let [no_match! (_.return _.null) - sum_tag (_.nth (_.string ..variant_tag_field) sum) - ## sum_tag (_.nth (_.int +0) sum) - sum_flag (_.nth (_.string ..variant_flag_field) sum) - ## sum_flag (_.nth (_.int +1) sum) - sum_value (_.nth (_.string ..variant_value_field) sum) - ## sum_value (_.nth (_.int +2) sum) - is_last? (_.=== ..unit sum_flag) - test_recursion! (_.if is_last? - ## Must recurse. - ($_ _.then - (_.set! wantedTag (_.- sum_tag wantedTag)) - (_.set! sum sum_value)) - no_match!)] - (<| (_.while (_.bool true)) - (_.cond (list [(_.=== sum_tag wantedTag) - (_.if (_.=== wantsLast sum_flag) - (_.return sum_value) - test_recursion!)] - - [(_.< wantedTag sum_tag) - test_recursion!] - - [(_.=== ..unit wantsLast) - (_.return (sum//make (_.- wantedTag sum_tag) sum_flag sum_value))]) - no_match!)))) - -(def: runtime//adt - Statement - ($_ _.then - @tuple//make - @tuple//left - @tuple//slice - @tuple//right - @sum//make - @sum//get - )) - -(runtime: (lux//try op) - (with_vars [value] - (_.try ($_ _.then - (_.set! value (_.apply/1 op [..unit])) - (_.return (..right value))) - (list (with_vars [error] - {#_.class (_.constant "Exception") - #_.exception error - #_.handler (_.return (..left (_.do "getMessage" (list) error)))}))))) - -(runtime: (lux//program_args inputs) - (with_vars [head tail] - ($_ _.then - (_.set! tail ..none) - (<| (_.for_each (_.array_reverse/1 inputs) head) - (_.set! tail (..some (_.array/* (list head tail))))) - (_.return tail)))) - -(def: runtime//lux - Statement - ($_ _.then - @lux//try - @lux//program_args - )) - -(def: #export high - (-> (I64 Any) (I64 Any)) - (i64.right_shift 32)) - -(def: #export low - (-> (I64 Any) (I64 Any)) - (let [mask (dec (i64.left_shift 32 1))] - (|>> (i64.and mask)))) - -(runtime: (i64//right_shift param subject) - (let [## The mask has to be calculated this way instead of in a more straightforward way - ## because in some languages, 1<<63 = max_negative_value - ## and max_negative_value-1 = max_positive_value. - ## And bitwise, max_positive_value works out to the mask that is desired when param = 0. - ## However, in PHP, max_negative_value-1 underflows and gets cast into a float. - ## And this messes up the computation. - ## This slightly more convoluted calculation avoids that problem. - mask (|> (_.int +1) - (_.bit_shl (_.- param (_.int +63))) - (_.- (_.int +1)) - (_.bit_shl (_.int +1)) - (_.+ (_.int +1)))] - ($_ _.then - (_.set! param (_.% (_.int +64) param)) - (_.if (_.=== (_.int +0) param) - (_.return subject) - (_.return (|> subject - (_.bit_shr param) - (_.bit_and mask))))))) - -(runtime: (i64//char code) - (_.if ..jphp? - (_.return (_.chr/1 [code])) - (_.return (|> code - [(_.string "V")] - _.pack/2 - [(_.string "UTF-32LE") (_.string "UTF-8")] - _.iconv/3)))) - -(runtime: (i64//+ parameter subject) - (let [high_16 (..i64//right_shift (_.int +16)) - low_16 (_.bit_and (_.int (.int (hex "FFFF")))) - - cap_16 low_16 - hh (..i64//right_shift (_.int +48)) - hl (|>> (..i64//right_shift (_.int +32)) cap_16) - lh (|>> (..i64//right_shift (_.int +16)) cap_16) - ll cap_16 - - up_16 (_.bit_shl (_.int +16))] - (with_vars [l48 l32 l16 l00 - r48 r32 r16 r00 - x48 x32 x16 x00] - ($_ _.then - (_.set! l48 (hh subject)) - (_.set! l32 (hl subject)) - (_.set! l16 (lh subject)) - (_.set! l00 (ll subject)) - - (_.set! r48 (hh parameter)) - (_.set! r32 (hl parameter)) - (_.set! r16 (lh parameter)) - (_.set! r00 (ll parameter)) - - (_.set! x00 (_.+ l00 r00)) - - (_.set! x16 (|> (high_16 x00) - (_.+ l16) - (_.+ r16))) - (_.set! x00 (low_16 x00)) - - (_.set! x32 (|> (high_16 x16) - (_.+ l32) - (_.+ r32))) - (_.set! x16 (low_16 x16)) - - (_.set! x48 (|> (high_16 x32) - (_.+ l48) - (_.+ r48) - low_16)) - (_.set! x32 (low_16 x32)) - - (let [high32 (_.bit_or (up_16 x48) x32) - low32 (_.bit_or (up_16 x16) x00)] - (_.return (|> high32 - (_.bit_shl (_.int +32)) - (_.bit_or low32)))) - )))) - -(runtime: (i64//negate value) - (let [i64//min (_.int (.int (hex "80,00,00,00,00,00,00,00")))] - (_.if (_.=== i64//min value) - (_.return i64//min) - (_.return (..i64//+ (_.int +1) (_.bit_not value)))))) - -(runtime: (i64//- parameter subject) - (_.return (..i64//+ (..i64//negate parameter) subject))) - -(runtime: (i64//* parameter subject) - (let [high_16 (..i64//right_shift (_.int +16)) - low_16 (_.bit_and (_.int (.int (hex "FFFF")))) - - cap_16 low_16 - hh (..i64//right_shift (_.int +48)) - hl (|>> (..i64//right_shift (_.int +32)) cap_16) - lh (|>> (..i64//right_shift (_.int +16)) cap_16) - ll cap_16 - - up_16 (_.bit_shl (_.int +16))] - (with_vars [l48 l32 l16 l00 - r48 r32 r16 r00 - x48 x32 x16 x00] - ($_ _.then - (_.set! l48 (hh subject)) - (_.set! l32 (hl subject)) - (_.set! l16 (lh subject)) - (_.set! l00 (ll subject)) - - (_.set! r48 (hh parameter)) - (_.set! r32 (hl parameter)) - (_.set! r16 (lh parameter)) - (_.set! r00 (ll parameter)) - - (_.set! x00 (_.* l00 r00)) - (_.set! x16 (high_16 x00)) - (_.set! x00 (low_16 x00)) - - (_.set! x16 (|> x16 (_.+ (_.* l16 r00)))) - (_.set! x32 (high_16 x16)) (_.set! x16 (low_16 x16)) - (_.set! x16 (|> x16 (_.+ (_.* l00 r16)))) - (_.set! x32 (|> x32 (_.+ (high_16 x16)))) (_.set! x16 (low_16 x16)) - - (_.set! x32 (|> x32 (_.+ (_.* l32 r00)))) - (_.set! x48 (high_16 x32)) (_.set! x32 (low_16 x32)) - (_.set! x32 (|> x32 (_.+ (_.* l16 r16)))) - (_.set! x48 (|> x48 (_.+ (high_16 x32)))) (_.set! x32 (low_16 x32)) - (_.set! x32 (|> x32 (_.+ (_.* l00 r32)))) - (_.set! x48 (|> x48 (_.+ (high_16 x32)))) (_.set! x32 (low_16 x32)) - - (_.set! x48 (|> x48 - (_.+ (_.* l48 r00)) - (_.+ (_.* l32 r16)) - (_.+ (_.* l16 r32)) - (_.+ (_.* l00 r48)) - low_16)) - - (let [high32 (_.bit_or (up_16 x48) x32) - low32 (_.bit_or (up_16 x16) x00)] - (_.return (|> high32 - (_.bit_shl (_.int +32)) - (_.bit_or low32)))) - )))) - -(def: runtime//i64 - Statement - ($_ _.then - @i64//right_shift - @i64//char - @i64//+ - @i64//negate - @i64//- - @i64//* - )) - -(runtime: (text//size value) - (_.if ..jphp? - (_.return (_.strlen/1 [value])) - (_.return (_.iconv_strlen/1 [value])))) - -(runtime: (text//index subject param start) - (_.if (_.=== (_.string "") param) - (_.return (..some (_.int +0))) - (with_vars [idx] - (_.if ..jphp? - ($_ _.then - (_.set! idx (_.strpos/3 [subject param start])) - (_.if (_.=== (_.bool false) idx) - (_.return ..none) - (_.return (..some idx)))) - ($_ _.then - (_.set! idx (_.iconv_strpos/3 [subject param start])) - (_.if (_.=== (_.bool false) idx) - (_.return ..none) - (_.return (..some idx)))))))) - -(def: (within? top value) - (-> Expression Expression Computation) - (_.and (|> value (_.>= (_.int +0))) - (|> value (_.< top)))) - -(runtime: (text//clip offset length text) - (_.if ..jphp? - (_.return (_.substr/3 [text offset length])) - (_.return (_.iconv_substr/3 [text offset length])))) - -(runtime: (text//char idx text) - (_.if (|> idx (within? (text//size text))) - (_.if ..jphp? - (_.return (_.ord/1 (_.substr/3 [text idx (_.int +1)]))) - (_.return (|> (_.iconv_substr/3 [text idx (_.int +1)]) - [(_.string "UTF-8") (_.string "UTF-32LE")] - _.iconv/3 - [(_.string "V")] - _.unpack/2 - (_.nth (_.int +1))))) - (_.throw (_.new (_.constant "Exception") (list (_.string "[Lux Error] Cannot get char from text.")))))) - -(def: runtime//text - Statement - ($_ _.then - @text//size - @text//index - @text//clip - @text//char - )) - -(runtime: (f64//decode value) - (with_vars [output] - ($_ _.then - (_.set! output (_.floatval/1 value)) - (_.if (_.=== (_.float +0.0) output) - (_.if ($_ _.or - (_.=== (_.string "0.0") output) - (_.=== (_.string "+0.0") output) - (_.=== (_.string "-0.0") output) - (_.=== (_.string "0") output) - (_.=== (_.string "+0") output) - (_.=== (_.string "-0") output)) - (_.return (..some output)) - (_.return ..none)) - (_.return (..some output))) - ))) - -(def: runtime//f64 - Statement - ($_ _.then - @f64//decode - )) - -(def: check_necessary_conditions! - Statement - (let [i64_support? (_.=== (_.int +8) (_.constant "PHP_INT_SIZE")) - i64_error (_.string (format "Cannot run program!" text.new_line - "Lux/PHP programs require 64-bit PHP builds!"))] - (_.when (_.not i64_support?) - (_.throw (_.new (_.constant "Exception") (list i64_error)))))) - -(def: runtime - Statement - ($_ _.then - check_necessary_conditions! - runtime//array - runtime//adt - runtime//lux - runtime//i64 - runtime//f64 - runtime//text - runtime//io - )) - -(def: #export generate - (Operation [Registry Output]) - (do ///////phase.monad - [_ (/////generation.execute! ..runtime) - _ (/////generation.save! ..module_id ..runtime)] - (wrap [(|> artifact.empty - artifact.resource - product.right) - (row.row [..module_id - (|> ..runtime - _.code - (\ utf8.codec encode))])]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/structure.lux deleted file mode 100644 index 5f7a4e358..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/structure.lux +++ /dev/null @@ -1,41 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [data - [collection - ["." list]]] - [target - ["_" php (#+ Expression)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." primitive] - ["///#" //// #_ - [analysis (#+ Variant Tuple)] - ["#." synthesis (#+ Synthesis)] - ["//#" /// #_ - ["#." phase ("#\." monad)]]]]) - -(def: #export (tuple expression archive elemsS+) - (Generator (Tuple Synthesis)) - (case elemsS+ - #.Nil - (///////phase\wrap (//primitive.text /////synthesis.unit)) - - (#.Cons singletonS #.Nil) - (expression archive singletonS) - - _ - (let [size (_.int (.int (list.size elemsS+)))] - (|> elemsS+ - (monad.map ///////phase.monad (expression archive)) - (///////phase\map (|>> _.array/* - (//runtime.tuple//make size))))))) - -(def: #export (variant expression archive [lefts right? valueS]) - (Generator (Variant Synthesis)) - (let [tag (if right? - (inc lefts) - lefts)] - (///////phase\map (//runtime.variant tag right?) - (expression archive valueS)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python.lux deleted file mode 100644 index 2e86ad107..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python.lux +++ /dev/null @@ -1,112 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." exception (#+ exception:)]] - [target - ["_" python]]] - ["." / #_ - [runtime (#+ Phase Phase!)] - ["#." primitive] - ["#." structure] - ["#." reference] - ["#." function] - ["#." case] - ["#." loop] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." extension] - ["/#" // #_ - [analysis (#+)] - ["#." synthesis] - ["//#" /// #_ - ["#." phase ("#\." monad)] - [reference (#+) - [variable (#+)]]]]]]]) - -(def: (statement expression archive synthesis) - Phase! - (case synthesis - (^template [<tag>] - [(^ (<tag> value)) - (//////phase\map _.return (expression archive synthesis))]) - ([////synthesis.bit] - [////synthesis.i64] - [////synthesis.f64] - [////synthesis.text] - [////synthesis.variant] - [////synthesis.tuple] - [#////synthesis.Reference] - [////synthesis.branch/get] - [////synthesis.function/apply] - [#////synthesis.Extension]) - - (^ (////synthesis.branch/case case)) - (/case.case! false statement expression archive case) - - (^template [<tag> <generator>] - [(^ (<tag> value)) - (<generator> statement expression archive value)]) - ([////synthesis.branch/let /case.let!] - [////synthesis.branch/if /case.if!] - [////synthesis.loop/scope /loop.scope!] - [////synthesis.loop/recur /loop.recur!]) - - (^ (////synthesis.function/abstraction abstraction)) - (//////phase\map _.return (/function.function statement expression archive abstraction)) - )) - -(exception: #export cannot-recur-as-an-expression) - -(def: #export (expression archive synthesis) - Phase - (case synthesis - (^template [<tag> <generator>] - [(^ (<tag> value)) - (//////phase\wrap (<generator> value))]) - ([////synthesis.bit /primitive.bit] - [////synthesis.i64 /primitive.i64] - [////synthesis.f64 /primitive.f64] - [////synthesis.text /primitive.text]) - - (^ (////synthesis.variant variantS)) - (/structure.variant expression archive variantS) - - (^ (////synthesis.tuple members)) - (/structure.tuple expression archive members) - - (#////synthesis.Reference value) - (//reference.reference /reference.system archive value) - - (^ (////synthesis.branch/case case)) - (/case.case ..statement expression archive case) - - (^ (////synthesis.branch/let let)) - (/case.let expression archive let) - - (^ (////synthesis.branch/if if)) - (/case.if expression archive if) - - (^ (////synthesis.branch/get get)) - (/case.get expression archive get) - - (^ (////synthesis.loop/scope scope)) - (/loop.scope ..statement expression archive scope) - - (^ (////synthesis.loop/recur updates)) - (//////phase.throw ..cannot-recur-as-an-expression []) - - (^ (////synthesis.function/abstraction abstraction)) - (/function.function ..statement expression archive abstraction) - - (^ (////synthesis.function/apply application)) - (/function.apply expression archive application) - - (#////synthesis.Extension extension) - (///extension.apply archive expression extension))) - -(def: #export generate - Phase - ..expression) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux deleted file mode 100644 index 28ffbb624..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux +++ /dev/null @@ -1,317 +0,0 @@ -(.module: - [lux (#- case let if) - [abstract - ["." monad (#+ do)]] - [control - [exception (#+ exception:)]] - [data - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set]]] - [math - [number - ["n" nat] - ["i" int]]] - [target - ["_" python (#+ Expression SVar Statement)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator Phase! Generator!)] - ["#." reference] - ["#." primitive] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - [synthesis - ["." case]] - ["/#" // #_ - ["#." synthesis (#+ Member Synthesis Path)] - ["#." generation] - ["//#" /// #_ - [reference - ["#." variable (#+ Register)]] - ["#." phase ("#\." monad)] - [meta - [archive (#+ Archive)]]]]]]]) - -(def: #export (gensym prefix) - (-> Text (Operation SVar)) - (///////phase\map (|>> %.nat (format prefix) _.var) /////generation.next)) - -(def: #export register - (-> Register SVar) - (|>> (///reference.local //reference.system) :assume)) - -(def: #export capture - (-> Register SVar) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: #export (let expression archive [valueS register bodyS]) - (Generator [Synthesis Register Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS) - bodyO (expression archive bodyS)] - ## TODO: Find some way to do 'let' without paying the price of the closure. - (wrap (_.apply/* (_.lambda (list (..register register)) - bodyO) - (list valueO))))) - -(def: #export (let! statement expression archive [valueS register bodyS]) - (Generator! [Synthesis Register Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS) - bodyO (statement expression archive bodyS)] - (wrap ($_ _.then - (_.set (list (..register register)) valueO) - bodyO)))) - -(def: #export (if expression archive [testS thenS elseS]) - (Generator [Synthesis Synthesis Synthesis]) - (do ///////phase.monad - [testO (expression archive testS) - thenO (expression archive thenS) - elseO (expression archive elseS)] - (wrap (_.? testO thenO elseO)))) - -(def: #export (if! statement expression archive [testS thenS elseS]) - (Generator! [Synthesis Synthesis Synthesis]) - (do ///////phase.monad - [test! (expression archive testS) - then! (statement expression archive thenS) - else! (statement expression archive elseS)] - (wrap (_.if test! - then! - else!)))) - -(def: #export (get expression archive [pathP valueS]) - (Generator [(List Member) Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS)] - (wrap (list\fold (function (_ side source) - (.let [method (.case side - (^template [<side> <accessor>] - [(<side> lefts) - (<accessor> (_.int (.int lefts)))]) - ([#.Left //runtime.tuple::left] - [#.Right //runtime.tuple::right]))] - (method source))) - valueO - (list.reverse pathP))))) - -(def: @savepoint (_.var "lux_pm_savepoint")) -(def: @cursor (_.var "lux_pm_cursor")) -(def: @temp (_.var "lux_pm_temp")) - -(def: (push! value) - (-> (Expression Any) (Statement Any)) - (_.statement (|> @cursor (_.do "append" (list value))))) - -(def: peek_and_pop - (Expression Any) - (|> @cursor (_.do "pop" (list)))) - -(def: pop! - (Statement Any) - (_.statement ..peek_and_pop)) - -(def: peek - (Expression Any) - (_.nth (_.int -1) @cursor)) - -(def: save! - (Statement Any) - (.let [cursor (_.slice_from (_.int +0) @cursor)] - (_.statement (|> @savepoint (_.do "append" (list cursor)))))) - -(def: restore! - (Statement Any) - (_.set (list @cursor) (|> @savepoint (_.do "pop" (list))))) - -(def: fail_pm! _.break) - -(def: (multi_pop! pops) - (-> Nat (Statement Any)) - (_.delete (_.slice_from (_.int (i.* -1 (.int pops))) @cursor))) - -(template [<name> <flag> <prep>] - [(def: (<name> simple? idx) - (-> Bit Nat (Statement Any)) - ($_ _.then - (_.set (list @temp) (|> idx <prep> .int _.int (//runtime.sum::get ..peek <flag>))) - (.if simple? - (_.when (_.= _.none @temp) - fail_pm!) - (_.if (_.= _.none @temp) - fail_pm! - (..push! @temp)) - )))] - - [left_choice _.none (<|)] - [right_choice (_.string "") inc] - ) - -(def: (with_looping in_closure? g!once body!) - (-> Bit SVar (Statement Any) (Statement Any)) - (.if in_closure? - (_.while (_.bool true) - body! - #.None) - ($_ _.then - (_.set (list g!once) (_.bool true)) - (_.while g!once - ($_ _.then - (_.set (list g!once) (_.bool false)) - body!) - (#.Some _.continue))))) - -(def: (alternation in_closure? g!once pre! post!) - (-> Bit SVar (Statement Any) (Statement Any) (Statement Any)) - ($_ _.then - (..with_looping in_closure? g!once - ($_ _.then - ..save! - pre!)) - ..restore! - post!)) - -(def: (pattern_matching' in_closure? statement expression archive) - (-> Bit Phase! Phase Archive Path (Operation (Statement Any))) - (function (recur pathP) - (.case pathP - (#/////synthesis.Then bodyS) - (statement expression archive bodyS) - - #/////synthesis.Pop - (///////phase\wrap ..pop!) - - (#/////synthesis.Bind register) - (///////phase\wrap (_.set (list (..register register)) ..peek)) - - (#/////synthesis.Bit_Fork when thenP elseP) - (do {! ///////phase.monad} - [then! (recur thenP) - else! (.case elseP - (#.Some elseP) - (recur elseP) - - #.None - (wrap ..fail_pm!))] - (wrap (.if when - (_.if ..peek - then! - else!) - (_.if ..peek - else! - then!)))) - - (^template [<tag> <format>] - [(<tag> cons) - (do {! ///////phase.monad} - [clauses (monad.map ! (function (_ [match then]) - (\ ! map - (|>> [(_.= (|> match <format>) - ..peek)]) - (recur then))) - (#.Cons cons))] - (wrap (_.cond clauses - ..fail_pm!)))]) - ([#/////synthesis.I64_Fork (<| //primitive.i64 .int)] - [#/////synthesis.F64_Fork (<| //primitive.f64)] - [#/////synthesis.Text_Fork (<| //primitive.text)]) - - (^template [<complex> <simple> <choice>] - [(^ (<complex> idx)) - (///////phase\wrap (<choice> false idx)) - - (^ (<simple> idx nextP)) - (|> nextP - recur - (///////phase\map (_.then (<choice> true idx))))]) - ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice] - [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice]) - - (^ (/////synthesis.member/left 0)) - (///////phase\wrap (|> ..peek (_.nth (_.int +0)) ..push!)) - - (^template [<pm> <getter>] - [(^ (<pm> lefts)) - (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))]) - ([/////synthesis.member/left //runtime.tuple::left] - [/////synthesis.member/right //runtime.tuple::right]) - - (^ (/////synthesis.!bind_top register thenP)) - (do ///////phase.monad - [then! (recur thenP)] - (///////phase\wrap ($_ _.then - (_.set (list (..register register)) ..peek_and_pop) - then!))) - - (^ (/////synthesis.!multi_pop nextP)) - (.let [[extra_pops nextP'] (case.count_pops nextP)] - (do ///////phase.monad - [next! (recur nextP')] - (///////phase\wrap ($_ _.then - (..multi_pop! (n.+ 2 extra_pops)) - next!)))) - - (^ (/////synthesis.path/seq preP postP)) - (do ///////phase.monad - [pre! (recur preP) - post! (recur postP)] - (wrap (_.then pre! post!))) - - (^ (/////synthesis.path/alt preP postP)) - (do ///////phase.monad - [pre! (recur preP) - post! (recur postP) - g!once (..gensym "once")] - (wrap (..alternation in_closure? g!once pre! post!)))))) - -(def: (pattern_matching in_closure? statement expression archive pathP) - (-> Bit Phase! Phase Archive Path (Operation (Statement Any))) - (do ///////phase.monad - [pattern_matching! (pattern_matching' in_closure? statement expression archive pathP) - g!once (..gensym "once")] - (wrap ($_ _.then - (..with_looping in_closure? g!once - pattern_matching!) - (_.raise (_.Exception/1 (_.string case.pattern_matching_error))))))) - -(def: #export dependencies - (-> Path (List SVar)) - (|>> case.storage - (get@ #case.dependencies) - set.to_list - (list\map (function (_ variable) - (.case variable - (#///////variable.Local register) - (..register register) - - (#///////variable.Foreign register) - (..capture register)))))) - -(def: #export (case! in_closure? statement expression archive [valueS pathP]) - (-> Bit (Generator! [Synthesis Path])) - (do ///////phase.monad - [stack_init (expression archive valueS) - pattern_matching! (pattern_matching in_closure? statement expression archive pathP)] - (wrap ($_ _.then - (_.set (list @cursor) (_.list (list stack_init))) - (_.set (list @savepoint) (_.list (list))) - pattern_matching! - )))) - -(def: #export (case statement expression archive [valueS pathP]) - (-> Phase! (Generator [Synthesis Path])) - (do ///////phase.monad - [[[case_module case_artifact] pattern_matching!] (/////generation.with_new_context archive - (case! true statement expression archive [valueS pathP])) - #let [@case (_.var (///reference.artifact [case_module case_artifact])) - @dependencies+ (..dependencies (/////synthesis.path/seq (/////synthesis.path/then valueS) - pathP)) - directive (_.def @case @dependencies+ - pattern_matching!)] - _ (/////generation.execute! directive) - _ (/////generation.save! case_artifact directive)] - (wrap (_.apply/* @case @dependencies+)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux deleted file mode 100644 index cc670d277..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux +++ /dev/null @@ -1,111 +0,0 @@ -(.module: - [lux (#- function) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [target - ["_" python (#+ SVar Expression Statement)]]] - ["." // #_ - [runtime (#+ Operation Phase Generator Phase! Generator!)] - ["#." reference] - ["#." case] - ["#." loop] - ["/#" // #_ - ["#." reference] - ["//#" /// #_ - [analysis (#+ Variant Tuple Environment Abstraction Application Analysis)] - [synthesis (#+ Synthesis)] - ["#." generation (#+ Context)] - ["//#" /// #_ - [arity (#+ Arity)] - ["#." phase] - [reference - [variable (#+ Register Variable)]] - [meta - [archive (#+ Archive) - ["." artifact]]]]]]]) - -(def: #export (apply expression archive [functionS argsS+]) - (Generator (Application Synthesis)) - (do {! ///////phase.monad} - [functionO (expression archive functionS) - argsO+ (monad.map ! (expression archive) argsS+)] - (wrap (_.apply/* functionO argsO+)))) - -(def: #export capture - (-> Register SVar) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: (with_closure function_id @function inits function_definition) - (-> artifact.ID SVar (List (Expression Any)) (Statement Any) (Operation (Expression Any))) - (case inits - #.Nil - (do ///////phase.monad - [_ (/////generation.execute! function_definition) - _ (/////generation.save! function_id function_definition)] - (wrap @function)) - - _ - (do {! ///////phase.monad} - [#let [directive (_.def @function - (|> (list.enumeration inits) - (list\map (|>> product.left ..capture))) - ($_ _.then - function_definition - (_.return @function)))] - _ (/////generation.execute! directive) - _ (/////generation.save! function_id directive)] - (wrap (_.apply/* @function inits))))) - -(def: input - (|>> inc //case.register)) - -(def: #export (function statement expression archive [environment arity bodyS]) - (-> Phase! (Generator (Abstraction Synthesis))) - (do {! ///////phase.monad} - [[[function_module function_artifact] body!] (/////generation.with_new_context archive - (/////generation.with_anchor 1 - (statement expression archive bodyS))) - environment (monad.map ! (expression archive) environment) - #let [@curried (_.var "curried") - arityO (|> arity .int _.int) - @num_args (_.var "num_args") - @self (_.var (///reference.artifact [function_module function_artifact])) - apply_poly (.function (_ args func) - (_.apply_poly (list) args func)) - initialize_self! (_.set (list (//case.register 0)) @self) - initialize! (list\fold (.function (_ post pre!) - ($_ _.then - pre! - (_.set (list (..input post)) (_.nth (|> post .int _.int) @curried)))) - initialize_self! - (list.indices arity))]] - (with_closure function_artifact @self environment - (_.def @self (list (_.poly @curried)) - ($_ _.then - (_.set (list @num_args) (_.len/1 @curried)) - (_.cond (list [(|> @num_args (_.= arityO)) - (<| (_.then initialize!) - //loop.set_scope - body!)] - [(|> @num_args (_.> arityO)) - (let [arity_inputs (_.slice (_.int +0) arityO @curried) - extra_inputs (_.slice arityO @num_args @curried)] - (_.return (|> @self - (apply_poly arity_inputs) - (apply_poly extra_inputs))))]) - ## (|> @num_args (_.< arityO)) - (let [@next (_.var "next") - @missing (_.var "missing")] - ($_ _.then - (_.def @next (list (_.poly @missing)) - (_.return (|> @self (apply_poly (|> @curried (_.+ @missing)))))) - (_.return @next) - ))) - ))) - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux deleted file mode 100644 index 0f932ee38..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux +++ /dev/null @@ -1,121 +0,0 @@ -(.module: - [lux (#- Scope) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set]]] - [math - [number - ["n" nat]]] - [target - ["_" python (#+ Expression SVar Statement)]]] - ["." // #_ - [runtime (#+ Operation Phase Generator Phase! Generator!)] - ["#." case] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - [synthesis - ["." case]] - ["/#" // #_ - ["." synthesis (#+ Scope Synthesis)] - ["#." generation] - ["//#" /// #_ - ["#." phase] - [reference - ["#." variable (#+ Register)]]]]]]]) - -(def: (setup offset bindings body) - (-> Register (List (Expression Any)) (Statement Any) (Statement Any)) - (|> bindings - list.enumeration - (list\map (function (_ [register value]) - (_.set (list (//case.register (n.+ offset register))) - value))) - list.reverse - (list\fold _.then body))) - -(def: #export (set_scope body!) - (-> (Statement Any) (Statement Any)) - (_.while (_.bool true) - body! - #.None)) - -(def: #export (scope! statement expression archive [start initsS+ bodyS]) - (Generator! (Scope Synthesis)) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (statement expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [initsO+ (monad.map ! (expression archive) initsS+) - body! (/////generation.with_anchor start - (statement expression archive bodyS))] - (wrap (<| (..setup start initsO+) - ..set_scope - body!))))) - -(def: #export (scope statement expression archive [start initsS+ bodyS]) - (-> Phase! (Generator (Scope Synthesis))) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [initsO+ (monad.map ! (expression archive) initsS+) - [[loop_module loop_artifact] body!] (/////generation.with_new_context archive - (/////generation.with_anchor start - (statement expression archive bodyS))) - #let [@loop (_.var (///reference.artifact [loop_module loop_artifact])) - locals (|> initsS+ - list.enumeration - (list\map (|>> product.left (n.+ start) //case.register))) - actual_loop (<| (_.def @loop locals) - ..set_scope - body!) - [directive instantiation] (: [(Statement Any) (Expression Any)] - (case (|> (synthesis.path/then bodyS) - //case.dependencies - (set.from_list _.hash) - (set.difference (set.from_list _.hash locals)) - set.to_list) - #.Nil - [actual_loop - @loop] - - foreigns - [(_.def @loop foreigns - ($_ _.then - actual_loop - (_.return @loop) - )) - (_.apply/* @loop foreigns)]))] - _ (/////generation.execute! directive) - _ (/////generation.save! loop_artifact directive)] - (wrap (_.apply/* instantiation initsO+))))) - -(def: #export (recur! statement expression archive argsS+) - (Generator! (List Synthesis)) - (do {! ///////phase.monad} - [offset /////generation.anchor - @temp (//case.gensym "lux_recur_values") - argsO+ (monad.map ! (expression archive) argsS+) - #let [re_binds (|> argsO+ - list.enumeration - (list\map (function (_ [idx _]) - (_.nth (_.int (.int idx)) @temp))))]] - (wrap ($_ _.then - (_.set (list @temp) (_.list argsO+)) - (..setup offset re_binds - _.continue))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/primitive.lux deleted file mode 100644 index ec8889281..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/primitive.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux (#- i64) - [target - ["_" python (#+ Expression)]]] - ["." // #_ - ["#." runtime]]) - -(template [<type> <name> <implementation>] - [(def: #export <name> - (-> <type> (Expression Any)) - <implementation>)] - - [Bit bit _.bool] - [(I64 Any) i64 (|>> .int _.int //runtime.i64::64)] - [Frac f64 _.float] - [Text text _.unicode] - ) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/reference.lux deleted file mode 100644 index 1fe57fb8c..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/reference.lux +++ /dev/null @@ -1,12 +0,0 @@ -(.module: - [lux #* - [target - ["_" python (#+ Expression)]]] - [/// - [reference (#+ System)]]) - -(implementation: #export system - (System (Expression Any)) - - (def: constant _.var) - (def: variable _.var)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux deleted file mode 100644 index b77d0c915..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux +++ /dev/null @@ -1,455 +0,0 @@ -(.module: - [lux (#- inc) - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<.>" code]]] - [data - ["." product] - ["." text ("#\." hash) - ["%" format (#+ format)] - [encoding - ["." utf8]]] - [collection - ["." list ("#\." functor)] - ["." row]]] - ["." macro - [syntax (#+ syntax:)] - ["." code]] - [math - [number (#+ hex) - ["f" frac] - ["." i64]]] - ["@" target - ["_" python (#+ Expression SVar Computation Literal Statement)]]] - ["." /// #_ - ["#." reference] - ["//#" /// #_ - ["$" version] - ["#." synthesis (#+ Synthesis)] - ["#." generation] - ["//#" /// - ["#." phase] - [reference - [variable (#+ Register)]] - [meta - [archive (#+ Output Archive) - ["." artifact (#+ Registry)]]]]]]) - -(template [<name> <base>] - [(type: #export <name> - (<base> Register (Expression Any) (Statement Any)))] - - [Operation /////generation.Operation] - [Phase /////generation.Phase] - [Handler /////generation.Handler] - [Bundle /////generation.Bundle] - ) - -(type: #export Phase! - (-> Phase Archive Synthesis (Operation (Statement Any)))) - -(type: #export (Generator! i) - (-> Phase! Phase Archive i (Operation (Statement Any)))) - -(type: #export (Generator i) - (-> Phase Archive i (Operation (Expression Any)))) - -(def: prefix - "LuxRuntime") - -(def: #export - unit - (_.unicode /////synthesis.unit)) - -(def: (flag value) - (-> Bit Literal) - (if value - ..unit - _.none)) - -(def: (variant' tag last? value) - (-> (Expression Any) (Expression Any) (Expression Any) Literal) - (_.tuple (list tag last? value))) - -(def: #export (variant tag last? value) - (-> Nat Bit (Expression Any) Literal) - (variant' (_.int (.int tag)) - (flag last?) - value)) - -(def: #export none - Literal - (..variant 0 #0 unit)) - -(def: #export some - (-> (Expression Any) Literal) - (..variant 1 #1)) - -(def: #export left - (-> (Expression Any) Literal) - (..variant 0 #0)) - -(def: #export right - (-> (Expression Any) Literal) - (..variant 1 #1)) - -(def: (runtime_name name) - (-> Text SVar) - (let [identifier (format ..prefix - "_" (%.nat $.version) - "_" (%.nat (text\hash name)))] - (_.var identifier))) - -(def: (feature name definition) - (-> SVar (-> SVar (Statement Any)) (Statement Any)) - (definition name)) - -(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} - body) - (do {! meta.monad} - [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] - (wrap (list (` (let [(~+ (|> vars - (list.zip/2 ids) - (list\map (function (_ [id var]) - (list (code.local_identifier var) - (` (_.var (~ (code.text (format "v" (%.nat id))))))))) - list.concat))] - (~ body))))))) - -(syntax: (runtime: {declaration (<>.or <code>.local_identifier - (<code>.form (<>.and <code>.local_identifier - (<>.some <code>.local_identifier))))} - code) - (case declaration - (#.Left name) - (macro.with_gensyms [g!_] - (let [nameC (code.local_identifier name) - code_nameC (code.local_identifier (format "@" name)) - runtime_nameC (` (runtime_name (~ (code.text name))))] - (wrap (list (` (def: #export (~ nameC) SVar (~ runtime_nameC))) - (` (def: (~ code_nameC) - (Statement Any) - (..feature (~ runtime_nameC) - (function ((~ g!_) (~ g!_)) - (_.set (list (~ g!_)) (~ code)))))))))) - - (#.Right [name inputs]) - (macro.with_gensyms [g!_] - (let [nameC (code.local_identifier name) - code_nameC (code.local_identifier (format "@" name)) - runtime_nameC (` (runtime_name (~ (code.text name)))) - inputsC (list\map code.local_identifier inputs) - inputs_typesC (list\map (function.constant (` (_.Expression Any))) - inputs)] - (wrap (list (` (def: #export ((~ nameC) (~+ inputsC)) - (-> (~+ inputs_typesC) (Computation Any)) - (_.apply/* (~ runtime_nameC) (list (~+ inputsC))))) - (` (def: (~ code_nameC) - (Statement Any) - (..feature (~ runtime_nameC) - (function ((~ g!_) (~ g!_)) - (..with_vars [(~+ inputsC)] - (_.def (~ g!_) (list (~+ inputsC)) - (~ code))))))))))))) - -(runtime: (lux::try op) - (with_vars [exception] - (_.try (_.return (..right (_.apply/* op (list ..unit)))) - (list [(list (_.var "Exception")) exception - (_.return (..left (_.str/1 exception)))])))) - -(runtime: (lux::program_args program_args) - (with_vars [inputs value] - ($_ _.then - (_.set (list inputs) ..none) - (<| (_.for_in value (_.apply/* (_.var "reversed") (list program_args))) - (_.set (list inputs) - (..some (_.list (list value inputs))))) - (_.return inputs)))) - -(runtime: (lux::exec code globals) - ($_ _.then - (_.exec code (#.Some globals)) - (_.return ..unit))) - -(def: runtime::lux - (Statement Any) - ($_ _.then - @lux::try - @lux::program_args - @lux::exec - )) - -(runtime: (io::log! message) - ($_ _.then - (_.print message) - (_.return ..unit))) - -(runtime: (io::throw! message) - (_.raise (_.Exception/1 message))) - -(def: runtime::io - (Statement Any) - ($_ _.then - @io::log! - @io::throw! - )) - -(def: last_index - (|>> _.len/1 (_.- (_.int +1)))) - -(with_expansions [<recur> (as_is ($_ _.then - (_.set (list lefts) (_.- last_index_right lefts)) - (_.set (list tuple) (_.nth last_index_right tuple))))] - (runtime: (tuple::left lefts tuple) - (with_vars [last_index_right] - (_.while (_.bool true) - ($_ _.then - (_.set (list last_index_right) (..last_index tuple)) - (_.if (_.> lefts last_index_right) - ## No need for recursion - (_.return (_.nth lefts tuple)) - ## Needs recursion - <recur>)) - #.None))) - - (runtime: (tuple::right lefts tuple) - (with_vars [last_index_right right_index] - (_.while (_.bool true) - ($_ _.then - (_.set (list last_index_right) (..last_index tuple)) - (_.set (list right_index) (_.+ (_.int +1) lefts)) - (_.cond (list [(_.= last_index_right right_index) - (_.return (_.nth right_index tuple))] - [(_.> last_index_right right_index) - ## Needs recursion. - <recur>]) - (_.return (_.slice_from right_index tuple)))) - #.None)))) - -(runtime: (sum::get sum wantsLast wantedTag) - (let [no_match! (_.return _.none) - sum_tag (_.nth (_.int +0) sum) - sum_flag (_.nth (_.int +1) sum) - sum_value (_.nth (_.int +2) sum) - is_last? (_.= ..unit sum_flag) - test_recursion! (_.if is_last? - ## Must recurse. - ($_ _.then - (_.set (list wantedTag) (_.- sum_tag wantedTag)) - (_.set (list sum) sum_value)) - no_match!)] - (_.while (_.bool true) - (_.cond (list [(_.= wantedTag sum_tag) - (_.if (_.= wantsLast sum_flag) - (_.return sum_value) - test_recursion!)] - - [(_.< wantedTag sum_tag) - test_recursion!] - - [(_.= ..unit wantsLast) - (_.return (variant' (_.- wantedTag sum_tag) sum_flag sum_value))]) - - no_match!) - #.None))) - -(def: runtime::adt - (Statement Any) - ($_ _.then - @tuple::left - @tuple::right - @sum::get - )) - -(def: i64::+limit (_.manual "+0x7FFFFFFFFFFFFFFF")) -(def: i64::-limit (_.manual "-0x8000000000000000")) -(def: i64::+iteration (_.manual "+0x10000000000000000")) -(def: i64::-iteration (_.manual "-0x10000000000000000")) -(def: i64::+cap (_.manual "+0x8000000000000000")) -(def: i64::-cap (_.manual "-0x8000000000000001")) - -(runtime: (i64::64 input) - (with_vars [temp] - (`` (<| (~~ (template [<scenario> <iteration> <cap> <entrance>] - [(_.if (|> input <scenario>) - ($_ _.then - (_.set (list temp) (_.% <iteration> input)) - (_.return (_.? (|> temp <scenario>) - (|> temp (_.- <cap>) (_.+ <entrance>)) - temp))))] - - [(_.> ..i64::+limit) ..i64::+iteration ..i64::+cap ..i64::-limit] - [(_.< ..i64::-limit) ..i64::-iteration ..i64::-cap ..i64::+limit] - )) - (_.return (for {@.python input} - ## This +- is only necessary to guarantee that values within the limits are always longs in Python 2 - (|> input (_.+ ..i64::+limit) (_.- ..i64::+limit)))))))) - -(def: as_nat - (_.% ..i64::+iteration)) - -(runtime: (i64::left_shift param subject) - (_.return (|> subject - (_.bit_shl (_.% (_.int +64) param)) - ..i64::64))) - -(runtime: (i64::right_shift param subject) - ($_ _.then - (_.set (list param) (_.% (_.int +64) param)) - (_.return (_.? (_.= (_.int +0) param) - subject - (|> subject - ..as_nat - (_.bit_shr param)))))) - -(runtime: (i64::division param subject) - (with_vars [floored] - ($_ _.then - (_.set (list floored) (_.// param subject)) - (_.return (let [potentially_floored? (_.< (_.int +0) floored) - inexact? (|> subject - (_.% param) - (_.= (_.int +0)) - _.not)] - (_.? (_.and potentially_floored? - inexact?) - (_.+ (_.int +1) floored) - floored)))))) - -(runtime: (i64::remainder param subject) - (_.return (_.- (|> subject (..i64::division param) (_.* param)) - subject))) - -(template [<runtime> <host>] - [(runtime: (<runtime> left right) - (_.return (..i64::64 (<host> (..as_nat left) (..as_nat right)))))] - - [i64::and _.bit_and] - [i64::or _.bit_or] - [i64::xor _.bit_xor] - ) - -(def: python_version - (Expression Any) - (|> (_.__import__/1 (_.unicode "sys")) - (_.the "version_info") - (_.the "major"))) - -(runtime: (i64::char value) - (_.return (_.? (_.= (_.int +3) ..python_version) - (_.chr/1 value) - (_.unichr/1 value)))) - -(def: runtime::i64 - (Statement Any) - ($_ _.then - @i64::64 - @i64::left_shift - @i64::right_shift - @i64::division - @i64::remainder - @i64::and - @i64::or - @i64::xor - @i64::char - )) - -(runtime: (f64::/ parameter subject) - (_.return (_.? (_.= (_.float +0.0) parameter) - (<| (_.? (_.> (_.float +0.0) subject) - (_.float f.positive_infinity)) - (_.? (_.< (_.float +0.0) subject) - (_.float f.negative_infinity)) - (_.float f.not_a_number)) - (_./ parameter subject)))) - -(runtime: (f64::decode input) - (with_vars [ex] - (_.try - (_.return (..some (_.float/1 input))) - (list [(list (_.var "Exception")) ex - (_.return ..none)])))) - -(def: runtime::f64 - (Statement Any) - ($_ _.then - @f64::/ - @f64::decode - )) - -(runtime: (text::index start param subject) - (with_vars [idx] - ($_ _.then - (_.set (list idx) (|> subject (_.do "find" (list param start)))) - (_.return (_.? (_.= (_.int -1) idx) - ..none - (..some (..i64::64 idx))))))) - -(def: inc - (|>> (_.+ (_.int +1)))) - -(def: (within? top value) - (-> (Expression Any) (Expression Any) (Computation Any)) - (_.and (|> value (_.>= (_.int +0))) - (|> value (_.< top)))) - -(runtime: (text::clip @offset @length @text) - (_.return (|> @text (_.slice @offset (_.+ @offset @length))))) - -(runtime: (text::char idx text) - (_.if (|> idx (within? (_.len/1 text))) - (_.return (|> text (_.slice idx (..inc idx)) _.ord/1 ..i64::64)) - (_.raise (_.Exception/1 (_.unicode "[Lux Error] Cannot get char from text."))))) - -(def: runtime::text - (Statement Any) - ($_ _.then - @text::index - @text::clip - @text::char - )) - -(runtime: (array::write idx value array) - ($_ _.then - (_.set (list (_.nth idx array)) value) - (_.return array))) - -(def: runtime::array - (Statement Any) - ($_ _.then - @array::write - )) - -(def: runtime - (Statement Any) - ($_ _.then - runtime::lux - runtime::io - runtime::adt - runtime::i64 - runtime::f64 - runtime::text - runtime::array - )) - -(def: module_id - 0) - -(def: #export generate - (Operation [Registry Output]) - (/////generation.with_buffer - (do ///////phase.monad - [_ (/////generation.execute! ..runtime) - _ (/////generation.save! ..module_id ..runtime)] - (wrap [(|> artifact.empty - artifact.resource - product.right) - (row.row [..module_id - (|> ..runtime - _.code - (\ utf8.codec encode))])])))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/structure.lux deleted file mode 100644 index c5edce4a7..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/structure.lux +++ /dev/null @@ -1,36 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [target - ["_" python (#+ Expression)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." primitive] - ["///#" //// #_ - [analysis (#+ Variant Tuple)] - ["#." synthesis (#+ Synthesis)] - ["//#" /// #_ - ["#." phase ("#\." monad)]]]]) - -(def: #export (tuple generate archive elemsS+) - (Generator (Tuple Synthesis)) - (case elemsS+ - #.Nil - (///////phase\wrap (//primitive.text /////synthesis.unit)) - - (#.Cons singletonS #.Nil) - (generate archive singletonS) - - _ - (|> elemsS+ - (monad.map ///////phase.monad (generate archive)) - (///////phase\map _.list)))) - -(def: #export (variant generate archive [lefts right? valueS]) - (Generator (Variant Synthesis)) - (let [tag (if right? - (inc lefts) - lefts)] - (///////phase\map (//runtime.variant tag right?) - (generate archive valueS)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r.lux deleted file mode 100644 index b4b3e6423..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r.lux +++ /dev/null @@ -1,58 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [target - ["_" r]]] - ["." / #_ - [runtime (#+ Phase)] - ["#." primitive] - ["#." structure] - ["#." reference] - ["#." case] - ["#." loop] - ["#." function] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." extension] - ["/#" // #_ - [analysis (#+)] - ["#." synthesis] - ["//#" /// #_ - ["#." phase ("#\." monad)] - [reference (#+) - [variable (#+)]]]]]]]) - -(def: #export (generate archive synthesis) - Phase - (case synthesis - (^template [<tag> <generator>] - [(^ (<tag> value)) - (//////phase\wrap (<generator> value))]) - ([////synthesis.bit /primitive.bit] - [////synthesis.i64 /primitive.i64] - [////synthesis.f64 /primitive.f64] - [////synthesis.text /primitive.text]) - - (#////synthesis.Reference value) - (//reference.reference /reference.system archive value) - - (^template [<tag> <generator>] - [(^ (<tag> value)) - (<generator> generate archive value)]) - ([////synthesis.variant /structure.variant] - [////synthesis.tuple /structure.tuple] - [////synthesis.branch/let /case.let] - [////synthesis.branch/if /case.if] - [////synthesis.branch/get /case.get] - [////synthesis.function/apply /function.apply] - - [////synthesis.branch/case /case.case] - [////synthesis.loop/scope /loop.scope] - [////synthesis.loop/recur /loop.recur] - [////synthesis.function/abstraction /function.function]) - - (#////synthesis.Extension extension) - (///extension.apply archive generate extension) - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/case.lux deleted file mode 100644 index fe4e4a7c2..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/case.lux +++ /dev/null @@ -1,239 +0,0 @@ -(.module: - [lux (#- case let if) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set]]] - [macro - ["." template]] - [math - [number - ["i" int]]] - [target - ["_" r (#+ Expression SVar)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." reference] - ["#." primitive] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." synthesis #_ - ["#/." case]] - ["/#" // #_ - ["#." synthesis (#+ Member Synthesis Path)] - ["#." generation] - ["//#" /// #_ - [reference - ["#." variable (#+ Register)]] - ["#." phase ("#\." monad)] - [meta - [archive (#+ Archive)]]]]]]]) - -(def: #export register - (-> Register SVar) - (|>> (///reference.local //reference.system) :assume)) - -(def: #export capture - (-> Register SVar) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: #export (let expression archive [valueS register bodyS]) - (Generator [Synthesis Register Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS) - bodyO (expression archive bodyS)] - (wrap (_.block - ($_ _.then - (_.set! (..register register) valueO) - bodyO))))) - -(def: #export (if expression archive [testS thenS elseS]) - (Generator [Synthesis Synthesis Synthesis]) - (do ///////phase.monad - [testO (expression archive testS) - thenO (expression archive thenS) - elseO (expression archive elseS)] - (wrap (_.if testO thenO elseO)))) - -(def: #export (get expression archive [pathP valueS]) - (Generator [(List Member) Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS)] - (wrap (list\fold (function (_ side source) - (.let [method (.case side - (^template [<side> <accessor>] - [(<side> lefts) - (<accessor> (_.int (.int lefts)))]) - ([#.Left //runtime.tuple::left] - [#.Right //runtime.tuple::right]))] - (method source))) - valueO - (list.reverse pathP))))) - -(def: $savepoint (_.var "lux_pm_cursor_savepoint")) -(def: $cursor (_.var "lux_pm_cursor")) -(def: $temp (_.var "lux_pm_temp")) -(def: $alt_error (_.var "alt_error")) - -(def: top - _.length) - -(def: next - (|>> _.length (_.+ (_.int +1)))) - -(def: (push! value var) - (-> Expression SVar Expression) - (_.set_nth! (next var) value var)) - -(def: (pop! var) - (-> SVar Expression) - (_.set_nth! (top var) _.null var)) - -(def: (push_cursor! value) - (-> Expression Expression) - (push! value $cursor)) - -(def: save_cursor! - Expression - (push! (_.slice (_.float +1.0) (_.length $cursor) $cursor) - $savepoint)) - -(def: restore_cursor! - Expression - (_.set! $cursor (_.nth (top $savepoint) $savepoint))) - -(def: peek - Expression - (|> $cursor (_.nth (top $cursor)))) - -(def: pop_cursor! - Expression - (pop! $cursor)) - -(def: error - (_.string (template.with_locals [error] - (template.text [error])))) - -(def: fail! - (_.stop ..error)) - -(def: (catch handler) - (-> Expression Expression) - (_.function (list $alt_error) - (_.if (|> $alt_error (_.= ..error)) - handler - (_.stop $alt_error)))) - -(def: (pattern_matching' expression archive) - (Generator Path) - (function (recur pathP) - (.case pathP - (#/////synthesis.Then bodyS) - (expression archive bodyS) - - #/////synthesis.Pop - (///////phase\wrap ..pop_cursor!) - - (#/////synthesis.Bind register) - (///////phase\wrap (_.set! (..register register) ..peek)) - - (#/////synthesis.Bit_Fork when thenP elseP) - (do {! ///////phase.monad} - [then! (recur thenP) - else! (.case elseP - (#.Some elseP) - (recur elseP) - - #.None - (wrap ..fail!))] - (wrap (.if when - (_.if ..peek - then! - else!) - (_.if ..peek - else! - then!)))) - - (^template [<tag> <format> <=>] - [(<tag> cons) - (do {! ///////phase.monad} - [clauses (monad.map ! (function (_ [match then]) - (do ! - [then! (recur then)] - (wrap [(<=> (|> match <format>) - ..peek) - then!]))) - (#.Cons cons))] - (wrap (list\fold (function (_ [when then] else) - (_.if when then else)) - ..fail! - clauses)))]) - ([#/////synthesis.I64_Fork //primitive.i64 //runtime.i64::=] - [#/////synthesis.F64_Fork //primitive.f64 _.=] - [#/////synthesis.Text_Fork //primitive.text _.=]) - - (^template [<pm> <flag> <prep>] - [(^ (<pm> idx)) - (///////phase\wrap ($_ _.then - (_.set! $temp (|> idx <prep> .int _.int (//runtime.sum::get ..peek (//runtime.flag <flag>)))) - (_.if (_.= _.null $temp) - ..fail! - (..push_cursor! $temp))))]) - ([/////synthesis.side/left false (<|)] - [/////synthesis.side/right true inc]) - - (^ (/////synthesis.member/left 0)) - (///////phase\wrap (_.nth (_.int +1) ..peek)) - - (^template [<pm> <getter>] - [(^ (<pm> lefts)) - (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push_cursor!))]) - ([/////synthesis.member/left //runtime.tuple::left] - [/////synthesis.member/right //runtime.tuple::right]) - - (^ (/////synthesis.path/seq leftP rightP)) - (do ///////phase.monad - [leftO (recur leftP) - rightO (recur rightP)] - (wrap ($_ _.then - leftO - rightO))) - - (^ (/////synthesis.path/alt leftP rightP)) - (do {! ///////phase.monad} - [leftO (recur leftP) - rightO (recur rightP)] - (wrap (_.try ($_ _.then - ..save_cursor! - leftO) - #.None - (#.Some (..catch ($_ _.then - ..restore_cursor! - rightO))) - #.None))) - ))) - -(def: (pattern_matching expression archive pathP) - (Generator Path) - (do ///////phase.monad - [pattern_matching! (pattern_matching' expression archive pathP)] - (wrap (_.try pattern_matching! - #.None - (#.Some (..catch (_.stop (_.string "Invalid expression for pattern-matching.")))) - #.None)))) - -(def: #export (case expression archive [valueS pathP]) - (Generator [Synthesis Path]) - (do {! ///////phase.monad} - [valueO (expression archive valueS)] - (<| (\ ! map (|>> ($_ _.then - (_.set! $cursor (_.list (list valueO))) - (_.set! $savepoint (_.list (list)))) - _.block)) - (pattern_matching expression archive pathP)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/function.lux deleted file mode 100644 index c89ffaf0a..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/function.lux +++ /dev/null @@ -1,116 +0,0 @@ -(.module: - [lux (#- function) - [abstract - ["." monad (#+ do)]] - [control - pipe] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [target - ["_" r (#+ Expression SVar)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." reference] - ["#." case] - ["/#" // #_ - ["#." reference] - ["//#" /// #_ - [analysis (#+ Variant Tuple Abstraction Application Analysis)] - [synthesis (#+ Synthesis)] - ["#." generation (#+ Context)] - ["//#" /// #_ - [arity (#+ Arity)] - ["#." phase ("#\." monad)] - [reference - [variable (#+ Register Variable)]] - [meta - [archive - ["." artifact]]]]]]]) - -(def: #export (apply expression archive [functionS argsS+]) - (Generator (Application Synthesis)) - (do {! ///////phase.monad} - [functionO (expression archive functionS) - argsO+ (monad.map ! (expression archive) argsS+)] - (wrap (_.apply argsO+ functionO)))) - -(def: (with_closure function_id $function inits function_definition) - (-> artifact.ID SVar (List Expression) Expression (Operation Expression)) - (case inits - #.Nil - (do ///////phase.monad - [_ (/////generation.execute! function_definition) - _ (/////generation.save! (%.nat function_id) - function_definition)] - (wrap $function)) - - _ - (do ///////phase.monad - [#let [closure_definition (_.set! $function - (_.function (|> inits - list.size - list.indices - (list\map //case.capture)) - ($_ _.then - function_definition - $function)))] - _ (/////generation.execute! closure_definition) - _ (/////generation.save! (%.nat function_id) closure_definition)] - (wrap (_.apply inits $function))))) - -(def: $curried (_.var "curried")) -(def: $missing (_.var "missing")) - -(def: (input_declaration register) - (-> Register Expression) - (_.set! (|> register inc //case.register) - (|> $curried (_.nth (|> register inc .int _.int))))) - -(def: #export (function expression archive [environment arity bodyS]) - (Generator (Abstraction Synthesis)) - (do {! ///////phase.monad} - [[[function_module function_artifact] bodyO] (/////generation.with_new_context archive - (do ! - [$self (\ ! map (|>> ///reference.artifact _.var) - (/////generation.context archive))] - (/////generation.with_anchor $self - (expression archive bodyS)))) - closureO+ (monad.map ! (expression archive) environment) - #let [arityO (|> arity .int _.int) - $num_args (_.var "num_args") - $self (_.var (///reference.artifact [function_module function_artifact])) - apply_poly (.function (_ args func) - (_.apply (list func args) (_.var "do.call")))]] - (with_closure function_artifact $self closureO+ - (_.set! $self (_.function (list _.var_args) - ($_ _.then - (_.set! $curried (_.list (list _.var_args))) - (_.set! $num_args (_.length $curried)) - (_.cond (list [(|> $num_args (_.= arityO)) - ($_ _.then - (_.set! (//case.register 0) $self) - (|> arity - list.indices - (list\map input_declaration) - (list\fold _.then bodyO)))] - [(|> $num_args (_.> arityO)) - (let [arity_args (_.slice (_.int +1) arityO $curried) - output_func_args (_.slice (|> arityO (_.+ (_.int +1))) - $num_args - $curried)] - (|> $self - (apply_poly arity_args) - (apply_poly output_func_args)))]) - ## (|> $num_args (_.< arityO)) - (let [$missing (_.var "missing")] - (_.function (list _.var_args) - ($_ _.then - (_.set! $missing (_.list (list _.var_args))) - (|> $self - (apply_poly (_.apply (list $curried $missing) - (_.var "append")))))))))))) - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/loop.lux deleted file mode 100644 index c8f8bd1d5..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/loop.lux +++ /dev/null @@ -1,64 +0,0 @@ -(.module: - [lux (#- Scope) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set (#+ Set)]]] - [math - [number - ["n" nat]]] - [target - ["_" r]]] - ["." // #_ - [runtime (#+ Operation Phase Generator)] - ["#." case] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - [synthesis - ["." case]] - ["/#" // #_ - ["."synthesis (#+ Scope Synthesis)] - ["#." generation] - ["//#" /// #_ - ["#." phase] - [meta - [archive (#+ Archive)]] - [reference - [variable (#+ Register)]]]]]]]) - -(def: #export (scope expression archive [offset initsS+ bodyS]) - (Generator (Scope Synthesis)) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [$scope (\ ! map _.var (/////generation.gensym "loop_scope")) - initsO+ (monad.map ! (expression archive) initsS+) - bodyO (/////generation.with_anchor $scope - (expression archive bodyS))] - (wrap (_.block - ($_ _.then - (_.set! $scope - (_.function (|> initsS+ - list.size - list.indices - (list\map (|>> (n.+ offset) //case.register))) - bodyO)) - (_.apply initsO+ $scope))))))) - -(def: #export (recur expression archive argsS+) - (Generator (List Synthesis)) - (do {! ///////phase.monad} - [$scope /////generation.anchor - argsO+ (monad.map ! (expression archive) argsS+)] - (wrap (_.apply argsO+ $scope)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux deleted file mode 100644 index efbd569f4..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux (#- i64) - [target - ["_" r (#+ Expression)]]] - ["." // #_ - ["#." runtime]]) - -(template [<name> <type> <code>] - [(def: #export <name> - (-> <type> Expression) - <code>)] - - [bit Bit _.bool] - [i64 (I64 Any) (|>> .int //runtime.i64)] - [f64 Frac _.float] - [text Text _.string] - ) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux deleted file mode 100644 index 85ccd90dc..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux +++ /dev/null @@ -1,339 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - ["p" parser]) - (data ["e" error] - [text] - text/format - [number] - (coll [list "list/" Functor<List>] - (dictionary ["dict" unordered #+ Dict]))) - [macro #+ with-gensyms] - (macro [code] - ["s" syntax #+ syntax:]) - [host]) - (luxc ["&" lang] - (lang ["la" analysis] - ["ls" synthesis] - (host [r #+ Expression]))) - [///] - (/// [".T" runtime] - [".T" case] - [".T" function] - [".T" loop])) - -## [Types] -(type: #export Translator - (-> ls.Synthesis (Meta Expression))) - -(type: #export Proc - (-> Translator (List ls.Synthesis) (Meta Expression))) - -(type: #export Bundle - (Dict Text Proc)) - -(syntax: (Vector {size s.nat} elemT) - (wrap (list (` [(~+ (list.repeat size elemT))])))) - -(type: #export Nullary (-> (Vector +0 Expression) Expression)) -(type: #export Unary (-> (Vector +1 Expression) Expression)) -(type: #export Binary (-> (Vector +2 Expression) Expression)) -(type: #export Trinary (-> (Vector +3 Expression) Expression)) -(type: #export Variadic (-> (List Expression) Expression)) - -## [Utils] -(def: #export (install name unnamed) - (-> Text (-> Text Proc) - (-> Bundle Bundle)) - (dict.put name (unnamed name))) - -(def: #export (prefix prefix bundle) - (-> Text Bundle Bundle) - (|> bundle - dict.entries - (list/map (function (_ [key val]) [(format prefix " " key) val])) - (dict.from-list text.Hash<Text>))) - -(def: (wrong-arity proc expected actual) - (-> Text Nat Nat Text) - (format "Wrong number of arguments for " (%t proc) "\n" - "Expected: " (|> expected .int %i) "\n" - " Actual: " (|> actual .int %i))) - -(syntax: (arity: {name s.local-identifier} {arity s.nat}) - (with-gensyms [g!_ g!proc g!name g!translate g!inputs] - (do {@ macro.monad} - [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] - (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!proc)) - (-> (-> (..Vector (~ (code.nat arity)) Expression) Expression) - (-> Text ..Proc)) - (function ((~ g!_) (~ g!name)) - (function ((~ g!_) (~ g!translate) (~ g!inputs)) - (case (~ g!inputs) - (^ (list (~+ g!input+))) - (do macro.Monad<Meta> - [(~+ (|> g!input+ - (list/map (function (_ g!input) - (list g!input (` ((~ g!translate) (~ g!input)))))) - list.concat))] - ((~' wrap) ((~ g!proc) [(~+ g!input+)]))) - - (~' _) - (macro.fail (wrong-arity (~ g!name) +1 (list.size (~ g!inputs)))))))))))))) - -(arity: nullary +0) -(arity: unary +1) -(arity: binary +2) -(arity: trinary +3) - -(def: #export (variadic proc) - (-> Variadic (-> Text Proc)) - (function (_ proc-name) - (function (_ translate inputsS) - (do {@ macro.Monad<Meta>} - [inputsI (monad.map @ translate inputsS)] - (wrap (proc inputsI)))))) - -## [Procedures] -## [[Lux]] -(def: (lux//is [leftO rightO]) - Binary - (r.apply (list leftO rightO) - (r.global "identical"))) - -(def: (lux//if [testO thenO elseO]) - Trinary - (caseT.translate-if testO thenO elseO)) - -(def: (lux//try riskyO) - Unary - (runtimeT.lux//try riskyO)) - -(exception: #export (Wrong-Syntax {message Text}) - message) - -(def: #export (wrong-syntax procedure args) - (-> Text (List ls.Synthesis) Text) - (format "Procedure: " procedure "\n" - "Arguments: " (%code (code.tuple args)))) - -(def: lux//loop - (-> Text Proc) - (function (_ proc-name) - (function (_ translate inputsS) - (case (s.run inputsS ($_ p.seq s.nat (s.tuple (p.many s.any)) s.any)) - (#e.Success [offset initsS+ bodyS]) - (loopT.translate-loop translate offset initsS+ bodyS) - - (#e.Error error) - (&.throw Wrong-Syntax (wrong-syntax proc-name inputsS))) - ))) - -(def: lux//recur - (-> Text Proc) - (function (_ proc-name) - (function (_ translate inputsS) - (loopT.translate-recur translate inputsS)))) - -(def: lux-procs - Bundle - (|> (dict.new text.Hash<Text>) - (install "is" (binary lux//is)) - (install "try" (unary lux//try)) - (install "if" (trinary lux//if)) - (install "loop" lux//loop) - (install "recur" lux//recur) - )) - -## [[Bits]] -(template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (<op> paramO subjectO))] - - [bit//and runtimeT.bit//and] - [bit//or runtimeT.bit//or] - [bit//xor runtimeT.bit//xor] - ) - -(template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (<op> (runtimeT.int64-low paramO) subjectO))] - - [bit//left-shift runtimeT.bit//left-shift] - [bit//arithmetic-right-shift runtimeT.bit//arithmetic-right-shift] - [bit//logical-right-shift runtimeT.bit//logical-right-shift] - ) - -(def: bit-procs - Bundle - (<| (prefix "bit") - (|> (dict.new text.Hash<Text>) - (install "and" (binary bit//and)) - (install "or" (binary bit//or)) - (install "xor" (binary bit//xor)) - (install "left-shift" (binary bit//left-shift)) - (install "logical-right-shift" (binary bit//logical-right-shift)) - (install "arithmetic-right-shift" (binary bit//arithmetic-right-shift)) - ))) - -## [[Numbers]] -(host.import: java/lang/Double - (#static MIN_VALUE Double) - (#static MAX_VALUE Double)) - -(template [<name> <const> <encode>] - [(def: (<name> _) - Nullary - (<encode> <const>))] - - [frac//smallest Double::MIN_VALUE r.float] - [frac//min (f/* -1.0 Double::MAX_VALUE) r.float] - [frac//max Double::MAX_VALUE r.float] - ) - -(template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (|> subjectO (<op> paramO)))] - - [int//add runtimeT.int//+] - [int//sub runtimeT.int//-] - [int//mul runtimeT.int//*] - [int//div runtimeT.int///] - [int//rem runtimeT.int//%] - ) - -(template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (<op> paramO subjectO))] - - [frac//add r.+] - [frac//sub r.-] - [frac//mul r.*] - [frac//div r./] - [frac//rem r.%%] - [frac//= r.=] - [frac//< r.<] - - [text//= r.=] - [text//< r.<] - ) - -(template [<name> <cmp>] - [(def: (<name> [subjectO paramO]) - Binary - (<cmp> paramO subjectO))] - - [int//= runtimeT.int//=] - [int//< runtimeT.int//<] - ) - -(def: (apply1 func) - (-> Expression (-> Expression Expression)) - (function (_ value) - (r.apply (list value) func))) - -(def: int//char (|>> runtimeT.int64-low (apply1 (r.global "intToUtf8")))) - -(def: int-procs - Bundle - (<| (prefix "int") - (|> (dict.new text.Hash<Text>) - (install "+" (binary int//add)) - (install "-" (binary int//sub)) - (install "*" (binary int//mul)) - (install "/" (binary int//div)) - (install "%" (binary int//rem)) - (install "=" (binary int//=)) - (install "<" (binary int//<)) - (install "to-frac" (unary runtimeT.int//to-float)) - (install "char" (unary int//char))))) - -(def: (frac//encode value) - (-> Expression Expression) - (r.apply (list (r.string "%f") value) (r.global "sprintf"))) - -(def: frac-procs - Bundle - (<| (prefix "frac") - (|> (dict.new text.Hash<Text>) - (install "+" (binary frac//add)) - (install "-" (binary frac//sub)) - (install "*" (binary frac//mul)) - (install "/" (binary frac//div)) - (install "%" (binary frac//rem)) - (install "=" (binary frac//=)) - (install "<" (binary frac//<)) - (install "smallest" (nullary frac//smallest)) - (install "min" (nullary frac//min)) - (install "max" (nullary frac//max)) - (install "to-int" (unary (apply1 (r.global "as.integer")))) - (install "encode" (unary frac//encode)) - (install "decode" (unary runtimeT.frac//decode))))) - -## [[Text]] -(def: (text//concat [subjectO paramO]) - Binary - (r.apply (list subjectO paramO) (r.global "paste0"))) - -(def: (text//char [subjectO paramO]) - Binary - (runtimeT.text//char subjectO paramO)) - -(def: (text//clip [subjectO paramO extraO]) - Trinary - (runtimeT.text//clip subjectO paramO extraO)) - -(def: (text//index [textO partO startO]) - Trinary - (runtimeT.text//index textO partO startO)) - -(def: text-procs - Bundle - (<| (prefix "text") - (|> (dict.new text.Hash<Text>) - (install "=" (binary text//=)) - (install "<" (binary text//<)) - (install "concat" (binary text//concat)) - (install "index" (trinary text//index)) - (install "size" (unary (|>> (apply1 (r.global "nchar")) runtimeT.int//from-float))) - (install "char" (binary text//char)) - (install "clip" (trinary text//clip)) - ))) - -## [[IO]] -(def: (io//exit input) - Unary - (r.apply-kw (list) - (list ["status" (runtimeT.int//to-float input)]) - (r.global "quit"))) - -(def: (void code) - (-> Expression Expression) - (r.block (r.then code runtimeT.unit))) - -(def: io-procs - Bundle - (<| (prefix "io") - (|> (dict.new text.Hash<Text>) - (install "log" (unary (|>> r.print ..void))) - (install "error" (unary r.stop)) - (install "exit" (unary io//exit)) - (install "current-time" (nullary (function (_ _) - (runtimeT.io//current-time! runtimeT.unit))))))) - -## [Bundles] -(def: #export procedures - Bundle - (<| (prefix "lux") - (|> lux-procs - (dict.merge bit-procs) - (dict.merge int-procs) - (dict.merge frac-procs) - (dict.merge text-procs) - (dict.merge io-procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux deleted file mode 100644 index 3bd33955f..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux +++ /dev/null @@ -1,89 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data [text] - text/format - (coll [list "list/" Functor<List>] - (dictionary ["dict" unordered #+ Dict]))) - [macro "macro/" Monad<Meta>]) - (luxc ["&" lang] - (lang ["la" analysis] - ["ls" synthesis] - (host [ruby #+ Ruby Expression Statement]))) - [///] - (/// [".T" runtime]) - (// ["@" common])) - -## (template [<name> <lua>] -## [(def: (<name> _) @.Nullary <lua>)] - -## [lua//nil "nil"] -## [lua//table "{}"] -## ) - -## (def: (lua//global proc translate inputs) -## (-> Text @.Proc) -## (case inputs -## (^ (list [_ (#.Text name)])) -## (do macro.Monad<Meta> -## [] -## (wrap name)) - -## _ -## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -## (def: (lua//call proc translate inputs) -## (-> Text @.Proc) -## (case inputs -## (^ (list& functionS argsS+)) -## (do {@ macro.Monad<Meta>} -## [functionO (translate functionS) -## argsO+ (monad.map @ translate argsS+)] -## (wrap (lua.apply functionO argsO+))) - -## _ -## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -## (def: lua-procs -## @.Bundle -## (|> (dict.new text.Hash<Text>) -## (@.install "nil" (@.nullary lua//nil)) -## (@.install "table" (@.nullary lua//table)) -## (@.install "global" lua//global) -## (@.install "call" lua//call))) - -## (def: (table//call proc translate inputs) -## (-> Text @.Proc) -## (case inputs -## (^ (list& tableS [_ (#.Text field)] argsS+)) -## (do {@ macro.Monad<Meta>} -## [tableO (translate tableS) -## argsO+ (monad.map @ translate argsS+)] -## (wrap (lua.method field tableO argsO+))) - -## _ -## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -## (def: (table//get [fieldO tableO]) -## @.Binary -## (runtimeT.lua//get tableO fieldO)) - -## (def: (table//set [fieldO valueO tableO]) -## @.Trinary -## (runtimeT.lua//set tableO fieldO valueO)) - -## (def: table-procs -## @.Bundle -## (<| (@.prefix "table") -## (|> (dict.new text.Hash<Text>) -## (@.install "call" table//call) -## (@.install "get" (@.binary table//get)) -## (@.install "set" (@.trinary table//set))))) - -(def: #export procedures - @.Bundle - (<| (@.prefix "lua") - (dict.new text.Hash<Text>) - ## (|> lua-procs - ## (dict.merge table-procs)) - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/reference.lux deleted file mode 100644 index c986bc2a0..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/reference.lux +++ /dev/null @@ -1,12 +0,0 @@ -(.module: - [lux #* - [target - ["_" r (#+ Expression)]]] - [/// - [reference (#+ System)]]) - -(implementation: #export system - (System Expression) - - (def: constant _.var) - (def: variable _.var)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux deleted file mode 100644 index ac0efe5ef..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux +++ /dev/null @@ -1,854 +0,0 @@ -(.module: - [lux (#- Location inc i64) - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<.>" code]]] - [data - ["." product] - ["." text ("#\." hash) - ["%" format (#+ format)] - [encoding - ["." utf8]]] - [collection - ["." list ("#\." functor)] - ["." row]]] - ["." macro - [syntax (#+ syntax:)] - ["." code]] - [math - [number (#+ hex) - ["n" nat] - ["i" int ("#\." interval)] - ["." i64]]] - ["@" target - ["_" r (#+ SVar Expression)]]] - ["." /// #_ - ["#." reference] - ["//#" /// #_ - [analysis (#+ Variant)] - ["#." synthesis (#+ Synthesis)] - ["#." generation] - ["//#" /// - ["#." phase] - [reference - [variable (#+ Register)]] - [meta - [archive (#+ Output Archive) - ["." artifact (#+ Registry)]]]]]]) - -(def: module_id - 0) - -(template [<name> <base>] - [(type: #export <name> - (<base> _.SVar _.Expression _.Expression))] - - [Operation /////generation.Operation] - [Phase /////generation.Phase] - [Handler /////generation.Handler] - [Bundle /////generation.Bundle] - ) - -(type: #export (Generator i) - (-> Phase Archive i (Operation Expression))) - -(def: #export unit - Expression - (_.string /////synthesis.unit)) - -(def: full_32 (hex "FFFFFFFF")) -(def: half_32 (hex "7FFFFFFF")) -(def: post_32 (hex "100000000")) - -(def: (cap_32 input) - (-> Nat Int) - (cond (n.> full_32 input) - (|> input (i64.and full_32) cap_32) - - (n.> half_32 input) - (|> post_32 (n.- input) .int (i.* -1)) - - ## else - (.int input))) - -(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} - body) - (do {! meta.monad} - [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] - (wrap (list (` (let [(~+ (|> vars - (list.zip/2 ids) - (list\map (function (_ [id var]) - (list (code.local_identifier var) - (` (_.var (~ (code.text (format "v" (%.nat id))))))))) - list.concat))] - (~ body))))))) - -(syntax: (runtime: {declaration (<>.or <code>.local_identifier - (<code>.form (<>.and <code>.local_identifier - (<>.some <code>.local_identifier))))} - code) - (do meta.monad - [runtime_id meta.count] - (macro.with_gensyms [g!_] - (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id])) - runtime_name (` (_.var (~ (code.text (%.code runtime)))))] - (case declaration - (#.Left name) - (let [g!name (code.local_identifier name)] - (wrap (list (` (def: #export (~ g!name) - _.SVar - (~ runtime_name))) - - (` (def: (~ (code.local_identifier (format "@" name))) - _.Expression - (_.set! (~ runtime_name) (~ code))))))) - - (#.Right [name inputs]) - (let [g!name (code.local_identifier name) - inputsC (list\map code.local_identifier inputs) - inputs_typesC (list\map (function.constant (` _.Expression)) - inputs)] - (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) - (-> (~+ inputs_typesC) _.Expression) - (_.apply (list (~+ inputsC)) (~ runtime_name)))) - - (` (def: (~ (code.local_identifier (format "@" name))) - _.Expression - (..with_vars [(~+ inputsC)] - (_.set! (~ runtime_name) - (_.function (list (~+ inputsC)) - (~ code)))))))))))))) - -(def: #export variant_tag_field "luxVT") -(def: #export variant_flag_field "luxVF") -(def: #export variant_value_field "luxVV") - -(def: #export (flag value) - (-> Bit Expression) - (if value - (_.string "") - _.null)) - -(runtime: (adt::variant tag last? value) - (_.named_list (list [..variant_tag_field (_.as::integer tag)] - [..variant_flag_field last?] - [..variant_value_field value]))) - -(def: #export (variant tag last? value) - (-> Nat Bit Expression Expression) - (adt::variant (_.int (.int tag)) - (flag last?) - value)) - -(def: #export none - Expression - (variant 0 #0 ..unit)) - -(def: #export some - (-> Expression Expression) - (variant 1 #1)) - -(def: #export left - (-> Expression Expression) - (variant 0 #0)) - -(def: #export right - (-> Expression Expression) - (variant 1 #1)) - -(def: high_shift (_.bit_shl (_.int +32))) - -(template [<name> <power>] - [(runtime: <name> (|> (_.as::integer (_.int +2)) (_.** (_.as::integer (_.int <power>)))))] - - [f2^32 +32] - [f2^63 +63] - ) - -(def: (as_double value) - (-> Expression Expression) - (_.apply (list value) (_.var "as.double"))) - -(def: #export i64_high_field "luxIH") -(def: #export i64_low_field "luxIL") - -(runtime: (i64::unsigned_low input) - (with_vars [low] - ($_ _.then - (_.set! low (|> input (_.nth (_.string ..i64_low_field)))) - (_.if (|> low (_.>= (_.int +0))) - low - (|> low (_.+ f2^32)))))) - -(runtime: (i64::to_float input) - (let [high (|> input - (_.nth (_.string ..i64_high_field)) - high_shift) - low (|> input - i64::unsigned_low)] - (|> high (_.+ low) as_double))) - -(runtime: (i64::new high low) - (_.named_list (list [..i64_high_field (_.as::integer high)] - [..i64_low_field (_.as::integer low)]))) - -(def: high_32 - (-> Nat Nat) - (i64.right_shift 32)) - -(def: low_32 - (-> Nat Nat) - (|>> (i64.and (hex "FFFFFFFF")))) - -(def: #export (i64 value) - (-> Int Expression) - (let [value (.nat value)] - (i64::new (|> value ..high_32 ..cap_32 _.int) - (|> value ..low_32 ..cap_32 _.int)))) - -(def: #export (lux_i64 high low) - (-> Int Int Int) - (|> high - (i64.left_shift 32) - (i64.or low))) - -(template [<name> <value>] - [(runtime: <name> - (..i64 <value>))] - - [i64::zero +0] - [i64::one +1] - [i64::min i\bottom] - [i64::max i\top] - ) - -(def: #export i64_high (_.nth (_.string ..i64_high_field))) -(def: #export i64_low (_.nth (_.string ..i64_low_field))) - -(runtime: (i64::not input) - (i64::new (|> input i64_high _.bit_not) - (|> input i64_low _.bit_not))) - -(runtime: (i64::+ param subject) - (with_vars [sH sL pH pL - x00 x16 x32 x48] - ($_ _.then - (_.set! sH (|> subject i64_high)) - (_.set! sL (|> subject i64_low)) - (_.set! pH (|> param i64_high)) - (_.set! pL (|> param i64_low)) - (let [bits16 (_.manual "0xFFFF") - move_top_16 (_.bit_shl (_.int +16)) - top_16 (_.bit_ushr (_.int +16)) - bottom_16 (_.bit_and bits16) - split_16 (function (_ source) - [(|> source top_16) - (|> source bottom_16)]) - split_int (function (_ high low) - [(split_16 high) - (split_16 low)]) - - [[s48 s32] [s16 s00]] (split_int sH sL) - [[p48 p32] [p16 p00]] (split_int pH pL) - new_half (function (_ top bottom) - (|> top bottom_16 move_top_16 - (_.bit_or (bottom_16 bottom))))] - ($_ _.then - (_.set! x00 (|> s00 (_.+ p00))) - (_.set! x16 (|> x00 top_16 (_.+ s16) (_.+ p16))) - (_.set! x32 (|> x16 top_16 (_.+ s32) (_.+ p32))) - (_.set! x48 (|> x32 top_16 (_.+ s48) (_.+ p48))) - (i64::new (new_half x48 x32) - (new_half x16 x00))))))) - -(runtime: (i64::= reference sample) - (let [n/a? (function (_ value) - (_.apply (list value) (_.var "is.na"))) - isTRUE? (function (_ value) - (_.apply (list value) (_.var "isTRUE"))) - comparison (: (-> (-> Expression Expression) Expression) - (function (_ field) - (|> (|> (field sample) (_.= (field reference))) - (_.or (|> (n/a? (field sample)) - (_.and (n/a? (field reference))))))))] - (|> (comparison i64_high) - (_.and (comparison i64_low)) - isTRUE?))) - -(runtime: (i64::negate input) - (_.if (|> input (i64::= i64::min)) - i64::min - (|> input i64::not (i64::+ i64::one)))) - -(runtime: i64::-one - (i64::negate i64::one)) - -(runtime: (i64::- param subject) - (i64::+ (i64::negate param) subject)) - -(runtime: (i64::< reference sample) - (with_vars [r_? s_?] - ($_ _.then - (_.set! s_? (|> sample ..i64_high (_.< (_.int +0)))) - (_.set! r_? (|> reference ..i64_high (_.< (_.int +0)))) - (|> (|> s_? (_.and (_.not r_?))) - (_.or (|> (_.not s_?) (_.and r_?) _.not)) - (_.or (|> sample - (i64::- reference) - ..i64_high - (_.< (_.int +0)))))))) - -(runtime: (i64::from_float input) - (_.cond (list [(_.apply (list input) (_.var "is.nan")) - i64::zero] - [(|> input (_.<= (_.negate f2^63))) - i64::min] - [(|> input (_.+ (_.float +1.0)) (_.>= f2^63)) - i64::max] - [(|> input (_.< (_.float +0.0))) - (|> input _.negate i64::from_float i64::negate)]) - (i64::new (|> input (_./ f2^32)) - (|> input (_.%% f2^32))))) - -(runtime: (i64::* param subject) - (with_vars [sH sL pH pL - x00 x16 x32 x48] - ($_ _.then - (_.set! sH (|> subject i64_high)) - (_.set! pH (|> param i64_high)) - (let [negative_subject? (|> sH (_.< (_.int +0))) - negative_param? (|> pH (_.< (_.int +0)))] - (_.cond (list [negative_subject? - (_.if negative_param? - (i64::* (i64::negate param) - (i64::negate subject)) - (i64::negate (i64::* param - (i64::negate subject))))] - - [negative_param? - (i64::negate (i64::* (i64::negate param) - subject))]) - ($_ _.then - (_.set! sL (|> subject i64_low)) - (_.set! pL (|> param i64_low)) - (let [bits16 (_.manual "0xFFFF") - move_top_16 (_.bit_shl (_.int +16)) - top_16 (_.bit_ushr (_.int +16)) - bottom_16 (_.bit_and bits16) - split_16 (function (_ source) - [(|> source top_16) - (|> source bottom_16)]) - split_int (function (_ high low) - [(split_16 high) - (split_16 low)]) - new_half (function (_ top bottom) - (|> top bottom_16 move_top_16 - (_.bit_or (bottom_16 bottom)))) - x16_top (|> x16 top_16) - x32_top (|> x32 top_16)] - (with_vars [s48 s32 s16 s00 - p48 p32 p16 p00] - (let [[[_s48 _s32] [_s16 _s00]] (split_int sH sL) - [[_p48 _p32] [_p16 _p00]] (split_int pH pL) - set_subject_chunks! ($_ _.then (_.set! s48 _s48) (_.set! s32 _s32) (_.set! s16 _s16) (_.set! s00 _s00)) - set_param_chunks! ($_ _.then (_.set! p48 _p48) (_.set! p32 _p32) (_.set! p16 _p16) (_.set! p00 _p00))] - ($_ _.then - set_subject_chunks! - set_param_chunks! - (_.set! x00 (|> s00 (_.* p00))) - (_.set! x16 (|> x00 top_16 (_.+ (|> s16 (_.* p00))))) - (_.set! x32 x16_top) - (_.set! x16 (|> x16 bottom_16 (_.+ (|> s00 (_.* p16))))) - (_.set! x32 (|> x32 (_.+ x16_top) (_.+ (|> s32 (_.* p00))))) - (_.set! x48 x32_top) - (_.set! x32 (|> x32 bottom_16 (_.+ (|> s16 (_.* p16))))) - (_.set! x48 (|> x48 (_.+ x32_top))) - (_.set! x32 (|> x32 bottom_16 (_.+ (|> s00 (_.* p32))))) - (_.set! x48 (|> x48 (_.+ x32_top) - (_.+ (|> s48 (_.* p00))) - (_.+ (|> s32 (_.* p16))) - (_.+ (|> s16 (_.* p32))) - (_.+ (|> s00 (_.* p48))))) - (i64::new (new_half x48 x32) - (new_half x16 x00))))) - ))))))) - -(def: (limit_shift! shift) - (-> SVar Expression) - (_.set! shift (|> shift (_.bit_and (_.as::integer (_.int +63)))))) - -(def: (no_shift_clause shift input) - (-> SVar SVar [Expression Expression]) - [(|> shift (_.= (_.int +0))) - input]) - -(runtime: (i64::left_shift shift input) - ($_ _.then - (limit_shift! shift) - (_.cond (list (no_shift_clause shift input) - [(|> shift (_.< (_.int +32))) - (let [mid (|> (i64_low input) (_.bit_ushr (|> (_.int +32) (_.- shift)))) - high (|> (i64_high input) - (_.bit_shl shift) - (_.bit_or mid)) - low (|> (i64_low input) - (_.bit_shl shift))] - (i64::new high low))]) - (let [high (|> (i64_high input) - (_.bit_shl (|> shift (_.- (_.int +32)))))] - (i64::new high (_.int +0)))))) - -(runtime: (i64::arithmetic_right_shift_32 shift input) - (let [top_bit (|> input (_.bit_and (_.as::integer (_.int (hex "+80000000")))))] - (|> input - (_.bit_ushr shift) - (_.bit_or top_bit)))) - -(runtime: (i64::arithmetic_right_shift shift input) - ($_ _.then - (limit_shift! shift) - (_.cond (list (no_shift_clause shift input) - [(|> shift (_.< (_.int +32))) - (let [mid (|> (i64_high input) (_.bit_shl (|> (_.int +32) (_.- shift)))) - high (|> (i64_high input) - (i64::arithmetic_right_shift_32 shift)) - low (|> (i64_low input) - (_.bit_ushr shift) - (_.bit_or mid))] - (i64::new high low))]) - (let [low (|> (i64_high input) - (i64::arithmetic_right_shift_32 (|> shift (_.- (_.int +32))))) - high (_.if (|> (i64_high input) (_.>= (_.int +0))) - (_.int +0) - (_.int -1))] - (i64::new high low))))) - -(runtime: (i64::/ param subject) - (let [negative? (|>> (i64::< i64::zero)) - valid_division_check [(|> param (i64::= i64::zero)) - (_.stop (_.string "Cannot divide by zero!"))] - short_circuit_check [(|> subject (i64::= i64::zero)) - i64::zero]] - (_.cond (list valid_division_check - short_circuit_check - - [(|> subject (i64::= i64::min)) - (_.cond (list [(|> (|> param (i64::= i64::one)) - (_.or (|> param (i64::= i64::-one)))) - i64::min] - [(|> param (i64::= i64::min)) - i64::one]) - (with_vars [approximation] - ($_ _.then - (_.set! approximation - (|> subject - (i64::arithmetic_right_shift (_.int +1)) - (i64::/ param) - (i64::left_shift (_.int +1)))) - (_.if (|> approximation (i64::= i64::zero)) - (_.if (negative? param) - i64::one - i64::-one) - (let [remainder (i64::- (i64::* param approximation) - subject)] - (|> remainder - (i64::/ param) - (i64::+ approximation)))))))] - [(|> param (i64::= i64::min)) - i64::zero] - - [(negative? subject) - (_.if (negative? param) - (|> (i64::negate subject) - (i64::/ (i64::negate param))) - (|> (i64::negate subject) - (i64::/ param) - i64::negate))] - - [(negative? param) - (|> param - i64::negate - (i64::/ subject) - i64::negate)]) - (with_vars [result remainder approximate approximate_result log2 approximate_remainder] - ($_ _.then - (_.set! result i64::zero) - (_.set! remainder subject) - (_.while (|> (|> remainder (i64::< param)) - (_.or (|> remainder (i64::= param)))) - (let [calc_rough_estimate (_.apply (list (|> (i64::to_float remainder) (_./ (i64::to_float param)))) - (_.var "floor")) - calc_approximate_result (i64::from_float approximate) - calc_approximate_remainder (|> approximate_result (i64::* param)) - delta (_.if (|> (_.float +48.0) (_.<= log2)) - (_.float +1.0) - (_.** (|> log2 (_.- (_.float +48.0))) - (_.float +2.0)))] - ($_ _.then - (_.set! approximate (_.apply (list (_.float +1.0) calc_rough_estimate) - (_.var "max"))) - (_.set! log2 (let [log (function (_ input) - (_.apply (list input) (_.var "log")))] - (_.apply (list (|> (log (_.int +2)) - (_./ (log approximate)))) - (_.var "ceil")))) - (_.set! approximate_result calc_approximate_result) - (_.set! approximate_remainder calc_approximate_remainder) - (_.while (|> (negative? approximate_remainder) - (_.or (|> approximate_remainder (i64::< remainder)))) - ($_ _.then - (_.set! approximate (|> delta (_.- approximate))) - (_.set! approximate_result calc_approximate_result) - (_.set! approximate_remainder calc_approximate_remainder))) - (_.set! result (|> (_.if (|> approximate_result (i64::= i64::zero)) - i64::one - approximate_result) - (i64::+ result))) - (_.set! remainder (|> remainder (i64::- approximate_remainder)))))) - result)) - ))) - -(runtime: (i64::% param subject) - (let [flat (|> subject (i64::/ param) (i64::* param))] - (|> subject (i64::- flat)))) - -(runtime: (lux::try op) - (with_vars [error value] - (_.try ($_ _.then - (_.set! value (_.apply (list ..unit) op)) - (..right value)) - #.None - (#.Some (_.function (list error) - (..left (_.nth (_.string "message") - error)))) - #.None))) - -(runtime: (lux::program_args program_args) - (with_vars [inputs value] - ($_ _.then - (_.set! inputs ..none) - (<| (_.for_in value program_args) - (_.set! inputs (..some (_.list (list value inputs))))) - inputs))) - -(def: runtime::lux - Expression - ($_ _.then - @lux::try - @lux::program_args - )) - -(def: current_time_float - Expression - (let [raw_time (_.apply (list) (_.var "Sys.time"))] - (_.apply (list raw_time) (_.var "as.numeric")))) - -(runtime: (io::current_time! _) - (|> current_time_float - (_.* (_.float +1,000.0)) - i64::from_float)) - -(def: runtime::io - Expression - ($_ _.then - @io::current_time! - )) - -(def: minimum_index_length - (-> SVar Expression) - (|>> (_.+ (_.int +1)))) - -(def: (product_element product index) - (-> Expression Expression Expression) - (|> product (_.nth (|> index (_.+ (_.int +1)))))) - -(def: (product_tail product) - (-> SVar Expression) - (|> product (_.nth (_.length product)))) - -(def: (updated_index min_length product) - (-> Expression Expression Expression) - (|> min_length (_.- (_.length product)))) - -(runtime: (tuple::left index product) - (let [$index_min_length (_.var "index_min_length")] - ($_ _.then - (_.set! $index_min_length (minimum_index_length index)) - (_.if (|> (_.length product) (_.> $index_min_length)) - ## No need for recursion - (product_element product index) - ## Needs recursion - (tuple::left (updated_index $index_min_length product) - (product_tail product)))))) - -(runtime: (tuple::right index product) - (let [$index_min_length (_.var "index_min_length")] - ($_ _.then - (_.set! $index_min_length (minimum_index_length index)) - (_.cond (list [## Last element. - (|> (_.length product) (_.= $index_min_length)) - (product_element product index)] - [## Needs recursion - (|> (_.length product) (_.< $index_min_length)) - (tuple::right (updated_index $index_min_length product) - (product_tail product))]) - ## Must slice - (|> product (_.slice_from index)))))) - -(runtime: (sum::get sum wants_last? wanted_tag) - (let [no_match _.null - sum_tag (|> sum (_.nth (_.string ..variant_tag_field))) - sum_flag (|> sum (_.nth (_.string ..variant_flag_field))) - sum_value (|> sum (_.nth (_.string ..variant_value_field))) - is_last? (|> sum_flag (_.= (_.string ""))) - test_recursion (_.if is_last? - ## Must recurse. - (|> wanted_tag - (_.- sum_tag) - (sum::get sum_value wants_last?)) - no_match)] - (_.cond (list [(_.= sum_tag wanted_tag) - (_.if (_.= wants_last? sum_flag) - sum_value - test_recursion)] - - [(|> wanted_tag (_.> sum_tag)) - test_recursion] - - [(|> (|> wants_last? (_.= (_.string ""))) - (_.and (|> wanted_tag (_.< sum_tag)))) - (adt::variant (|> sum_tag (_.- wanted_tag)) sum_flag sum_value)]) - - no_match))) - -(def: runtime::adt - Expression - ($_ _.then - @tuple::left - @tuple::right - @sum::get - @adt::variant - )) - -(template [<name> <op>] - [(runtime: (<name> mask input) - (i64::new (<op> (i64_high mask) - (i64_high input)) - (<op> (i64_low mask) - (i64_low input))))] - - [i64::and _.bit_and] - [i64::or _.bit_or] - [i64::xor _.bit_xor] - ) - -(runtime: (i64::right_shift shift input) - ($_ _.then - (limit_shift! shift) - (_.cond (list (no_shift_clause shift input) - [(|> shift (_.< (_.int +32))) - (with_vars [$mid] - (let [mid (|> (i64_high input) (_.bit_shl (|> (_.int +32) (_.- shift)))) - high (|> (i64_high input) (_.bit_ushr shift)) - low (|> (i64_low input) - (_.bit_ushr shift) - (_.bit_or (_.if (_.apply (list $mid) (_.var "is.na")) - (_.as::integer (_.int +0)) - $mid)))] - ($_ _.then - (_.set! $mid mid) - (i64::new high low))))] - [(|> shift (_.= (_.int +32))) - (let [high (i64_high input)] - (i64::new (_.int +0) high))]) - (let [low (|> (i64_high input) (_.bit_ushr (|> shift (_.- (_.int +32)))))] - (i64::new (_.int +0) low))))) - -(def: runtime::i64 - Expression - ($_ _.then - @f2^32 - @f2^63 - - @i64::new - @i64::from_float - - @i64::and - @i64::or - @i64::xor - @i64::not - @i64::left_shift - @i64::arithmetic_right_shift_32 - @i64::arithmetic_right_shift - @i64::right_shift - - @i64::zero - @i64::one - @i64::min - @i64::max - @i64::= - @i64::< - @i64::+ - @i64::- - @i64::negate - @i64::-one - @i64::unsigned_low - @i64::to_float - @i64::* - @i64::/ - @i64::% - )) - -(runtime: (frac::decode input) - (with_vars [output] - ($_ _.then - (_.set! output (_.apply (list input) (_.var "as.numeric"))) - (_.if (|> output (_.= _.n/a)) - ..none - (..some output))))) - -(def: runtime::frac - Expression - ($_ _.then - @frac::decode - )) - -(def: inc - (-> Expression Expression) - (|>> (_.+ (_.int +1)))) - -(template [<name> <top_cmp>] - [(def: (<name> top value) - (-> Expression Expression Expression) - (|> (|> value (_.>= (_.int +0))) - (_.and (|> value (<top_cmp> top)))))] - - [within? _.<] - [up_to? _.<=] - ) - -(def: (text_clip start end text) - (-> Expression Expression Expression Expression) - (_.apply (list text start end) - (_.var "substr"))) - -(def: (text_length text) - (-> Expression Expression) - (_.apply (list text) (_.var "nchar"))) - -(runtime: (text::index subject param start) - (with_vars [idx startF subjectL] - ($_ _.then - (_.set! startF (i64::to_float start)) - (_.set! subjectL (text_length subject)) - (_.if (|> startF (within? subjectL)) - ($_ _.then - (_.set! idx (|> (_.apply_kw (list param (_.if (|> startF (_.= (_.int +0))) - subject - (text_clip (inc startF) - (inc subjectL) - subject))) - (list ["fixed" (_.bool #1)]) - (_.var "regexpr")) - (_.nth (_.int +1)))) - (_.if (|> idx (_.= (_.int -1))) - ..none - (..some (i64::from_float (|> idx (_.+ startF)))))) - ..none)))) - -(runtime: (text::clip text from to) - (with_vars [length] - ($_ _.then - (_.set! length (_.length text)) - (_.if ($_ _.and - (|> to (within? length)) - (|> from (up_to? to))) - (..some (text_clip (inc from) (inc to) text)) - ..none)))) - -(def: (char_at idx text) - (-> Expression Expression Expression) - (_.apply (list (text_clip idx idx text)) - (_.var "utf8ToInt"))) - -(runtime: (text::char text idx) - (_.if (|> idx (within? (_.length text))) - ($_ _.then - (_.set! idx (inc idx)) - (..some (i64::from_float (char_at idx text)))) - ..none)) - -(def: runtime::text - Expression - ($_ _.then - @text::index - @text::clip - @text::char - )) - -(def: (check_index_out_of_bounds array idx body) - (-> Expression Expression Expression Expression) - (_.if (|> idx (_.<= (_.length array))) - body - (_.stop (_.string "Array index out of bounds!")))) - -(runtime: (array::new size) - (with_vars [output] - ($_ _.then - (_.set! output (_.list (list))) - (_.set_nth! (|> size (_.+ (_.int +1))) - _.null - output) - output))) - -(runtime: (array::get array idx) - (with_vars [temp] - (<| (check_index_out_of_bounds array idx) - ($_ _.then - (_.set! temp (|> array (_.nth (_.+ (_.int +1) idx)))) - (_.if (|> temp (_.= _.null)) - ..none - (..some temp)))))) - -(runtime: (array::put array idx value) - (<| (check_index_out_of_bounds array idx) - ($_ _.then - (_.set_nth! (_.+ (_.int +1) idx) value array) - array))) - -(def: runtime::array - Expression - ($_ _.then - @array::new - @array::get - @array::put - )) - -(def: runtime - Expression - ($_ _.then - runtime::lux - runtime::i64 - runtime::adt - runtime::frac - runtime::text - runtime::array - runtime::io - )) - -(def: #export generate - (Operation [Registry Output]) - (do ///////phase.monad - [_ (/////generation.execute! ..runtime) - _ (/////generation.save! (%.nat ..module_id) ..runtime)] - (wrap [(|> artifact.empty - artifact.resource - product.right) - (row.row [(%.nat ..module_id) - (|> ..runtime - _.code - (\ utf8.codec encode))])]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/structure.lux deleted file mode 100644 index 5f4703836..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/structure.lux +++ /dev/null @@ -1,39 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [data - [collection - ["." list]]] - [target - ["_" r (#+ Expression)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." primitive] - ["///#" //// #_ - [analysis (#+ Variant Tuple)] - ["#." synthesis (#+ Synthesis)] - ["//#" /// #_ - ["#." phase ("#\." monad)]]]]) - -(def: #export (tuple expression archive elemsS+) - (Generator (Tuple Synthesis)) - (case elemsS+ - #.Nil - (///////phase\wrap (//primitive.text /////synthesis.unit)) - - (#.Cons singletonS #.Nil) - (expression archive singletonS) - - _ - (|> elemsS+ - (monad.map ///////phase.monad (expression archive)) - (///////phase\map _.list)))) - -(def: #export (variant expression archive [lefts right? valueS]) - (Generator (Variant Synthesis)) - (let [tag (if right? - (inc lefts) - lefts)] - (///////phase\map (|>> (//runtime.variant tag right?)) - (expression archive valueS)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux deleted file mode 100644 index cdcc5a134..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux +++ /dev/null @@ -1,88 +0,0 @@ -(.module: - [lux #* - ["@" target] - [data - [text - ["%" format (#+ format)]]]] - ["." //// #_ - ["." version] - ["#." generation (#+ Context)] - ["//#" /// #_ - ["." reference (#+ Reference) - ["." variable (#+ Register Variable)]] - ["." phase ("#\." monad)] - [meta - [archive (#+ Archive)]]]]) - -## This universe constant is for languages where one can't just turn all compiled definitions -## into the local variables of some scoping function. -(def: #export universe - (for {## In the case of Lua, there is a limit of 200 locals in a function's scope. - @.lua (not ("lua script universe")) - ## Cannot make all definitions be local variables because of limitations with JRuby. - @.ruby (not ("ruby script universe")) - ## Cannot make all definitions be local variables because of limitations with PHP itself. - @.php (not ("php script universe")) - ## Cannot make all definitions be local variables because of limitations with Kawa. - @.scheme (not ("scheme script universe"))} - #0)) - -(def: universe_label - Text - (with_expansions [<label> (format "u" (%.nat (if ..universe 1 0)))] - (for {@.lua <label> - @.ruby <label> - @.php <label> - @.scheme <label>} - ""))) - -(def: #export (artifact [module artifact]) - (-> Context Text) - (format "l" (%.nat version.version) - ..universe_label - "m" (%.nat module) - "a" (%.nat artifact))) - -(interface: #export (System expression) - (: (-> Text expression) - constant) - (: (-> Text expression) - variable)) - -(def: #export (constant system archive name) - (All [anchor expression directive] - (-> (System expression) Archive Name - (////generation.Operation anchor expression directive expression))) - (phase\map (|>> ..artifact (\ system constant)) - (////generation.remember archive name))) - -(template [<sigil> <name>] - [(def: #export (<name> system) - (All [expression] - (-> (System expression) - (-> Register expression))) - (|>> %.nat (format <sigil>) (\ system variable)))] - - ["f" foreign] - ["l" local] - ) - -(def: #export (variable system variable) - (All [expression] - (-> (System expression) Variable expression)) - (case variable - (#variable.Local register) - (..local system register) - - (#variable.Foreign register) - (..foreign system register))) - -(def: #export (reference system archive reference) - (All [anchor expression directive] - (-> (System expression) Archive Reference (////generation.Operation anchor expression directive expression))) - (case reference - (#reference.Constant value) - (..constant system archive value) - - (#reference.Variable value) - (phase\wrap (..variable system value)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby.lux deleted file mode 100644 index f1a4e3c1c..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby.lux +++ /dev/null @@ -1,104 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." exception (#+ exception:)]] - [target - ["_" ruby]]] - ["." / #_ - [runtime (#+ Phase Phase!)] - ["#." primitive] - ["#." structure] - ["#." reference] - ["#." function] - ["#." case] - ["#." loop] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." extension] - ["/#" // #_ - [analysis (#+)] - ["#." synthesis] - ["//#" /// #_ - ["#." phase ("#\." monad)] - [reference (#+) - [variable (#+)]]]]]]]) - -(def: (statement expression archive synthesis) - Phase! - (case synthesis - (^template [<tag>] - [(^ (<tag> value)) - (//////phase\map _.return (expression archive synthesis))]) - ([////synthesis.bit] - [////synthesis.i64] - [////synthesis.f64] - [////synthesis.text] - [////synthesis.variant] - [////synthesis.tuple] - [#////synthesis.Reference] - [////synthesis.branch/get] - [////synthesis.function/apply] - [#////synthesis.Extension]) - - (^ (////synthesis.branch/case case)) - (/case.case! false statement expression archive case) - - (^template [<tag> <generator>] - [(^ (<tag> value)) - (<generator> statement expression archive value)]) - ([////synthesis.branch/let /case.let!] - [////synthesis.branch/if /case.if!] - [////synthesis.loop/scope /loop.scope!] - [////synthesis.loop/recur /loop.recur!]) - - (^ (////synthesis.function/abstraction abstraction)) - (//////phase\map _.return (/function.function statement expression archive abstraction)) - )) - -(exception: #export cannot-recur-as-an-expression) - -(def: (expression archive synthesis) - Phase - (case synthesis - (^template [<tag> <generator>] - [(^ (<tag> value)) - (//////phase\wrap (<generator> value))]) - ([////synthesis.bit /primitive.bit] - [////synthesis.i64 /primitive.i64] - [////synthesis.f64 /primitive.f64] - [////synthesis.text /primitive.text]) - - (^template [<tag> <generator>] - [(^ (<tag> value)) - (<generator> expression archive value)]) - ([////synthesis.variant /structure.variant] - [////synthesis.tuple /structure.tuple] - - [////synthesis.branch/let /case.let] - [////synthesis.branch/if /case.if] - [////synthesis.branch/get /case.get] - - [////synthesis.function/apply /function.apply]) - - (^template [<tag> <generator>] - [(^ (<tag> value)) - (<generator> statement expression archive value)]) - ([////synthesis.branch/case /case.case] - [////synthesis.loop/scope /loop.scope] - [////synthesis.function/abstraction /function.function]) - - (^ (////synthesis.loop/recur _)) - (//////phase.throw ..cannot-recur-as-an-expression []) - - (#////synthesis.Reference value) - (//reference.reference /reference.system archive value) - - (#////synthesis.Extension extension) - (///extension.apply archive expression extension))) - -(def: #export generate - Phase - ..expression) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/case.lux deleted file mode 100644 index 2249874b5..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/case.lux +++ /dev/null @@ -1,311 +0,0 @@ -(.module: - [lux (#- case let if) - [abstract - ["." monad (#+ do)]] - [control - [exception (#+ exception:)]] - [data - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set]]] - [math - [number - ["n" nat] - ["i" int]]] - [target - ["_" ruby (#+ Expression LVar Statement)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator Phase! Generator!)] - ["#." reference] - ["#." primitive] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - [synthesis - ["." case]] - ["/#" // #_ - ["#." synthesis (#+ Member Synthesis Path)] - ["#." generation] - ["//#" /// #_ - [reference - ["#." variable (#+ Register)]] - ["#." phase ("#\." monad)] - [meta - [archive (#+ Archive)]]]]]]]) - -(def: #export (gensym prefix) - (-> Text (Operation LVar)) - (///////phase\map (|>> %.nat (format prefix) _.local) /////generation.next)) - -(def: #export register - (-> Register LVar) - (|>> (///reference.local //reference.system) :assume)) - -(def: #export capture - (-> Register LVar) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: #export (let expression archive [valueS register bodyS]) - (Generator [Synthesis Register Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS) - bodyO (expression archive bodyS)] - ## TODO: Find some way to do 'let' without paying the price of the closure. - (wrap (|> bodyO - _.return - (_.lambda #.None (list (..register register))) - (_.apply_lambda/* (list valueO)))))) - -(def: #export (let! statement expression archive [valueS register bodyS]) - (Generator! [Synthesis Register Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS) - bodyO (statement expression archive bodyS)] - (wrap ($_ _.then - (_.set (list (..register register)) valueO) - bodyO)))) - -(def: #export (if expression archive [testS thenS elseS]) - (Generator [Synthesis Synthesis Synthesis]) - (do ///////phase.monad - [testO (expression archive testS) - thenO (expression archive thenS) - elseO (expression archive elseS)] - (wrap (_.? testO thenO elseO)))) - -(def: #export (if! statement expression archive [testS thenS elseS]) - (Generator! [Synthesis Synthesis Synthesis]) - (do ///////phase.monad - [test! (expression archive testS) - then! (statement expression archive thenS) - else! (statement expression archive elseS)] - (wrap (_.if test! - then! - else!)))) - -(def: #export (get expression archive [pathP valueS]) - (Generator [(List Member) Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS)] - (wrap (list\fold (function (_ side source) - (.let [method (.case side - (^template [<side> <accessor>] - [(<side> lefts) - (<accessor> (_.int (.int lefts)))]) - ([#.Left //runtime.tuple//left] - [#.Right //runtime.tuple//right]))] - (method source))) - valueO - (list.reverse pathP))))) - -(def: @savepoint (_.local "lux_pm_savepoint")) -(def: @cursor (_.local "lux_pm_cursor")) -(def: @temp (_.local "lux_pm_temp")) - -(def: (push! value) - (-> Expression Statement) - (_.statement (|> @cursor (_.do "push" (list value))))) - -(def: peek_and_pop - Expression - (|> @cursor (_.do "pop" (list)))) - -(def: pop! - Statement - (_.statement ..peek_and_pop)) - -(def: peek - Expression - (_.nth (_.int -1) @cursor)) - -(def: save! - Statement - (.let [cursor (_.array_range (_.int +0) (_.int -1) @cursor)] - (_.statement (|> @savepoint (_.do "push" (list cursor)))))) - -(def: restore! - Statement - (_.set (list @cursor) (|> @savepoint (_.do "pop" (list))))) - -(def: fail! _.break) - -(def: (multi_pop! pops) - (-> Nat Statement) - (_.statement (_.do "slice!" (list (_.int (i.* -1 (.int pops))) - (_.int (.int pops))) - @cursor))) - -(template [<name> <flag> <prep>] - [(def: (<name> simple? idx) - (-> Bit Nat Statement) - ($_ _.then - (_.set (list @temp) (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>))) - (.if simple? - (_.when (_.= _.nil @temp) - fail!) - (_.if (_.= _.nil @temp) - fail! - (..push! @temp)))))] - - [left_choice _.nil (<|)] - [right_choice (_.string "") inc] - ) - -(def: (with_looping in_closure? g!once g!continue? body!) - (-> Bit LVar LVar Statement Statement) - (.if in_closure? - ($_ _.then - (_.while (_.bool true) - body!)) - ($_ _.then - (_.set (list g!once) (_.bool true)) - (_.set (list g!continue?) (_.bool false)) - (<| (_.while (_.bool true)) - (_.if g!once - ($_ _.then - (_.set (list g!once) (_.bool false)) - body!) - ($_ _.then - (_.set (list g!continue?) (_.bool true)) - _.break))) - (_.when g!continue? - _.next)))) - -(def: (alternation in_closure? g!once g!continue? pre! post!) - (-> Bit LVar LVar Statement Statement Statement) - ($_ _.then - (with_looping in_closure? g!once g!continue? - ($_ _.then - ..save! - pre!)) - ..restore! - post!)) - -(def: (pattern_matching' in_closure? statement expression archive) - (-> Bit (Generator! Path)) - (function (recur pathP) - (.case pathP - (#/////synthesis.Then bodyS) - (statement expression archive bodyS) - - #/////synthesis.Pop - (///////phase\wrap ..pop!) - - (#/////synthesis.Bind register) - (///////phase\wrap (_.set (list (..register register)) ..peek)) - - (#/////synthesis.Bit_Fork when thenP elseP) - (do {! ///////phase.monad} - [then! (recur thenP) - else! (.case elseP - (#.Some elseP) - (recur elseP) - - #.None - (wrap ..fail!))] - (wrap (.if when - (_.if ..peek - then! - else!) - (_.if ..peek - else! - then!)))) - - (^template [<tag> <format>] - [(<tag> cons) - (do {! ///////phase.monad} - [clauses (monad.map ! (function (_ [match then]) - (\ ! map - (|>> [(_.= (|> match <format>) - ..peek)]) - (recur then))) - (#.Cons cons))] - (wrap (_.cond clauses - ..fail!)))]) - ([#/////synthesis.I64_Fork (<| //primitive.i64 .int)] - [#/////synthesis.F64_Fork (<| //primitive.f64)] - [#/////synthesis.Text_Fork (<| //primitive.text)]) - - (^template [<complex> <simple> <choice>] - [(^ (<complex> idx)) - (///////phase\wrap (<choice> false idx)) - - (^ (<simple> idx nextP)) - (|> nextP - recur - (///////phase\map (_.then (<choice> true idx))))]) - ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice] - [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice]) - - (^ (/////synthesis.member/left 0)) - (///////phase\wrap (|> ..peek (_.nth (_.int +0)) ..push!)) - - (^template [<pm> <getter>] - [(^ (<pm> lefts)) - (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))]) - ([/////synthesis.member/left //runtime.tuple//left] - [/////synthesis.member/right //runtime.tuple//right]) - - (^ (/////synthesis.!bind_top register thenP)) - (do ///////phase.monad - [then! (recur thenP)] - (///////phase\wrap ($_ _.then - (_.set (list (..register register)) ..peek_and_pop) - then!))) - - (^ (/////synthesis.!multi_pop nextP)) - (.let [[extra_pops nextP'] (case.count_pops nextP)] - (do ///////phase.monad - [next! (recur nextP')] - (///////phase\wrap ($_ _.then - (..multi_pop! (n.+ 2 extra_pops)) - next!)))) - - (^ (/////synthesis.path/seq preP postP)) - (do ///////phase.monad - [pre! (recur preP) - post! (recur postP)] - (wrap ($_ _.then - pre! - post!))) - - (^ (/////synthesis.path/alt preP postP)) - (do ///////phase.monad - [pre! (recur preP) - post! (recur postP) - g!once (..gensym "once") - g!continue? (..gensym "continue")] - (wrap (..alternation in_closure? g!once g!continue? pre! post!))) - ))) - -(def: (pattern_matching in_closure? statement expression archive pathP) - (-> Bit (Generator! Path)) - (do ///////phase.monad - [pattern_matching! (pattern_matching' in_closure? statement expression archive pathP) - g!once (..gensym "once") - g!continue? (..gensym "continue")] - (wrap ($_ _.then - (..with_looping in_closure? g!once g!continue? - pattern_matching!) - (_.statement (_.raise (_.string case.pattern_matching_error))))))) - -(def: #export (case! in_closure? statement expression archive [valueS pathP]) - (-> Bit (Generator! [Synthesis Path])) - (do ///////phase.monad - [stack_init (expression archive valueS) - pattern_matching! (pattern_matching in_closure? statement expression archive pathP)] - (wrap ($_ _.then - (_.set (list @cursor) (_.array (list stack_init))) - (_.set (list @savepoint) (_.array (list))) - pattern_matching! - )))) - -(def: #export (case statement expression archive case) - (-> Phase! (Generator [Synthesis Path])) - (|> case - (case! true statement expression archive) - (\ ///////phase.monad map - (|>> (_.lambda #.None (list)) - (_.apply_lambda/* (list)))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/function.lux deleted file mode 100644 index 535453f2e..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/function.lux +++ /dev/null @@ -1,111 +0,0 @@ -(.module: - [lux (#- function) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [target - ["_" ruby (#+ LVar GVar Expression Statement)]]] - ["." // #_ - [runtime (#+ Operation Phase Generator Phase! Generator!)] - ["#." reference] - ["#." case] - ["#." loop] - ["/#" // #_ - ["#." reference] - ["//#" /// #_ - [analysis (#+ Variant Tuple Environment Abstraction Application Analysis)] - [synthesis (#+ Synthesis)] - ["#." generation (#+ Context)] - ["//#" /// #_ - [arity (#+ Arity)] - ["#." phase] - [reference - [variable (#+ Register Variable)]] - [meta - [archive (#+ Archive) - ["." artifact]]]]]]]) - -(def: #export (apply expression archive [functionS argsS+]) - (Generator (Application Synthesis)) - (do {! ///////phase.monad} - [functionO (expression archive functionS) - argsO+ (monad.map ! (expression archive) argsS+)] - (wrap (_.apply_lambda/* argsO+ functionO)))) - -(def: #export capture - (-> Register LVar) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: (with_closure inits self function_definition) - (-> (List Expression) Text Expression [Statement Expression]) - (case inits - #.Nil - (let [@self (_.global self)] - [(_.set (list @self) function_definition) - @self]) - - _ - (let [@self (_.local self)] - [(_.function @self - (|> (list.enumeration inits) - (list\map (|>> product.left ..capture))) - ($_ _.then - (_.set (list @self) function_definition) - (_.return @self))) - (_.apply/* inits @self)]))) - -(def: input - (|>> inc //case.register)) - -(def: #export (function statement expression archive [environment arity bodyS]) - (-> Phase! (Generator (Abstraction Synthesis))) - (do {! ///////phase.monad} - [[[function_module function_artifact] body!] (/////generation.with_new_context archive - (/////generation.with_anchor 1 - (statement expression archive bodyS))) - closureO+ (monad.map ! (expression archive) environment) - #let [function_name (///reference.artifact [function_module function_artifact]) - @curried (_.local "curried") - arityO (|> arity .int _.int) - limitO (|> arity dec .int _.int) - @num_args (_.local "num_args") - @self (_.local function_name) - initialize_self! (_.set (list (//case.register 0)) @self) - initialize! (list\fold (.function (_ post pre!) - ($_ _.then - pre! - (_.set (list (..input post)) (_.nth (|> post .int _.int) @curried)))) - initialize_self! - (list.indices arity)) - [declaration instatiation] (with_closure closureO+ function_name - (_.lambda (#.Some @self) (list (_.variadic @curried)) - ($_ _.then - (_.set (list @num_args) (_.the "length" @curried)) - (_.cond (list [(|> @num_args (_.= arityO)) - (<| (_.then initialize!) - //loop.with_scope - body!)] - [(|> @num_args (_.> arityO)) - (let [slice (.function (_ from to) - (_.array_range from to @curried)) - arity_args (_.splat (slice (_.int +0) limitO)) - output_func_args (_.splat (slice arityO @num_args))] - (_.return (|> @self - (_.apply_lambda/* (list arity_args)) - (_.apply_lambda/* (list output_func_args)))))]) - ## (|> @num_args (_.< arityO)) - (let [@missing (_.local "missing")] - (_.return (_.lambda #.None (list (_.variadic @missing)) - (_.return (|> @self - (_.apply_lambda/* (list (_.splat (|> (_.array (list)) - (_.do "concat" (list @curried)) - (_.do "concat" (list @missing)))))))))))) - )))] - _ (/////generation.execute! declaration) - _ (/////generation.save! function_artifact declaration)] - (wrap instatiation))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/loop.lux deleted file mode 100644 index a2df0884a..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/loop.lux +++ /dev/null @@ -1,95 +0,0 @@ -(.module: - [lux (#- Scope) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set]]] - [math - [number - ["n" nat]]] - [target - ["_" ruby (#+ Expression LVar Statement)]]] - ["." // #_ - [runtime (#+ Operation Phase Generator Phase! Generator!)] - ["#." case] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - [synthesis - ["." case]] - ["/#" // #_ - ["." synthesis (#+ Scope Synthesis)] - ["#." generation] - ["//#" /// #_ - ["#." phase] - [reference - ["#." variable (#+ Register)]]]]]]]) - -(def: (setup offset bindings body) - (-> Register (List Expression) Statement Statement) - (|> bindings - list.enumeration - (list\map (function (_ [register value]) - (_.set (list (//case.register (n.+ offset register))) - value))) - list.reverse - (list\fold _.then body))) - -(def: symbol - (_.symbol "lux_continue")) - -(def: #export with_scope - (-> Statement Statement) - (_.while (_.bool true))) - -(def: #export (scope! statement expression archive [start initsS+ bodyS]) - (Generator! (Scope Synthesis)) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (statement expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [initsO+ (monad.map ! (expression archive) initsS+) - body! (/////generation.with_anchor start - (statement expression archive bodyS))] - (wrap (<| (..setup start initsO+) - ..with_scope - body!))))) - -(def: #export (scope statement expression archive [start initsS+ bodyS]) - (-> Phase! (Generator (Scope Synthesis))) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [body! (scope! statement expression archive [start initsS+ bodyS])] - (wrap (|> body! - (_.lambda #.None (list)) - (_.apply_lambda/* (list))))))) - -(def: #export (recur! statement expression archive argsS+) - (Generator! (List Synthesis)) - (do {! ///////phase.monad} - [offset /////generation.anchor - @temp (//case.gensym "lux_recur_values") - argsO+ (monad.map ! (expression archive) argsS+) - #let [re_binds (|> argsO+ - list.enumeration - (list\map (function (_ [idx _]) - (_.nth (_.int (.int idx)) @temp))))]] - (wrap ($_ _.then - (_.set (list @temp) (_.array argsO+)) - (..setup offset re_binds - _.next))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/primitive.lux deleted file mode 100644 index 59efdb9fb..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/primitive.lux +++ /dev/null @@ -1,15 +0,0 @@ -(.module: - [lux (#- i64) - [target - ["_" ruby (#+ Literal)]]]) - -(template [<type> <name> <implementation>] - [(def: #export <name> - (-> <type> Literal) - <implementation>)] - - [Bit bit _.bool] - [(I64 Any) i64 (|>> .int _.int)] - [Frac f64 _.float] - [Text text _.string] - ) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/reference.lux deleted file mode 100644 index 1ea2cca00..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/reference.lux +++ /dev/null @@ -1,12 +0,0 @@ -(.module: - [lux #* - [target - ["_" ruby (#+ Expression)]]] - [/// - [reference (#+ System)]]) - -(implementation: #export system - (System Expression) - - (def: constant _.global) - (def: variable _.local)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux deleted file mode 100644 index 2eb8ec79c..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux +++ /dev/null @@ -1,402 +0,0 @@ -(.module: - [lux (#- inc) - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<.>" code]]] - [data - ["." product] - ["." text ("#\." hash) - ["%" format (#+ format)] - [encoding - ["." utf8]]] - [collection - ["." list ("#\." functor)] - ["." row]]] - ["." macro - [syntax (#+ syntax:)] - ["." code]] - [math - [number (#+ hex) - ["." i64]]] - ["@" target - ["_" ruby (#+ Expression LVar Computation Literal Statement)]]] - ["." /// #_ - ["#." reference] - ["//#" /// #_ - ["$" version] - ["#." synthesis (#+ Synthesis)] - ["#." generation] - ["//#" /// - ["#." phase] - [reference - [variable (#+ Register)]] - [meta - [archive (#+ Output Archive) - ["." artifact (#+ Registry)]]]]]]) - -(template [<name> <base>] - [(type: #export <name> - (<base> Register Expression Statement))] - - [Operation /////generation.Operation] - [Phase /////generation.Phase] - [Handler /////generation.Handler] - [Bundle /////generation.Bundle] - ) - -(type: #export (Generator i) - (-> Phase Archive i (Operation Expression))) - -(type: #export Phase! - (-> Phase Archive Synthesis (Operation Statement))) - -(type: #export (Generator! i) - (-> Phase! Phase Archive i (Operation Statement))) - -(def: #export unit - (_.string /////synthesis.unit)) - -(def: (flag value) - (-> Bit Literal) - (if value - ..unit - _.nil)) - -(def: (feature name definition) - (-> LVar (-> LVar Statement) Statement) - (definition name)) - -(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} - body) - (do {! meta.monad} - [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] - (wrap (list (` (let [(~+ (|> vars - (list.zip/2 ids) - (list\map (function (_ [id var]) - (list (code.local_identifier var) - (` (_.local (~ (code.text (format "v" (%.nat id))))))))) - list.concat))] - (~ body))))))) - -(def: module_id - 0) - -(syntax: (runtime: {declaration (<>.or <code>.local_identifier - (<code>.form (<>.and <code>.local_identifier - (<>.some <code>.local_identifier))))} - code) - (do meta.monad - [runtime_id meta.count] - (macro.with_gensyms [g!_] - (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id])) - runtime_name (` (_.local (~ (code.text (%.code runtime)))))] - (case declaration - (#.Left name) - (macro.with_gensyms [g!_] - (let [g!name (code.local_identifier name)] - (wrap (list (` (def: #export (~ g!name) LVar (~ runtime_name))) - (` (def: (~ (code.local_identifier (format "@" name))) - Statement - (..feature (~ runtime_name) - (function ((~ g!_) (~ g!name)) - (_.set (list (~ g!name)) (~ code)))))))))) - - (#.Right [name inputs]) - (macro.with_gensyms [g!_] - (let [g!name (code.local_identifier name) - inputsC (list\map code.local_identifier inputs) - inputs_typesC (list\map (function.constant (` _.Expression)) - inputs)] - (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) - (-> (~+ inputs_typesC) Computation) - (_.apply/* (list (~+ inputsC)) (~ runtime_name)))) - - (` (def: (~ (code.local_identifier (format "@" name))) - Statement - (..feature (~ runtime_name) - (function ((~ g!_) (~ g!_)) - (..with_vars [(~+ inputsC)] - (_.function (~ g!_) (list (~+ inputsC)) - (~ code)))))))))))))))) - -(def: tuple_size - (_.the "length")) - -(def: last_index - (|>> ..tuple_size (_.- (_.int +1)))) - -(with_expansions [<recur> (as_is ($_ _.then - (_.set (list lefts) (_.- last_index_right lefts)) - (_.set (list tuple) (_.nth last_index_right tuple))))] - (runtime: (tuple//left lefts tuple) - (with_vars [last_index_right] - (<| (_.while (_.bool true)) - ($_ _.then - (_.set (list last_index_right) (..last_index tuple)) - (_.if (_.> lefts last_index_right) - ## No need for recursion - (_.return (_.nth lefts tuple)) - ## Needs recursion - <recur>))))) - - (runtime: (tuple//right lefts tuple) - (with_vars [last_index_right right_index] - (<| (_.while (_.bool true)) - ($_ _.then - (_.set (list last_index_right) (..last_index tuple)) - (_.set (list right_index) (_.+ (_.int +1) lefts)) - (_.cond (list [(_.= last_index_right right_index) - (_.return (_.nth right_index tuple))] - [(_.> last_index_right right_index) - ## Needs recursion. - <recur>]) - (_.return (_.array_range right_index (..tuple_size tuple) tuple))) - ))))) - -(def: #export variant_tag_field "_lux_tag") -(def: #export variant_flag_field "_lux_flag") -(def: #export variant_value_field "_lux_value") - -(runtime: (sum//make tag last? value) - (_.return (_.hash (list [(_.string ..variant_tag_field) tag] - [(_.string ..variant_flag_field) last?] - [(_.string ..variant_value_field) value])))) - -(def: #export (variant tag last? value) - (-> Nat Bit Expression Computation) - (sum//make (_.int (.int tag)) (..flag last?) value)) - -(def: #export none - Computation - (..variant 0 #0 ..unit)) - -(def: #export some - (-> Expression Computation) - (..variant 1 #1)) - -(def: #export left - (-> Expression Computation) - (..variant 0 #0)) - -(def: #export right - (-> Expression Computation) - (..variant 1 #1)) - -(runtime: (sum//get sum wantsLast wantedTag) - (let [no_match! (_.return _.nil) - sum_tag (_.nth (_.string ..variant_tag_field) sum) - sum_flag (_.nth (_.string ..variant_flag_field) sum) - sum_value (_.nth (_.string ..variant_value_field) sum) - is_last? (_.= ..unit sum_flag) - test_recursion! (_.if is_last? - ## Must recurse. - ($_ _.then - (_.set (list wantedTag) (_.- sum_tag wantedTag)) - (_.set (list sum) sum_value)) - no_match!)] - (<| (_.while (_.bool true)) - (_.cond (list [(_.= sum_tag wantedTag) - (_.if (_.= wantsLast sum_flag) - (_.return sum_value) - test_recursion!)] - - [(_.< wantedTag sum_tag) - test_recursion!] - - [(_.= ..unit wantsLast) - (_.return (sum//make (_.- wantedTag sum_tag) sum_flag sum_value))]) - - no_match!)))) - -(def: runtime//adt - Statement - ($_ _.then - @tuple//left - @tuple//right - @sum//make - @sum//get - )) - -(runtime: (lux//try risky) - (with_vars [error value] - (_.begin ($_ _.then - (_.set (list value) (_.apply_lambda/* (list ..unit) risky)) - (_.return (..right value))) - (list [(list) error - (_.return (..left (_.the "message" error)))])))) - -(runtime: (lux//program_args raw) - (with_vars [tail head] - ($_ _.then - (_.set (list tail) ..none) - (<| (_.for_in head raw) - (_.set (list tail) (..some (_.array (list head tail))))) - (_.return tail)))) - -(def: runtime//lux - Statement - ($_ _.then - @lux//try - @lux//program_args - )) - -(def: i64//+limit (_.manual "+0x7FFFFFFFFFFFFFFF")) -(def: i64//-limit (_.manual "-0x8000000000000000")) -(def: i64//+iteration (_.manual "+0x10000000000000000")) -(def: i64//-iteration (_.manual "-0x10000000000000000")) -(def: i64//+cap (_.manual "+0x8000000000000000")) -(def: i64//-cap (_.manual "-0x8000000000000001")) - -(runtime: (i64//64 input) - (with_vars [temp] - (`` (<| (~~ (template [<scenario> <iteration> <cap> <entrance>] - [(_.if (|> input <scenario>) - ($_ _.then - (_.set (list temp) (_.% <iteration> input)) - (_.return (_.? (|> temp <scenario>) - (|> temp (_.- <cap>) (_.+ <entrance>)) - temp))))] - - [(_.> ..i64//+limit) ..i64//+iteration ..i64//+cap ..i64//-limit] - [(_.< ..i64//-limit) ..i64//-iteration ..i64//-cap ..i64//+limit] - )) - (_.return input))))) - -(runtime: i64//nat_top - (|> (_.int +1) - (_.bit_shl (_.int +64)) - (_.- (_.int +1)))) - -(def: as_nat - (_.% (_.manual "0x10000000000000000"))) - -(runtime: (i64//left_shift param subject) - (_.return (|> subject - (_.bit_shl (_.% (_.int +64) param)) - ..i64//64))) - -(runtime: (i64//right_shift param subject) - ($_ _.then - (_.set (list param) (_.% (_.int +64) param)) - (_.return (_.? (_.= (_.int +0) param) - subject - (|> subject - ..as_nat - (_.bit_shr param)))))) - -(template [<runtime> <host>] - [(runtime: (<runtime> left right) - (_.return (..i64//64 (<host> (..as_nat left) (..as_nat right)))))] - - [i64//and _.bit_and] - [i64//or _.bit_or] - [i64//xor _.bit_xor] - ) - -(runtime: (i64//division parameter subject) - (let [extra (_.do "remainder" (list parameter) subject)] - (_.return (|> subject - (_.- extra) - (_./ parameter))))) - -(def: runtime//i64 - Statement - ($_ _.then - @i64//64 - @i64//nat_top - @i64//left_shift - @i64//right_shift - @i64//and - @i64//or - @i64//xor - @i64//division - )) - -(runtime: (f64//decode inputG) - (with_vars [@input @temp] - ($_ _.then - (_.set (list @input) inputG) - (_.set (list @temp) (_.do "to_f" (list) @input)) - (_.if ($_ _.or - (_.not (_.= (_.float +0.0) @temp)) - (_.= (_.string "0") @input) - (_.= (_.string ".0") @input) - (_.= (_.string "0.0") @input)) - (_.return (..some @temp)) - (_.return ..none))))) - -(def: runtime//f64 - Statement - ($_ _.then - @f64//decode - )) - -(runtime: (text//index subject param start) - (with_vars [idx] - ($_ _.then - (_.set (list idx) (|> subject (_.do "index" (list param start)))) - (_.if (_.= _.nil idx) - (_.return ..none) - (_.return (..some idx)))))) - -(def: (within? top value) - (-> Expression Expression Computation) - (_.and (|> value (_.>= (_.int +0))) - (|> value (_.< top)))) - -(runtime: (text//clip offset length text) - (_.if (_.= (_.int +0) length) - (_.return (_.string "")) - (_.return (_.array_range offset (_.+ offset (_.- (_.int +1) length)) text)))) - -(runtime: (text//char idx text) - (_.if (|> idx (within? (_.the "length" text))) - (_.return (|> text (_.array_range idx idx) (_.do "ord" (list)))) - (_.statement (_.raise (_.string "[Lux Error] Cannot get char from text."))))) - -(def: runtime//text - Statement - ($_ _.then - @text//index - @text//clip - @text//char - )) - -(runtime: (array//write idx value array) - ($_ _.then - (_.set (list (_.nth idx array)) value) - (_.return array))) - -(def: runtime//array - Statement - ($_ _.then - @array//write - )) - -(def: runtime - Statement - ($_ _.then - runtime//adt - runtime//lux - runtime//i64 - runtime//f64 - runtime//text - runtime//array - )) - -(def: #export generate - (Operation [Registry Output]) - (do ///////phase.monad - [_ (/////generation.execute! ..runtime) - _ (/////generation.save! ..module_id ..runtime)] - (wrap [(|> artifact.empty - artifact.resource - product.right) - (row.row [..module_id - (|> ..runtime - _.code - (\ utf8.codec encode))])]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/structure.lux deleted file mode 100644 index e8d192326..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/structure.lux +++ /dev/null @@ -1,36 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [target - ["_" ruby (#+ Expression)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." primitive] - ["///#" //// #_ - [analysis (#+ Variant Tuple)] - ["#." synthesis (#+ Synthesis)] - ["//#" /// #_ - ["#." phase ("#\." monad)]]]]) - -(def: #export (tuple generate archive elemsS+) - (Generator (Tuple Synthesis)) - (case elemsS+ - #.Nil - (///////phase\wrap (//primitive.text /////synthesis.unit)) - - (#.Cons singletonS #.Nil) - (generate archive singletonS) - - _ - (|> elemsS+ - (monad.map ///////phase.monad (generate archive)) - (///////phase\map _.array)))) - -(def: #export (variant generate archive [lefts right? valueS]) - (Generator (Variant Synthesis)) - (let [tag (if right? - (inc lefts) - lefts)] - (///////phase\map (//runtime.variant tag right?) - (generate archive valueS)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux deleted file mode 100644 index 1a36df4e0..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux +++ /dev/null @@ -1,58 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [target - ["_" scheme]]] - ["." / #_ - [runtime (#+ Phase)] - ["#." primitive] - ["#." structure] - ["#." reference] - ["#." case] - ["#." loop] - ["#." function] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." extension] - ["/#" // #_ - [analysis (#+)] - ["#." synthesis] - ["//#" /// #_ - ["#." phase ("#\." monad)] - [reference (#+) - [variable (#+)]]]]]]]) - -(def: #export (generate archive synthesis) - Phase - (case synthesis - (^template [<tag> <generator>] - [(^ (<tag> value)) - (//////phase\wrap (<generator> value))]) - ([////synthesis.bit /primitive.bit] - [////synthesis.i64 /primitive.i64] - [////synthesis.f64 /primitive.f64] - [////synthesis.text /primitive.text]) - - (#////synthesis.Reference value) - (//reference.reference /reference.system archive value) - - (^template [<tag> <generator>] - [(^ (<tag> value)) - (<generator> generate archive value)]) - ([////synthesis.variant /structure.variant] - [////synthesis.tuple /structure.tuple] - [////synthesis.branch/let /case.let] - [////synthesis.branch/if /case.if] - [////synthesis.branch/get /case.get] - [////synthesis.function/apply /function.apply] - - [////synthesis.branch/case /case.case] - [////synthesis.loop/scope /loop.scope] - [////synthesis.loop/recur /loop.recur] - [////synthesis.function/abstraction /function.function]) - - (#////synthesis.Extension extension) - (///extension.apply archive generate extension) - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux deleted file mode 100644 index 884e20c0f..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux +++ /dev/null @@ -1,222 +0,0 @@ -(.module: - [lux (#- case let if) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set]]] - [macro - ["." template]] - [math - [number - ["i" int]]] - [target - ["_" scheme (#+ Expression Computation Var)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." reference] - ["#." primitive] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." synthesis #_ - ["#/." case]] - ["/#" // #_ - ["#." synthesis (#+ Member Synthesis Path)] - ["#." generation] - ["//#" /// #_ - [reference - ["#." variable (#+ Register)]] - ["#." phase ("#\." monad)] - [meta - [archive (#+ Archive)]]]]]]]) - -(def: #export register - (-> Register Var) - (|>> (///reference.local //reference.system) :assume)) - -(def: #export capture - (-> Register Var) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: #export (let expression archive [valueS register bodyS]) - (Generator [Synthesis Register Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS) - bodyO (expression archive bodyS)] - (wrap (_.let (list [(..register register) valueO]) - bodyO)))) - -(def: #export (if expression archive [testS thenS elseS]) - (Generator [Synthesis Synthesis Synthesis]) - (do ///////phase.monad - [testO (expression archive testS) - thenO (expression archive thenS) - elseO (expression archive elseS)] - (wrap (_.if testO thenO elseO)))) - -(def: #export (get expression archive [pathP valueS]) - (Generator [(List Member) Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS)] - (wrap (list\fold (function (_ side source) - (.let [method (.case side - (^template [<side> <accessor>] - [(<side> lefts) - (<accessor> (_.int (.int lefts)))]) - ([#.Left //runtime.tuple//left] - [#.Right //runtime.tuple//right]))] - (method source))) - valueO - (list.reverse pathP))))) - -(def: @savepoint (_.var "lux_pm_cursor_savepoint")) -(def: @cursor (_.var "lux_pm_cursor")) -(def: @temp (_.var "lux_pm_temp")) -(def: @alt_error (_.var "alt_error")) - -(def: (push! value var) - (-> Expression Var Computation) - (_.set! var (_.cons/2 value var))) - -(def: (push_cursor! value) - (-> Expression Computation) - (push! value @cursor)) - -(def: (pop! var) - (-> Var Computation) - (_.set! var (_.cdr/1 var))) - -(def: save_cursor! - Computation - (push! @cursor @savepoint)) - -(def: restore_cursor! - Computation - (_.begin (list (_.set! @cursor (_.car/1 @savepoint)) - (_.set! @savepoint (_.cdr/1 @savepoint))))) - -(def: peek - Computation - (_.car/1 @cursor)) - -(def: pop_cursor! - Computation - (pop! @cursor)) - -(def: pm_error - (_.string (template.with_locals [pm_error] - (template.text [pm_error])))) - -(def: fail! - (_.raise/1 pm_error)) - -(def: (try_pm on_failure happy_path) - (-> Expression Expression Computation) - (_.guard @alt_error - (list [(_.and (list (_.string?/1 @alt_error) - (_.string=?/2 ..pm_error @alt_error))) - on_failure]) - #.None - happy_path)) - -(def: (pattern_matching' expression archive) - (Generator Path) - (function (recur pathP) - (.case pathP - (#/////synthesis.Then bodyS) - (expression archive bodyS) - - #/////synthesis.Pop - (///////phase\wrap pop_cursor!) - - (#/////synthesis.Bind register) - (///////phase\wrap (_.define_constant (..register register) ..peek)) - - (#/////synthesis.Bit_Fork when thenP elseP) - (do {! ///////phase.monad} - [then! (recur thenP) - else! (.case elseP - (#.Some elseP) - (recur elseP) - - #.None - (wrap ..fail!))] - (wrap (.if when - (_.if ..peek - then! - else!) - (_.if ..peek - else! - then!)))) - - (^template [<tag> <format> <=>] - [(<tag> cons) - (do {! ///////phase.monad} - [clauses (monad.map ! (function (_ [match then]) - (do ! - [then! (recur then)] - (wrap [(<=> (|> match <format>) - ..peek) - then!]))) - (#.Cons cons))] - (wrap (list\fold (function (_ [when then] else) - (_.if when then else)) - ..fail! - clauses)))]) - ([#/////synthesis.I64_Fork //primitive.i64 _.=/2] - [#/////synthesis.F64_Fork //primitive.f64 _.=/2] - [#/////synthesis.Text_Fork //primitive.text _.string=?/2]) - - (^template [<pm> <flag> <prep>] - [(^ (<pm> idx)) - (///////phase\wrap (_.let (list [@temp (|> idx <prep> .int _.int (//runtime.sum//get ..peek (_.bool <flag>)))]) - (_.if (_.null?/1 @temp) - ..fail! - (push_cursor! @temp))))]) - ([/////synthesis.side/left false (<|)] - [/////synthesis.side/right true inc]) - - (^ (/////synthesis.member/left 0)) - (///////phase\wrap (..push_cursor! (_.vector-ref/2 ..peek (_.int +0)))) - - (^template [<pm> <getter>] - [(^ (<pm> lefts)) - (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push_cursor!))]) - ([/////synthesis.member/left //runtime.tuple//left] - [/////synthesis.member/right //runtime.tuple//right]) - - (^ (/////synthesis.path/seq leftP rightP)) - (do ///////phase.monad - [leftO (recur leftP) - rightO (recur rightP)] - (wrap (_.begin (list leftO - rightO)))) - - (^ (/////synthesis.path/alt leftP rightP)) - (do {! ///////phase.monad} - [leftO (recur leftP) - rightO (recur rightP)] - (wrap (try_pm (_.begin (list restore_cursor! - rightO)) - (_.begin (list save_cursor! - leftO))))) - ))) - -(def: (pattern_matching expression archive pathP) - (Generator Path) - (\ ///////phase.monad map - (try_pm (_.raise/1 (_.string "Invalid expression for pattern-matching."))) - (pattern_matching' expression archive pathP))) - -(def: #export (case expression archive [valueS pathP]) - (Generator [Synthesis Path]) - (do {! ///////phase.monad} - [valueO (expression archive valueS)] - (<| (\ ! map (_.let (list [@cursor (_.list/* (list valueO))] - [@savepoint (_.list/* (list))]))) - (pattern_matching expression archive pathP)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/extension.lux deleted file mode 100644 index 3bc0a0887..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/extension.lux +++ /dev/null @@ -1,13 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - [// - [runtime (#+ Bundle)]] - [/ - ["." common]]) - -(def: #export bundle - Bundle - common.bundle) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/extension/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/extension/common.lux deleted file mode 100644 index f7f55e260..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/extension/common.lux +++ /dev/null @@ -1,222 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["ex" exception (#+ exception:)] - [parser - ["s" code]]] - [data - ["." product] - ["." text] - [number (#+ hex) - ["f" frac]] - [collection - ["." list ("#\." functor)] - ["dict" dictionary (#+ Dictionary)]]] - ["." macro (#+ with-gensyms) - ["." code] - [syntax (#+ syntax:)]] - [target - ["_" scheme (#+ Expression Computation)]]] - ["." /// #_ - ["#." runtime (#+ Operation Phase Handler Bundle)] - ["#//" /// - ["#." extension - ["." bundle]] - ["#/" // #_ - ["#." synthesis (#+ Synthesis)]]]]) - -(syntax: (Vector {size s.nat} elemT) - (wrap (list (` [(~+ (list.repeat size elemT))])))) - -(type: #export Nullary (-> (Vector 0 Expression) Computation)) -(type: #export Unary (-> (Vector 1 Expression) Computation)) -(type: #export Binary (-> (Vector 2 Expression) Computation)) -(type: #export Trinary (-> (Vector 3 Expression) Computation)) -(type: #export Variadic (-> (List Expression) Computation)) - -(syntax: (arity: {name s.local-identifier} {arity s.nat}) - (with-gensyms [g!_ g!extension g!name g!phase g!inputs] - (do {! macro.monad} - [g!input+ (monad.seq ! (list.repeat arity (macro.gensym "input")))] - (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension)) - (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation) - Handler) - (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!inputs)) - (case (~ g!inputs) - (^ (list (~+ g!input+))) - (do /////.monad - [(~+ (|> g!input+ - (list\map (function (_ g!input) - (list g!input (` ((~ g!phase) (~ g!input)))))) - list.concat))] - ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) - - (~' _) - (/////.throw /////extension.incorrect-arity [(~ g!name) 1 (list.size (~ g!inputs))])))))))))) - -(arity: nullary 0) -(arity: unary 1) -(arity: binary 2) -(arity: trinary 3) - -(def: #export (variadic extension) - (-> Variadic Handler) - (function (_ extension-name) - (function (_ phase inputsS) - (do {! /////.monad} - [inputsI (monad.map ! phase inputsS)] - (wrap (extension inputsI)))))) - -(def: bundle::lux - Bundle - (|> bundle.empty - (bundle.install "is?" (binary (product.uncurry _.eq?/2))) - (bundle.install "try" (unary ///runtime.lux//try)))) - -(template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (<op> paramO subjectO))] - - [i64::and _.bit-and/2] - [i64::or _.bit-or/2] - [i64::xor _.bit-xor/2] - ) - -(def: (i64::left-shift [subjectO paramO]) - Binary - (_.arithmetic-shift/2 (_.remainder/2 (_.int +64) paramO) - subjectO)) - -(def: (i64::arithmetic-right-shift [subjectO paramO]) - Binary - (_.arithmetic-shift/2 (|> paramO (_.remainder/2 (_.int +64)) (_.*/2 (_.int -1))) - subjectO)) - -(def: (i64::logical-right-shift [subjectO paramO]) - Binary - (///runtime.i64//logical-right-shift (_.remainder/2 (_.int +64) paramO) subjectO)) - -(template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (|> subjectO (<op> paramO)))] - - [i64::+ _.+/2] - [i64::- _.-/2] - [i64::* _.*/2] - [i64::/ _.quotient/2] - [i64::% _.remainder/2] - ) - -(template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (<op> paramO subjectO))] - - [f64::+ _.+/2] - [f64::- _.-/2] - [f64::* _.*/2] - [f64::/ _.//2] - [f64::% _.mod/2] - [f64::= _.=/2] - [f64::< _.</2] - - [text::= _.string=?/2] - [text::< _.string<?/2] - ) - -(template [<name> <cmp>] - [(def: (<name> [subjectO paramO]) - Binary - (<cmp> paramO subjectO))] - - [i64::= _.=/2] - [i64::< _.</2] - ) - -(def: i64::char (|>> _.integer->char/1 _.string/1)) - -(def: bundle::i64 - Bundle - (<| (bundle.prefix "i64") - (|> bundle.empty - (bundle.install "and" (binary i64::and)) - (bundle.install "or" (binary i64::or)) - (bundle.install "xor" (binary i64::xor)) - (bundle.install "left-shift" (binary i64::left-shift)) - (bundle.install "logical-right-shift" (binary i64::logical-right-shift)) - (bundle.install "arithmetic-right-shift" (binary i64::arithmetic-right-shift)) - (bundle.install "+" (binary i64::+)) - (bundle.install "-" (binary i64::-)) - (bundle.install "*" (binary i64::*)) - (bundle.install "/" (binary i64::/)) - (bundle.install "%" (binary i64::%)) - (bundle.install "=" (binary i64::=)) - (bundle.install "<" (binary i64::<)) - (bundle.install "f64" (unary (|>> (_.//2 (_.float +1.0))))) - (bundle.install "char" (unary i64::char))))) - -(def: bundle::f64 - Bundle - (<| (bundle.prefix "f64") - (|> bundle.empty - (bundle.install "+" (binary f64::+)) - (bundle.install "-" (binary f64::-)) - (bundle.install "*" (binary f64::*)) - (bundle.install "/" (binary f64::/)) - (bundle.install "%" (binary f64::%)) - (bundle.install "=" (binary f64::=)) - (bundle.install "<" (binary f64::<)) - (bundle.install "i64" (unary _.exact/1)) - (bundle.install "encode" (unary _.number->string/1)) - (bundle.install "decode" (unary ///runtime.frac//decode))))) - -(def: (text::char [subjectO paramO]) - Binary - (_.string/1 (_.string-ref/2 subjectO paramO))) - -(def: (text::clip [subjectO startO endO]) - Trinary - (_.substring/3 subjectO startO endO)) - -(def: bundle::text - Bundle - (<| (bundle.prefix "text") - (|> bundle.empty - (bundle.install "=" (binary text::=)) - (bundle.install "<" (binary text::<)) - (bundle.install "concat" (binary (product.uncurry _.string-append/2))) - (bundle.install "size" (unary _.string-length/1)) - (bundle.install "char" (binary text::char)) - (bundle.install "clip" (trinary text::clip))))) - -(def: (io::log input) - Unary - (_.begin (list (_.display/1 input) - _.newline/0))) - -(def: (void code) - (-> Expression Computation) - (_.begin (list code (_.string //////synthesis.unit)))) - -(def: bundle::io - Bundle - (<| (bundle.prefix "io") - (|> bundle.empty - (bundle.install "log" (unary (|>> io::log ..void))) - (bundle.install "error" (unary _.raise/1)) - (bundle.install "exit" (unary _.exit/1)) - (bundle.install "current-time" (nullary (function (_ _) (///runtime.io//current-time (_.string //////synthesis.unit)))))))) - -(def: #export bundle - Bundle - (<| (bundle.prefix "lux") - (|> bundle::lux - (dict.merge bundle::i64) - (dict.merge bundle::f64) - (dict.merge bundle::text) - (dict.merge bundle::io) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux deleted file mode 100644 index 65c674ded..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux +++ /dev/null @@ -1,100 +0,0 @@ -(.module: - [lux (#- function) - [abstract - ["." monad (#+ do)]] - [control - pipe] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [target - ["_" scheme (#+ Expression Computation Var)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." reference] - ["#." case] - ["/#" // #_ - ["#." reference] - ["//#" /// #_ - [analysis (#+ Variant Tuple Abstraction Application Analysis)] - [synthesis (#+ Synthesis)] - ["#." generation (#+ Context)] - ["//#" /// #_ - [arity (#+ Arity)] - ["#." phase ("#\." monad)] - [reference - [variable (#+ Register Variable)]]]]]]) - -(def: #export (apply expression archive [functionS argsS+]) - (Generator (Application Synthesis)) - (do {! ///////phase.monad} - [functionO (expression archive functionS) - argsO+ (monad.map ! (expression archive) argsS+)] - (wrap (_.apply/* argsO+ functionO)))) - -(def: capture - (-> Register Var) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: (with_closure inits function_definition) - (-> (List Expression) Computation (Operation Computation)) - (///////phase\wrap - (case inits - #.Nil - function_definition - - _ - (|> function_definition - (_.lambda [(|> (list.enumeration inits) - (list\map (|>> product.left ..capture))) - #.None]) - (_.apply/* inits))))) - -(def: @curried (_.var "curried")) -(def: @missing (_.var "missing")) - -(def: input - (|>> inc //case.register)) - -(def: #export (function expression archive [environment arity bodyS]) - (Generator (Abstraction Synthesis)) - (do {! ///////phase.monad} - [[function_name bodyO] (/////generation.with_new_context archive - (do ! - [@self (\ ! map (|>> ///reference.artifact _.var) - (/////generation.context archive))] - (/////generation.with_anchor @self - (expression archive bodyS)))) - closureO+ (monad.map ! (expression archive) environment) - #let [arityO (|> arity .int _.int) - apply_poly (.function (_ args func) - (_.apply/2 (_.var "apply") func args)) - @num_args (_.var "num_args") - @self (_.var (///reference.artifact function_name))]] - (with_closure closureO+ - (_.letrec (list [@self (_.lambda [(list) (#.Some @curried)] - (_.let (list [@num_args (_.length/1 @curried)]) - (<| (_.if (|> @num_args (_.=/2 arityO)) - (<| (_.let (list [(//case.register 0) @self])) - (_.let_values (list [[(|> (list.indices arity) - (list\map ..input)) - #.None] - (_.apply/2 (_.var "apply") (_.var "values") @curried)])) - bodyO)) - (_.if (|> @num_args (_.>/2 arityO)) - (let [arity_args (//runtime.slice (_.int +0) arityO @curried) - output_func_args (//runtime.slice arityO - (|> @num_args (_.-/2 arityO)) - @curried)] - (_.begin (list (|> @self - (apply_poly arity_args) - (apply_poly output_func_args)))))) - ## (|> @num_args (_.</2 arityO)) - (_.lambda [(list) (#.Some @missing)] - (|> @self - (apply_poly (_.append/2 @curried @missing))))) - ))]) - @self)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux deleted file mode 100644 index d4b964910..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux +++ /dev/null @@ -1,63 +0,0 @@ -(.module: - [lux (#- Scope) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set (#+ Set)]]] - [math - [number - ["n" nat]]] - [target - ["_" scheme]]] - ["." // #_ - [runtime (#+ Operation Phase Generator)] - ["#." case] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - [synthesis - ["." case]] - ["/#" // #_ - ["."synthesis (#+ Scope Synthesis)] - ["#." generation] - ["//#" /// #_ - ["#." phase] - [meta - [archive (#+ Archive)]] - [reference - [variable (#+ Register)]]]]]]]) - -(def: @scope - (_.var "scope")) - -(def: #export (scope expression archive [start initsS+ bodyS]) - (Generator (Scope Synthesis)) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [initsO+ (monad.map ! (expression archive) initsS+) - bodyO (/////generation.with_anchor @scope - (expression archive bodyS))] - (wrap (_.letrec (list [@scope (_.lambda [(|> initsS+ - list.enumeration - (list\map (|>> product.left (n.+ start) //case.register))) - #.None] - bodyO)]) - (_.apply/* initsO+ @scope)))))) - -(def: #export (recur expression archive argsS+) - (Generator (List Synthesis)) - (do {! ///////phase.monad} - [@scope /////generation.anchor - argsO+ (monad.map ! (expression archive) argsS+)] - (wrap (_.apply/* argsO+ @scope)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/primitive.lux deleted file mode 100644 index 4bfa67161..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/primitive.lux +++ /dev/null @@ -1,15 +0,0 @@ -(.module: - [lux (#- i64) - [target - ["_" scheme (#+ Expression)]]]) - -(template [<name> <type> <code>] - [(def: #export <name> - (-> <type> Expression) - <code>)] - - [bit Bit _.bool] - [i64 (I64 Any) (|>> .int _.int)] - [f64 Frac _.float] - [text Text _.string] - ) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux deleted file mode 100644 index f24134d9f..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux +++ /dev/null @@ -1,12 +0,0 @@ -(.module: - [lux #* - [target - ["_" scheme (#+ Expression)]]] - [/// - [reference (#+ System)]]) - -(implementation: #export system - (System Expression) - - (def: constant _.var) - (def: variable _.var)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux deleted file mode 100644 index 7f55df9a9..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux +++ /dev/null @@ -1,369 +0,0 @@ -(.module: - [lux (#- Location inc) - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<.>" code]]] - [data - ["." product] - ["." text ("#\." hash) - ["%" format (#+ format)] - [encoding - ["." utf8]]] - [collection - ["." list ("#\." functor)] - ["." row]]] - ["." macro - [syntax (#+ syntax:)] - ["." code]] - [math - [number (#+ hex) - ["." i64]]] - ["@" target - ["_" scheme (#+ Expression Computation Var)]]] - ["." /// #_ - ["#." reference] - ["//#" /// #_ - [analysis (#+ Variant)] - ["#." synthesis (#+ Synthesis)] - ["#." generation] - ["//#" /// - ["#." phase] - [reference - [variable (#+ Register)]] - [meta - [archive (#+ Output Archive) - ["." artifact (#+ Registry)]]]]]]) - -(def: module_id - 0) - -(template [<name> <base>] - [(type: #export <name> - (<base> Var Expression Expression))] - - [Operation /////generation.Operation] - [Phase /////generation.Phase] - [Handler /////generation.Handler] - [Bundle /////generation.Bundle] - ) - -(type: #export (Generator i) - (-> Phase Archive i (Operation Expression))) - -(def: #export unit - (_.string /////synthesis.unit)) - -(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} - body) - (do {! meta.monad} - [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] - (wrap (list (` (let [(~+ (|> vars - (list.zip/2 ids) - (list\map (function (_ [id var]) - (list (code.local_identifier var) - (` (_.var (~ (code.text (format "v" (%.nat id))))))))) - list.concat))] - (~ body))))))) - -(syntax: (runtime: {declaration (<>.or <code>.local_identifier - (<code>.form (<>.and <code>.local_identifier - (<>.some <code>.local_identifier))))} - code) - (do meta.monad - [runtime_id meta.count] - (macro.with_gensyms [g!_] - (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id])) - runtime_name (` (_.var (~ (code.text (%.code runtime)))))] - (case declaration - (#.Left name) - (let [g!name (code.local_identifier name)] - (wrap (list (` (def: #export (~ g!name) - Var - (~ runtime_name))) - - (` (def: (~ (code.local_identifier (format "@" name))) - _.Computation - (_.define_constant (~ runtime_name) (~ code))))))) - - (#.Right [name inputs]) - (let [g!name (code.local_identifier name) - inputsC (list\map code.local_identifier inputs) - inputs_typesC (list\map (function.constant (` _.Expression)) - inputs)] - (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) - (-> (~+ inputs_typesC) _.Computation) - (_.apply/* (list (~+ inputsC)) (~ runtime_name)))) - - (` (def: (~ (code.local_identifier (format "@" name))) - _.Computation - (..with_vars [(~+ inputsC)] - (_.define_function (~ runtime_name) [(list (~+ inputsC)) #.None] - (~ code))))))))))))) - -(def: last_index - (-> Expression Computation) - (|>> _.length/1 (_.-/2 (_.int +1)))) - -(runtime: (tuple//left lefts tuple) - (with_vars [last_index_right] - (_.begin - (list (_.define_constant last_index_right (..last_index tuple)) - (_.if (_.>/2 lefts last_index_right) - ## No need for recursion - (_.vector-ref/2 tuple lefts) - ## Needs recursion - (tuple//left (_.-/2 last_index_right lefts) - (_.vector-ref/2 tuple last_index_right))))))) - -(runtime: (tuple//right lefts tuple) - (with_vars [last_index_right right_index @slice] - (_.begin - (list (_.define_constant last_index_right (..last_index tuple)) - (_.define_constant right_index (_.+/2 (_.int +1) lefts)) - (<| (_.if (_.=/2 last_index_right right_index) - (_.vector-ref/2 tuple right_index)) - (_.if (_.>/2 last_index_right right_index) - ## Needs recursion. - (tuple//right (_.-/2 last_index_right lefts) - (_.vector-ref/2 tuple last_index_right))) - (_.begin - (list (_.define_constant @slice (_.make-vector/1 (_.-/2 right_index (_.length/1 tuple)))) - (_.vector-copy!/5 @slice (_.int +0) tuple right_index (_.length/1 tuple)) - @slice)))) - ))) - -(def: (variant' tag last? value) - (-> Expression Expression Expression Computation) - ($_ _.cons/2 - tag - last? - value)) - -(runtime: (sum//make tag last? value) - (variant' tag last? value)) - -(def: #export (variant [lefts right? value]) - (-> (Variant Expression) Computation) - (..sum//make (_.int (.int lefts)) (_.bool right?) value)) - -(runtime: (sum//get sum last? wanted_tag) - (with_vars [sum_tag sum_flag sum_value sum_temp sum_dump] - (let [no_match _.nil - test_recursion (_.if sum_flag - ## Must recurse. - (sum//get sum_value - last? - (|> wanted_tag (_.-/2 sum_tag))) - no_match)] - (<| (_.let (list [sum_tag (_.car/1 sum)] - [sum_temp (_.cdr/1 sum)])) - (_.let (list [sum_flag (_.car/1 sum_temp)] - [sum_value (_.cdr/1 sum_temp)])) - (_.if (_.=/2 wanted_tag sum_tag) - (_.if (_.eqv?/2 last? sum_flag) - sum_value - test_recursion)) - (_.if (_.</2 wanted_tag sum_tag) - test_recursion) - (_.if last? - (variant' (|> sum_tag (_.-/2 wanted_tag)) sum_flag sum_value)) - no_match)))) - -(def: runtime//adt - Computation - (_.begin (list @tuple//left - @tuple//right - @sum//get - @sum//make))) - -(def: #export none - Computation - (|> ..unit [0 #0] variant)) - -(def: #export some - (-> Expression Computation) - (|>> [1 #1] ..variant)) - -(def: #export left - (-> Expression Computation) - (|>> [0 #0] ..variant)) - -(def: #export right - (-> Expression Computation) - (|>> [1 #1] ..variant)) - -(runtime: (slice offset length list) - (<| (_.if (_.null?/1 list) - list) - (_.if (|> offset (_.>/2 (_.int +0))) - (slice (|> offset (_.-/2 (_.int +1))) - length - (_.cdr/1 list))) - (_.if (|> length (_.>/2 (_.int +0))) - (_.cons/2 (_.car/1 list) - (slice offset - (|> length (_.-/2 (_.int +1))) - (_.cdr/1 list)))) - _.nil)) - -(runtime: (lux//try op) - (with_vars [error] - (_.with_exception_handler - (_.lambda [(list error) #.None] - (..left error)) - (_.lambda [(list) #.None] - (..right (_.apply/* (list ..unit) op)))))) - -(runtime: (lux//program_args program_args) - (with_vars [@loop @input @output] - (_.letrec (list [@loop (_.lambda [(list @input @output) #.None] - (_.if (_.null?/1 @input) - @output - (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))]) - (_.apply/2 @loop (_.reverse/1 program_args) ..none)))) - -(def: runtime//lux - Computation - (_.begin (list @lux//try - @lux//program_args))) - -(def: i64//+limit (_.manual "+9223372036854775807" - ## "+0x7FFFFFFFFFFFFFFF" - )) -(def: i64//-limit (_.manual "-9223372036854775808" - ## "-0x8000000000000000" - )) -(def: i64//+iteration (_.manual "+18446744073709551616" - ## "+0x10000000000000000" - )) -(def: i64//-iteration (_.manual "-18446744073709551616" - ## "-0x10000000000000000" - )) -(def: i64//+cap (_.manual "+9223372036854775808" - ## "+0x8000000000000000" - )) -(def: i64//-cap (_.manual "-9223372036854775809" - ## "-0x8000000000000001" - )) - -(runtime: (i64//64 input) - (with_vars [temp] - (`` (<| (~~ (template [<scenario> <iteration> <cap> <entrance>] - [(_.if (|> input <scenario>) - (_.let (list [temp (_.remainder/2 <iteration> input)]) - (_.if (|> temp <scenario>) - (|> temp (_.-/2 <cap>) (_.+/2 <entrance>)) - temp)))] - - [(_.>/2 ..i64//+limit) ..i64//+iteration ..i64//+cap ..i64//-limit] - [(_.</2 ..i64//-limit) ..i64//-iteration ..i64//-cap ..i64//+limit] - )) - input)))) - -(runtime: (i64//left_shift param subject) - (|> subject - (_.arithmetic-shift/2 (_.remainder/2 (_.int +64) param)) - ..i64//64)) - -(def: as_nat - (_.remainder/2 ..i64//+iteration)) - -(runtime: (i64//right_shift shift subject) - (_.let (list [shift (_.remainder/2 (_.int +64) shift)]) - (_.if (_.=/2 (_.int +0) shift) - subject - (|> subject - ..as_nat - (_.arithmetic-shift/2 (_.-/2 shift (_.int +0))))))) - -(template [<runtime> <host>] - [(runtime: (<runtime> left right) - (..i64//64 (<host> (..as_nat left) (..as_nat right))))] - - [i64//or _.bitwise-ior/2] - [i64//xor _.bitwise-xor/2] - [i64//and _.bitwise-and/2] - ) - -(runtime: (i64//division param subject) - (|> subject (_.//2 param) _.truncate/1 ..i64//64)) - -(def: runtime//i64 - Computation - (_.begin (list @i64//64 - @i64//left_shift - @i64//right_shift - @i64//or - @i64//xor - @i64//and - @i64//division))) - -(runtime: (f64//decode input) - (with_vars [@output] - (let [output_is_not_a_number? (_.not/1 (_.=/2 @output @output)) - input_is_not_a_number? (_.string=?/2 (_.string "+nan.0") input)] - (_.let (list [@output (_.string->number/1 input)]) - (_.if (_.and (list output_is_not_a_number? - (_.not/1 input_is_not_a_number?))) - ..none - (..some @output)))))) - -(def: runtime//f64 - Computation - (_.begin (list @f64//decode))) - -(runtime: (text//index offset sub text) - (with_vars [index] - (_.let (list [index (_.string-contains/3 text sub offset)]) - (_.if index - (..some index) - ..none)))) - -(runtime: (text//clip offset length text) - (_.substring/3 text offset (_.+/2 offset length))) - -(runtime: (text//char index text) - (_.char->integer/1 (_.string-ref/2 text index))) - -(def: runtime//text - (_.begin (list @text//index - @text//clip - @text//char))) - -(runtime: (array//write idx value array) - (_.begin (list (_.vector-set!/3 array idx value) - array))) - -(def: runtime//array - Computation - ($_ _.then - @array//write - )) - -(def: runtime - Computation - (_.begin (list @slice - runtime//lux - runtime//i64 - runtime//adt - runtime//f64 - runtime//text - runtime//array - ))) - -(def: #export generate - (Operation [Registry Output]) - (do ///////phase.monad - [_ (/////generation.execute! ..runtime) - _ (/////generation.save! (%.nat ..module_id) ..runtime)] - (wrap [(|> artifact.empty - artifact.resource - product.right) - (row.row [(%.nat ..module_id) - (|> ..runtime - _.code - (\ utf8.codec encode))])]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux deleted file mode 100644 index 951fa494d..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux +++ /dev/null @@ -1,39 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [data - [collection - ["." list]]] - [target - ["_" scheme (#+ Expression)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." primitive] - ["///#" //// #_ - [analysis (#+ Variant Tuple)] - ["#." synthesis (#+ Synthesis)] - ["//#" /// #_ - ["#." phase ("#\." monad)]]]]) - -(def: #export (tuple expression archive elemsS+) - (Generator (Tuple Synthesis)) - (case elemsS+ - #.Nil - (///////phase\wrap (//primitive.text /////synthesis.unit)) - - (#.Cons singletonS #.Nil) - (expression archive singletonS) - - _ - (|> elemsS+ - (monad.map ///////phase.monad (expression archive)) - (///////phase\map _.vector/*)))) - -(def: #export (variant expression archive [lefts right? valueS]) - (Generator (Variant Synthesis)) - (let [tag (if right? - (inc lefts) - lefts)] - (///////phase\map (|>> [tag right?] //runtime.variant) - (expression archive valueS)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux deleted file mode 100644 index 615e7a722..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux +++ /dev/null @@ -1,103 +0,0 @@ -(.module: - [lux (#- primitive) - [abstract - ["." monad (#+ do)]] - [control - [pipe (#+ case>)] - ["." try]] - [data - ["." maybe] - [collection - ["." list ("#\." functor)] - ["." dictionary (#+ Dictionary)]]]] - ["." / #_ - ["#." function] - ["#." case] - ["#." variable] - ["/#" // #_ - ["#." extension] - ["/#" // #_ - ["#." analysis (#+ Analysis)] - ["/" synthesis (#+ Synthesis Phase)] - [/// - ["." phase ("#\." monad)] - [reference (#+) - [variable (#+)]]]]]]) - -(def: (primitive analysis) - (-> ///analysis.Primitive /.Primitive) - (case analysis - #///analysis.Unit - (#/.Text /.unit) - - (^template [<analysis> <synthesis>] - [(<analysis> value) - (<synthesis> value)]) - ([#///analysis.Bit #/.Bit] - [#///analysis.Frac #/.F64] - [#///analysis.Text #/.Text]) - - (^template [<analysis> <synthesis>] - [(<analysis> value) - (<synthesis> (.i64 value))]) - ([#///analysis.Nat #/.I64] - [#///analysis.Int #/.I64] - [#///analysis.Rev #/.I64]))) - -(def: (optimization archive) - Phase - (function (optimization' analysis) - (case analysis - (#///analysis.Primitive analysis') - (phase\wrap (#/.Primitive (..primitive analysis'))) - - (#///analysis.Reference reference) - (phase\wrap (#/.Reference reference)) - - (#///analysis.Structure structure) - (/.with_currying? false - (case structure - (#///analysis.Variant variant) - (do phase.monad - [valueS (optimization' (get@ #///analysis.value variant))] - (wrap (/.variant (set@ #///analysis.value valueS variant)))) - - (#///analysis.Tuple tuple) - (|> tuple - (monad.map phase.monad optimization') - (phase\map (|>> /.tuple))))) - - (#///analysis.Case inputA branchesAB+) - (/.with_currying? false - (/case.synthesize optimization branchesAB+ archive inputA)) - - (^ (///analysis.no_op value)) - (optimization' value) - - (#///analysis.Apply _) - (/.with_currying? false - (/function.apply optimization archive analysis)) - - (#///analysis.Function environmentA bodyA) - (/function.abstraction optimization environmentA archive bodyA) - - (#///analysis.Extension name args) - (/.with_currying? false - (function (_ state) - (|> (//extension.apply archive optimization [name args]) - (phase.run' state) - (case> (#try.Success output) - (#try.Success output) - - (#try.Failure _) - (|> args - (monad.map phase.monad optimization') - (phase\map (|>> [name] #/.Extension)) - (phase.run' state)))))) - ))) - -(def: #export (phase archive analysis) - Phase - (do phase.monad - [synthesis (..optimization archive analysis)] - (phase.lift (/variable.optimization synthesis)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux deleted file mode 100644 index 4d847ec2e..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux +++ /dev/null @@ -1,429 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - ["." monad (#+ do)]] - [control - [pipe (#+ when> new> case>)]] - [data - ["." product] - ["." bit ("#\." equivalence)] - ["." text ("#\." equivalence)] - [collection - ["." list ("#\." functor fold monoid)] - ["." set (#+ Set)]]] - [math - [number - ["n" nat] - ["." i64] - ["." frac ("#\." equivalence)]]]] - ["." /// #_ - [// - ["#." analysis (#+ Pattern Match Analysis)] - ["/" synthesis (#+ Path Synthesis Operation Phase)] - [/// - ["#" phase ("#\." monad)] - ["#." reference - ["#/." variable (#+ Register Variable)]] - [meta - [archive (#+ Archive)]]]]]) - -(def: clean_up - (-> Path Path) - (|>> (#/.Seq #/.Pop))) - -(def: (path' pattern end? thenC) - (-> Pattern Bit (Operation Path) (Operation Path)) - (case pattern - (#///analysis.Simple simple) - (case simple - #///analysis.Unit - thenC - - (#///analysis.Bit when) - (///\map (function (_ then) - (#/.Bit_Fork when then #.None)) - thenC) - - (^template [<from> <to> <conversion>] - [(<from> test) - (///\map (function (_ then) - (<to> [(<conversion> test) then] (list))) - thenC)]) - ([#///analysis.Nat #/.I64_Fork .i64] - [#///analysis.Int #/.I64_Fork .i64] - [#///analysis.Rev #/.I64_Fork .i64] - [#///analysis.Frac #/.F64_Fork |>] - [#///analysis.Text #/.Text_Fork |>])) - - (#///analysis.Bind register) - (<| (\ ///.monad map (|>> (#/.Seq (#/.Bind register)))) - /.with_new_local - thenC) - - (#///analysis.Complex (#///analysis.Variant [lefts right? value_pattern])) - (<| (///\map (|>> (#/.Seq (#/.Access (#/.Side (if right? - (#.Right lefts) - (#.Left lefts))))))) - (path' value_pattern end?) - (when> [(new> (not end?) [])] [(///\map ..clean_up)]) - thenC) - - (#///analysis.Complex (#///analysis.Tuple tuple)) - (let [tuple::last (dec (list.size tuple))] - (list\fold (function (_ [tuple::lefts tuple::member] nextC) - (.case tuple::member - (#///analysis.Simple #///analysis.Unit) - nextC - - _ - (let [right? (n.= tuple::last tuple::lefts) - end?' (and end? right?)] - (<| (///\map (|>> (#/.Seq (#/.Access (#/.Member (if right? - (#.Right (dec tuple::lefts)) - (#.Left tuple::lefts))))))) - (path' tuple::member end?') - (when> [(new> (not end?') [])] [(///\map ..clean_up)]) - nextC)))) - thenC - (list.reverse (list.enumeration tuple)))) - )) - -(def: (path archive synthesize pattern bodyA) - (-> Archive Phase Pattern Analysis (Operation Path)) - (path' pattern true (///\map (|>> #/.Then) (synthesize archive bodyA)))) - -(def: (weave_branch weave equivalence [new_test new_then] [[old_test old_then] old_tail]) - (All [a] (-> (-> Path Path Path) (Equivalence a) [a Path] (/.Fork a Path) - (/.Fork a Path))) - (if (\ equivalence = new_test old_test) - [[old_test (weave new_then old_then)] old_tail] - [[old_test old_then] - (case old_tail - #.Nil - (list [new_test new_then]) - - (#.Cons old_cons) - (#.Cons (weave_branch weave equivalence [new_test new_then] old_cons)))])) - -(def: (weave_fork weave equivalence new_fork old_fork) - (All [a] (-> (-> Path Path Path) (Equivalence a) (/.Fork a Path) (/.Fork a Path) - (/.Fork a Path))) - (list\fold (..weave_branch weave equivalence) old_fork (#.Cons new_fork))) - -(def: (weave new old) - (-> Path Path Path) - (with_expansions [<default> (as_is (#/.Alt old new))] - (case [new old] - [_ - (#/.Alt old_left old_right)] - (#/.Alt old_left - (weave new old_right)) - - [(#/.Seq preN postN) - (#/.Seq preO postO)] - (case (weave preN preO) - (#/.Alt _) - <default> - - woven - (#/.Seq woven (weave postN postO))) - - [#/.Pop #/.Pop] - old - - [(#/.Bit_Fork new_when new_then new_else) - (#/.Bit_Fork old_when old_then old_else)] - (if (bit\= new_when old_when) - (#/.Bit_Fork old_when - (weave new_then old_then) - (case [new_else old_else] - [#.None #.None] - #.None - - (^or [(#.Some woven_then) #.None] - [#.None (#.Some woven_then)]) - (#.Some woven_then) - - [(#.Some new_else) (#.Some old_else)] - (#.Some (weave new_else old_else)))) - (#/.Bit_Fork old_when - (case new_else - #.None - old_then - - (#.Some new_else) - (weave new_else old_then)) - (#.Some (case old_else - #.None - new_then - - (#.Some old_else) - (weave new_then old_else))))) - - (^template [<tag> <equivalence>] - [[(<tag> new_fork) (<tag> old_fork)] - (<tag> (..weave_fork weave <equivalence> new_fork old_fork))]) - ([#/.I64_Fork i64.equivalence] - [#/.F64_Fork frac.equivalence] - [#/.Text_Fork text.equivalence]) - - (^template [<access> <side>] - [[(#/.Access (<access> (<side> newL))) - (#/.Access (<access> (<side> oldL)))] - (if (n.= newL oldL) - old - <default>)]) - ([#/.Side #.Left] - [#/.Side #.Right] - [#/.Member #.Left] - [#/.Member #.Right]) - - [(#/.Bind newR) (#/.Bind oldR)] - (if (n.= newR oldR) - old - <default>) - - _ - <default>))) - -(def: (get patterns @selection) - (-> (///analysis.Tuple ///analysis.Pattern) Register (List /.Member)) - (loop [lefts 0 - patterns patterns] - (with_expansions [<failure> (as_is (list)) - <continue> (as_is (recur (inc lefts) - tail)) - <member> (as_is (if (list.empty? tail) - (#.Right (dec lefts)) - (#.Left lefts)))] - (case patterns - #.Nil - <failure> - - (#.Cons head tail) - (case head - (#///analysis.Simple #///analysis.Unit) - <continue> - - (#///analysis.Bind register) - (if (n.= @selection register) - (list <member>) - <continue>) - - (#///analysis.Complex (#///analysis.Tuple sub_patterns)) - (case (get sub_patterns @selection) - #.Nil - <continue> - - sub_members - (list& <member> sub_members)) - - _ - <failure>))))) - -(def: #export (synthesize_case synthesize archive input [[headP headA] tailPA+]) - (-> Phase Archive Synthesis Match (Operation Synthesis)) - (do {! ///.monad} - [headSP (path archive synthesize headP headA) - tailSP+ (monad.map ! (product.uncurry (path archive synthesize)) tailPA+)] - (wrap (/.branch/case [input (list\fold weave headSP tailSP+)])))) - -(template: (!masking <variable> <output>) - [[(#///analysis.Bind <variable>) - (#///analysis.Reference (///reference.local <output>))] - (list)]) - -(def: #export (synthesize_let synthesize archive input @variable body) - (-> Phase Archive Synthesis Register Analysis (Operation Synthesis)) - (do ///.monad - [body (/.with_new_local - (synthesize archive body))] - (wrap (/.branch/let [input @variable body])))) - -(def: #export (synthesize_masking synthesize archive input @variable @output) - (-> Phase Archive Synthesis Register Register (Operation Synthesis)) - (if (n.= @variable @output) - (///\wrap input) - (..synthesize_let synthesize archive input @variable (#///analysis.Reference (///reference.local @output))))) - -(def: #export (synthesize_if synthesize archive test then else) - (-> Phase Archive Synthesis Analysis Analysis (Operation Synthesis)) - (do ///.monad - [then (synthesize archive then) - else (synthesize archive else)] - (wrap (/.branch/if [test then else])))) - -(template: (!get <patterns> <output>) - [[(///analysis.pattern/tuple <patterns>) - (#///analysis.Reference (///reference.local <output>))] - (.list)]) - -(def: #export (synthesize_get synthesize archive input patterns @member) - (-> Phase Archive Synthesis (///analysis.Tuple ///analysis.Pattern) Register (Operation Synthesis)) - (case (..get patterns @member) - #.Nil - (..synthesize_case synthesize archive input (!get patterns @member)) - - path - (case input - (^ (/.branch/get [sub_path sub_input])) - (///\wrap (/.branch/get [(list\compose path sub_path) sub_input])) - - _ - (///\wrap (/.branch/get [path input]))))) - -(def: #export (synthesize synthesize^ [headB tailB+] archive inputA) - (-> Phase Match Phase) - (do {! ///.monad} - [inputS (synthesize^ archive inputA)] - (case [headB tailB+] - (^ (!masking @variable @output)) - (..synthesize_masking synthesize^ archive inputS @variable @output) - - [[(#///analysis.Bind @variable) body] - #.Nil] - (..synthesize_let synthesize^ archive inputS @variable body) - - (^or (^ [[(///analysis.pattern/bit #1) then] - (list [(///analysis.pattern/bit #0) else])]) - (^ [[(///analysis.pattern/bit #1) then] - (list [(///analysis.pattern/unit) else])]) - - (^ [[(///analysis.pattern/bit #0) else] - (list [(///analysis.pattern/bit #1) then])]) - (^ [[(///analysis.pattern/bit #0) else] - (list [(///analysis.pattern/unit) then])])) - (..synthesize_if synthesize^ archive inputS then else) - - (^ (!get patterns @member)) - (..synthesize_get synthesize^ archive inputS patterns @member) - - match - (..synthesize_case synthesize^ archive inputS match)))) - -(def: #export (count_pops path) - (-> Path [Nat Path]) - (case path - (^ (/.path/seq #/.Pop path')) - (let [[pops post_pops] (count_pops path')] - [(inc pops) post_pops]) - - _ - [0 path])) - -(def: #export pattern_matching_error - "Invalid expression for pattern-matching.") - -(type: #export Storage - {#bindings (Set Register) - #dependencies (Set Variable)}) - -(def: empty - Storage - {#bindings (set.new n.hash) - #dependencies (set.new ///reference/variable.hash)}) - -## TODO: Use this to declare all local variables at the beginning of -## script functions. -## That way, it should be possible to do cheap "let" expressions, -## since the variable will exist beforehand, so no closure will need -## to be created for it. -## Apply this trick to JS, Python et al. -(def: #export (storage path) - (-> Path Storage) - (loop for_path - [path path - path_storage ..empty] - (case path - (^or #/.Pop (#/.Access Access)) - path_storage - - (^ (/.path/bind register)) - (update@ #bindings (set.add register) - path_storage) - - (#/.Bit_Fork _ default otherwise) - (|> (case otherwise - #.None - path_storage - - (#.Some otherwise) - (for_path otherwise path_storage)) - (for_path default)) - - (^or (#/.I64_Fork forks) - (#/.F64_Fork forks) - (#/.Text_Fork forks)) - (|> (#.Cons forks) - (list\map product.right) - (list\fold for_path path_storage)) - - (^or (^ (/.path/seq left right)) - (^ (/.path/alt left right))) - (list\fold for_path path_storage (list left right)) - - (^ (/.path/then bodyS)) - (loop for_synthesis - [bodyS bodyS - synthesis_storage path_storage] - (case bodyS - (^ (/.variant [lefts right? valueS])) - (for_synthesis valueS synthesis_storage) - - (^ (/.tuple members)) - (list\fold for_synthesis synthesis_storage members) - - (#/.Reference (#///reference.Variable (#///reference/variable.Local register))) - (if (set.member? (get@ #bindings synthesis_storage) register) - synthesis_storage - (update@ #dependencies (set.add (#///reference/variable.Local register)) synthesis_storage)) - - (#/.Reference (#///reference.Variable var)) - (update@ #dependencies (set.add var) synthesis_storage) - - (^ (/.function/apply [functionS argsS])) - (list\fold for_synthesis synthesis_storage (#.Cons functionS argsS)) - - (^ (/.function/abstraction [environment arity bodyS])) - (list\fold for_synthesis synthesis_storage environment) - - (^ (/.branch/case [inputS pathS])) - (update@ #dependencies - (set.union (get@ #dependencies (for_path pathS synthesis_storage))) - (for_synthesis inputS synthesis_storage)) - - (^ (/.branch/let [inputS register exprS])) - (update@ #dependencies - (set.union (|> synthesis_storage - (update@ #bindings (set.add register)) - (for_synthesis exprS) - (get@ #dependencies))) - (for_synthesis inputS synthesis_storage)) - - (^ (/.branch/if [testS thenS elseS])) - (list\fold for_synthesis synthesis_storage (list testS thenS elseS)) - - (^ (/.branch/get [access whole])) - (for_synthesis whole synthesis_storage) - - (^ (/.loop/scope [start initsS+ iterationS])) - (update@ #dependencies - (set.union (|> synthesis_storage - (update@ #bindings (set.union (|> initsS+ - list.enumeration - (list\map (|>> product.left (n.+ start))) - (set.from_list n.hash)))) - (for_synthesis iterationS) - (get@ #dependencies))) - (list\fold for_synthesis synthesis_storage initsS+)) - - (^ (/.loop/recur replacementsS+)) - (list\fold for_synthesis synthesis_storage replacementsS+) - - (#/.Extension [extension argsS]) - (list\fold for_synthesis synthesis_storage argsS) - - _ - synthesis_storage)) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux deleted file mode 100644 index d3558e9c4..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux +++ /dev/null @@ -1,276 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)] - ["." enum]] - [control - [pipe (#+ case>)] - ["." exception (#+ exception:)]] - [data - ["." maybe ("#\." functor)] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor monoid fold)]]] - [math - [number - ["n" nat]]]] - ["." // #_ - ["#." loop (#+ Transform)] - ["//#" /// #_ - ["#." analysis (#+ Environment Analysis)] - ["/" synthesis (#+ Path Abstraction Synthesis Operation Phase)] - [/// - [arity (#+ Arity)] - ["#." reference - ["#/." variable (#+ Register Variable)]] - ["." phase ("#\." monad)]]]]) - -(exception: #export (cannot_find_foreign_variable_in_environment {foreign Register} {environment (Environment Synthesis)}) - (exception.report - ["Foreign" (%.nat foreign)] - ["Environment" (exception.enumerate /.%synthesis environment)])) - -(def: arity_arguments - (-> Arity (List Synthesis)) - (|>> dec - (enum.range n.enum 1) - (list\map (|>> /.variable/local)))) - -(template: #export (self_reference) - (/.variable/local 0)) - -(def: (expanded_nested_self_reference arity) - (-> Arity Synthesis) - (/.function/apply [(..self_reference) (arity_arguments arity)])) - -(def: #export (apply phase) - (-> Phase Phase) - (function (_ archive exprA) - (let [[funcA argsA] (////analysis.application exprA)] - (do {! phase.monad} - [funcS (phase archive funcA) - argsS (monad.map ! (phase archive) argsA)] - (with_expansions [<apply> (as_is (/.function/apply [funcS argsS]))] - (case funcS - (^ (/.function/abstraction functionS)) - (if (n.= (get@ #/.arity functionS) - (list.size argsS)) - (do ! - [locals /.locals] - (wrap (|> functionS - (//loop.optimization true locals argsS) - (maybe\map (: (-> [Nat (List Synthesis) Synthesis] Synthesis) - (function (_ [start inits iteration]) - (case iteration - (^ (/.loop/scope [start' inits' output])) - (if (and (n.= start start') - (list.empty? inits')) - (/.loop/scope [start inits output]) - (/.loop/scope [start inits iteration])) - - _ - (/.loop/scope [start inits iteration]))))) - (maybe.default <apply>)))) - (wrap <apply>)) - - (^ (/.function/apply [funcS' argsS'])) - (wrap (/.function/apply [funcS' (list\compose argsS' argsS)])) - - _ - (wrap <apply>))))))) - -(def: (find_foreign environment register) - (-> (Environment Synthesis) Register (Operation Synthesis)) - (case (list.nth register environment) - (#.Some aliased) - (phase\wrap aliased) - - #.None - (phase.throw ..cannot_find_foreign_variable_in_environment [register environment]))) - -(def: (grow_path grow path) - (-> (-> Synthesis (Operation Synthesis)) Path (Operation Path)) - (case path - (#/.Bind register) - (phase\wrap (#/.Bind (inc register))) - - (^template [<tag>] - [(<tag> left right) - (do phase.monad - [left' (grow_path grow left) - right' (grow_path grow right)] - (wrap (<tag> left' right')))]) - ([#/.Alt] [#/.Seq]) - - (#/.Bit_Fork when then else) - (do {! phase.monad} - [then (grow_path grow then) - else (case else - (#.Some else) - (\ ! map (|>> #.Some) (grow_path grow else)) - - #.None - (wrap #.None))] - (wrap (#/.Bit_Fork when then else))) - - (^template [<tag>] - [(<tag> [[test then] elses]) - (do {! phase.monad} - [then (grow_path grow then) - elses (monad.map ! (function (_ [else_test else_then]) - (do ! - [else_then (grow_path grow else_then)] - (wrap [else_test else_then]))) - elses)] - (wrap (<tag> [[test then] elses])))]) - ([#/.I64_Fork] - [#/.F64_Fork] - [#/.Text_Fork]) - - (#/.Then thenS) - (|> thenS - grow - (phase\map (|>> #/.Then))) - - _ - (phase\wrap path))) - -(def: (grow environment expression) - (-> (Environment Synthesis) Synthesis (Operation Synthesis)) - (case expression - (#/.Structure structure) - (case structure - (#////analysis.Variant [lefts right? subS]) - (|> subS - (grow environment) - (phase\map (|>> [lefts right?] /.variant))) - - (#////analysis.Tuple membersS+) - (|> membersS+ - (monad.map phase.monad (grow environment)) - (phase\map (|>> /.tuple)))) - - (^ (..self_reference)) - (phase\wrap (/.function/apply [expression (list (/.variable/local 1))])) - - (#/.Reference reference) - (case reference - (#////reference.Variable variable) - (case variable - (#////reference/variable.Local register) - (phase\wrap (/.variable/local (inc register))) - - (#////reference/variable.Foreign register) - (..find_foreign environment register)) - - (#////reference.Constant constant) - (phase\wrap expression)) - - (#/.Control control) - (case control - (#/.Branch branch) - (case branch - (#/.Let [inputS register bodyS]) - (do phase.monad - [inputS' (grow environment inputS) - bodyS' (grow environment bodyS)] - (wrap (/.branch/let [inputS' (inc register) bodyS']))) - - (#/.If [testS thenS elseS]) - (do phase.monad - [testS' (grow environment testS) - thenS' (grow environment thenS) - elseS' (grow environment elseS)] - (wrap (/.branch/if [testS' thenS' elseS']))) - - (#/.Get members inputS) - (do phase.monad - [inputS' (grow environment inputS)] - (wrap (/.branch/get [members inputS']))) - - (#/.Case [inputS pathS]) - (do phase.monad - [inputS' (grow environment inputS) - pathS' (grow_path (grow environment) pathS)] - (wrap (/.branch/case [inputS' pathS'])))) - - (#/.Loop loop) - (case loop - (#/.Scope [start initsS+ iterationS]) - (do {! phase.monad} - [initsS+' (monad.map ! (grow environment) initsS+) - iterationS' (grow environment iterationS)] - (wrap (/.loop/scope [(inc start) initsS+' iterationS']))) - - (#/.Recur argumentsS+) - (|> argumentsS+ - (monad.map phase.monad (grow environment)) - (phase\map (|>> /.loop/recur)))) - - (#/.Function function) - (case function - (#/.Abstraction [_env _arity _body]) - (do {! phase.monad} - [_env' (monad.map ! - (|>> (case> (#/.Reference (#////reference.Variable (#////reference/variable.Foreign register))) - (..find_foreign environment register) - - captured - (grow environment captured))) - _env)] - (wrap (/.function/abstraction [_env' _arity _body]))) - - (#/.Apply funcS argsS+) - (do {! phase.monad} - [funcS (grow environment funcS) - argsS+ (monad.map ! (grow environment) argsS+)] - (wrap (/.function/apply (case funcS - (^ (/.function/apply [(..self_reference) pre_argsS+])) - [(..self_reference) - (list\compose pre_argsS+ argsS+)] - - _ - [funcS - argsS+])))))) - - (#/.Extension name argumentsS+) - (|> argumentsS+ - (monad.map phase.monad (grow environment)) - (phase\map (|>> (#/.Extension name)))) - - (#/.Primitive _) - (phase\wrap expression))) - -(def: #export (abstraction phase environment archive bodyA) - (-> Phase (Environment Analysis) Phase) - (do {! phase.monad} - [currying? /.currying? - environment (monad.map ! (phase archive) environment) - bodyS (/.with_currying? true - (/.with_locals 2 - (phase archive bodyA))) - abstraction (: (Operation Abstraction) - (case bodyS - (^ (/.function/abstraction [env' down_arity' bodyS'])) - (|> bodyS' - (grow env') - (\ ! map (function (_ body) - {#/.environment environment - #/.arity (inc down_arity') - #/.body body}))) - - _ - (wrap {#/.environment environment - #/.arity 1 - #/.body bodyS})))] - (wrap (if currying? - (/.function/abstraction abstraction) - (case (//loop.optimization false 1 (list) abstraction) - (#.Some [startL initsL bodyL]) - (/.function/abstraction {#/.environment environment - #/.arity (get@ #/.arity abstraction) - #/.body (/.loop/scope [startL initsL bodyL])}) - - #.None - (/.function/abstraction abstraction)))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux deleted file mode 100644 index e0fbf816c..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux +++ /dev/null @@ -1,186 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [data - ["." maybe ("#\." monad)] - [collection - ["." list]]] - [math - [number - ["n" nat]]]] - [//// - ["." analysis (#+ Environment)] - ["/" synthesis (#+ Path Abstraction Synthesis)] - [/// - [arity (#+ Arity)] - ["." reference - ["." variable (#+ Register Variable)]]]]) - -(type: #export (Transform a) - (-> a (Maybe a))) - -(def: #export (register_optimization offset) - (-> Register (-> Register Register)) - (|>> dec (n.+ offset))) - -(def: (path_optimization body_optimization offset) - (-> (Transform Synthesis) Register (Transform Path)) - (function (recur path) - (case path - (#/.Bind register) - (#.Some (#/.Bind (register_optimization offset register))) - - (^template [<tag>] - [(<tag> left right) - (do maybe.monad - [left' (recur left) - right' (recur right)] - (wrap (<tag> left' right')))]) - ([#/.Alt] [#/.Seq]) - - (#/.Bit_Fork when then else) - (do {! maybe.monad} - [then (recur then) - else (case else - (#.Some else) - (\ ! map (|>> #.Some) (recur else)) - - #.None - (wrap #.None))] - (wrap (#/.Bit_Fork when then else))) - - (^template [<tag>] - [(<tag> [[test then] elses]) - (do {! maybe.monad} - [then (recur then) - elses (monad.map ! (function (_ [else_test else_then]) - (do ! - [else_then (recur else_then)] - (wrap [else_test else_then]))) - elses)] - (wrap (<tag> [[test then] elses])))]) - ([#/.I64_Fork] - [#/.F64_Fork] - [#/.Text_Fork]) - - (#/.Then body) - (|> body - body_optimization - (maybe\map (|>> #/.Then))) - - _ - (#.Some path)))) - -(def: (body_optimization true_loop? offset scope_environment arity expr) - (-> Bit Register (Environment Synthesis) Arity (Transform Synthesis)) - (loop [return? true - expr expr] - (case expr - (#/.Primitive _) - (#.Some expr) - - (#/.Structure structure) - (case structure - (#analysis.Variant variant) - (do maybe.monad - [value' (|> variant (get@ #analysis.value) (recur false))] - (wrap (|> variant - (set@ #analysis.value value') - /.variant))) - - (#analysis.Tuple tuple) - (|> tuple - (monad.map maybe.monad (recur false)) - (maybe\map (|>> /.tuple)))) - - (#/.Reference reference) - (case reference - (^ (#reference.Variable (variable.self))) - (if true_loop? - #.None - (#.Some expr)) - - (^ (reference.constant constant)) - (#.Some expr) - - (^ (reference.local register)) - (#.Some (#/.Reference (reference.local (register_optimization offset register)))) - - (^ (reference.foreign register)) - (if true_loop? - (list.nth register scope_environment) - (#.Some expr))) - - (^ (/.branch/case [input path])) - (do maybe.monad - [input' (recur false input) - path' (path_optimization (recur return?) offset path)] - (wrap (|> path' [input'] /.branch/case))) - - (^ (/.branch/let [input register body])) - (do maybe.monad - [input' (recur false input) - body' (recur return? body)] - (wrap (/.branch/let [input' (register_optimization offset register) body']))) - - (^ (/.branch/if [input then else])) - (do maybe.monad - [input' (recur false input) - then' (recur return? then) - else' (recur return? else)] - (wrap (/.branch/if [input' then' else']))) - - (^ (/.branch/get [path record])) - (do maybe.monad - [record (recur false record)] - (wrap (/.branch/get [path record]))) - - (^ (/.loop/scope scope)) - (do {! maybe.monad} - [inits' (|> scope - (get@ #/.inits) - (monad.map ! (recur false))) - iteration' (recur return? (get@ #/.iteration scope))] - (wrap (/.loop/scope {#/.start (|> scope (get@ #/.start) (register_optimization offset)) - #/.inits inits' - #/.iteration iteration'}))) - - (^ (/.loop/recur args)) - (|> args - (monad.map maybe.monad (recur false)) - (maybe\map (|>> /.loop/recur))) - - (^ (/.function/abstraction [environment arity body])) - (do {! maybe.monad} - [environment' (monad.map ! (recur false) environment)] - (wrap (/.function/abstraction [environment' arity body]))) - - (^ (/.function/apply [abstraction arguments])) - (do {! maybe.monad} - [arguments' (monad.map maybe.monad (recur false) arguments)] - (with_expansions [<application> (as_is (do ! - [abstraction' (recur false abstraction)] - (wrap (/.function/apply [abstraction' arguments']))))] - (case abstraction - (^ (#/.Reference (#reference.Variable (variable.self)))) - (if (and return? - (n.= arity (list.size arguments))) - (wrap (/.loop/recur arguments')) - (if true_loop? - #.None - <application>)) - - _ - <application>))) - - (#/.Extension [name args]) - (|> args - (monad.map maybe.monad (recur false)) - (maybe\map (|>> [name] #/.Extension)))))) - -(def: #export (optimization true_loop? offset inits functionS) - (-> Bit Register (List Synthesis) Abstraction (Maybe [Register (List Synthesis) Synthesis])) - (|> (get@ #/.body functionS) - (body_optimization true_loop? offset (get@ #/.environment functionS) (get@ #/.arity functionS)) - (maybe\map (|>> [offset inits])))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux deleted file mode 100644 index 68e12745d..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux +++ /dev/null @@ -1,442 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["." product] - ["." maybe ("#\." functor)] - ["." text - ["%" format]] - [collection - ["." dictionary (#+ Dictionary)] - ["." list ("#\." functor fold)] - ["." set]]] - [math - [number - ["n" nat]]]] - [//// - ["/" synthesis (#+ Path Synthesis)] - ["." analysis] - [/// - [arity (#+ Arity)] - ["." reference - ["." variable (#+ Register Variable)]]]]) - -(def: (prune redundant register) - (-> Register Register Register) - (if (n.> redundant register) - (dec register) - register)) - -(type: (Remover a) - (-> Register (-> a a))) - -(def: (remove_local_from_path remove_local redundant) - (-> (Remover Synthesis) (Remover Path)) - (function (recur path) - (case path - (#/.Seq (#/.Bind register) - post) - (if (n.= redundant register) - (recur post) - (#/.Seq (#/.Bind (if (n.> redundant register) - (dec register) - register)) - (recur post))) - - (^or (#/.Seq (#/.Access (#/.Member member)) - (#/.Seq (#/.Bind register) - post)) - ## This alternative form should never occur in practice. - ## Yet, it is "technically" possible to construct it. - (#/.Seq (#/.Seq (#/.Access (#/.Member member)) - (#/.Bind register)) - post)) - (if (n.= redundant register) - (recur post) - (#/.Seq (#/.Access (#/.Member member)) - (#/.Seq (#/.Bind (if (n.> redundant register) - (dec register) - register)) - (recur post)))) - - (^template [<tag>] - [(<tag> left right) - (<tag> (recur left) (recur right))]) - ([#/.Seq] - [#/.Alt]) - - (#/.Bit_Fork when then else) - (#/.Bit_Fork when (recur then) (maybe\map recur else)) - - (^template [<tag>] - [(<tag> [[test then] tail]) - (<tag> [[test (recur then)] - (list\map (function (_ [test' then']) - [test' (recur then')]) - tail)])]) - ([#/.I64_Fork] - [#/.F64_Fork] - [#/.Text_Fork]) - - (^or #/.Pop - (#/.Access _)) - path - - (#/.Bind register) - (undefined) - - (#/.Then then) - (#/.Then (remove_local redundant then)) - ))) - -(def: (remove_local_from_variable redundant variable) - (Remover Variable) - (case variable - (#variable.Local register) - (#variable.Local (..prune redundant register)) - - (#variable.Foreign register) - variable)) - -(def: (remove_local redundant) - (Remover Synthesis) - (function (recur synthesis) - (case synthesis - (#/.Primitive _) - synthesis - - (#/.Structure structure) - (#/.Structure (case structure - (#analysis.Variant [lefts right value]) - (#analysis.Variant [lefts right (recur value)]) - - (#analysis.Tuple tuple) - (#analysis.Tuple (list\map recur tuple)))) - - (#/.Reference reference) - (case reference - (#reference.Variable variable) - (/.variable (..remove_local_from_variable redundant variable)) - - (#reference.Constant constant) - synthesis) - - (#/.Control control) - (#/.Control (case control - (#/.Branch branch) - (#/.Branch (case branch - (#/.Let input register output) - (#/.Let (recur input) - (..prune redundant register) - (recur output)) - - (#/.If test then else) - (#/.If (recur test) (recur then) (recur else)) - - (#/.Get path record) - (#/.Get path (recur record)) - - (#/.Case input path) - (#/.Case (recur input) (remove_local_from_path remove_local redundant path)))) - - (#/.Loop loop) - (#/.Loop (case loop - (#/.Scope [start inits iteration]) - (#/.Scope [(..prune redundant start) - (list\map recur inits) - (recur iteration)]) - - (#/.Recur resets) - (#/.Recur (list\map recur resets)))) - - (#/.Function function) - (#/.Function (case function - (#/.Abstraction [environment arity body]) - (#/.Abstraction [(list\map recur environment) - arity - body]) - - (#/.Apply abstraction inputs) - (#/.Apply (recur abstraction) (list\map recur inputs)))))) - - (#/.Extension name inputs) - (#/.Extension name (list\map recur inputs))))) - -(type: Redundancy - (Dictionary Register Bit)) - -(def: initial - Redundancy - (dictionary.new n.hash)) - -(def: redundant! true) -(def: necessary! false) - -(def: (extended offset amount redundancy) - (-> Register Nat Redundancy [(List Register) Redundancy]) - (let [extension (|> amount list.indices (list\map (n.+ offset)))] - [extension - (list\fold (function (_ register redundancy) - (dictionary.put register ..necessary! redundancy)) - redundancy - extension)])) - -(def: (default arity) - (-> Arity Redundancy) - (product.right (..extended 0 (inc arity) ..initial))) - -(type: (Optimization a) - (-> [Redundancy a] (Try [Redundancy a]))) - -(def: (list_optimization optimization) - (All [a] (-> (Optimization a) (Optimization (List a)))) - (function (recur [redundancy values]) - (case values - #.Nil - (#try.Success [redundancy - values]) - - (#.Cons head tail) - (do try.monad - [[redundancy head] (optimization [redundancy head]) - [redundancy tail] (recur [redundancy tail])] - (wrap [redundancy - (#.Cons head tail)]))))) - -(template [<name>] - [(exception: #export (<name> {register Register}) - (exception.report - ["Register" (%.nat register)]))] - - [redundant_declaration] - [unknown_register] - ) - -(def: (declare register redundancy) - (-> Register Redundancy (Try Redundancy)) - (case (dictionary.get register redundancy) - #.None - (#try.Success (dictionary.put register ..redundant! redundancy)) - - (#.Some _) - (exception.throw ..redundant_declaration [register]))) - -(def: (observe register redundancy) - (-> Register Redundancy (Try Redundancy)) - (case (dictionary.get register redundancy) - #.None - (exception.throw ..unknown_register [register]) - - (#.Some _) - (#try.Success (dictionary.put register ..necessary! redundancy)))) - -(def: (format redundancy) - (%.Format Redundancy) - (|> redundancy - dictionary.entries - (list\map (function (_ [register redundant?]) - (%.format (%.nat register) ": " (%.bit redundant?)))) - (text.join_with ", "))) - -(def: (path_optimization optimization) - (-> (Optimization Synthesis) (Optimization Path)) - (function (recur [redundancy path]) - (case path - (^or #/.Pop - (#/.Access _)) - (#try.Success [redundancy - path]) - - (#/.Bit_Fork when then else) - (do {! try.monad} - [[redundancy then] (recur [redundancy then]) - [redundancy else] (case else - (#.Some else) - (\ ! map - (function (_ [redundancy else]) - [redundancy (#.Some else)]) - (recur [redundancy else])) - - #.None - (wrap [redundancy #.None]))] - (wrap [redundancy (#/.Bit_Fork when then else)])) - - (^template [<tag> <type>] - [(<tag> [[test then] elses]) - (do {! try.monad} - [[redundancy then] (recur [redundancy then]) - [redundancy elses] (..list_optimization (: (Optimization [<type> Path]) - (function (_ [redundancy [else_test else_then]]) - (do ! - [[redundancy else_then] (recur [redundancy else_then])] - (wrap [redundancy [else_test else_then]])))) - [redundancy elses])] - (wrap [redundancy (<tag> [[test then] elses])]))]) - ([#/.I64_Fork (I64 Any)] - [#/.F64_Fork Frac] - [#/.Text_Fork Text]) - - (#/.Bind register) - (do try.monad - [redundancy (..declare register redundancy)] - (wrap [redundancy - path])) - - (#/.Alt left right) - (do try.monad - [[redundancy left] (recur [redundancy left]) - [redundancy right] (recur [redundancy right])] - (wrap [redundancy (#/.Alt left right)])) - - (#/.Seq pre post) - (do try.monad - [#let [baseline (|> redundancy - dictionary.keys - (set.from_list n.hash))] - [redundancy pre] (recur [redundancy pre]) - #let [bindings (|> redundancy - dictionary.keys - (set.from_list n.hash) - (set.difference baseline))] - [redundancy post] (recur [redundancy post]) - #let [redundants (|> redundancy - dictionary.entries - (list.filter (function (_ [register redundant?]) - (and (set.member? bindings register) - redundant?))) - (list\map product.left))]] - (wrap [(list\fold dictionary.remove redundancy (set.to_list bindings)) - (|> redundants - (list.sort n.>) - (list\fold (..remove_local_from_path ..remove_local) (#/.Seq pre post)))])) - - (#/.Then then) - (do try.monad - [[redundancy then] (optimization [redundancy then])] - (wrap [redundancy (#/.Then then)])) - ))) - -(def: (optimization' [redundancy synthesis]) - (Optimization Synthesis) - (with_expansions [<no_op> (as_is (#try.Success [redundancy - synthesis]))] - (case synthesis - (#/.Primitive _) - <no_op> - - (#/.Structure structure) - (case structure - (#analysis.Variant [lefts right value]) - (do try.monad - [[redundancy value] (optimization' [redundancy value])] - (wrap [redundancy - (#/.Structure (#analysis.Variant [lefts right value]))])) - - (#analysis.Tuple tuple) - (do try.monad - [[redundancy tuple] (..list_optimization optimization' [redundancy tuple])] - (wrap [redundancy - (#/.Structure (#analysis.Tuple tuple))]))) - - (#/.Reference reference) - (case reference - (#reference.Variable variable) - (case variable - (#variable.Local register) - (do try.monad - [redundancy (..observe register redundancy)] - <no_op>) - - (#variable.Foreign register) - <no_op>) - - (#reference.Constant constant) - <no_op>) - - (#/.Control control) - (case control - (#/.Branch branch) - (case branch - (#/.Let input register output) - (do try.monad - [[redundancy input] (optimization' [redundancy input]) - redundancy (..declare register redundancy) - [redundancy output] (optimization' [redundancy output]) - #let [redundant? (|> redundancy - (dictionary.get register) - (maybe.default ..necessary!))]] - (wrap [(dictionary.remove register redundancy) - (#/.Control (if redundant? - (#/.Branch (#/.Case input - (#/.Seq #/.Pop - (#/.Then (..remove_local register output))))) - (#/.Branch (#/.Let input register output))))])) - - (#/.If test then else) - (do try.monad - [[redundancy test] (optimization' [redundancy test]) - [redundancy then] (optimization' [redundancy then]) - [redundancy else] (optimization' [redundancy else])] - (wrap [redundancy - (#/.Control (#/.Branch (#/.If test then else)))])) - - (#/.Get path record) - (do try.monad - [[redundancy record] (optimization' [redundancy record])] - (wrap [redundancy - (#/.Control (#/.Branch (#/.Get path record)))])) - - (#/.Case input path) - (do try.monad - [[redundancy input] (optimization' [redundancy input]) - [redundancy path] (..path_optimization optimization' [redundancy path])] - (wrap [redundancy - (#/.Control (#/.Branch (#/.Case input path)))]))) - - (#/.Loop loop) - (case loop - (#/.Scope [start inits iteration]) - (do try.monad - [[redundancy inits] (..list_optimization optimization' [redundancy inits]) - #let [[extension redundancy] (..extended start (list.size inits) redundancy)] - [redundancy iteration] (optimization' [redundancy iteration])] - (wrap [(list\fold dictionary.remove redundancy extension) - (#/.Control (#/.Loop (#/.Scope [start inits iteration])))])) - - (#/.Recur resets) - (do try.monad - [[redundancy resets] (..list_optimization optimization' [redundancy resets])] - (wrap [redundancy - (#/.Control (#/.Loop (#/.Recur resets)))]))) - - (#/.Function function) - (case function - (#/.Abstraction [environment arity body]) - (do {! try.monad} - [[redundancy environment] (..list_optimization optimization' [redundancy environment]) - [_ body] (optimization' [(..default arity) body])] - (wrap [redundancy - (#/.Control (#/.Function (#/.Abstraction [environment arity body])))])) - - (#/.Apply abstraction inputs) - (do try.monad - [[redundancy abstraction] (optimization' [redundancy abstraction]) - [redundancy inputs] (..list_optimization optimization' [redundancy inputs])] - (wrap [redundancy - (#/.Control (#/.Function (#/.Apply abstraction inputs)))])))) - - (#/.Extension name inputs) - (do try.monad - [[redundancy inputs] (..list_optimization optimization' [redundancy inputs])] - (wrap [redundancy - (#/.Extension name inputs)]))))) - -(def: #export optimization - (-> Synthesis (Try Synthesis)) - (|>> [..initial] - optimization' - (\ try.monad map product.right))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/program.lux b/stdlib/source/lux/tool/compiler/language/lux/program.lux deleted file mode 100644 index fc384c178..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/program.lux +++ /dev/null @@ -1,56 +0,0 @@ -(.module: - [lux (#- Module) - [abstract - ["." monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["." product] - ["." maybe] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)]]]] - [// - [generation (#+ Context)] - [/// - [meta - ["." archive (#+ Archive) - ["." descriptor (#+ Module)] - ["." artifact]]]]]) - -(type: #export (Program expression directive) - (-> Context expression directive)) - -(def: #export name - Text - "") - -(exception: #export (cannot-find-program {modules (List Module)}) - (exception.report - ["Modules" (exception.enumerate %.text modules)])) - -(def: #export (context archive) - (-> Archive (Try Context)) - (do {! try.monad} - [registries (|> archive - archive.archived - (monad.map ! - (function (_ module) - (do ! - [id (archive.id module archive) - [descriptor document] (archive.find module archive)] - (wrap [[module id] (get@ #descriptor.registry descriptor)])))))] - (case (list.one (function (_ [[module module-id] registry]) - (do maybe.monad - [program-id (artifact.remember ..name registry)] - (wrap [module-id program-id]))) - registries) - (#.Some program-context) - (wrap program-context) - - #.None - (|> registries - (list\map (|>> product.left product.left)) - (exception.throw ..cannot-find-program))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/syntax.lux b/stdlib/source/lux/tool/compiler/language/lux/syntax.lux deleted file mode 100644 index 00d1497a1..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/syntax.lux +++ /dev/null @@ -1,582 +0,0 @@ -## This is LuxC's parser. -## It takes the source code of a Lux file in raw text form and -## extracts the syntactic structure of the code from it. -## It only produces Lux Code nodes, and thus removes any white-space -## and comments while processing its inputs. - -## Another important aspect of the parser is that it keeps track of -## its position within the input data. -## That is, the parser takes into account the line and column -## information in the input text (it doesn't really touch the -## file-name aspect of the location, leaving it intact in whatever -## base-line location it is given). - -## This particular piece of functionality is not located in one -## function, but it is instead scattered throughout several parsers, -## since the logic for how to update the location varies, depending on -## what is being parsed, and the rules involved. - -## You will notice that several parsers have a "where" parameter, that -## tells them the location position prior to the parser being run. -## They are supposed to produce some parsed output, alongside an -## updated location pointing to the end position, after the parser was run. - -## Lux Code nodes/tokens are annotated with location meta-data -## [file-name, line, column] to keep track of their provenance and -## location, which is helpful for documentation and debugging. -(.module: - [lux #* - ["@" target] - [abstract - monad] - [control - ["." exception (#+ exception:)] - [parser - [text (#+ Offset)]]] - [data - ["." maybe] - ["." text - ["%" format (#+ format)]] - [collection - ["." list] - ["." dictionary (#+ Dictionary)]]] - [macro - ["." template]] - [math - [number - ["n" nat] - ["." int] - ["." rev] - ["." frac]]]]) - -(template: (inline: <declaration> <type> <body>) - (for {@.python (def: <declaration> <type> <body>)} - (template: <declaration> <body>))) - -## TODO: Implement "lux syntax char case!" as a custom extension. -## That way, it should be possible to obtain the char without wrapping -## it into a java.lang.Long, thereby improving performance. - -## TODO: Make an extension to take advantage of java/lang/String::indexOf<int,int> -## to get better performance than the current "lux text index" extension. - -## TODO: Instead of always keeping a "where" location variable, keep the -## individual components (i.e. file, line and column) separate, so -## that updated the "where" only involved updating the components, and -## producing the locations only involved building them, without any need -## for pattern-matching and de-structuring. - -(type: Char - Nat) - -(template [<name> <extension> <diff>] - [(template: (<name> value) - (<extension> <diff> value))] - - [!inc "lux i64 +" 1] - [!inc/2 "lux i64 +" 2] - [!dec "lux i64 -" 1] - ) - -(template: (!clip from to text) - ("lux text clip" from (n.- from to) text)) - -(template [<name> <extension>] - [(template: (<name> reference subject) - (<extension> reference subject))] - - [!n/= "lux i64 ="] - [!i/< "lux i64 <"] - ) - -(template [<name> <extension>] - [(template: (<name> param subject) - (<extension> param subject))] - - [!n/+ "lux i64 +"] - [!n/- "lux i64 -"] - ) - -(type: #export Aliases - (Dictionary Text Text)) - -(def: #export no_aliases - Aliases - (dictionary.new text.hash)) - -(def: #export prelude "lux") - -(def: #export text_delimiter text.double_quote) - -(template [<char> <definition>] - [(def: #export <definition> <char>)] - - ## Form delimiters - ["(" open_form] - [")" close_form] - - ## Tuple delimiters - ["[" open_tuple] - ["]" close_tuple] - - ## Record delimiters - ["{" open_record] - ["}" close_record] - - ["#" sigil] - - ["," digit_separator] - - ["+" positive_sign] - ["-" negative_sign] - - ["." frac_separator] - - ## The parts of a name are separated by a single mark. - ## E.g. module.short. - ## Only one such mark may be used in an name, since there - ## can only be 2 parts to a name (the module [before the - ## mark], and the short [after the mark]). - ## There are also some extra rules regarding name syntax, - ## encoded in the parser. - ["." name_separator] - ) - -(exception: #export (end_of_file {module Text}) - (exception.report - ["Module" (%.text module)])) - -(def: amount_of_input_shown 64) - -(inline: (input_at start input) - (-> Offset Text Text) - (let [end (|> start (!n/+ amount_of_input_shown) (n.min ("lux text size" input)))] - (!clip start end input))) - -(exception: #export (unrecognized_input {[file line column] Location} {context Text} {input Text} {offset Offset}) - (exception.report - ["File" file] - ["Line" (%.nat line)] - ["Column" (%.nat column)] - ["Context" (%.text context)] - ["Input" (input_at offset input)])) - -(exception: #export (text_cannot_contain_new_lines {text Text}) - (exception.report - ["Text" (%.text text)])) - -(template: (!failure parser where offset source_code) - (#.Left [[where offset source_code] - (exception.construct ..unrecognized_input [where (%.name (name_of parser)) source_code offset])])) - -(template: (!end_of_file where offset source_code current_module) - (#.Left [[where offset source_code] - (exception.construct ..end_of_file current_module)])) - -(type: (Parser a) - (-> Source (Either [Source Text] [Source a]))) - -(template: (!with_char+ @source_code_size @source_code @offset @char @else @body) - (if (!i/< (:as Int @source_code_size) - (:as Int @offset)) - (let [@char ("lux text char" @offset @source_code)] - @body) - @else)) - -(template: (!with_char @source_code @offset @char @else @body) - (!with_char+ ("lux text size" @source_code) @source_code @offset @char @else @body)) - -(template: (!letE <binding> <computation> <body>) - (case <computation> - (#.Right <binding>) - <body> - - ## (#.Left error) - <<otherwise>> - (:assume <<otherwise>>))) - -(template: (!horizontal where offset source_code) - [(update@ #.column inc where) - (!inc offset) - source_code]) - -(inline: (!new_line where) - (-> Location Location) - (let [[where::file where::line where::column] where] - [where::file (!inc where::line) 0])) - -(inline: (!forward length where) - (-> Nat Location Location) - (let [[where::file where::line where::column] where] - [where::file where::line (!n/+ length where::column)])) - -(template: (!vertical where offset source_code) - [(!new_line where) - (!inc offset) - source_code]) - -(template [<name> <close> <tag>] - [(inline: (<name> parse where offset source_code) - (-> (Parser Code) Location Offset Text - (Either [Source Text] [Source Code])) - (loop [source (: Source [(!forward 1 where) offset source_code]) - stack (: (List Code) #.Nil)] - (case (parse source) - (#.Right [source' top]) - (recur source' (#.Cons top stack)) - - (#.Left [source' error]) - (if (is? <close> error) - (#.Right [source' - [where (<tag> (list.reverse stack))]]) - (#.Left [source' error])))))] - - ## Form and tuple syntax is mostly the same, differing only in the - ## delimiters involved. - ## They may have an arbitrary number of arbitrary Code nodes as elements. - [parse_form ..close_form #.Form] - [parse_tuple ..close_tuple #.Tuple] - ) - -(inline: (parse_record parse where offset source_code) - (-> (Parser Code) Location Offset Text - (Either [Source Text] [Source Code])) - (loop [source (: Source [(!forward 1 where) offset source_code]) - stack (: (List [Code Code]) #.Nil)] - (case (parse source) - (#.Right [sourceF field]) - (!letE [sourceFV value] (parse sourceF) - (recur sourceFV (#.Cons [field value] stack))) - - (#.Left [source' error]) - (if (is? ..close_record error) - (#.Right [source' - [where (#.Record (list.reverse stack))]]) - (#.Left [source' error]))))) - -(template: (!guarantee_no_new_lines where offset source_code content body) - (case ("lux text index" 0 (static text.new_line) content) - #.None - body - - g!_ - (#.Left [[where offset source_code] - (exception.construct ..text_cannot_contain_new_lines content)]))) - -(def: (parse_text where offset source_code) - (-> Location Offset Text (Either [Source Text] [Source Code])) - (case ("lux text index" offset (static ..text_delimiter) source_code) - (#.Some g!end) - (<| (let [g!content (!clip offset g!end source_code)]) - (!guarantee_no_new_lines where offset source_code g!content) - (#.Right [[(let [size (!n/- offset g!end)] - (update@ #.column (|>> (!n/+ size) (!n/+ 2)) where)) - (!inc g!end) - source_code] - [where - (#.Text g!content)]])) - - _ - (!failure ..parse_text where offset source_code))) - -(with_expansions [<digits> (as_is "0" "1" "2" "3" "4" "5" "6" "7" "8" "9") - <non_name_chars> (template [<char>] - [(~~ (static <char>))] - - [text.space] - [text.new_line] [text.carriage_return] - [..name_separator] - [..open_form] [..close_form] - [..open_tuple] [..close_tuple] - [..open_record] [..close_record] - [..text_delimiter] - [..sigil]) - <digit_separator> (static ..digit_separator)] - (template: (!if_digit? @char @then @else) - ("lux syntax char case!" @char - [[<digits>] - @then] - - ## else - @else)) - - (template: (!if_digit?+ @char @then @else_options @else) - (`` ("lux syntax char case!" @char - [[<digits> <digit_separator>] - @then - - (~~ (template.splice @else_options))] - - ## else - @else))) - - (`` (template: (!if_name_char?|tail @char @then @else) - ("lux syntax char case!" @char - [[<non_name_chars>] - @else] - - ## else - @then))) - - (`` (template: (!if_name_char?|head @char @then @else) - ("lux syntax char case!" @char - [[<non_name_chars> <digits>] - @else] - - ## else - @then))) - ) - -(template: (!number_output <source_code> <start> <end> <codec> <tag>) - (case (|> <source_code> - (!clip <start> <end>) - (text.replace_all ..digit_separator "") - (\ <codec> decode)) - (#.Right output) - (#.Right [[(let [[where::file where::line where::column] where] - [where::file where::line (!n/+ (!n/- <start> <end>) where::column)]) - <end> - <source_code>] - [where (<tag> output)]]) - - (#.Left error) - (#.Left [[where <start> <source_code>] - error]))) - -(def: no_exponent Offset 0) - -(with_expansions [<int_output> (as_is (!number_output source_code start end int.decimal #.Int)) - <frac_output> (as_is (!number_output source_code start end frac.decimal #.Frac)) - <failure> (!failure ..parse_frac where offset source_code) - <frac_separator> (static ..frac_separator) - <signs> (template [<sign>] - [(~~ (static <sign>))] - - [..positive_sign] - [..negative_sign])] - (inline: (parse_frac source_code//size start where offset source_code) - (-> Nat Nat Location Offset Text - (Either [Source Text] [Source Code])) - (loop [end offset - exponent (static ..no_exponent)] - (<| (!with_char+ source_code//size source_code end char/0 <frac_output>) - (!if_digit?+ char/0 - (recur (!inc end) exponent) - - [["e" "E"] - (if (is? (static ..no_exponent) exponent) - (<| (!with_char+ source_code//size source_code (!inc end) char/1 <failure>) - (`` ("lux syntax char case!" char/1 - [[<signs>] - (<| (!with_char+ source_code//size source_code (!n/+ 2 end) char/2 <failure>) - (!if_digit?+ char/2 - (recur (!n/+ 3 end) char/0) - [] - <failure>))] - ## else - <failure>))) - <frac_output>)] - - <frac_output>)))) - - (inline: (parse_signed source_code//size start where offset source_code) - (-> Nat Nat Location Offset Text - (Either [Source Text] [Source Code])) - (loop [end offset] - (<| (!with_char+ source_code//size source_code end char <int_output>) - (!if_digit?+ char - (recur (!inc end)) - - [[<frac_separator>] - (parse_frac source_code//size start where (!inc end) source_code)] - - <int_output>)))) - ) - -(template [<parser> <codec> <tag>] - [(inline: (<parser> source_code//size start where offset source_code) - (-> Nat Nat Location Offset Text - (Either [Source Text] [Source Code])) - (loop [g!end offset] - (<| (!with_char+ source_code//size source_code g!end g!char (!number_output source_code start g!end <codec> <tag>)) - (!if_digit?+ g!char - (recur (!inc g!end)) - [] - (!number_output source_code start g!end <codec> <tag>)))))] - - [parse_nat n.decimal #.Nat] - [parse_rev rev.decimal #.Rev] - ) - -(template: (!parse_signed source_code//size offset where source_code @aliases @end) - (<| (let [g!offset/1 (!inc offset)]) - (!with_char+ source_code//size source_code g!offset/1 g!char/1 @end) - (!if_digit? g!char/1 - (parse_signed source_code//size offset where (!inc/2 offset) source_code) - (!parse_full_name offset [where (!inc offset) source_code] where @aliases #.Identifier)))) - -(with_expansions [<output> (#.Right [[(update@ #.column (|>> (!n/+ (!n/- start end))) where) - end - source_code] - (!clip start end source_code)])] - (inline: (parse_name_part start where offset source_code) - (-> Nat Location Offset Text - (Either [Source Text] [Source Text])) - (let [source_code//size ("lux text size" source_code)] - (loop [end offset] - (<| (!with_char+ source_code//size source_code end char <output>) - (!if_name_char?|tail char - (recur (!inc end)) - <output>)))))) - -(template: (!parse_half_name @offset @char @module) - (!if_name_char?|head @char - (!letE [source' name] (..parse_name_part @offset where (!inc @offset) source_code) - (#.Right [source' [@module name]])) - (!failure ..!parse_half_name where @offset source_code))) - -(`` (def: (parse_short_name source_code//size current_module [where offset/0 source_code]) - (-> Nat Text (Parser Name)) - (<| (!with_char+ source_code//size source_code offset/0 char/0 - (!end_of_file where offset/0 source_code current_module)) - (if (!n/= (char (~~ (static ..name_separator))) char/0) - (<| (let [offset/1 (!inc offset/0)]) - (!with_char+ source_code//size source_code offset/1 char/1 - (!end_of_file where offset/1 source_code current_module)) - (!parse_half_name offset/1 char/1 current_module)) - (!parse_half_name offset/0 char/0 (static ..prelude)))))) - -(template: (!parse_short_name source_code//size @current_module @source @where @tag) - (!letE [source' name] (..parse_short_name source_code//size @current_module @source) - (#.Right [source' [@where (@tag name)]]))) - -(with_expansions [<simple> (as_is (#.Right [source' ["" simple]]))] - (`` (def: (parse_full_name aliases start source) - (-> Aliases Offset (Parser Name)) - (<| (!letE [source' simple] (let [[where offset source_code] source] - (..parse_name_part start where offset source_code))) - (let [[where' offset' source_code'] source']) - (!with_char source_code' offset' char/separator <simple>) - (if (!n/= (char (~~ (static ..name_separator))) char/separator) - (<| (let [offset'' (!inc offset')]) - (!letE [source'' complex] (..parse_name_part offset'' (!forward 1 where') offset'' source_code')) - (if ("lux text =" "" complex) - (let [[where offset source_code] source] - (!failure ..parse_full_name where offset source_code)) - (#.Right [source'' [(|> aliases - (dictionary.get simple) - (maybe.default simple)) - complex]]))) - <simple>))))) - -(template: (!parse_full_name @offset @source @where @aliases @tag) - (!letE [source' full_name] (..parse_full_name @aliases @offset @source) - (#.Right [source' [@where (@tag full_name)]]))) - -## TODO: Grammar macro for specifying syntax. -## (grammar: lux_grammar -## [expression ...] -## [form "(" [#* expression] ")"]) - -(with_expansions [<consume_1> (as_is where (!inc offset/0) source_code) - <move_1> (as_is [(!forward 1 where) (!inc offset/0) source_code]) - <move_2> (as_is [(!forward 1 where) (!inc/2 offset/0) source_code]) - <recur> (as_is (parse current_module aliases source_code//size)) - <horizontal_move> (as_is (recur (!horizontal where offset/0 source_code)))] - - (template: (!close closer) - (#.Left [<move_1> closer])) - - (def: #export (parse current_module aliases source_code//size) - (-> Text Aliases Nat (Parser Code)) - ## The "exec []" is only there to avoid function fusion. - ## This is to preserve the loop as much as possible and keep it tight. - (exec [] - (function (recur [where offset/0 source_code]) - (<| (!with_char+ source_code//size source_code offset/0 char/0 - (!end_of_file where offset/0 source_code current_module)) - (with_expansions [<composites> (template [<open> <close> <parser>] - [[(~~ (static <open>))] - (<parser> <recur> <consume_1>) - - [(~~ (static <close>))] - (!close <close>)] - - [..open_form ..close_form parse_form] - [..open_tuple ..close_tuple parse_tuple] - [..open_record ..close_record parse_record] - )] - (`` ("lux syntax char case!" char/0 - [[(~~ (static text.space)) - (~~ (static text.carriage_return))] - <horizontal_move> - - ## New line - [(~~ (static text.new_line))] - (recur (!vertical where offset/0 source_code)) - - <composites> - - ## Text - [(~~ (static ..text_delimiter))] - (parse_text where (!inc offset/0) source_code) - - ## Special code - [(~~ (static ..sigil))] - (<| (let [offset/1 (!inc offset/0)]) - (!with_char+ source_code//size source_code offset/1 char/1 - (!end_of_file where offset/1 source_code current_module)) - ("lux syntax char case!" char/1 - [[(~~ (static ..name_separator))] - (!parse_short_name source_code//size current_module <move_2> where #.Tag) - - ## Single_line comment - [(~~ (static ..sigil))] - (case ("lux text index" (!inc offset/1) (static text.new_line) source_code) - (#.Some end) - (recur (!vertical where end source_code)) - - _ - (!end_of_file where offset/1 source_code current_module)) - - (~~ (template [<char> <bit>] - [[<char>] - (#.Right [[(update@ #.column (|>> !inc/2) where) - (!inc offset/1) - source_code] - [where (#.Bit <bit>)]])] - - ["0" #0] - ["1" #1]))] - - ## else - (!if_name_char?|head char/1 - ## Tag - (!parse_full_name offset/1 <move_2> where aliases #.Tag) - (!failure ..parse where offset/0 source_code)))) - - ## Coincidentally (= ..name_separator ..frac_separator) - [(~~ (static ..name_separator)) - ## (~~ (static ..frac_separator)) - ] - (<| (let [offset/1 (!inc offset/0)]) - (!with_char+ source_code//size source_code offset/1 char/1 - (!end_of_file where offset/1 source_code current_module)) - (!if_digit? char/1 - (parse_rev source_code//size offset/0 where (!inc offset/1) source_code) - (!parse_short_name source_code//size current_module [where offset/1 source_code] where #.Identifier))) - - [(~~ (static ..positive_sign)) - (~~ (static ..negative_sign))] - (!parse_signed source_code//size offset/0 where source_code aliases - (!end_of_file where offset/0 source_code current_module))] - - ## else - (!if_digit? char/0 - ## Natural number - (parse_nat source_code//size offset/0 where (!inc offset/0) source_code) - ## Identifier - (!parse_full_name offset/0 [<consume_1>] where aliases #.Identifier)) - ))) - ))) - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux deleted file mode 100644 index 0b2086f25..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux +++ /dev/null @@ -1,808 +0,0 @@ -(.module: - [lux (#- i64 Scope) - [abstract - [monad (#+ do)] - [equivalence (#+ Equivalence)] - [hash (#+ Hash)]] - [control - [pipe (#+ case>)] - ["." exception (#+ exception:)]] - [data - ["." sum] - ["." product] - ["." maybe] - ["." bit ("#\." equivalence)] - ["." text ("#\." equivalence) - ["%" format (#+ Format format)]] - [collection - ["." list ("#\." functor)] - ["." dictionary (#+ Dictionary)]]] - [math - [number - ["." i64] - ["n" nat] - ["i" int] - ["f" frac]]]] - [// - ["." analysis (#+ Environment Composite Analysis)] - [phase - ["." extension (#+ Extension)]] - [/// - [arity (#+ Arity)] - ["." phase] - ["." reference (#+ Reference) - ["." variable (#+ Register Variable)]]]]) - -(type: #export Resolver - (Dictionary Variable Variable)) - -(type: #export State - {#locals Nat - ## https://en.wikipedia.org/wiki/Currying - #currying? Bit}) - -(def: #export fresh_resolver - Resolver - (dictionary.new variable.hash)) - -(def: #export init - State - {#locals 0 - #currying? false}) - -(type: #export Primitive - (#Bit Bit) - (#I64 (I64 Any)) - (#F64 Frac) - (#Text Text)) - -(type: #export Side - (Either Nat Nat)) - -(type: #export Member - (Either Nat Nat)) - -(type: #export Access - (#Side Side) - (#Member Member)) - -(type: #export (Fork value next) - [[value next] (List [value next])]) - -(type: #export (Path' s) - #Pop - (#Access Access) - (#Bind Register) - (#Bit_Fork Bit (Path' s) (Maybe (Path' s))) - (#I64_Fork (Fork (I64 Any) (Path' s))) - (#F64_Fork (Fork Frac (Path' s))) - (#Text_Fork (Fork Text (Path' s))) - (#Alt (Path' s) (Path' s)) - (#Seq (Path' s) (Path' s)) - (#Then s)) - -(type: #export (Abstraction' s) - {#environment (Environment s) - #arity Arity - #body s}) - -(type: #export (Apply' s) - {#function s - #arguments (List s)}) - -(type: #export (Branch s) - (#Let s Register s) - (#If s s s) - (#Get (List Member) s) - (#Case s (Path' s))) - -(type: #export (Scope s) - {#start Register - #inits (List s) - #iteration s}) - -(type: #export (Loop s) - (#Scope (Scope s)) - (#Recur (List s))) - -(type: #export (Function s) - (#Abstraction (Abstraction' s)) - (#Apply s (List s))) - -(type: #export (Control s) - (#Branch (Branch s)) - (#Loop (Loop s)) - (#Function (Function s))) - -(type: #export #rec Synthesis - (#Primitive Primitive) - (#Structure (Composite Synthesis)) - (#Reference Reference) - (#Control (Control Synthesis)) - (#Extension (Extension Synthesis))) - -(template [<special> <general>] - [(type: #export <special> - (<general> ..State Analysis Synthesis))] - - [State+ extension.State] - [Operation extension.Operation] - [Phase extension.Phase] - [Handler extension.Handler] - [Bundle extension.Bundle] - ) - -(type: #export Path - (Path' Synthesis)) - -(def: #export path/pop - Path - #Pop) - -(template [<name> <kind>] - [(template: #export (<name> content) - (.<| #..Access - <kind> - content))] - - [path/side #..Side] - [path/member #..Member] - ) - -(template [<name> <kind> <side>] - [(template: #export (<name> content) - (.<| #..Access - <kind> - <side> - content))] - - [side/left #..Side #.Left] - [side/right #..Side #.Right] - [member/left #..Member #.Left] - [member/right #..Member #.Right] - ) - -(template [<name> <tag>] - [(template: #export (<name> content) - (<tag> content))] - - [path/bind #..Bind] - [path/then #..Then] - ) - -(template [<name> <tag>] - [(template: #export (<name> left right) - (<tag> [left right]))] - - [path/alt #..Alt] - [path/seq #..Seq] - ) - -(type: #export Abstraction - (Abstraction' Synthesis)) - -(type: #export Apply - (Apply' Synthesis)) - -(def: #export unit Text "") - -(template [<with> <query> <tag> <type>] - [(def: #export (<with> value) - (-> <type> (All [a] (-> (Operation a) (Operation a)))) - (extension.temporary (set@ <tag> value))) - - (def: #export <query> - (Operation <type>) - (extension.read (get@ <tag>)))] - - [with_locals locals #locals Nat] - [with_currying? currying? #currying? Bit] - ) - -(def: #export with_new_local - (All [a] (-> (Operation a) (Operation a))) - (<<| (do phase.monad - [locals ..locals]) - (..with_locals (inc locals)))) - -(template [<name> <tag>] - [(template: #export (<name> content) - (#..Primitive (<tag> content)))] - - [bit #..Bit] - [i64 #..I64] - [f64 #..F64] - [text #..Text] - ) - -(template [<name> <tag>] - [(template: #export (<name> content) - (<| #..Structure - <tag> - content))] - - [variant #analysis.Variant] - [tuple #analysis.Tuple] - ) - -(template [<name> <tag>] - [(template: #export (<name> content) - (.<| #..Reference - <tag> - content))] - - [variable reference.variable] - [constant reference.constant] - [variable/local reference.local] - [variable/foreign reference.foreign] - ) - -(template [<name> <family> <tag>] - [(template: #export (<name> content) - (.<| #..Control - <family> - <tag> - content))] - - [branch/case #..Branch #..Case] - [branch/let #..Branch #..Let] - [branch/if #..Branch #..If] - [branch/get #..Branch #..Get] - - [loop/recur #..Loop #..Recur] - [loop/scope #..Loop #..Scope] - - [function/abstraction #..Function #..Abstraction] - [function/apply #..Function #..Apply] - ) - -(def: #export (%path' %then value) - (All [a] (-> (Format a) (Format (Path' a)))) - (case value - #Pop - "_" - - (#Bit_Fork when then else) - (format "(?" - " " (%.bit when) " " (%path' %then then) - (case else - (#.Some else) - (format " " (%.bit (not when)) " " (%path' %then else)) - - #.None - "") - ")") - - (^template [<tag> <format>] - [(<tag> cons) - (|> (#.Cons cons) - (list\map (function (_ [test then]) - (format (<format> test) " " (%path' %then then)))) - (text.join_with " ") - (text.enclose ["(? " ")"]))]) - ([#I64_Fork (|>> .int %.int)] - [#F64_Fork %.frac] - [#Text_Fork %.text]) - - (#Access access) - (case access - (#Side side) - (case side - (#.Left lefts) - (format "(" (%.nat lefts) " #0" ")") - - (#.Right lefts) - (format "(" (%.nat lefts) " #1" ")")) - - (#Member member) - (case member - (#.Left lefts) - (format "[" (%.nat lefts) " #0" "]") - - (#.Right lefts) - (format "[" (%.nat lefts) " #1" "]"))) - - (#Bind register) - (format "(@ " (%.nat register) ")") - - (#Alt left right) - (format "(| " (%path' %then left) " " (%path' %then right) ")") - - (#Seq left right) - (format "(& " (%path' %then left) " " (%path' %then right) ")") - - (#Then then) - (|> (%then then) - (text.enclose ["(! " ")"])))) - -(def: #export (%synthesis value) - (Format Synthesis) - (case value - (#Primitive primitive) - (case primitive - (^template [<pattern> <format>] - [(<pattern> value) - (<format> value)]) - ([#Bit %.bit] - [#F64 %.frac] - [#Text %.text]) - - (#I64 value) - (%.int (.int value))) - - (#Structure structure) - (case structure - (#analysis.Variant [lefts right? content]) - (|> (%synthesis content) - (format (%.nat lefts) " " (%.bit right?) " ") - (text.enclose ["(" ")"])) - - (#analysis.Tuple members) - (|> members - (list\map %synthesis) - (text.join_with " ") - (text.enclose ["[" "]"]))) - - (#Reference reference) - (reference.format reference) - - (#Control control) - (case control - (#Function function) - (case function - (#Abstraction [environment arity body]) - (let [environment' (|> environment - (list\map %synthesis) - (text.join_with " ") - (text.enclose ["[" "]"]))] - (|> (format environment' " " (%.nat arity) " " (%synthesis body)) - (text.enclose ["(#function " ")"]))) - - (#Apply func args) - (|> args - (list\map %synthesis) - (text.join_with " ") - (format (%synthesis func) " ") - (text.enclose ["(" ")"]))) - - (#Branch branch) - (case branch - (#Let input register body) - (|> (format (%.nat register) " " (%synthesis input) " " (%synthesis body)) - (text.enclose ["(#let " ")"])) - - (#If test then else) - (|> (format (%synthesis test) " " (%synthesis then) " " (%synthesis else)) - (text.enclose ["(#if " ")"])) - - (#Get members record) - (|> (format (%.list (%path' %synthesis) - (list\map (|>> #Member #Access) members)) - " " (%synthesis record)) - (text.enclose ["(#get " ")"])) - - (#Case input path) - (|> (format (%synthesis input) " " (%path' %synthesis path)) - (text.enclose ["(#case " ")"]))) - - (#Loop loop) - (case loop - (#Scope scope) - (|> (format (%.nat (get@ #start scope)) - " " (|> (get@ #inits scope) - (list\map %synthesis) - (text.join_with " ") - (text.enclose ["[" "]"])) - " " (%synthesis (get@ #iteration scope))) - (text.enclose ["(#loop " ")"])) - - (#Recur args) - (|> args - (list\map %synthesis) - (text.join_with " ") - (text.enclose ["(#recur " ")"])))) - - (#Extension [name args]) - (|> (list\map %synthesis args) - (text.join_with " ") - (format (%.text name) " ") - (text.enclose ["(" ")"])))) - -(def: #export %path - (Format Path) - (%path' %synthesis)) - -(implementation: #export primitive_equivalence - (Equivalence Primitive) - - (def: (= reference sample) - (case [reference sample] - (^template [<tag> <eq> <format>] - [[(<tag> reference') (<tag> sample')] - (<eq> reference' sample')]) - ([#Bit bit\= %.bit] - [#F64 f.= %.frac] - [#Text text\= %.text]) - - [(#I64 reference') (#I64 sample')] - (i.= (.int reference') (.int sample')) - - _ - false))) - -(implementation: primitive_hash - (Hash Primitive) - - (def: &equivalence ..primitive_equivalence) - - (def: hash - (|>> (case> (^template [<tag> <hash>] - [(<tag> value') - (\ <hash> hash value')]) - ([#Bit bit.hash] - [#F64 f.hash] - [#Text text.hash] - [#I64 i64.hash]))))) - -(def: side_equivalence - (Equivalence Side) - (sum.equivalence n.equivalence n.equivalence)) - -(def: member_equivalence - (Equivalence Member) - (sum.equivalence n.equivalence n.equivalence)) - -(def: member_hash - (Hash Member) - (sum.hash n.hash n.hash)) - -(implementation: #export access_equivalence - (Equivalence Access) - - (def: (= reference sample) - (case [reference sample] - (^template [<tag> <equivalence>] - [[(<tag> reference) (<tag> sample)] - (\ <equivalence> = reference sample)]) - ([#Side ..side_equivalence] - [#Member ..member_equivalence]) - - _ - false))) - -(implementation: access_hash - (Hash Access) - - (def: &equivalence ..access_equivalence) - - (def: (hash value) - (let [sub_hash (sum.hash n.hash n.hash)] - (case value - (^template [<tag>] - [(<tag> value) - (\ sub_hash hash value)]) - ([#Side] - [#Member]))))) - -(implementation: #export (path'_equivalence equivalence) - (All [a] (-> (Equivalence a) (Equivalence (Path' a)))) - - (def: (= reference sample) - (case [reference sample] - [#Pop #Pop] - true - - [(#Bit_Fork reference_when reference_then reference_else) - (#Bit_Fork sample_when sample_then sample_else)] - (and (bit\= reference_when sample_when) - (= reference_then sample_then) - (\ (maybe.equivalence =) = reference_else sample_else)) - - (^template [<tag> <equivalence>] - [[(<tag> reference_cons) - (<tag> sample_cons)] - (\ (list.equivalence (product.equivalence <equivalence> =)) = - (#.Cons reference_cons) - (#.Cons sample_cons))]) - ([#I64_Fork i64.equivalence] - [#F64_Fork f.equivalence] - [#Text_Fork text.equivalence]) - - (^template [<tag> <equivalence>] - [[(<tag> reference') (<tag> sample')] - (\ <equivalence> = reference' sample')]) - ([#Access ..access_equivalence] - [#Then equivalence]) - - [(#Bind reference') (#Bind sample')] - (n.= reference' sample') - - (^template [<tag>] - [[(<tag> leftR rightR) (<tag> leftS rightS)] - (and (= leftR leftS) - (= rightR rightS))]) - ([#Alt] - [#Seq]) - - _ - false))) - -(implementation: (path'_hash super) - (All [a] (-> (Hash a) (Hash (Path' a)))) - - (def: &equivalence - (..path'_equivalence (\ super &equivalence))) - - (def: (hash value) - (case value - #Pop - 2 - - (#Access access) - (n.* 3 (\ ..access_hash hash access)) - - (#Bind register) - (n.* 5 (\ n.hash hash register)) - - (#Bit_Fork when then else) - ($_ n.* 7 - (\ bit.hash hash when) - (hash then) - (\ (maybe.hash (path'_hash super)) hash else)) - - (^template [<factor> <tag> <hash>] - [(<tag> cons) - (let [case_hash (product.hash <hash> - (path'_hash super)) - cons_hash (product.hash case_hash (list.hash case_hash))] - (n.* <factor> (\ cons_hash hash cons)))]) - ([11 #I64_Fork i64.hash] - [13 #F64_Fork f.hash] - [17 #Text_Fork text.hash]) - - (^template [<factor> <tag>] - [(<tag> fork) - (let [recur_hash (path'_hash super) - fork_hash (product.hash recur_hash recur_hash)] - (n.* <factor> (\ fork_hash hash fork)))]) - ([19 #Alt] - [23 #Seq]) - - (#Then body) - (n.* 29 (\ super hash body)) - ))) - -(implementation: (branch_equivalence (^open "\.")) - (All [a] (-> (Equivalence a) (Equivalence (Branch a)))) - - (def: (= reference sample) - (case [reference sample] - [(#Let [reference_input reference_register reference_body]) - (#Let [sample_input sample_register sample_body])] - (and (\= reference_input sample_input) - (n.= reference_register sample_register) - (\= reference_body sample_body)) - - [(#If [reference_test reference_then reference_else]) - (#If [sample_test sample_then sample_else])] - (and (\= reference_test sample_test) - (\= reference_then sample_then) - (\= reference_else sample_else)) - - [(#Get [reference_path reference_record]) - (#Get [sample_path sample_record])] - (and (\ (list.equivalence ..member_equivalence) = reference_path sample_path) - (\= reference_record sample_record)) - - [(#Case [reference_input reference_path]) - (#Case [sample_input sample_path])] - (and (\= reference_input sample_input) - (\ (path'_equivalence \=) = reference_path sample_path)) - - _ - false))) - -(implementation: (branch_hash super) - (All [a] (-> (Hash a) (Hash (Branch a)))) - - (def: &equivalence - (..branch_equivalence (\ super &equivalence))) - - (def: (hash value) - (case value - (#Let [input register body]) - ($_ n.* 2 - (\ super hash input) - (\ n.hash hash register) - (\ super hash body)) - - (#If [test then else]) - ($_ n.* 3 - (\ super hash test) - (\ super hash then) - (\ super hash else)) - - (#Get [path record]) - ($_ n.* 5 - (\ (list.hash ..member_hash) hash path) - (\ super hash record)) - - (#Case [input path]) - ($_ n.* 7 - (\ super hash input) - (\ (..path'_hash super) hash path)) - ))) - -(implementation: (loop_equivalence (^open "\.")) - (All [a] (-> (Equivalence a) (Equivalence (Loop a)))) - - (def: (= reference sample) - (case [reference sample] - [(#Scope [reference_start reference_inits reference_iteration]) - (#Scope [sample_start sample_inits sample_iteration])] - (and (n.= reference_start sample_start) - (\ (list.equivalence \=) = reference_inits sample_inits) - (\= reference_iteration sample_iteration)) - - [(#Recur reference) (#Recur sample)] - (\ (list.equivalence \=) = reference sample) - - _ - false))) - -(implementation: (loop_hash super) - (All [a] (-> (Hash a) (Hash (Loop a)))) - - (def: &equivalence - (..loop_equivalence (\ super &equivalence))) - - (def: (hash value) - (case value - (#Scope [start inits iteration]) - ($_ n.* 2 - (\ n.hash hash start) - (\ (list.hash super) hash inits) - (\ super hash iteration)) - - (#Recur resets) - ($_ n.* 3 - (\ (list.hash super) hash resets)) - ))) - -(implementation: (function_equivalence (^open "\.")) - (All [a] (-> (Equivalence a) (Equivalence (Function a)))) - - (def: (= reference sample) - (case [reference sample] - [(#Abstraction [reference_environment reference_arity reference_body]) - (#Abstraction [sample_environment sample_arity sample_body])] - (and (\ (list.equivalence \=) = reference_environment sample_environment) - (n.= reference_arity sample_arity) - (\= reference_body sample_body)) - - [(#Apply [reference_abstraction reference_arguments]) - (#Apply [sample_abstraction sample_arguments])] - (and (\= reference_abstraction sample_abstraction) - (\ (list.equivalence \=) = reference_arguments sample_arguments)) - - _ - false))) - -(implementation: (function_hash super) - (All [a] (-> (Hash a) (Hash (Function a)))) - - (def: &equivalence - (..function_equivalence (\ super &equivalence))) - - (def: (hash value) - (case value - (#Abstraction [environment arity body]) - ($_ n.* 2 - (\ (list.hash super) hash environment) - (\ n.hash hash arity) - (\ super hash body)) - - (#Apply [abstraction arguments]) - ($_ n.* 3 - (\ super hash abstraction) - (\ (list.hash super) hash arguments)) - ))) - -(implementation: (control_equivalence (^open "\.")) - (All [a] (-> (Equivalence a) (Equivalence (Control a)))) - - (def: (= reference sample) - (case [reference sample] - (^template [<tag> <equivalence>] - [[(<tag> reference) (<tag> sample)] - (\ (<equivalence> \=) = reference sample)]) - ([#Branch ..branch_equivalence] - [#Loop ..loop_equivalence] - [#Function ..function_equivalence]) - - _ - false))) - -(implementation: (control_hash super) - (All [a] (-> (Hash a) (Hash (Control a)))) - - (def: &equivalence - (..control_equivalence (\ super &equivalence))) - - (def: (hash value) - (case value - (^template [<factor> <tag> <hash>] - [(<tag> value) - (n.* <factor> (\ (<hash> super) hash value))]) - ([2 #Branch ..branch_hash] - [3 #Loop ..loop_hash] - [5 #Function ..function_hash]) - ))) - -(implementation: #export equivalence - (Equivalence Synthesis) - - (def: (= reference sample) - (case [reference sample] - (^template [<tag> <equivalence>] - [[(<tag> reference') (<tag> sample')] - (\ <equivalence> = reference' sample')]) - ([#Primitive ..primitive_equivalence] - [#Structure (analysis.composite_equivalence =)] - [#Reference reference.equivalence] - [#Control (control_equivalence =)] - [#Extension (extension.equivalence =)]) - - _ - false))) - -(def: #export path_equivalence - (Equivalence Path) - (path'_equivalence equivalence)) - -(implementation: #export hash - (Hash Synthesis) - - (def: &equivalence ..equivalence) - - (def: (hash value) - (let [recur_hash [..equivalence hash]] - (case value - (^template [<tag> <hash>] - [(<tag> value) - (\ <hash> hash value)]) - ([#Primitive ..primitive_hash] - [#Structure (analysis.composite_hash recur_hash)] - [#Reference reference.hash] - [#Control (..control_hash recur_hash)] - [#Extension (extension.hash recur_hash)]))))) - -(template: #export (!bind_top register thenP) - ($_ ..path/seq - (#..Bind register) - #..Pop - thenP)) - -(template: #export (!multi_pop nextP) - ($_ ..path/seq - #..Pop - #..Pop - nextP)) - -## TODO: There are sister patterns to the simple side checks for tuples. -## These correspond to the situation where tuple members are accessed -## and bound to variables, but those variables are never used, so they -## become POPs. -## After re-implementing unused-variable-elimination, must add those -## pattern-optimizations again, since a lot of BINDs will become POPs -## and thus will result in useless code being generated. -(template [<name> <side>] - [(template: #export (<name> idx nextP) - ($_ ..path/seq - (<side> idx) - #..Pop - nextP))] - - [simple_left_side ..side/left] - [simple_right_side ..side/right] - ) diff --git a/stdlib/source/lux/tool/compiler/language/lux/version.lux b/stdlib/source/lux/tool/compiler/language/lux/version.lux deleted file mode 100644 index 53b3424ae..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/version.lux +++ /dev/null @@ -1,8 +0,0 @@ -(.module: - [lux #*] - [//// - [version (#+ Version)]]) - -(def: #export version - Version - 00,06,00) diff --git a/stdlib/source/lux/tool/compiler/meta.lux b/stdlib/source/lux/tool/compiler/meta.lux deleted file mode 100644 index df3eb31a7..000000000 --- a/stdlib/source/lux/tool/compiler/meta.lux +++ /dev/null @@ -1,8 +0,0 @@ -(.module: - [lux #*] - [// - [version (#+ Version)]]) - -(def: #export version - Version - 00,01,00) diff --git a/stdlib/source/lux/tool/compiler/meta/archive.lux b/stdlib/source/lux/tool/compiler/meta/archive.lux deleted file mode 100644 index 09b501ef3..000000000 --- a/stdlib/source/lux/tool/compiler/meta/archive.lux +++ /dev/null @@ -1,279 +0,0 @@ -(.module: - [lux (#- Module) - [abstract - ["." equivalence (#+ Equivalence)] - ["." monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["." function] - ["<>" parser - ["<b>" binary (#+ Parser)]]] - [data - [binary (#+ Binary)] - ["." product] - ["." name] - ["." text - ["%" format (#+ format)]] - [format - ["." binary (#+ Writer)]] - [collection - ["." list ("#\." functor fold)] - ["." dictionary (#+ Dictionary)] - ["." set] - ["." row (#+ Row)]]] - [math - [number - ["n" nat ("#\." equivalence)]]] - [type - abstract]] - [/ - ["." artifact] - ["." signature (#+ Signature)] - ["." key (#+ Key)] - ["." descriptor (#+ Module Descriptor)] - ["." document (#+ Document)] - [/// - [version (#+ Version)]]]) - -(type: #export Output - (Row [artifact.ID Binary])) - -(exception: #export (unknown_document {module Module} - {known_modules (List Module)}) - (exception.report - ["Module" (%.text module)] - ["Known Modules" (exception.enumerate %.text known_modules)])) - -(exception: #export (cannot_replace_document {module Module} - {old (Document Any)} - {new (Document Any)}) - (exception.report - ["Module" (%.text module)] - ["Old key" (signature.description (document.signature old))] - ["New key" (signature.description (document.signature new))])) - -(exception: #export (module_has_already_been_reserved {module Module}) - (exception.report - ["Module" (%.text module)])) - -(exception: #export (module_must_be_reserved_before_it_can_be_added {module Module}) - (exception.report - ["Module" (%.text module)])) - -(exception: #export (module_is_only_reserved {module Module}) - (exception.report - ["Module" (%.text module)])) - -(type: #export ID - Nat) - -(def: #export runtime_module - Module - "") - -(abstract: #export Archive - {#next ID - #resolver (Dictionary Module [ID (Maybe [Descriptor (Document Any) Output])])} - - (def: next - (-> Archive ID) - (|>> :representation (get@ #next))) - - (def: #export empty - Archive - (:abstraction {#next 0 - #resolver (dictionary.new text.hash)})) - - (def: #export (id module archive) - (-> Module Archive (Try ID)) - (let [(^slots [#..resolver]) (:representation archive)] - (case (dictionary.get module resolver) - (#.Some [id _]) - (#try.Success id) - - #.None - (exception.throw ..unknown_document [module - (dictionary.keys resolver)])))) - - (def: #export (reserve module archive) - (-> Module Archive (Try [ID Archive])) - (let [(^slots [#..next #..resolver]) (:representation archive)] - (case (dictionary.get module resolver) - (#.Some _) - (exception.throw ..module_has_already_been_reserved [module]) - - #.None - (#try.Success [next - (|> archive - :representation - (update@ #..resolver (dictionary.put module [next #.None])) - (update@ #..next inc) - :abstraction)])))) - - (def: #export (add module [descriptor document output] archive) - (-> Module [Descriptor (Document Any) Output] Archive (Try Archive)) - (let [(^slots [#..resolver]) (:representation archive)] - (case (dictionary.get module resolver) - (#.Some [id #.None]) - (#try.Success (|> archive - :representation - (update@ #..resolver (dictionary.put module [id (#.Some [descriptor document output])])) - :abstraction)) - - (#.Some [id (#.Some [existing_descriptor existing_document existing_output])]) - (if (is? document existing_document) - ## TODO: Find out why this code allows for the same module to be added more than once. It looks fishy... - (#try.Success archive) - (exception.throw ..cannot_replace_document [module existing_document document])) - - #.None - (exception.throw ..module_must_be_reserved_before_it_can_be_added [module])))) - - (def: #export (find module archive) - (-> Module Archive (Try [Descriptor (Document Any) Output])) - (let [(^slots [#..resolver]) (:representation archive)] - (case (dictionary.get module resolver) - (#.Some [id (#.Some entry)]) - (#try.Success entry) - - (#.Some [id #.None]) - (exception.throw ..module_is_only_reserved [module]) - - #.None - (exception.throw ..unknown_document [module - (dictionary.keys resolver)])))) - - (def: #export (archived? archive module) - (-> Archive Module Bit) - (case (..find module archive) - (#try.Success _) - yes - - (#try.Failure _) - no)) - - (def: #export archived - (-> Archive (List Module)) - (|>> :representation - (get@ #resolver) - dictionary.entries - (list.all (function (_ [module [id descriptor+document]]) - (case descriptor+document - (#.Some _) (#.Some module) - #.None #.None))))) - - (def: #export (reserved? archive module) - (-> Archive Module Bit) - (let [(^slots [#..resolver]) (:representation archive)] - (case (dictionary.get module resolver) - (#.Some [id _]) - yes - - #.None - no))) - - (def: #export reserved - (-> Archive (List Module)) - (|>> :representation - (get@ #resolver) - dictionary.keys)) - - (def: #export reservations - (-> Archive (List [Module ID])) - (|>> :representation - (get@ #resolver) - dictionary.entries - (list\map (function (_ [module [id _]]) - [module id])))) - - (def: #export (merge additions archive) - (-> Archive Archive Archive) - (let [[+next +resolver] (:representation additions)] - (|> archive - :representation - (update@ #next (n.max +next)) - (update@ #resolver (function (_ resolver) - (list\fold (function (_ [module [id entry]] resolver) - (case entry - (#.Some _) - (dictionary.put module [id entry] resolver) - - #.None - resolver)) - resolver - (dictionary.entries +resolver)))) - :abstraction))) - - (type: Reservation [Module ID]) - (type: Frozen [Version ID (List Reservation)]) - - (def: reader - (Parser ..Frozen) - ($_ <>.and - <b>.nat - <b>.nat - (<b>.list (<>.and <b>.text <b>.nat)))) - - (def: writer - (Writer ..Frozen) - ($_ binary.and - binary.nat - binary.nat - (binary.list (binary.and binary.text binary.nat)))) - - (def: #export (export version archive) - (-> Version Archive Binary) - (let [(^slots [#..next #..resolver]) (:representation archive)] - (|> resolver - dictionary.entries - (list.all (function (_ [module [id descriptor+document]]) - (case descriptor+document - (#.Some _) (#.Some [module id]) - #.None #.None))) - [version next] - (binary.run ..writer)))) - - (exception: #export (version_mismatch {expected Version} {actual Version}) - (exception.report - ["Expected" (%.nat expected)] - ["Actual" (%.nat actual)])) - - (exception: #export corrupt_data) - - (def: (correct_modules? reservations) - (-> (List Reservation) Bit) - (n.= (list.size reservations) - (|> reservations - (list\map product.left) - (set.from_list text.hash) - set.size))) - - (def: (correct_ids? reservations) - (-> (List Reservation) Bit) - (n.= (list.size reservations) - (|> reservations - (list\map product.right) - (set.from_list n.hash) - set.size))) - - (def: (correct_reservations? reservations) - (-> (List Reservation) Bit) - (and (correct_modules? reservations) - (correct_ids? reservations))) - - (def: #export (import expected binary) - (-> Version Binary (Try Archive)) - (do try.monad - [[actual next reservations] (<b>.run ..reader binary) - _ (exception.assert ..version_mismatch [expected actual] - (n\= expected actual)) - _ (exception.assert ..corrupt_data [] - (correct_reservations? reservations))] - (wrap (:abstraction - {#next next - #resolver (list\fold (function (_ [module id] archive) - (dictionary.put module [id #.None] archive)) - (get@ #resolver (:representation ..empty)) - reservations)})))) - ) diff --git a/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux b/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux deleted file mode 100644 index 5592df470..000000000 --- a/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux +++ /dev/null @@ -1,154 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - [pipe (#+ case>)] - ["." exception (#+ exception:)] - ["<>" parser - ["<b>" binary (#+ Parser)]]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list] - ["." row (#+ Row) ("#\." functor fold)] - ["." dictionary (#+ Dictionary)]] - [format - ["." binary (#+ Writer)]]] - [type - abstract]]) - -(type: #export ID - Nat) - -(type: #export Category - #Anonymous - (#Definition Text) - (#Analyser Text) - (#Synthesizer Text) - (#Generator Text) - (#Directive Text)) - -(type: #export Artifact - {#id ID - #category Category}) - -(abstract: #export Registry - {#artifacts (Row Artifact) - #resolver (Dictionary Text ID)} - - (def: #export empty - Registry - (:abstraction {#artifacts row.empty - #resolver (dictionary.new text.hash)})) - - (def: #export artifacts - (-> Registry (Row Artifact)) - (|>> :representation (get@ #artifacts))) - - (def: next - (-> Registry ID) - (|>> ..artifacts row.size)) - - (def: #export (resource registry) - (-> Registry [ID Registry]) - (let [id (..next registry)] - [id - (|> registry - :representation - (update@ #artifacts (row.add {#id id - #category #Anonymous})) - :abstraction)])) - - (template [<tag> <create> <fetch>] - [(def: #export (<create> name registry) - (-> Text Registry [ID Registry]) - (let [id (..next registry)] - [id - (|> registry - :representation - (update@ #artifacts (row.add {#id id - #category (<tag> name)})) - (update@ #resolver (dictionary.put name id)) - :abstraction)])) - - (def: #export (<fetch> registry) - (-> Registry (List Text)) - (|> registry - :representation - (get@ #artifacts) - row.to_list - (list.all (|>> (get@ #category) - (case> (<tag> name) (#.Some name) - _ #.None)))))] - - [#Definition definition definitions] - [#Analyser analyser analysers] - [#Synthesizer synthesizer synthesizers] - [#Generator generator generators] - [#Directive directive directives] - ) - - (def: #export (remember name registry) - (-> Text Registry (Maybe ID)) - (|> (:representation registry) - (get@ #resolver) - (dictionary.get name))) - - (def: #export writer - (Writer Registry) - (let [category (: (Writer Category) - (function (_ value) - (case value - (^template [<nat> <tag> <writer>] - [(<tag> value) ((binary.and binary.nat <writer>) [<nat> value])]) - ([0 #Anonymous binary.any] - [1 #Definition binary.text] - [2 #Analyser binary.text] - [3 #Synthesizer binary.text] - [4 #Generator binary.text] - [5 #Directive binary.text])))) - artifacts (: (Writer (Row Category)) - (binary.row/64 category))] - (|>> :representation - (get@ #artifacts) - (row\map (get@ #category)) - artifacts))) - - (exception: #export (invalid_category {tag Nat}) - (exception.report - ["Tag" (%.nat tag)])) - - (def: #export parser - (Parser Registry) - (let [category (: (Parser Category) - (do {! <>.monad} - [tag <b>.nat] - (case tag - 0 (\ ! map (|>> #Anonymous) <b>.any) - 1 (\ ! map (|>> #Definition) <b>.text) - 2 (\ ! map (|>> #Analyser) <b>.text) - 3 (\ ! map (|>> #Synthesizer) <b>.text) - 4 (\ ! map (|>> #Generator) <b>.text) - 5 (\ ! map (|>> #Directive) <b>.text) - _ (<>.fail (exception.construct ..invalid_category [tag])))))] - (|> (<b>.row/64 category) - (\ <>.monad map (row\fold (function (_ artifact registry) - (product.right - (case artifact - #Anonymous - (..resource registry) - - (^template [<tag> <create>] - [(<tag> name) - (<create> name registry)]) - ([#Definition ..definition] - [#Analyser ..analyser] - [#Synthesizer ..synthesizer] - [#Generator ..generator] - [#Directive ..directive]) - ))) - ..empty))))) - ) diff --git a/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux b/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux deleted file mode 100644 index a31f6e793..000000000 --- a/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux +++ /dev/null @@ -1,48 +0,0 @@ -(.module: - [lux (#- Module) - [control - ["<>" parser - ["<b>" binary (#+ Parser)]]] - [data - ["." text] - [collection - [set (#+ Set)]] - [format - ["." binary (#+ Writer)]]] - [world - [file (#+ Path)]]] - [// - ["." artifact (#+ Registry)]]) - -(type: #export Module - Text) - -(type: #export Descriptor - {#name Module - #file Path - #hash Nat - #state Module_State - #references (Set Module) - #registry Registry}) - -(def: #export writer - (Writer Descriptor) - ($_ binary.and - binary.text - binary.text - binary.nat - binary.any - (binary.set binary.text) - artifact.writer - )) - -(def: #export parser - (Parser Descriptor) - ($_ <>.and - <b>.text - <b>.text - <b>.nat - (\ <>.monad wrap #.Cached) - (<b>.set text.hash <b>.text) - artifact.parser - )) diff --git a/stdlib/source/lux/tool/compiler/meta/archive/document.lux b/stdlib/source/lux/tool/compiler/meta/archive/document.lux deleted file mode 100644 index b60d77246..000000000 --- a/stdlib/source/lux/tool/compiler/meta/archive/document.lux +++ /dev/null @@ -1,71 +0,0 @@ -(.module: - [lux (#- Module) - [abstract - [monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["<>" parser - [binary (#+ Parser)]]] - [data - [collection - ["." dictionary (#+ Dictionary)]] - [format - ["." binary (#+ Writer)]]] - [type (#+ :share) - abstract]] - [// - ["." signature (#+ Signature)] - ["." key (#+ Key)] - [descriptor (#+ Module)]]) - -(exception: #export (invalid-signature {expected Signature} {actual Signature}) - (exception.report - ["Expected" (signature.description expected)] - ["Actual" (signature.description actual)])) - -(abstract: #export (Document d) - {#signature Signature - #content d} - - (def: #export (read key document) - (All [d] (-> (Key d) (Document Any) (Try d))) - (let [[document//signature document//content] (:representation document)] - (if (\ signature.equivalence = - (key.signature key) - document//signature) - (#try.Success (:share [e] - (Key e) - key - - e - (:assume document//content))) - (exception.throw ..invalid-signature [(key.signature key) - document//signature])))) - - (def: #export (write key content) - (All [d] (-> (Key d) d (Document d))) - (:abstraction {#signature (key.signature key) - #content content})) - - (def: #export (check key document) - (All [d] (-> (Key d) (Document Any) (Try (Document d)))) - (do try.monad - [_ (..read key document)] - (wrap (:assume document)))) - - (def: #export signature - (-> (Document Any) Signature) - (|>> :representation (get@ #signature))) - - (def: #export (writer content) - (All [d] (-> (Writer d) (Writer (Document d)))) - (let [writer (binary.and signature.writer - content)] - (|>> :representation writer))) - - (def: #export parser - (All [d] (-> (Parser d) (Parser (Document d)))) - (|>> (<>.and signature.parser) - (\ <>.monad map (|>> :abstraction)))) - ) diff --git a/stdlib/source/lux/tool/compiler/meta/archive/key.lux b/stdlib/source/lux/tool/compiler/meta/archive/key.lux deleted file mode 100644 index 1f30e105b..000000000 --- a/stdlib/source/lux/tool/compiler/meta/archive/key.lux +++ /dev/null @@ -1,18 +0,0 @@ -(.module: - [lux #* - [type - abstract]] - [// - [signature (#+ Signature)]]) - -(abstract: #export (Key k) - Signature - - (def: #export signature - (-> (Key Any) Signature) - (|>> :representation)) - - (def: #export (key signature sample) - (All [d] (-> Signature d (Key d))) - (:abstraction signature)) - ) diff --git a/stdlib/source/lux/tool/compiler/meta/archive/signature.lux b/stdlib/source/lux/tool/compiler/meta/archive/signature.lux deleted file mode 100644 index 8956f99ec..000000000 --- a/stdlib/source/lux/tool/compiler/meta/archive/signature.lux +++ /dev/null @@ -1,41 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)]] - [control - ["<>" parser - ["<b>" binary (#+ Parser)]]] - [data - ["." product] - ["." name] - ["." text - ["%" format (#+ format)]] - [format - ["." binary (#+ Writer)]]] - [math - [number - ["." nat]]]] - [//// - [version (#+ Version)]]) - -(type: #export Signature - {#name Name - #version Version}) - -(def: #export equivalence - (Equivalence Signature) - (product.equivalence name.equivalence nat.equivalence)) - -(def: #export (description signature) - (-> Signature Text) - (format (%.name (get@ #name signature)) " " (%.nat (get@ #version signature)))) - -(def: #export writer - (Writer Signature) - (binary.and (binary.and binary.text binary.text) - binary.nat)) - -(def: #export parser - (Parser Signature) - (<>.and (<>.and <b>.text <b>.text) - <b>.nat)) diff --git a/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux b/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux deleted file mode 100644 index 2a9389235..000000000 --- a/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux +++ /dev/null @@ -1,96 +0,0 @@ -(.module: - [lux (#- Module) - [abstract - ["." monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." state] - ["." function - ["." memo (#+ Memo)]]] - [data - ["." maybe ("#\." functor)] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." dictionary (#+ Dictionary)] - ["." set (#+ Set)]]]] - [/// - ["." archive (#+ Output Archive) - [key (#+ Key)] - ["." descriptor (#+ Module Descriptor)] - ["." document (#+ Document)]]]) - -(type: Ancestry - (Set Module)) - -(def: fresh - Ancestry - (set.new text.hash)) - -(type: #export Graph - (Dictionary Module Ancestry)) - -(def: empty - Graph - (dictionary.new text.hash)) - -(def: #export modules - (-> Graph (List Module)) - dictionary.keys) - -(type: Dependency - {#module Module - #imports Ancestry}) - -(def: #export graph - (-> (List Dependency) Graph) - (list\fold (function (_ [module imports] graph) - (dictionary.put module imports graph)) - ..empty)) - -(def: (ancestry archive) - (-> Archive Graph) - (let [memo (: (Memo Module Ancestry) - (function (_ recur module) - (do {! state.monad} - [#let [parents (case (archive.find module archive) - (#try.Success [descriptor document]) - (get@ #descriptor.references descriptor) - - (#try.Failure error) - ..fresh)] - ancestors (monad.map ! recur (set.to_list parents))] - (wrap (list\fold set.union parents ancestors))))) - ancestry (memo.open memo)] - (list\fold (function (_ module memory) - (if (dictionary.key? memory module) - memory - (let [[memory _] (ancestry [memory module])] - memory))) - ..empty - (archive.archived archive)))) - -(def: (dependency? ancestry target source) - (-> Graph Module Module Bit) - (let [target_ancestry (|> ancestry - (dictionary.get target) - (maybe.default ..fresh))] - (set.member? target_ancestry source))) - -(type: #export Order - (List [Module [archive.ID [Descriptor (Document .Module) Output]]])) - -(def: #export (load_order key archive) - (-> (Key .Module) Archive (Try Order)) - (let [ancestry (..ancestry archive)] - (|> ancestry - dictionary.keys - (list.sort (..dependency? ancestry)) - (monad.map try.monad - (function (_ module) - (do try.monad - [module_id (archive.id module archive) - [descriptor document output] (archive.find module archive) - document (document.check key document)] - (wrap [module [module_id [descriptor document output]]]))))))) diff --git a/stdlib/source/lux/tool/compiler/meta/io.lux b/stdlib/source/lux/tool/compiler/meta/io.lux deleted file mode 100644 index 6bafa0a79..000000000 --- a/stdlib/source/lux/tool/compiler/meta/io.lux +++ /dev/null @@ -1,19 +0,0 @@ -(.module: - [lux (#- Code) - [data - ["." text]] - [world - [file (#+ Path System)]]]) - -(type: #export Context - Path) - -(type: #export Code - Text) - -(def: #export (sanitize system) - (All [m] (-> (System m) Text Text)) - (text.replace_all "/" (\ system separator))) - -(def: #export lux_context - "lux") diff --git a/stdlib/source/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/lux/tool/compiler/meta/io/archive.lux deleted file mode 100644 index 1ff603267..000000000 --- a/stdlib/source/lux/tool/compiler/meta/io/archive.lux +++ /dev/null @@ -1,449 +0,0 @@ -(.module: - [lux (#- Module) - [target (#+ Target)] - [abstract - [predicate (#+ Predicate)] - ["." monad (#+ do)]] - [control - [pipe (#+ case>)] - ["." try (#+ Try)] - ["." exception (#+ exception:)] - [concurrency - ["." promise (#+ Promise) ("#\." monad)]] - ["<>" parser - ["<.>" binary (#+ Parser)]]] - [data - [binary (#+ Binary)] - ["." product] - ["." text ("#\." equivalence) - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." dictionary (#+ Dictionary)] - ["." row (#+ Row)] - ["." set]]] - [math - [number - ["n" nat]]] - [world - ["." file]]] - [program - [compositor - [import (#+ Import)] - ["." static (#+ Static)]]] - ["." // (#+ Context) - ["#." context] - ["/#" // - ["." archive (#+ Output Archive) - ["." artifact (#+ Artifact)] - ["." descriptor (#+ Module Descriptor)] - ["." document (#+ Document)]] - [cache - ["." dependency]] - ["/#" // (#+ Input) - [language - ["$" lux - ["." version] - ["." analysis] - ["." synthesis] - ["." generation] - ["." directive] - ["#/." program]]]]]]) - -(exception: #export (cannot_prepare {archive file.Path} - {module_id archive.ID} - {error Text}) - (exception.report - ["Archive" archive] - ["Module ID" (%.nat module_id)] - ["Error" error])) - -(def: (archive fs static) - (All [!] (-> (file.System !) Static file.Path)) - (format (get@ #static.target static) - (\ fs separator) - (get@ #static.host static))) - -(def: (unversioned_lux_archive fs static) - (All [!] (-> (file.System !) Static file.Path)) - (format (..archive fs static) - (\ fs separator) - //.lux_context)) - -(def: (versioned_lux_archive fs static) - (All [!] (-> (file.System !) Static file.Path)) - (format (..unversioned_lux_archive fs static) - (\ fs separator) - (%.nat version.version))) - -(def: (module fs static module_id) - (All [!] (-> (file.System !) Static archive.ID file.Path)) - (format (..versioned_lux_archive fs static) - (\ fs separator) - (%.nat module_id))) - -(def: #export (artifact fs static module_id artifact_id) - (All [!] (-> (file.System !) Static archive.ID artifact.ID file.Path)) - (format (..module fs static module_id) - (\ fs separator) - (%.nat artifact_id) - (get@ #static.artifact_extension static))) - -(def: (ensure_directory fs path) - (-> (file.System Promise) file.Path (Promise (Try Any))) - (do promise.monad - [? (\ fs directory? path)] - (if ? - (wrap (#try.Success [])) - (\ fs make_directory path)))) - -(def: #export (prepare fs static module_id) - (-> (file.System Promise) Static archive.ID (Promise (Try Any))) - (do {! promise.monad} - [#let [module (..module fs static module_id)] - module_exists? (\ fs directory? module)] - (if module_exists? - (wrap (#try.Success [])) - (do (try.with !) - [_ (ensure_directory fs (..unversioned_lux_archive fs static)) - _ (ensure_directory fs (..versioned_lux_archive fs static))] - (|> module - (\ fs make_directory) - (\ ! map (|>> (case> (#try.Success output) - (#try.Success []) - - (#try.Failure error) - (exception.throw ..cannot_prepare [(..archive fs static) - module_id - error]))))))))) - -(def: #export (write fs static module_id artifact_id content) - (-> (file.System Promise) Static archive.ID artifact.ID Binary (Promise (Try Any))) - (\ fs write content (..artifact fs static module_id artifact_id))) - -(def: #export (enable fs static) - (-> (file.System Promise) Static (Promise (Try Any))) - (do (try.with promise.monad) - [_ (..ensure_directory fs (get@ #static.target static))] - (..ensure_directory fs (..archive fs static)))) - -(def: (general_descriptor fs static) - (-> (file.System Promise) Static file.Path) - (format (..archive fs static) - (\ fs separator) - "general_descriptor")) - -(def: #export (freeze fs static archive) - (-> (file.System Promise) Static Archive (Promise (Try Any))) - (\ fs write (archive.export ///.version archive) (..general_descriptor fs static))) - -(def: module_descriptor_file - "module_descriptor") - -(def: (module_descriptor fs static module_id) - (-> (file.System Promise) Static archive.ID file.Path) - (format (..module fs static module_id) - (\ fs separator) - ..module_descriptor_file)) - -(def: #export (cache fs static module_id content) - (-> (file.System Promise) Static archive.ID Binary (Promise (Try Any))) - (\ fs write content (..module_descriptor fs static module_id))) - -(def: (read_module_descriptor fs static module_id) - (-> (file.System Promise) Static archive.ID (Promise (Try Binary))) - (\ fs read (..module_descriptor fs static module_id))) - -(def: parser - (Parser [Descriptor (Document .Module)]) - (<>.and descriptor.parser - (document.parser $.parser))) - -(def: (fresh_analysis_state host) - (-> Target .Lux) - (analysis.state (analysis.info version.version host))) - -(def: (analysis_state host archive) - (-> Target Archive (Try .Lux)) - (do {! try.monad} - [modules (: (Try (List [Module .Module])) - (monad.map ! (function (_ module) - (do ! - [[descriptor document output] (archive.find module archive) - content (document.read $.key document)] - (wrap [module content]))) - (archive.archived archive)))] - (wrap (set@ #.modules modules (fresh_analysis_state host))))) - -(def: (cached_artifacts fs static module_id) - (-> (file.System Promise) Static archive.ID (Promise (Try (Dictionary Text Binary)))) - (let [! (try.with promise.monad)] - (|> (..module fs static module_id) - (\ fs directory_files) - (\ ! map (|>> (list\map (function (_ file) - [(file.name fs file) file])) - (list.filter (|>> product.left (text\= ..module_descriptor_file) not)) - (monad.map ! (function (_ [name path]) - (|> path - (\ fs read) - (\ ! map (|>> [name]))))) - (\ ! map (dictionary.from_list text.hash)))) - (\ ! join)))) - -(type: Definitions (Dictionary Text Any)) -(type: Analysers (Dictionary Text analysis.Handler)) -(type: Synthesizers (Dictionary Text synthesis.Handler)) -(type: Generators (Dictionary Text generation.Handler)) -(type: Directives (Dictionary Text directive.Handler)) - -(type: Bundles - [Analysers - Synthesizers - Generators - Directives]) - -(def: empty_bundles - Bundles - [(dictionary.new text.hash) - (dictionary.new text.hash) - (dictionary.new text.hash) - (dictionary.new text.hash)]) - -(def: (loaded_document extension host module_id expected actual document) - (All [expression directive] - (-> Text (generation.Host expression directive) archive.ID (Row Artifact) (Dictionary Text Binary) (Document .Module) - (Try [(Document .Module) Bundles]))) - (do {! try.monad} - [[definitions bundles] (: (Try [Definitions Bundles]) - (loop [input (row.to_list expected) - definitions (: Definitions - (dictionary.new text.hash)) - bundles ..empty_bundles] - (let [[analysers synthesizers generators directives] bundles] - (case input - (#.Cons [[artifact_id artifact_category] input']) - (case (do ! - [data (try.from_maybe (dictionary.get (format (%.nat artifact_id) extension) actual)) - #let [context [module_id artifact_id] - directive (\ host ingest context data)]] - (case artifact_category - #artifact.Anonymous - (do ! - [_ (\ host re_learn context directive)] - (wrap [definitions - [analysers - synthesizers - generators - directives]])) - - (#artifact.Definition name) - (if (text\= $/program.name name) - (wrap [definitions - [analysers - synthesizers - generators - directives]]) - (do ! - [value (\ host re_load context directive)] - (wrap [(dictionary.put name value definitions) - [analysers - synthesizers - generators - directives]]))) - - (#artifact.Analyser extension) - (do ! - [value (\ host re_load context directive)] - (wrap [definitions - [(dictionary.put extension (:as analysis.Handler value) analysers) - synthesizers - generators - directives]])) - - (#artifact.Synthesizer extension) - (do ! - [value (\ host re_load context directive)] - (wrap [definitions - [analysers - (dictionary.put extension (:as synthesis.Handler value) synthesizers) - generators - directives]])) - - (#artifact.Generator extension) - (do ! - [value (\ host re_load context directive)] - (wrap [definitions - [analysers - synthesizers - (dictionary.put extension (:as generation.Handler value) generators) - directives]])) - - (#artifact.Directive extension) - (do ! - [value (\ host re_load context directive)] - (wrap [definitions - [analysers - synthesizers - generators - (dictionary.put extension (:as directive.Handler value) directives)]])))) - (#try.Success [definitions' bundles']) - (recur input' definitions' bundles') - - failure - failure) - - #.None - (#try.Success [definitions bundles]))))) - content (document.read $.key document) - definitions (monad.map ! (function (_ [def_name def_global]) - (case def_global - (#.Alias alias) - (wrap [def_name (#.Alias alias)]) - - (#.Definition [exported? type annotations _]) - (do ! - [value (try.from_maybe (dictionary.get def_name definitions))] - (wrap [def_name (#.Definition [exported? type annotations value])])))) - (get@ #.definitions content))] - (wrap [(document.write $.key (set@ #.definitions definitions content)) - bundles]))) - -(def: (load_definitions fs static module_id host_environment [descriptor document output]) - (All [expression directive] - (-> (file.System Promise) Static archive.ID (generation.Host expression directive) - [Descriptor (Document .Module) Output] - (Promise (Try [[Descriptor (Document .Module) Output] - Bundles])))) - (do (try.with promise.monad) - [actual (cached_artifacts fs static module_id) - #let [expected (|> descriptor (get@ #descriptor.registry) artifact.artifacts)] - [document bundles] (promise\wrap (loaded_document (get@ #static.artifact_extension static) host_environment module_id expected actual document))] - (wrap [[descriptor document output] bundles]))) - -(def: (purge! fs static [module_name module_id]) - (-> (file.System Promise) Static [Module archive.ID] (Promise (Try Any))) - (do {! (try.with promise.monad)} - [#let [cache (..module fs static module_id)] - _ (|> cache - (\ fs directory_files) - (\ ! map (monad.map ! (\ fs delete))) - (\ ! join))] - (\ fs delete cache))) - -(def: (valid_cache? expected actual) - (-> Descriptor Input Bit) - (and (text\= (get@ #descriptor.name expected) - (get@ #////.module actual)) - (text\= (get@ #descriptor.file expected) - (get@ #////.file actual)) - (n.= (get@ #descriptor.hash expected) - (get@ #////.hash actual)))) - -(type: Purge - (Dictionary Module archive.ID)) - -(def: initial_purge - (-> (List [Bit [Module [archive.ID [Descriptor (Document .Module) Output]]]]) - Purge) - (|>> (list.all (function (_ [valid_cache? [module_name [module_id _]]]) - (if valid_cache? - #.None - (#.Some [module_name module_id])))) - (dictionary.from_list text.hash))) - -(def: (full_purge caches load_order) - (-> (List [Bit [Module [archive.ID [Descriptor (Document .Module) Output]]]]) - dependency.Order - Purge) - (list\fold (function (_ [module_name [module_id [descriptor document output]]] purge) - (let [purged? (: (Predicate Module) - (dictionary.key? purge))] - (if (purged? module_name) - purge - (if (|> descriptor - (get@ #descriptor.references) - set.to_list - (list.any? purged?)) - (dictionary.put module_name module_id purge) - purge)))) - (..initial_purge caches) - load_order)) - -(def: pseudo_module - Text - "(Lux Caching System)") - -(def: (load_every_reserved_module host_environment fs static import contexts archive) - (All [expression directive] - (-> (generation.Host expression directive) (file.System Promise) Static Import (List Context) Archive - (Promise (Try [Archive .Lux Bundles])))) - (do {! (try.with promise.monad)} - [pre_loaded_caches (|> archive - archive.reservations - (monad.map ! (function (_ [module_name module_id]) - (do ! - [data (..read_module_descriptor fs static module_id) - [descriptor document] (promise\wrap (<binary>.run ..parser data))] - (if (text\= archive.runtime_module module_name) - (wrap [true - [module_name [module_id [descriptor document (: Output row.empty)]]]]) - (do ! - [input (//context.read fs ..pseudo_module import contexts (get@ #static.host_module_extension static) module_name)] - (wrap [(..valid_cache? descriptor input) - [module_name [module_id [descriptor document (: Output row.empty)]]]]))))))) - load_order (|> pre_loaded_caches - (list\map product.right) - (monad.fold try.monad - (function (_ [module [module_id descriptor,document,output]] archive) - (archive.add module descriptor,document,output archive)) - archive) - (\ try.monad map (dependency.load_order $.key)) - (\ try.monad join) - promise\wrap) - #let [purge (..full_purge pre_loaded_caches load_order)] - _ (|> purge - dictionary.entries - (monad.map ! (..purge! fs static))) - loaded_caches (|> load_order - (list.filter (function (_ [module_name [module_id [descriptor document output]]]) - (not (dictionary.key? purge module_name)))) - (monad.map ! (function (_ [module_name [module_id descriptor,document,output]]) - (do ! - [[descriptor,document,output bundles] (..load_definitions fs static module_id host_environment descriptor,document,output)] - (wrap [[module_name descriptor,document,output] - bundles])))))] - (promise\wrap - (do {! try.monad} - [archive (monad.fold ! - (function (_ [[module descriptor,document] _bundle] archive) - (archive.add module descriptor,document archive)) - archive - loaded_caches) - analysis_state (..analysis_state (get@ #static.host static) archive)] - (wrap [archive - analysis_state - (list\fold (function (_ [_ [+analysers +synthesizers +generators +directives]] - [analysers synthesizers generators directives]) - [(dictionary.merge +analysers analysers) - (dictionary.merge +synthesizers synthesizers) - (dictionary.merge +generators generators) - (dictionary.merge +directives directives)]) - ..empty_bundles - loaded_caches)]))))) - -(def: #export (thaw host_environment fs static import contexts) - (All [expression directive] - (-> (generation.Host expression directive) (file.System Promise) Static Import (List Context) - (Promise (Try [Archive .Lux Bundles])))) - (do promise.monad - [binary (\ fs read (..general_descriptor fs static))] - (case binary - (#try.Success binary) - (do (try.with promise.monad) - [archive (promise\wrap (archive.import ///.version binary))] - (..load_every_reserved_module host_environment fs static import contexts archive)) - - (#try.Failure error) - (wrap (#try.Success [archive.empty - (fresh_analysis_state (get@ #static.host static)) - ..empty_bundles]))))) diff --git a/stdlib/source/lux/tool/compiler/meta/io/context.lux b/stdlib/source/lux/tool/compiler/meta/io/context.lux deleted file mode 100644 index f31b4e1b2..000000000 --- a/stdlib/source/lux/tool/compiler/meta/io/context.lux +++ /dev/null @@ -1,169 +0,0 @@ -(.module: - [lux (#- Module Code) - ["@" target] - [abstract - [predicate (#+ Predicate)] - ["." monad (#+ Monad do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)] - [concurrency - ["." promise (#+ Promise) ("#\." monad)]]] - [data - [binary (#+ Binary)] - ["." text ("#\." hash) - ["%" format (#+ format)] - [encoding - ["." utf8]]] - [collection - ["." dictionary (#+ Dictionary)]]] - [world - ["." file]]] - [program - [compositor - [import (#+ Import)]]] - ["." // (#+ Context Code) - ["/#" // #_ - [archive - [descriptor (#+ Module)]] - ["/#" // (#+ Input)]]]) - -(exception: #export (cannot_find_module {importer Module} {module Module}) - (exception.report - ["Module" (%.text module)] - ["Importer" (%.text importer)])) - -(exception: #export (cannot_read_module {module Module}) - (exception.report - ["Module" (%.text module)])) - -(type: #export Extension - Text) - -(def: lux_extension - Extension - ".lux") - -(def: #export (path fs context module) - (All [m] (-> (file.System m) Context Module file.Path)) - (|> module - (//.sanitize fs) - (format context (\ fs separator)))) - -(def: (find_source_file fs importer contexts module extension) - (-> (file.System Promise) Module (List Context) Module Extension - (Promise (Try file.Path))) - (case contexts - #.Nil - (promise\wrap (exception.throw ..cannot_find_module [importer module])) - - (#.Cons context contexts') - (let [path (format (..path fs context module) extension)] - (do promise.monad - [? (\ fs file? path)] - (if ? - (wrap (#try.Success path)) - (find_source_file fs importer contexts' module extension)))))) - -(def: (full_host_extension partial_host_extension) - (-> Extension Extension) - (format partial_host_extension ..lux_extension)) - -(def: (find_local_source_file fs importer import contexts partial_host_extension module) - (-> (file.System Promise) Module Import (List Context) Extension Module - (Promise (Try [file.Path Binary]))) - ## Preference is explicitly being given to Lux files that have a host extension. - ## Normal Lux files (i.e. without a host extension) are then picked as fallback files. - (do {! promise.monad} - [outcome (..find_source_file fs importer contexts module (..full_host_extension partial_host_extension))] - (case outcome - (#try.Success path) - (|> path - (\ fs read) - (\ (try.with !) map (|>> [path]))) - - (#try.Failure _) - (do {! (try.with !)} - [path (..find_source_file fs importer contexts module ..lux_extension)] - (|> path - (\ fs read) - (\ ! map (|>> [path]))))))) - -(def: (find_library_source_file importer import partial_host_extension module) - (-> Module Import Extension Module (Try [file.Path Binary])) - (let [path (format module (..full_host_extension partial_host_extension))] - (case (dictionary.get path import) - (#.Some data) - (#try.Success [path data]) - - #.None - (let [path (format module ..lux_extension)] - (case (dictionary.get path import) - (#.Some data) - (#try.Success [path data]) - - #.None - (exception.throw ..cannot_find_module [importer module])))))) - -(def: (find_any_source_file fs importer import contexts partial_host_extension module) - (-> (file.System Promise) Module Import (List Context) Extension Module - (Promise (Try [file.Path Binary]))) - ## Preference is explicitly being given to Lux files that have a host extension. - ## Normal Lux files (i.e. without a host extension) are then picked as fallback files. - (do {! promise.monad} - [outcome (find_local_source_file fs importer import contexts partial_host_extension module)] - (case outcome - (#try.Success [path data]) - (wrap outcome) - - (#try.Failure _) - (wrap (..find_library_source_file importer import partial_host_extension module))))) - -(def: #export (read fs importer import contexts partial_host_extension module) - (-> (file.System Promise) Module Import (List Context) Extension Module - (Promise (Try Input))) - (do (try.with promise.monad) - [[path binary] (..find_any_source_file fs importer import contexts partial_host_extension module)] - (case (\ utf8.codec decode binary) - (#try.Success code) - (wrap {#////.module module - #////.file path - #////.hash (text\hash code) - #////.code code}) - - (#try.Failure _) - (promise\wrap (exception.throw ..cannot_read_module [module]))))) - -(type: #export Enumeration - (Dictionary file.Path Binary)) - -(def: (enumerate_context fs directory enumeration) - (-> (file.System Promise) Context Enumeration (Promise (Try Enumeration))) - (do {! (try.with promise.monad)} - [enumeration (|> directory - (\ fs directory_files) - (\ ! map (monad.fold ! (function (_ file enumeration) - (if (text.ends_with? ..lux_extension file) - (do ! - [source_code (\ fs read file)] - (promise\wrap - (dictionary.try_put (file.name fs file) source_code enumeration))) - (wrap enumeration))) - enumeration)) - (\ ! join))] - (|> directory - (\ fs sub_directories) - (\ ! map (monad.fold ! (enumerate_context fs) enumeration)) - (\ ! join)))) - -(def: Action - (type (All [a] (Promise (Try a))))) - -(def: #export (enumerate fs contexts) - (-> (file.System Promise) (List Context) (Action Enumeration)) - (monad.fold (: (Monad Action) - (try.with promise.monad)) - (..enumerate_context fs) - (: Enumeration - (dictionary.new text.hash)) - contexts)) diff --git a/stdlib/source/lux/tool/compiler/meta/packager.lux b/stdlib/source/lux/tool/compiler/meta/packager.lux deleted file mode 100644 index fff07d28f..000000000 --- a/stdlib/source/lux/tool/compiler/meta/packager.lux +++ /dev/null @@ -1,42 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ Monad)]] - [control - [try (#+ Try)]] - [data - [binary (#+ Binary)] - [collection - ["." row] - ["." list ("#\." functor)]]] - [world - ["." file (#+ Path)]]] - [program - [compositor - [static (#+ Static)]]] - [// - [cache - ["." dependency]] - ["." archive (#+ Archive) - ["." descriptor] - ["." artifact]] - [// - [language - [lux - [generation (#+ Context)]]]]]) - -(type: #export Packager - (-> Archive Context (Try Binary))) - -(type: #export Order - (List [archive.ID (List artifact.ID)])) - -(def: #export order - (-> dependency.Order Order) - (list\map (function (_ [module [module_id [descriptor document]]]) - (|> descriptor - (get@ #descriptor.registry) - artifact.artifacts - row.to_list - (list\map (|>> (get@ #artifact.id))) - [module_id])))) diff --git a/stdlib/source/lux/tool/compiler/meta/packager/jvm.lux b/stdlib/source/lux/tool/compiler/meta/packager/jvm.lux deleted file mode 100644 index a89bdc836..000000000 --- a/stdlib/source/lux/tool/compiler/meta/packager/jvm.lux +++ /dev/null @@ -1,144 +0,0 @@ -(.module: - [lux (#- Module Definition) - [type (#+ :share)] - ["." ffi (#+ import: do_to)] - [abstract - ["." monad (#+ Monad do)]] - [control - ["." try (#+ Try)] - [concurrency - ["." promise (#+ Promise)]]] - [data - ["." binary (#+ Binary)] - ["." text - ["%" format (#+ format)]] - [collection - ["." row (#+ Row) ("#\." fold)] - ["." list ("#\." functor fold)]]] - [math - [number - ["n" nat]]] - [target - [jvm - [encoding - ["." name]]]]] - [program - [compositor - ["." static (#+ Static)]]] - ["." // (#+ Packager) - [// - ["." archive (#+ Output) - ["." descriptor (#+ Module)] - ["." artifact]] - [cache - ["." dependency]] - ["." io #_ - ["#" archive]] - [// - [language - ["$" lux - [generation (#+ Context)] - [phase - [generation - [jvm - ["." runtime (#+ Definition)]]]]]]]]]) - -(import: java/lang/Object) - -(import: java/lang/String) - -(import: java/util/jar/Attributes - ["#::." - (put [java/lang/Object java/lang/Object] #? java/lang/Object)]) - -(import: java/util/jar/Attributes$Name - ["#::." - (#static MAIN_CLASS java/util/jar/Attributes$Name) - (#static MANIFEST_VERSION java/util/jar/Attributes$Name)]) - -(import: java/util/jar/Manifest - ["#::." - (new []) - (getMainAttributes [] java/util/jar/Attributes)]) - -(import: java/io/Flushable - ["#::." - (flush [] void)]) - -(import: java/io/Closeable - ["#::." - (close [] void)]) - -(import: java/io/OutputStream) - -(import: java/io/ByteArrayOutputStream - ["#::." - (new [int]) - (toByteArray [] [byte])]) - -(import: java/util/zip/ZipEntry) - -(import: java/util/zip/ZipOutputStream - ["#::." - (write [[byte] int int] void) - (closeEntry [] void)]) - -(import: java/util/jar/JarEntry - ["#::." - (new [java/lang/String])]) - -(import: java/util/jar/JarOutputStream - ["#::." - (new [java/io/OutputStream java/util/jar/Manifest]) - (putNextEntry [java/util/zip/ZipEntry] void)]) - -(def: byte 1) -## https://en.wikipedia.org/wiki/Kibibyte -(def: kibi_byte (n.* 1,024 byte)) -## https://en.wikipedia.org/wiki/Mebibyte -(def: mebi_byte (n.* 1,024 kibi_byte)) - -(def: manifest_version "1.0") - -(def: (manifest program) - (-> Context java/util/jar/Manifest) - (let [manifest (java/util/jar/Manifest::new)] - (exec (do_to (java/util/jar/Manifest::getMainAttributes manifest) - (java/util/jar/Attributes::put (java/util/jar/Attributes$Name::MAIN_CLASS) (|> program runtime.class_name name.internal name.external)) - (java/util/jar/Attributes::put (java/util/jar/Attributes$Name::MANIFEST_VERSION) ..manifest_version)) - manifest))) - -(def: (write_class static module artifact content sink) - (-> Static archive.ID artifact.ID Binary java/util/jar/JarOutputStream - java/util/jar/JarOutputStream) - (let [class_path (format (runtime.class_name [module artifact]) - (get@ #static.artifact_extension static))] - (do_to sink - (java/util/jar/JarOutputStream::putNextEntry (java/util/jar/JarEntry::new class_path)) - (java/util/zip/ZipOutputStream::write content +0 (.int (binary.size content))) - (java/io/Flushable::flush) - (java/util/zip/ZipOutputStream::closeEntry)))) - -(def: (write_module static [module output] sink) - (-> Static [archive.ID Output] java/util/jar/JarOutputStream - java/util/jar/JarOutputStream) - (row\fold (function (_ [artifact content] sink) - (..write_class static module artifact content sink)) - sink - output)) - -(def: #export (package static) - (-> Static Packager) - (function (_ archive program) - (do {! try.monad} - [order (dependency.load_order $.key archive) - #let [buffer (java/io/ByteArrayOutputStream::new (.int ..mebi_byte)) - sink (|> order - (list\map (function (_ [module [module_id [descriptor document output]]]) - [module_id output])) - (list\fold (..write_module static) - (java/util/jar/JarOutputStream::new buffer (..manifest program)))) - _ (do_to sink - (java/io/Flushable::flush) - (java/io/Closeable::close))]] - (wrap (java/io/ByteArrayOutputStream::toByteArray buffer))))) diff --git a/stdlib/source/lux/tool/compiler/meta/packager/scheme.lux b/stdlib/source/lux/tool/compiler/meta/packager/scheme.lux deleted file mode 100644 index ac35684ed..000000000 --- a/stdlib/source/lux/tool/compiler/meta/packager/scheme.lux +++ /dev/null @@ -1,131 +0,0 @@ -(.module: - [lux (#- Module) - [type (#+ :share)] - [abstract - ["." monad (#+ Monad do)]] - [control - ["." try (#+ Try)]] - [data - [binary (#+ Binary)] - ["." product] - ["." text - ["%" format (#+ format)] - ["." encoding]] - [collection - ["." row] - ["." list ("#\." functor fold)] - ["." dictionary (#+ Dictionary)] - ["." set]] - [format - ["." tar] - ["." binary]]] - [target - ["_" scheme]] - [time - ["." instant (#+ Instant)]] - [world - ["." file]]] - [program - [compositor - ["." static (#+ Static)]]] - ["." // (#+ Packager) - [// - ["." archive (#+ Output) - ["." descriptor (#+ Module Descriptor)] - ["." artifact] - ["." document (#+ Document)]] - [cache - ["." dependency]] - ["." io #_ - ["#" archive]] - [// - [language - ["$" lux - [generation (#+ Context)]]]]]]) - -## TODO: Delete ASAP -(type: (Action ! a) - (! (Try a))) - -(def: (then pre post) - (-> _.Expression _.Expression _.Expression) - (_.manual (format (_.code pre) - text.new_line - (_.code post)))) - -(def: bundle_module - (-> Output (Try _.Expression)) - (|>> row.to_list - (list\map product.right) - (monad.fold try.monad - (function (_ content so_far) - (|> content - (\ encoding.utf8 decode) - (\ try.monad map - (|>> :assume - (:share [directive] - directive - so_far - - directive) - (..then so_far))))) - (: _.Expression (_.manual ""))))) - -(def: module_file - (-> archive.ID file.Path) - (|>> %.nat (text.suffix ".scm"))) - -(def: mode - tar.Mode - ($_ tar.and - tar.read_by_group - tar.read_by_owner - - tar.write_by_other - tar.write_by_group - tar.write_by_owner)) - -(def: owner - tar.Owner - {#tar.name tar.anonymous - #tar.id tar.no_id}) - -(def: ownership - {#tar.user ..owner - #tar.group ..owner}) - -(def: (write_module now mapping [module [module_id [descriptor document output]]]) - (-> Instant (Dictionary Module archive.ID) - [Module [archive.ID [Descriptor (Document .Module) Output]]] - (Try tar.Entry)) - (do {! try.monad} - [bundle (: (Try _.Expression) - (..bundle_module output)) - entry_content (: (Try tar.Content) - (|> descriptor - (get@ #descriptor.references) - set.to_list - (list.all (function (_ module) (dictionary.get module mapping))) - (list\map (|>> ..module_file _.string _.load-relative/1)) - (list\fold ..then bundle) - (: _.Expression) - _.code - (\ encoding.utf8 encode) - tar.content)) - module_file (tar.path (..module_file module_id))] - (wrap (#tar.Normal [module_file now ..mode ..ownership entry_content])))) - -(def: #export (package now) - (-> Instant Packager) - (function (package archive program) - (do {! try.monad} - [order (dependency.load_order $.key archive) - #let [mapping (|> order - (list\map (function (_ [module [module_id [descriptor document output]]]) - [module module_id])) - (dictionary.from_list text.hash) - (: (Dictionary Module archive.ID)))] - entries (monad.map ! (..write_module now mapping) order)] - (wrap (|> entries - row.from_list - (binary.run tar.writer)))))) diff --git a/stdlib/source/lux/tool/compiler/meta/packager/script.lux b/stdlib/source/lux/tool/compiler/meta/packager/script.lux deleted file mode 100644 index 98a011a4c..000000000 --- a/stdlib/source/lux/tool/compiler/meta/packager/script.lux +++ /dev/null @@ -1,75 +0,0 @@ -(.module: - [lux #* - [type (#+ :share)] - [abstract - ["." monad (#+ Monad do)]] - [control - ["." try (#+ Try)]] - [data - [binary (#+ Binary)] - ["." product] - [text - ["%" format (#+ format)] - [encoding - ["." utf8]]] - [collection - ["." row] - ["." list ("#\." functor)]]]] - [program - [compositor - ["." static (#+ Static)]]] - ["." // (#+ Packager) - [// - ["." archive (#+ Output) - ["." descriptor] - ["." artifact]] - [cache - ["." dependency]] - ["." io #_ - ["#" archive]] - [// - [language - ["$" lux - [generation (#+ Context)]]]]]]) - -## TODO: Delete ASAP -(type: (Action ! a) - (! (Try a))) - -(def: (write_module sequence [module output] so_far) - (All [directive] - (-> (-> directive directive directive) [archive.ID Output] directive - (Try directive))) - (|> output - row.to_list - (list\map product.right) - (monad.fold try.monad - (function (_ content so_far) - (|> content - (\ utf8.codec decode) - (\ try.monad map - (function (_ content) - (sequence so_far - (:share [directive] - directive - so_far - - directive - (:assume content))))))) - so_far))) - -(def: #export (package header to_code sequence scope) - (All [directive] - (-> directive - (-> directive Text) - (-> directive directive directive) - (-> directive directive) - Packager)) - (function (package archive program) - (do {! try.monad} - [order (dependency.load_order $.key archive)] - (|> order - (list\map (function (_ [module [module_id [descriptor document output]]]) - [module_id output])) - (monad.fold ! (..write_module sequence) header) - (\ ! map (|>> scope to_code (\ utf8.codec encode))))))) diff --git a/stdlib/source/lux/tool/compiler/phase.lux b/stdlib/source/lux/tool/compiler/phase.lux deleted file mode 100644 index 0d6543c33..000000000 --- a/stdlib/source/lux/tool/compiler/phase.lux +++ /dev/null @@ -1,118 +0,0 @@ -(.module: - [lux #* - ["." debug] - [abstract - [monad (#+ Monad do)]] - [control - ["." state] - ["." try (#+ Try) ("#\." functor)] - ["ex" exception (#+ Exception exception:)] - ["." io] - [parser - ["s" code]]] - [data - ["." product] - ["." text - ["%" format (#+ format)]]] - [time - ["." instant] - ["." duration]] - [macro - [syntax (#+ syntax:)]]] - [// - [meta - [archive (#+ Archive)]]]) - -(type: #export (Operation s o) - (state.State' Try s o)) - -(def: #export monad - (All [s] (Monad (Operation s))) - (state.with try.monad)) - -(type: #export (Phase s i o) - (-> Archive i (Operation s o))) - -(def: #export (run' state operation) - (All [s o] - (-> s (Operation s o) (Try [s o]))) - (operation state)) - -(def: #export (run state operation) - (All [s o] - (-> s (Operation s o) (Try o))) - (|> state - operation - (\ try.monad map product.right))) - -(def: #export get_state - (All [s o] - (Operation s s)) - (function (_ state) - (#try.Success [state state]))) - -(def: #export (set_state state) - (All [s o] - (-> s (Operation s Any))) - (function (_ _) - (#try.Success [state []]))) - -(def: #export (sub [get set] operation) - (All [s s' o] - (-> [(-> s s') (-> s' s s)] - (Operation s' o) - (Operation s o))) - (function (_ state) - (do try.monad - [[state' output] (operation (get state))] - (wrap [(set state' state) output])))) - -(def: #export fail - (-> Text Operation) - (|>> try.fail (state.lift try.monad))) - -(def: #export (throw exception parameters) - (All [e] (-> (Exception e) e Operation)) - (..fail (ex.construct exception parameters))) - -(def: #export (lift error) - (All [s a] (-> (Try a) (Operation s a))) - (function (_ state) - (try\map (|>> [state]) error))) - -(syntax: #export (assert exception message test) - (wrap (list (` (if (~ test) - (\ ..monad (~' wrap) []) - (..throw (~ exception) (~ message))))))) - -(def: #export identity - (All [s a] (Phase s a a)) - (function (_ archive input state) - (#try.Success [state input]))) - -(def: #export (compose pre post) - (All [s0 s1 i t o] - (-> (Phase s0 i t) - (Phase s1 t o) - (Phase [s0 s1] i o))) - (function (_ archive input [pre/state post/state]) - (do try.monad - [[pre/state' temp] (pre archive input pre/state) - [post/state' output] (post archive temp post/state)] - (wrap [[pre/state' post/state'] output])))) - -(def: #export (timed definition description operation) - (All [s a] - (-> Name Text (Operation s a) (Operation s a))) - (do ..monad - [_ (wrap []) - #let [pre (io.run instant.now)] - output operation - #let [_ (|> instant.now - io.run - instant.relative - (duration.difference (instant.relative pre)) - %.duration - (format (%.name definition) " [" description "]: ") - debug.log!)]] - (wrap output))) diff --git a/stdlib/source/lux/tool/compiler/reference.lux b/stdlib/source/lux/tool/compiler/reference.lux deleted file mode 100644 index 98a1f0c07..000000000 --- a/stdlib/source/lux/tool/compiler/reference.lux +++ /dev/null @@ -1,84 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)]] - [control - [pipe (#+ case>)]] - [data - ["." name] - [text - ["%" format (#+ Format)]]] - [math - [number - ["n" nat]]]] - ["." / #_ - ["#." variable (#+ Variable)]]) - -(type: #export Constant - Name) - -(type: #export Reference - (#Variable Variable) - (#Constant Constant)) - -(implementation: #export equivalence - (Equivalence Reference) - - (def: (= reference sample) - (case [reference sample] - (^template [<tag> <equivalence>] - [[(<tag> reference) (<tag> sample)] - (\ <equivalence> = reference sample)]) - ([#Variable /variable.equivalence] - [#Constant name.equivalence]) - - _ - false))) - -(implementation: #export hash - (Hash Reference) - - (def: &equivalence - ..equivalence) - - (def: (hash value) - (case value - (^template [<factor> <tag> <hash>] - [(<tag> value) - ($_ n.* <factor> - (\ <hash> hash value))]) - ([2 #Variable /variable.hash] - [3 #Constant name.hash]) - ))) - -(template [<name> <family> <tag>] - [(template: #export (<name> content) - (<| <family> - <tag> - content))] - - [local #..Variable #/variable.Local] - [foreign #..Variable #/variable.Foreign] - ) - -(template [<name> <tag>] - [(template: #export (<name> content) - (<| <tag> - content))] - - [variable #..Variable] - [constant #..Constant] - ) - -(def: #export self - Reference - (..local 0)) - -(def: #export format - (Format Reference) - (|>> (case> (#Variable variable) - (/variable.format variable) - - (#Constant constant) - (%.name constant)))) diff --git a/stdlib/source/lux/tool/compiler/reference/variable.lux b/stdlib/source/lux/tool/compiler/reference/variable.lux deleted file mode 100644 index 84aea58ab..000000000 --- a/stdlib/source/lux/tool/compiler/reference/variable.lux +++ /dev/null @@ -1,67 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)]] - [control - [pipe (#+ case>)]] - [data - [text - ["%" format (#+ Format)]]] - [math - [number - ["n" nat] - ["i" int]]]]) - -(type: #export Register - Nat) - -(type: #export Variable - (#Local Register) - (#Foreign Register)) - -(implementation: #export equivalence - (Equivalence Variable) - - (def: (= reference sample) - (case [reference sample] - (^template [<tag>] - [[(<tag> reference') (<tag> sample')] - (n.= reference' sample')]) - ([#Local] [#Foreign]) - - _ - #0))) - -(implementation: #export hash - (Hash Variable) - - (def: &equivalence - ..equivalence) - - (def: hash - (|>> (case> (^template [<factor> <tag>] - [(<tag> register) - ($_ n.* <factor> - (\ n.hash hash register))]) - ([2 #Local] - [3 #Foreign]))))) - -(template: #export (self) - (#..Local 0)) - -(def: #export self? - (-> Variable Bit) - (|>> (case> (^ (..self)) - true - - _ - false))) - -(def: #export format - (Format Variable) - (|>> (case> (#Local local) - (%.format "+" (%.nat local)) - - (#Foreign foreign) - (%.format "-" (%.nat foreign))))) diff --git a/stdlib/source/lux/tool/compiler/version.lux b/stdlib/source/lux/tool/compiler/version.lux deleted file mode 100644 index d29428636..000000000 --- a/stdlib/source/lux/tool/compiler/version.lux +++ /dev/null @@ -1,51 +0,0 @@ -(.module: - [lux #* - [data - [text - ["%" format]]] - [math - [number - ["n" nat]]]]) - -(type: #export Version - Nat) - -(def: range 100) - -(def: level - (n.% ..range)) - -(def: current - (-> Nat Nat) - (|>>)) - -(def: next - (n./ ..range)) - -(def: #export patch - (-> Version Nat) - (|>> ..current ..level)) - -(def: #export minor - (-> Version Nat) - (|>> ..next ..level)) - -(def: #export major - (-> Version Nat) - (|>> ..next ..next ..level)) - -(def: separator ".") - -(def: (padded value) - (-> Nat Text) - (if (n.< 10 value) - (%.format "0" (%.nat value)) - (%.nat value))) - -(def: #export (format version) - (%.Format Version) - (%.format (..padded (..major version)) - ..separator - (..padded (..minor version)) - ..separator - (..padded (..patch version)))) diff --git a/stdlib/source/lux/tool/interpreter.lux b/stdlib/source/lux/tool/interpreter.lux deleted file mode 100644 index e18a27c47..000000000 --- a/stdlib/source/lux/tool/interpreter.lux +++ /dev/null @@ -1,221 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ Monad do)] - ["." try (#+ Try)] - ["ex" exception (#+ exception:)]] - [data - ["." text ("#\." equivalence) - ["%" format (#+ format)]]] - [type (#+ :share) - ["." check]] - [compiler - ["." phase - ["." analysis - ["." module] - ["." type]] - ["." generation] - ["." directive (#+ State+ Operation) - ["." total]] - ["." extension]] - ["." default - ["." syntax] - ["." platform (#+ Platform)] - ["." init]] - ["." cli (#+ Configuration)]] - [world - ["." file (#+ File)] - ["." console (#+ Console)]]] - ["." /type]) - -(exception: #export (error {message Text}) - message) - -(def: #export module "<INTERPRETER>") - -(def: fresh-source Source [[..module 1 0] 0 ""]) - -(def: (add-line line [where offset input]) - (-> Text Source Source) - [where offset (format input text.new-line line)]) - -(def: exit-command Text "exit") - -(def: welcome-message - Text - (format text.new-line - "Welcome to the interpreter!" text.new-line - "Type '" ..exit-command "' to leave." text.new-line - text.new-line)) - -(def: farewell-message - Text - "Till next time...") - -(def: enter-module - (All [anchor expression directive] - (Operation anchor expression directive Any)) - (directive.lift-analysis - (do phase.monad - [_ (module.create 0 ..module)] - (analysis.set-current-module ..module)))) - -(def: (initialize Monad<!> Console<!> platform configuration generation-bundle) - (All [! anchor expression directive] - (-> (Monad !) - (Console !) (Platform ! anchor expression directive) - Configuration - (generation.Bundle anchor expression directive) - (! (State+ anchor expression directive)))) - (do Monad<!> - [state (platform.initialize platform generation-bundle) - state (platform.compile platform - (set@ #cli.module syntax.prelude configuration) - (set@ [#extension.state - #directive.analysis #directive.state - #extension.state - #.info #.mode] - #.Interpreter - state)) - [state _] (\ (get@ #platform.file-system platform) - lift (phase.run' state enter-module)) - _ (\ Console<!> write ..welcome-message)] - (wrap state))) - -(with-expansions [<Interpretation> (as-is (Operation anchor expression directive [Type Any]))] - - (def: (interpret-directive code) - (All [anchor expression directive] - (-> Code <Interpretation>)) - (do phase.monad - [_ (total.phase code) - _ init.refresh] - (wrap [Any []]))) - - (def: (interpret-expression code) - (All [anchor expression directive] - (-> Code <Interpretation>)) - (do {! phase.monad} - [state (extension.lift phase.get-state) - #let [analyse (get@ [#directive.analysis #directive.phase] state) - synthesize (get@ [#directive.synthesis #directive.phase] state) - generate (get@ [#directive.generation #directive.phase] state)] - [_ codeT codeA] (directive.lift-analysis - (analysis.with-scope - (type.with-fresh-env - (do ! - [[codeT codeA] (type.with-inference - (analyse code)) - codeT (type.with-env - (check.clean codeT))] - (wrap [codeT codeA]))))) - codeS (directive.lift-synthesis - (synthesize codeA))] - (directive.lift-generation - (generation.with-buffer - (do ! - [codeH (generate codeS) - count generation.next - codeV (generation.evaluate! (format "interpretation_" (%.nat count)) codeH)] - (wrap [codeT codeV])))))) - - (def: (interpret configuration code) - (All [anchor expression directive] - (-> Configuration Code <Interpretation>)) - (function (_ state) - (case (<| (phase.run' state) - (:share [anchor expression directive] - {(State+ anchor expression directive) - state} - {<Interpretation> - (interpret-directive code)})) - (#try.Success [state' output]) - (#try.Success [state' output]) - - (#try.Failure error) - (if (ex.match? total.not-a-directive error) - (<| (phase.run' state) - (:share [anchor expression directive] - {(State+ anchor expression directive) - state} - {<Interpretation> - (interpret-expression code)})) - (#try.Failure error))))) - ) - -(def: (execute configuration code) - (All [anchor expression directive] - (-> Configuration Code (Operation anchor expression directive Text))) - (do phase.monad - [[codeT codeV] (interpret configuration code) - state phase.get-state] - (wrap (/type.represent (get@ [#extension.state - #directive.analysis #directive.state - #extension.state] - state) - codeT - codeV)))) - -(type: (Context anchor expression directive) - {#configuration Configuration - #state (State+ anchor expression directive) - #source Source}) - -(with-expansions [<Context> (as-is (Context anchor expression directive))] - (def: (read-eval-print context) - (All [anchor expression directive] - (-> <Context> (Try [<Context> Text]))) - (do try.monad - [#let [[_where _offset _code] (get@ #source context)] - [source' input] (syntax.parse ..module syntax.no-aliases (text.size _code) (get@ #source context)) - [state' representation] (let [## TODO: Simplify ASAP - state (:share [anchor expression directive] - {<Context> - context} - {(State+ anchor expression directive) - (get@ #state context)})] - (<| (phase.run' state) - ## TODO: Simplify ASAP - (:share [anchor expression directive] - {<Context> - context} - {(Operation anchor expression directive Text) - (execute (get@ #configuration context) input)})))] - (wrap [(|> context - (set@ #state state') - (set@ #source source')) - representation])))) - -(def: #export (run Monad<!> Console<!> platform configuration generation-bundle) - (All [! anchor expression directive] - (-> (Monad !) - (Console !) (Platform ! anchor expression directive) - Configuration - (generation.Bundle anchor expression directive) - (! Any))) - (do {! Monad<!>} - [state (initialize Monad<!> Console<!> platform configuration)] - (loop [context {#configuration configuration - #state state - #source ..fresh-source} - multi-line? #0] - (do ! - [_ (if multi-line? - (\ Console<!> write " ") - (\ Console<!> write "> ")) - line (\ Console<!> read-line)] - (if (and (not multi-line?) - (text\= ..exit-command line)) - (\ Console<!> write ..farewell-message) - (case (read-eval-print (update@ #source (add-line line) context)) - (#try.Success [context' representation]) - (do ! - [_ (\ Console<!> write representation)] - (recur context' #0)) - - (#try.Failure error) - (if (ex.match? syntax.end-of-file error) - (recur context #1) - (exec (log! (ex.construct ..error error)) - (recur (set@ #source ..fresh-source context) #0)))))) - ))) diff --git a/stdlib/source/lux/tool/mediator.lux b/stdlib/source/lux/tool/mediator.lux deleted file mode 100644 index 5beb217e0..000000000 --- a/stdlib/source/lux/tool/mediator.lux +++ /dev/null @@ -1,18 +0,0 @@ -(.module: - [lux (#- Source Module) - [world - ["." binary (#+ Binary)] - ["." file (#+ File)]]] - [// - [compiler (#+ Compiler) - [meta - ["." archive (#+ Archive) - [descriptor (#+ Module)]]]]]) - -(type: #export Source File) - -(type: #export (Mediator !) - (-> Archive Module (! Archive))) - -(type: #export (Instancer ! d o) - (-> (file.System !) (List Source) (Compiler d o) (Mediator !))) diff --git a/stdlib/source/lux/type.lux b/stdlib/source/lux/type.lux deleted file mode 100644 index af6048ac9..000000000 --- a/stdlib/source/lux/type.lux +++ /dev/null @@ -1,462 +0,0 @@ -(.module: {#.doc "Basic functionality for working with types."} - [lux (#- function) - ["@" target] - [abstract - [equivalence (#+ Equivalence)] - [monad (#+ Monad do)]] - [control - ["." function] - ["." exception (#+ exception:)] - ["<>" parser - ["<.>" code (#+ Parser)]]] - [data - ["." product] - ["." maybe] - ["." text ("#\." monoid equivalence)] - ["." name ("#\." equivalence codec)] - [collection - ["." array] - ["." list ("#\." functor monoid fold)]]] - ["." macro - [syntax (#+ syntax:)] - ["." code]] - [math - [number - ["n" nat ("#\." decimal)]]] - ["." meta - ["." location]]]) - -(template [<name> <tag>] - [(def: #export (<name> type) - (-> Type [Nat Type]) - (loop [num_args 0 - type type] - (case type - (<tag> env sub_type) - (recur (inc num_args) sub_type) - - _ - [num_args type])))] - - [flatten_univ_q #.UnivQ] - [flatten_ex_q #.ExQ] - ) - -(def: #export (flatten_function type) - (-> Type [(List Type) Type]) - (case type - (#.Function in out') - (let [[ins out] (flatten_function out')] - [(list& in ins) out]) - - _ - [(list) type])) - -(def: #export (flatten_application type) - (-> Type [Type (List Type)]) - (case type - (#.Apply arg func') - (let [[func args] (flatten_application func')] - [func (list\compose args (list arg))]) - - _ - [type (list)])) - -(template [<name> <tag>] - [(def: #export (<name> type) - (-> Type (List Type)) - (case type - (<tag> left right) - (list& left (<name> right)) - - _ - (list type)))] - - [flatten_variant #.Sum] - [flatten_tuple #.Product] - ) - -(def: #export (format type) - (-> Type Text) - (case type - (#.Primitive name params) - ($_ text\compose - "(primitive " - (text.enclose' text.double_quote name) - (|> params - (list\map (|>> format (text\compose " "))) - (list\fold (function.flip text\compose) "")) - ")") - - (^template [<tag> <open> <close> <flatten>] - [(<tag> _) - ($_ text\compose <open> - (|> (<flatten> type) - (list\map format) - list.reverse - (list.interpose " ") - (list\fold text\compose "")) - <close>)]) - ([#.Sum "(| " ")" flatten_variant] - [#.Product "[" "]" flatten_tuple]) - - (#.Function input output) - (let [[ins out] (flatten_function type)] - ($_ text\compose "(-> " - (|> ins - (list\map format) - list.reverse - (list.interpose " ") - (list\fold text\compose "")) - " " (format out) ")")) - - (#.Parameter idx) - (n\encode idx) - - (#.Var id) - ($_ text\compose "⌈v:" (n\encode id) "⌋") - - (#.Ex id) - ($_ text\compose "⟨e:" (n\encode id) "⟩") - - (#.Apply param fun) - (let [[type_func type_args] (flatten_application type)] - ($_ text\compose "(" (format type_func) " " (|> type_args (list\map format) list.reverse (list.interpose " ") (list\fold text\compose "")) ")")) - - (^template [<tag> <desc>] - [(<tag> env body) - ($_ text\compose "(" <desc> " {" (|> env (list\map format) (text.join_with " ")) "} " (format body) ")")]) - ([#.UnivQ "All"] - [#.ExQ "Ex"]) - - (#.Named [module name] type) - ($_ text\compose module "." name) - )) - -(def: (beta_reduce env type) - (-> (List Type) Type Type) - (case type - (#.Primitive name params) - (#.Primitive name (list\map (beta_reduce env) params)) - - (^template [<tag>] - [(<tag> left right) - (<tag> (beta_reduce env left) (beta_reduce env right))]) - ([#.Sum] [#.Product] - [#.Function] [#.Apply]) - - (^template [<tag>] - [(<tag> old_env def) - (case old_env - #.Nil - (<tag> env def) - - _ - (<tag> (list\map (beta_reduce env) old_env) def))]) - ([#.UnivQ] - [#.ExQ]) - - (#.Parameter idx) - (maybe.default (error! ($_ text\compose - "Unknown type parameter" text.new_line - " Index: " (n\encode idx) text.new_line - "Environment: " (|> env - list.enumeration - (list\map (.function (_ [index type]) - ($_ text\compose - (n\encode index) - " " (..format type)))) - (text.join_with (text\compose text.new_line " "))))) - (list.nth idx env)) - - _ - type - )) - -(implementation: #export equivalence - (Equivalence Type) - - (def: (= x y) - (or (for {@.php false} ## TODO: Remove this once JPHP is gone. - (is? x y)) - (case [x y] - [(#.Primitive xname xparams) (#.Primitive yname yparams)] - (and (text\= xname yname) - (n.= (list.size yparams) (list.size xparams)) - (list\fold (.function (_ [x y] prev) (and prev (= x y))) - #1 - (list.zip/2 xparams yparams))) - - (^template [<tag>] - [[(<tag> xid) (<tag> yid)] - (n.= yid xid)]) - ([#.Var] [#.Ex] [#.Parameter]) - - (^or [(#.Function xleft xright) (#.Function yleft yright)] - [(#.Apply xleft xright) (#.Apply yleft yright)]) - (and (= xleft yleft) - (= xright yright)) - - [(#.Named xname xtype) (#.Named yname ytype)] - (and (name\= xname yname) - (= xtype ytype)) - - (^template [<tag>] - [[(<tag> xL xR) (<tag> yL yR)] - (and (= xL yL) (= xR yR))]) - ([#.Sum] [#.Product]) - - (^or [(#.UnivQ xenv xbody) (#.UnivQ yenv ybody)] - [(#.ExQ xenv xbody) (#.ExQ yenv ybody)]) - (and (n.= (list.size yenv) (list.size xenv)) - (= xbody ybody) - (list\fold (.function (_ [x y] prev) (and prev (= x y))) - #1 - (list.zip/2 xenv yenv))) - - _ - #0 - )))) - -(def: #export (apply params func) - (-> (List Type) Type (Maybe Type)) - (case params - #.Nil - (#.Some func) - - (#.Cons param params') - (case func - (^template [<tag>] - [(<tag> env body) - (|> body - (beta_reduce (list& func param env)) - (apply params'))]) - ([#.UnivQ] [#.ExQ]) - - (#.Apply A F) - (apply (list& A params) F) - - (#.Named name unnamed) - (apply params unnamed) - - _ - #.None))) - -(def: #export (to_code type) - (-> Type Code) - (case type - (#.Primitive name params) - (` (#.Primitive (~ (code.text name)) - (.list (~+ (list\map to_code params))))) - - (^template [<tag>] - [(<tag> idx) - (` (<tag> (~ (code.nat idx))))]) - ([#.Var] [#.Ex] [#.Parameter]) - - (^template [<tag>] - [(<tag> left right) - (` (<tag> (~ (to_code left)) - (~ (to_code right))))]) - ([#.Sum] [#.Product] [#.Function] [#.Apply]) - - (#.Named name sub_type) - (code.identifier name) - - (^template [<tag>] - [(<tag> env body) - (` (<tag> (.list (~+ (list\map to_code env))) - (~ (to_code body))))]) - ([#.UnivQ] [#.ExQ]) - )) - -(def: #export (un_alias type) - (-> Type Type) - (case type - (#.Named _ (#.Named name type')) - (un_alias (#.Named name type')) - - _ - type)) - -(def: #export (un_name type) - (-> Type Type) - (case type - (#.Named name type') - (un_name type') - - _ - type)) - -(template [<name> <base> <ctor>] - [(def: #export (<name> types) - (-> (List Type) Type) - (case types - #.Nil - <base> - - (#.Cons type #.Nil) - type - - (#.Cons type types') - (<ctor> type (<name> types'))))] - - [variant Nothing #.Sum] - [tuple Any #.Product] - ) - -(def: #export (function inputs output) - (-> (List Type) Type Type) - (case inputs - #.Nil - output - - (#.Cons input inputs') - (#.Function input (function inputs' output)))) - -(def: #export (application params quant) - (-> (List Type) Type Type) - (case params - #.Nil - quant - - (#.Cons param params') - (application params' (#.Apply param quant)))) - -(template [<name> <tag>] - [(def: #export (<name> size body) - (-> Nat Type Type) - (case size - 0 body - _ (|> body (<name> (dec size)) (<tag> (list)))))] - - [univ_q #.UnivQ] - [ex_q #.ExQ] - ) - -(def: #export (quantified? type) - (-> Type Bit) - (case type - (#.Named [module name] _type) - (quantified? _type) - - (#.Apply A F) - (maybe.default #0 - (do maybe.monad - [applied (apply (list A) F)] - (wrap (quantified? applied)))) - - (^or (#.UnivQ _) (#.ExQ _)) - #1 - - _ - #0)) - -(def: #export (array depth element_type) - (-> Nat Type Type) - (case depth - 0 element_type - _ (|> element_type - (array (dec depth)) - (list) - (#.Primitive array.type_name)))) - -(def: #export (flatten_array type) - (-> Type [Nat Type]) - (case type - (^multi (^ (#.Primitive name (list element_type))) - (text\= array.type_name name)) - (let [[depth element_type] (flatten_array element_type)] - [(inc depth) element_type]) - - _ - [0 type])) - -(def: #export array? - (-> Type Bit) - (|>> ..flatten_array - product.left - (n.> 0))) - -(syntax: (new_secret_marker) - (macro.with_gensyms [g!_secret_marker_] - (wrap (list g!_secret_marker_)))) - -(def: secret_marker - (`` (name_of (~~ (new_secret_marker))))) - -(syntax: #export (:log! {input (<>.or (<>.and <code>.identifier - (<>.maybe (<>.after (<code>.identifier! ..secret_marker) <code>.any))) - <code>.any)}) - (case input - (#.Left [valueN valueC]) - (do meta.monad - [location meta.location - valueT (meta.find_type valueN) - #let [_ ("lux io log" - ($_ text\compose - (name\encode (name_of ..:log!)) " " (location.format location) text.new_line - "Expression: " (case valueC - (#.Some valueC) - (code.format valueC) - - #.None - (name\encode valueN)) - text.new_line - " Type: " (..format valueT)))]] - (wrap (list (code.identifier valueN)))) - - (#.Right valueC) - (macro.with_gensyms [g!value] - (wrap (list (` (.let [(~ g!value) (~ valueC)] - (..:log! (~ valueC) (~ (code.identifier ..secret_marker)) (~ g!value))))))))) - -(def: type_parameters - (Parser (List Text)) - (<code>.tuple (<>.some <code>.local_identifier))) - -(syntax: #export (:cast {type_vars type_parameters} - input - output - {value (<>.maybe <code>.any)}) - (let [casterC (` (: (All [(~+ (list\map code.local_identifier type_vars))] - (-> (~ input) (~ output))) - (|>> :assume)))] - (case value - #.None - (wrap (list casterC)) - - (#.Some value) - (wrap (list (` ((~ casterC) (~ value)))))))) - -(type: Typed - {#type Code - #expression Code}) - -(def: typed - (Parser Typed) - (<>.and <code>.any <code>.any)) - -## TODO: Make sure the generated code always gets optimized away. -(syntax: #export (:share {type_vars ..type_parameters} - {exemplar ..typed} - {computation ..typed}) - (macro.with_gensyms [g!_] - (let [shareC (` (: (All [(~+ (list\map code.local_identifier type_vars))] - (-> (~ (get@ #type exemplar)) - (~ (get@ #type computation)))) - (.function ((~ g!_) (~ g!_)) - (~ (get@ #expression computation)))))] - (wrap (list (` ((~ shareC) (~ (get@ #expression exemplar))))))))) - -(syntax: #export (:by_example {type_vars ..type_parameters} - {exemplar ..typed} - {extraction <code>.any}) - (wrap (list (` (:of ((~! :share) - [(~+ (list\map code.local_identifier type_vars))] - - (~ (get@ #type exemplar)) - (~ (get@ #expression exemplar)) - - (~ extraction) - (:assume []))))))) diff --git a/stdlib/source/lux/type/abstract.lux b/stdlib/source/lux/type/abstract.lux deleted file mode 100644 index c3121d7ff..000000000 --- a/stdlib/source/lux/type/abstract.lux +++ /dev/null @@ -1,268 +0,0 @@ -(.module: - [lux #* - [type (#+ :cast)] - ["." meta] - [abstract - [monad (#+ Monad do)]] - [control - ["." exception (#+ exception:)] - ["<>" parser ("#\." monad) - ["<.>" code (#+ Parser)]]] - [data - ["." name ("#\." codec)] - ["." text ("#\." equivalence monoid)] - [collection - ["." list ("#\." functor monoid)]]] - [macro - ["." code] - [syntax (#+ syntax:) - ["|.|" export] - ["|.|" annotations]]]]) - -(type: Stack List) - -(def: peek - (All [a] (-> (Stack a) (Maybe a))) - list.head) - -(def: (push value stack) - (All [a] (-> a (Stack a) (Stack a))) - (#.Cons value stack)) - -(def: pop - (All [a] (-> (Stack a) (Maybe (Stack a)))) - list.tail) - -(type: #export Frame - {#name Text - #type_vars (List Code) - #abstraction Code - #representation Code}) - -(def: frames - (Stack Frame) - #.Nil) - -(template: (!peek <source> <reference> <then>) - (loop [entries <source>] - (case entries - (#.Cons [head_name head] tail) - (if (text\= <reference> head_name) - <then> - (recur tail)) - - #.Nil - (undefined)))) - -(def: (peek_frames_definition reference source) - (-> Text (List [Text Global]) (Stack Frame)) - (!peek source reference - (case head - (#.Left _) - (undefined) - - (#.Right [exported? frame_type frame_anns frame_value]) - (:as (Stack Frame) frame_value)))) - -(def: (peek_frames reference definition_reference source) - (-> Text Text (List [Text Module]) (Stack Frame)) - (!peek source reference - (peek_frames_definition definition_reference (get@ #.definitions head)))) - -(exception: #export no_active_frames) - -(def: (peek! frame) - (-> (Maybe Text) (Meta Frame)) - (function (_ compiler) - (let [[reference definition_reference] (name_of ..frames) - current_frames (peek_frames reference definition_reference (get@ #.modules compiler))] - (case (case frame - (#.Some frame) - (list.find (function (_ [actual _]) - (text\= frame actual)) - current_frames) - - #.None - (..peek current_frames)) - (#.Some frame) - (#.Right [compiler frame]) - - #.None - (exception.throw ..no_active_frames []))))) - -(def: #export current - (Meta Frame) - (..peek! #.None)) - -(def: #export (specific name) - (-> Text (Meta Frame)) - (..peek! (#.Some name))) - -(template: (!push <source> <reference> <then>) - (loop [entries <source>] - (case entries - (#.Cons [head_name head] tail) - (if (text\= <reference> head_name) - (#.Cons [head_name <then>] - tail) - (#.Cons [head_name head] - (recur tail))) - - #.Nil - (undefined)))) - -(def: (push_frame_definition reference frame source) - (-> Text Frame (List [Text Global]) (List [Text Global])) - (!push source reference - (case head - (#.Left _) - (undefined) - - (#.Right [exported? frames_type frames_anns frames_value]) - (#.Right [exported? - frames_type - frames_anns - (..push frame (:as (Stack Frame) frames_value))])))) - -(def: (push_frame [module_reference definition_reference] frame source) - (-> Name Frame (List [Text Module]) (List [Text Module])) - (!push source module_reference - (update@ #.definitions (push_frame_definition definition_reference frame) head))) - -(def: (push! frame) - (-> Frame (Meta Any)) - (function (_ compiler) - (#.Right [(update@ #.modules - (..push_frame (name_of ..frames) frame) - compiler) - []]))) - -(def: (pop_frame_definition reference source) - (-> Text (List [Text Global]) (List [Text Global])) - (!push source reference - (case head - (#.Left _) - (undefined) - - (#.Right [exported? frames_type frames_anns frames_value]) - (#.Right [exported? - frames_type - frames_anns - (let [current_frames (:as (Stack Frame) frames_value)] - (case (..pop current_frames) - (#.Some current_frames') - current_frames' - - #.None - current_frames))])))) - -(def: (pop_frame [module_reference definition_reference] source) - (-> Name (List [Text Module]) (List [Text Module])) - (!push source module_reference - (|> head (update@ #.definitions (pop_frame_definition definition_reference))))) - -(syntax: (pop!) - (function (_ compiler) - (#.Right [(update@ #.modules - (..pop_frame (name_of ..frames)) - compiler) - (list)]))) - -(def: cast - (Parser [(Maybe Text) Code]) - (<>.either (<>.and (<>.maybe <code>.local_identifier) <code>.any) - (<>.and (<>\wrap #.None) <code>.any))) - -(template [<name> <from> <to>] - [(syntax: #export (<name> {[frame value] ..cast}) - (do meta.monad - [[name type_vars abstraction representation] (peek! frame)] - (wrap (list (` ((~! :cast) [(~+ type_vars)] (~ <from>) (~ <to>) - (~ value)))))))] - - [:abstraction representation abstraction] - [:representation abstraction representation] - ) - -(def: abstraction_type_name - (-> Name Text) - (|>> name\encode - ($_ text\compose - (name\encode (name_of #..Abstraction)) - " "))) - -(def: representation_definition_name - (-> Text Text) - (|>> ($_ text\compose - (name\encode (name_of #..Representation)) - " "))) - -(def: declaration - (Parser [Text (List Text)]) - (<>.either (<code>.form (<>.and <code>.local_identifier (<>.some <code>.local_identifier))) - (<>.and <code>.local_identifier (\ <>.monad wrap (list))))) - -## TODO: Make sure the generated code always gets optimized away. -## (This applies to uses of ":abstraction" and ":representation") -(syntax: #export (abstract: - {export |export|.parser} - {[name type_vars] declaration} - representation_type - {annotations (<>.default |annotations|.empty |annotations|.parser)} - {primitives (<>.some <code>.any)}) - (do meta.monad - [current_module meta.current_module_name - #let [type_varsC (list\map code.local_identifier type_vars) - abstraction_declaration (` ((~ (code.local_identifier name)) (~+ type_varsC))) - representation_declaration (` ((~ (code.local_identifier (representation_definition_name name))) - (~+ type_varsC)))] - _ (..push! [name - type_varsC - abstraction_declaration - representation_declaration])] - (wrap (list& (` (type: (~+ (|export|.format export)) (~ abstraction_declaration) - (~ (|annotations|.format annotations)) - (primitive (~ (code.text (abstraction_type_name [current_module name]))) - [(~+ type_varsC)]))) - (` (type: (~ representation_declaration) - (~ representation_type))) - ($_ list\compose - primitives - (list (` ((~! ..pop!))))))))) - -(type: (Selection a) - (#Specific Code a) - (#Current a)) - -(def: (selection parser) - (All [a] (-> (Parser a) (Parser (Selection a)))) - (<>.or (<>.and <code>.any parser) - parser)) - -(syntax: #export (:transmutation {selection (..selection <code>.any)}) - (case selection - (#Specific specific value) - (wrap (list (` (..:abstraction (~ specific) - (..:representation (~ specific) - (~ value)))))) - - (#Current value) - (wrap (list (` (..:abstraction (..:representation (~ value)))))))) - -(syntax: #export (^:representation {selection (<code>.form (..selection <code>.local_identifier))} - body - {branches (<>.some <code>.any)}) - (case selection - (#Specific specific name) - (let [g!var (code.local_identifier name)] - (wrap (list& g!var - (` (.let [(~ g!var) (..:representation (~ specific) (~ g!var))] - (~ body))) - branches))) - - (#Current name) - (let [g!var (code.local_identifier name)] - (wrap (list& g!var - (` (.let [(~ g!var) (..:representation (~ g!var))] - (~ body))) - branches))))) diff --git a/stdlib/source/lux/type/check.lux b/stdlib/source/lux/type/check.lux deleted file mode 100644 index 3882591e5..000000000 --- a/stdlib/source/lux/type/check.lux +++ /dev/null @@ -1,720 +0,0 @@ -(.module: {#.doc "Type-checking functionality."} - [lux #* - ["@" target] - [abstract - [functor (#+ Functor)] - [apply (#+ Apply)] - ["." monad (#+ Monad do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ Exception exception:)]] - [data - ["." maybe] - ["." product] - ["." text ("#\." monoid equivalence)] - [collection - ["." list] - ["." set (#+ Set)]]] - [math - [number - ["n" nat ("#\." decimal)]]]] - ["." // ("#\." equivalence)]) - -(template: (!n\= reference subject) - ("lux i64 =" reference subject)) - -(template: (!text\= reference subject) - ("lux text =" reference subject)) - -(exception: #export (unknown_type_var {id Nat}) - (exception.report - ["ID" (n\encode id)])) - -(exception: #export (unbound_type_var {id Nat}) - (exception.report - ["ID" (n\encode id)])) - -(exception: #export (invalid_type_application {funcT Type} {argT Type}) - (exception.report - ["Type function" (//.format funcT)] - ["Type argument" (//.format argT)])) - -(exception: #export (cannot_rebind_var {id Nat} {type Type} {bound Type}) - (exception.report - ["Var" (n\encode id)] - ["Wanted Type" (//.format type)] - ["Current Type" (//.format bound)])) - -(exception: #export (type_check_failed {expected Type} {actual Type}) - (exception.report - ["Expected" (//.format expected)] - ["Actual" (//.format actual)])) - -(type: #export Var - Nat) - -(type: Assumption - [Type Type]) - -(type: #export (Check a) - (-> Type_Context (Try [Type_Context a]))) - -(type: (Checker a) - (-> (List Assumption) a a (Check (List Assumption)))) - -(type: Type_Vars - (List [Var (Maybe Type)])) - -(implementation: #export functor - (Functor Check) - - (def: (map f fa) - (function (_ context) - (case (fa context) - (#try.Success [context' output]) - (#try.Success [context' (f output)]) - - (#try.Failure error) - (#try.Failure error))))) - -(implementation: #export apply - (Apply Check) - - (def: &functor ..functor) - - (def: (apply ff fa) - (function (_ context) - (case (ff context) - (#try.Success [context' f]) - (case (fa context') - (#try.Success [context'' a]) - (#try.Success [context'' (f a)]) - - (#try.Failure error) - (#try.Failure error)) - - (#try.Failure error) - (#try.Failure error) - ))) - ) - -(implementation: #export monad - (Monad Check) - - (def: &functor ..functor) - - (def: (wrap x) - (function (_ context) - (#try.Success [context x]))) - - (def: (join ffa) - (function (_ context) - (case (ffa context) - (#try.Success [context' fa]) - (case (fa context') - (#try.Success [context'' a]) - (#try.Success [context'' a]) - - (#try.Failure error) - (#try.Failure error)) - - (#try.Failure error) - (#try.Failure error) - ))) - ) - -(open: "check\." ..monad) - -(def: (var::new id plist) - (-> Var Type_Vars Type_Vars) - (#.Cons [id #.None] plist)) - -(def: (var::get id plist) - (-> Var Type_Vars (Maybe (Maybe Type))) - (case plist - (#.Cons [var_id var_type] - plist') - (if (!n\= id var_id) - (#.Some var_type) - (var::get id plist')) - - #.Nil - #.None)) - -(def: (var::put id value plist) - (-> Var (Maybe Type) Type_Vars Type_Vars) - (case plist - #.Nil - (list [id value]) - - (#.Cons [var_id var_type] - plist') - (if (!n\= id var_id) - (#.Cons [var_id value] - plist') - (#.Cons [var_id var_type] - (var::put id value plist'))))) - -(def: #export (run context proc) - (All [a] (-> Type_Context (Check a) (Try a))) - (case (proc context) - (#try.Success [context' output]) - (#try.Success output) - - (#try.Failure error) - (#try.Failure error))) - -(def: #export (fail message) - (All [a] (-> Text (Check a))) - (function (_ context) - (#try.Failure message))) - -(def: #export (assert message test) - (-> Text Bit (Check Any)) - (function (_ context) - (if test - (#try.Success [context []]) - (#try.Failure message)))) - -(def: #export (throw exception message) - (All [e a] (-> (Exception e) e (Check a))) - (..fail (exception.construct exception message))) - -(def: #export existential - {#.doc "A producer of existential types."} - (Check [Nat Type]) - (function (_ context) - (let [id (get@ #.ex_counter context)] - (#try.Success [(update@ #.ex_counter inc context) - [id (#.Ex id)]])))) - -(template [<name> <outputT> <fail> <succeed>] - [(def: #export (<name> id) - (-> Var (Check <outputT>)) - (function (_ context) - (case (|> context (get@ #.var_bindings) (var::get id)) - (^or (#.Some (#.Some (#.Var _))) - (#.Some #.None)) - (#try.Success [context <fail>]) - - (#.Some (#.Some bound)) - (#try.Success [context <succeed>]) - - #.None - (exception.throw ..unknown_type_var id))))] - - [bound? Bit false true] - [read (Maybe Type) #.None (#.Some bound)] - ) - -(def: #export (read! id) - (-> Var (Check Type)) - (do ..monad - [?type (read id)] - (case ?type - (#.Some type) - (wrap type) - - #.None - (..throw ..unbound_type_var id)))) - -(def: (peek id) - (-> Var (Check Type)) - (function (_ context) - (case (|> context (get@ #.var_bindings) (var::get id)) - (#.Some (#.Some bound)) - (#try.Success [context bound]) - - (#.Some _) - (exception.throw ..unbound_type_var id) - - _ - (exception.throw ..unknown_type_var id)))) - -(def: #export (bind type id) - (-> Type Var (Check Any)) - (function (_ context) - (case (|> context (get@ #.var_bindings) (var::get id)) - (#.Some #.None) - (#try.Success [(update@ #.var_bindings (var::put id (#.Some type)) context) - []]) - - (#.Some (#.Some bound)) - (exception.throw ..cannot_rebind_var [id type bound]) - - _ - (exception.throw ..unknown_type_var id)))) - -(def: (update type id) - (-> Type Var (Check Any)) - (function (_ context) - (case (|> context (get@ #.var_bindings) (var::get id)) - (#.Some _) - (#try.Success [(update@ #.var_bindings (var::put id (#.Some type)) context) - []]) - - _ - (exception.throw ..unknown_type_var id)))) - -(def: #export var - (Check [Var Type]) - (function (_ context) - (let [id (get@ #.var_counter context)] - (#try.Success [(|> context - (update@ #.var_counter inc) - (update@ #.var_bindings (var::new id))) - [id (#.Var id)]])))) - -(def: (apply_type! funcT argT) - (-> Type Type (Check Type)) - (case funcT - (#.Var func_id) - (do ..monad - [?funcT' (read func_id)] - (case ?funcT' - (#.Some funcT') - (apply_type! funcT' argT) - - _ - (throw ..invalid_type_application [funcT argT]))) - - (#.Apply argT' funcT') - (do ..monad - [funcT'' (apply_type! funcT' argT')] - (apply_type! funcT'' argT)) - - _ - (case (//.apply (list argT) funcT) - (#.Some output) - (check\wrap output) - - _ - (throw ..invalid_type_application [funcT argT])))) - -(type: Ring - (Set Var)) - -(def: empty_ring - Ring - (set.new n.hash)) - -## TODO: Optimize this by not using sets anymore. -(def: (ring start) - (-> Var (Check Ring)) - (function (_ context) - (loop [current start - output (set.add start empty_ring)] - (case (|> context (get@ #.var_bindings) (var::get current)) - (#.Some (#.Some type)) - (case type - (#.Var post) - (if (!n\= start post) - (#try.Success [context output]) - (recur post (set.add post output))) - - _ - (#try.Success [context empty_ring])) - - (#.Some #.None) - (#try.Success [context output]) - - #.None - (exception.throw ..unknown_type_var current))))) - -(def: #export fresh_context - Type_Context - {#.var_counter 0 - #.ex_counter 0 - #.var_bindings (list)}) - -(def: (attempt op) - (All [a] (-> (Check a) (Check (Maybe a)))) - (function (_ context) - (case (op context) - (#try.Success [context' output]) - (#try.Success [context' (#.Some output)]) - - (#try.Failure _) - (#try.Success [context #.None])))) - -(def: (either left right) - (All [a] (-> (Check a) (Check a) (Check a))) - (function (_ context) - (case (left context) - (#try.Failure _) - (right context) - - output - output))) - -(def: (assumed? [e a] assumptions) - (-> Assumption (List Assumption) Bit) - (list.any? (function (_ [e' a']) - (and (//\= e e') - (//\= a a'))) - assumptions)) - -(def: (assume! assumption assumptions) - (-> Assumption (List Assumption) (List Assumption)) - (#.Cons assumption assumptions)) - -## TODO: "if_bind" can be optimized... -(def: (if_bind id type then else) - (All [a] - (-> Var Type (Check a) (-> Type (Check a)) - (Check a))) - ($_ either - (do ..monad - [_ (..bind type id)] - then) - (do {! ..monad} - [ring (..ring id) - _ (assert "" (n.> 1 (set.size ring))) - _ (monad.map ! (update type) (set.to_list ring))] - then) - (do ..monad - [?bound (read id)] - (else (maybe.default (#.Var id) ?bound))))) - -## TODO: "link_2" can be optimized... -(def: (link_2 left right) - (-> Var Var (Check Any)) - (do ..monad - [_ (..bind (#.Var right) left)] - (..bind (#.Var left) right))) - -## TODO: "link_3" can be optimized... -(def: (link_3 interpose to from) - (-> Var Var Var (Check Any)) - (do ..monad - [_ (update (#.Var interpose) from)] - (update (#.Var to) interpose))) - -## TODO: "check_vars" can be optimized... -(def: (check_vars check' assumptions idE idA) - (-> (Checker Type) (Checker Var)) - (if (!n\= idE idA) - (check\wrap assumptions) - (do {! ..monad} - [ebound (attempt (peek idE)) - abound (attempt (peek idA))] - (case [ebound abound] - ## Link the 2 variables circularly - [#.None #.None] - (do ! - [_ (link_2 idE idA)] - (wrap assumptions)) - - ## Interpose new variable between 2 existing links - [(#.Some etype) #.None] - (case etype - (#.Var targetE) - (do ! - [_ (link_3 idA targetE idE)] - (wrap assumptions)) - - _ - (check' assumptions etype (#.Var idA))) - - ## Interpose new variable between 2 existing links - [#.None (#.Some atype)] - (case atype - (#.Var targetA) - (do ! - [_ (link_3 idE targetA idA)] - (wrap assumptions)) - - _ - (check' assumptions (#.Var idE) atype)) - - [(#.Some etype) (#.Some atype)] - (case [etype atype] - [(#.Var targetE) (#.Var targetA)] - (do ! - [ringE (..ring idE) - ringA (..ring idA)] - (if (\ set.equivalence = ringE ringA) - (wrap assumptions) - ## Fuse 2 rings - (do ! - [_ (monad.fold ! (function (_ interpose to) - (do ! - [_ (link_3 interpose to idE)] - (wrap interpose))) - targetE - (set.to_list ringA))] - (wrap assumptions)))) - - (^template [<pattern> <id> <type>] - [<pattern> - (do ! - [ring (..ring <id>) - _ (monad.map ! (update <type>) (set.to_list ring))] - (wrap assumptions))]) - ([[(#.Var _) _] idE atype] - [[_ (#.Var _)] idA etype]) - - _ - (check' assumptions etype atype)))))) - -(def: silent_failure! - (All [a] (Check a)) - (..fail "")) - -## TODO: "check_apply" can be optimized... -(def: (check_apply check' assumptions expected actual) - (-> (Checker Type) (Checker [Type Type])) - (let [[expected_input expected_function] expected - [actual_input actual_function] actual] - (case [expected_function actual_function] - [(#.Ex exE) (#.Ex exA)] - (if (!n\= exE exA) - (check' assumptions expected_input actual_input) - ..silent_failure!) - - [(#.UnivQ _ _) (#.Ex _)] - (do ..monad - [expected' (apply_type! expected_function expected_input)] - (check' assumptions expected' (#.Apply actual))) - - [(#.Ex _) (#.UnivQ _ _)] - (do ..monad - [actual' (apply_type! actual_function actual_input)] - (check' assumptions (#.Apply expected) actual')) - - [(#.Apply [expected_input' expected_function']) (#.Ex _)] - (do ..monad - [expected_function'' (apply_type! expected_function' expected_input')] - (check' assumptions (#.Apply [expected_input expected_function'']) (#.Apply actual))) - - [(#.Ex _) (#.Apply [actual_input' actual_function'])] - (do ..monad - [actual_function'' (apply_type! actual_function' actual_input')] - (check' assumptions (#.Apply expected) (#.Apply [actual_input actual_function'']))) - - (^or [(#.Ex _) _] [_ (#.Ex _)]) - (do ..monad - [assumptions (check' assumptions expected_function actual_function)] - (check' assumptions expected_input actual_input)) - - [(#.Var id) _] - (function (_ context) - (case ((do ..monad - [expected_function' (..read! id)] - (check' assumptions (#.Apply expected_input expected_function') (#.Apply actual))) - context) - (#try.Success output) - (#try.Success output) - - (#try.Failure _) - (case actual_function - (#.UnivQ _ _) - ((do ..monad - [actual' (apply_type! actual_function actual_input)] - (check' assumptions (#.Apply expected) actual')) - context) - - (#.Ex exA) - ((do ..monad - [assumptions (check' assumptions expected_function actual_function)] - (check' assumptions expected_input actual_input)) - context) - - _ - ((do ..monad - [assumptions (check' assumptions expected_function actual_function) - expected' (apply_type! actual_function expected_input) - actual' (apply_type! actual_function actual_input)] - (check' assumptions expected' actual')) - context)))) - - [_ (#.Var id)] - (function (_ context) - (case ((do ..monad - [actual_function' (read! id)] - (check' assumptions (#.Apply expected) (#.Apply actual_input actual_function'))) - context) - (#try.Success output) - (#try.Success output) - - _ - ((do ..monad - [assumptions (check' assumptions expected_function actual_function) - expected' (apply_type! expected_function expected_input) - actual' (apply_type! expected_function actual_input)] - (check' assumptions expected' actual')) - context))) - - _ - ..silent_failure!))) - -(def: (with exception parameter check) - (All [e a] (-> (Exception e) e (Check a) (Check a))) - (|>> check (exception.with exception parameter))) - -## TODO: "check'" can be optimized... -(def: (check' assumptions expected actual) - {#.doc "Type-check to ensure that the 'expected' type subsumes the 'actual' type."} - (Checker Type) - (if (for {@.php false} ## TODO: Remove this once JPHP is gone. - (is? expected actual)) - (check\wrap assumptions) - (with ..type_check_failed [expected actual] - (case [expected actual] - [(#.Var idE) (#.Var idA)] - (check_vars check' assumptions idE idA) - - [(#.Var id) _] - (if_bind id actual - (check\wrap assumptions) - (function (_ bound) - (check' assumptions bound actual))) - - [_ (#.Var id)] - (if_bind id expected - (check\wrap assumptions) - (function (_ bound) - (check' assumptions expected bound))) - - (^template [<fE> <fA>] - [[(#.Apply aE <fE>) (#.Apply aA <fA>)] - (check_apply check' assumptions [aE <fE>] [aA <fA>])]) - ([F1 (#.Ex ex)] - [(#.Ex exE) fA] - [fE (#.Var idA)] - [(#.Var idE) fA]) - - [(#.Apply A F) _] - (let [new_assumption [expected actual]] - (if (assumed? new_assumption assumptions) - (check\wrap assumptions) - (do ..monad - [expected' (apply_type! F A)] - (check' (assume! new_assumption assumptions) expected' actual)))) - - [_ (#.Apply A F)] - (do ..monad - [actual' (apply_type! F A)] - (check' assumptions expected actual')) - - ## TODO: Refactor-away as cold-code - (^template [<tag> <instancer>] - [[(<tag> _) _] - (do ..monad - [[_ paramT] <instancer> - expected' (apply_type! expected paramT)] - (check' assumptions expected' actual))]) - ([#.UnivQ ..existential] - [#.ExQ ..var]) - - ## TODO: Refactor-away as cold-code - (^template [<tag> <instancer>] - [[_ (<tag> _)] - (do ..monad - [[_ paramT] <instancer> - actual' (apply_type! actual paramT)] - (check' assumptions expected actual'))]) - ([#.UnivQ ..var] - [#.ExQ ..existential]) - - [(#.Primitive e_name e_params) (#.Primitive a_name a_params)] - (if (!text\= e_name a_name) - (loop [assumptions assumptions - e_params e_params - a_params a_params] - (case [e_params a_params] - [#.Nil #.Nil] - (check\wrap assumptions) - - [(#.Cons e_head e_tail) (#.Cons a_head a_tail)] - (do ..monad - [assumptions' (check' assumptions e_head a_head)] - (recur assumptions' e_tail a_tail)) - - _ - ..silent_failure!)) - ..silent_failure!) - - (^template [<compose>] - [[(<compose> eL eR) (<compose> aL aR)] - (do ..monad - [assumptions (check' assumptions eL aL)] - (check' assumptions eR aR))]) - ([#.Sum] - [#.Product]) - - [(#.Function eI eO) (#.Function aI aO)] - (do ..monad - [assumptions (check' assumptions aI eI)] - (check' assumptions eO aO)) - - [(#.Ex e!id) (#.Ex a!id)] - (if (!n\= e!id a!id) - (check\wrap assumptions) - ..silent_failure!) - - [(#.Named _ ?etype) _] - (check' assumptions ?etype actual) - - [_ (#.Named _ ?atype)] - (check' assumptions expected ?atype) - - _ - ..silent_failure!)))) - -(def: #export (check expected actual) - {#.doc "Type-check to ensure that the 'expected' type subsumes the 'actual' type."} - (-> Type Type (Check Any)) - (check' (list) expected actual)) - -(def: #export (checks? expected actual) - {#.doc "A simple type-checking function that just returns a yes/no answer."} - (-> Type Type Bit) - (case (..run ..fresh_context (..check' (list) expected actual)) - (#try.Failure _) - false - - (#try.Success _) - true)) - -(def: #export context - (Check Type_Context) - (function (_ context) - (#try.Success [context context]))) - -(def: #export (clean inputT) - (-> Type (Check Type)) - (case inputT - (#.Primitive name paramsT+) - (|> paramsT+ - (monad.map ..monad clean) - (check\map (|>> (#.Primitive name)))) - - (^or (#.Parameter _) (#.Ex _) (#.Named _)) - (check\wrap inputT) - - (^template [<tag>] - [(<tag> leftT rightT) - (do ..monad - [leftT' (clean leftT)] - (|> (clean rightT) - (check\map (|>> (<tag> leftT')))))]) - ([#.Sum] [#.Product] [#.Function] [#.Apply]) - - (#.Var id) - (do ..monad - [?actualT (read id)] - (case ?actualT - (#.Some actualT) - (clean actualT) - - _ - (wrap inputT))) - - (^template [<tag>] - [(<tag> envT+ unquantifiedT) - (do {! ..monad} - [envT+' (monad.map ! clean envT+)] - (wrap (<tag> envT+' unquantifiedT)))]) - ([#.UnivQ] [#.ExQ]) - )) diff --git a/stdlib/source/lux/type/dynamic.lux b/stdlib/source/lux/type/dynamic.lux deleted file mode 100644 index 754e682f2..000000000 --- a/stdlib/source/lux/type/dynamic.lux +++ /dev/null @@ -1,50 +0,0 @@ -(.module: - [lux #* - ["." debug] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - [text - ["%" format]]] - [macro (#+ with_gensyms) - ["." syntax (#+ syntax:)]] - ["." type - abstract]]) - -(exception: #export (wrong_type {expected Type} {actual Type}) - (exception.report - ["Expected" (%.type expected)] - ["Actual" (%.type actual)])) - -(abstract: #export Dynamic - [Type Any] - - {#.doc "A value coupled with its type, so it can be checked later."} - - (def: abstraction (-> [Type Any] Dynamic) (|>> :abstraction)) - (def: representation (-> Dynamic [Type Any]) (|>> :representation)) - - (syntax: #export (:dynamic value) - {#.doc (doc (: Dynamic - (:dynamic 123)))} - (with_gensyms [g!value] - (wrap (list (` (let [(~ g!value) (~ value)] - ((~! ..abstraction) [(:of (~ g!value)) (~ g!value)]))))))) - - (syntax: #export (:check type value) - {#.doc (doc (: (try.Try Nat) - (:check Nat (:dynamic 123))))} - (with_gensyms [g!type g!value] - (wrap (list (` (let [[(~ g!type) (~ g!value)] ((~! ..representation) (~ value))] - (: ((~! try.Try) (~ type)) - (if (\ (~! type.equivalence) (~' =) - (.type (~ type)) (~ g!type)) - (#try.Success (:as (~ type) (~ g!value))) - ((~! exception.throw) ..wrong_type [(.type (~ type)) (~ g!type)]))))))))) - - (def: #export (format value) - (-> Dynamic (Try Text)) - (let [[type value] (:representation value)] - (debug.represent type value))) - ) diff --git a/stdlib/source/lux/type/implicit.lux b/stdlib/source/lux/type/implicit.lux deleted file mode 100644 index 14f2ac441..000000000 --- a/stdlib/source/lux/type/implicit.lux +++ /dev/null @@ -1,400 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ Monad do)] - ["eq" equivalence]] - [control - ["." try] - ["p" parser - ["s" code (#+ Parser)]]] - [data - ["." product] - ["." maybe] - ["." text ("#\." equivalence) - ["%" format (#+ format)]] - [collection - ["." list ("#\." monad fold)] - ["." dictionary (#+ Dictionary)]]] - ["." macro - ["." code] - [syntax (#+ syntax:)]] - [math - ["." number - ["n" nat]]] - ["." meta - ["." annotation]] - ["." type - ["." check (#+ Check)]]]) - -(def: (find_type_var id env) - (-> Nat Type_Context (Meta Type)) - (case (list.find (|>> product.left (n.= id)) - (get@ #.var_bindings env)) - (#.Some [_ (#.Some type)]) - (case type - (#.Var id') - (find_type_var id' env) - - _ - (\ meta.monad wrap type)) - - (#.Some [_ #.None]) - (meta.fail (format "Unbound type-var " (%.nat id))) - - #.None - (meta.fail (format "Unknown type-var " (%.nat id))) - )) - -(def: (resolve_type var_name) - (-> Name (Meta Type)) - (do meta.monad - [raw_type (meta.find_type var_name) - compiler meta.get_compiler] - (case raw_type - (#.Var id) - (find_type_var id (get@ #.type_context compiler)) - - _ - (wrap raw_type)))) - -(def: (find_member_type idx sig_type) - (-> Nat Type (Check Type)) - (case sig_type - (#.Named _ sig_type') - (find_member_type idx sig_type') - - (#.Apply arg func) - (case (type.apply (list arg) func) - #.None - (check.fail (format "Cannot apply type " (%.type func) " to type " (%.type arg))) - - (#.Some sig_type') - (find_member_type idx sig_type')) - - (#.Product left right) - (if (n.= 0 idx) - (\ check.monad wrap left) - (find_member_type (dec idx) right)) - - _ - (if (n.= 0 idx) - (\ check.monad wrap sig_type) - (check.fail (format "Cannot find member type " (%.nat idx) " for " (%.type sig_type)))))) - -(def: (find_member_name member) - (-> Name (Meta Name)) - (case member - ["" simple_name] - (meta.either (do meta.monad - [member (meta.normalize member) - _ (meta.resolve_tag member)] - (wrap member)) - (do {! meta.monad} - [this_module_name meta.current_module_name - imp_mods (meta.imported_modules this_module_name) - tag_lists (monad.map ! meta.tag_lists imp_mods) - #let [tag_lists (|> tag_lists list\join (list\map product.left) list\join) - candidates (list.filter (|>> product.right (text\= simple_name)) - tag_lists)]] - (case candidates - #.Nil - (meta.fail (format "Unknown tag: " (%.name member))) - - (#.Cons winner #.Nil) - (wrap winner) - - _ - (meta.fail (format "Too many candidate tags: " (%.list %.name candidates)))))) - - _ - (\ meta.monad wrap member))) - -(def: (resolve_member member) - (-> Name (Meta [Nat Type])) - (do meta.monad - [member (find_member_name member) - [idx tag_list sig_type] (meta.resolve_tag member)] - (wrap [idx sig_type]))) - -(def: (prepare_definitions source_module target_module constants aggregate) - (-> Text Text (List [Text Definition]) (-> (List [Name Type]) (List [Name Type]))) - (list\fold (function (_ [name [exported? def_type def_anns def_value]] aggregate) - (if (and (annotation.implementation? def_anns) - (or (text\= target_module source_module) - exported?)) - (#.Cons [[source_module name] def_type] aggregate) - aggregate)) - aggregate - constants)) - -(def: local_env - (Meta (List [Name Type])) - (do meta.monad - [local_batches meta.locals - #let [total_locals (list\fold (function (_ [name type] table) - (try.default table (dictionary.try_put name type table))) - (: (Dictionary Text Type) - (dictionary.new text.hash)) - (list\join local_batches))]] - (wrap (|> total_locals - dictionary.entries - (list\map (function (_ [name type]) [["" name] type])))))) - -(def: local_structs - (Meta (List [Name Type])) - (do {! meta.monad} - [this_module_name meta.current_module_name - definitions (meta.definitions this_module_name)] - (wrap (prepare_definitions this_module_name this_module_name definitions #.Nil)))) - -(def: imported_structs - (Meta (List [Name Type])) - (do {! meta.monad} - [this_module_name meta.current_module_name - imported_modules (meta.imported_modules this_module_name) - accessible_definitions (monad.map ! meta.definitions imported_modules)] - (wrap (list\fold (function (_ [imported_module definitions] tail) - (prepare_definitions imported_module this_module_name definitions tail)) - #.Nil - (list.zip/2 imported_modules accessible_definitions))))) - -(def: (apply_function_type func arg) - (-> Type Type (Check Type)) - (case func - (#.Named _ func') - (apply_function_type func' arg) - - (#.UnivQ _) - (do check.monad - [[id var] check.var] - (apply_function_type (maybe.assume (type.apply (list var) func)) - arg)) - - (#.Function input output) - (do check.monad - [_ (check.check input arg)] - (wrap output)) - - _ - (check.fail (format "Invalid function type: " (%.type func))))) - -(def: (concrete_type type) - (-> Type (Check [(List Nat) Type])) - (case type - (#.UnivQ _) - (do check.monad - [[id var] check.var - [ids final_output] (concrete_type (maybe.assume (type.apply (list var) type)))] - (wrap [(#.Cons id ids) - final_output])) - - _ - (\ check.monad wrap [(list) type]))) - -(def: (check_apply member_type input_types output_type) - (-> Type (List Type) Type (Check [])) - (do check.monad - [member_type' (monad.fold check.monad - (function (_ input member) - (apply_function_type member input)) - member_type - input_types)] - (check.check output_type member_type'))) - -(type: #rec Instance - {#constructor Name - #dependencies (List Instance)}) - -(def: (test_provision provision context dep alts) - (-> (-> Lux Type_Context Type (Check Instance)) - Type_Context Type (List [Name Type]) - (Meta (List Instance))) - (do meta.monad - [compiler meta.get_compiler] - (case (|> alts - (list\map (function (_ [alt_name alt_type]) - (case (check.run context - (do {! check.monad} - [[tvars alt_type] (concrete_type alt_type) - #let [[deps alt_type] (type.flatten_function alt_type)] - _ (check.check dep alt_type) - context' check.context - =deps (monad.map ! (provision compiler context') deps)] - (wrap =deps))) - (#.Left error) - (list) - - (#.Right =deps) - (list [alt_name =deps])))) - list\join) - #.Nil - (meta.fail (format "No candidates for provisioning: " (%.type dep))) - - found - (wrap found)))) - -(def: (provision compiler context dep) - (-> Lux Type_Context Type (Check Instance)) - (case (meta.run compiler - ($_ meta.either - (do meta.monad [alts ..local_env] (..test_provision provision context dep alts)) - (do meta.monad [alts ..local_structs] (..test_provision provision context dep alts)) - (do meta.monad [alts ..imported_structs] (..test_provision provision context dep alts)))) - (#.Left error) - (check.fail error) - - (#.Right candidates) - (case candidates - #.Nil - (check.fail (format "No candidates for provisioning: " (%.type dep))) - - (#.Cons winner #.Nil) - (\ check.monad wrap winner) - - _ - (check.fail (format "Too many candidates for provisioning: " (%.type dep) " --- " (%.list (|>> product.left %.name) candidates)))) - )) - -(def: (test_alternatives sig_type member_idx input_types output_type alts) - (-> Type Nat (List Type) Type (List [Name Type]) (Meta (List Instance))) - (do meta.monad - [compiler meta.get_compiler - context meta.type_context] - (case (|> alts - (list\map (function (_ [alt_name alt_type]) - (case (check.run context - (do {! check.monad} - [[tvars alt_type] (concrete_type alt_type) - #let [[deps alt_type] (type.flatten_function alt_type)] - _ (check.check alt_type sig_type) - member_type (find_member_type member_idx alt_type) - _ (check_apply member_type input_types output_type) - context' check.context - =deps (monad.map ! (provision compiler context') deps)] - (wrap =deps))) - (#.Left error) - (list) - - (#.Right =deps) - (list [alt_name =deps])))) - list\join) - #.Nil - (meta.fail (format "No alternatives for " (%.type (type.function input_types output_type)))) - - found - (wrap found)))) - -(def: (find_alternatives sig_type member_idx input_types output_type) - (-> Type Nat (List Type) Type (Meta (List Instance))) - (let [test (test_alternatives sig_type member_idx input_types output_type)] - ($_ meta.either - (do meta.monad [alts ..local_env] (test alts)) - (do meta.monad [alts ..local_structs] (test alts)) - (do meta.monad [alts ..imported_structs] (test alts))))) - -(def: (var? input) - (-> Code Bit) - (case input - [_ (#.Identifier _)] - #1 - - _ - #0)) - -(def: (join_pair [l r]) - (All [a] (-> [a a] (List a))) - (list l r)) - -(def: (instance$ [constructor dependencies]) - (-> Instance Code) - (case dependencies - #.Nil - (code.identifier constructor) - - _ - (` ((~ (code.identifier constructor)) (~+ (list\map instance$ dependencies)))))) - -(syntax: #export (\\ - {member s.identifier} - {args (p.or (p.and (p.some s.identifier) s.end!) - (p.and (p.some s.any) s.end!))}) - {#.doc (doc "Automatic implementation selection (for type-class style polymorphism)." - "This feature layers type-class style polymorphism on top of Lux's signatures and implementations." - "When calling a polymorphic function, or using a polymorphic constant," - "this macro will check the types of the arguments, and the expected type for the whole expression" - "and it will search in the local scope, the module's scope and the imports' scope" - "in order to find suitable implementations to satisfy those requirements." - "If a single alternative is found, that one will be used automatically." - "If no alternative is found, or if more than one alternative is found (ambiguity)" - "a compile-time error will be raised, to alert the user." - "Examples:" - "Nat equivalence" - (\ number.equivalence = x y) - (\\ = x y) - "Can optionally add the prefix of the module where the signature was defined." - (\\ eq.= x y) - "(List Nat) equivalence" - (\\ = - (list.indices 10) - (list.indices 10)) - "(Functor List) map" - (\\ map inc (list.indices 10)) - "Caveat emptor: You need to make sure to import the module of any implementation you want to use." - "Otherwise, this macro will not find it.")} - (case args - (#.Left [args _]) - (do {! meta.monad} - [[member_idx sig_type] (resolve_member member) - input_types (monad.map ! resolve_type args) - output_type meta.expected_type - chosen_ones (find_alternatives sig_type member_idx input_types output_type)] - (case chosen_ones - #.Nil - (meta.fail (format "No implementation could be found for member: " (%.name member))) - - (#.Cons chosen #.Nil) - (wrap (list (` (\ (~ (instance$ chosen)) - (~ (code.local_identifier (product.right member))) - (~+ (list\map code.identifier args)))))) - - _ - (meta.fail (format "Too many implementations available: " - (|> chosen_ones - (list\map (|>> product.left %.name)) - (text.join_with ", ")) - " --- for type: " (%.type sig_type))))) - - (#.Right [args _]) - (do {! meta.monad} - [labels (|> (macro.gensym "") (list.repeat (list.size args)) (monad.seq !))] - (wrap (list (` (let [(~+ (|> (list.zip/2 labels args) (list\map join_pair) list\join))] - (..\\ (~ (code.identifier member)) (~+ labels))))))) - )) - -(def: (implicit_bindings amount) - (-> Nat (Meta (List Code))) - (|> (macro.gensym "g!implicit") - (list.repeat amount) - (monad.seq meta.monad))) - -(def: implicits - (Parser (List Code)) - (s.tuple (p.many s.any))) - -(syntax: #export (with {implementations ..implicits} body) - (do meta.monad - [g!implicit+ (implicit_bindings (list.size implementations))] - (wrap (list (` (let [(~+ (|> (list.zip/2 g!implicit+ implementations) - (list\map (function (_ [g!implicit implementation]) - (list g!implicit implementation))) - list\join))] - (~ body))))))) - -(syntax: #export (implicit: {implementations ..implicits}) - (do meta.monad - [g!implicit+ (implicit_bindings (list.size implementations))] - (wrap (|> (list.zip/2 g!implicit+ implementations) - (list\map (function (_ [g!implicit implementation]) - (` (def: (~ g!implicit) - {#.implementation? #1} - (~ implementation))))))))) diff --git a/stdlib/source/lux/type/quotient.lux b/stdlib/source/lux/type/quotient.lux deleted file mode 100644 index dd47b6bf3..000000000 --- a/stdlib/source/lux/type/quotient.lux +++ /dev/null @@ -1,55 +0,0 @@ -(.module: - [lux (#- type) - [abstract - [equivalence (#+ Equivalence)]] - [macro (#+ with_gensyms) - [syntax (#+ syntax:)]] - ["." type - abstract]]) - -(abstract: #export (Class t c %) - (-> t c) - - (def: #export class - (All [t c] - (Ex [%] - (-> (-> t c) (Class t c %)))) - (|>> :abstraction)) - - (abstract: #export (Quotient t c %) - {#value t - #label c} - - (def: #export (quotient class value) - (All [t c %] - (-> (Class t c %) t - (Quotient t c %))) - (:abstraction {#value value - #label ((:representation Class class) value)})) - - (template [<name> <output> <slot>] - [(def: #export <name> - (All [t c %] (-> (Quotient t c %) <output>)) - (|>> :representation (get@ <slot>)))] - - [value t #value] - [label c #label] - ) - ) - ) - -(syntax: #export (type class) - (with_gensyms [g!t g!c g!%] - (wrap (list (` ((~! type.:by_example) - [(~ g!t) (~ g!c) (~ g!%)] - - (..Class (~ g!t) (~ g!c) (~ g!%)) - (~ class) - - (..Quotient (~ g!t) (~ g!c) (~ g!%)))))))) - -(implementation: #export (equivalence super) - (All [t c %] (-> (Equivalence c) (Equivalence (..Quotient t c %)))) - - (def: (= reference sample) - (\ super = (..label reference) (..label sample)))) diff --git a/stdlib/source/lux/type/refinement.lux b/stdlib/source/lux/type/refinement.lux deleted file mode 100644 index 5bbc90149..000000000 --- a/stdlib/source/lux/type/refinement.lux +++ /dev/null @@ -1,88 +0,0 @@ -(.module: - [lux (#- type) - [abstract - [predicate (#+ Predicate)]] - ["." macro - [syntax (#+ syntax:)]] - ["." type - abstract]]) - -(abstract: #export (Refined t %) - {#value t - #predicate (Predicate t)} - - {#.doc "A refined type '%' of base type 't' using a predicate."} - - (type: #export (Refiner t %) - (-> t (Maybe (Refined t %)))) - - (def: #export (refinement predicate) - (All [t] - (Ex [%] - (-> (Predicate t) (Refiner t %)))) - (function (_ un_refined) - (if (predicate un_refined) - (#.Some (:abstraction {#value un_refined - #predicate predicate})) - #.None))) - - (template [<name> <output> <slot>] - [(def: #export <name> - (All [t %] (-> (Refined t %) <output>)) - (|>> :representation (get@ <slot>)))] - - [un_refine t #value] - [predicate (Predicate t) #predicate] - ) - - (def: #export (lift transform) - (All [t %] - (-> (-> t t) - (-> (Refined t %) (Maybe (Refined t %))))) - (function (_ refined) - (let [(^slots [#value #predicate]) (:representation refined) - value' (transform value)] - (if (predicate value') - (#.Some (:abstraction {#value value' - #predicate predicate})) - #.None)))) - ) - -(def: #export (filter refiner values) - (All [t %] (-> (Refiner t %) (List t) (List (Refined t %)))) - (case values - #.Nil - #.Nil - - (#.Cons head tail) - (case (refiner head) - (#.Some refined) - (#.Cons refined (filter refiner tail)) - - #.None - (filter refiner tail)))) - -(def: #export (partition refiner values) - (All [t %] (-> (Refiner t %) (List t) [(List (Refined t %)) (List t)])) - (case values - #.Nil - [#.Nil #.Nil] - - (#.Cons head tail) - (let [[yes no] (partition refiner tail)] - (case (refiner head) - (#.Some refined) - [(#.Cons refined yes) - no] - - #.None - [yes - (#.Cons head no)])))) - -(syntax: #export (type refiner) - (macro.with_gensyms [g!t g!%] - (wrap (list (` ((~! type.:by_example) [(~ g!t) (~ g!%)] - (..Refiner (~ g!t) (~ g!%)) - (~ refiner) - - (..Refined (~ g!t) (~ g!%)))))))) diff --git a/stdlib/source/lux/type/resource.lux b/stdlib/source/lux/type/resource.lux deleted file mode 100644 index acad33a71..000000000 --- a/stdlib/source/lux/type/resource.lux +++ /dev/null @@ -1,217 +0,0 @@ -(.module: - [lux #* - ["." meta] - [abstract - ["." monad (#+ Monad do) - [indexed (#+ IxMonad)]]] - [control - ["." exception (#+ exception:)] - ["." io (#+ IO)] - [concurrency - ["." promise (#+ Promise)]] - ["<>" parser - ["<.>" code (#+ Parser)]]] - [data - ["." identity (#+ Identity)] - ["." maybe] - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." set] - ["." row (#+ Row)] - ["." list ("#\." functor fold)]]] - ["." macro - [syntax (#+ syntax:)]] - [math - [number - ["n" nat]]] - [type - abstract]]) - -(type: #export (Procedure monad input output value) - (-> input (monad [output value]))) - -(type: #export (Linear monad value) - (All [keys] - (Procedure monad keys keys value))) - -(type: #export (Affine monad permissions value) - (All [keys] - (Procedure monad keys [permissions keys] value))) - -(type: #export (Relevant monad permissions value) - (All [keys] - (Procedure monad [permissions keys] keys value))) - -(implementation: (indexed Monad<m>) - (All [m] (-> (Monad m) (IxMonad (Procedure m)))) - - (def: (wrap value) - (function (_ keys) - (\ Monad<m> wrap [keys value]))) - - (def: (bind f input) - (function (_ keysI) - (do Monad<m> - [[keysT value] (input keysI)] - ((f value) keysT))))) - -(template [<name> <m> <monad> <execute> <lift>] - [(def: #export <name> - (IxMonad (Procedure <m>)) - (..indexed <monad>)) - - (def: #export (<execute> procedure) - (All [v] (-> (Linear <m> v) (<m> v))) - (do <monad> - [[_ output] (procedure [])] - (wrap output))) - - (def: #export (<lift> procedure) - (All [v] (-> (<m> v) (Linear <m> v))) - (function (_ keys) - (do <monad> - [output procedure] - (wrap [keys output]))))] - - [pure Identity identity.monad run_pure lift_pure] - [sync IO io.monad run_sync lift_sync] - [async Promise promise.monad run_async lift_async] - ) - -(abstract: #export Ordered Any) - -(abstract: #export Commutative Any) - -(abstract: #export (Key mode key) - Any - - (template [<name> <mode>] - [(def: <name> - (Ex [k] (-> Any (Key <mode> k))) - (|>> :abstraction))] - - [ordered_key Ordered] - [commutative_key Commutative] - )) - -(abstract: #export (Res key value) - value - - {#.doc "A value locked by a key."} - - (template [<name> <m> <monad> <mode> <key>] - [(def: #export (<name> value) - (All [v] (Ex [k] (-> v (Affine <m> (Key <mode> k) (Res k v))))) - (function (_ keys) - (\ <monad> wrap [[(<key> []) keys] (:abstraction value)])))] - - [ordered_pure Identity identity.monad Ordered ordered_key] - [ordered_sync IO io.monad Ordered ordered_key] - [ordered_async Promise promise.monad Ordered ordered_key] - [commutative_sync IO io.monad Commutative commutative_key] - [commutative_pure Identity identity.monad Commutative commutative_key] - [commutative_async Promise promise.monad Commutative commutative_key] - ) - - (template [<name> <m> <monad>] - [(def: #export (<name> resource) - (All [v k m] - (-> (Res k v) (Relevant <m> (Key m k) v))) - (function (_ [key keys]) - (\ <monad> wrap [keys (:representation resource)])))] - - [read_pure Identity identity.monad] - [read_sync IO io.monad] - [read_async Promise promise.monad] - )) - -(exception: #export (index_cannot_be_repeated {index Nat}) - (exception.report - ["Index" (%.nat index)])) - -(exception: #export amount_cannot_be_zero) - -(def: indices - (Parser (List Nat)) - (<code>.tuple (loop [seen (set.new n.hash)] - (do {! <>.monad} - [done? <code>.end?] - (if done? - (wrap (list)) - (do ! - [head <code>.nat - _ (<>.assert (exception.construct ..index_cannot_be_repeated head) - (not (set.member? seen head))) - tail (recur (set.add head seen))] - (wrap (list& head tail)))))))) - -(def: (no_op Monad<m>) - (All [m] (-> (Monad m) (Linear m Any))) - (function (_ context) - (\ Monad<m> wrap [context []]))) - -(template [<name> <m> <monad>] - [(syntax: #export (<name> {swaps ..indices}) - (macro.with_gensyms [g!_ g!context] - (case swaps - #.Nil - (wrap (list (` ((~! no_op) <monad>)))) - - (#.Cons head tail) - (do {! meta.monad} - [#let [max_idx (list\fold n.max head tail)] - g!inputs (<| (monad.seq !) (list.repeat (inc max_idx)) (macro.gensym "input")) - #let [g!outputs (|> (monad.fold maybe.monad - (function (_ from to) - (do maybe.monad - [input (list.nth from g!inputs)] - (wrap (row.add input to)))) - (: (Row Code) row.empty) - swaps) - maybe.assume - row.to_list) - g!inputsT+ (list\map (|>> (~) (..Key ..Commutative) (`)) g!inputs) - g!outputsT+ (list\map (|>> (~) (..Key ..Commutative) (`)) g!outputs)]] - (wrap (list (` (: (All [(~+ g!inputs) (~ g!context)] - (Procedure (~! <m>) - [(~+ g!inputsT+) (~ g!context)] - [(~+ g!outputsT+) (~ g!context)] - .Any)) - (function ((~ g!_) [(~+ g!inputs) (~ g!context)]) - (\ (~! <monad>) (~' wrap) [[(~+ g!outputs) (~ g!context)] []]))))))))))] - - [exchange_pure Identity identity.monad] - [exchange_sync IO io.monad] - [exchange_async Promise promise.monad] - ) - -(def: amount - (Parser Nat) - (do <>.monad - [raw <code>.nat - _ (<>.assert (exception.construct ..amount_cannot_be_zero []) - (n.> 0 raw))] - (wrap raw))) - -(template [<name> <m> <monad> <from> <to>] - [(syntax: #export (<name> {amount ..amount}) - (macro.with_gensyms [g!_ g!context] - (do {! meta.monad} - [g!keys (<| (monad.seq !) (list.repeat amount) (macro.gensym "keys"))] - (wrap (list (` (: (All [(~+ g!keys) (~ g!context)] - (Procedure (~! <m>) - [<from> (~ g!context)] - [<to> (~ g!context)] - .Any)) - (function ((~ g!_) [<from> (~ g!context)]) - (\ (~! <monad>) (~' wrap) [[<to> (~ g!context)] []])))))))))] - - [group_pure Identity identity.monad (~+ g!keys) [(~+ g!keys)]] - [group_sync IO io.monad (~+ g!keys) [(~+ g!keys)]] - [group_async Promise promise.monad (~+ g!keys) [(~+ g!keys)]] - [un_group_pure Identity identity.monad [(~+ g!keys)] (~+ g!keys)] - [un_group_sync IO io.monad [(~+ g!keys)] (~+ g!keys)] - [un_group_async Promise promise.monad [(~+ g!keys)] (~+ g!keys)] - ) diff --git a/stdlib/source/lux/type/unit.lux b/stdlib/source/lux/type/unit.lux deleted file mode 100644 index ff0dfa645..000000000 --- a/stdlib/source/lux/type/unit.lux +++ /dev/null @@ -1,188 +0,0 @@ -## TODO: Write tests ASAP. -(.module: - [lux #* - ["." meta] - [abstract - [monad (#+ Monad do)] - [equivalence (#+ Equivalence)] - [order (#+ Order)] - [enum (#+ Enum)]] - [control - ["<>" parser - ["<.>" code (#+ Parser)]]] - [data - [text - ["%" format (#+ format)]]] - [macro - ["." code] - [syntax (#+ syntax:) - ["|.|" export] - ["|.|" annotations]]] - [math - [number - ["n" nat] - ["i" int] - ["." ratio (#+ Ratio)]]] - [type - abstract]]) - -(abstract: #export (Qty unit) - Int - - (def: in - (All [unit] (-> Int (Qty unit))) - (|>> :abstraction)) - - (def: out - (All [unit] (-> (Qty unit) Int)) - (|>> :representation)) - - (template [<name> <op>] - [(def: #export (<name> param subject) - (All [unit] (-> (Qty unit) (Qty unit) (Qty unit))) - (:abstraction (<op> (:representation param) - (:representation subject))))] - - [+ i.+] - [- i.-] - ) - - (template [<name> <op> <p> <s> <p*s>] - [(def: #export (<name> param subject) - (All [p s] (-> (Qty <p>) (Qty <s>) (Qty <p*s>))) - (:abstraction (<op> (:representation param) - (:representation subject))))] - - [* i.* p s [p s]] - [/ i./ p [p s] s] - ) - ) - -(interface: #export (Unit a) - (: (-> Int (Qty a)) - in) - (: (-> (Qty a) Int) - out)) - -(interface: #export (Scale s) - (: (All [u] (-> (Qty u) (Qty (s u)))) - scale) - (: (All [u] (-> (Qty (s u)) (Qty u))) - de_scale) - (: Ratio - ratio)) - -(type: #export Pure - (Qty Any)) - -(def: #export pure - (-> Int Pure) - ..in) - -(def: #export number - (-> Pure Int) - ..out) - -(syntax: #export (unit: - {export |export|.parser} - {type_name <code>.local_identifier} - {unit_name <code>.local_identifier} - {annotations (<>.default |annotations|.empty |annotations|.parser)}) - (do meta.monad - [@ meta.current_module_name - #let [g!type (code.local_identifier type_name)]] - (wrap (list (` (type: (~+ (|export|.format export)) (~ g!type) - (~ (|annotations|.format annotations)) - (primitive (~ (code.text (%.name [@ type_name])))))) - - (` (implementation: (~+ (|export|.format export)) (~ (code.local_identifier unit_name)) - (..Unit (~ g!type)) - - (def: (~' in) (~! ..in)) - (def: (~' out) (~! ..out)))) - )))) - -(def: scale - (Parser Ratio) - (<code>.tuple (do <>.monad - [numerator <code>.nat - _ (<>.assert (format "Numerator must be positive: " (%.nat numerator)) - (n.> 0 numerator)) - denominator <code>.nat - _ (<>.assert (format "Denominator must be positive: " (%.nat denominator)) - (n.> 0 denominator))] - (wrap [numerator denominator])))) - -(syntax: #export (scale: - {export |export|.parser} - {type_name <code>.local_identifier} - {scale_name <code>.local_identifier} - {(^slots [#ratio.numerator #ratio.denominator]) ..scale} - {annotations (<>.default |annotations|.empty |annotations|.parser)}) - (do meta.monad - [@ meta.current_module_name - #let [g!scale (code.local_identifier type_name)]] - (wrap (list (` (type: (~+ (|export|.format export)) ((~ g!scale) (~' u)) - (~ (|annotations|.format annotations)) - (primitive (~ (code.text (%.name [@ type_name]))) [(~' u)]))) - - (` (implementation: (~+ (|export|.format export)) (~ (code.local_identifier scale_name)) - (..Scale (~ g!scale)) - - (def: (~' scale) - (|>> ((~! ..out)) - (i.* (~ (code.int (.int numerator)))) - (i./ (~ (code.int (.int denominator)))) - ((~! ..in)))) - (def: (~' de_scale) - (|>> ((~! ..out)) - (i.* (~ (code.int (.int denominator)))) - (i./ (~ (code.int (.int numerator)))) - ((~! ..in)))) - (def: (~' ratio) - [(~ (code.nat numerator)) (~ (code.nat denominator))]))) - )))) - -(def: #export (re_scale from to quantity) - (All [si so u] (-> (Scale si) (Scale so) (Qty (si u)) (Qty (so u)))) - (let [[numerator denominator] (ratio./ (\ from ratio) - (\ to ratio))] - (|> quantity - out - (i.* (.int numerator)) - (i./ (.int denominator)) - in))) - -(scale: #export Kilo kilo [1 1,000]) -(scale: #export Mega mega [1 1,000,000]) -(scale: #export Giga giga [1 1,000,000,000]) - -(scale: #export Milli milli [ 1,000 1]) -(scale: #export Micro micro [ 1,000,000 1]) -(scale: #export Nano nano [1,000,000,000 1]) - -(unit: #export Gram gram) -(unit: #export Meter meter) -(unit: #export Litre litre) -(unit: #export Second second) - -(implementation: #export equivalence - (All [unit] (Equivalence (Qty unit))) - - (def: (= reference sample) - (i.= (..out reference) (..out sample)))) - -(implementation: #export order - (All [unit] (Order (Qty unit))) - - (def: &equivalence ..equivalence) - - (def: (< reference sample) - (i.< (..out reference) (..out sample)))) - -(implementation: #export enum - (All [unit] (Enum (Qty unit))) - - (def: &order ..order) - (def: succ (|>> ..out inc ..in)) - (def: pred (|>> ..out dec ..in))) diff --git a/stdlib/source/lux/type/variance.lux b/stdlib/source/lux/type/variance.lux deleted file mode 100644 index 863824e59..000000000 --- a/stdlib/source/lux/type/variance.lux +++ /dev/null @@ -1,11 +0,0 @@ -(.module: - [lux #*]) - -(type: #export (Co t) - (-> Any t)) - -(type: #export (Contra t) - (-> t Any)) - -(type: #export (In t) - (-> t t)) diff --git a/stdlib/source/lux/world/console.lux b/stdlib/source/lux/world/console.lux deleted file mode 100644 index 93842b99a..000000000 --- a/stdlib/source/lux/world/console.lux +++ /dev/null @@ -1,158 +0,0 @@ -(.module: - [lux #* - [ffi (#+ import:)] - ["@" target] - [abstract - [monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["." io (#+ IO io)] - [concurrency - ["." promise (#+ Promise)] - ["." atom]]] - [data - ["." text (#+ Char) - ["%" format (#+ format)]]]]) - -(template [<name>] - [(exception: #export (<name>) - "")] - - [cannot_open] - [cannot_close] - ) - -(interface: #export (Console !) - (: (-> [] (! (Try Char))) - read) - (: (-> [] (! (Try Text))) - read_line) - (: (-> Text (! (Try Any))) - write) - (: (-> [] (! (Try Any))) - close)) - -(def: #export (async console) - (-> (Console IO) (Console Promise)) - (`` (implementation - (~~ (template [<capability>] - [(def: <capability> - (|>> (\ console <capability>) promise.future))] - - [read] - [read_line] - [write] - [close]))))) - -(with_expansions [<jvm> (as_is (import: java/lang/String) - - (import: java/io/Console - ["#::." - (readLine [] #io #try java/lang/String)]) - - (import: java/io/InputStream - ["#::." - (read [] #io #try int)]) - - (import: java/io/PrintStream - ["#::." - (print [java/lang/String] #io #try void)]) - - (import: java/lang/System - ["#::." - (#static console [] #io #? java/io/Console) - (#static in java/io/InputStream) - (#static out java/io/PrintStream)]) - - (def: #export default - (IO (Try (Console IO))) - (do io.monad - [?jvm_console (java/lang/System::console)] - (case ?jvm_console - #.None - (wrap (exception.throw ..cannot_open [])) - - (#.Some jvm_console) - (let [jvm_input (java/lang/System::in) - jvm_output (java/lang/System::out)] - (<| wrap - exception.return - (: (Console IO)) ## TODO: Remove ASAP - (implementation - (def: (read _) - (|> jvm_input - java/io/InputStream::read - (\ (try.with io.monad) map .nat))) - - (def: (read_line _) - (java/io/Console::readLine jvm_console)) - - (def: (write message) - (java/io/PrintStream::print message jvm_output)) - - (def: close - (|>> (exception.throw ..cannot_close) wrap)))))))))] - (for {@.old (as_is <jvm>) - @.jvm (as_is <jvm>)} - (as_is))) - -(def: #export (write_line message console) - (All [!] (-> Text (Console !) (! (Try Any)))) - (\ console write (format message text.new_line))) - -(interface: #export (Mock s) - (: (-> s (Try [s Char])) - on_read) - (: (-> s (Try [s Text])) - on_read_line) - (: (-> Text s (Try s)) - on_write) - (: (-> s (Try s)) - on_close)) - -(def: #export (mock mock init) - (All [s] (-> (Mock s) s (Console IO))) - (let [state (atom.atom init)] - (`` (implementation - (~~ (template [<method> <mock>] - [(def: (<method> _) - (do {! io.monad} - [|state| (atom.read state)] - (case (\ mock <mock> |state|) - (#try.Success [|state| output]) - (do ! - [_ (atom.write |state| state)] - (wrap (#try.Success output))) - - (#try.Failure error) - (wrap (#try.Failure error)))))] - - [read on_read] - [read_line on_read_line] - )) - - (def: (write input) - (do {! io.monad} - [|state| (atom.read state)] - (case (\ mock on_write input |state|) - (#try.Success |state|) - (do ! - [_ (atom.write |state| state)] - (wrap (#try.Success []))) - - (#try.Failure error) - (wrap (#try.Failure error))))) - - (def: (close _) - (do {! io.monad} - [|state| (atom.read state)] - (case (\ mock on_close |state|) - (#try.Success |state|) - (do ! - [_ (atom.write |state| state)] - (wrap (#try.Success []))) - - (#try.Failure error) - (wrap (#try.Failure error))))) - )))) diff --git a/stdlib/source/lux/world/db/jdbc.lux b/stdlib/source/lux/world/db/jdbc.lux deleted file mode 100644 index 3dba77a8e..000000000 --- a/stdlib/source/lux/world/db/jdbc.lux +++ /dev/null @@ -1,175 +0,0 @@ -(.module: - [lux (#- and int) - [control - [functor (#+ Functor)] - [apply (#+ Apply)] - [monad (#+ Monad do)] - ["." try (#+ Try)] - ["ex" exception] - [concurrency - ["." promise (#+ Promise) ("#\." monad)]] - [security - ["!" capability (#+ capability:)]]] - [data - ["." product] - [text - ["%" format (#+ format)]]] - ["." io (#+ IO)] - [world - [net (#+ URL)]] - [host (#+ import:)]] - [// - ["." sql]] - ["." / #_ - ["#." input (#+ Input)] - ["#." output (#+ Output)]]) - -(import: java/lang/String) - -(import: java/sql/ResultSet - (getRow [] #try int) - (next [] #try boolean) - (close [] #io #try void)) - -(import: java/sql/Statement - (#static NO_GENERATED_KEYS int) - (#static RETURN_GENERATED_KEYS int) - (getGeneratedKeys [] #try java/sql/ResultSet) - (close [] #io #try void)) - -(import: java/sql/PreparedStatement - (executeUpdate [] #io #try int) - (executeQuery [] #io #try java/sql/ResultSet)) - -(import: java/sql/Connection - (prepareStatement [java/lang/String int] #try java/sql/PreparedStatement) - (isValid [int] #try boolean) - (close [] #io #try void)) - -(import: java/sql/DriverManager - (#static getConnection [java/lang/String java/lang/String java/lang/String] #io #try java/sql/Connection)) - -(type: #export Credentials - {#url URL - #user Text - #password Text}) - -(type: #export ID Int) - -(type: #export (Statement input) - {#sql sql.Statement - #input (Input input) - #value input}) - -(template [<name> <forge> <output>] - [(capability: #export (<name> ! i) - (<forge> (Statement i) (! (Try <output>))))] - - [Can-Execute can-execute Nat] - [Can-Insert can-insert (List ID)] - ) - -(capability: #export (Can-Query ! i o) - (can-query [(Statement i) (Output o)] (! (Try (List o))))) - -(capability: #export (Can-Close !) - (can-close Any (! (Try Any)))) - -(interface: #export (DB !) - (: (Can-Execute !) - execute) - (: (Can-Insert !) - insert) - (: (Can-Query !) - query) - (: (Can-Close !) - close)) - -(def: (with-statement statement conn action) - (All [i a] - (-> (Statement i) java/sql/Connection - (-> java/sql/PreparedStatement (IO (Try a))) - (IO (Try a)))) - (do (try.with io.monad) - [prepared (io.io (java/sql/Connection::prepareStatement (sql.sql (get@ #sql statement)) - (java/sql/Statement::RETURN_GENERATED_KEYS) - conn)) - _ (io.io ((get@ #input statement) (get@ #value statement) [1 prepared])) - result (action prepared) - _ (java/sql/Statement::close prepared)] - (wrap result))) - -(def: #export (async db) - (-> (DB IO) (DB Promise)) - (`` (implementation - (~~ (template [<name> <forge>] - [(def: <name> (<forge> (|>> (!.use (\ db <name>)) promise.future)))] - - [execute can-execute] - [insert can-insert] - [close can-close] - [query can-query]))))) - -(def: #export (connect creds) - (-> Credentials (IO (Try (DB IO)))) - (do (try.with io.monad) - [connection (java/sql/DriverManager::getConnection (get@ #url creds) - (get@ #user creds) - (get@ #password creds))] - (wrap (: (DB IO) - (implementation - (def: execute - (..can-execute - (function (execute statement) - (with-statement statement connection - (function (_ prepared) - (do (try.with io.monad) - [row-count (java/sql/PreparedStatement::executeUpdate prepared)] - (wrap (.nat row-count)))))))) - - (def: insert - (..can-insert - (function (insert statement) - (with-statement statement connection - (function (_ prepared) - (do (try.with io.monad) - [_ (java/sql/PreparedStatement::executeUpdate prepared) - result-set (io.io (java/sql/Statement::getGeneratedKeys prepared))] - (/output.rows /output.long result-set))))))) - - (def: close - (..can-close - (function (close _) - (java/sql/Connection::close connection)))) - - (def: query - (..can-query - (function (query [statement output]) - (with-statement statement connection - (function (_ prepared) - (do (try.with io.monad) - [result-set (java/sql/PreparedStatement::executeQuery prepared)] - (/output.rows output result-set))))))) - ))))) - -(def: #export (with-db creds action) - (All [a] - (-> Credentials - (-> (DB IO) (IO (Try a))) - (IO (Try a)))) - (do (try.with io.monad) - [db (..connect creds) - result (action db) - _ (!.use (\ db close) [])] - (wrap result))) - -(def: #export (with-async-db creds action) - (All [a] - (-> Credentials - (-> (DB Promise) (Promise (Try a))) - (Promise (Try a)))) - (do (try.with promise.monad) - [db (promise.future (..connect creds)) - result (action (..async db)) - _ (promise\wrap (io.run (!.use (\ db close) [])))] - (wrap result))) diff --git a/stdlib/source/lux/world/db/jdbc/input.lux b/stdlib/source/lux/world/db/jdbc/input.lux deleted file mode 100644 index 19f9e7422..000000000 --- a/stdlib/source/lux/world/db/jdbc/input.lux +++ /dev/null @@ -1,106 +0,0 @@ -(.module: - [lux (#- and int) - [ffi (#+ import:)] - [control - [functor (#+ Contravariant)] - [monad (#+ Monad do)] - ["." try (#+ Try)]] - [time - ["." instant (#+ Instant)]] - ["." io (#+ IO)] - [world - [binary (#+ Binary)]]]) - -(import: java/lang/String) - -(template [<class>] - [(import: <class> - (new [long]))] - - [java/sql/Date] [java/sql/Time] [java/sql/Timestamp] - ) - -(`` (import: java/sql/PreparedStatement - (~~ (template [<name> <type>] - [(<name> [int <type>] #try void)] - - [setBoolean boolean] - - [setByte byte] - [setShort short] - [setInt int] - [setLong long] - - [setFloat float] - [setDouble double] - - [setString java/lang/String] - [setBytes [byte]] - - [setDate java/sql/Date] - [setTime java/sql/Time] - [setTimestamp java/sql/Timestamp] - )))) - -(type: #export (Input a) - (-> a [Nat java/sql/PreparedStatement] - (Try [Nat java/sql/PreparedStatement]))) - -(implementation: #export contravariant (Contravariant Input) - (def: (map-1 f fb) - (function (fa value circumstance) - (fb (f value) circumstance)))) - -(def: #export (and pre post) - (All [l r] (-> (Input l) (Input r) (Input [l r]))) - (function (_ [left right] context) - (do try.monad - [context (pre left context)] - (post right context)))) - -(def: #export (fail error) - (All [a] (-> Text (Input a))) - (function (_ value [idx context]) - (#try.Failure error))) - -(def: #export empty - (Input Any) - (function (_ value context) - (#try.Success context))) - -(template [<function> <type> <setter>] - [(def: #export <function> - (Input <type>) - (function (_ value [idx statement]) - (do try.monad - [_ (<setter> (.int idx) value statement)] - (wrap [(.inc idx) statement]))))] - - [boolean Bit java/sql/PreparedStatement::setBoolean] - - [byte Int java/sql/PreparedStatement::setByte] - [short Int java/sql/PreparedStatement::setShort] - [int Int java/sql/PreparedStatement::setInt] - [long Int java/sql/PreparedStatement::setLong] - - [float Frac java/sql/PreparedStatement::setFloat] - [double Frac java/sql/PreparedStatement::setDouble] - - [string Text java/sql/PreparedStatement::setString] - [bytes Binary java/sql/PreparedStatement::setBytes] - ) - -(template [<function> <setter> <constructor>] - [(def: #export <function> - (Input Instant) - (function (_ value [idx statement]) - (do try.monad - [_ (<setter> (.int idx) - (<constructor> (instant.to-millis value)) - statement)] - (wrap [(.inc idx) statement]))))] - - [date java/sql/PreparedStatement::setDate java/sql/Date::new] - [time java/sql/PreparedStatement::setTime java/sql/Time::new] - [time-stamp java/sql/PreparedStatement::setTimestamp java/sql/Timestamp::new] - ) diff --git a/stdlib/source/lux/world/db/jdbc/output.lux b/stdlib/source/lux/world/db/jdbc/output.lux deleted file mode 100644 index 4639a5255..000000000 --- a/stdlib/source/lux/world/db/jdbc/output.lux +++ /dev/null @@ -1,194 +0,0 @@ -(.module: - [lux (#- and int) - [ffi (#+ import:)] - [control - [functor (#+ Functor)] - [apply (#+ Apply)] - [monad (#+ Monad do)] - ["ex" exception] - ["." try (#+ Try)]] - [time - ["." instant (#+ Instant)]] - ["." io (#+ IO)] - [world - [binary (#+ Binary)]]]) - -(import: java/lang/String) - -(import: java/util/Date - (getTime [] long)) - -(import: java/sql/Date) -(import: java/sql/Time) -(import: java/sql/Timestamp) - -(`` (import: java/sql/ResultSet - (~~ (template [<method-name> <return-class>] - [(<method-name> [int] #try <return-class>)] - - [getBoolean boolean] - - [getByte byte] - [getShort short] - [getInt int] - [getLong long] - - [getDouble double] - [getFloat float] - - [getString java/lang/String] - [getBytes [byte]] - - [getDate java/sql/Date] - [getTime java/sql/Time] - [getTimestamp java/sql/Timestamp] - )) - (next [] #try boolean) - (close [] #io #try void))) - -(type: #export (Output a) - (-> [Nat java/sql/ResultSet] (Try [Nat a]))) - -(implementation: #export functor - (Functor Output) - - (def: (map f fa) - (function (_ idx+rs) - (case (fa idx+rs) - (#try.Failure error) - (#try.Failure error) - - (#try.Success [idx' value]) - (#try.Success [idx' (f value)]))))) - -(implementation: #export apply - (Apply Output) - - (def: &functor ..functor) - - (def: (apply ff fa) - (function (_ [idx rs]) - (case (ff [idx rs]) - (#try.Success [idx' f]) - (case (fa [idx' rs]) - (#try.Success [idx'' a]) - (#try.Success [idx'' (f a)]) - - (#try.Failure msg) - (#try.Failure msg)) - - (#try.Failure msg) - (#try.Failure msg))))) - -(implementation: #export monad - (Monad Output) - - (def: &functor ..functor) - - (def: (wrap a) - (function (_ [idx rs]) - (#.Some [idx a]))) - - (def: (join mma) - (function (_ [idx rs]) - (case (mma [idx rs]) - (#try.Failure error) - (#try.Failure error) - - (#try.Success [idx' ma]) - (ma [idx' rs]))))) - -(def: #export (fail error) - (All [a] (-> Text (Output a))) - (function (_ [idx result-set]) - (#try.Failure error))) - -(def: #export (and left right) - (All [a b] - (-> (Output a) (Output b) (Output [a b]))) - (do ..monad - [=left left - =right right] - (wrap [=left =right]))) - -(template [<func-name> <method-name> <type>] - [(def: #export <func-name> - (Output <type>) - (function (_ [idx result-set]) - (case (<method-name> [(.int idx)] result-set) - (#try.Failure error) - (#try.Failure error) - - (#try.Success value) - (#try.Success [(inc idx) value]))))] - - [boolean java/sql/ResultSet::getBoolean Bit] - - [byte java/sql/ResultSet::getByte Int] - [short java/sql/ResultSet::getShort Int] - [int java/sql/ResultSet::getInt Int] - [long java/sql/ResultSet::getLong Int] - - [float java/sql/ResultSet::getFloat Frac] - [double java/sql/ResultSet::getDouble Frac] - - [string java/sql/ResultSet::getString Text] - [bytes java/sql/ResultSet::getBytes Binary] - ) - -(template [<func-name> <method-name>] - [(def: #export <func-name> - (Output Instant) - (function (_ [idx result-set]) - (case (<method-name> [(.int idx)] result-set) - (#try.Failure error) - (#try.Failure error) - - (#try.Success value) - (#try.Success [(inc idx) - (instant.from-millis (java/util/Date::getTime value))]))))] - - [date java/sql/ResultSet::getDate] - [time java/sql/ResultSet::getTime] - [time-stamp java/sql/ResultSet::getTimestamp] - ) - -(def: #export (rows output results) - (All [a] (-> (Output a) java/sql/ResultSet (IO (Try (List a))))) - (case (java/sql/ResultSet::next results) - (#try.Success has-next?) - (if has-next? - (case (output [1 results]) - (#.Some [_ head]) - (do io.monad - [?tail (rows output results)] - (case ?tail - (#try.Success tail) - (wrap (ex.return (#.Cons head tail))) - - (#try.Failure error) - (do io.monad - [temp (java/sql/ResultSet::close results)] - (wrap (do try.monad - [_ temp] - (try.fail error)))))) - - (#try.Failure error) - (do io.monad - [temp (java/sql/ResultSet::close results)] - (wrap (do try.monad - [_ temp] - (try.fail error))))) - (do io.monad - [temp (java/sql/ResultSet::close results)] - (wrap (do try.monad - [_ temp] - (wrap (list)))))) - - (#try.Failure error) - (do io.monad - [temp (java/sql/ResultSet::close results)] - (wrap (do try.monad - [_ temp] - (try.fail error)))) - )) diff --git a/stdlib/source/lux/world/db/sql.lux b/stdlib/source/lux/world/db/sql.lux deleted file mode 100644 index 4c9bce9b2..000000000 --- a/stdlib/source/lux/world/db/sql.lux +++ /dev/null @@ -1,475 +0,0 @@ -(.module: - [lux (#- Source Definition function and or not type is? int) - [control - [monad (#+ do)]] - [data - [number - ["i" int]] - ["." text ("#\." equivalence) - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)]]] - [type - abstract]]) - -(def: parenthesize - (-> Text Text) - (text.enclose ["(" ")"])) - -## Kind -(template [<declaration>] - [(abstract: #export <declaration> Any)] - - [Literal'] - [Column'] - [Placeholder'] - [(Value' kind)] - - [Function'] - - [Condition'] - - [Index'] - - [Table'] - [View'] - [Source'] - [DB'] - - [No-Limit] [With-Limit] - [No-Offset] [With-Offset] - [Order'] - [No-Order] [With-Order] - [No-Group] [With-Group] - [(Query' order group limit offset)] - - [Command'] - - [No-Where] [With-Where] [Without-Where] - [No-Having] [With-Having] [Without-Having] - [(Action' where having kind)] - - [(Schema' kind)] - [Definition'] - [(Statement' kind)] - ) - -(type: #export Alias Text) - -(def: #export no-alias Alias "") - -(abstract: #export (SQL kind) - Text - - ## SQL - (template [<declaration> <kind>] - [(type: #export <declaration> (SQL <kind>))] - - [Literal (Value' Literal')] - [Column (Value' Column')] - [Placeholder (Value' Placeholder')] - [Value (Value' Any)] - - [Function Function'] - [Condition Condition'] - - [Index Index'] - - [Table Table'] - [View View'] - [Source Source'] - [DB DB'] - - [Order Order'] - - [(Schema kind) (Schema' kind)] - - [(Query where having order group limit offset) (Statement' (Action' where having (Query' order group limit offset)))] - [(Command where having) (Statement' (Action' where having Command'))] - [(Action where having kind) (Statement' (Action' where having kind))] - - [Definition (Statement' Definition')] - [Statement (Statement' Any)] - ) - - (def: Base-Query (.type (Query No-Where No-Having No-Order No-Group No-Limit No-Offset))) - (def: Any-Query (.type (Query Any Any Any Any Any Any))) - - (def: #export read - {#.doc (doc "Only use this function for debugging purposes." - "Do not use this function to actually execute SQL code.")} - (-> (SQL Any) Text) - (|>> :representation)) - - (def: #export (sql action) - (-> Statement Text) - (format (:representation action) ";")) - - (def: enumerate - (-> (List (SQL Any)) Text) - (|>> (list\map (|>> :representation)) - (text.join-with ", "))) - - ## Value - (def: #export ? Placeholder (:abstraction "?")) - - (def: literal - (-> Text Literal) - (|>> :abstraction)) - - (def: #export null Literal (..literal "NULL")) - - (def: #export (int value) - (-> Int Literal) - (..literal (if (i.< +0 value) - (%.int value) - (%.nat (.nat value))))) - - (def: #export function - (-> Text Function) - (|>> :abstraction)) - - (def: #export (call function parameters) - (-> Function (List Value) Value) - (:abstraction (format (:representation function) - (..parenthesize (..enumerate parameters))))) - - ## Condition - (template [<name> <sql-op>] - [(def: #export (<name> reference sample) - (-> Value Value Condition) - (:abstraction - (..parenthesize - (format (:representation sample) - " " <sql-op> " " - (:representation reference)))))] - - [= "="] - [<> "<>"] - [is? "IS"] - [> ">"] - [>= ">="] - [< "<"] - [<= "<="] - [like? "LIKE"] - [ilike? "ILIKE"] - ) - - (def: #export (between from to sample) - (-> Value Value Value Condition) - (:abstraction - (..parenthesize - (format (:representation sample) - " BETWEEN " (:representation from) - " AND " (:representation to))))) - - (def: #export (in options value) - (-> (List Value) Value Condition) - (:abstraction - (format (:representation value) - " IN " - (..parenthesize (enumerate options))))) - - (template [<func-name> <sql-op>] - [(def: #export (<func-name> left right) - (-> Condition Condition Condition) - (:abstraction - (format (..parenthesize (:representation left)) - " " <sql-op> " " - (..parenthesize (:representation right)))))] - - [and "AND"] - [or "OR"] - ) - - (template [<name> <type> <sql>] - [(def: #export <name> - (-> <type> Condition) - (|>> :representation ..parenthesize (format <sql> " ") :abstraction))] - - [not Condition "NOT"] - [exists Any-Query "EXISTS"] - ) - - ## Query - (template [<name> <type> <decoration>] - [(def: #export <name> - (-> <type> Source) - (|>> :representation <decoration> :abstraction))] - - [from-table Table (<|)] - [from-view View (<|)] - [from-query Any-Query ..parenthesize] - ) - - (template [<func-name> <op>] - [(def: #export (<func-name> columns source) - (-> (List [Column Alias]) Source Base-Query) - (:abstraction - (format <op> - " " - (case columns - #.Nil - "*" - - _ - (|> columns - (list\map (.function (_ [column alias]) - (if (text\= ..no-alias alias) - (:representation column) - (format (:representation column) " AS " alias)))) - (text.join-with ", "))) - " FROM " (:representation source))))] - - - [select "SELECT"] - [select-distinct "SELECT DISTINCT"] - ) - - (template [<name> <join-text>] - [(def: #export (<name> table condition prev) - (-> Table Condition Base-Query Base-Query) - (:abstraction - (format (:representation prev) - " " <join-text> " " - (:representation table) - " ON " (:representation condition))))] - - [inner-join "INNER JOIN"] - [left-join "LEFT JOIN"] - [right-join "RIGHT JOIN"] - [full-outer-join "FULL OUTER JOIN"] - ) - - (template [<function> <sql-op>] - [(def: #export (<function> left right) - (-> Any-Query Any-Query (Query Without-Where Without-Having No-Order No-Group No-Limit No-Offset)) - (:abstraction - (format (:representation left) - " " <sql-op> " " - (:representation right))))] - - [union "UNION"] - [union-all "UNION ALL"] - [intersect "INTERSECT"] - ) - - (template [<name> <sql> <variables> <input> <output>] - [(def: #export (<name> value query) - (All <variables> - (-> Nat <input> <output>)) - (:abstraction - (format (:representation query) - " " <sql> " " - (%.nat value))))] - - [limit "LIMIT" [where having order group offset] - (Query where having order group No-Limit offset) - (Query where having order group With-Limit offset)] - - [offset "OFFSET" [where having order group limit] - (Query where having order group limit No-Offset) - (Query where having order group limit With-Offset)] - ) - - (template [<name> <sql>] - [(def: #export <name> - Order - (:abstraction <sql>))] - - [ascending "ASC"] - [descending "DESC"] - ) - - (def: #export (order-by pairs query) - (All [where having group limit offset] - (-> (List [Value Order]) - (Query where having No-Order group limit offset) - (Query where having With-Order group limit offset))) - (case pairs - #.Nil - (|> query :representation :abstraction) - - _ - (:abstraction - (format (:representation query) - " ORDER BY " - (|> pairs - (list\map (.function (_ [value order]) - (format (:representation value) " " (:representation order)))) - (text.join-with ", ")))))) - - (def: #export (group-by pairs query) - (All [where having order limit offset] - (-> (List Value) - (Query where having order No-Group limit offset) - (Query where having order With-Group limit offset))) - (case pairs - #.Nil - (|> query :representation :abstraction) - - _ - (:abstraction - (format (:representation query) - " GROUP BY " - (..enumerate pairs))))) - - ## Command - (def: #export (insert table columns rows) - (-> Table (List Column) (List (List Value)) (Command Without-Where Without-Having)) - (:abstraction - (format "INSERT INTO " (:representation table) " " - (..parenthesize (..enumerate columns)) - " VALUES " - (|> rows - (list\map (|>> ..enumerate ..parenthesize)) - (text.join-with ", ")) - ))) - - (def: #export (update table pairs) - (-> Table (List [Column Value]) (Command No-Where No-Having)) - (:abstraction (format "UPDATE " (:representation table) - (case pairs - #.Nil - "" - - _ - (format " SET " (|> pairs - (list\map (.function (_ [column value]) - (format (:representation column) "=" (:representation value)))) - (text.join-with ", "))))))) - - (def: #export delete - (-> Table (Command No-Where No-Having)) - (|>> :representation (format "DELETE FROM ") :abstraction)) - - ## Action - (def: #export (where condition prev) - (All [kind having] - (-> Condition (Action No-Where having kind) (Action With-Where having kind))) - (:abstraction - (format (:representation prev) - " WHERE " - (:representation condition)))) - - (def: #export (having condition prev) - (All [where kind] - (-> Condition (Action where No-Having kind) (Action where With-Having kind))) - (:abstraction - (format (:representation prev) - " HAVING " - (:representation condition)))) - - ## Schema - (def: #export type - (-> Text (Schema Value)) - (|>> :abstraction)) - - (template [<name> <attr>] - [(def: #export (<name> attr) - (-> (Schema Value) (Schema Value)) - (:abstraction - (format (:representation attr) " " <attr>)))] - - [unique "UNIQUE"] - [not-null "NOT NULL"] - [stored "STORED"] - ) - - (def: #export (default value attr) - (-> Value (Schema Value) (Schema Value)) - (:abstraction - (format (:representation attr) " DEFAULT " (:representation value)))) - - (def: #export (define-column name type) - (-> Column (Schema Value) (Schema Column)) - (:abstraction - (format (:representation name) " " (:representation type)))) - - (def: #export (auto-increment offset column) - (-> Int (Schema Column) (Schema Column)) - (:abstraction - (format (:representation column) " AUTO_INCREMENT=" (:representation (..int offset))))) - - (def: #export (create-table or-replace? table columns) - (-> Bit Table (List (Schema Column)) Definition) - (let [command (if or-replace? - "CREATE OR REPLACE TABLE" - "CREATE TABLE IF NOT EXISTS")] - (:abstraction - (format command " " (:representation table) - (..parenthesize (..enumerate columns)))))) - - (def: #export (create-table-as table query) - (-> Table Any-Query Definition) - (:abstraction - (format "CREATE TABLE " (:representation table) " AS " (:representation query)))) - - (template [<name> <sql>] - [(def: #export (<name> table) - (-> Table Definition) - (:abstraction - (format <sql> " TABLE " (:representation table))))] - - [drop "DROP"] - [truncate "TRUNCATE"] - ) - - (def: #export (add-column table column) - (-> Table (Schema Column) Definition) - (:abstraction - (format "ALTER TABLE " (:representation table) " ADD " (:representation column)))) - - (def: #export (drop-column table column) - (-> Table Column Definition) - (:abstraction - (format "ALTER TABLE " (:representation table) " DROP COLUMN " (:representation column)))) - - (template [<name> <type>] - [(def: #export (<name> name) - (-> Text <type>) - (:abstraction name))] - - [column Column] - [table Table] - [view View] - [index Index] - [db DB] - ) - - (template [<name> <type> <sql>] - [(def: #export <name> - (-> <type> Definition) - (|>> :representation (format <sql> " ") :abstraction))] - - [create-db DB "CREATE DATABASE"] - [drop-db DB "DROP DATABASE"] - [drop-view View "DROP VIEW"] - ) - - (template [<name> <sql>] - [(def: #export (<name> view query) - (-> View Any-Query Definition) - (:abstraction - (format <sql> " " (:representation view) " AS " (:representation query))))] - - [create-view "CREATE VIEW"] - [create-or-replace-view "CREATE OR REPLACE VIEW"] - ) - - (def: #export (create-index index table unique? columns) - (-> Index Table Bit (List Column) Definition) - (:abstraction - (format "CREATE " (if unique? "UNIQUE" "") " INDEX " (:representation index) - " ON " (:representation table) " " (..parenthesize (..enumerate columns))))) - - (def: #export (with alias query body) - (All [where having order group limit offset] - (-> Table Any-Query - (Query where having order group limit offset) - (Query where having order group limit offset))) - (:abstraction - (format "WITH " (:representation alias) - " AS " (..parenthesize (:representation query)) - " " (:representation body)))) - ) diff --git a/stdlib/source/lux/world/file.lux b/stdlib/source/lux/world/file.lux deleted file mode 100644 index fade9ad67..000000000 --- a/stdlib/source/lux/world/file.lux +++ /dev/null @@ -1,1302 +0,0 @@ -(.module: - [lux #* - ["@" target] - ["." ffi] - [abstract - ["." monad (#+ Monad do)]] - [control - [pipe (#+ case>)] - ["." try (#+ Try) ("#\." functor)] - ["." exception (#+ exception:)] - ["." io (#+ IO) ("#\." functor)] - ["." function] - [concurrency - ["." promise (#+ Promise)] - ["." stm (#+ Var STM)]]] - [data - ["." bit ("#\." equivalence)] - ["." product] - ["." maybe ("#\." functor)] - ["." binary (#+ Binary)] - ["." text ("#\." equivalence) - ["%" format (#+ format)]] - [collection - ["." array (#+ Array)] - ["." list ("#\." functor)] - ["." dictionary (#+ Dictionary)]]] - [macro - ["." template]] - [math - [number - ["i" int] - ["f" frac]]] - [time - ["." instant (#+ Instant)] - ["." duration]]]) - -(type: #export Path - Text) - -(`` (interface: #export (System !) - (: Text - separator) - - (~~ (template [<name> <output>] - [(: (-> Path (! <output>)) - <name>)] - - [file? Bit] - [directory? Bit] - )) - - (~~ (template [<name> <output>] - [(: (-> Path (! (Try <output>))) - <name>)] - - [make_directory Any] - [directory_files (List Path)] - [sub_directories (List Path)] - - [file_size Nat] - [last_modified Instant] - [can_execute? Bit] - [read Binary] - [delete Any] - )) - - (~~ (template [<name> <input>] - [(: (-> <input> Path (! (Try Any))) - <name>)] - - [modify Instant] - [write Binary] - [append Binary] - [move Path] - )) - )) - -(def: #export (un_nest fs path) - (All [!] (-> (System !) Path (Maybe [Path Text]))) - (let [/ (\ fs separator)] - (case (text.last_index_of / path) - #.None - #.None - - (#.Some last_separator) - (do maybe.monad - [[parent temp] (text.split last_separator path) - [_ child] (text.split (text.size /) temp)] - (wrap [parent child]))))) - -(def: #export (parent fs path) - (All [!] (-> (System !) Path (Maybe Path))) - (|> (..un_nest fs path) - (maybe\map product.left))) - -(def: #export (name fs path) - (All [!] (-> (System !) Path Text)) - (|> (..un_nest fs path) - (maybe\map product.right) - (maybe.default path))) - -(def: #export (async fs) - (-> (System IO) (System Promise)) - (`` (implementation - (def: separator - (\ fs separator)) - - (~~ (template [<name>] - [(def: <name> - (|>> (\ fs <name>) - promise.future))] - - [file?] - [directory?] - - [make_directory] - [directory_files] - [sub_directories] - - [file_size] - [last_modified] - [can_execute?] - [read] - [delete])) - - (~~ (template [<name>] - [(def: (<name> input path) - (promise.future (\ fs <name> input path)))] - - [modify] - [write] - [append] - [move])) - ))) - -(def: #export (nest fs parent child) - (All [!] (-> (System !) Path Text Path)) - (format parent (\ fs separator) child)) - -(template [<name>] - [(exception: #export (<name> {file Path}) - (exception.report - ["Path" file]))] - - [cannot_make_file] - [cannot_find_file] - [cannot_delete] - - [cannot_make_directory] - [cannot_find_directory] - - [cannot_read_all_data] - ) - -(with_expansions [<extra> (as_is (exception: #export (cannot_move {target Path} {source Path}) - (exception.report - ["Source" source] - ["Target" target])))] - (for {@.old (as_is <extra>) - @.jvm (as_is <extra>) - @.lua (as_is <extra>)} - (as_is))) - -(with_expansions [<for_jvm> (as_is (exception: #export (cannot_modify_file {instant Instant} {file Path}) - (exception.report - ["Instant" (%.instant instant)] - ["Path" file])) - - (ffi.import: java/lang/String) - - (`` (ffi.import: java/io/File - ["#::." - (new [java/lang/String]) - (~~ (template [<name>] - [(<name> [] #io #try boolean)] - - [createNewFile] [mkdir] - [delete] - [isFile] [isDirectory] - [canRead] [canWrite] [canExecute])) - - (length [] #io #try long) - (listFiles [] #io #try #? [java/io/File]) - (getAbsolutePath [] #io #try java/lang/String) - (renameTo [java/io/File] #io #try boolean) - (lastModified [] #io #try long) - (setLastModified [long] #io #try boolean) - (#static separator java/lang/String)])) - - (ffi.import: java/lang/AutoCloseable - ["#::." - (close [] #io #try void)]) - - (ffi.import: java/io/OutputStream - ["#::." - (write [[byte]] #io #try void) - (flush [] #io #try void)]) - - (ffi.import: java/io/FileOutputStream - ["#::." - (new [java/io/File boolean] #io #try)]) - - (ffi.import: java/io/InputStream - ["#::." - (read [[byte]] #io #try int)]) - - (ffi.import: java/io/FileInputStream - ["#::." - (new [java/io/File] #io #try)]) - - (`` (implementation: #export default - (System IO) - - (def: separator - (java/io/File::separator)) - - (~~ (template [<name> <method>] - [(def: <name> - (|>> java/io/File::new - <method> - (io\map (|>> (try.default false)))))] - - [file? java/io/File::isFile] - [directory? java/io/File::isDirectory] - )) - - (def: (make_directory path) - (|> path - java/io/File::new - java/io/File::mkdir)) - - (~~ (template [<name> <method>] - [(def: (<name> path) - (do {! (try.with io.monad)} - [?children (java/io/File::listFiles (java/io/File::new path))] - (case ?children - (#.Some children) - (|> children - array.to_list - (monad.filter ! (|>> <method>)) - (\ ! map (monad.map ! (|>> java/io/File::getAbsolutePath))) - (\ ! join)) - - #.None - (\ io.monad wrap (exception.throw ..cannot_find_directory [path])))))] - - [directory_files java/io/File::isFile] - [sub_directories java/io/File::isDirectory] - )) - - (def: file_size - (|>> java/io/File::new - java/io/File::length - (\ (try.with io.monad) map .nat))) - - (def: last_modified - (|>> java/io/File::new - (java/io/File::lastModified) - (\ (try.with io.monad) map (|>> duration.from_millis instant.absolute)))) - - (def: can_execute? - (|>> java/io/File::new - java/io/File::canExecute)) - - (def: (read path) - (do (try.with io.monad) - [#let [file (java/io/File::new path)] - size (java/io/File::length file) - #let [data (binary.create (.nat size))] - stream (java/io/FileInputStream::new file) - bytes_read (java/io/InputStream::read data stream) - _ (java/lang/AutoCloseable::close stream)] - (if (i.= size bytes_read) - (wrap data) - (\ io.monad wrap (exception.throw ..cannot_read_all_data path))))) - - (def: (delete path) - (|> path - java/io/File::new - java/io/File::delete)) - - (def: (modify time_stamp path) - (|> path - java/io/File::new - (java/io/File::setLastModified (|> time_stamp instant.relative duration.to_millis)))) - - (~~ (template [<name> <flag>] - [(def: (<name> data path) - (do (try.with io.monad) - [stream (java/io/FileOutputStream::new (java/io/File::new path) <flag>) - _ (java/io/OutputStream::write data stream) - _ (java/io/OutputStream::flush stream)] - (java/lang/AutoCloseable::close stream)))] - - [write #0] - [append #1] - )) - - (def: (move destination origin) - (|> origin - java/io/File::new - (java/io/File::renameTo (java/io/File::new destination)))) - )))] - (for {@.old (as_is <for_jvm>) - @.jvm (as_is <for_jvm>) - - @.js - (as_is (ffi.import: Buffer - ["#::." - (#static from [Binary] ..Buffer)]) - - (ffi.import: FileDescriptor) - - (ffi.import: Stats - ["#::." - (size ffi.Number) - (mtimeMs ffi.Number) - (isFile [] #io #try ffi.Boolean) - (isDirectory [] #io #try ffi.Boolean)]) - - (ffi.import: FsConstants - ["#::." - (F_OK ffi.Number) - (R_OK ffi.Number) - (W_OK ffi.Number) - (X_OK ffi.Number)]) - - (ffi.import: Fs - ["#::." - (constants FsConstants) - (readFileSync [ffi.String] #io #try Binary) - (appendFileSync [ffi.String Buffer] #io #try Any) - (writeFileSync [ffi.String Buffer] #io #try Any) - (statSync [ffi.String] #io #try Stats) - (accessSync [ffi.String ffi.Number] #io #try Any) - (renameSync [ffi.String ffi.String] #io #try Any) - (utimesSync [ffi.String ffi.Number ffi.Number] #io #try Any) - (unlink [ffi.String] #io #try Any) - (readdirSync [ffi.String] #io #try (Array ffi.String)) - (mkdirSync [ffi.String] #io #try Any) - (rmdirSync [ffi.String] #io #try Any)]) - - (ffi.import: JsPath - ["#::." - (sep ffi.String)]) - - (template [<name> <path>] - [(def: (<name> _) - (-> [] (Maybe (-> ffi.String Any))) - (ffi.constant (-> ffi.String Any) <path>))] - - [normal_require [require]] - [global_require [global require]] - [process_load [global process mainModule constructor _load]] - ) - - (def: (require _) - (-> [] (-> ffi.String Any)) - (case [(normal_require []) (global_require []) (process_load [])] - (^or [(#.Some require) _ _] - [_ (#.Some require) _] - [_ _ (#.Some require)]) - require - - _ - (undefined))) - - (template [<name> <module> <type>] - [(def: (<name> _) - (-> [] <type>) - (:as <type> (..require [] <module>)))] - - [node_fs "fs" ..Fs] - [node_path "path" ..JsPath] - ) - - (`` (implementation: #export default - (System IO) - - (def: separator - (if ffi.on_node_js? - (JsPath::sep (..node_path [])) - "/")) - - (~~ (template [<name> <method>] - [(def: (<name> path) - (do {! io.monad} - [?stats (Fs::statSync [path] (..node_fs []))] - (case ?stats - (#try.Success stats) - (|> stats - (<method> []) - (\ ! map (|>> (try.default false)))) - - (#try.Failure _) - (wrap false))))] - - [file? Stats::isFile] - [directory? Stats::isDirectory] - )) - - (def: (make_directory path) - (let [node_fs (..node_fs [])] - (do io.monad - [outcome (Fs::accessSync [path (|> node_fs Fs::constants FsConstants::F_OK)] node_fs)] - (case outcome - (#try.Success _) - (wrap (exception.throw ..cannot_make_directory [path])) - - (#try.Failure _) - (Fs::mkdirSync [path] node_fs))))) - - (~~ (template [<name> <method>] - [(def: (<name> path) - (do {! (try.with io.monad)} - [#let [node_fs (..node_fs [])] - subs (Fs::readdirSync [path] node_fs)] - (|> subs - array.to_list - (monad.map ! (function (_ sub) - (do ! - [stats (Fs::statSync [sub] node_fs)] - (\ ! map (|>> [sub]) (<method> [] stats))))) - (\ ! map (|>> (list.filter product.right) - (list\map product.left))))))] - - [directory_files Stats::isFile] - [sub_directories Stats::isDirectory] - )) - - (def: (file_size path) - (let [! (try.with io.monad)] - (|> (..node_fs []) - (Fs::statSync [path]) - (\ ! map (|>> Stats::size - f.nat))))) - - (def: (last_modified path) - (let [! (try.with io.monad)] - (|> (..node_fs []) - (Fs::statSync [path]) - (\ ! map (|>> Stats::mtimeMs - f.int - duration.from_millis - instant.absolute))))) - - (def: (can_execute? path) - (let [node_fs (..node_fs [])] - (|> node_fs - (Fs::accessSync [path (|> node_fs Fs::constants FsConstants::X_OK)]) - (io\map (|>> (case> (#try.Success _) - true - - (#try.Failure _) - false) - #try.Success))))) - - (def: (read path) - (Fs::readFileSync [path] (..node_fs []))) - - (def: (delete path) - (do {! (try.with io.monad)} - [#let [node_fs (..node_fs [])] - stats (Fs::statSync [path] node_fs) - verdict (Stats::isFile [] stats)] - (if verdict - (Fs::unlink [path] node_fs) - (Fs::rmdirSync [path] node_fs)))) - - (def: (modify time_stamp path) - (let [when (|> time_stamp instant.relative duration.to_millis i.frac)] - (Fs::utimesSync [path when when] (..node_fs [])))) - - (~~ (template [<name> <method>] - [(def: (<name> data path) - (<method> [path (Buffer::from data)] (..node_fs [])))] - - [write Fs::writeFileSync] - [append Fs::appendFileSync] - )) - - (def: (move destination origin) - (Fs::renameSync [origin destination] (..node_fs []))) - ))) - - @.python - (as_is (type: (Tuple/2 left right) - (primitive "python_tuple[2]" [left right])) - - (ffi.import: PyFile - ["#::." - (read [] #io #try Binary) - (write [Binary] #io #try #? Any) - (close [] #io #try #? Any)]) - - (ffi.import: (open [ffi.String ffi.String] #io #try PyFile)) - (ffi.import: (tuple [[ffi.Integer ffi.Integer]] (Tuple/2 ffi.Integer ffi.Integer))) - - (ffi.import: os - ["#::." - (#static F_OK ffi.Integer) - (#static R_OK ffi.Integer) - (#static W_OK ffi.Integer) - (#static X_OK ffi.Integer) - - (#static mkdir [ffi.String] #io #try #? Any) - (#static access [ffi.String ffi.Integer] #io #try ffi.Boolean) - (#static remove [ffi.String] #io #try #? Any) - (#static rmdir [ffi.String] #io #try #? Any) - (#static rename [ffi.String ffi.String] #io #try #? Any) - (#static utime [ffi.String (Tuple/2 ffi.Integer ffi.Integer)] #io #try #? Any) - (#static listdir [ffi.String] #io #try (Array ffi.String))]) - - (ffi.import: os/path - ["#::." - (#static isfile [ffi.String] #io #try ffi.Boolean) - (#static isdir [ffi.String] #io #try ffi.Boolean) - (#static sep ffi.String) - (#static getsize [ffi.String] #io #try ffi.Integer) - (#static getmtime [ffi.String] #io #try ffi.Float)]) - - (`` (implementation: #export default - (System IO) - - (def: separator - (os/path::sep)) - - (~~ (template [<name> <method>] - [(def: <name> - (|>> <method> - (io\map (|>> (try.default false)))))] - - [file? os/path::isfile] - [directory? os/path::isdir] - )) - - (def: make_directory - os::mkdir) - - (~~ (template [<name> <method>] - [(def: <name> - (let [! (try.with io.monad)] - (|>> os::listdir - (\ ! map (|>> array.to_list - (monad.map ! (function (_ sub) - (\ ! map (|>> [sub]) (<method> [sub])))) - (\ ! map (|>> (list.filter product.right) - (list\map product.left))))) - (\ ! join))))] - - [directory_files os/path::isfile] - [sub_directories os/path::isdir] - )) - - (def: file_size - (|>> os/path::getsize - (\ (try.with io.monad) map .nat))) - - (def: last_modified - (|>> os/path::getmtime - (\ (try.with io.monad) map (|>> f.int - (i.* +1,000) - duration.from_millis - instant.absolute)))) - - (def: (can_execute? path) - (os::access [path (os::X_OK)])) - - (def: (read path) - (do (try.with io.monad) - [file (..open [path "rb"]) - data (PyFile::read [] file) - _ (PyFile::close [] file)] - (wrap data))) - - (def: (delete path) - (do (try.with io.monad) - [? (os/path::isfile [path])] - (if ? - (os::remove [path]) - (os::rmdir [path])))) - - (def: (modify time_stamp path) - (let [when (|> time_stamp instant.relative duration.to_millis (i./ +1,000))] - (os::utime [path (..tuple [when when])]))) - - (~~ (template [<name> <mode>] - [(def: (<name> data path) - (do (try.with io.monad) - [file (..open [path <mode>]) - _ (PyFile::write [data] file)] - (PyFile::close [] file)))] - - [write "w+b"] - [append "ab"] - )) - - (def: (move destination origin) - (os::rename [origin destination])) - ))) - - @.ruby - (as_is (ffi.import: Time #as RubyTime - ["#::." - (#static at [Frac] RubyTime) - (to_f [] Frac)]) - - (ffi.import: Stat #as RubyStat - ["#::." - (executable? [] Bit) - (size Int) - (mtime [] RubyTime)]) - - (ffi.import: File #as RubyFile - ["#::." - (#static SEPARATOR ffi.String) - (#static open [Path ffi.String] #io #try RubyFile) - (#static stat [Path] #io #try RubyStat) - (#static delete [Path] #io #try Int) - (#static file? [Path] #io #try Bit) - (#static directory? [Path] #io #try Bit) - (#static utime [RubyTime RubyTime Path] #io #try Int) - - (read [] #io #try Binary) - (write [Binary] #io #try Int) - (flush [] #io #try #? Any) - (close [] #io #try #? Any)]) - - (ffi.import: Dir #as RubyDir - ["#::." - (#static open [Path] #io #try RubyDir) - - (children [] #io #try (Array Path)) - (close [] #io #try #? Any)]) - - (ffi.import: "fileutils" FileUtils #as RubyFileUtils - ["#::." - (#static move [Path Path] #io #try #? Any) - (#static rmdir [Path] #io #try #? Any) - (#static mkdir [Path] #io #try #? Any)]) - - (def: ruby_separator - Text - (..RubyFile::SEPARATOR)) - - (`` (implementation: #export default - (System IO) - - (def: separator - ..ruby_separator) - - (~~ (template [<name> <test>] - [(def: <name> - (|>> <test> - (io\map (|>> (try.default false)))))] - - [file? RubyFile::file?] - [directory? RubyFile::directory?] - )) - - (def: make_directory - RubyFileUtils::mkdir) - - (~~ (template [<name> <test>] - [(def: (<name> path) - (do {! (try.with io.monad)} - [self (RubyDir::open [path]) - children (RubyDir::children [] self) - output (loop [input (|> children - array.to_list - (list\map (|>> (format path ..ruby_separator)))) - output (: (List ..Path) - (list))] - (case input - #.Nil - (wrap output) - - (#.Cons head tail) - (do ! - [verdict (<test> head)] - (recur tail (if verdict - (#.Cons head output) - output))))) - _ (RubyDir::close [] self)] - (wrap output)))] - - [directory_files RubyFile::file?] - [sub_directories RubyFile::directory?] - )) - - (~~ (template [<name> <pipeline>] - [(def: <name> - (let [! (try.with io.monad)] - (|>> RubyFile::stat - (\ ! map (`` (|>> (~~ (template.splice <pipeline>))))))))] - - [file_size [RubyStat::size .nat]] - [last_modified [(RubyStat::mtime []) - (RubyTime::to_f []) - (f.* +1,000.0) - f.int - duration.from_millis - instant.absolute]] - [can_execute? [(RubyStat::executable? [])]] - )) - - (def: (read path) - (do (try.with io.monad) - [file (RubyFile::open [path "rb"]) - data (RubyFile::read [] file) - _ (RubyFile::close [] file)] - (wrap data))) - - (def: (delete path) - (do (try.with io.monad) - [? (RubyFile::file? path)] - (if ? - (RubyFile::delete [path]) - (RubyFileUtils::rmdir [path])))) - - (def: (modify moment path) - (let [moment (|> moment - instant.relative - duration.to_millis - i.frac - (f./ +1,000.0) - RubyTime::at)] - (RubyFile::utime [moment moment path]))) - - (~~ (template [<mode> <name>] - [(def: (<name> data path) - (do {! (try.with io.monad)} - [file (RubyFile::open [path <mode>]) - data (RubyFile::write [data] file) - _ (RubyFile::flush [] file) - _ (RubyFile::close [] file)] - (wrap [])))] - - ["wb" write] - ["ab" append] - )) - - (def: (move destination origin) - (do (try.with io.monad) - [_ (RubyFileUtils::move [origin destination])] - (wrap []))) - ))) - - ## @.php - ## (as_is (ffi.import: (FILE_APPEND Int)) - ## ## https://www.php.net/manual/en/dir.constants.php - ## (ffi.import: (DIRECTORY_SEPARATOR ffi.String)) - ## ## https://www.php.net/manual/en/function.pack.php - ## ## https://www.php.net/manual/en/function.unpack.php - ## (ffi.import: (unpack [ffi.String ffi.String] Binary)) - ## ## https://www.php.net/manual/en/ref.filesystem.php - ## ## https://www.php.net/manual/en/function.file-get-contents.php - ## (ffi.import: (file_get_contents [Path] #io #try ffi.String)) - ## ## https://www.php.net/manual/en/function.file-put-contents.php - ## (ffi.import: (file_put_contents [Path ffi.String Int] #io #try ffi.Integer)) - ## (ffi.import: (filemtime [Path] #io #try ffi.Integer)) - ## (ffi.import: (filesize [Path] #io #try ffi.Integer)) - ## (ffi.import: (is_executable [Path] #io #try ffi.Boolean)) - ## (ffi.import: (touch [Path ffi.Integer] #io #try ffi.Boolean)) - ## (ffi.import: (rename [Path Path] #io #try ffi.Boolean)) - ## (ffi.import: (unlink [Path] #io #try ffi.Boolean)) - - ## ## https://www.php.net/manual/en/function.rmdir.php - ## (ffi.import: (rmdir [Path] #io #try ffi.Boolean)) - ## ## https://www.php.net/manual/en/function.scandir.php - ## (ffi.import: (scandir [Path] #io #try (Array Path))) - ## ## https://www.php.net/manual/en/function.is-file.php - ## (ffi.import: (is_file [Path] #io #try ffi.Boolean)) - ## ## https://www.php.net/manual/en/function.is-dir.php - ## (ffi.import: (is_dir [Path] #io #try ffi.Boolean)) - ## ## https://www.php.net/manual/en/function.mkdir.php - ## (ffi.import: (mkdir [Path] #io #try ffi.Boolean)) - - ## (def: byte_array_format "C*") - ## (def: default_separator (..DIRECTORY_SEPARATOR)) - - ## (template [<name>] - ## [(exception: #export (<name> {file Path}) - ## (exception.report - ## ["Path" file]))] - - ## [cannot_write_to_file] - ## ) - - ## (`` (implementation: (file path) - ## (-> Path (File IO)) - - ## (~~ (template [<name> <mode>] - ## [(def: (<name> data) - ## (do {! (try.with io.monad)} - ## [outcome (..file_put_contents [path ("php pack" ..byte_array_format data) <mode>])] - ## (if (bit\= false (:as Bit outcome)) - ## (\ io.monad wrap (exception.throw ..cannot_write_to_file [path])) - ## (wrap []))))] - - ## [over_write +0] - ## [append (..FILE_APPEND)] - ## )) - - ## (def: (content _) - ## (do {! (try.with io.monad)} - ## [data (..file_get_contents [path])] - ## (if (bit\= false (:as Bit data)) - ## (\ io.monad wrap (exception.throw ..cannot_find_file [path])) - ## (wrap (..unpack [..byte_array_format data]))))) - - ## (def: path - ## path) - - ## (~~ (template [<name> <ffi> <pipeline>] - ## [(def: (<name> _) - ## (do {! (try.with io.monad)} - ## [value (<ffi> [path])] - ## (if (bit\= false (:as Bit value)) - ## (\ io.monad wrap (exception.throw ..cannot_find_file [path])) - ## (wrap (`` (|> value (~~ (template.splice <pipeline>))))))))] - - ## [size ..filesize [.nat]] - ## [last_modified ..filemtime [(i.* +1,000) duration.from_millis instant.absolute]] - ## )) - - ## (def: (can_execute? _) - ## (..is_executable [path])) - - ## (def: (modify moment) - ## (do {! (try.with io.monad)} - ## [verdict (..touch [path (|> moment instant.relative duration.to_millis (i./ +1,000))])] - ## (if (bit\= false (:as Bit verdict)) - ## (\ io.monad wrap (exception.throw ..cannot_find_file [path])) - ## (wrap [])))) - - ## (def: (move destination) - ## (do {! (try.with io.monad)} - ## [verdict (..rename [path destination])] - ## (if (bit\= false (:as Bit verdict)) - ## (\ io.monad wrap (exception.throw ..cannot_find_file [path])) - ## (wrap (file destination))))) - - ## (def: (delete _) - ## (do (try.with io.monad) - ## [verdict (..unlink [path])] - ## (if (bit\= false (:as Bit verdict)) - ## (\ io.monad wrap (exception.throw ..cannot_find_file [path])) - ## (wrap [])))) - ## )) - - ## (`` (implementation: (directory path) - ## (-> Path (Directory IO)) - - ## (def: scope - ## path) - - ## (~~ (template [<name> <test> <constructor> <capability>] - ## [(def: (<name> _) - ## (do {! (try.with io.monad)} - ## [children (..scandir [path])] - ## (loop [input (|> children - ## array.to_list - ## (list.filter (function (_ child) - ## (not (or (text\= "." child) - ## (text\= ".." child)))))) - ## output (: (List (<capability> IO)) - ## (list))] - ## (case input - ## #.Nil - ## (wrap output) - - ## (#.Cons head tail) - ## (do ! - ## [verdict (<test> head)] - ## (if verdict - ## (recur tail (#.Cons (<constructor> head) output)) - ## (recur tail output)))))))] - - ## [files ..is_file ..file File] - ## [directories ..is_dir directory Directory] - ## )) - - ## (def: (discard _) - ## (do (try.with io.monad) - ## [verdict (..rmdir [path])] - ## (if (bit\= false (:as Bit verdict)) - ## (\ io.monad wrap (exception.throw ..cannot_find_directory [path])) - ## (wrap [])))) - ## )) - - ## (`` (implementation: #export default - ## (System IO) - - ## (~~ (template [<name> <test> <constructor> <exception>] - ## [(def: (<name> path) - ## (do {! (try.with io.monad)} - ## [verdict (<test> path)] - ## (\ io.monad wrap - ## (if verdict - ## (#try.Success (<constructor> path)) - ## (exception.throw <exception> [path])))))] - - ## [file ..is_file ..file ..cannot_find_file] - ## [directory ..is_dir ..directory ..cannot_find_directory] - ## )) - - ## (def: (make_file path) - ## (do {! (try.with io.monad)} - ## [verdict (..touch [path (|> instant.now io.run instant.relative duration.to_millis (i./ +1,000))])] - ## (\ io.monad wrap - ## (if verdict - ## (#try.Success (..file path)) - ## (exception.throw ..cannot_make_file [path]))))) - - ## (def: (make_directory path) - ## (do {! (try.with io.monad)} - ## [verdict (..mkdir path)] - ## (\ io.monad wrap - ## (if verdict - ## (#try.Success (..directory path)) - ## (exception.throw ..cannot_make_directory [path]))))) - - ## (def: separator - ## ..default_separator) - ## )) - ## ) - } - (as_is))) - -(def: #export (exists? monad fs path) - (All [!] (-> (Monad !) (System !) Path (! Bit))) - (do monad - [verdict (\ fs file? path)] - (if verdict - (wrap verdict) - (\ fs directory? path)))) - -(type: Mock_File - {#mock_last_modified Instant - #mock_can_execute Bit - #mock_content Binary}) - -(type: #rec Mock - (Dictionary Text (Either Mock_File Mock))) - -(def: empty_mock - Mock - (dictionary.new text.hash)) - -(def: (retrieve_mock_file! separator path mock) - (-> Text Path Mock (Try [Text Mock_File])) - (loop [directory mock - trail (text.split_all_with separator path)] - (case trail - (#.Cons head tail) - (case (dictionary.get head directory) - #.None - (exception.throw ..cannot_find_file [path]) - - (#.Some node) - (case [node tail] - [(#.Left file) #.Nil] - (#try.Success [head file]) - - [(#.Right sub_directory) (#.Cons _)] - (recur sub_directory tail) - - _ - (exception.throw ..cannot_find_file [path]))) - - #.Nil - (exception.throw ..cannot_find_file [path])))) - -(def: (update_mock_file! / path now content mock) - (-> Text Path Instant Binary Mock (Try Mock)) - (loop [directory mock - trail (text.split_all_with / path)] - (case trail - (#.Cons head tail) - (case (dictionary.get head directory) - #.None - (case tail - #.Nil - (#try.Success (dictionary.put head - (#.Left {#mock_last_modified now - #mock_can_execute false - #mock_content content}) - directory)) - - (#.Cons _) - (exception.throw ..cannot_find_file [path])) - - (#.Some node) - (case [node tail] - [(#.Left file) #.Nil] - (#try.Success (dictionary.put head - (#.Left (|> file - (set@ #mock_last_modified now) - (set@ #mock_content content))) - directory)) - - [(#.Right sub_directory) (#.Cons _)] - (do try.monad - [sub_directory (recur sub_directory tail)] - (wrap (dictionary.put head (#.Right sub_directory) directory))) - - _ - (exception.throw ..cannot_find_file [path]))) - - #.Nil - (exception.throw ..cannot_find_file [path])))) - -(def: (mock_delete! / path mock) - (-> Text Path Mock (Try Mock)) - (loop [directory mock - trail (text.split_all_with / path)] - (case trail - (#.Cons head tail) - (case (dictionary.get head directory) - #.None - (exception.throw ..cannot_delete [path]) - - (#.Some node) - (case tail - #.Nil - (case node - (#.Left file) - (#try.Success (dictionary.remove head directory)) - - (#.Right sub_directory) - (if (dictionary.empty? sub_directory) - (#try.Success (dictionary.remove head directory)) - (exception.throw ..cannot_delete [path]))) - - (#.Cons _) - (case node - (#.Left file) - (exception.throw ..cannot_delete [path]) - - (#.Right sub_directory) - (do try.monad - [sub_directory' (recur sub_directory tail)] - (wrap (dictionary.put head (#.Right sub_directory') directory)))))) - - #.Nil - (exception.throw ..cannot_delete [path])))) - -(def: (try_update! transform var) - (All [a] (-> (-> a (Try a)) (Var a) (STM (Try Any)))) - (do {! stm.monad} - [|var| (stm.read var)] - (case (transform |var|) - (#try.Success |var|) - (do ! - [_ (stm.write |var| var)] - (wrap (#try.Success []))) - - (#try.Failure error) - (wrap (#try.Failure error))))) - -(def: (make_mock_directory! / path mock) - (-> Text Path Mock (Try Mock)) - (loop [directory mock - trail (text.split_all_with / path)] - (case trail - (#.Cons head tail) - (case (dictionary.get head directory) - #.None - (case tail - #.Nil - (#try.Success (dictionary.put head (#.Right ..empty_mock) directory)) - - (#.Cons _) - (exception.throw ..cannot_make_directory [path])) - - (#.Some node) - (case [node tail] - [(#.Right sub_directory) (#.Cons _)] - (do try.monad - [sub_directory (recur sub_directory tail)] - (wrap (dictionary.put head (#.Right sub_directory) directory))) - - _ - (exception.throw ..cannot_make_directory [path]))) - - #.Nil - (exception.throw ..cannot_make_directory [path])))) - -(def: (retrieve_mock_directory! / path mock) - (-> Text Path Mock (Try Mock)) - (loop [directory mock - trail (text.split_all_with / path)] - (case trail - #.Nil - (#try.Success directory) - - (#.Cons head tail) - (case (dictionary.get head directory) - #.None - (exception.throw ..cannot_find_directory [path]) - - (#.Some node) - (case node - (#.Left _) - (exception.throw ..cannot_find_directory [path]) - - (#.Right sub_directory) - (case tail - #.Nil - (#try.Success sub_directory) - - (#.Cons _) - (recur sub_directory tail))))))) - -(def: #export (mock separator) - (-> Text (System Promise)) - (let [store (stm.var ..empty_mock)] - (`` (implementation - (def: separator - separator) - - (~~ (template [<method> <retrieve>] - [(def: (<method> path) - (|> store - stm.read - (\ stm.monad map - (|>> (<retrieve> separator path) - (try\map (function.constant true)) - (try.default false))) - stm.commit))] - - [file? ..retrieve_mock_file!] - [directory? ..retrieve_mock_directory!])) - - (def: (make_directory path) - (stm.commit - (do {! stm.monad} - [|store| (stm.read store)] - (case (..make_mock_directory! separator path |store|) - (#try.Success |store|) - (do ! - [_ (stm.write |store| store)] - (wrap (#try.Success []))) - - (#try.Failure error) - (wrap (#try.Failure error)))))) - - (~~ (template [<method> <tag>] - [(def: (<method> path) - (stm.commit - (do stm.monad - [|store| (stm.read store)] - (wrap (do try.monad - [directory (..retrieve_mock_directory! separator path |store|)] - (wrap (|> directory - dictionary.entries - (list.all (function (_ [node_name node]) - (case node - (<tag> _) - (#.Some (format path separator node_name)) - - _ - #.None))))))))))] - - [directory_files #.Left] - [sub_directories #.Right] - )) - - (def: (file_size path) - (stm.commit - (do stm.monad - [|store| (stm.read store)] - (wrap (|> |store| - (..retrieve_mock_file! separator path) - (try\map (|>> product.right - (get@ #mock_content) - binary.size))))))) - - (def: (last_modified path) - (stm.commit - (do stm.monad - [|store| (stm.read store)] - (wrap (|> |store| - (..retrieve_mock_file! separator path) - (try\map (|>> product.right - (get@ #mock_last_modified)))))))) - - (def: (can_execute? path) - (stm.commit - (do stm.monad - [|store| (stm.read store)] - (wrap (|> |store| - (..retrieve_mock_file! separator path) - (try\map (|>> product.right - (get@ #mock_can_execute)))))))) - - (def: (read path) - (stm.commit - (do stm.monad - [|store| (stm.read store)] - (wrap (|> |store| - (..retrieve_mock_file! separator path) - (try\map (|>> product.right - (get@ #mock_content)))))))) - - (def: (delete path) - (stm.commit - (..try_update! (..mock_delete! separator path) store))) - - (def: (modify now path) - (stm.commit - (..try_update! (function (_ |store|) - (do try.monad - [[name file] (..retrieve_mock_file! separator path |store|)] - (..update_mock_file! separator path now (get@ #mock_content file) |store|))) - store))) - - (def: (write content path) - (do promise.monad - [now (promise.future instant.now)] - (stm.commit - (..try_update! (..update_mock_file! separator path now content) store)))) - - (def: (append content path) - (do promise.monad - [now (promise.future instant.now)] - (stm.commit - (..try_update! (function (_ |store|) - (do try.monad - [[name file] (..retrieve_mock_file! separator path |store|)] - (..update_mock_file! separator path now - (\ binary.monoid compose - (get@ #mock_content file) - content) - |store|))) - store)))) - - (def: (move destination origin) - (stm.commit - (do {! stm.monad} - [|store| (stm.read store)] - (case (do try.monad - [[name file] (..retrieve_mock_file! separator origin |store|) - |store| (..mock_delete! separator origin |store|)] - (..update_mock_file! separator destination (get@ #mock_last_modified file) (get@ #mock_content file) |store|)) - (#try.Success |store|) - (do ! - [_ (stm.write |store| store)] - (wrap (#try.Success []))) - - (#try.Failure error) - (wrap (#try.Failure error)))))) - )))) - -(def: (check_or_make_directory monad fs path) - (All [!] (-> (Monad !) (System !) Path (! (Try Any)))) - (do monad - [? (\ fs directory? path)] - (if ? - (wrap (#try.Success [])) - (\ fs make_directory path)))) - -(def: #export (make_directories monad fs path) - (All [!] (-> (Monad !) (System !) Path (! (Try Any)))) - (let [rooted? (text.starts_with? (\ fs separator) path) - segments (text.split_all_with (\ fs separator) path)] - (case (if rooted? - (list.drop 1 segments) - segments) - #.Nil - (\ monad wrap (exception.throw ..cannot_make_directory [path])) - - (#.Cons head tail) - (case head - "" (\ monad wrap (exception.throw ..cannot_make_directory [path])) - _ (loop [current (if rooted? - (format (\ fs separator) head) - head) - next tail] - (do monad - [? (..check_or_make_directory monad fs current)] - (case ? - (#try.Success _) - (case next - #.Nil - (wrap (#try.Success [])) - - (#.Cons head tail) - (recur (format current (\ fs separator) head) - tail)) - - (#try.Failure error) - (wrap (#try.Failure error))))))))) - -(def: #export (make_file monad fs content path) - (All [!] (-> (Monad !) (System !) Binary Path (! (Try Any)))) - (do monad - [? (\ fs file? path)] - (if ? - (wrap (exception.throw ..cannot_make_file [path])) - (\ fs write content path)))) diff --git a/stdlib/source/lux/world/file/watch.lux b/stdlib/source/lux/world/file/watch.lux deleted file mode 100644 index f1415da80..000000000 --- a/stdlib/source/lux/world/file/watch.lux +++ /dev/null @@ -1,458 +0,0 @@ -(.module: - [lux #* - ["@" target] - ["." ffi (#+ import:)] - [abstract - [predicate (#+ Predicate)] - ["." monad (#+ do)]] - [control - ["." io (#+ IO)] - ["." try (#+ Try)] - ["." exception (#+ exception:)] - [concurrency - ["." promise (#+ Promise)] - ["." stm (#+ STM Var)]]] - [data - ["." product] - ["." maybe] - ["." text - ["%" format (#+ format)]] - [collection - ["." dictionary (#+ Dictionary)] - ["." list ("#\." functor monoid fold)] - ["." set] - ["." array]]] - [math - [number - ["n" nat]]] - [time - ["." instant (#+ Instant) ("#\." equivalence)]] - [type - [abstract (#+ abstract: :representation :abstraction)]]] - ["." //]) - -(abstract: #export Concern - {#create Bit - #modify Bit - #delete Bit} - - (def: none - Concern - (:abstraction - {#create false - #modify false - #delete false})) - - (template [<concern> <predicate> <event> <create> <modify> <delete>] - [(def: #export <concern> - Concern - (:abstraction - {#create <create> - #modify <modify> - #delete <delete>})) - - (def: #export <predicate> - (Predicate Concern) - (|>> :representation (get@ <event>)))] - - [creation creation? #create - true false false] - [modification modification? #modify - false true false] - [deletion deletion? #delete - false false true] - ) - - (def: #export (also left right) - (-> Concern Concern Concern) - (:abstraction - {#create (or (..creation? left) (..creation? right)) - #modify (or (..modification? left) (..modification? right)) - #delete (or (..deletion? left) (..deletion? right))})) - - (def: #export all - Concern - ($_ ..also - ..creation - ..modification - ..deletion - )) - ) - -(interface: #export (Watcher !) - (: (-> Concern //.Path (! (Try Any))) - start) - (: (-> //.Path (! (Try Concern))) - concern) - (: (-> //.Path (! (Try Concern))) - stop) - (: (-> [] (! (Try (List [Concern //.Path])))) - poll)) - -(template [<name>] - [(exception: #export (<name> {path //.Path}) - (exception.report - ["Path" (%.text path)]))] - - [not_being_watched] - [cannot_poll_a_non_existent_directory] - ) - -(type: File_Tracker - (Dictionary //.Path Instant)) - -(type: Directory_Tracker - (Dictionary //.Path [Concern File_Tracker])) - -(def: (update_watch! new_concern path tracker) - (-> Concern //.Path (Var Directory_Tracker) (STM Bit)) - (do {! stm.monad} - [@tracker (stm.read tracker)] - (case (dictionary.get path @tracker) - (#.Some [old_concern last_modified]) - (do ! - [_ (stm.update (dictionary.put path [new_concern last_modified]) tracker)] - (wrap true)) - - #.None - (wrap false)))) - -(def: (file_tracker fs directory) - (-> (//.System Promise) //.Path (Promise (Try File_Tracker))) - (do {! (try.with promise.monad)} - [files (\ fs directory_files directory)] - (monad.fold ! - (function (_ file tracker) - (do ! - [last_modified (\ fs last_modified file)] - (wrap (dictionary.put file last_modified tracker)))) - (: File_Tracker - (dictionary.new text.hash)) - files))) - -(def: (poll_files fs directory) - (-> (//.System Promise) //.Path (Promise (Try (List [//.Path Instant])))) - (do {! (try.with promise.monad)} - [files (\ fs directory_files directory)] - (monad.map ! (function (_ file) - (|> file - (\ fs last_modified) - (\ ! map (|>> [file])))) - files))) - -(def: (poll_directory_changes fs [directory [concern file_tracker]]) - (-> (//.System Promise) [//.Path [Concern File_Tracker]] - (Promise (Try [[//.Path [Concern File_Tracker]] - [(List [//.Path Instant]) - (List [//.Path Instant Instant]) - (List //.Path)]]))) - (do {! (try.with promise.monad)} - [current_files (..poll_files fs directory) - #let [creations (if (..creation? concern) - (list.filter (|>> product.left (dictionary.key? file_tracker) not) - current_files) - (list)) - available (|> current_files - (list\map product.left) - (set.from_list text.hash)) - deletions (if (..deletion? concern) - (|> (dictionary.entries file_tracker) - (list\map product.left) - (list.filter (|>> (set.member? available) not))) - (list)) - modifications (list.all (function (_ [path current_modification]) - (do maybe.monad - [previous_modification (dictionary.get path file_tracker)] - (wrap [path previous_modification current_modification]))) - current_files)]] - (wrap [[directory - [concern - (let [with_deletions (list\fold dictionary.remove file_tracker deletions) - with_creations (list\fold (function (_ [path last_modified] tracker) - (dictionary.put path last_modified tracker)) - with_deletions - creations) - with_modifications (list\fold (function (_ [path previous_modification current_modification] tracker) - (dictionary.put path current_modification tracker)) - with_creations - modifications)] - with_modifications)]] - [creations - modifications - deletions]]))) - -(def: #export (polling fs) - (-> (//.System Promise) (Watcher Promise)) - (let [tracker (: (Var Directory_Tracker) - (stm.var (dictionary.new text.hash)))] - (implementation - (def: (start new_concern path) - (do {! promise.monad} - [exists? (\ fs directory? path)] - (if exists? - (do ! - [updated? (stm.commit (..update_watch! new_concern path tracker))] - (if updated? - (wrap (#try.Success [])) - (do (try.with !) - [file_tracker (..file_tracker fs path)] - (do ! - [_ (stm.commit (stm.update (dictionary.put path [new_concern file_tracker]) tracker))] - (wrap (#try.Success [])))))) - (wrap (exception.throw ..cannot_poll_a_non_existent_directory [path]))))) - (def: (concern path) - (stm.commit - (do stm.monad - [@tracker (stm.read tracker)] - (wrap (case (dictionary.get path @tracker) - (#.Some [concern file_tracker]) - (#try.Success concern) - - #.None - (exception.throw ..not_being_watched [path])))))) - (def: (stop path) - (stm.commit - (do {! stm.monad} - [@tracker (stm.read tracker)] - (case (dictionary.get path @tracker) - (#.Some [concern file_tracker]) - (do ! - [_ (stm.update (dictionary.remove path) tracker)] - (wrap (#try.Success concern))) - - #.None - (wrap (exception.throw ..not_being_watched [path])))))) - (def: (poll _) - (do promise.monad - [@tracker (stm.commit (stm.read tracker))] - (do {! (try.with promise.monad)} - [changes (|> @tracker - dictionary.entries - (monad.map ! (..poll_directory_changes fs))) - _ (do promise.monad - [_ (stm.commit (stm.write (|> changes - (list\map product.left) - (dictionary.from_list text.hash)) - tracker))] - (wrap (#try.Success []))) - #let [[creations modifications deletions] - (list\fold (function (_ [_ [creations modifications deletions]] - [all_creations all_modifications all_deletions]) - [(list\compose creations all_creations) - (list\compose modifications all_modifications) - (list\compose deletions all_deletions)]) - [(list) (list) (list)] - changes)]] - (wrap ($_ list\compose - (list\map (|>> product.left [..creation]) creations) - (|> modifications - (list.filter (function (_ [path previous_modification current_modification]) - (not (instant\= previous_modification current_modification)))) - (list\map (|>> product.left [..modification]))) - (list\map (|>> [..deletion]) deletions) - ))))) - ))) - -(def: #export (mock separator) - (-> Text [(//.System Promise) (Watcher Promise)]) - (let [fs (//.mock separator)] - [fs - (..polling fs)])) - -(with_expansions [<jvm> (as_is (import: java/lang/Object) - - (import: java/lang/String) - - (import: (java/util/List a) - ["#::." - (size [] int) - (get [int] a)]) - - (def: (default_list list) - (All [a] (-> (java/util/List a) (List a))) - (let [size (.nat (java/util/List::size list))] - (loop [idx 0 - output #.Nil] - (if (n.< size idx) - (recur (inc idx) - (#.Cons (java/util/List::get (.int idx) list) - output)) - output)))) - - (import: (java/nio/file/WatchEvent$Kind a)) - - (import: (java/nio/file/WatchEvent a) - ["#::." - (kind [] (java/nio/file/WatchEvent$Kind a))]) - - (import: java/nio/file/Watchable) - - (import: java/nio/file/Path - ["#::." - (register [java/nio/file/WatchService [(java/nio/file/WatchEvent$Kind [? < java/lang/Object])]] #io #try java/nio/file/WatchKey) - (toString [] java/lang/String)]) - - (import: java/nio/file/StandardWatchEventKinds - ["#::." - (#static ENTRY_CREATE (java/nio/file/WatchEvent$Kind java/nio/file/Path)) - (#static ENTRY_MODIFY (java/nio/file/WatchEvent$Kind java/nio/file/Path)) - (#static ENTRY_DELETE (java/nio/file/WatchEvent$Kind java/nio/file/Path))]) - - (def: (default_event_concern event) - (All [a] - (-> (java/nio/file/WatchEvent a) Concern)) - (let [kind (:as (java/nio/file/WatchEvent$Kind java/nio/file/Path) - (java/nio/file/WatchEvent::kind event))] - (cond (is? (java/nio/file/StandardWatchEventKinds::ENTRY_CREATE) - kind) - ..creation - - (is? (java/nio/file/StandardWatchEventKinds::ENTRY_MODIFY) - kind) - ..modification - - (is? (java/nio/file/StandardWatchEventKinds::ENTRY_DELETE) - kind) - ..deletion - - ## else - ..none - ))) - - (import: java/nio/file/WatchKey - ["#::." - (reset [] #io boolean) - (cancel [] #io void) - (watchable [] java/nio/file/Watchable) - (pollEvents [] #io (java/util/List (java/nio/file/WatchEvent ?)))]) - - (def: default_key_concern - (-> java/nio/file/WatchKey (IO Concern)) - (|>> java/nio/file/WatchKey::pollEvents - (\ io.monad map (|>> ..default_list - (list\map default_event_concern) - (list\fold ..also ..none))))) - - (import: java/nio/file/WatchService - ["#::." - (poll [] #io #try #? java/nio/file/WatchKey)]) - - (import: java/nio/file/FileSystem - ["#::." - (newWatchService [] #io #try java/nio/file/WatchService)]) - - (import: java/nio/file/FileSystems - ["#::." - (#static getDefault [] java/nio/file/FileSystem)]) - - (import: java/io/File - ["#::." - (new [java/lang/String]) - (toPath [] java/nio/file/Path)]) - - (type: Watch_Event - (java/nio/file/WatchEvent$Kind java/lang/Object)) - - (def: (default_start watch_events watcher path) - (-> (List Watch_Event) java/nio/file/WatchService //.Path (Promise (Try java/nio/file/WatchKey))) - (let [watch_events' (list\fold (function (_ [index watch_event] watch_events') - (ffi.array_write index watch_event watch_events')) - (ffi.array (java/nio/file/WatchEvent$Kind java/lang/Object) - (list.size watch_events)) - (list.enumeration watch_events))] - (promise.future - (java/nio/file/Path::register watcher - watch_events' - (|> path java/io/File::new java/io/File::toPath))))) - - (def: (default_poll watcher) - (-> java/nio/file/WatchService (IO (Try (List [Concern //.Path])))) - (loop [output (: (List [Concern //.Path]) - (list))] - (do (try.with io.monad) - [?key (java/nio/file/WatchService::poll watcher)] - (case ?key - (#.Some key) - (do {! io.monad} - [valid? (java/nio/file/WatchKey::reset key)] - (if valid? - (do ! - [#let [path (|> key - java/nio/file/WatchKey::watchable - (:as java/nio/file/Path) - java/nio/file/Path::toString - (:as //.Path))] - concern (..default_key_concern key)] - (recur (#.Cons [concern path] - output))) - (recur output))) - - #.None - (wrap output))))) - - (def: (watch_events concern) - (-> Concern (List Watch_Event)) - ($_ list\compose - (if (..creation? concern) - (list (:as Watch_Event (java/nio/file/StandardWatchEventKinds::ENTRY_CREATE))) - (list)) - (if (..modification? concern) - (list (:as Watch_Event (java/nio/file/StandardWatchEventKinds::ENTRY_MODIFY))) - (list)) - (if (..deletion? concern) - (list (:as Watch_Event (java/nio/file/StandardWatchEventKinds::ENTRY_DELETE))) - (list)) - )) - - (def: #export default - (IO (Try (Watcher Promise))) - (do (try.with io.monad) - [watcher (java/nio/file/FileSystem::newWatchService - (java/nio/file/FileSystems::getDefault)) - #let [tracker (stm.var (: (Dictionary //.Path [Concern java/nio/file/WatchKey]) - (dictionary.new text.hash))) - - stop (: (-> //.Path (Promise (Try Concern))) - (function (_ path) - (do {! promise.monad} - [@tracker (stm.commit (stm.read tracker))] - (case (dictionary.get path @tracker) - (#.Some [concern key]) - (do ! - [_ (promise.future - (java/nio/file/WatchKey::cancel key)) - _ (stm.commit (stm.update (dictionary.remove path) tracker))] - (wrap (#try.Success concern))) - - #.None - (wrap (exception.throw ..not_being_watched [path]))))))]] - (wrap (: (Watcher Promise) - (implementation - (def: (start concern path) - (do promise.monad - [?concern (stop path)] - (do (try.with promise.monad) - [key (..default_start (..watch_events (..also (try.default ..none ?concern) - concern)) - watcher - path)] - (do promise.monad - [_ (stm.commit (stm.update (dictionary.put path [concern key]) tracker))] - (wrap (#try.Success [])))))) - (def: (concern path) - (do promise.monad - [@tracker (stm.commit (stm.read tracker))] - (case (dictionary.get path @tracker) - (#.Some [concern key]) - (wrap (#try.Success concern)) - - #.None - (wrap (exception.throw ..not_being_watched [path]))))) - (def: stop stop) - (def: (poll _) - (promise.future (..default_poll watcher))) - ))))) - )] - (for {@.old (as_is <jvm>) - @.jvm (as_is <jvm>)} - (as_is))) diff --git a/stdlib/source/lux/world/input/keyboard.lux b/stdlib/source/lux/world/input/keyboard.lux deleted file mode 100644 index 90068c197..000000000 --- a/stdlib/source/lux/world/input/keyboard.lux +++ /dev/null @@ -1,111 +0,0 @@ -(.module: - [lux #*]) - -(type: #export Key - Nat) - -(template [<code> <name>] - [(def: #export <name> Key <code>)] - - [00008 back_space] - [00010 enter] - [00016 shift] - [00017 control] - [00018 alt] - [00020 caps_lock] - [00027 escape] - [00032 space] - [00033 page_up] - [00034 page_down] - [00035 end] - [00036 home] - - [00037 left] - [00038 up] - [00039 right] - [00040 down] - - [00065 a] - [00066 b] - [00067 c] - [00068 d] - [00069 e] - [00070 f] - [00071 g] - [00072 h] - [00073 i] - [00074 j] - [00075 k] - [00076 l] - [00077 m] - [00078 n] - [00079 o] - [00080 p] - [00081 q] - [00082 r] - [00083 s] - [00084 t] - [00085 u] - [00086 v] - [00087 w] - [00088 x] - [00089 y] - [00090 z] - - [00096 num_pad_0] - [00097 num_pad_1] - [00098 num_pad_2] - [00099 num_pad_3] - [00100 num_pad_4] - [00101 num_pad_5] - [00102 num_pad_6] - [00103 num_pad_7] - [00104 num_pad_8] - [00105 num_pad_9] - - [00127 delete] - [00144 num_lock] - [00145 scroll_lock] - [00154 print_screen] - [00155 insert] - [00524 windows] - - [00112 f1] - [00113 f2] - [00114 f3] - [00115 f4] - [00116 f5] - [00117 f6] - [00118 f7] - [00119 f8] - [00120 f9] - [00121 f10] - [00122 f11] - [00123 f12] - [61440 f13] - [61441 f14] - [61442 f15] - [61443 f16] - [61444 f17] - [61445 f18] - [61446 f19] - [61447 f20] - [61448 f21] - [61449 f22] - [61450 f23] - [61451 f24] - ) - -(type: #export Press - {#pressed? Bit - #input Key}) - -(template [<bit> <name>] - [(def: #export (<name> key) - (-> Key Press) - {#pressed? <bit> - #input key})] - - [#0 release] - [#1 press] - ) diff --git a/stdlib/source/lux/world/net.lux b/stdlib/source/lux/world/net.lux deleted file mode 100644 index e4133710e..000000000 --- a/stdlib/source/lux/world/net.lux +++ /dev/null @@ -1,12 +0,0 @@ -(.module: - [lux (#- Location)]) - -(type: #export Address Text) - -(type: #export Port Nat) - -(type: #export URL Text) - -(type: #export Location - {#address Address - #port Port}) diff --git a/stdlib/source/lux/world/net/http.lux b/stdlib/source/lux/world/net/http.lux deleted file mode 100644 index 6682c24bd..000000000 --- a/stdlib/source/lux/world/net/http.lux +++ /dev/null @@ -1,79 +0,0 @@ -(.module: - [lux #* - [control - [try (#+ Try)] - [concurrency - [promise (#+ Promise)] - [frp (#+ Channel)]] - [parser - ["." environment (#+ Environment)]]] - [data - [binary (#+ Binary)]]] - [// (#+ URL) - [uri (#+ URI)]]) - -(type: #export Version - Text) - -(type: #export Method - #Post - #Get - #Put - #Patch - #Delete - #Head - #Connect - #Options - #Trace) - -(type: #export Port - Nat) - -(type: #export Status - Nat) - -(type: #export Headers - Environment) - -(def: #export empty - Headers - environment.empty) - -(type: #export Header - (-> Headers Headers)) - -(type: #export (Body !) - (-> (Maybe Nat) (! (Try [Nat Binary])))) - -(type: #export Scheme - #HTTP - #HTTPS) - -(type: #export Address - {#port Port - #host Text}) - -(type: #export Identification - {#local Address - #remote Address}) - -(type: #export Protocol - {#version Version - #scheme Scheme}) - -(type: #export Resource - {#method Method - #uri URI}) - -(type: #export (Message !) - {#headers Headers - #body (Body !)}) - -(type: #export (Request !) - [Identification Protocol Resource (Message !)]) - -(type: #export (Response !) - [Status (Message !)]) - -(type: #export (Server !) - (-> (Request !) (! (Response !)))) diff --git a/stdlib/source/lux/world/net/http/client.lux b/stdlib/source/lux/world/net/http/client.lux deleted file mode 100644 index 986ef0c89..000000000 --- a/stdlib/source/lux/world/net/http/client.lux +++ /dev/null @@ -1,226 +0,0 @@ -(.module: - [lux #* - ["@" target] - ["." ffi] - [abstract - ["." monad (#+ do)]] - [control - [pipe (#+ case>)] - ["." io (#+ IO)] - ["." try (#+ Try)] - [concurrency - ["." promise (#+ Promise)]]] - [data - ["." binary (#+ Binary)] - ["." maybe ("#\." functor)] - ["." text] - [collection - ["." dictionary]]] - [math - [number - ["n" nat] - ["i" int]]]] - ["." // - [// (#+ URL)]]) - -(interface: #export (Client !) - (: (-> //.Method URL //.Headers (Maybe Binary) - (! (Try (//.Response !)))) - request)) - -(template [<name> <method>] - [(def: #export (<name> url headers data client) - (All [!] - (-> URL //.Headers (Maybe Binary) (Client !) - (! (Try (//.Response !))))) - (\ client request <method> url headers data))] - - [post #//.Post] - [get #//.Get] - [put #//.Put] - [patch #//.Patch] - [delete #//.Delete] - [head #//.Head] - [connect #//.Connect] - [options #//.Options] - [trace #//.Trace] - ) - -(def: default_buffer_size - (n.* 1,024 1,024)) - -(def: empty_body - [Nat Binary] - [0 (binary.create 0)]) - -(def: (body_of data) - (-> Binary [Nat Binary]) - [(binary.size data) data]) - -(with_expansions [<jvm> (as_is (ffi.import: java/lang/String) - - (ffi.import: java/lang/AutoCloseable - ["#::." - (close [] #io #try void)]) - - (ffi.import: java/io/InputStream) - - (ffi.import: java/io/OutputStream - ["#::." - (flush [] #io #try void) - (write [[byte]] #io #try void)]) - - (ffi.import: java/net/URLConnection - ["#::." - (setDoOutput [boolean] #io #try void) - (setRequestProperty [java/lang/String java/lang/String] #io #try void) - (getInputStream [] #io #try java/io/InputStream) - (getOutputStream [] #io #try java/io/OutputStream) - (getHeaderFieldKey [int] #io #try #? java/lang/String) - (getHeaderField [int] #io #try #? java/lang/String)]) - - (ffi.import: java/net/HttpURLConnection - ["#::." - (setRequestMethod [java/lang/String] #io #try void) - (getResponseCode [] #io #try int)]) - - (ffi.import: java/net/URL - ["#::." - (new [java/lang/String]) - (openConnection [] #io #try java/net/URLConnection)]) - - (ffi.import: java/io/BufferedInputStream - ["#::." - (new [java/io/InputStream]) - (read [[byte] int int] #io #try int)]) - - (def: jvm_method - (-> //.Method Text) - (|>> (case> #//.Post "POST" - #//.Get "GET" - #//.Put "PUT" - #//.Patch "PATCH" - #//.Delete "DELETE" - #//.Head "HEAD" - #//.Connect "CONNECT" - #//.Options "OPTIONS" - #//.Trace "TRACE"))) - - (def: (default_body input) - (-> java/io/BufferedInputStream (//.Body IO)) - (|>> (maybe\map (|>> [true])) - (maybe.default [false ..default_buffer_size]) - (case> [_ 0] - (do (try.with io.monad) - [_ (java/lang/AutoCloseable::close input)] - (wrap ..empty_body)) - - [partial? buffer_size] - (let [buffer (binary.create buffer_size)] - (if partial? - (loop [so_far +0] - (do {! (try.with io.monad)} - [#let [remaining (i.- so_far (.int buffer_size))] - bytes_read (java/io/BufferedInputStream::read buffer so_far remaining input)] - (case bytes_read - -1 (do ! - [_ (java/lang/AutoCloseable::close input)] - (wrap [(.nat so_far) buffer])) - +0 (recur so_far) - _ (if (i.= remaining bytes_read) - (wrap [buffer_size buffer]) - (recur (i.+ bytes_read so_far)))))) - (loop [so_far +0 - output (\ binary.monoid identity)] - (do {! (try.with io.monad)} - [#let [remaining (i.- so_far (.int buffer_size))] - bytes_read (java/io/BufferedInputStream::read buffer so_far remaining input)] - (case bytes_read - -1 (do ! - [_ (java/lang/AutoCloseable::close input)] - (case so_far - +0 (wrap (..body_of output)) - _ (|> buffer - (binary.slice 0 (.nat so_far)) - (\ try.functor map - (|>> (\ binary.monoid compose output) - ..body_of)) - (\ io.monad wrap)))) - +0 (recur so_far output) - _ (if (i.= remaining bytes_read) - (recur +0 - (\ binary.monoid compose output buffer)) - (recur (i.+ bytes_read so_far) - output)))))))))) - - (def: (default_headers connection) - (-> java/net/HttpURLConnection (IO (Try //.Headers))) - (loop [index +0 - headers //.empty] - (do {! (try.with io.monad)} - [?name (java/net/URLConnection::getHeaderFieldKey index connection)] - (case ?name - (#.Some name) - (do ! - [?value (java/net/URLConnection::getHeaderField index connection)] - (recur (inc index) - (dictionary.put name (maybe.default "" ?value) headers))) - - #.None - (wrap headers))))) - - (implementation: #export default - (Client IO) - - (def: (request method url headers data) - (: (IO (Try (//.Response IO))) - (do {! (try.with io.monad)} - [connection (|> url java/net/URL::new java/net/URL::openConnection) - #let [connection (:as java/net/HttpURLConnection connection)] - _ (java/net/HttpURLConnection::setRequestMethod (..jvm_method method) connection) - _ (monad.map ! (function (_ [name value]) - (java/net/URLConnection::setRequestProperty name value connection)) - (dictionary.entries headers)) - _ (case data - (#.Some data) - (do ! - [_ (java/net/URLConnection::setDoOutput true connection) - stream (java/net/URLConnection::getOutputStream connection) - _ (java/io/OutputStream::write data stream) - _ (java/io/OutputStream::flush stream) - _ (java/lang/AutoCloseable::close stream)] - (wrap [])) - - #.None - (wrap [])) - status (java/net/HttpURLConnection::getResponseCode connection) - headers (..default_headers connection) - input (|> connection - java/net/URLConnection::getInputStream - (\ ! map (|>> java/io/BufferedInputStream::new)))] - (wrap [(.nat status) - {#//.headers headers - #//.body (..default_body input)}]))))))] - (for {@.old (as_is <jvm>) - @.jvm (as_is <jvm>)} - (as_is))) - -(implementation: #export (async client) - (-> (Client IO) (Client Promise)) - - (def: (request method url headers data) - (|> (\ client request method url headers data) - promise.future - (\ promise.monad map - (|>> (case> (#try.Success [status message]) - (#try.Success [status (update@ #//.body (: (-> (//.Body IO) (//.Body Promise)) - (function (_ body) - (|>> body promise.future))) - message)]) - - (#try.Failure error) - (#try.Failure error))))))) - -(def: #export headers - (-> (List [Text Text]) //.Headers) - (dictionary.from_list text.hash)) diff --git a/stdlib/source/lux/world/net/http/cookie.lux b/stdlib/source/lux/world/net/http/cookie.lux deleted file mode 100644 index 969f951ec..000000000 --- a/stdlib/source/lux/world/net/http/cookie.lux +++ /dev/null @@ -1,87 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)] - ["." try (#+ Try)] - ["p" parser ("#\." monad) - ["l" text (#+ Parser)]]] - [data - [number - ["i" int]] - [text - ["%" format (#+ format)]] - [format - ["." context (#+ Context)]] - [collection - ["." dictionary]]] - [time - ["." duration (#+ Duration)]]] - ["." // (#+ Header) - ["." header]]) - -(type: #export Directive (-> Text Text)) - -(def: (directive extension) - (-> Text Directive) - (function (_ so-far) - (format so-far "; " extension))) - -(def: #export (set name value) - (-> Text Text Header) - (header.add "Set-Cookie" (format name "=" value))) - -(def: #export (max-age duration) - (-> Duration Directive) - (let [seconds (duration.query duration.second duration)] - (..directive (format "Max-Age=" (if (i.< +0 seconds) - (%.int seconds) - (%.nat (.nat seconds))))))) - -(template [<name> <prefix>] - [(def: #export (<name> value) - (-> Text Directive) - (..directive (format <prefix> "=" value)))] - - [domain "Domain"] - [path "Path"] - ) - -(template [<name> <tag>] - [(def: #export <name> - Directive - (..directive <tag>))] - - [secure "Secure"] - [http-only "HttpOnly"] - ) - -(type: #export CSRF-Policy - #Strict - #Lax) - -(def: #export (same-site policy) - (-> CSRF-Policy Directive) - (..directive (format "SameSite=" (case policy - #Strict "Strict" - #Lax "Lax")))) - -(def: (cookie context) - (-> Context (Parser Context)) - (do p.monad - [key (l.slice (l.many! (l.none-of! "="))) - _ (l.this "=") - value (l.slice (l.many! (l.none-of! ";")))] - (wrap (dictionary.put key value context)))) - -(def: (cookies context) - (-> Context (Parser Context)) - ($_ p.either - (do p.monad - [context' (..cookie context) - _ (l.this "; ")] - (cookies context')) - (p\wrap context))) - -(def: #export (get header) - (-> Text (Try Context)) - (l.run header (..cookies context.empty))) diff --git a/stdlib/source/lux/world/net/http/header.lux b/stdlib/source/lux/world/net/http/header.lux deleted file mode 100644 index 4cd1daa67..000000000 --- a/stdlib/source/lux/world/net/http/header.lux +++ /dev/null @@ -1,34 +0,0 @@ -(.module: - [lux #* - [control - [pipe (#+ case>)]] - [data - [text - ["%" format (#+ format)]] - [collection - ["." dictionary (#+ Dictionary)]]]] - [// (#+ Header) - ["." mime (#+ MIME)] - [// (#+ URL)]]) - -(def: #export (add name value) - (-> Text Text Header) - (dictionary.upsert name "" - (|>> (case> - "" - value - - previous - (format previous "," value))))) - -(def: #export content-length - (-> Nat Header) - (|>> %.nat (..add "Content-Length"))) - -(def: #export content-type - (-> MIME Header) - (|>> mime.name (..add "Content-Type"))) - -(def: #export location - (-> URL Header) - (..add "Location")) diff --git a/stdlib/source/lux/world/net/http/mime.lux b/stdlib/source/lux/world/net/http/mime.lux deleted file mode 100644 index 1029e6bb9..000000000 --- a/stdlib/source/lux/world/net/http/mime.lux +++ /dev/null @@ -1,99 +0,0 @@ -(.module: - [lux #* - [data - ["." text - ["%" format (#+ format)] - ["." encoding (#+ Encoding)]]] - [type - abstract]]) - -(abstract: #export MIME - Text - - {#doc "Multipurpose Internet Mail Extensions"} - - (def: #export mime - (-> Text MIME) - (|>> :abstraction)) - - (def: #export name - (-> MIME Text) - (|>> :representation)) - ) - -## https://developer.mozilla.org/en-US/docs/Web/HTTP/Basics_of_HTTP/MIME_types/Complete_list_of_MIME_types -(template [<name> <type>] - [(def: #export <name> MIME (..mime <type>))] - - [aac-audio "audio/aac"] - [abiword "application/x-abiword"] - [avi "video/x-msvideo"] - [amazon-kindle-ebook "application/vnd.amazon.ebook"] - [binary "application/octet-stream"] - [bitmap "image/bmp"] - [bzip "application/x-bzip"] - [bzip2 "application/x-bzip2"] - [c-shell "application/x-csh"] - [css "text/css"] - [csv "text/csv"] - [microsoft-word "application/msword"] - [microsoft-word-openxml "application/vnd.openxmlformats-officedocument.wordprocessingml.document"] - [ms-embedded-opentype-fonts "application/vnd.ms-fontobject"] - [epub "application/epub+zip"] - [ecmascript "application/ecmascript"] - [gif "image/gif"] - [html "text/html"] - [icon "image/x-icon"] - [icalendar "text/calendar"] - [jar "application/java-archive"] - [jpeg "image/jpeg"] - [javascript "application/javascript"] - [json "application/json"] - [midi "audio/midi"] - [mpeg "video/mpeg"] - [apple-installer-package "application/vnd.apple.installer+xml"] - [opendocument-presentation "application/vnd.oasis.opendocument.presentation"] - [opendocument-spreadsheet "application/vnd.oasis.opendocument.spreadsheet"] - [opendocument-text "application/vnd.oasis.opendocument.text"] - [ogg-audio "audio/ogg"] - [ogg-video "video/ogg"] - [ogg "application/ogg"] - [opentype-font "font/otf"] - [png "image/png"] - [pdf "application/pdf"] - [microsoft-powerpoint "application/vnd.ms-powerpoint"] - [microsoft-powerpoint-openxml "application/vnd.openxmlformats-officedocument.presentationml.presentation"] - [rar "application/x-rar-compressed"] - [rtf "application/rtf"] - [bourne-shell "application/x-sh"] - [svg "image/svg+xml"] - [flash "application/x-shockwave-flash"] - [tar "application/x-tar"] - [tiff "image/tiff"] - [typescript "application/typescript"] - [truetype-font "font/ttf"] - [microsoft-visio "application/vnd.visio"] - [wav "audio/wav"] - [webm-audio "audio/webm"] - [webm-video "video/webm"] - [webp "image/webp"] - [woff "font/woff"] - [woff2 "font/woff2"] - [xhtml "application/xhtml+xml"] - [microsoft-excel "application/vnd.ms-excel"] - [microsoft-excel-openxml "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"] - [xml "application/xml"] - [xul "application/vnd.mozilla.xul+xml"] - [zip "application/zip"] - [!3gpp-audio "audio/3gpp"] - [!3gpp "video/3gpp"] - [!3gpp2-audio "audio/3gpp2"] - [!3gpp2 "video/3gpp2"] - [!7z "application/x-7z-compressed"] - ) - -(def: #export (text encoding) - (-> Encoding MIME) - (..mime (format "text/plain; charset=" text.double-quote (encoding.name encoding) text.double-quote))) - -(def: #export utf-8 MIME (..text encoding.utf-8)) diff --git a/stdlib/source/lux/world/net/http/query.lux b/stdlib/source/lux/world/net/http/query.lux deleted file mode 100644 index 006942bfe..000000000 --- a/stdlib/source/lux/world/net/http/query.lux +++ /dev/null @@ -1,64 +0,0 @@ -(.module: - [lux #* - [control - pipe - [monad (#+ do)] - ["." try (#+ Try)] - ["p" parser - ["l" text (#+ Parser)]]] - [data - [number - ["." nat]] - ["." text - ["%" format (#+ format)]] - [format - ["." context (#+ Context)]] - [collection - ["." dictionary]]]]) - -(def: component - (Parser Text) - (p.rec - (function (_ component) - (do {! p.monad} - [head (l.some (l.none-of "+%&;"))] - ($_ p.either - (p.after (p.either l.end - (l.this "&")) - (wrap head)) - (do ! - [_ (l.this "+") - tail component] - (wrap (format head " " tail))) - (do ! - [_ (l.this "%") - code (|> (l.exactly 2 l.hexadecimal) - (p.codec nat.hex) - (\ ! map text.from-code)) - tail component] - (wrap (format head code tail)))))))) - -(def: (form context) - (-> Context (Parser Context)) - ($_ p.either - (do p.monad - [_ l.end] - (wrap context)) - (do {! p.monad} - [key (l.some (l.none-of "=&;")) - key (l.local key ..component)] - (p.either (do ! - [_ (l.this "=") - value ..component] - (form (dictionary.put key value context))) - (do ! - [_ ($_ p.or - (l.one-of "&;") - l.end)] - (form (dictionary.put key "" context))))) - ## if invalid form data, just stop parsing... - (\ p.monad wrap context))) - -(def: #export (parameters raw) - (-> Text (Try Context)) - (l.run raw (..form context.empty))) diff --git a/stdlib/source/lux/world/net/http/request.lux b/stdlib/source/lux/world/net/http/request.lux deleted file mode 100644 index 0d9354cd8..000000000 --- a/stdlib/source/lux/world/net/http/request.lux +++ /dev/null @@ -1,127 +0,0 @@ -(.module: - [lux #* - [control - pipe - ["." monad (#+ do)] - ["." try (#+ Try)] - [concurrency - ["." promise (#+ Promise)] - ["." frp]] - [parser - ["<.>" json]]] - [data - ["." maybe] - ["." number - ["n" nat]] - ["." text - ["." encoding]] - [format - ["." json (#+ JSON)] - ["." context (#+ Context Property)]] - [collection - ["." list ("#\." functor fold)] - ["." dictionary]]] - [world - ["." binary (#+ Binary)]]] - ["." // (#+ Body Response Server) - ["#." response] - ["#." query] - ["#." cookie]]) - -(def: (merge inputs) - (-> (List Binary) Binary) - (let [[_ output] (try.assume - (monad.fold try.monad - (function (_ input [offset output]) - (let [amount (binary.size input)] - (\ try.functor map (|>> [(n.+ amount offset)]) - (binary.copy amount 0 input offset output)))) - [0 (|> inputs - (list\map binary.size) - (list\fold n.+ 0) - binary.create)] - inputs))] - output)) - -(def: (read-text-body body) - (-> Body (Promise (Try Text))) - (do promise.monad - [blobs (frp.consume body)] - (wrap (\ encoding.utf8 decode (merge blobs))))) - -(def: failure (//response.bad-request "")) - -(def: #export (json reader server) - (All [a] (-> (<json>.Reader a) (-> a Server) Server)) - (function (_ (^@ request [identification protocol resource message])) - (do promise.monad - [?raw (read-text-body (get@ #//.body message))] - (case (do try.monad - [raw ?raw - content (\ json.codec decode raw)] - (json.run content reader)) - (#try.Success input) - (server input request) - - (#try.Failure error) - (promise.resolved ..failure))))) - -(def: #export (text server) - (-> (-> Text Server) Server) - (function (_ (^@ request [identification protocol resource message])) - (do promise.monad - [?raw (read-text-body (get@ #//.body message))] - (case ?raw - (#try.Success content) - (server content request) - - (#try.Failure error) - (promise.resolved ..failure))))) - -(def: #export (query property server) - (All [a] (-> (Property a) (-> a Server) Server)) - (function (_ [identification protocol resource message]) - (let [full (get@ #//.uri resource) - [uri query] (|> full - (text.split-with "?") - (maybe.default [full ""]))] - (case (do try.monad - [query (//query.parameters query) - input (context.run query property)] - (wrap [[identification protocol (set@ #//.uri uri resource) message] - input])) - (#try.Success [request input]) - (server input request) - - (#try.Failure error) - (promise.resolved ..failure))))) - -(def: #export (form property server) - (All [a] (-> (Property a) (-> a Server) Server)) - (function (_ (^@ request [identification protocol resource message])) - (do promise.monad - [?body (read-text-body (get@ #//.body message))] - (case (do try.monad - [body ?body - form (//query.parameters body)] - (context.run form property)) - (#try.Success input) - (server input request) - - (#try.Failure error) - (promise.resolved ..failure))))) - -(def: #export (cookies property server) - (All [a] (-> (Property a) (-> a Server) Server)) - (function (_ (^@ request [identification protocol resource message])) - (case (do try.monad - [cookies (|> (get@ #//.headers message) - (dictionary.get "Cookie") - (maybe.default "") - //cookie.get)] - (context.run cookies property)) - (#try.Success input) - (server input request) - - (#try.Failure error) - (promise.resolved ..failure)))) diff --git a/stdlib/source/lux/world/net/http/response.lux b/stdlib/source/lux/world/net/http/response.lux deleted file mode 100644 index 3e06614d2..000000000 --- a/stdlib/source/lux/world/net/http/response.lux +++ /dev/null @@ -1,73 +0,0 @@ -(.module: - [lux (#- static) - [control - [concurrency - ["." promise] - ["." frp ("#\." monad)]]] - [data - ["." text - ["." encoding]] - [format - ["." html] - ["." css (#+ CSS)] - ["." context] - ["." json (#+ JSON) ("#\." codec)]]] - ["." io] - [world - ["." binary (#+ Binary)]]] - ["." // (#+ Status Body Response Server) - ["." status] - ["." mime (#+ MIME)] - ["." header] - [// (#+ URL)]]) - -(def: #export (static response) - (-> Response Server) - (function (_ request) - (promise.resolved response))) - -(def: #export empty - (-> Status Response) - (let [body (frp\wrap (\ encoding.utf8 encode ""))] - (function (_ status) - [status - {#//.headers (|> context.empty - (header.content-length 0) - (header.content-type mime.utf-8)) - #//.body body}]))) - -(def: #export (temporary-redirect to) - (-> URL Response) - (let [[status message] (..empty status.temporary-redirect)] - [status (update@ #//.headers (header.location to) message)])) - -(def: #export not-found - Response - (..empty status.not-found)) - -(def: #export (content status type data) - (-> Status MIME Binary Response) - [status - {#//.headers (|> context.empty - (header.content-length (binary.size data)) - (header.content-type type)) - #//.body (frp\wrap data)}]) - -(def: #export bad-request - (-> Text Response) - (|>> (\ encoding.utf8 encode) (content status.bad-request mime.utf-8))) - -(def: #export ok - (-> MIME Binary Response) - (content status.ok)) - -(template [<name> <type> <mime> <pre>] - [(def: #export <name> - (-> <type> Response) - (|>> <pre> (\ encoding.utf8 encode) (..ok <mime>)))] - - [text Text mime.utf-8 (<|)] - [html html.Document mime.html html.html] - [css CSS mime.css css.css] - [json JSON mime.json json\encode] - ) diff --git a/stdlib/source/lux/world/net/http/route.lux b/stdlib/source/lux/world/net/http/route.lux deleted file mode 100644 index 32bdf1213..000000000 --- a/stdlib/source/lux/world/net/http/route.lux +++ /dev/null @@ -1,73 +0,0 @@ -(.module: - [lux (#- or) - [control - [monad (#+ do)] - [concurrency - ["." promise]]] - [data - ["." maybe] - ["." text] - [number - ["n" nat]]]] - ["." // (#+ URI Server) - ["#." status] - ["#." response]]) - -(template [<scheme> <name>] - [(def: #export (<name> server) - (-> Server Server) - (function (_ (^@ request [identification protocol resource message])) - (case (get@ #//.scheme protocol) - <scheme> - (server request) - - _ - (promise.resolved //response.not-found))))] - - [#//.HTTP http] - [#//.HTTPS https] - ) - -(template [<method> <name>] - [(def: #export (<name> server) - (-> Server Server) - (function (_ (^@ request [identification protocol resource message])) - (case (get@ #//.method resource) - <method> - (server request) - - _ - (promise.resolved //response.not-found))))] - - [#//.Get get] - [#//.Post post] - [#//.Put put] - [#//.Patch patch] - [#//.Delete delete] - [#//.Head head] - [#//.Connect connect] - [#//.Options options] - [#//.Trace trace] - ) - -(def: #export (uri path server) - (-> URI Server Server) - (function (_ [identification protocol resource message]) - (if (text.starts-with? path (get@ #//.uri resource)) - (server [identification - protocol - (update@ #//.uri - (|>> (text.clip' (text.size path)) maybe.assume) - resource) - message]) - (promise.resolved //response.not-found)))) - -(def: #export (or primary alternative) - (-> Server Server Server) - (function (_ request) - (do promise.monad - [response (primary request) - #let [[status message] response]] - (if (n.= //status.not-found status) - (alternative request) - (wrap response))))) diff --git a/stdlib/source/lux/world/net/http/status.lux b/stdlib/source/lux/world/net/http/status.lux deleted file mode 100644 index cb0e8a8af..000000000 --- a/stdlib/source/lux/world/net/http/status.lux +++ /dev/null @@ -1,82 +0,0 @@ -(.module: - [lux #*] - [// (#+ Status)]) - -## https://en.wikipedia.org/wiki/List_of_HTTP_status_codes -(template [<status> <name>] - [(def: #export <name> - Status - <status>)] - - ## 1xx Informational response - [100 continue] - [101 switching_protocols] - [102 processing] - [103 early_hints] - - ## 2xx Success - [200 ok] - [201 created] - [202 accepted] - [203 non_authoritative_information] - [204 no_content] - [205 reset_content] - [206 partial_content] - [207 multi_status] - [208 already_reported] - [226 im_used] - - ## 3xx Redirection - [300 multiple_choices] - [301 moved_permanently] - [302 found] - [303 see_other] - [304 not_modified] - [305 use_proxy] - [306 switch_proxy] - [307 temporary_redirect] - [308 permanent_redirect] - - ## 4xx Client errors - [400 bad_request] - [401 unauthorized] - [402 payment_required] - [403 forbidden] - [404 not_found] - [405 method_not_allowed] - [406 not_acceptable] - [407 proxy_authentication_required] - [408 request_timeout] - [409 conflict] - [410 gone] - [411 length_required] - [412 precondition_failed] - [413 payload_too_large] - [414 uri_too_long] - [415 unsupported_media_type] - [416 range_not_satisfiable] - [417 expectation_failed] - [418 im_a_teapot] - [421 misdirected_request] - [422 unprocessable_entity] - [423 locked] - [424 failed_dependency] - [426 upgrade_required] - [428 precondition_required] - [429 too_many_requests] - [431 request_header_fields_too_large] - [451 unavailable_for_legal_reasons] - - ## 5xx Server errors - [500 internal_server_error] - [501 not_implemented] - [502 bad_gateway] - [503 service_unavailable] - [504 gateway_timeout] - [505 http_version_not_supported] - [506 variant_also_negotiates] - [507 insufficient_storage] - [508 loop_detected] - [510 not_extended] - [511 network_authentication_required] - ) diff --git a/stdlib/source/lux/world/net/http/version.lux b/stdlib/source/lux/world/net/http/version.lux deleted file mode 100644 index 4a693766d..000000000 --- a/stdlib/source/lux/world/net/http/version.lux +++ /dev/null @@ -1,12 +0,0 @@ -(.module: - [lux #*] - [// (#+ Version)]) - -(template [<name> <version>] - [(def: #export <name> Version <version>)] - - [v0_9 "0.9"] - [v1_0 "1.0"] - [v1_1 "1.1"] - [v2_0 "2.0"] - ) diff --git a/stdlib/source/lux/world/net/uri.lux b/stdlib/source/lux/world/net/uri.lux deleted file mode 100644 index e7d70d108..000000000 --- a/stdlib/source/lux/world/net/uri.lux +++ /dev/null @@ -1,8 +0,0 @@ -(.module: - [lux #*]) - -(type: #export URI - Text) - -(def: #export separator - "/") diff --git a/stdlib/source/lux/world/output/video/resolution.lux b/stdlib/source/lux/world/output/video/resolution.lux deleted file mode 100644 index 2dbe1c8bc..000000000 --- a/stdlib/source/lux/world/output/video/resolution.lux +++ /dev/null @@ -1,46 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)]] - [data - ["." product]] - [math - [number - ["." nat]]]]) - -(type: #export Resolution - {#width Nat - #height Nat}) - -(def: #export hash - (Hash Resolution) - (product.hash nat.hash nat.hash)) - -(def: #export equivalence - (Equivalence Resolution) - (\ ..hash &equivalence)) - -## https://en.wikipedia.org/wiki/Display_resolution#Common_display_resolutions -(template [<name> <width> <height>] - [(def: #export <name> - Resolution - {#width <width> - #height <height>})] - - [svga 800 600] - [wsvga 1024 600] - [xga 1024 768] - [xga+ 1152 864] - [wxga/16:9 1280 720] - [wxga/5:3 1280 768] - [wxga/16:10 1280 800] - [sxga 1280 1024] - [wxga+ 1440 900] - [hd+ 1600 900] - [wsxga+ 1680 1050] - [fhd 1920 1080] - [wuxga 1920 1200] - [wqhd 2560 1440] - [uhd-4k 3840 2160] - ) diff --git a/stdlib/source/lux/world/program.lux b/stdlib/source/lux/world/program.lux deleted file mode 100644 index c64f9ffa7..000000000 --- a/stdlib/source/lux/world/program.lux +++ /dev/null @@ -1,450 +0,0 @@ -(.module: - [lux #* - ["@" target] - ["." ffi (#+ import:)] - [abstract - ["." monad (#+ Monad do)]] - [control - ["." function] - ["." io (#+ IO)] - ["." try (#+ Try)] - ["." exception (#+ exception:)] - [concurrency - ["." atom] - ["." promise (#+ Promise)]] - [parser - ["." environment (#+ Environment)]]] - [data - ["." bit ("#\." equivalence)] - ["." maybe] - ["." text - ["%" format (#+ format)]] - [collection - ["." array (#+ Array)] - ["." dictionary (#+ Dictionary)] - ["." list ("#\." functor)]]] - ["." macro - ["." template]] - [math - [number - ["i" int]]] - [type - abstract]] - [// - [file (#+ Path)] - [shell (#+ Exit)]]) - -(exception: #export (unknown_environment_variable {name Text}) - (exception.report - ["Name" (%.text name)])) - -(interface: #export (Program !) - (: (-> Any (! (List Text))) - available_variables) - (: (-> Text (! (Try Text))) - variable) - (: Path - home) - (: Path - directory) - (: (-> Exit (! Nothing)) - exit)) - -(def: #export (environment monad program) - (All [!] (-> (Monad !) (Program !) (! Environment))) - (do {! monad} - [variables (\ program available_variables []) - entries (monad.map ! (function (_ name) - (\ ! map (|>> [name]) (\ program variable name))) - variables)] - (wrap (|> entries - (list.all (function (_ [name value]) - (case value - (#try.Success value) - (#.Some [name value]) - - (#try.Failure _) - #.None))) - (dictionary.from_list text.hash))))) - -(`` (implementation: #export (async program) - (-> (Program IO) (Program Promise)) - - (~~ (template [<method>] - [(def: <method> - (\ program <method>))] - - [home] - [directory] - )) - - (~~ (template [<method>] - [(def: <method> - (|>> (\ program <method>) promise.future))] - - [available_variables] - [variable] - [exit] - )))) - -(def: #export (mock environment home directory) - (-> Environment Path Path (Program IO)) - (let [@dead? (atom.atom false)] - (implementation - (def: available_variables - (function.constant (io.io (dictionary.keys environment)))) - (def: (variable name) - (io.io (case (dictionary.get name environment) - (#.Some value) - (#try.Success value) - - #.None - (exception.throw ..unknown_environment_variable [name])))) - (def: home - home) - (def: directory - directory) - (def: (exit code) - (io.io (error! (%.int code))))))) - -## Do not trust the values of environment variables -## https://wiki.sei.cmu.edu/confluence/display/java/ENV02-J.+Do+not+trust+the+values+of+environment+variables - -(with_expansions [<jvm> (as_is (import: java/lang/String) - - (import: (java/util/Iterator a) - ["#::." - (hasNext [] boolean) - (next [] a)]) - - (import: (java/util/Set a) - ["#::." - (iterator [] (java/util/Iterator a))]) - - (import: (java/util/Map k v) - ["#::." - (keySet [] (java/util/Set k))]) - - (import: java/lang/System - ["#::." - (#static getenv [] (java/util/Map java/lang/String java/lang/String)) - (#static getenv #as resolveEnv [java/lang/String] #io #? java/lang/String) - (#static getProperty [java/lang/String] #? java/lang/String) - (#static exit [int] #io void)]) - - (def: (jvm\\consume iterator) - (All [a] (-> (java/util/Iterator a) (List a))) - (if (java/util/Iterator::hasNext iterator) - (#.Cons (java/util/Iterator::next iterator) - (jvm\\consume iterator)) - #.Nil)) - )] - (for {@.old (as_is <jvm>) - @.jvm (as_is <jvm>) - @.js (as_is (def: default_exit! - (-> Exit (IO Nothing)) - (|>> %.int error! io.io)) - - (import: NodeJs_Process - ["#::." - (exit [ffi.Number] #io Nothing) - (cwd [] #io Path)]) - - (def: (exit_node_js! code) - (-> Exit (IO Nothing)) - (case (ffi.constant ..NodeJs_Process [process]) - (#.Some process) - (NodeJs_Process::exit (i.frac code) process) - - #.None - (..default_exit! code))) - - (import: Browser_Window - ["#::." - (close [] Nothing)]) - - (import: Browser_Location - ["#::." - (reload [] Nothing)]) - - (def: (exit_browser! code) - (-> Exit (IO Nothing)) - (case [(ffi.constant ..Browser_Window [window]) - (ffi.constant ..Browser_Location [location])] - [(#.Some window) (#.Some location)] - (exec - (Browser_Window::close [] window) - (Browser_Location::reload [] location) - (..default_exit! code)) - - [(#.Some window) #.None] - (exec - (Browser_Window::close [] window) - (..default_exit! code)) - - [#.None (#.Some location)] - (exec - (Browser_Location::reload [] location) - (..default_exit! code)) - - [#.None #.None] - (..default_exit! code))) - - (import: Object - ["#::." - (#static entries [Object] (Array (Array ffi.String)))]) - - (import: NodeJs_OS - ["#::." - (homedir [] #io Path)]) - - (template [<name> <path>] - [(def: (<name> _) - (-> [] (Maybe (-> ffi.String Any))) - (ffi.constant (-> ffi.String Any) <path>))] - - [normal_require [require]] - [global_require [global require]] - [process_load [global process mainModule constructor _load]] - ) - - (def: (require _) - (-> [] (-> ffi.String Any)) - (case [(normal_require []) (global_require []) (process_load [])] - (^or [(#.Some require) _ _] - [_ (#.Some require) _] - [_ _ (#.Some require)]) - require - - _ - (undefined)))) - @.python (as_is (import: os - ["#::." - (#static getcwd [] #io ffi.String) - (#static _exit [ffi.Integer] #io Nothing)]) - - (import: os/path - ["#::." - (#static expanduser [ffi.String] #io ffi.String)]) - - (import: os/environ - ["#::." - (#static keys [] #io (Array ffi.String)) - (#static get [ffi.String] #io #? ffi.String)])) - @.lua (as_is (ffi.import: LuaFile - ["#::." - (read [ffi.String] #io #? ffi.String) - (close [] #io ffi.Boolean)]) - - (ffi.import: (io/popen [ffi.String] #io #try #? LuaFile)) - (ffi.import: (os/getenv [ffi.String] #io #? ffi.String)) - (ffi.import: (os/exit [ffi.Integer] #io Nothing)) - - (def: (run_command default command) - (-> Text Text (IO Text)) - (do {! io.monad} - [outcome (io/popen [command])] - (case outcome - (#try.Success outcome) - (case outcome - (#.Some file) - (do ! - [?output (LuaFile::read ["*l"] file) - _ (LuaFile::close [] file)] - (wrap (maybe.default default ?output))) - - #.None - (wrap default)) - - (#try.Failure _) - (wrap default))))) - @.ruby (as_is (ffi.import: Env #as RubyEnv - ["#::." - (#static keys [] (Array Text)) - (#static fetch [Text] #io #? Text)]) - - (ffi.import: "fileutils" FileUtils #as RubyFileUtils - ["#::." - (#static pwd [] #io Path)]) - - (ffi.import: Dir #as RubyDir - ["#::." - (#static home [] #io Path)]) - - (ffi.import: Kernel #as RubyKernel - ["#::." - (#static exit [Int] #io Nothing)])) - - ## @.php - ## (as_is (ffi.import: (exit [Int] #io Nothing)) - ## ## https://www.php.net/manual/en/function.exit.php - ## (ffi.import: (getcwd [] #io ffi.String)) - ## ## https://www.php.net/manual/en/function.getcwd.php - ## (ffi.import: (getenv #as getenv/1 [ffi.String] #io ffi.String)) - ## (ffi.import: (getenv #as getenv/0 [] #io (Array ffi.String))) - ## ## https://www.php.net/manual/en/function.getenv.php - ## ## https://www.php.net/manual/en/function.array-keys.php - ## (ffi.import: (array_keys [(Array ffi.String)] (Array ffi.String))) - ## ) - - ## @.scheme - ## (as_is (ffi.import: (exit [Int] #io Nothing)) - ## ## https://srfi.schemers.org/srfi-98/srfi-98.html - ## (abstract: Pair Any) - ## (abstract: PList Any) - ## (ffi.import: (get-environment-variables [] #io PList)) - ## (ffi.import: (car [Pair] Text)) - ## (ffi.import: (cdr [Pair] Text)) - ## (ffi.import: (car #as head [PList] Pair)) - ## (ffi.import: (cdr #as tail [PList] PList))) - } - (as_is))) - -(implementation: #export default - (Program IO) - - (def: (available_variables _) - (with_expansions [<jvm> (io.io (|> (java/lang/System::getenv) - java/util/Map::keySet - java/util/Set::iterator - ..jvm\\consume))] - (for {@.old <jvm> - @.jvm <jvm> - @.js (io.io (if ffi.on_node_js? - (case (ffi.constant Object [process env]) - (#.Some process/env) - (|> (Object::entries [process/env]) - array.to_list - (list\map (|>> (array.read 0) maybe.assume))) - - #.None - (list)) - (list))) - @.python (\ io.monad map array.to_list (os/environ::keys [])) - ## Lua offers no way to get all the environment variables available. - @.lua (io.io (list)) - @.ruby (|> (RubyEnv::keys []) - array.to_list - io.io) - ## @.php (do io.monad - ## [environment (..getenv/0 [])] - ## (wrap (|> environment - ## ..array_keys - ## array.to_list - ## (list\map (function (_ variable) - ## [variable ("php array read" (:as Nat variable) environment)])) - ## (dictionary.from_list text.hash)))) - ## @.scheme (do io.monad - ## [input (..get-environment-variables [])] - ## (loop [input input - ## output environment.empty] - ## (if ("scheme object nil?" input) - ## (wrap output) - ## (let [entry (..head input)] - ## (recur (..tail input) - ## (dictionary.put (..car entry) (..cdr entry) output)))))) - }))) - - (def: (variable name) - (template.let [(!fetch <method>) - [(do io.monad - [value (<method> name)] - (wrap (case value - (#.Some value) - (#try.Success value) - - #.None - (exception.throw ..unknown_environment_variable [name]))))]] - (with_expansions [<jvm> (!fetch java/lang/System::resolveEnv)] - (for {@.old <jvm> - @.jvm <jvm> - @.js (io.io (if ffi.on_node_js? - (case (do maybe.monad - [process/env (ffi.constant Object [process env])] - (array.read (:as Nat name) - (:as (Array Text) process/env))) - (#.Some value) - (#try.Success value) - - #.None - (exception.throw ..unknown_environment_variable [name])) - (exception.throw ..unknown_environment_variable [name]))) - @.python (!fetch os/environ::get) - @.lua (!fetch os/getenv) - @.ruby (!fetch RubyEnv::fetch) - })))) - - (def: home - (io.run - (with_expansions [<default> (io.io "~") - <jvm> (io.io (maybe.default "" (java/lang/System::getProperty "user.home")))] - (for {@.old <jvm> - @.jvm <jvm> - @.js (if ffi.on_node_js? - (|> (..require [] "os") - (:as NodeJs_OS) - (NodeJs_OS::homedir [])) - <default>) - @.python (os/path::expanduser ["~"]) - @.lua (..run_command "~" "echo ~") - @.ruby (RubyDir::home []) - ## @.php (do io.monad - ## [output (..getenv/1 ["HOME"])] - ## (wrap (if (bit\= false (:as Bit output)) - ## "~" - ## output))) - } - ## TODO: Replace dummy implementation. - <default>)))) - - (def: directory - (io.run - (with_expansions [<default> "." - <jvm> (io.io (maybe.default "" (java/lang/System::getProperty "user.dir")))] - (for {@.old <jvm> - @.jvm <jvm> - @.js (if ffi.on_node_js? - (case (ffi.constant ..NodeJs_Process [process]) - (#.Some process) - (NodeJs_Process::cwd [] process) - - #.None - (io.io <default>)) - (io.io <default>)) - @.python (os::getcwd []) - @.lua (do io.monad - [#let [default <default>] - on_windows (..run_command default "cd")] - (if (is? default on_windows) - (..run_command default "pwd") - (wrap on_windows))) - @.ruby (RubyFileUtils::pwd []) - ## @.php (do io.monad - ## [output (..getcwd [])] - ## (wrap (if (bit\= false (:as Bit output)) - ## "." - ## output))) - } - ## TODO: Replace dummy implementation. - (io.io <default>))))) - - (def: (exit code) - (with_expansions [<jvm> (do io.monad - [_ (java/lang/System::exit code)] - (wrap (undefined)))] - (for {@.old <jvm> - @.jvm <jvm> - @.js (cond ffi.on_node_js? - (..exit_node_js! code) - - ffi.on_browser? - (..exit_browser! code) - - ## else - (..default_exit! code)) - @.python (os::_exit [code]) - @.lua (os/exit [code]) - @.ruby (RubyKernel::exit [code]) - ## @.php (..exit [code]) - ## @.scheme (..exit [code]) - })))) diff --git a/stdlib/source/lux/world/service/authentication.lux b/stdlib/source/lux/world/service/authentication.lux deleted file mode 100644 index a9acda426..000000000 --- a/stdlib/source/lux/world/service/authentication.lux +++ /dev/null @@ -1,24 +0,0 @@ -(.module: - [lux #* - [control - [try (#+ Try)] - [security - [capability (#+ Capability)]]]]) - -(type: #export (Can-Register ! account secret value) - (Capability [account secret value] (! (Try Any)))) - -(type: #export (Can-Authenticate ! account secret value) - (Capability [account secret] (! (Try value)))) - -(type: #export (Can-Reset ! account secret) - (Capability [account secret] (! (Try Any)))) - -(type: #export (Can-Forget ! account) - (Capability [account] (! (Try Any)))) - -(type: #export (Service ! account secret value) - {#can-register (Can-Register ! account secret value) - #can-authenticate (Can-Authenticate ! account secret value) - #can-reset (Can-Reset ! account secret) - #can-forget (Can-Forget ! account)}) diff --git a/stdlib/source/lux/world/service/crud.lux b/stdlib/source/lux/world/service/crud.lux deleted file mode 100644 index 82fee2c75..000000000 --- a/stdlib/source/lux/world/service/crud.lux +++ /dev/null @@ -1,32 +0,0 @@ -(.module: - [lux #* - [control - ["." try (#+ Try)] - [security - ["!" capability (#+ capability:)]]] - [time - ["." instant (#+ Instant)]]]) - -(type: #export ID Nat) - -(type: #export Time - {#created Instant - #updated Instant}) - -(capability: #export (Can-Create ! entity) - (can-create [Instant entity] (! (Try ID)))) - -(capability: #export (Can-Retrieve ! entity) - (can-retrieve ID (! (Try [Time entity])))) - -(capability: #export (Can-Update ! entity) - (can-update [ID Instant entity] (! (Try Any)))) - -(capability: #export (Can-Delete ! entity) - (can-delete ID (! (Try Any)))) - -(type: #export (CRUD ! entity) - {#can-create (Can-Create ! entity) - #can-retrieve (Can-Retrieve ! entity) - #can-update (Can-Update ! entity) - #can-delete (Can-Delete ! entity)}) diff --git a/stdlib/source/lux/world/service/inventory.lux b/stdlib/source/lux/world/service/inventory.lux deleted file mode 100644 index dbdc93d6d..000000000 --- a/stdlib/source/lux/world/service/inventory.lux +++ /dev/null @@ -1,30 +0,0 @@ -(.module: - [lux #* - [control - [try (#+ Try)] - [security - ["!" capability (#+ capability:)]]]]) - -(type: #export ID Nat) - -(type: #export Ownership - {#owner ID - #property ID}) - -(capability: #export (Can-Own !) - (can-own Ownership (! (Try Any)))) - -(capability: #export (Can-Disown !) - (can-disown Ownership (! (Try Any)))) - -(capability: #export (Can-Check !) - (can-check Ownership (! (Try Bit)))) - -(capability: #export (Can-List-Property !) - (can-list-property ID (! (Try (List ID))))) - -(type: #export (Inventory !) - {#can-own (Can-Own !) - #can-disown (Can-Disown !) - #can-check (Can-Check !) - #can-list-property (Can-List-Property !)}) diff --git a/stdlib/source/lux/world/service/journal.lux b/stdlib/source/lux/world/service/journal.lux deleted file mode 100644 index f05195c4f..000000000 --- a/stdlib/source/lux/world/service/journal.lux +++ /dev/null @@ -1,50 +0,0 @@ -(.module: - [lux #* - [control - [equivalence (#+ Equivalence)] - [interval (#+ Interval)] - [try (#+ Try)] - [security - ["!" capability (#+ capability:)]]] - [data - ["." text ("#\." equivalence)]] - [time - ["." instant (#+ Instant) ("#\." equivalence)]]]) - -(type: #export (Entry a) - {#what a - #why Text - #how Text - #who Text - #where Text - #when Instant}) - -(type: #export Range - (Interval Instant)) - -(def: #export (range start end) - (-> Instant Instant Range) - (implementation - (def: &enum instant.enum) - (def: bottom start) - (def: top end))) - -(implementation: #export (equivalence (^open "_\.")) - (All [a] (-> (Equivalence a) (Equivalence (Entry a)))) - (def: (= reference sample) - (and (_\= (get@ #what reference) (get@ #what sample)) - (text\= (get@ #why reference) (get@ #why sample)) - (text\= (get@ #how reference) (get@ #how sample)) - (text\= (get@ #who reference) (get@ #who sample)) - (text\= (get@ #where reference) (get@ #where sample)) - (instant\= (get@ #when reference) (get@ #when sample))))) - -(capability: #export (Can-Write ! a) - (can-write (Entry a) (! (Try Any)))) - -(capability: #export (Can-Read ! a) - (can-read Range (! (Try (List (Entry a)))))) - -(type: #export (Journal ! a) - {#can-write (Can-Write ! a) - #can-read (Can-Read ! a)}) diff --git a/stdlib/source/lux/world/service/mail.lux b/stdlib/source/lux/world/service/mail.lux deleted file mode 100644 index eb49c6131..000000000 --- a/stdlib/source/lux/world/service/mail.lux +++ /dev/null @@ -1,18 +0,0 @@ -(.module: - [lux #* - [control - [try (#+ Try)] - [concurrency - [frp (#+ Channel)]] - [security - ["!" capability (#+ capability:)]]]]) - -(capability: #export (Can-Send ! address message) - (can-send [address message] (! (Try Any)))) - -(capability: #export (Can-Subscribe ! address message) - (can-subscribe [address] (! (Try (Channel message))))) - -(type: #export (Service ! address message) - {#can-send (Can-Send ! address message) - #can-subscribe (Can-Subscribe ! address message)}) diff --git a/stdlib/source/lux/world/shell.lux b/stdlib/source/lux/world/shell.lux deleted file mode 100644 index 254e813ad..000000000 --- a/stdlib/source/lux/world/shell.lux +++ /dev/null @@ -1,373 +0,0 @@ -(.module: - [lux #* - ["@" target] - ["jvm" ffi (#+ import:)] - [abstract - [monad (#+ do)]] - [control - ["." function] - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["." io (#+ IO)] - [security - ["?" policy (#+ Context Safety Safe)]] - [concurrency - ["." atom (#+ Atom)] - ["." promise (#+ Promise)]] - [parser - [environment (#+ Environment)]]] - [data - ["." product] - ["." text - ["%" format (#+ format)] - [encoding - ["." utf8]]] - [collection - ["." array (#+ Array)] - ["." list ("#\." fold functor)] - ["." dictionary]]] - [math - [number (#+ hex) - ["n" nat]]]] - [// - [file (#+ Path)]]) - -(type: #export Exit - Int) - -(template [<code> <name>] - [(def: #export <name> - Exit - <code>)] - - [+0 normal] - [+1 error] - ) - -(interface: #export (Process !) - (: (-> [] (! (Try Text))) - read) - (: (-> [] (! (Try Text))) - error) - (: (-> Text (! (Try Any))) - write) - (: (-> [] (! (Try Any))) - destroy) - (: (-> [] (! (Try Exit))) - await)) - -(def: (async_process process) - (-> (Process IO) (Process Promise)) - (`` (implementation - (~~ (template [<method>] - [(def: <method> - (|>> (\ process <method>) - promise.future))] - - [read] - [error] - [write] - [destroy] - [await] - ))))) - -(type: #export Command - Text) - -(type: #export Argument - Text) - -(interface: #export (Shell !) - (: (-> [Environment Path Command (List Argument)] (! (Try (Process !)))) - execute)) - -(def: #export (async shell) - (-> (Shell IO) (Shell Promise)) - (implementation - (def: (execute input) - (promise.future - (do (try.with io.monad) - [process (\ shell execute input)] - (wrap (..async_process process))))))) - -## https://en.wikipedia.org/wiki/Code_injection#Shell_injection -(interface: (Policy ?) - (: (-> Command (Safe Command ?)) - command) - (: (-> Argument (Safe Argument ?)) - argument) - (: (All [a] (-> (Safe a ?) a)) - value)) - -(type: (Sanitizer a) - (-> a a)) - -(type: Replacer - (-> Text Text)) - -(def: (replace bad replacer) - (-> Text Replacer (-> Text Text)) - (text.replace_all bad (replacer bad))) - -(def: sanitize_common_command - (-> Replacer (Sanitizer Command)) - (let [x0A (text.from_code (hex "0A")) - xFF (text.from_code (hex "FF"))] - (function (_ replacer) - (|>> (..replace x0A replacer) - (..replace xFF replacer) - (..replace "\" replacer) - (..replace "&" replacer) - (..replace "#" replacer) - (..replace ";" replacer) - (..replace "`" replacer) - (..replace "|" replacer) - (..replace "*" replacer) - (..replace "?" replacer) - (..replace "~" replacer) - (..replace "^" replacer) - (..replace "$" replacer) - (..replace "<" replacer) (..replace ">" replacer) - (..replace "(" replacer) (..replace ")" replacer) - (..replace "[" replacer) (..replace "]" replacer) - (..replace "{" replacer) (..replace "}" replacer))))) - -(def: (policy sanitize_command sanitize_argument) - (Ex [?] (-> (Sanitizer Command) (Sanitizer Argument) (Policy ?))) - (?.with_policy - (: (Context Safety Policy) - (function (_ (^open "?\.")) - (implementation - (def: command (|>> sanitize_command ?\can_upgrade)) - (def: argument (|>> sanitize_argument ?\can_upgrade)) - (def: value ?\can_downgrade)))))) - -(def: unix_policy - (let [replacer (: Replacer - (|>> (format "\"))) - sanitize_command (: (Sanitizer Command) - (..sanitize_common_command replacer)) - sanitize_argument (: (Sanitizer Argument) - (|>> (..replace "'" replacer) - (text.enclose' "'")))] - (..policy sanitize_command sanitize_argument))) - -(def: windows_policy - (let [replacer (: Replacer - (function.constant " ")) - sanitize_command (: (Sanitizer Command) - (|>> (..sanitize_common_command replacer) - (..replace "%" replacer) - (..replace "!" replacer))) - sanitize_argument (: (Sanitizer Argument) - (|>> (..replace "%" replacer) - (..replace "!" replacer) - (..replace text.double_quote replacer) - (text.enclose' text.double_quote)))] - (..policy sanitize_command sanitize_argument))) - -(with_expansions [<jvm> (as_is (import: java/lang/String - ["#::." - (toLowerCase [] java/lang/String)]) - - (def: (jvm::arguments_array arguments) - (-> (List Argument) (Array java/lang/String)) - (product.right - (list\fold (function (_ argument [idx output]) - [(inc idx) (jvm.array_write idx - (:as java/lang/String argument) - output)]) - [0 (jvm.array java/lang/String (list.size arguments))] - arguments))) - - (import: (java/util/Map k v) - ["#::." - (put [k v] v)]) - - (def: (jvm::load_environment input target) - (-> Environment - (java/util/Map java/lang/String java/lang/String) - (java/util/Map java/lang/String java/lang/String)) - (list\fold (function (_ [key value] target') - (exec (java/util/Map::put (:as java/lang/String key) - (:as java/lang/String value) - target') - target')) - target - (dictionary.entries input))) - - (import: java/io/Reader - ["#::." - (read [] #io #try int)]) - - (import: java/io/BufferedReader - ["#::." - (new [java/io/Reader]) - (readLine [] #io #try #? java/lang/String)]) - - (import: java/io/InputStream) - - (import: java/io/InputStreamReader - ["#::." - (new [java/io/InputStream])]) - - (import: java/io/OutputStream - ["#::." - (write [[byte]] #io #try void)]) - - (import: java/lang/Process - ["#::." - (getInputStream [] #io #try java/io/InputStream) - (getErrorStream [] #io #try java/io/InputStream) - (getOutputStream [] #io #try java/io/OutputStream) - (destroy [] #io #try void) - (waitFor [] #io #try int)]) - - (exception: #export no_more_output) - - (def: (default_process process) - (-> java/lang/Process (IO (Try (Process IO)))) - (do {! (try.with io.monad)} - [jvm_input (java/lang/Process::getInputStream process) - jvm_error (java/lang/Process::getErrorStream process) - jvm_output (java/lang/Process::getOutputStream process) - #let [jvm_input (|> jvm_input - java/io/InputStreamReader::new - java/io/BufferedReader::new) - jvm_error (|> jvm_error - java/io/InputStreamReader::new - java/io/BufferedReader::new)]] - (wrap (: (Process IO) - (`` (implementation - (~~ (template [<name> <stream>] - [(def: (<name> _) - (do ! - [output (java/io/BufferedReader::readLine <stream>)] - (case output - (#.Some output) - (wrap output) - - #.None - (\ io.monad wrap (exception.throw ..no_more_output [])))))] - - [read jvm_input] - [error jvm_error] - )) - (def: (write message) - (java/io/OutputStream::write (\ utf8.codec encode message) jvm_output)) - (~~ (template [<name> <method>] - [(def: (<name> _) - (<method> process))] - - [destroy java/lang/Process::destroy] - [await java/lang/Process::waitFor] - )))))))) - - (import: java/io/File - ["#::." - (new [java/lang/String])]) - - (import: java/lang/ProcessBuilder - ["#::." - (new [[java/lang/String]]) - (environment [] #try (java/util/Map java/lang/String java/lang/String)) - (directory [java/io/File] java/lang/ProcessBuilder) - (start [] #io #try java/lang/Process)]) - - (import: java/lang/System - ["#::." - (#static getProperty [java/lang/String] #io #try java/lang/String)]) - - ## https://en.wikipedia.org/wiki/Code_injection#Shell_injection - (def: windows? - (IO (Try Bit)) - (\ (try.with io.monad) map - (|>> java/lang/String::toLowerCase (text.starts_with? "windows")) - (java/lang/System::getProperty "os.name"))) - - (implementation: #export default - (Shell IO) - - (def: (execute [environment working_directory command arguments]) - (do {! (try.with io.monad)} - [#let [builder (|> (list& command arguments) - ..jvm::arguments_array - java/lang/ProcessBuilder::new - (java/lang/ProcessBuilder::directory (java/io/File::new working_directory)))] - _ (|> builder - java/lang/ProcessBuilder::environment - (\ try.functor map (..jvm::load_environment environment)) - (\ io.monad wrap)) - process (java/lang/ProcessBuilder::start builder)] - (..default_process process)))) - )] - (for {@.old (as_is <jvm>) - @.jvm (as_is <jvm>)} - (as_is))) - -(interface: #export (Mock s) - (: (-> s (Try [s Text])) - on_read) - (: (-> s (Try [s Text])) - on_error) - (: (-> Text s (Try s)) - on_write) - (: (-> s (Try s)) - on_destroy) - (: (-> s (Try [s Exit])) - on_await)) - -(`` (implementation: (mock_process mock state) - (All [s] (-> (Mock s) (Atom s) (Process IO))) - - (~~ (template [<name> <mock>] - [(def: (<name> _) - (do {! io.monad} - [|state| (atom.read state)] - (case (\ mock <mock> |state|) - (#try.Success [|state| output]) - (do ! - [_ (atom.write |state| state)] - (wrap (#try.Success output))) - - (#try.Failure error) - (wrap (#try.Failure error)))))] - - [read on_read] - [error on_error] - [await on_await] - )) - (def: (write message) - (do {! io.monad} - [|state| (atom.read state)] - (case (\ mock on_write message |state|) - (#try.Success |state|) - (do ! - [_ (atom.write |state| state)] - (wrap (#try.Success []))) - - (#try.Failure error) - (wrap (#try.Failure error))))) - (def: (destroy _) - (do {! io.monad} - [|state| (atom.read state)] - (case (\ mock on_destroy |state|) - (#try.Success |state|) - (do ! - [_ (atom.write |state| state)] - (wrap (#try.Success []))) - - (#try.Failure error) - (wrap (#try.Failure error))))))) - -(implementation: #export (mock mock init) - (All [s] - (-> (-> [Environment Path Command (List Argument)] - (Try (Mock s))) - s - (Shell IO))) - - (def: (execute input) - (io.io (do try.monad - [mock (mock input)] - (wrap (..mock_process mock (atom.atom init))))))) |