diff options
Diffstat (limited to 'source/lux')
48 files changed, 2108 insertions, 1200 deletions
diff --git a/source/lux/codata/function.lux b/source/lux/codata/function.lux new file mode 100644 index 000000000..1b7336049 --- /dev/null +++ b/source/lux/codata/function.lux @@ -0,0 +1,27 @@ +## 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 new file mode 100644 index 000000000..195aef616 --- /dev/null +++ b/source/lux/codata/io.lux @@ -0,0 +1,42 @@ +## 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 new file mode 100644 index 000000000..c0c79fc1a --- /dev/null +++ b/source/lux/codata/lazy.lux @@ -0,0 +1,56 @@ +## 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 new file mode 100644 index 000000000..e776f73ec --- /dev/null +++ b/source/lux/codata/reader.lux @@ -0,0 +1,30 @@ +## 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 new file mode 100644 index 000000000..311fce320 --- /dev/null +++ b/source/lux/codata/state.lux @@ -0,0 +1,39 @@ +## 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 index 1d6dd1b50..86ce99761 100644 --- a/source/lux/codata/stream.lux +++ b/source/lux/codata/stream.lux @@ -1,20 +1,20 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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 (lazy #as L #refer #all) - (functor #as F #refer #all) + (lux (control (functor #as F #refer #all) (monad #as M #refer #all) (comonad #as CM #refer #all)) (meta lux - macro syntax) - (data (list #as l #refer (#only list list& List/Monad))))) + (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) @@ -25,8 +25,8 @@ (All [a] (-> a (List a) a (List a) (Stream a))) (case xs - #;Nil (cycle' init full init full) - (#;Cons [y xs']) (... [x (cycle' y xs' init full)]))) + #;Nil (cycle' init full init full) + (#;Cons x' xs') (... [x (cycle' x' xs' init full)]))) ## [Functions] (def #export (iterate f x) @@ -43,8 +43,8 @@ (All [a] (-> (List a) (Maybe (Stream a)))) (case xs - #;Nil #;None - (#;Cons [x xs']) (#;Some (cycle' x xs' x xs')))) + #;Nil #;None + (#;Cons x xs') (#;Some (cycle' x xs' x xs')))) (do-template [<name> <return> <part>] [(def #export (<name> s) @@ -59,7 +59,7 @@ (All [a] (-> Int (Stream a) a)) (let [[h t] (! s)] (if (i> idx 0) - (@ (dec idx) t) + (@ (i+ -1 idx) t) h))) (do-template [<taker> <dropper> <splitter> <det-type> <det-test> <det-step>] @@ -68,8 +68,8 @@ (-> <det-type> (Stream a) (List a))) (let [[x xs'] (! xs)] (if <det-test> - (list& x (<taker> <det-step> xs')) - (list)))) + (@list& x (<taker> <det-step> xs')) + (@list)))) (def #export (<dropper> det xs) (All [a] @@ -86,10 +86,10 @@ (if <det-test> (let [[tail next] (<splitter> <det-step> xs')] [(#;Cons [x tail]) next]) - [(list) xs])))] + [(@list) xs])))] [take-while drop-while split-with (-> a Bool) (det x) det] - [take drop split Int (i> det 0) (dec det)] + [take drop split Int (i> det 0) (i+ -1 det)] ) (def #export (unfold step init) @@ -107,27 +107,34 @@ (def #export (partition p xs) (All [a] (-> (-> a Bool) (Stream a) (, (Stream a) (Stream a)))) - [(filter p xs) (filter (complement p) xs)]) + [(filter p xs) (filter (comp p) xs)]) ## [Structures] (defstruct #export Stream/Functor (Functor Stream) - (def (F;map f fa) + (def (map f fa) (let [[h t] (! fa)] - (... [(f h) (F;map f t)])))) + (... [(f h) (map f t)])))) (defstruct #export Stream/CoMonad (CoMonad Stream) - (def CM;_functor Stream/Functor) - (def CM;unwrap head) - (def (CM;split wa) - (:: Stream/Functor (F;map repeat wa)))) + (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^)]) - (do Lux/Monad - [patterns (map% Lux/Monad macro-expand-1 patterns') - g!s (gensym "s") - #let [patterns+ (: (List Syntax) - (do List/Monad - [pattern (l;reverse patterns)] - (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s))))))]] - (M;wrap (list g!s (` (;let [(~@ patterns+)] (~ body))))))) +(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 new file mode 100644 index 000000000..b4c8a3e57 --- /dev/null +++ b/source/lux/control/bounded.lux @@ -0,0 +1,14 @@ +## 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 index ce9a7e7de..2543f34da 100644 --- a/source/lux/control/comonad.lux +++ b/source/lux/control/comonad.lux @@ -1,17 +1,13 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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 - lux/meta/macro) + (lux/data/list #refer #all #open ("" List/Fold))) -## Signatures +## [Signatures] (defsig #export (CoMonad w) (: (F;Functor w) _functor) @@ -22,33 +18,35 @@ (-> (w a) (w (w a)))) split)) -## Functions +## [Functions] (def #export (extend w f ma) (All [w a b] (-> (CoMonad w) (-> (w a) b) (w a) (w b))) (using w - (using _functor - (map f (split ma))))) + (map f (split ma)))) -## Syntax +## [Syntax] (defmacro #export (be tokens state) (case tokens - (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) - (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (#;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 - (#;Meta [_ (#;TagS ["" "let"])]) - (` (;let (~ value) (~ body'))) + [_ (#;TagS ["" "let"])] + (` (let (~ value) (~ body'))) _ - (` (extend (;lambda [(~ var)] (~ body')) - (~ value))))))) + (` (|> (~ value) (~ g!split) ((~ g!map) (lambda [(~ var)] (~ body'))))) + )))) body (reverse (as-pairs bindings)))] - (#;Right [state (list (` (;case (~ monad) - {#;return ;return #;bind ;bind} - (~ body'))))])) + (#;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 new file mode 100644 index 000000000..4ce368e96 --- /dev/null +++ b/source/lux/control/enum.lux @@ -0,0 +1,25 @@ +## 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 new file mode 100644 index 000000000..d86df5757 --- /dev/null +++ b/source/lux/control/eq.lux @@ -0,0 +1,11 @@ +## 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 new file mode 100644 index 000000000..d0aef1576 --- /dev/null +++ b/source/lux/control/fold.lux @@ -0,0 +1,42 @@ +## 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 index 6a9dcfff8..99c34a45c 100644 --- a/source/lux/control/functor.lux +++ b/source/lux/control/functor.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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) diff --git a/source/lux/control/hash.lux b/source/lux/control/hash.lux new file mode 100644 index 000000000..643c49e9d --- /dev/null +++ b/source/lux/control/hash.lux @@ -0,0 +1,11 @@ +## 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/lazy.lux b/source/lux/control/lazy.lux deleted file mode 100644 index 22dac74fe..000000000 --- a/source/lux/control/lazy.lux +++ /dev/null @@ -1,47 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/meta macro) - (.. (functor #as F #refer #all) - (monad #as M #refer #all)) - (lux/data list)) - -## 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)) - -## Structs -(defstruct #export Lazy/Functor (Functor Lazy) - (def (F;map f ma) - (lambda [k] (ma (. k f))))) - -(defstruct #export Lazy/Monad (Monad Lazy) - (def M;_functor Lazy/Functor) - - (def (M;wrap a) - (... a)) - - (def M;join !)) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux index a03c1499a..e5c5989cf 100644 --- a/source/lux/control/monad.lux +++ b/source/lux/control/monad.lux @@ -1,15 +1,11 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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)) - lux/meta/macro) + (monoid #as M))) ## [Utils] (def (foldL f init xs) @@ -19,21 +15,21 @@ #;Nil init - (#;Cons [x xs']) + (#;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])) + (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')]) + (#;Cons x1 (#;Cons x2 xs')) + (#;Cons [x1 x2] (as-pairs xs')) _ #;Nil)) @@ -52,27 +48,25 @@ ## [Syntax] (defmacro #export (do tokens state) (case tokens - ## (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) - (#;Cons [monad (#;Cons [(#;Meta [_ (#;TupleS bindings)]) (#;Cons [body #;Nil])])]) - (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (#;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 - (#;Meta [_ (#;TagS ["" "let"])]) - (` (;let (~ value) (~ body'))) + [_ (#;TagS ["" "let"])] + (` (let (~ value) (~ body'))) _ - (` (;case ;;_functor - {#F;map F;map} - (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;;join)))) - ## (` (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;:: ;;_functor) (;;join))) + (` (|> (~ value) ((~ g!map) (lambda [(~ var)] (~ body'))) (~ g!join))) )))) body (reverse (as-pairs bindings)))] - (#;Right [state (#;Cons [(` (;case (~ monad) - {#;;_functor ;;_functor #;;wrap ;;wrap #;;join ;;join} - (~ body'))) - #;Nil])])) + (#;Right [state (#;Cons (` (case (~ monad) + {#_functor {#F;map (~ g!map)} #wrap (~ (' wrap)) #join (~ g!join)} + (~ body'))) + #;Nil)])) _ (#;Left "Wrong syntax for do"))) @@ -82,18 +76,32 @@ (All [m a b] (-> (Monad m) (-> a (m b)) (m a) (m b))) (using m - (join (:: _functor (F;map f ma))))) + (join (map f ma)))) -(def #export (map% m f xs) - (All [m a b] - (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) +(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 - (:: m (;;wrap #;Nil)) + (:: monad (wrap #;Nil)) - (#;Cons [x xs']) - (do m - [y (f x) - ys (map% m f xs')] - (;;wrap (#;Cons [y ys]))) + (#;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 index d32baabc5..447ab8225 100644 --- a/source/lux/control/monoid.lux +++ b/source/lux/control/monoid.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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) diff --git a/source/lux/control/number.lux b/source/lux/control/number.lux new file mode 100644 index 000000000..b1bbec190 --- /dev/null +++ b/source/lux/control/number.lux @@ -0,0 +1,25 @@ +## 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/data/ord.lux b/source/lux/control/ord.lux index 80f2e4fb5..cb77e7042 100644 --- a/source/lux/data/ord.lux +++ b/source/lux/control/ord.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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)) @@ -27,11 +24,11 @@ (def < <) (def (<= x y) (or (< x y) - (:: eq (E;= x y)))) + (:: eq (= x y)))) (def > >) (def (>= x y) (or (> x y) - (:: eq (E;= x y)))))) + (:: eq (= x y)))))) ## [Functions] (do-template [<name> <op>] @@ -40,5 +37,5 @@ (-> (Ord a) a a a)) (if (:: ord (<op> x y)) x y))] - [max ;;>] - [min ;;<]) + [max >] + [min <]) diff --git a/source/lux/control/show.lux b/source/lux/control/show.lux new file mode 100644 index 000000000..706819ec2 --- /dev/null +++ b/source/lux/control/show.lux @@ -0,0 +1,11 @@ +## 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 index d4f223612..a3e28733b 100644 --- a/source/lux/data/bool.lux +++ b/source/lux/data/bool.lux @@ -1,33 +1,36 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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))) + (lux (control (monoid #as m) + (eq #as E) + (show #as S)) + (codata function))) ## [Structures] (defstruct #export Bool/Eq (E;Eq Bool) - (def (E;= x y) + (def (= x y) (if x y (not y)))) (defstruct #export Bool/Show (S;Show Bool) - (def (S;show x) + (def (show x) (if x "true" "false"))) (do-template [<name> <unit> <op>] [(defstruct #export <name> (m;Monoid Bool) - (def m;unit <unit>) - (def (m;++ x y) + (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/bounded.lux b/source/lux/data/bounded.lux deleted file mode 100644 index 9d2dabde1..000000000 --- a/source/lux/data/bounded.lux +++ /dev/null @@ -1,17 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux) - -## Signatures -(defsig #export (Bounded a) - (: a - top) - - (: a - bottom)) diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux index 5a811c006..b7b4c6bda 100644 --- a/source/lux/data/char.lux +++ b/source/lux/data/char.lux @@ -1,21 +1,22 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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) - (show #as S) - (text #as T #open ("text:" Text/Monoid)))) + (lux/control (eq #as E) + (show #as S)) + (.. (text #as T #open ("text:" Text/Monoid)))) ## [Structures] (defstruct #export Char/Eq (E;Eq Char) - (def (E;= x y) + (def (= x y) (_jvm_ceq x y))) (defstruct #export Char/Show (S;Show Char) - (def (S;show x) + (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/dict.lux b/source/lux/data/dict.lux deleted file mode 100644 index 63a66d49b..000000000 --- a/source/lux/data/dict.lux +++ /dev/null @@ -1,83 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/data (eq #as E))) - -## Signatures -(defsig #export (Dict d) - (: (All [k v] - (-> k (d k v) (Maybe v))) - get) - (: (All [k v] - (-> k v (d k v) (d k v))) - put) - (: (All [k v] - (-> k (d k v) (d k v))) - remove)) - -## Types -(deftype #export (PList k v) - (| (#PList (, (E;Eq k) (List (, k v)))))) - -## Constructors -(def #export (plist eq) - (All [k v] - (-> (E;Eq k) (PList k v))) - (#PList [eq #;Nil])) - -## Utils -(def (pl-get eq k kvs) - (All [k v] - (-> (E;Eq k) k (List (, k v)) (Maybe v))) - (case kvs - #;Nil - #;None - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - (#;Some v') - (pl-get eq k kvs')))) - -(def (pl-put eq k v kvs) - (All [k v] - (-> (E;Eq k) k v (List (, k v)) (List (, k v)))) - (case kvs - #;Nil - (#;Cons [[k v] kvs]) - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - (#;Cons [[k v] kvs']) - (#;Cons [[k' v'] (pl-put eq k v kvs')])))) - -(def (pl-remove eq k kvs) - (All [k v] - (-> (E;Eq k) k (List (, k v)) (List (, k v)))) - (case kvs - #;Nil - kvs - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - kvs' - (#;Cons [[k' v'] (pl-remove eq k kvs')])))) - -## Structs -(defstruct #export PList/Dict (Dict PList) - (def (get k plist) - (let [(#PList [eq kvs]) plist] - (pl-get eq k kvs))) - - (def (put k v plist) - (let [(#PList [eq kvs]) plist] - (#PList [eq (pl-put eq k v kvs)]))) - - (def (remove k plist) - (let [(#PList [eq kvs]) plist] - (#PList [eq (pl-remove eq k kvs)])))) diff --git a/source/lux/data/either.lux b/source/lux/data/either.lux index eba6438db..38de1e2d1 100644 --- a/source/lux/data/either.lux +++ b/source/lux/data/either.lux @@ -1,13 +1,12 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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 (#exclude partition)))) + (lux (control (functor #as F #refer #all) + (monad #as M #refer #all)) + (data (list #refer (#exclude partition))))) ## [Types] ## (deftype (Either l r) @@ -33,14 +32,32 @@ [rights b #;Right] ) -(def #export (partition es) +(def #export (partition xs) (All [a b] (-> (List (Either a b)) (, (List a) (List b)))) - (foldL (: (All [a b] - (-> (, (List a) (List b)) (Either a b) (, (List a) (List b)))) - (lambda [tails e] - (let [[ltail rtail] tails] - (case e - (#;Left x) [(#;Cons [x ltail]) rtail] - (#;Right x) [ltail (#;Cons [x rtail])])))) - [(list) (list)] - (reverse es))) + (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/eq.lux b/source/lux/data/eq.lux deleted file mode 100644 index be3400208..000000000 --- a/source/lux/data/eq.lux +++ /dev/null @@ -1,14 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux) - -## [Signatures] -(defsig #export (Eq a) - (: (-> a a Bool) - =)) diff --git a/source/lux/data/error.lux b/source/lux/data/error.lux deleted file mode 100644 index cb5c309a6..000000000 --- a/source/lux/data/error.lux +++ /dev/null @@ -1,34 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -(deftype #export (Error a) - (| (#Fail Text) - (#Ok a))) - -## [Structures] -(defstruct #export Error/Functor (Functor Error) - (def (F;map f ma) - (case ma - (#Fail msg) (#Fail msg) - (#Ok datum) (#Ok (f datum))))) - -(defstruct #export Error/Monad (Monad Error) - (def M;_functor Error/Functor) - - (def (M;wrap a) - (#Ok a)) - - (def (M;join mma) - (case mma - (#Fail msg) (#Fail msg) - (#Ok ma) ma))) diff --git a/source/lux/data/id.lux b/source/lux/data/id.lux index 0e3bdbee6..e4f2a775f 100644 --- a/source/lux/data/id.lux +++ b/source/lux/data/id.lux @@ -1,28 +1,27 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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))) + (monad #as M #refer #all) + (comonad #as CM #refer #all))) ## [Types] (deftype #export (Id a) - (| (#Id a))) + a) ## [Structures] (defstruct #export Id/Functor (Functor Id) - (def (F;map f fa) - (let [(#Id a) fa] - (#Id (f a))))) + (def map id)) (defstruct #export Id/Monad (Monad Id) - (def M;_functor Id/Functor) - (def (M;wrap a) (#Id a)) - (def (M;join mma) - (let [(#Id ma) mma] - ma))) + (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 new file mode 100644 index 000000000..cb2353e43 --- /dev/null +++ b/source/lux/data/ident.lux @@ -0,0 +1,33 @@ +## 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/io.lux b/source/lux/data/io.lux deleted file mode 100644 index a194fc854..000000000 --- a/source/lux/data/io.lux +++ /dev/null @@ -1,52 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/meta macro) - (lux/control (functor #as F) - (monad #as M)) - (.. list - (text #as T #open ("text:" Text/Monoid)))) - -## Types -(deftype #export (IO a) - (-> (,) a)) - -## Syntax -(defmacro #export (io tokens state) - (case tokens - (\ (list value)) - (let [blank (symbol$ ["" ""])] - (#;Right [state (list (` (_lux_lambda (~ blank) (~ blank) (~ value))))])) - - _ - (#;Left "Wrong syntax for io"))) - -## Structures -(defstruct #export IO/Functor (F;Functor IO) - (def (F;map f ma) - (io (f (ma []))))) - -(defstruct #export IO/Monad (M;Monad IO) - (def M;_functor IO/Functor) - - (def (M;wrap x) - (io x)) - - (def (M;join mma) - (mma []))) - -## Functions -(def #export (print x) - (-> Text (IO (,))) - (io (_jvm_invokevirtual "java.io.PrintStream" "print" ["java.lang.Object"] - (_jvm_getstatic "java.lang.System" "out") [x]))) - -(def #export (println x) - (-> Text (IO (,))) - (print (text:++ x "\n"))) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 8fd5c2951..6bf050228 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -1,42 +1,51 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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)) - lux/meta/macro) - -## Types + (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 -(def #export (foldL f init xs) - (All [a b] - (-> (-> a b a) a (List b) a)) - (case xs - #;Nil - init +## [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'))) + (#;Cons [x xs']) + (foldL f (f init x) xs'))) + + (def (foldR f init xs) + (case xs + #;Nil + init -(def #export (foldR f init xs) - (All [a b] - (-> (-> b a a) a (List b) a)) - (case xs - #;Nil - init + (#;Cons [x xs']) + (f x (foldR f init xs'))))) - (#;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] @@ -59,7 +68,7 @@ (def #export (partition p xs) (All [a] (-> (-> a Bool) (List a) (, (List a) (List a)))) - [(filter p xs) (filter (complement p) xs)]) + [(filter p xs) (filter (comp p) xs)]) (def #export (as-pairs xs) (All [a] (-> (List a) (List (, a a)))) @@ -74,7 +83,7 @@ [(def #export (<name> n xs) (All [a] (-> Int (List a) (List a))) - (if (i> n 0) + (if (i:> n 0) (case xs #;Nil #;Nil @@ -83,8 +92,8 @@ <then>) <else>))] - [take (#;Cons [x (take (dec n) xs')]) #;Nil] - [drop (drop (dec n) xs') xs] + [take (#;Cons [x (take (i:+ -1 n) xs')]) #;Nil] + [drop (drop (i:+ -1 n) xs') xs] ) (do-template [<name> <then> <else>] @@ -107,13 +116,13 @@ (def #export (split n xs) (All [a] (-> Int (List a) (, (List a) (List a)))) - (if (i> n 0) + (if (i:> n 0) (case xs #;Nil [#;Nil #;Nil] (#;Cons [x xs']) - (let [[tail rest] (split (dec n) xs')] + (let [[tail rest] (split (i:+ -1 n) xs')] [(#;Cons [x tail]) rest])) [#;Nil xs])) @@ -138,8 +147,8 @@ (def #export (repeat n x) (All [a] (-> Int a (List a))) - (if (i> n 0) - (#;Cons [x (repeat (dec n) x)]) + (if (i:> n 0) + (#;Cons [x (repeat (i:+ -1 n) x)]) #;Nil)) (def #export (iterate f x) @@ -181,8 +190,8 @@ (#;Cons [x (#;Cons [sep (interpose sep xs')])]))) (def #export (size list) - (-> List Int) - (foldL (lambda [acc _] (i+ 1 acc)) 0 list)) + (All [a] (-> (List a) Int)) + (foldL (lambda [acc _] (i:+ 1 acc)) 0 list)) (do-template [<name> <init> <op>] [(def #export (<name> p xs) @@ -201,50 +210,135 @@ #;None (#;Cons [x xs']) - (if (i= 0 i) + (if (i:= 0 i) (#;Some x) - (@ (dec i) xs')))) + (@ (i:+ -1 i) xs')))) -## Syntax -(defmacro #export (list xs state) - (#;Right [state (#;Cons [(foldL (lambda [tail head] - (` (#;Cons [(~ head) (~ tail)]))) - (` #;Nil) - (reverse xs)) - #;Nil])])) +## [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) +(defmacro #export (@list& xs state) (case (reverse xs) - (#;Cons [last init]) - (#;Right [state (list (foldL (lambda [tail head] - (` (#;Cons [(~ head) (~ tail)]))) + (#;Cons last init) + (#;Right state (@list (foldL (: (-> AST AST AST) + (lambda [tail head] (` (#;Cons (~ head) (~ tail))))) last - init))]) + init))) _ - (#;Left "Wrong syntax for list&"))) + (#;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 + ))) -## Structures (defstruct #export List/Monoid (All [a] (Monoid (List a))) - (def m;unit #;Nil) - (def (m;++ xs ys) + (def unit #;Nil) + (def (++ xs ys) (case xs - #;Nil ys - (#;Cons [x xs']) (#;Cons [x (m;++ xs' ys)])))) + #;Nil ys + (#;Cons x xs') (#;Cons x (++ xs' ys))))) (defstruct #export List/Functor (Functor List) - (def (F;map f ma) + (def (map f ma) (case ma - #;Nil #;Nil - (#;Cons [a ma']) (#;Cons [(f a) (F;map f ma')])))) + #;Nil #;Nil + (#;Cons a ma') (#;Cons (f a) (map f ma'))))) (defstruct #export List/Monad (Monad List) - (def M;_functor List/Functor) + (def _functor List/Functor) - (def (M;wrap a) - (#;Cons [a #;Nil])) + (def (wrap a) + (#;Cons a #;Nil)) - (def (M;join mma) + (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 index faec53c2e..1303270a7 100644 --- a/source/lux/data/maybe.lux +++ b/source/lux/data/maybe.lux @@ -1,15 +1,12 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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))) + (lux (control (monoid #as m #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all)))) ## [Types] ## (deftype (Maybe a) @@ -17,26 +14,33 @@ ## (#;Some a))) ## [Structures] -(defstruct #export Maybe/Monoid (Monoid Maybe) - (def m;unit #;None) - (def (m;++ xs ys) +(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 (F;map f ma) + (def (map f ma) (case ma #;None #;None (#;Some a) (#;Some (f a))))) (defstruct #export Maybe/Monad (Monad Maybe) - (def M;_functor Maybe/Functor) + (def _functor Maybe/Functor) - (def (M;wrap x) + (def (wrap x) (#;Some x)) - (def (M;join mma) + (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.lux b/source/lux/data/number.lux deleted file mode 100644 index 8771ef06e..000000000 --- a/source/lux/data/number.lux +++ /dev/null @@ -1,113 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;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>)] - [+] [-] [*] [/] [%]) - - (: (-> Int n) - from-int) - - (do-template [<name>] - [(: (-> n n) <name>)] - [negate] [signum] [abs]) - ) - -## [Structures] -## Number -(do-template [<name> <type> <+> <-> <*> </> <%> <=> <<> <from> <0> <1> <-1>] - [(defstruct #export <name> (Number <type>) - (def + <+>) - (def - <->) - (def * <*>) - (def / </>) - (def % <%>) - (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 i+ i- i* i/ i% i= i< id 0 1 -1] - [Real/Number Real r+ r- r* r/ r% r= r< _jvm_l2d 0.0 1.0 -1.0]) - -## Eq -(defstruct #export Int/Eq (E;Eq Int) - (def E;= i=)) - -(defstruct #export Real/Eq (E;Eq Real) - (def E;= r=)) - -## Ord -(do-template [<name> <type> <eq> <lt> <gt>] - [(defstruct #export <name> (O;Ord <type>) - (def O;_eq <eq>) - (def O;< <lt>) - (def (O;<= x y) - (or (<lt> x y) - (:: <eq> (E;= x y)))) - (def O;> <gt>) - (def (O;>= x y) - (or (<gt> x y) - (:: <eq> (E;= x y)))))] - - [ Int/Ord Int Int/Eq i< i>] - [Real/Ord Real Real/Eq r< r>]) - -## Bounded -(do-template [<name> <type> <top> <bottom>] - [(defstruct #export <name> (B;Bounded <type>) - (def B;top <top>) - (def B;bottom <bottom>))] - - [ Int/Bounded Int (_jvm_getstatic "java.lang.Long" "MAX_VALUE") (_jvm_getstatic "java.lang.Long" "MIN_VALUE")] - [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 m;unit <unit>) - (def m;++ <++>))] - - [ IntAdd/Monoid Int 0 i+] - [ IntMul/Monoid Int 1 i*] - [RealAdd/Monoid Real 0.0 r+] - [RealMul/Monoid Real 1.0 r*] - [ IntMax/Monoid Int (:: Int/Bounded B;bottom) (O;max Int/Ord)] - [ IntMin/Monoid Int (:: Int/Bounded B;top) (O;min Int/Ord)] - [RealMax/Monoid Real (:: Real/Bounded B;bottom) (O;max Real/Ord)] - [RealMin/Monoid Real (:: Real/Bounded B;top) (O;min Real/Ord)] - ) - -## Show -(do-template [<name> <type> <body>] - [(defstruct #export <name> (S;Show <type>) - (def (S;show x) - <body>))] - - [ Int/Show Int (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] - [Real/Show Real (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] - ) diff --git a/source/lux/data/number/int.lux b/source/lux/data/number/int.lux new file mode 100644 index 000000000..1e71b8a5a --- /dev/null +++ b/source/lux/data/number/int.lux @@ -0,0 +1,93 @@ +## 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 new file mode 100644 index 000000000..7d5243385 --- /dev/null +++ b/source/lux/data/number/real.lux @@ -0,0 +1,93 @@ +## 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/reader.lux b/source/lux/data/reader.lux deleted file mode 100644 index e91687c3a..000000000 --- a/source/lux/data/reader.lux +++ /dev/null @@ -1,33 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;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 (F;map f fa) - (lambda [env] - (f (fa env))))) - -(defstruct #export Reader/Monad (All [r] - (Monad (Reader r))) - (def M;_functor Reader/Functor) - - (def (M;wrap x) - (lambda [env] x)) - - (def (M;join mma) - (lambda [env] - (mma env env)))) diff --git a/source/lux/data/show.lux b/source/lux/data/show.lux deleted file mode 100644 index f4e1cf762..000000000 --- a/source/lux/data/show.lux +++ /dev/null @@ -1,14 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux) - -## Signatures -(defsig #export (Show a) - (: (-> a Text) - show)) diff --git a/source/lux/data/state.lux b/source/lux/data/state.lux deleted file mode 100644 index bc9858a29..000000000 --- a/source/lux/data/state.lux +++ /dev/null @@ -1,35 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;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 (Functor State) - (def (F;map f ma) - (lambda [state] - (let [[state' a] (ma state)] - [state' (f a)])))) - -(defstruct #export State/Monad (All [s] - (Monad (State s))) - (def M;_functor State/Functor) - - (def (M;wrap x) - (lambda [state] - [state x])) - - (def (M;join mma) - (lambda [state] - (let [[state' ma] (mma state)] - (ma state'))))) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index 6ad9cfd63..af2de51ff 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -1,16 +1,16 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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)) - (lux/data (eq #as E) - (ord #as O) - (show #as S))) + (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) @@ -112,12 +112,12 @@ ## [Structures] (defstruct #export Text/Eq (E;Eq Text) - (def (E;= x y) + (def (= x y) (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"] x [y]))) (defstruct #export Text/Ord (O;Ord Text) - (def O;_eq Text/Eq) + (def _eq Text/Eq) (do-template [<name> <op>] [(def (<name> x y) @@ -125,17 +125,71 @@ x [y])) 0))] - [O;< i<] - [O;<= i<=] - [O;> i>] - [O;>= i>=])) + [< i<] + [<= i<=] + [> i>] + [>= i>=])) (defstruct #export Text/Show (S;Show Text) - (def (S;show x) - x)) + (def show id)) (defstruct #export Text/Monoid (m;Monoid Text) - (def m;unit "") - (def (m;++ x y) + (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 new file mode 100644 index 000000000..6eef74670 --- /dev/null +++ b/source/lux/data/tuple.lux @@ -0,0 +1,35 @@ +## 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 index f71492e35..3bf99c1ad 100644 --- a/source/lux/data/writer.lux +++ b/source/lux/data/writer.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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) @@ -18,17 +15,17 @@ ## [Structures] (defstruct #export Writer/Functor (All [l] (Functor (Writer l))) - (def (F;map f fa) + (def (map f fa) (let [[log datum] fa] [log (f datum)]))) (defstruct #export (Writer/Monad mon) (All [l] (-> (Monoid l) (Monad (Writer l)))) - (def M;_functor Writer/Functor) + (def _functor Writer/Functor) - (def (M;wrap x) - [(:: mon m;unit) x]) + (def (wrap x) + [(:: mon unit) x]) - (def (M;join mma) + (def (join mma) (let [[log1 [log2 a]] mma] - [(:: mon (m;++ log1 log2)) a]))) + [(:: mon (++ log1 log2)) a]))) diff --git a/source/lux/host/io.lux b/source/lux/host/io.lux new file mode 100644 index 000000000..220f089a2 --- /dev/null +++ b/source/lux/host/io.lux @@ -0,0 +1,60 @@ +## 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 index 7af043969..737c1731d 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -1,238 +1,377 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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))) - (data (list #as l #refer #all #open ("" List/Functor)) - (text #as text)) + (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 - macro + 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 finally^ - (Parser Syntax) - (form^ (do Parser/Monad - [_ (symbol?^ ["" "finally"]) - expr id^] - (M;wrap expr)))) - -(def catch^ - (Parser (, Text Ident Syntax)) - (form^ (do Parser/Monad - [_ (symbol?^ ["" "catch"]) - ex-class local-symbol^ - ex symbol^ - expr id^] - (M;wrap [ex-class ex expr])))) +(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 (, (List Text) Text (List Text) Text)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - inputs (tuple^ (*^ local-symbol^)) - output local-symbol^] - (M;wrap [modifiers name inputs output])))) + (Parser (, MemberDecl MethodDecl)) + (form^ (&^ member-decl^ + method-decl'^))) (def field-decl^ - (Parser (, (List Text) Text Text)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - class local-symbol^] - (M;wrap [modifiers name class])))) + (Parser (, MemberDecl FieldDecl)) + (form^ (&^ member-decl^ + local-symbol^))) (def arg-decl^ - (Parser (, Text Text)) - (form^ (do Parser/Monad - [arg-name local-symbol^ - arg-class local-symbol^] - (M;wrap [arg-name arg-class])))) + (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 (, (List Text) Text (List (, Text Text)) Text Syntax)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - inputs (tuple^ (*^ arg-decl^)) - output local-symbol^ - body id^] - (M;wrap [modifiers name inputs output body])))) - -(def method-call^ - (Parser (, Text (List Text) (List Syntax))) - (form^ (do Parser/Monad - [method local-symbol^ - arity-classes (tuple^ (*^ local-symbol^)) - arity-args (tuple^ (*^ id^)) - _ (: (Parser (,)) - (if (i= (size arity-classes) - (size arity-args)) - (M;wrap []) - (lambda [_] #;None)))] - (M;wrap [method arity-classes arity-args]) - ))) + (Parser (, MemberDecl MethodDef)) + (form^ (&^ member-decl^ + method-def'^))) -## [Syntax] -(defsyntax #export (throw ex) - (emit (list (` (_jvm_throw (~ ex)))))) - -(defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) - (emit (list (` (_jvm_try (~ body) - (~@ (:: List/Monoid (m;++ (map (: (-> (, Text Ident Syntax) Syntax) - (lambda [catch] - (let [[class ex body] catch] - (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) - catches) - (case finally - #;None - (list) - - (#;Some finally) - (list (` (_jvm_finally (~ finally))))))))))))) - -(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) - (let [members' (map (: (-> (, (List Text) Text (List Text) Text) Syntax) - (lambda [member] - (let [[modifiers name inputs output] member] - (` ((~ (text$ name)) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) - members)] - (emit (list (` (_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))] - (~@ members'))))))) +(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 - [current-module get-module-name - #let [fields' (map (: (-> (, (List Text) Text Text) Syntax) - (lambda [field] - (let [[modifiers name class] field] - (` ((~ (text$ name)) - (~ (text$ class)) - [(~@ (map text$ modifiers))]))))) - fields) - methods' (map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) - (lambda [methods] - (let [[modifiers name inputs output body] methods] - (` ((~ (text$ name)) - [(~@ (map (: (-> (, Text Text) Syntax) - (lambda [in] - (let [[left right] in] - (form$ (list (symbol$ ["" left]) - (text$ right)))))) - inputs))] - (~ (text$ output)) - [(~@ (map text$ modifiers))] - (~ body)))))) - methods)]] - (emit (list (` (_jvm_class (~ (text$ name)) (~ (text$ super)) - [(~@ (map text$ interfaces))] - [(~@ fields')] - [(~@ methods')])))))) - -(defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))]) - (emit (list (` (_jvm_new (~ (text$ class)) - [(~@ (map text$ arg-classes))] - [(~@ args)]))))) + [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)))))) + (emit (@list (` (;_jvm_instanceof (~ (text$ class)) (~ obj)))))) (defsyntax #export (locking lock body) (do Lux/Monad [g!lock (gensym "") - g!body (gensym "")] - (emit (list (` (;let [(~ g!lock) (~ lock) - _ (_jvm_monitorenter (~ g!lock)) + g!body (gensym "") + g!_ (gensym "")] + (emit (@list (` (let [(~ g!lock) (~ lock) + (~ g!_) (;_jvm_monitorenter (~ g!lock)) (~ g!body) (~ body) - _ (_jvm_monitorexit (~ g!lock))] - (~ g!body))))) + (~ g!_) (;_jvm_monitorexit (~ g!lock))] + (~ g!body))))) )) (defsyntax #export (null? obj) - (emit (list (` (_jvm_null? (~ obj)))))) + (emit (@list (` (;_jvm_null? (~ obj)))))) -(defsyntax #export (program [args symbol^] body) - (emit (list (` (_jvm_program (~ (symbol$ args)) - (~ body)))))) - -(defsyntax #export (.? [field local-symbol^] obj) - (case obj - (#;Meta [_ (#;SymbolS obj-name)]) - (do Lux/Monad - [obj-type (find-var-type obj-name)] - (case obj-type - (#;DataT class) - (emit (list (` (_jvm_getfield (~ (text$ class)) (~ (text$ field)))))) - - _ - (fail "Can only get field from object."))) +(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 Lux/Monad - [g!obj (gensym "")] - (emit (list (` (;let [(~ g!obj) (~ obj)] - (.? (~ (text$ field)) (~ g!obj))))))))) - -(defsyntax #export (.= [field local-symbol^] value obj) - (case obj - (#;Meta [_ (#;SymbolS obj-name)]) - (do Lux/Monad - [obj-type (find-var-type obj-name)] - (case obj-type - (#;DataT class) - (emit (list (` (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ value))))) - - _ - (fail "Can only set field of object."))) +(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))))))) + ))] - _ - (do Lux/Monad - [g!obj (gensym "")] - (emit (list (` (;let [(~ g!obj) (~ obj)] - (.= (~ (text$ field)) (~ value) (~ g!obj))))))))) - -(defsyntax #export (.! [call method-call^] obj) - (let [[m-name ?m-classes m-args] call] - (case obj - (#;Meta [_ (#;SymbolS obj-name)]) - (do Lux/Monad - [obj-type (find-var-type obj-name)] - (case obj-type - (#;DataT class) - (emit (list (` (_jvm_invokevirtual (~ (text$ class)) (~ (text$ m-name)) [(~@ (map text$ ?m-classes))] - (~ obj) [(~@ m-args)])))) - - _ - (fail "Can only call method on object."))) - - _ - (do Lux/Monad - [g!obj (gensym "")] - (emit (list (` (;let [(~ g!obj) (~ obj)] - (.! ((~ (symbol$ ["" m-name])) - [(~@ (map (lambda [c] (symbol$ ["" c])) ?m-classes))] - [(~@ m-args)]) - (~ g!obj)))))))))) - -(defsyntax #export (..? [field local-symbol^] [class local-symbol^]) - (emit (list (` (_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) - -(defsyntax #export (..= [field local-symbol^] value [class local-symbol^]) - (emit (list (` (_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value)))))) - -(defsyntax #export (..! [call method-call^] [class local-symbol^]) - (let [[m-name m-classes m-args] call] - (emit (list (` (_jvm_invokestatic (~ (text$ class)) (~ (text$ m-name)) - [(~@ (map text$ m-classes))] - [(~@ m-args)])))))) + [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 index a495d130c..a60ce512c 100644 --- a/source/lux/math.lux +++ b/source/lux/math.lux @@ -1,12 +1,10 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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) +(;import lux + (lux/data/number/int #open ("i:" Int/Number))) ## [Constants] (do-template [<name> <value>] @@ -61,3 +59,22 @@ [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 new file mode 100644 index 000000000..a9bc8b588 --- /dev/null +++ b/source/lux/meta/ast.lux @@ -0,0 +1,113 @@ +## 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 index 19b7dd9df..b6ff09f59 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -1,21 +1,19 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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 - (.. macro) + (.. ast) (lux/control (monoid #as m) (functor #as F) - (monad #as M #refer (#only do))) - (lux/data list - maybe - (show #as S) - (number #as N) - (text #as T #open ("text:" Text/Monoid Text/Eq)))) + (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) @@ -29,7 +27,7 @@ ## [Structures] (defstruct #export Lux/Functor (F;Functor Lux) - (def (F;map f fa) + (def (map f fa) (lambda [state] (case (fa state) (#;Left msg) @@ -39,11 +37,11 @@ (#;Right [state' (f a)]))))) (defstruct #export Lux/Monad (M;Monad Lux) - (def M;_functor Lux/Functor) - (def (M;wrap x) + (def _functor Lux/Functor) + (def (wrap x) (lambda [state] (#;Right [state x]))) - (def (M;join mma) + (def (join mma) (lambda [state] (case (mma state) (#;Left msg) @@ -69,7 +67,7 @@ #;Nil #;None - (#;Cons [[k' v] plist']) + (#;Cons [k' v] plist') (if (text:= k k') (#;Some v) (get k plist')))) @@ -77,20 +75,27 @@ (def (find-macro' modules current-module module name) (-> (List (, Text (Module Compiler))) Text Text Text (Maybe Macro)) - (do Maybe/Monad - [$module (get module modules) - gdef (|> (: (Module Compiler) $module) (get@ #;defs) (get name))] - (case (: (, Bool (DefData' Macro)) gdef) - [exported? (#;MacroD macro')] - (if (or exported? (text:= module current-module)) - (#;Some 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) - - [_ (#;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))) @@ -107,15 +112,15 @@ ["" name] (do Lux/Monad [module-name get-module-name] - (M;wrap (: Ident [module-name name]))) + (wrap [module-name name])) _ - (:: Lux/Monad (M;wrap ident)))) + (:: Lux/Monad (wrap ident)))) (def #export (macro-expand syntax) - (-> Syntax (Lux (List Syntax))) + (-> AST (Lux (List AST))) (case syntax - (#;Meta [_ (#;FormS (#;Cons [(#;Meta [_ (#;SymbolS macro-name)]) args]))]) + [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))] (do Lux/Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] @@ -124,31 +129,51 @@ (do Lux/Monad [expansion (macro args) expansion' (M;map% Lux/Monad macro-expand expansion)] - (M;wrap (:: List/Monad (M;join 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 (list& (symbol$ macro-name) args))] - (M;wrap (list (form$ (:: List/Monad (M;join parts')))))))) + [parts' (M;map% Lux/Monad macro-expand-all (@list& (symbol$ macro-name) args))] + (wrap (@list (form$ (:: List/Monad (join parts')))))))) - (#;Meta [_ (#;FormS (#;Cons [harg targs]))]) + [_ (#;FormS (#;Cons [harg targs]))] (do Lux/Monad - [harg+ (macro-expand harg) - targs+ (M;map% Lux/Monad macro-expand targs)] - (M;wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List Syntax)) targs+)))))))) + [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+)))))))) - (#;Meta [_ (#;TupleS members)]) + [_ (#;TupleS members)] (do Lux/Monad - [members' (M;map% Lux/Monad macro-expand members)] - (M;wrap (list (tuple$ (:: List/Monad (M;join members')))))) + [members' (M;map% Lux/Monad macro-expand-all members)] + (wrap (@list (tuple$ (:: List/Monad (join members')))))) _ - (:: Lux/Monad (M;wrap (list syntax))))) + (:: Lux/Monad (wrap (@list syntax))))) (def #export (gensym prefix state) - (-> Text (Lux Syntax)) - (#;Right [(update@ #;seed inc state) - (symbol$ ["__gensym__" (:: N;Int/Show (S;show (get@ #;seed 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] @@ -163,12 +188,12 @@ (#;Left msg))) (def #export (macro-expand-1 token) - (-> Syntax (Lux Syntax)) + (-> AST (Lux AST)) (do Lux/Monad [token+ (macro-expand token)] (case token+ - (\ (list token')) - (M;wrap token') + (\ (@list token')) + (wrap token') _ (fail "Macro expanded to more than 1 element.")))) @@ -187,34 +212,18 @@ (case (get module (get@ #;modules state)) (#;Some =module) (using List/Monad - (#;Right [state (join (:: _functor (F;map (: (-> (, Text (, Bool (DefData' Macro))) - (List Text)) - (lambda [gdef] - (let [[name [export? _]] gdef] - (if export? - (list name) - (list))))) - (get@ #;defs =module))))])) + (#;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 (show-envs envs) - (-> (List (Env Text (, LuxVar Type))) Text) - (|> envs - (F;map (lambda [env] - (case env - {#;name name #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure _} - ($ text:++ name ": " (|> locals - (F;map (: (All [a] (-> (, Text a) Text)) - (lambda [b] (let [[label _] b] label)))) - (:: List/Functor) - (interpose " ") - (foldL text:++ text:unit)))))) - (:: List/Functor) - (interpose "\n") - (foldL text:++ text:unit))) - (def (try-both f x1 x2) (All [a b] (-> (-> a (Maybe b)) a a (Maybe b))) @@ -222,56 +231,71 @@ #;None (f x2) (#;Some y) (#;Some y))) -(def (find-in-env name state) - (-> Ident Compiler (Maybe Type)) - (let [vname' (ident->text name)] - (case state - {#;source source #;modules modules - #;envs envs #;types types #;host host - #;seed seed #;eval? eval?} - (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) - (lambda [env] - (case env - {#;name _ #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure {#;counter _ #;mappings closure}} - (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) - (lambda [binding] - (let [[bname [_ type]] binding] - (if (text:= vname' bname) - (#;Some type) - #;None))))) - locals - closure)))) - envs)))) - -(def (find-in-defs name state) - (-> Ident Compiler (Maybe Type)) +(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 #;types types #;host host - #;seed seed #;eval? eval?} state] + #;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 _}) + (#;Some {#;defs defs #;module-aliases _ #;imports _ #;tags _ #;types _}) (case (get v-name defs) #;None #;None - (#;Some [_ def-data]) - (case def-data - #;TypeD (#;Some Type) - (#;ValueD type) (#;Some type) - (#;MacroD m) (#;Some Macro) - (#;AliasD name') (find-in-defs name' state)))))) + (#;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 - [name' (normalize name)] + [#let [[_ _name] name] + name' (normalize name)] (: (Lux Type) (lambda [state] - (case (find-in-env name state) + (case (find-in-env _name state) (#;Some struct-type) (#;Right [state struct-type]) @@ -281,8 +305,62 @@ (#;Right [state struct-type]) _ - (let [{#;source source #;modules modules - #;envs envs #;types types #;host host - #;seed seed #;eval? eval?} state] - (#;Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs)))))))) + (#;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/macro.lux b/source/lux/meta/macro.lux deleted file mode 100644 index 22aeaf874..000000000 --- a/source/lux/meta/macro.lux +++ /dev/null @@ -1,54 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux) - -## [Utils] -(def (_meta x) - (-> (Syntax' (Meta Cursor)) Syntax) - (#;Meta [["" -1 -1] x])) - -## [Syntax] -(def #export (defmacro tokens state) - Macro - (case tokens - (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])]) - (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) ((~ name) (~@ args)) - (~ (_meta (#;SymbolS ["lux" "Macro"]))) - (~ body))) - (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) - #;Nil])])]) - - (#;Cons [(#;Meta [_ (#;TagS ["" "export"])]) (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])]) - (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) (~ (_meta (#;TagS ["" "export"]))) ((~ name) (~@ args)) - (~ (_meta (#;SymbolS ["lux" "Macro"]))) - (~ body))) - (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) - #;Nil])])]) - - _ - (#;Left "Wrong syntax for defmacro"))) -(_lux_declare-macro defmacro) - -## [Functions] -(do-template [<name> <type> <tag>] - [(def #export (<name> x) - (-> <type> Syntax) - (#;Meta [["" -1 -1] (<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 Syntax) #;FormS] - [tuple$ (List Syntax) #;TupleS] - [record$ (List (, Syntax Syntax)) #;RecordS] - ) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index 63ab81475..641dfba0d 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -1,21 +1,20 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## 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 - (.. (macro #as m #refer #all) + (.. ast (lux #as l #refer (#only Lux/Monad gensym))) (lux (control (functor #as F) - (monad #as M #refer (#only do))) - (data (eq #as E) - (bool #as b) + (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))) + (list #refer #all #open ("" List/Functor List/Fold)) + (number (int #open ("i" Int/Ord)) + (real #open ("r" Real/Eq)))))) ## [Utils] (def (first xy) @@ -27,15 +26,19 @@ (All [a] (-> (List (, a a)) (List a))) (case pairs #;Nil #;Nil - (#;Cons [[x y] pairs']) (list& x y (join-pairs pairs')))) + (#;Cons [[x y] pairs']) (@list& x y (join-pairs pairs')))) -## Types +(def (pair->tuple [left right]) + (-> (, AST AST) AST) + (tuple$ (@list left right))) + +## [Types] (deftype #export (Parser a) - (-> (List Syntax) (Maybe (, (List Syntax) a)))) + (-> (List AST) (Maybe (, (List AST) a)))) -## Structures +## [Structures] (defstruct #export Parser/Functor (F;Functor Parser) - (def (F;map f ma) + (def (map f ma) (lambda [tokens] (case (ma tokens) #;None @@ -45,12 +48,12 @@ (#;Some [tokens' (f a)]))))) (defstruct #export Parser/Monad (M;Monad Parser) - (def M;_functor Parser/Functor) + (def _functor Parser/Functor) - (def (M;wrap x tokens) + (def (wrap x tokens) (#;Some [tokens x])) - (def (M;join mma) + (def (join mma) (lambda [tokens] (case (mma tokens) #;None @@ -59,9 +62,9 @@ (#;Some [tokens' ma]) (ma tokens'))))) -## Parsers +## [Parsers] (def #export (id^ tokens) - (Parser Syntax) + (Parser AST) (case tokens #;Nil #;None (#;Cons [t tokens']) (#;Some [tokens' t]))) @@ -70,7 +73,7 @@ [(def #export (<name> tokens) (Parser <type>) (case tokens - (#;Cons [(#;Meta [_ (<tag> x)]) tokens']) + (#;Cons [[_ (<tag> x)] tokens']) (#;Some [tokens' x]) _ @@ -85,11 +88,24 @@ [ 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 [(#;Meta [_ (<tag> ["" x])]) tokens']) + (#;Cons [[_ (<tag> ["" x])] tokens']) (#;Some [tokens' x]) _ @@ -108,32 +124,51 @@ (do-template [<name> <type> <tag> <eq>] [(def #export (<name> v tokens) - (-> <type> (Parser (,))) + (-> <type> (Parser Bool)) (case tokens - (#;Cons [(#;Meta [_ (<tag> x)]) tokens']) - (if (<eq> v x) - (#;Some [tokens' []]) - #;None) + (#;Cons [[_ (<tag> x)] tokens']) + (#;Some [tokens' (<eq> v x)]) _ - #;None))] + (#;Some [tokens false])))] - [ bool?^ Bool #;BoolS (:: b;Bool/Eq E;=)] + [ bool?^ Bool #;BoolS (:: b;Bool/Eq =)] [ int?^ Int #;IntS i=] [ real?^ Real #;RealS r=] - [ char?^ Char #;CharS (:: c;Char/Eq E;=)] - [ text?^ Text #;TextS (:: t;Text/Eq E;=)] + [ 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 [(#;Meta [_ (<tag> form)]) tokens']) - (case (p form) + (#;Cons [[_ (<tag> members)] tokens']) + (case (p members) (#;Some [#;Nil x]) (#;Some [tokens' x]) _ #;None) @@ -144,6 +179,18 @@ [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)))) @@ -153,17 +200,17 @@ (def (run-parser p tokens) (All [a] - (-> (Parser a) (List Syntax) (Maybe (, (List Syntax) 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)]) + #;None (#;Some [tokens (@list)]) (#;Some [tokens' x]) (run-parser (do Parser/Monad [xs (*^ p)] - (M;wrap (list& x xs))) + (wrap (@list& x xs))) tokens'))) (def #export (+^ p) @@ -172,7 +219,7 @@ (do Parser/Monad [x p xs (*^ p)] - (M;wrap (list& x xs)))) + (wrap (@list& x xs)))) (def #export (&^ p1 p2) (All [a b] @@ -180,17 +227,18 @@ (do Parser/Monad [x1 p1 x2 p2] - (M;wrap [x1 x2]))) + (wrap [x1 x2]))) (def #export (|^ p1 p2 tokens) (All [a b] - (-> (Parser a) (Parser b) (Parser (Either 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] - (M;wrap (#;Right x2))) - tokens))) + (wrap (#;Right x2))) + tokens) + )) (def #export (||^ ps tokens) (All [a] @@ -208,55 +256,51 @@ #;Nil (#;Some [tokens []]) _ #;None)) -## Syntax +## [Syntax] (defmacro #export (defsyntax tokens) - (let [[exported? tokens] (: (, Bool (List Syntax)) - (case tokens - (\ (list& (#;Meta [_ (#;TagS ["" "export"])]) tokens')) - [true tokens'] + (let [[exported? tokens] (case tokens + (\ (@list& [_ (#;TagS ["" "export"])] tokens')) + [true tokens'] - _ - [false tokens]))] + _ + [false tokens])] (case tokens - (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))]) - body)) + (\ (@list [_ (#;FormS (@list& [_ (#;SymbolS ["" name])] args))] + body)) (do Lux/Monad - [names+parsers (M;map% Lux/Monad - (: (-> Syntax (Lux (, Syntax Syntax))) - (lambda [arg] - (case arg - (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)]) - parser))])) - (M;wrap [(symbol$ var-name) parser]) - - (\ (#;Meta [_ (#;SymbolS var-name)])) - (M;wrap [(symbol$ var-name) (` id^)]) - - _ - (l;fail "Syntax pattern expects 2-tuples or symbols.")))) - args) + [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 [names (:: List/Functor (F;map first names+parsers)) - error-msg (text$ (text:++ "Wrong syntax for " name)) - body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + #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) + (` (;_lux_case ((~ parser) (~ g!tokens)) + (#;Some [(~ g!tokens) (~ name)]) + (~ body) - (~ g!_) - (l;fail (~ error-msg))))))) + (~ g!_) + (l;fail (~ error-msg))))))) body - (: (List (, Syntax Syntax)) (list& [(symbol$ ["" ""]) (` end^)] (reverse names+parsers)))) - macro-def (: Syntax - (` (m;defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) - (~ body'))))]] - (M;wrap (list& macro-def - (if exported? - (list (` (_lux_export (~ (symbol$ ["" name]))))) - (list))))) + (: (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 new file mode 100644 index 000000000..0938d104d --- /dev/null +++ b/source/lux/meta/type.lux @@ -0,0 +1,193 @@ +## 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)) |