diff options
Diffstat (limited to 'source/lux')
37 files changed, 0 insertions, 3219 deletions
diff --git a/source/lux/codata/function.lux b/source/lux/codata/function.lux deleted file mode 100644 index 1b7336049..000000000 --- a/source/lux/codata/function.lux +++ /dev/null @@ -1,27 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux/control (monoid #as m))) - -## [Functions] -(def #export (const x y) - (All [a b] (-> a (-> b a))) - x) - -(def #export (flip f) - (All [a b c] - (-> (-> a b c) (-> b a c))) - (lambda [x y] (f y x))) - -(def #export (. f g) - (All [a b c] - (-> (-> b c) (-> a b) (-> a c))) - (lambda [x] (f (g x)))) - -## [Structures] -(defstruct #export Comp/Monoid (All [a] (m;Monoid (-> a a))) - (def unit id) - (def ++ .)) diff --git a/source/lux/codata/io.lux b/source/lux/codata/io.lux deleted file mode 100644 index 195aef616..000000000 --- a/source/lux/codata/io.lux +++ /dev/null @@ -1,42 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control (functor #as F) - (monad #as M)) - (data list))) - -## [Types] -(deftype #export (IO a) - (-> (,) a)) - -## [Syntax] -(defmacro #export (@io tokens state) - (case tokens - (\ (@list value)) - (let [blank (: AST [["" -1 -1] (#;SymbolS ["" ""])])] - (#;Right [state (@list (` (;_lux_lambda (~ blank) (~ blank) (~ value))))])) - - _ - (#;Left "Wrong syntax for @io"))) - -## [Structures] -(defstruct #export IO/Functor (F;Functor IO) - (def (map f ma) - (@io (f (ma []))))) - -(defstruct #export IO/Monad (M;Monad IO) - (def _functor IO/Functor) - - (def (wrap x) - (@io x)) - - (def (join mma) - (mma []))) - -## [Functions] -(def #export (run-io io) - (All [a] (-> (IO a) a)) - (io [])) diff --git a/source/lux/codata/lazy.lux b/source/lux/codata/lazy.lux deleted file mode 100644 index c0c79fc1a..000000000 --- a/source/lux/codata/lazy.lux +++ /dev/null @@ -1,56 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (meta ast) - (control (functor #as F #refer #all) - (monad #as M #refer #all)) - (data list)) - (.. function)) - -## [Types] -(deftype #export (Lazy a) - (All [b] - (-> (-> a b) b))) - -## [Syntax] -(defmacro #export (... tokens state) - (case tokens - (\ (@list value)) - (let [blank (symbol$ ["" ""])] - (#;Right [state (@list (` (;lambda [(~ blank)] ((~ blank) (~ value)))))])) - - _ - (#;Left "Wrong syntax for ..."))) - -## [Functions] -(def #export (! thunk) - (All [a] - (-> (Lazy a) a)) - (thunk id)) - -(def #export (call/cc f) - (All [a b c] (Lazy (-> a (Lazy b c)) (Lazy a c))) - (lambda [k] - (f (lambda [a _] - (k a)) - k))) - -(def #export (run-lazy l k) - (All [a z] (-> (Lazy a z) (-> a z) z)) - (l k)) - -## [Structs] -(defstruct #export Lazy/Functor (Functor Lazy) - (def (map f ma) - (lambda [k] (ma (. k f))))) - -(defstruct #export Lazy/Monad (Monad Lazy) - (def _functor Lazy/Functor) - - (def (wrap a) - (... a)) - - (def join !)) diff --git a/source/lux/codata/reader.lux b/source/lux/codata/reader.lux deleted file mode 100644 index e776f73ec..000000000 --- a/source/lux/codata/reader.lux +++ /dev/null @@ -1,30 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import (lux #refer (#exclude Reader)) - (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -(deftype #export (Reader r a) - (-> r a)) - -## [Structures] -(defstruct #export Reader/Functor (All [r] - (Functor (Reader r))) - (def (map f fa) - (lambda [env] - (f (fa env))))) - -(defstruct #export Reader/Monad (All [r] - (Monad (Reader r))) - (def _functor Reader/Functor) - - (def (wrap x) - (lambda [env] x)) - - (def (join mma) - (lambda [env] - (mma env env)))) diff --git a/source/lux/codata/state.lux b/source/lux/codata/state.lux deleted file mode 100644 index 311fce320..000000000 --- a/source/lux/codata/state.lux +++ /dev/null @@ -1,39 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -(deftype #export (State s a) - (-> s (, s a))) - -## [Structures] -(defstruct #export State/Functor (All [s] - (Functor (State s))) - (def (map f ma) - (lambda [state] - (let [[state' a] (ma state)] - [state' (f a)])))) - -(defstruct #export State/Monad (All [s] - (Monad (State s))) - (def _functor State/Functor) - - (def (wrap a) - (lambda [state] - [state a])) - - (def (join mma) - (lambda [state] - (let [[state' ma] (mma state)] - (ma state'))))) - -## [Functions] -(def #export (run-state state action) - (All [s a] (-> s (State s a) a)) - (let [[state' output] (action state)] - output)) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux deleted file mode 100644 index 86ce99761..000000000 --- a/source/lux/codata/stream.lux +++ /dev/null @@ -1,140 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control (functor #as F #refer #all) - (monad #as M #refer #all) - (comonad #as CM #refer #all)) - (meta lux - syntax) - (data (list #as l #refer (#only @list @list& List/Monad) #open ("" List/Fold)) - (number (int #open ("i" Int/Number Int/Ord))) - bool) - (codata (lazy #as L #refer #all)))) - -(open List/Monad "list:") - -## [Types] -(deftype #export (Stream a) - (Lazy (, a (Stream a)))) - -## [Utils] -(def (cycle' x xs init full) - (All [a] - (-> a (List a) a (List a) (Stream a))) - (case xs - #;Nil (cycle' init full init full) - (#;Cons x' xs') (... [x (cycle' x' xs' init full)]))) - -## [Functions] -(def #export (iterate f x) - (All [a] - (-> (-> a a) a (Stream a))) - (... [x (iterate f (f x))])) - -(def #export (repeat x) - (All [a] - (-> a (Stream a))) - (... [x (repeat x)])) - -(def #export (cycle xs) - (All [a] - (-> (List a) (Maybe (Stream a)))) - (case xs - #;Nil #;None - (#;Cons x xs') (#;Some (cycle' x xs' x xs')))) - -(do-template [<name> <return> <part>] - [(def #export (<name> s) - (All [a] (-> (Stream a) <return>)) - (let [[h t] (! s)] - <part>))] - - [head a h] - [tail (Stream a) t]) - -(def #export (@ idx s) - (All [a] (-> Int (Stream a) a)) - (let [[h t] (! s)] - (if (i> idx 0) - (@ (i+ -1 idx) t) - h))) - -(do-template [<taker> <dropper> <splitter> <det-type> <det-test> <det-step>] - [(def #export (<taker> det xs) - (All [a] - (-> <det-type> (Stream a) (List a))) - (let [[x xs'] (! xs)] - (if <det-test> - (@list& x (<taker> <det-step> xs')) - (@list)))) - - (def #export (<dropper> det xs) - (All [a] - (-> <det-type> (Stream a) (Stream a))) - (let [[x xs'] (! xs)] - (if <det-test> - (<dropper> <det-step> xs') - xs))) - - (def #export (<splitter> det xs) - (All [a] - (-> <det-type> (Stream a) (, (List a) (Stream a)))) - (let [[x xs'] (! xs)] - (if <det-test> - (let [[tail next] (<splitter> <det-step> xs')] - [(#;Cons [x tail]) next]) - [(@list) xs])))] - - [take-while drop-while split-with (-> a Bool) (det x) det] - [take drop split Int (i> det 0) (i+ -1 det)] - ) - -(def #export (unfold step init) - (All [a b] - (-> (-> a (, a b)) a (Stream b))) - (let [[next x] (step init)] - (... [x (unfold step next)]))) - -(def #export (filter p xs) - (All [a] (-> (-> a Bool) (Stream a) (Stream a))) - (let [[x xs'] (! xs)] - (if (p x) - (... [x (filter p xs')]) - (filter p xs')))) - -(def #export (partition p xs) - (All [a] (-> (-> a Bool) (Stream a) (, (Stream a) (Stream a)))) - [(filter p xs) (filter (comp p) xs)]) - -## [Structures] -(defstruct #export Stream/Functor (Functor Stream) - (def (map f fa) - (let [[h t] (! fa)] - (... [(f h) (map f t)])))) - -(defstruct #export Stream/CoMonad (CoMonad Stream) - (def _functor Stream/Functor) - (def unwrap head) - (def (split wa) - (let [[head tail] (! wa)] - (... [wa (split tail)])))) - -## [Pattern-matching] -(defsyntax #export (\stream& body [patterns (+^ id^)]) - (case (l;reverse patterns) - (\ (@list& last prevs)) - (do Lux/Monad - [prevs (map% Lux/Monad macro-expand-1 prevs) - g!s (gensym "s") - #let [body+ (foldL (lambda [inner outer] - (` (let [[(~ outer) (~ g!s)] (! (~ g!s))] - (~ inner)))) - (` (let [(~ last) (~ g!s)] (~ body))) - prevs)]] - (wrap (@list g!s body+))) - - _ - (fail "Wrong syntax for \\stream&"))) diff --git a/source/lux/control/bounded.lux b/source/lux/control/bounded.lux deleted file mode 100644 index b4c8a3e57..000000000 --- a/source/lux/control/bounded.lux +++ /dev/null @@ -1,14 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux) - -## Signatures -(defsig #export (Bounded a) - (: a - top) - - (: a - bottom)) diff --git a/source/lux/control/comonad.lux b/source/lux/control/comonad.lux deleted file mode 100644 index 2543f34da..000000000 --- a/source/lux/control/comonad.lux +++ /dev/null @@ -1,52 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (../functor #as F) - (lux/data/list #refer #all #open ("" List/Fold))) - -## [Signatures] -(defsig #export (CoMonad w) - (: (F;Functor w) - _functor) - (: (All [a] - (-> (w a) a)) - unwrap) - (: (All [a] - (-> (w a) (w (w a)))) - split)) - -## [Functions] -(def #export (extend w f ma) - (All [w a b] - (-> (CoMonad w) (-> (w a) b) (w a) (w b))) - (using w - (map f (split ma)))) - -## [Syntax] -(defmacro #export (be tokens state) - (case tokens - (#;Cons comonad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil))) - (let [g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])]) - g!split (: AST [["" -1 -1] (#;SymbolS ["" " split "])]) - body' (foldL (: (-> AST (, AST AST) AST) - (lambda [body' binding] - (let [[var value] binding] - (case var - [_ (#;TagS ["" "let"])] - (` (let (~ value) (~ body'))) - - _ - (` (|> (~ value) (~ g!split) ((~ g!map) (lambda [(~ var)] (~ body'))))) - )))) - body - (reverse (as-pairs bindings)))] - (#;Right [state (#;Cons (` (case (~ comonad) - {#_functor {#F;map (~ g!map)} #unwrap (~ (' unwrap)) #split (~ g!split)} - (~ body'))) - #;Nil)])) - - _ - (#;Left "Wrong syntax for be"))) diff --git a/source/lux/control/enum.lux b/source/lux/control/enum.lux deleted file mode 100644 index 4ce368e96..000000000 --- a/source/lux/control/enum.lux +++ /dev/null @@ -1,25 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux/control ord)) - -## [Signatures] -(defsig #export (Enum e) - (: (Ord e) _ord) - (: (-> e e) succ) - (: (-> e e) pred)) - -## [Functions] -(def (range' <= succ from to) - (All [a] (-> (-> a a Bool) (-> a a) a a (List a))) - (if (<= from to) - (#;Cons from (range' <= succ (succ from) to)) - #;Nil)) - -(def #export (range enum from to) - (All [a] (-> (Enum a) a a (List a))) - (using enum - (range' <= succ from to))) diff --git a/source/lux/control/eq.lux b/source/lux/control/eq.lux deleted file mode 100644 index d86df5757..000000000 --- a/source/lux/control/eq.lux +++ /dev/null @@ -1,11 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux) - -## [Signatures] -(defsig #export (Eq a) - (: (-> a a Bool) - =)) diff --git a/source/lux/control/fold.lux b/source/lux/control/fold.lux deleted file mode 100644 index d0aef1576..000000000 --- a/source/lux/control/fold.lux +++ /dev/null @@ -1,42 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control monoid - eq) - (data/number/int #open ("i" Int/Number Int/Eq)))) - -## [Signatures] -(defsig #export (Fold F) - (: (All [a b] - (-> (-> a b a) a (F b) a)) - foldL) - (: (All [a b] - (-> (-> b a a) a (F b) a)) - foldR)) - -## [Functions] -(def #export (foldM mon fold xs) - (All [F a] (-> (Monoid a) (Fold F) (F a) a)) - (using [mon fold] - (foldL ++ unit xs))) - -(def #export (size fold xs) - (All [F a] (-> (Fold F) (F a) Int)) - (using fold - (foldL (lambda [count _] (i+ 1 count)) - 0 - xs))) - -(def #export (member? eq fold x xs) - (All [F a] (-> (Eq a) (Fold F) a (F a) Bool)) - (using [eq fold] - (foldL (lambda [prev x'] (or prev (= x x'))) - false - xs))) - -(def #export (empty? fold xs) - (All [F a] (-> (Fold F) (F a) Bool)) - (i= 0 (size fold xs))) diff --git a/source/lux/control/functor.lux b/source/lux/control/functor.lux deleted file mode 100644 index 99c34a45c..000000000 --- a/source/lux/control/functor.lux +++ /dev/null @@ -1,12 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux) - -## Signatures -(defsig #export (Functor f) - (: (All [a b] - (-> (-> a b) (f a) (f b))) - map)) diff --git a/source/lux/control/hash.lux b/source/lux/control/hash.lux deleted file mode 100644 index 643c49e9d..000000000 --- a/source/lux/control/hash.lux +++ /dev/null @@ -1,11 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux) - -## [Signatures] -(defsig #export (Hash a) - (: (-> a Int) - hash)) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux deleted file mode 100644 index e5c5989cf..000000000 --- a/source/lux/control/monad.lux +++ /dev/null @@ -1,107 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (.. (functor #as F) - (monoid #as M))) - -## [Utils] -(def (foldL f init xs) - (All [a b] - (-> (-> a b a) a (List b) a)) - (case xs - #;Nil - init - - (#;Cons x xs') - (foldL f (f init x) xs'))) - -(def (reverse xs) - (All [a] - (-> (List a) (List a))) - (foldL (lambda [tail head] (#;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)) - -## [Signatures] -(defsig #export (Monad m) - (: (F;Functor m) - _functor) - (: (All [a] - (-> a (m a))) - wrap) - (: (All [a] - (-> (m (m a)) (m a))) - join)) - -## [Syntax] -(defmacro #export (do tokens state) - (case tokens - (#;Cons monad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil))) - (let [g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])]) - g!join (: AST [["" -1 -1] (#;SymbolS ["" " join "])]) - body' (foldL (: (-> AST (, AST AST) AST) - (lambda [body' binding] - (let [[var value] binding] - (case var - [_ (#;TagS ["" "let"])] - (` (let (~ value) (~ body'))) - - _ - (` (|> (~ value) ((~ g!map) (lambda [(~ var)] (~ body'))) (~ g!join))) - )))) - body - (reverse (as-pairs bindings)))] - (#;Right [state (#;Cons (` (case (~ monad) - {#_functor {#F;map (~ g!map)} #wrap (~ (' wrap)) #join (~ g!join)} - (~ body'))) - #;Nil)])) - - _ - (#;Left "Wrong syntax for do"))) - -## [Functions] -(def #export (bind m f ma) - (All [m a b] - (-> (Monad m) (-> a (m b)) (m a) (m b))) - (using m - (join (map f ma)))) - -(def #export (seq% monad xs) - (All [M a] - (-> (Monad M) (List (M a)) (M (List a)))) - (case xs - #;Nil - (:: monad (wrap #;Nil)) - - (#;Cons x xs') - (do monad - [_x x - _xs (seq% monad xs')] - (wrap (#;Cons _x _xs))) - )) - -(def #export (map% monad f xs) - (All [M a b] - (-> (Monad M) (-> a (M b)) (List a) (M (List b)))) - (case xs - #;Nil - (:: monad (wrap #;Nil)) - - (#;Cons x xs') - (do monad - [_x (f x) - _xs (map% monad f xs')] - (wrap (#;Cons _x _xs))) - )) diff --git a/source/lux/control/monoid.lux b/source/lux/control/monoid.lux deleted file mode 100644 index 447ab8225..000000000 --- a/source/lux/control/monoid.lux +++ /dev/null @@ -1,21 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux) - -## Signatures -(defsig #export (Monoid a) - (: a - unit) - (: (-> a a a) - ++)) - -## Constructors -(def #export (monoid$ unit ++) - (All [a] - (-> a (-> a a a) (Monoid a))) - (struct - (def unit unit) - (def ++ ++))) diff --git a/source/lux/control/number.lux b/source/lux/control/number.lux deleted file mode 100644 index b1bbec190..000000000 --- a/source/lux/control/number.lux +++ /dev/null @@ -1,25 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux/control (monoid #as m) - (eq #as E) - (ord #as O) - (bounded #as B) - (show #as S))) - -## [Signatures] -(defsig #export (Number n) - (do-template [<name>] - [(: (-> n n n) <name>)] - [+] [-] [*] [/] [%]) - - (do-template [<name>] - [(: (-> n n) <name>)] - [negate] [signum] [abs]) - - (: (-> Int n) - from-int) - ) diff --git a/source/lux/control/ord.lux b/source/lux/control/ord.lux deleted file mode 100644 index cb77e7042..000000000 --- a/source/lux/control/ord.lux +++ /dev/null @@ -1,41 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (../eq #as E)) - -## [Signatures] -(defsig #export (Ord a) - (: (E;Eq a) - _eq) - (do-template [<name>] - [(: (-> a a Bool) <name>)] - - [<] [<=] [>] [>=])) - -## [Constructors] -(def #export (ord$ eq < >) - (All [a] - (-> (E;Eq a) (-> a a Bool) (-> a a Bool) (Ord a))) - (struct - (def _eq eq) - (def < <) - (def (<= x y) - (or (< x y) - (:: eq (= x y)))) - (def > >) - (def (>= x y) - (or (> x y) - (:: eq (= x y)))))) - -## [Functions] -(do-template [<name> <op>] - [(def #export (<name> ord x y) - (All [a] - (-> (Ord a) a a a)) - (if (:: ord (<op> x y)) x y))] - - [max >] - [min <]) diff --git a/source/lux/control/show.lux b/source/lux/control/show.lux deleted file mode 100644 index 706819ec2..000000000 --- a/source/lux/control/show.lux +++ /dev/null @@ -1,11 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux) - -## [Signatures] -(defsig #export (Show a) - (: (-> a Text) - show)) diff --git a/source/lux/data/bool.lux b/source/lux/data/bool.lux deleted file mode 100644 index a3e28733b..000000000 --- a/source/lux/data/bool.lux +++ /dev/null @@ -1,36 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control (monoid #as m) - (eq #as E) - (show #as S)) - (codata function))) - -## [Structures] -(defstruct #export Bool/Eq (E;Eq Bool) - (def (= x y) - (if x - y - (not y)))) - -(defstruct #export Bool/Show (S;Show Bool) - (def (show x) - (if x "true" "false"))) - -(do-template [<name> <unit> <op>] - [(defstruct #export <name> (m;Monoid Bool) - (def unit <unit>) - (def (++ x y) - (<op> x y)))] - - [ Or/Monoid false or] - [And/Monoid true and] - ) - -## [Functions] -(def #export comp - (All [a] (-> (-> a Bool) (-> a Bool))) - (. not)) diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux deleted file mode 100644 index b7b4c6bda..000000000 --- a/source/lux/data/char.lux +++ /dev/null @@ -1,22 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux/control (eq #as E) - (show #as S)) - (.. (text #as T #open ("text:" Text/Monoid)))) - -## [Structures] -(defstruct #export Char/Eq (E;Eq Char) - (def (= x y) - (_jvm_ceq x y))) - -(defstruct #export Char/Show (S;Show Char) - (def (show x) - ($ text:++ "#\"" (_jvm_invokevirtual "java.lang.Object" "toString" [] x []) "\""))) - -(def #export (->text c) - (-> Char Text) - (_jvm_invokevirtual "java.lang.Object" "toString" [] c [])) diff --git a/source/lux/data/either.lux b/source/lux/data/either.lux deleted file mode 100644 index 38de1e2d1..000000000 --- a/source/lux/data/either.lux +++ /dev/null @@ -1,63 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control (functor #as F #refer #all) - (monad #as M #refer #all)) - (data (list #refer (#exclude partition))))) - -## [Types] -## (deftype (Either l r) -## (| (#;Left l) -## (#;Right r))) - -## [Functions] -(def #export (either f g e) - (All [a b c] (-> (-> a c) (-> b c) (Either a b) c)) - (case e - (#;Left x) (f x) - (#;Right x) (g x))) - -(do-template [<name> <side> <tag>] - [(def #export (<name> es) - (All [a b] (-> (List (Either a b)) (List <side>))) - (case es - #;Nil #;Nil - (#;Cons [(<tag> x) es']) (#;Cons [x (<name> es')]) - (#;Cons [_ es']) (<name> es')))] - - [lefts a #;Left] - [rights b #;Right] - ) - -(def #export (partition xs) - (All [a b] (-> (List (Either a b)) (, (List a) (List b)))) - (case xs - #;Nil - [#;Nil #;Nil] - - (#;Cons x xs') - (let [[lefts rights] (partition xs')] - (case x - (#;Left x') [(#;Cons x' lefts) rights] - (#;Right x') [lefts (#;Cons x' rights)])))) - -## [Structures] -(defstruct #export Error/Functor (All [a] (Functor (Either a))) - (def (map f ma) - (case ma - (#;Left msg) (#;Left msg) - (#;Right datum) (#;Right (f datum))))) - -(defstruct #export Error/Monad (All [a] (Monad (Either a))) - (def _functor Error/Functor) - - (def (wrap a) - (#;Right a)) - - (def (join mma) - (case mma - (#;Left msg) (#;Left msg) - (#;Right ma) ma))) diff --git a/source/lux/data/id.lux b/source/lux/data/id.lux deleted file mode 100644 index e4f2a775f..000000000 --- a/source/lux/data/id.lux +++ /dev/null @@ -1,27 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux/control (functor #as F #refer #all) - (monad #as M #refer #all) - (comonad #as CM #refer #all))) - -## [Types] -(deftype #export (Id a) - a) - -## [Structures] -(defstruct #export Id/Functor (Functor Id) - (def map id)) - -(defstruct #export Id/Monad (Monad Id) - (def _functor Id/Functor) - (def wrap id) - (def join id)) - -(defstruct #export Id/CoMonad (CoMonad Id) - (def _functor Id/Functor) - (def unwrap id) - (def split id)) diff --git a/source/lux/data/ident.lux b/source/lux/data/ident.lux deleted file mode 100644 index cb2353e43..000000000 --- a/source/lux/data/ident.lux +++ /dev/null @@ -1,33 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control (eq #as E) - (show #as S)) - (data (text #open ("text:" Text/Monoid Text/Eq))))) - -## [Types] -## (deftype Ident -## (, Text Text)) - -## [Functions] -(do-template [<name> <side>] - [(def #export (<name> [left right]) - (-> Ident Text) - <side>)] - - [module left] - [name right] - ) - -## [Structures] -(defstruct #export Ident/Eq (E;Eq Ident) - (def (= [xmodule xname] [ymodule yname]) - (and (text:= xmodule ymodule) - (text:= xname yname)))) - -(defstruct #export Ident/Show (S;Show Ident) - (def (show [module name]) - ($ text:++ module ";" name))) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux deleted file mode 100644 index 6bf050228..000000000 --- a/source/lux/data/list.lux +++ /dev/null @@ -1,344 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control (monoid #as m #refer #all) - (functor #as F #refer #all) - (monad #as M #refer #all) - (eq #as E) - (ord #as O) - (fold #as f)) - (data (number (int #open ("i:" Int/Number Int/Ord Int/Show))) - bool - (text #open ("text:" Text/Monoid)) - tuple) - codata/function)) - -## [Types] -## (deftype (List a) -## (| #Nil -## (#Cons (, a (List a))))) - -## [Functions] -(defstruct #export List/Fold (f;Fold List) - (def (foldL f init xs) - (case xs - #;Nil - init - - (#;Cons [x xs']) - (foldL f (f init x) xs'))) - - (def (foldR f init xs) - (case xs - #;Nil - init - - (#;Cons [x xs']) - (f x (foldR f init xs'))))) - -(open List/Fold) - -(def #export (fold mon xs) - (All [a] - (-> (m;Monoid a) (List a) a)) - (using mon - (foldL ++ unit xs))) - -(def #export (reverse xs) - (All [a] - (-> (List a) (List a))) - (foldL (lambda [tail head] (#;Cons [head tail])) - #;Nil - xs)) - -(def #export (filter p xs) - (All [a] - (-> (-> a Bool) (List a) (List a))) - (case xs - #;Nil - #;Nil - - (#;Cons [x xs']) - (if (p x) - (#;Cons [x (filter p xs')]) - (filter p xs')))) - -(def #export (partition p xs) - (All [a] (-> (-> a Bool) (List a) (, (List a) (List a)))) - [(filter p xs) (filter (comp p) xs)]) - -(def #export (as-pairs xs) - (All [a] (-> (List a) (List (, a a)))) - (case xs - (\ (#;Cons [x1 (#;Cons [x2 xs'])])) - (#;Cons [[x1 x2] (as-pairs xs')]) - - _ - #;Nil)) - -(do-template [<name> <then> <else>] - [(def #export (<name> n xs) - (All [a] - (-> Int (List a) (List a))) - (if (i:> n 0) - (case xs - #;Nil - #;Nil - - (#;Cons [x xs']) - <then>) - <else>))] - - [take (#;Cons [x (take (i:+ -1 n) xs')]) #;Nil] - [drop (drop (i:+ -1 n) xs') xs] - ) - -(do-template [<name> <then> <else>] - [(def #export (<name> p xs) - (All [a] - (-> (-> a Bool) (List a) (List a))) - (case xs - #;Nil - #;Nil - - (#;Cons [x xs']) - (if (p x) - <then> - <else>)))] - - [take-while (#;Cons [x (take-while p xs')]) #;Nil] - [drop-while (drop-while p xs') xs] - ) - -(def #export (split n xs) - (All [a] - (-> Int (List a) (, (List a) (List a)))) - (if (i:> n 0) - (case xs - #;Nil - [#;Nil #;Nil] - - (#;Cons [x xs']) - (let [[tail rest] (split (i:+ -1 n) xs')] - [(#;Cons [x tail]) rest])) - [#;Nil xs])) - -(def (split-with' p ys xs) - (All [a] - (-> (-> a Bool) (List a) (List a) (, (List a) (List a)))) - (case xs - #;Nil - [ys xs] - - (#;Cons [x xs']) - (if (p x) - (split-with' p (#;Cons [x ys]) xs') - [ys xs]))) - -(def #export (split-with p xs) - (All [a] - (-> (-> a Bool) (List a) (, (List a) (List a)))) - (let [[ys' xs'] (split-with' p #;Nil xs)] - [(reverse ys') xs'])) - -(def #export (repeat n x) - (All [a] - (-> Int a (List a))) - (if (i:> n 0) - (#;Cons [x (repeat (i:+ -1 n) x)]) - #;Nil)) - -(def #export (iterate f x) - (All [a] - (-> (-> a (Maybe a)) a (List a))) - (case (f x) - (#;Some x') - (#;Cons [x (iterate f x')]) - - #;None - (#;Cons [x #;Nil]))) - -(def #export (some f xs) - (All [a b] - (-> (-> a (Maybe b)) (List a) (Maybe b))) - (case xs - #;Nil - #;None - - (#;Cons [x xs']) - (case (f x) - #;None - (some f xs') - - (#;Some y) - (#;Some y)))) - -(def #export (interpose sep xs) - (All [a] - (-> a (List a) (List a))) - (case xs - #;Nil - xs - - (#;Cons [x #;Nil]) - xs - - (#;Cons [x xs']) - (#;Cons [x (#;Cons [sep (interpose sep xs')])]))) - -(def #export (size list) - (All [a] (-> (List a) Int)) - (foldL (lambda [acc _] (i:+ 1 acc)) 0 list)) - -(do-template [<name> <init> <op>] - [(def #export (<name> p xs) - (All [a] - (-> (-> a Bool) (List a) Bool)) - (foldL (lambda [_1 _2] (<op> _1 (p _2))) <init> xs))] - - [every? true and] - [any? false or]) - -(def #export (@ i xs) - (All [a] - (-> Int (List a) (Maybe a))) - (case xs - #;Nil - #;None - - (#;Cons [x xs']) - (if (i:= 0 i) - (#;Some x) - (@ (i:+ -1 i) xs')))) - -## [Syntax] -(defmacro #export (@list xs state) - (#;Right state (#;Cons (foldL (: (-> AST AST AST) - (lambda [tail head] (` (#;Cons (~ head) (~ tail))))) - (` #;Nil) - (reverse xs)) - #;Nil))) - -(defmacro #export (@list& xs state) - (case (reverse xs) - (#;Cons last init) - (#;Right state (@list (foldL (: (-> AST AST AST) - (lambda [tail head] (` (#;Cons (~ head) (~ tail))))) - last - init))) - - _ - (#;Left "Wrong syntax for @list&"))) - -## [Structures] -(defstruct #export (List/Eq eq) - (All [a] (-> (E;Eq a) (E;Eq (List a)))) - (def (= xs ys) - (case [xs ys] - [#;Nil #;Nil] - true - - [(#;Cons x xs') (#;Cons y ys')] - (and (:: eq (= x y)) - (= xs' ys')) - - [_ _] - false - ))) - -(defstruct #export List/Monoid (All [a] - (Monoid (List a))) - (def unit #;Nil) - (def (++ xs ys) - (case xs - #;Nil ys - (#;Cons x xs') (#;Cons x (++ xs' ys))))) - -(defstruct #export List/Functor (Functor List) - (def (map f ma) - (case ma - #;Nil #;Nil - (#;Cons a ma') (#;Cons (f a) (map f ma'))))) - -(defstruct #export List/Monad (Monad List) - (def _functor List/Functor) - - (def (wrap a) - (#;Cons a #;Nil)) - - (def (join mma) - (using List/Monoid - (foldL ++ unit mma)))) - -## [Functions] -(def #export (sort ord xs) - (All [a] (-> (O;Ord a) (List a) (List a))) - (case xs - #;Nil - #;Nil - - (#;Cons x xs') - (using ord - (let [pre (filter (>= x) xs') - post (filter (< x) xs') - ++ (:: List/Monoid ++)] - ($ ++ (sort ord pre) (@list x) (sort ord post)))))) - -## [Syntax] -(def (symbol$ name) - (-> Text AST) - [["" -1 -1] (#;SymbolS "" name)]) - -(def (range from to) - (-> Int Int (List Int)) - (if (i:<= from to) - (@list& from (range (i:+ 1 from) to)) - (@list))) - -(defmacro #export (zip tokens state) - (case tokens - (\ (@list [_ (#;IntS num-lists)])) - (if (i:> num-lists 0) - (using List/Functor - (let [indices (range 0 (i:- num-lists 1)) - type-vars (: (List AST) (map (. symbol$ i:show) indices)) - zip-type (` (All [(~@ type-vars)] - (-> (~@ (map (: (-> AST AST) (lambda [var] (` (List (~ var))))) - type-vars)) - (List (, (~@ type-vars)))))) - vars+lists (map (lambda [idx] - (let [base (text:++ "_" (i:show idx))] - [(symbol$ base) - (symbol$ (text:++ base "s"))])) - indices) - pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs)))) - vars+lists))]) - g!step (symbol$ "\tstep\t") - g!blank (symbol$ "\t_\t") - list-vars (map second vars+lists) - code (` (: (~ zip-type) - (lambda (~ g!step) [(~@ list-vars)] - (case [(~@ list-vars)] - (~ pattern) - (#;Cons [(~@ (map first vars+lists))] - ((~ g!step) (~@ list-vars))) - - (~ g!blank) - #;Nil))))] - (#;Right [state (@list code)]))) - (#;Left "Can't zip no lists.")) - - _ - (#;Left "Wrong syntax for zip"))) - -(def #export zip2 (zip 2)) -(def #export zip3 (zip 3)) - -(def #export (empty? xs) - (All [a] (-> (List a) Bool)) - (case xs - #;Nil true - _ false)) diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux deleted file mode 100644 index 1303270a7..000000000 --- a/source/lux/data/maybe.lux +++ /dev/null @@ -1,46 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control (monoid #as m #refer #all) - (functor #as F #refer #all) - (monad #as M #refer #all)))) - -## [Types] -## (deftype (Maybe a) -## (| #;None -## (#;Some a))) - -## [Structures] -(defstruct #export Maybe/Monoid (All [a] (Monoid (Maybe a))) - (def unit #;None) - (def (++ xs ys) - (case xs - #;None ys - (#;Some x) (#;Some x)))) - -(defstruct #export Maybe/Functor (Functor Maybe) - (def (map f ma) - (case ma - #;None #;None - (#;Some a) (#;Some (f a))))) - -(defstruct #export Maybe/Monad (Monad Maybe) - (def _functor Maybe/Functor) - - (def (wrap x) - (#;Some x)) - - (def (join mma) - (case mma - #;None #;None - (#;Some xs) xs))) - -## [Functions] -(def #export (? else maybe) - (All [a] (-> a (Maybe a) a)) - (case maybe - (#;Some x) x - _ else)) diff --git a/source/lux/data/number/int.lux b/source/lux/data/number/int.lux deleted file mode 100644 index 1e71b8a5a..000000000 --- a/source/lux/data/number/int.lux +++ /dev/null @@ -1,93 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux/control (number #as N) - (monoid #as m) - (eq #as E) - (ord #as O) - (enum #as EN) - (bounded #as B) - (show #as S))) - -## [Structures] -## Number -(do-template [<name> <type> <+> <-> <*> </> <%> <=> <<> <from> <0> <1> <-1>] - [(defstruct #export <name> (N;Number <type>) - (def (+ x y) (<+> x y)) - (def (- x y) (<-> x y)) - (def (* x y) (<*> x y)) - (def (/ x y) (</> x y)) - (def (% x y) (<%> x y)) - (def (from-int x) - (<from> x)) - (def (negate x) - (<*> <-1> x)) - (def (abs x) - (if (<<> x <0>) - (<*> <-1> x) - x)) - (def (signum x) - (cond (<=> x <0>) <0> - (<<> x <0>) <-1> - ## else - <1>)) - )] - - [ Int/Number Int _jvm_ladd _jvm_lsub _jvm_lmul _jvm_ldiv _jvm_lrem _jvm_leq _jvm_llt id 0 1 -1]) - -## Eq -(defstruct #export Int/Eq (E;Eq Int) - (def (= x y) (_jvm_leq x y))) - -## Ord -(do-template [<name> <type> <eq> <=> <lt> <gt>] - [(defstruct #export <name> (O;Ord <type>) - (def _eq <eq>) - (def (< x y) (<lt> x y)) - (def (<= x y) - (or (<lt> x y) - (<=> x y))) - (def (> x y) (<gt> x y)) - (def (>= x y) - (or (<gt> x y) - (<=> x y))))] - - [ Int/Ord Int Int/Eq _jvm_leq _jvm_llt _jvm_lgt]) - -## Enum -(defstruct #export Int/Enum (EN;Enum Int) - (def _ord Int/Ord) - (def succ (lambda [n] (:: Int/Number (+ n 1)))) - (def pred (lambda [n] (:: Int/Number (- n 1))))) - -## Bounded -(do-template [<name> <type> <top> <bottom>] - [(defstruct #export <name> (B;Bounded <type>) - (def top <top>) - (def bottom <bottom>))] - - [ Int/Bounded Int (_jvm_getstatic "java.lang.Long" "MAX_VALUE") (_jvm_getstatic "java.lang.Long" "MIN_VALUE")]) - -## Monoid -(do-template [<name> <type> <unit> <++>] - [(defstruct #export <name> (m;Monoid <type>) - (def unit <unit>) - (def (++ x y) (<++> x y)))] - - [ IntAdd/Monoid Int 0 _jvm_ladd] - [ IntMul/Monoid Int 1 _jvm_lmul] - [ IntMax/Monoid Int (:: Int/Bounded bottom) (O;max Int/Ord)] - [ IntMin/Monoid Int (:: Int/Bounded top) (O;min Int/Ord)] - ) - -## Show -(do-template [<name> <type> <body>] - [(defstruct #export <name> (S;Show <type>) - (def (show x) - <body>))] - - [ Int/Show Int (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] - ) diff --git a/source/lux/data/number/real.lux b/source/lux/data/number/real.lux deleted file mode 100644 index 7d5243385..000000000 --- a/source/lux/data/number/real.lux +++ /dev/null @@ -1,93 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux/control (number #as N) - (monoid #as m) - (eq #as E) - (ord #as O) - (enum #as EN) - (bounded #as B) - (show #as S))) - -## [Structures] -## Number -(do-template [<name> <type> <+> <-> <*> </> <%> <=> <<> <from> <0> <1> <-1>] - [(defstruct #export <name> (N;Number <type>) - (def (+ x y) (<+> x y)) - (def (- x y) (<-> x y)) - (def (* x y) (<*> x y)) - (def (/ x y) (</> x y)) - (def (% x y) (<%> x y)) - (def (from-int x) - (<from> x)) - (def (negate x) - (<*> <-1> x)) - (def (abs x) - (if (<<> x <0>) - (<*> <-1> x) - x)) - (def (signum x) - (cond (<=> x <0>) <0> - (<<> x <0>) <-1> - ## else - <1>)) - )] - - [Real/Number Real _jvm_dadd _jvm_dsub _jvm_dmul _jvm_ddiv _jvm_drem _jvm_deq _jvm_dlt _jvm_l2d 0.0 1.0 -1.0]) - -## Eq -(defstruct #export Real/Eq (E;Eq Real) - (def (= x y) (_jvm_deq x y))) - -## Ord -(do-template [<name> <type> <eq> <=> <lt> <gt>] - [(defstruct #export <name> (O;Ord <type>) - (def _eq <eq>) - (def (< x y) (<lt> x y)) - (def (<= x y) - (or (<lt> x y) - (<=> x y))) - (def (> x y) (<gt> x y)) - (def (>= x y) - (or (<gt> x y) - (<=> x y))))] - - [Real/Ord Real Real/Eq _jvm_deq _jvm_dlt _jvm_dgt]) - -## Enum -(defstruct Real/Enum (EN;Enum Real) - (def _ord Real/Ord) - (def succ (lambda [n] (:: Real/Number (+ n 1.0)))) - (def pred (lambda [n] (:: Real/Number (- n 1.0))))) - -## Bounded -(do-template [<name> <type> <top> <bottom>] - [(defstruct #export <name> (B;Bounded <type>) - (def top <top>) - (def bottom <bottom>))] - - [Real/Bounded Real (_jvm_getstatic "java.lang.Double" "MAX_VALUE") (_jvm_getstatic "java.lang.Double" "MIN_VALUE")]) - -## Monoid -(do-template [<name> <type> <unit> <++>] - [(defstruct #export <name> (m;Monoid <type>) - (def unit <unit>) - (def (++ x y) (<++> x y)))] - - [RealAdd/Monoid Real 0.0 _jvm_dadd] - [RealMul/Monoid Real 1.0 _jvm_dmul] - [RealMax/Monoid Real (:: Real/Bounded bottom) (O;max Real/Ord)] - [RealMin/Monoid Real (:: Real/Bounded top) (O;min Real/Ord)] - ) - -## Show -(do-template [<name> <type> <body>] - [(defstruct #export <name> (S;Show <type>) - (def (show x) - <body>))] - - [Real/Show Real (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] - ) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux deleted file mode 100644 index af2de51ff..000000000 --- a/source/lux/data/text.lux +++ /dev/null @@ -1,195 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control (monoid #as m) - (eq #as E) - (ord #as O) - (show #as S) - (monad #as M #refer #all)) - (data (number (int #open ("i" Int/Number Int/Ord))) - maybe))) - -## [Functions] -(def #export (size x) - (-> Text Int) - (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "length" [] - x []))) - -(def #export (@ idx x) - (-> Int Text (Maybe Char)) - (if (and (i< idx (size x)) - (i>= idx 0)) - (#;Some (_jvm_invokevirtual "java.lang.String" "charAt" ["int"] - x [(_jvm_l2i idx)])) - #;None)) - -(def #export (contains? x y) - (-> Text Text Bool) - (_jvm_invokevirtual "java.lang.String" "contains" ["java.lang.CharSequence"] - x [y])) - -(do-template [<name> <method>] - [(def #export (<name> x) - (-> Text Text) - (_jvm_invokevirtual "java.lang.String" <method> [] - x []))] - [lower-case "toLowerCase"] - [upper-case "toUpperCase"] - [trim "trim"] - ) - -(def #export (sub' from to x) - (-> Int Int Text (Maybe Text)) - (if (and (i< from to) - (i>= from 0) - (i<= to (size x))) - (#;Some (_jvm_invokevirtual "java.lang.String" "substring" ["int" "int"] - x [(_jvm_l2i from) (_jvm_l2i to)])) - #;None)) - -(def #export (sub from x) - (-> Int Text (Maybe Text)) - (sub' from (size x) x)) - -(def #export (split at x) - (-> Int Text (Maybe (, Text Text))) - (if (and (i< at (size x)) - (i>= at 0)) - (let [pre (_jvm_invokevirtual "java.lang.String" "substring" ["int" "int"] - x [(_jvm_l2i 0) (_jvm_l2i at)]) - post (_jvm_invokevirtual "java.lang.String" "substring" ["int"] - x [(_jvm_l2i at)])] - (#;Some [pre post])) - #;None)) - -(def #export (replace pattern value template) - (-> Text Text Text Text) - (_jvm_invokevirtual "java.lang.String" "replace" ["java.lang.CharSequence" "java.lang.CharSequence"] - template [pattern value])) - -(do-template [<common> <general> <method>] - [(def #export (<general> pattern from x) - (-> Text Int Text (Maybe Int)) - (if (and (i< from (size x)) (i>= from 0)) - (case (_jvm_i2l (_jvm_invokevirtual "java.lang.String" <method> ["java.lang.String" "int"] - x [pattern (_jvm_l2i from)])) - -1 #;None - idx (#;Some idx)) - #;None)) - - (def #export (<common> pattern x) - (-> Text Text (Maybe Int)) - (case (_jvm_i2l (_jvm_invokevirtual "java.lang.String" <method> ["java.lang.String"] - x [pattern])) - -1 #;None - idx (#;Some idx)))] - - [index-of index-of' "indexOf"] - [last-index-of last-index-of' "lastIndexOf"] - ) - -(def #export (starts-with? prefix x) - (-> Text Text Bool) - (case (index-of prefix x) - (#;Some 0) - true - - _ - false)) - -(def #export (ends-with? postfix x) - (-> Text Text Bool) - (case (last-index-of postfix x) - (#;Some n) - (i= (i+ n (size postfix)) - (size x)) - - _ - false)) - -## [Structures] -(defstruct #export Text/Eq (E;Eq Text) - (def (= x y) - (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"] - x [y]))) - -(defstruct #export Text/Ord (O;Ord Text) - (def _eq Text/Eq) - - (do-template [<name> <op>] - [(def (<name> x y) - (<op> (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "compareTo" ["java.lang.String"] - x [y])) - 0))] - - [< i<] - [<= i<=] - [> i>] - [>= i>=])) - -(defstruct #export Text/Show (S;Show Text) - (def show id)) - -(defstruct #export Text/Monoid (m;Monoid Text) - (def unit "") - (def (++ x y) - (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"] - x [y]))) - -## [Syntax] -(def (extract-var template) - (-> Text (Maybe (, Text Text Text))) - (do Maybe/Monad - [pre-idx (index-of "#{" template) - [pre in] (split pre-idx template) - [_ in] (split 2 in) - post-idx (index-of "}" in) - [var post] (split post-idx in) - #let [[_ post] (? ["" ""] (split 1 post))]] - (wrap [pre var post]))) - -(do-template [<name> <type> <tag>] - [(def (<name> value) - (-> <type> AST) - [["" -1 -1] (<tag> value)])] - - [text$ Text #;TextS] - [symbol$ Ident #;SymbolS]) - -(def (unravel-template template) - (-> Text (List AST)) - (case (extract-var template) - (#;Some [pre var post]) - (#;Cons (text$ pre) - (#;Cons (symbol$ ["" var]) - (unravel-template post))) - - #;None - (#;Cons (text$ template) #;Nil))) - -(defmacro #export (<> tokens state) - (case tokens - (#;Cons [_ (#;TextS template)] #;Nil) - (let [++ (symbol$ ["" ""])] - (#;Right state (#;Cons (` (;let [(~ ++) (get@ #m;++ Text/Monoid)] - (;$ (~ ++) (~@ (unravel-template template))))) - #;Nil))) - - _ - (#;Left "Wrong syntax for <>"))) - -(def #export (split-lines text) - (-> Text (List Text)) - (case (: (Maybe (List Text)) - (do Maybe/Monad - [idx (index-of "\n" text) - [head post] (split (inc idx) text)] - (wrap (#;Cons head (split-lines post))))) - #;None - (#;Cons text #;Nil) - - (#;Some xs) - xs)) diff --git a/source/lux/data/tuple.lux b/source/lux/data/tuple.lux deleted file mode 100644 index 6eef74670..000000000 --- a/source/lux/data/tuple.lux +++ /dev/null @@ -1,35 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux) - -## [Functions] -(do-template [<name> <type> <output>] - [(def #export (<name> xy) - (All [a b] (-> (, a b) <type>)) - (let [[x y] xy] - <output>))] - - [first a x] - [second b y]) - -(def #export (curry f) - (All [a b c] - (-> (-> (, a b) c) - (-> a b c))) - (lambda [x y] - (f [x y]))) - -(def #export (uncurry f) - (All [a b c] - (-> (-> a b c) (-> (, a b) c))) - (lambda [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])) diff --git a/source/lux/data/writer.lux b/source/lux/data/writer.lux deleted file mode 100644 index 3bf99c1ad..000000000 --- a/source/lux/data/writer.lux +++ /dev/null @@ -1,31 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux/control (monoid #as m #refer #all) - (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -(deftype #export (Writer l a) - (, l a)) - -## [Structures] -(defstruct #export Writer/Functor (All [l] - (Functor (Writer l))) - (def (map f fa) - (let [[log datum] fa] - [log (f datum)]))) - -(defstruct #export (Writer/Monad mon) (All [l] - (-> (Monoid l) (Monad (Writer l)))) - (def _functor Writer/Functor) - - (def (wrap x) - [(:: mon unit) x]) - - (def (join mma) - (let [[log1 [log2 a]] mma] - [(:: mon (++ log1 log2)) a]))) diff --git a/source/lux/host/io.lux b/source/lux/host/io.lux deleted file mode 100644 index 220f089a2..000000000 --- a/source/lux/host/io.lux +++ /dev/null @@ -1,60 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (data (list #refer #all #open ("" List/Fold))) - (codata io) - (meta ast - syntax - lux) - control/monad) - (.. jvm)) - -## [Functions] -(do-template [<name> <method> <type> <class>] - [(def #export (<name> x) - (-> <type> (IO (,))) - (@io (_jvm_invokevirtual "java.io.PrintStream" <method> [<class>] - (_jvm_getstatic "java.lang.System" "out") [x])))] - - [write-char "print" Char "char"] - [write "print" Text "java.lang.String"] - [write-line "println" Text "java.lang.String"] - ) - -(do-template [<name> <type> <op>] - [(def #export <name> - (IO (Maybe <type>)) - (let [in (_jvm_getstatic "java.lang.System" "in") - reader (_jvm_new "java.io.InputStreamReader" ["java.io.InputStream"] [in]) - buff-reader (_jvm_new "java.io.BufferedReader" ["java.io.Reader"] [reader])] - (@io (let [output (: (Either Text <type>) (try <op>)) - _close (: (Either Text (,)) (try (_jvm_invokeinterface "java.io.Closeable" "close" [] buff-reader [])))] - (case [output _close] - (\or [(#;Left _) _] [_ (#;Left _)]) #;None - [(#;Right input) (#;Right _)] (#;Some input))))))] - - [read-char Char (_jvm_i2c (_jvm_invokevirtual "java.io.BufferedReader" "read" [] buff-reader []))] - [read-line Text (_jvm_invokevirtual "java.io.BufferedReader" "readLine" [] buff-reader [])] - ) - -## [Syntax] -(def simple-bindings^ - (Parser (List (, Text AST))) - (tuple^ (*^ (&^ local-symbol^ id^)))) - -(defsyntax #export (with-open [bindings simple-bindings^] body) - (do Lux/Monad - [g!output (gensym "output") - #let [code (foldL (: (-> AST (, Text AST) AST) - (lambda [body [res-name res-value]] - (let [g!res-name (symbol$ ["" res-name])] - (` (let [(~ g!res-name) (~ res-value) - (~ g!output) (~ body)] - (exec (;_jvm_invokeinterface "java.io.Closeable" "close" [] (~ g!res-name) []) - (~ g!output))))))) - body - (reverse bindings))]] - (wrap (@list code)))) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux deleted file mode 100644 index 737c1731d..000000000 --- a/source/lux/host/jvm.lux +++ /dev/null @@ -1,377 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control (monoid #as m) - (functor #as F) - (monad #as M #refer (#only do seq%)) - (enum #as E)) - (data (list #refer #all #open ("" List/Functor List/Fold)) - (number/int #refer #all #open ("i:" Int/Ord Int/Number)) - maybe - tuple - (text #open ("text:" Text/Monoid))) - (meta lux - ast - syntax))) - -(open List/Monad "list:") - -## [Types] -(defsyntax #export (Array [dimensions (?^ nat^)] type) - (emit (@list (foldL (lambda [inner _] (` (#;DataT "#Array" (@list (~ inner))))) - type - (repeat (? 1 dimensions) []))))) - -## [Utils] -## Types -(deftype StackFrame (^ java.lang.StackTraceElement)) -(deftype StackTrace (Array StackFrame)) - -(deftype Modifier Text) -(deftype JvmType Text) - -(deftype AnnotationParam - (, Text AST)) - -(deftype Annotation - (& #ann-name Text - #ann-params (List AnnotationParam))) - -(deftype MemberDecl - (& #member-name Text - #member-modifiers (List Modifier) - #member-anns (List Annotation))) - -(deftype FieldDecl - JvmType) - -(deftype MethodDecl - (& #method-inputs (List JvmType) - #method-output JvmType - #method-exs (List JvmType))) - -(deftype ArgDecl - (& #arg-name Text - #arg-type JvmType)) - -(deftype MethodDef - (& #method-vars (List ArgDecl) - #return-type JvmType - #return-body AST - #throws-exs (List JvmType))) - -(deftype ExpectedInput - (& #opt-input? Bool - #input-type JvmType)) - -(deftype ExpectedOutput - (& #ex-output? Bool - #opt-output? Bool - #output-type JvmType)) - -## Functions -(def (prepare-args args) - (-> (List ExpectedInput) (Lux (, (List AST) (List AST) (List AST) (List Text)))) - (do Lux/Monad - [vars (seq% Lux/Monad (repeat (size args) (gensym ""))) - #let [pairings (map (: (-> (, (, Bool Text) AST) (, AST (List AST))) - (lambda [[[opt? arg-class] var]] - (if opt? - [(` (Maybe (^ (~ (symbol$ ["" arg-class]))))) - (@list var (` (: (^ (~ (symbol$ ["" arg-class]))) - (case (~ var) - (#;Some (~ var)) (~ var) - #;None ;_jvm_null))))] - [(` (^ (~ (symbol$ ["" arg-class])))) - (@list)]))) - (zip2 args vars)) - var-types (map first pairings) - var-rebinds (map second pairings) - arg-classes (map second args)]] - (wrap [vars var-types (list:join var-rebinds) arg-classes]))) - -(def (class->type class) - (-> JvmType AST) - (case class - "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)) - "void" (` ;Unit) - _ - (` (^ (~ (symbol$ ["" class])))))) - -## Parsers -(def annotation-params^ - (Parser (List AnnotationParam)) - (record^ (*^ (tuple^ (&^ local-tag^ id^))))) - -(def annotation^ - (Parser Annotation) - (form^ (&^ local-symbol^ - annotation-params^))) - -(def annotations^' - (Parser (List Annotation)) - (do Parser/Monad - [_ (tag!^ ["" "ann"])] - (tuple^ (*^ annotation^)))) - -(def annotations^ - (Parser (List Annotation)) - (do Parser/Monad - [anns?? (?^ annotations^')] - (wrap (? (@list) anns??)))) - -(def member-decl^ - (Parser MemberDecl) - (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - anns annotations^] - (wrap [name modifiers anns]))) - -(def throws-decl'^ - (Parser (List JvmType)) - (do Parser/Monad - [_ (tag!^ ["" "throws"])] - (tuple^ (*^ local-symbol^)))) - -(def throws-decl^ - (Parser (List JvmType)) - (do Parser/Monad - [exs? (?^ throws-decl'^)] - (wrap (? (@list) exs?)))) - -(def method-decl'^ - (Parser MethodDecl) - (do Parser/Monad - [inputs (tuple^ (*^ local-symbol^)) - outputs local-symbol^ - exs throws-decl^] - (wrap [inputs outputs exs]))) - -(def method-decl^ - (Parser (, MemberDecl MethodDecl)) - (form^ (&^ member-decl^ - method-decl'^))) - -(def field-decl^ - (Parser (, MemberDecl FieldDecl)) - (form^ (&^ member-decl^ - local-symbol^))) - -(def arg-decl^ - (Parser ArgDecl) - (form^ (&^ local-symbol^ local-symbol^))) - -(def method-def'^ - (Parser MethodDef) - (do Parser/Monad - [inputs (tuple^ (*^ arg-decl^)) - output local-symbol^ - exs throws-decl^ - body id^] - (wrap [inputs output body exs]))) - -(def method-def^ - (Parser (, MemberDecl MethodDef)) - (form^ (&^ member-decl^ - method-def'^))) - -(def exp-input^ - (Parser ExpectedInput) - (&^ (tag?^ ["" "?"]) - local-symbol^)) - -(def exp-output^ - (Parser ExpectedOutput) - (do Parser/Monad - [ex? (tag?^ ["" "!"]) - opt? (tag?^ ["" "?"]) - return local-symbol^] - (wrap [ex? opt? return]))) - -## Generators -(def (gen-annotation-param [name value]) - (-> AnnotationParam (, AST AST)) - [(text$ name) value]) - -(def (gen-annotation [name params]) - (-> Annotation AST) - (` ((~ (text$ name)) - (~ (record$ (map gen-annotation-param params)))))) - -(def (gen-method-decl [[name modifiers anns] [inputs output exs]]) - (-> (, MemberDecl MethodDecl) AST) - (` ((~ (text$ name)) - [(~@ (map text$ modifiers))] - [(~@ (map gen-annotation anns))] - [(~@ (map text$ exs))] - [(~@ (map text$ inputs))] - (~ (text$ output))))) - -(def (gen-field-decl [[name modifiers anns] class]) - (-> (, MemberDecl FieldDecl) AST) - (` ((~ (text$ name)) - [(~@ (map text$ modifiers))] - [(~@ (map gen-annotation anns))] - (~ (text$ class)) - ))) - -(def (gen-arg-decl [name type]) - (-> ArgDecl AST) - (form$ (@list (symbol$ ["" name]) (text$ type)))) - -(def (gen-method-def [[name modifiers anns] [inputs output body exs]]) - (-> (, MemberDecl MethodDef) AST) - (` ((~ (text$ name)) - [(~@ (map text$ modifiers))] - [(~@ (map gen-annotation anns))] - [(~@ (map text$ exs))] - [(~@ (map gen-arg-decl inputs))] - (~ (text$ output)) - (~ body)))) - -(def (gen-expected-output [ex? opt? output] body) - (-> ExpectedOutput AST (, AST AST)) - (let [type (class->type output) - [body type] (if opt? - [(` (;;??? (~ body))) - (` (Maybe (~ type)))] - [body type]) - [body type] (if ex? - [(` (;;try (~ body))) - (` (Either Text (~ type)))] - [body type])] - [body type])) - -## [Functions] -(def (stack-trace->text trace) - (-> StackTrace Text) - (let [size (_jvm_arraylength trace) - idxs (E;range Int/Enum 0 (i:+ -1 size))] - (|> idxs - (map (: (-> Int Text) - (lambda [idx] - (_jvm_invokevirtual "java.lang.Object" "toString" [] (_jvm_aaload trace idx) [])))) - (interpose "\n") - (foldL text:++ "") - ))) - -(def (get-stack-trace t) - (-> (^ java.lang.Throwable) StackTrace) - (_jvm_invokevirtual "java.lang.Throwable" "getStackTrace" [] t [])) - -(def #export (throwable->text t) - (-> (^ java.lang.Throwable) Text) - ($ text:++ - (_jvm_invokevirtual "java.lang.Object" "toString" [] t []) - "\n" - (|> t get-stack-trace stack-trace->text))) - -## [Syntax] -(defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] - [annotations annotations^] - [fields (*^ field-decl^)] - [methods (*^ method-def^)]) - (emit (@list (` (;_jvm_class (~ (text$ name)) (~ (text$ super)) - [(~@ (map text$ interfaces))] - [(~@ (map gen-annotation annotations))] - [(~@ (map gen-field-decl fields))] - [(~@ (map gen-method-def methods))]))))) - -(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] - [annotations annotations^] - [members (*^ method-decl^)]) - (emit (@list (` (;_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))] - [(~@ (map gen-annotation annotations))] - (~@ (map gen-method-decl members))))))) - -(defsyntax #export (object [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] - [methods (*^ method-def^)]) - (emit (@list (` (;_jvm_anon-class (~ (text$ super)) - [(~@ (map text$ interfaces))] - [(~@ (map gen-method-def methods))]))))) - -(defsyntax #export (program [args symbol^] body) - (emit (@list (` (;_jvm_program (~ (symbol$ args)) - (~ body)))))) - -(defsyntax #export (??? expr) - (do Lux/Monad - [g!temp (gensym "")] - (wrap (@list (` (let [(~ g!temp) (~ expr)] - (if (;_jvm_null? (~ g!temp)) - #;None - (#;Some (~ g!temp))))))))) - -(defsyntax #export (try expr) - (emit (@list (` (;_jvm_try (#;Right (~ expr)) - (~ (' (_jvm_catch "java.lang.Exception" e - (#;Left (throwable->text e)))))))))) - -(defsyntax #export (instance? [class local-symbol^] obj) - (emit (@list (` (;_jvm_instanceof (~ (text$ class)) (~ obj)))))) - -(defsyntax #export (locking lock body) - (do Lux/Monad - [g!lock (gensym "") - g!body (gensym "") - g!_ (gensym "")] - (emit (@list (` (let [(~ g!lock) (~ lock) - (~ g!_) (;_jvm_monitorenter (~ g!lock)) - (~ g!body) (~ body) - (~ g!_) (;_jvm_monitorexit (~ g!lock))] - (~ g!body))))) - )) - -(defsyntax #export (null? obj) - (emit (@list (` (;_jvm_null? (~ obj)))))) - -(defsyntax #export (new$ [class local-symbol^] [args (tuple^ (*^ exp-input^))] [unsafe? (tag?^ ["" "unsafe"])]) - (do Lux/Monad - [[vars var-types var-rebinds arg-classes] (prepare-args args) - #let [new-expr (` (;_jvm_new (~ (text$ class)) [(~@ (map text$ arg-classes))] [(~@ vars)])) - return-type (class->type class) - [new-expr return-type] (if unsafe? - [(` (try (~ new-expr))) (` (Either Text (~ return-type)))] - [new-expr return-type])]] - (wrap (@list (` (: (-> (, (~@ var-types)) (~ return-type)) - (lambda [[(~@ vars)]] - (let [(~@ var-rebinds)] - (~ new-expr))))))))) - -(do-template [<name> <op> <use-self?>] - [(defsyntax #export (<name> [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ exp-input^))] - [expected-output exp-output^] [unsafe? (tag?^ ["" "unsafe"])]) - (do Lux/Monad - [[vars var-types var-rebinds arg-classes] (prepare-args args) - g!self (gensym "self") - #let [included-self (: (List AST) - (if <use-self?> - (@list g!self) - (@list))) - [body return-type] (gen-expected-output expected-output - (` (<op> (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] (~@ included-self) [(~@ vars)]))) - [body return-type] (if unsafe? - [(` (try (~ body))) (` (Either Text (~ return-type)))] - [body return-type])]] - (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class]))) (~ return-type)) - (lambda [[(~@ vars)] (~@ included-self)] - (let [(~@ var-rebinds)] - (~ body))))))) - ))] - - [invoke-virtual$ ;_jvm_invokevirtual true] - [invoke-interface$ ;_jvm_invokeinterface true] - [invoke-special$ ;_jvm_invokespecial true] - [invoke-static$ ;_jvm_invokestatic false] - ) diff --git a/source/lux/math.lux b/source/lux/math.lux deleted file mode 100644 index a60ce512c..000000000 --- a/source/lux/math.lux +++ /dev/null @@ -1,80 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux/data/number/int #open ("i:" Int/Number))) - -## [Constants] -(do-template [<name> <value>] - [(def #export <name> - Real - (_jvm_getstatic "java.lang.Math" <value>))] - - [e "E"] - [pi "PI"] - ) - -## [Functions] -(do-template [<name> <method>] - [(def #export (<name> n) - (-> Real Real) - (_jvm_invokestatic "java.lang.Math" <method> ["double"] [n]))] - - [cos "cos"] - [sin "sin"] - [tan "tan"] - - [acos "acos"] - [asin "asin"] - [atan "atan"] - - [cosh "cosh"] - [sinh "sinh"] - [tanh "tanh"] - - [ceil "ceil"] - [floor "floor"] - - [exp "exp"] - [log "log"] - - [cbrt "cbrt"] - [sqrt "sqrt"] - - [->degrees "toDegrees"] - [->radians "toRadians"] - ) - -(def #export (round n) - (-> Real Int) - (_jvm_invokestatic "java.lang.Math" "round" ["double"] [n])) - -(do-template [<name> <method>] - [(def #export (<name> x y) - (-> Real Real Real) - (_jvm_invokestatic "java.lang.Math" <method> ["double" "double"] [x y]))] - - [atan2 "atan2"] - [pow "pow"] - ) - -(def (gcd' a b) - (-> Int Int Int) - (case b - 0 a - _ (gcd' b (i:% a b)))) - -(def #export (gcd a b) - (-> Int Int Int) - (gcd' (i:abs a) (i:abs b))) - -(def #export (lcm x y) - (-> Int Int Int) - (case [x y] - (\or [_ 0] [0 _]) - 0 - - _ - (i:abs (i:* (i:/ x (gcd x y)) y)))) diff --git a/source/lux/meta/ast.lux b/source/lux/meta/ast.lux deleted file mode 100644 index a9bc8b588..000000000 --- a/source/lux/meta/ast.lux +++ /dev/null @@ -1,113 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control (show #as S #refer #all) - (eq #as E #refer #all)) - (data bool - (number int - real) - char - (text #refer (#only Text/Show Text/Eq) #open ("text:" Text/Monoid)) - ident - (list #refer #all #open ("" List/Functor List/Fold)) - ))) - -## [Types] -## (deftype (AST' w) -## (| (#;BoolS Bool) -## (#;IntS Int) -## (#;RealS Real) -## (#;CharS Char) -## (#;TextS Text) -## (#;SymbolS Text Text) -## (#;TagS Text Text) -## (#;FormS (List (w (AST' w)))) -## (#;TupleS (List (w (AST' w)))) -## (#;RecordS (List (, (w (AST' w)) (w (AST' w))))))) - -## (deftype AST -## (Meta Cursor (AST' (Meta Cursor)))) - -## [Utils] -(def _cursor Cursor ["" -1 -1]) - -## [Functions] -(do-template [<name> <type> <tag>] - [(def #export (<name> x) - (-> <type> AST) - [_cursor (<tag> x)])] - - [bool$ Bool #;BoolS] - [int$ Int #;IntS] - [real$ Real #;RealS] - [char$ Char #;CharS] - [text$ Text #;TextS] - [symbol$ Ident #;SymbolS] - [tag$ Ident #;TagS] - [form$ (List AST) #;FormS] - [tuple$ (List AST) #;TupleS] - [record$ (List (, AST AST)) #;RecordS] - ) - -## [Structures] -(defstruct #export AST/Show (Show AST) - (def (show ast) - (case ast - (\template [<tag> <struct>] - [[_ (<tag> value)] - (:: <struct> (show value))]) - [[#;BoolS Bool/Show] - [#;IntS Int/Show] - [#;RealS Real/Show] - [#;CharS Char/Show] - [#;TextS Text/Show]] - - (\template [<tag> <prefix>] - [[_ (<tag> ident)] - (text:++ <prefix> (:: Ident/Show (show ident)))]) - [[#;SymbolS ""] [#;TagS "#"]] - - (\template [<tag> <open> <close>] - [[_ (<tag> members)] - ($ text:++ <open> (|> members (map show) (interpose "") (foldL text:++ text:unit)) <close>)]) - [[#;FormS "(" ")"] [#;TupleS "[" "]"]] - - [_ (#;RecordS pairs)] - ($ text:++ "{" (|> pairs (map (lambda [[left right]] ($ text:++ (show left) " " (show right)))) (interpose "") (foldL text:++ text:unit)) "}") - ))) - -(defstruct #export AST/Eq (Eq AST) - (def (= x y) - (case [x y] - (\template [<tag> <struct>] - [[[_ (<tag> x')] [_ (<tag> y')]] - (:: <struct> (= x' y'))]) - [[#;BoolS Bool/Eq] - [#;IntS Int/Eq] - [#;RealS Real/Eq] - [#;CharS Char/Eq] - [#;TextS Text/Eq] - [#;SymbolS Ident/Eq] - [#;TagS Ident/Eq]] - - (\template [<tag>] - [[[_ (<tag> xs')] [_ (<tag> ys')]] - (and (:: Int/Eq (= (size xs') (size ys'))) - (foldL (lambda [old [x' y']] - (and old (= x' y'))) - true - (zip2 xs' ys')))]) - [[#;FormS] [#;TupleS]] - - [[_ (#;RecordS xs')] [_ (#;RecordS ys')]] - (and (:: Int/Eq (= (size xs') (size ys'))) - (foldL (lambda [old [[xl' xr'] [yl' yr']]] - (and old (= xl' yl') (= xr' yr'))) - true - (zip2 xs' ys'))) - - _ - false))) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux deleted file mode 100644 index b6ff09f59..000000000 --- a/source/lux/meta/lux.lux +++ /dev/null @@ -1,366 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (.. ast) - (lux/control (monoid #as m) - (functor #as F) - (monad #as M #refer (#only do)) - (show #as S)) - (lux/data (list #refer #all #open ("list:" List/Monoid List/Functor)) - (text #as T #open ("text:" Text/Monoid Text/Eq)) - (number/int #as I #open ("i" Int/Number)) - (tuple #as t) - ident)) - -## [Types] -## (deftype (Lux a) -## (-> Compiler (Either Text (, Compiler a)))) - -## [Utils] -(def (ident->text ident) - (-> Ident Text) - (let [[pre post] ident] - ($ text:++ pre ";" post))) - -## [Structures] -(defstruct #export Lux/Functor (F;Functor Lux) - (def (map f fa) - (lambda [state] - (case (fa state) - (#;Left msg) - (#;Left msg) - - (#;Right [state' a]) - (#;Right [state' (f a)]))))) - -(defstruct #export Lux/Monad (M;Monad Lux) - (def _functor Lux/Functor) - (def (wrap x) - (lambda [state] - (#;Right [state x]))) - (def (join mma) - (lambda [state] - (case (mma state) - (#;Left msg) - (#;Left msg) - - (#;Right [state' ma]) - (ma state'))))) - -## Functions -(def #export (get-module-name state) - (Lux Text) - (case (reverse (get@ #;envs state)) - #;Nil - (#;Left "Can't get the module name without a module!") - - (#;Cons [env _]) - (#;Right [state (get@ #;name env)]))) - -(def (get k plist) - (All [a] - (-> Text (List (, Text a)) (Maybe a))) - (case plist - #;Nil - #;None - - (#;Cons [k' v] plist') - (if (text:= k k') - (#;Some v) - (get k plist')))) - -(def (find-macro' modules current-module module name) - (-> (List (, Text (Module Compiler))) Text Text Text - (Maybe Macro)) - (case (get module modules) - (#;Some $module) - (case (|> (: (Module Compiler) $module) (get@ #;defs) (get name)) - (#;Some gdef) - (case (: Definition gdef) - [exported? (#;MacroD macro')] - (if (or exported? (text:= module current-module)) - (#;Some macro') - #;None) - - [_ (#;AliasD [r-module r-name])] - (find-macro' modules current-module r-module r-name) - - _ - #;None) - - _ - #;None) - - _ - #;None)) - -(def #export (find-macro ident) - (-> Ident (Lux (Maybe Macro))) - (do Lux/Monad - [current-module get-module-name] - (let [[module name] ident] - (: (Lux (Maybe Macro)) - (lambda [state] - (#;Right [state (find-macro' (get@ #;modules state) current-module module name)])))))) - -(def #export (normalize ident) - (-> Ident (Lux Ident)) - (case ident - ["" name] - (do Lux/Monad - [module-name get-module-name] - (wrap [module-name name])) - - _ - (:: Lux/Monad (wrap ident)))) - -(def #export (macro-expand syntax) - (-> AST (Lux (List AST))) - (case syntax - [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))] - (do Lux/Monad - [macro-name' (normalize macro-name) - ?macro (find-macro macro-name')] - (case ?macro - (#;Some macro) - (do Lux/Monad - [expansion (macro args) - expansion' (M;map% Lux/Monad macro-expand expansion)] - (wrap (:: List/Monad (join expansion')))) - - #;None - (:: Lux/Monad (wrap (@list syntax))))) - - _ - (:: Lux/Monad (wrap (@list syntax))))) - -(def #export (macro-expand-all syntax) - (-> AST (Lux (List AST))) - (case syntax - [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))] - (do Lux/Monad - [macro-name' (normalize macro-name) - ?macro (find-macro macro-name')] - (case ?macro - (#;Some macro) - (do Lux/Monad - [expansion (macro args) - expansion' (M;map% Lux/Monad macro-expand-all expansion)] - (wrap (:: List/Monad (join expansion')))) - - #;None - (do Lux/Monad - [parts' (M;map% Lux/Monad macro-expand-all (@list& (symbol$ macro-name) args))] - (wrap (@list (form$ (:: List/Monad (join parts')))))))) - - [_ (#;FormS (#;Cons [harg targs]))] - (do Lux/Monad - [harg+ (macro-expand-all harg) - targs+ (M;map% Lux/Monad macro-expand-all targs)] - (wrap (@list (form$ (list:++ harg+ (:: List/Monad (join (: (List (List AST)) targs+)))))))) - - [_ (#;TupleS members)] - (do Lux/Monad - [members' (M;map% Lux/Monad macro-expand-all members)] - (wrap (@list (tuple$ (:: List/Monad (join members')))))) - - _ - (:: Lux/Monad (wrap (@list syntax))))) - -(def #export (gensym prefix state) - (-> Text (Lux AST)) - (#;Right [(update@ #;seed (i+ 1) state) - (symbol$ ["" ($ text:++ "__gensym__" prefix (:: I;Int/Show (show (get@ #;seed state))))])])) - -(def #export (emit datum) - (All [a] - (-> a (Lux a))) - (lambda [state] - (#;Right [state datum]))) - -(def #export (fail msg) - (All [a] - (-> Text (Lux a))) - (lambda [_] - (#;Left msg))) - -(def #export (macro-expand-1 token) - (-> AST (Lux AST)) - (do Lux/Monad - [token+ (macro-expand token)] - (case token+ - (\ (@list token')) - (wrap token') - - _ - (fail "Macro expanded to more than 1 element.")))) - -(def #export (module-exists? module state) - (-> Text (Lux Bool)) - (#;Right [state (case (get module (get@ #;modules state)) - (#;Some _) - true - - #;None - false)])) - -(def #export (exported-defs module state) - (-> Text (Lux (List Text))) - (case (get module (get@ #;modules state)) - (#;Some =module) - (using List/Monad - (#;Right [state (join (map (: (-> (, Text Definition) - (List Text)) - (lambda [gdef] - (let [[name [export? _]] gdef] - (if export? - (@list name) - (@list))))) - (get@ #;defs =module)))])) - - #;None - (#;Left ($ text:++ "Unknown module: " module)))) - -(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 #export (find-in-env name state) - (-> Text Compiler (Maybe Type)) - (case state - {#;source source #;modules modules - #;envs envs #;type-vars types #;host host - #;seed seed #;eval? eval? #;expected expected - #;cursor cursor} - (some (: (-> (Env Text (Meta (, Type Cursor) Analysis)) (Maybe Type)) - (lambda [env] - (case env - {#;name _ #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure {#;counter _ #;mappings closure}} - (try-both (some (: (-> (, Text (Meta (, Type Cursor) Analysis)) (Maybe Type)) - (lambda [binding] - (let [[bname [[type _] _]] binding] - (if (text:= name bname) - (#;Some type) - #;None))))) - locals - closure)))) - envs))) - -(def (find-in-defs' name state) - (-> Ident Compiler (Maybe Definition)) - (let [[v-prefix v-name] name - {#;source source #;modules modules - #;envs envs #;type-vars types #;host host - #;seed seed #;eval? eval? #;expected expected - #;cursor cursor} state] - (case (get v-prefix modules) - #;None - #;None - - (#;Some {#;defs defs #;module-aliases _ #;imports _ #;tags _ #;types _}) - (case (get v-name defs) - #;None - #;None - - (#;Some def) - (case def - [_ (#;AliasD name')] (find-in-defs' name' state) - _ (#;Some def) - ))) - )) - -(def #export (find-in-defs name state) - (-> Ident Compiler (Maybe Type)) - (case (find-in-defs' name state) - (#;Some [_ def-data]) - (case def-data - (#;ValueD [type value]) (#;Some type) - (#;MacroD _) (#;Some Macro) - (#;TypeD _) (#;Some Type) - _ #;None) - - #;None - #;None)) - -(def #export (find-var-type name) - (-> Ident (Lux Type)) - (do Lux/Monad - [#let [[_ _name] name] - name' (normalize name)] - (: (Lux Type) - (lambda [state] - (case (find-in-env _name state) - (#;Some struct-type) - (#;Right [state struct-type]) - - _ - (case (find-in-defs name' state) - (#;Some struct-type) - (#;Right [state struct-type]) - - _ - (#;Left ($ text:++ "Unknown var: " (ident->text name))))))) - )) - -(def #export (find-type name) - (-> Ident (Lux Type)) - (do Lux/Monad - [name' (normalize name)] - (: (Lux Type) - (lambda [state] - (case (find-in-defs' name' state) - (#;Some def-data) - (case def-data - [_ (#;TypeD type)] (#;Right [state type]) - _ (#;Left ($ text:++ "Definition is not a type: " (ident->text name)))) - - _ - (#;Left ($ text:++ "Unknown var: " (ident->text name)))))) - )) - -(def #export (defs module-name state) - (-> Text (Lux (List (, Text Definition)))) - (case (get module-name (get@ #;modules state)) - #;None (#;Left ($ text:++ "Unknown module: " module-name)) - (#;Some module) (#;Right [state (get@ #;defs module)]) - )) - -(def #export (exports module-name) - (-> Text (Lux (List (, Text Definition)))) - (do Lux/Monad - [defs (defs module-name)] - (wrap (filter (lambda [[name [exported? data]]] exported?) - defs)))) - -(def #export (modules state) - (Lux (List Text)) - (|> state - (get@ #;modules) - (list:map t;first) - (#;Right state))) - -(def #export (find-module name state) - (-> Text (Lux (Module Compiler))) - (case (get name (get@ #;modules state)) - (#;Some module) - (#;Right state module) - - _ - (#;Left ($ text:++ "Unknown module: " name)))) - -(def #export (tags-for [module name]) - (-> Ident (Lux (Maybe (List Ident)))) - (do Lux/Monad - [module (find-module module)] - (case (get name (get@ #;types module)) - (#;Some [tags _]) - (wrap (#;Some tags)) - - _ - (wrap #;None)))) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux deleted file mode 100644 index 641dfba0d..000000000 --- a/source/lux/meta/syntax.lux +++ /dev/null @@ -1,306 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (.. ast - (lux #as l #refer (#only Lux/Monad gensym))) - (lux (control (functor #as F) - (monad #as M #refer (#only do)) - (eq #as E)) - (data (bool #as b) - (char #as c) - (text #as t #open ("text:" Text/Monoid Text/Eq)) - (list #refer #all #open ("" List/Functor List/Fold)) - (number (int #open ("i" Int/Ord)) - (real #open ("r" Real/Eq)))))) - -## [Utils] -(def (first xy) - (All [a b] (-> (, a b) a)) - (let [[x y] xy] - x)) - -(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')))) - -(def (pair->tuple [left right]) - (-> (, AST AST) AST) - (tuple$ (@list left right))) - -## [Types] -(deftype #export (Parser a) - (-> (List AST) (Maybe (, (List AST) a)))) - -## [Structures] -(defstruct #export Parser/Functor (F;Functor Parser) - (def (map f ma) - (lambda [tokens] - (case (ma tokens) - #;None - #;None - - (#;Some [tokens' a]) - (#;Some [tokens' (f a)]))))) - -(defstruct #export Parser/Monad (M;Monad Parser) - (def _functor Parser/Functor) - - (def (wrap x tokens) - (#;Some [tokens x])) - - (def (join mma) - (lambda [tokens] - (case (mma tokens) - #;None - #;None - - (#;Some [tokens' ma]) - (ma tokens'))))) - -## [Parsers] -(def #export (id^ tokens) - (Parser AST) - (case tokens - #;Nil #;None - (#;Cons [t tokens']) (#;Some [tokens' t]))) - -(do-template [<name> <type> <tag>] - [(def #export (<name> tokens) - (Parser <type>) - (case tokens - (#;Cons [[_ (<tag> x)] tokens']) - (#;Some [tokens' x]) - - _ - #;None))] - - [ bool^ Bool #;BoolS] - [ int^ Int #;IntS] - [ real^ Real #;RealS] - [ char^ Char #;CharS] - [ text^ Text #;TextS] - [symbol^ Ident #;SymbolS] - [ tag^ Ident #;TagS] - ) - -(def #export (assert v tokens) - (-> Bool (Parser (,))) - (if v - (#;Some [tokens []]) - #;None)) - -(def #export nat^ - (Parser Int) - (do Parser/Monad - [n int^ - _ (assert (i>= n 0))] - (wrap n))) - -(do-template [<name> <tag>] - [(def #export (<name> tokens) - (Parser Text) - (case tokens - (#;Cons [[_ (<tag> ["" x])] tokens']) - (#;Some [tokens' x]) - - _ - #;None))] - - [local-symbol^ #;SymbolS] - [ local-tag^ #;TagS] - ) - -(def (ident:= x y) - (-> Ident Ident Bool) - (let [[x1 x2] x - [y1 y2] y] - (and (text:= x1 y1) - (text:= x2 y2)))) - -(do-template [<name> <type> <tag> <eq>] - [(def #export (<name> v tokens) - (-> <type> (Parser Bool)) - (case tokens - (#;Cons [[_ (<tag> x)] tokens']) - (#;Some [tokens' (<eq> v x)]) - - _ - (#;Some [tokens false])))] - - [ bool?^ Bool #;BoolS (:: b;Bool/Eq =)] - [ int?^ Int #;IntS i=] - [ real?^ Real #;RealS r=] - [ char?^ Char #;CharS (:: c;Char/Eq =)] - [ text?^ Text #;TextS (:: t;Text/Eq =)] - [symbol?^ Ident #;SymbolS ident:=] - [ tag?^ Ident #;TagS ident:=] - ) - -(do-template [<name> <type> <tag> <eq>] - [(def #export (<name> v tokens) - (-> <type> (Parser Unit)) - (case tokens - (#;Cons [[_ (<tag> x)] tokens']) - (if (<eq> v x) - (#;Some [tokens' []]) - #;None) - - _ - #;None))] - - [ bool!^ Bool #;BoolS (:: b;Bool/Eq =)] - [ int!^ Int #;IntS i=] - [ real!^ Real #;RealS r=] - [ char!^ Char #;CharS (:: c;Char/Eq =)] - [ text!^ Text #;TextS (:: t;Text/Eq =)] - [symbol!^ Ident #;SymbolS ident:=] - [ tag!^ Ident #;TagS ident:=] - ) - -(do-template [<name> <tag>] - [(def #export (<name> p tokens) - (All [a] - (-> (Parser a) (Parser a))) - (case tokens - (#;Cons [[_ (<tag> members)] tokens']) - (case (p members) - (#;Some [#;Nil x]) (#;Some [tokens' x]) - _ #;None) - - _ - #;None))] - - [ form^ #;FormS] - [tuple^ #;TupleS] - ) - -(def #export (record^ p tokens) - (All [a] - (-> (Parser a) (Parser a))) - (case tokens - (#;Cons [[_ (#;RecordS pairs)] tokens']) - (case (p (map pair->tuple pairs)) - (#;Some [#;Nil x]) (#;Some [tokens' x]) - _ #;None) - - _ - #;None)) - -(def #export (?^ p tokens) - (All [a] - (-> (Parser a) (Parser (Maybe a)))) - (case (p tokens) - #;None (#;Some [tokens #;None]) - (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)]))) - -(def (run-parser p tokens) - (All [a] - (-> (Parser a) (List AST) (Maybe (, (List AST) a)))) - (p tokens)) - -(def #export (*^ p tokens) - (All [a] - (-> (Parser a) (Parser (List a)))) - (case (p tokens) - #;None (#;Some [tokens (@list)]) - (#;Some [tokens' x]) (run-parser (do Parser/Monad - [xs (*^ p)] - (wrap (@list& x xs))) - tokens'))) - -(def #export (+^ p) - (All [a] - (-> (Parser a) (Parser (List a)))) - (do Parser/Monad - [x p - xs (*^ p)] - (wrap (@list& x xs)))) - -(def #export (&^ p1 p2) - (All [a b] - (-> (Parser a) (Parser b) (Parser (, a b)))) - (do Parser/Monad - [x1 p1 - x2 p2] - (wrap [x1 x2]))) - -(def #export (|^ p1 p2 tokens) - (All [a b] - (-> (Parser a) (Parser b) (Parser (Either a b)))) - (case (p1 tokens) - (#;Some [tokens' x1]) (#;Some [tokens' (#;Left x1)]) - #;None (run-parser (do Parser/Monad - [x2 p2] - (wrap (#;Right x2))) - tokens) - )) - -(def #export (||^ ps tokens) - (All [a] - (-> (List (Parser a)) (Parser (Maybe a)))) - (case ps - #;Nil #;None - (#;Cons [p ps']) (case (p tokens) - #;None (||^ ps' tokens) - (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)])) - )) - -(def #export (end^ tokens) - (Parser (,)) - (case tokens - #;Nil (#;Some [tokens []]) - _ #;None)) - -## [Syntax] -(defmacro #export (defsyntax tokens) - (let [[exported? tokens] (case tokens - (\ (@list& [_ (#;TagS ["" "export"])] tokens')) - [true tokens'] - - _ - [false tokens])] - (case tokens - (\ (@list [_ (#;FormS (@list& [_ (#;SymbolS ["" name])] args))] - body)) - (do Lux/Monad - [vars+parsers (M;map% Lux/Monad - (: (-> AST (Lux (, AST AST))) - (lambda [arg] - (case arg - (\ [_ (#;TupleS (@list var parser))]) - (wrap [var parser]) - - (\ [_ (#;SymbolS var-name)]) - (wrap [(symbol$ var-name) (` id^)]) - - _ - (l;fail "Syntax pattern expects 2-tuples or symbols.")))) - args) - g!tokens (gensym "tokens") - g!_ (gensym "_") - #let [error-msg (text$ (text:++ "Wrong syntax for " name)) - body' (foldL (: (-> AST (, AST AST) AST) - (lambda [body name+parser] - (let [[name parser] name+parser] - (` (;_lux_case ((~ parser) (~ g!tokens)) - (#;Some [(~ g!tokens) (~ name)]) - (~ body) - - (~ g!_) - (l;fail (~ error-msg))))))) - body - (: (List (, AST AST)) (@list& [(symbol$ ["" ""]) (` end^)] (reverse vars+parsers)))) - macro-def (` (defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) - (~ body')))]] - (wrap (@list& macro-def - (if exported? - (@list (` (;_lux_export (~ (symbol$ ["" name]))))) - (@list))))) - - _ - (l;fail "Wrong syntax for defsyntax")))) diff --git a/source/lux/meta/type.lux b/source/lux/meta/type.lux deleted file mode 100644 index 0938d104d..000000000 --- a/source/lux/meta/type.lux +++ /dev/null @@ -1,193 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control show - eq - monad) - (data (char #as c) - (text #as t #open ("text:" Text/Monoid Text/Eq)) - (number/int #open ("int:" Int/Number Int/Ord Int/Show)) - maybe - (list #refer #all #open ("list:" List/Monad List/Monoid List/Fold))) - )) - -(open List/Fold) - -## [Utils] -(def (unravel-fun type) - (-> Type (, Type (List Type))) - (case type - (#;LambdaT in out') - (let [[out ins] (unravel-fun out')] - [out (@list& in ins)]) - - _ - [type (@list)])) - -(def (unravel-app type) - (-> Type (, Type (List Type))) - (case type - (#;AppT left' right) - (let [[left rights] (unravel-app left')] - [left (list:++ rights (@list right))]) - - _ - [type (@list)])) - -## [Structures] -(defstruct #export Type/Show (Show Type) - (def (show type) - (case type - (#;DataT name params) - (case params - #;Nil - ($ text:++ "(^ " name ")") - - _ - ($ text:++ "(^ " name " " (|> params (list:map show) (interpose " ") (list:foldL text:++ "")) ")")) - - (#;TupleT members) - (case members - #;Nil - "(,)" - - _ - ($ text:++ "(, " (|> members (list:map show) (interpose " ") (foldL text:++ "")) ")")) - - (#;VariantT members) - (case members - #;Nil - "(|)" - - _ - ($ text:++ "(| " (|> members (list:map show) (interpose " ") (foldL text:++ "")) ")")) - - (#;LambdaT input output) - (let [[out ins] (unravel-fun type)] - ($ text:++ "(-> " (|> ins (list:map show) (interpose " ") (foldL text:++ "")) " " (show out) ")")) - - (#;VarT id) - ($ text:++ "⌈" (int:show id) "⌋") - - (#;BoundT idx) - (int:show idx) - - (#;ExT id) - ($ text:++ "⟨" (int:show id) "⟩") - - (#;AppT fun param) - (let [[type-fun type-args] (unravel-app type)] - ($ text:++ "(" (show type-fun) " " (|> type-args (list:map show) (interpose " ") (foldL text:++ "")) ")")) - - (#;UnivQ env body) - ($ text:++ "(All " (show body) ")") - - (#;ExQ env body) - ($ text:++ "(Ex " (show body) ")") - - (#;NamedT [module name] type) - ($ text:++ module ";" name) - ))) - -(defstruct #export Type/Eq (Eq Type) - (def (= x y) - (case [x y] - [(#;DataT xname xparams) (#;DataT yname yparams)] - (and (text:= xname yname) - (int:= (size xparams) (size yparams)) - (foldL (lambda [prev [x y]] - (and prev (= x y))) - true - (zip2 xparams yparams))) - - (\or [(#;VarT xid) (#;VarT yid)] - [(#;ExT xid) (#;ExT yid)] - [(#;BoundT xid) (#;BoundT yid)]) - (int:= xid yid) - - (\or [(#;LambdaT xleft xright) (#;LambdaT yleft yright)] - [(#;AppT xleft xright) (#;AppT yleft yright)]) - (and (= xleft yleft) - (= xright yright)) - - [(#;NamedT [xmodule xname] xtype) (#;NamedT [ymodule yname] ytype)] - (and (text:= xmodule ymodule) - (text:= xname yname) - (= xtype ytype)) - - (\or [(#;TupleT xmembers) (#;TupleT ymembers)] - [(#;VariantT xmembers) (#;VariantT ymembers)]) - (and (int:= (size xmembers) (size ymembers)) - (foldL (lambda [prev [x y]] - (and prev (= x y))) - true - (zip2 xmembers ymembers))) - - (\or [(#;UnivQ xenv xbody) (#;UnivQ yenv ybody)] - [(#;ExQ xenv xbody) (#;ExQ yenv ybody)]) - (and (int:= (size xenv) (size yenv)) - (foldL (lambda [prev [x y]] - (and prev (= x y))) - (= xbody ybody) - (zip2 xenv yenv))) - - _ - false - ))) - -## [Functions] -(def #export (beta-reduce env type) - (-> (List Type) Type Type) - (case type - (\template [<tag>] - [(<tag> members) - (<tag> (list:map (beta-reduce env) members))]) - [[#;VariantT] - [#;TupleT]] - - (\template [<tag>] - [(<tag> left right) - (<tag> (beta-reduce env left) (beta-reduce env right))]) - [[#;LambdaT] - [#;AppT]] - - (\template [<tag>] - [(<tag> env def) - (case env - #;Nil - (<tag> env def) - - _ - type)]) - [[#;UnivQ] - [#;ExQ]] - - (#;BoundT idx) - (? type (@ idx env)) - - (#;NamedT name type) - (beta-reduce env type) - - _ - type - )) - -(def #export (apply-type type-fun param) - (-> Type Type (Maybe Type)) - (case type-fun - (#;UnivQ env body) - (#;Some (beta-reduce (@list& type-fun param env) body)) - - (#;AppT F A) - (do Maybe/Monad - [type-fn* (apply-type F A)] - (apply-type type-fn* param)) - - (#;NamedT name type) - (apply-type type param) - - _ - #;None)) |