aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--source/lux.lux16
-rw-r--r--source/lux/control/enum.lux25
-rw-r--r--source/lux/control/fold.lux42
-rw-r--r--source/lux/control/monad.lux51
-rw-r--r--source/lux/data/ident.lux33
-rw-r--r--source/lux/data/list.lux88
-rw-r--r--source/lux/data/maybe.lux3
-rw-r--r--source/lux/data/text.lux14
-rw-r--r--source/lux/data/tuple.lux3
-rw-r--r--source/lux/math.lux22
-rw-r--r--source/lux/meta/ast.lux72
-rw-r--r--source/program.lux5
-rw-r--r--src/lux/parser.clj49
-rw-r--r--src/lux/type.clj6
14 files changed, 350 insertions, 79 deletions
diff --git a/source/lux.lux b/source/lux.lux
index 5f5c6925b..164dea835 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -2932,23 +2932,23 @@
_
(fail "Can only \"use\" records.")))
+
+ [_ (#TupleS members)]
+ (return (@list (foldL (: (-> AST AST AST)
+ (lambda [body' struct'] (` (;;using (~ struct') (~ body')))))
+ body
+ members)))
_
(let [dummy (symbol$ ["" ""])]
(return (@list (` (;_lux_case (~ struct)
(~ dummy)
- (;using (~ dummy)
- (~ body))))))))
+ (;;using (~ dummy)
+ (~ body))))))))
_
(fail "Wrong syntax for using")))
-(def (flip f)
- (All [a b c]
- (-> (-> a b c) (-> b a c)))
- (lambda [y x]
- (f x y)))
-
(defmacro #export (cond tokens)
(if (i= 0 (i% (length tokens) 2))
(fail "cond requires an even number of arguments.")
diff --git a/source/lux/control/enum.lux b/source/lux/control/enum.lux
new file mode 100644
index 000000000..34910c837
--- /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) pre))
+
+## [Functions]
+(def #export (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/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/monad.lux b/source/lux/control/monad.lux
index 8e59ae941..b286545a7 100644
--- a/source/lux/control/monad.lux
+++ b/source/lux/control/monad.lux
@@ -6,8 +6,7 @@
(;import lux
(.. (functor #as F)
(monoid #as M))
- (lux/meta macro
- ast))
+ (lux/meta macro))
## [Utils]
(def (foldL f init xs)
@@ -17,21 +16,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))
@@ -50,10 +49,9 @@
## [Syntax]
(defmacro #export (do tokens state)
(case tokens
- ## (\ (list monad [_ (#;TupleS bindings)] body))
- (#;Cons [monad (#;Cons [[_ (#;TupleS bindings)] (#;Cons [body #;Nil])])])
- (let [g!map (symbol$ ["" " map "])
- g!join (symbol$ ["" " join "])
+ (#;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]
@@ -82,16 +80,31 @@
(using m
(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))))
+ ## (seq% monad (:: monad ;;_functor (F;map f xs)))
(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/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/list.lux b/source/lux/data/list.lux
index 489ac5b4f..b2049d419 100644
--- a/source/lux/data/list.lux
+++ b/source/lux/data/list.lux
@@ -8,7 +8,8 @@
(functor #as F #refer #all)
(monad #as M #refer #all)
(eq #as E)
- (ord #as O))
+ (ord #as O)
+ (fold #as f))
(data (number (int #open ("i" Int/Number Int/Ord)))
bool)
meta/macro))
@@ -39,6 +40,23 @@
(#;Cons [x xs'])
(f x (foldR f init xs'))))
+(defstruct #export List/Fold (f;Fold List)
+ (def (foldL f init xs)
+ (case xs
+ #;Nil
+ init
+
+ (#;Cons [x xs'])
+ (foldL f (f init x) xs')))
+
+ (def (foldR f init xs)
+ (case xs
+ #;Nil
+ init
+
+ (#;Cons [x xs'])
+ (f x (foldR f init xs')))))
+
(def #export (fold mon xs)
(All [a]
(-> (m;Monoid a) (List a) a))
@@ -224,13 +242,75 @@
(case (reverse xs)
(#;Cons last init)
(#;Right state (@list (foldL (: (-> AST AST AST)
- (lambda [tail head] (` (#;Cons (~ head) (~ tail)))))
- last
- init)))
+ (lambda [tail head] (` (#;Cons (~ head) (~ tail)))))
+ last
+ init)))
_
(#;Left "Wrong syntax for @list&")))
+## (defmacro #export (zip tokens state)
+## (if (i> (size tokens) 0)
+## (using List/Functor
+## (let [indices (range 0 (i+ 1 (size tokens)))
+## vars+lists (map (lambda [idx]
+## (let [base (text:++ "_" idx)]
+## [[["" -1 -1] (#SymbolS "" base)]
+## [["" -1 -1] (#SymbolS "" (text:++ base "s"))]]))
+## indices)
+## pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs))))
+## vars+lists))])
+## g!step [["" -1 -1] (#SymbolS "" "\tstep\t")]
+## g!arg [["" -1 -1] (#SymbolS "" "\targ\t")]
+## g!blank [["" -1 -1] (#SymbolS "" "\t_\t")]
+## code (` ((lambda (~ g!step) [(~ g!arg)]
+## (case (~ g!arg)
+## (~ pattern)
+## (#;Cons [(~@ vars)] ((~ g!step) [(~ (map second vars))]))
+
+## (~ g!blank)
+## #;Nil))
+## [(~@ tokens)]))]
+## (#;Right state (@list code))))
+## (#;Left "Can't zip no lists.")))
+
+## (defmacro #export (zip-with tokens state)
+## (case tokens
+## (@list& _f tokens)
+## (case _f
+## [_ (#;SymbolS _)]
+## (if (i> (size tokens) 0)
+## (using List/Functor
+## (let [indices (range 0 (i+ 1 (size tokens)))
+## vars+lists (map (lambda [idx]
+## (let [base (text:++ "_" idx)]
+## [[["" -1 -1] (#SymbolS "" base)]
+## [["" -1 -1] (#SymbolS "" (text:++ base "s"))]]))
+## indices)
+## pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs))))
+## vars+lists))])
+## g!step [["" -1 -1] (#SymbolS "" "\tstep\t")]
+## g!arg [["" -1 -1] (#SymbolS "" "\targ\t")]
+## g!blank [["" -1 -1] (#SymbolS "" "\t_\t")]
+## code (` ((lambda (~ g!step) [(~ g!arg)]
+## (case (~ g!arg)
+## (~ pattern)
+## (#;Cons ((~ _f) (~@ vars)) ((~ g!step) [(~ (map second vars))]))
+
+## (~ g!blank)
+## #;Nil))
+## [(~@ tokens)]))]
+## (#;Right state (@list code))))
+## (#;Left "Can't zip-with no lists."))
+
+## _
+## (let [g!temp [["" -1 -1] (#SymbolS "" "\ttemp\t")]]
+## (#;Right state (@list (` (let [(~ g!temp) (~ _f)]
+## (;;zip-with (~@ (@list& g!temp tokens)))))))))
+
+## _
+## (#;Left "Wrong syntax for zip-with")))
+
## [Structures]
## (defstruct #export (List/Eq eq) (All [a] (-> (Eq a) (Eq (List a))))
## (def (= xs ys)
diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux
index 7c0affd68..2db3d768d 100644
--- a/source/lux/data/maybe.lux
+++ b/source/lux/data/maybe.lux
@@ -4,8 +4,7 @@
## You can obtain one at http://mozilla.org/MPL/2.0/.
(;import lux
- (lux (meta macro
- ast)
+ (lux (meta macro)
(control (monoid #as m #refer #all)
(functor #as F #refer #all)
(monad #as M #refer #all)))
diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux
index e54dff5c0..f701f6079 100644
--- a/source/lux/data/text.lux
+++ b/source/lux/data/text.lux
@@ -4,8 +4,7 @@
## You can obtain one at http://mozilla.org/MPL/2.0/.
(;import lux
- (lux (meta macro
- ast)
+ (lux (meta macro)
(control (monoid #as m)
(eq #as E)
(ord #as O)
@@ -151,9 +150,18 @@
[_ in] (split 2 in)
post-idx (index-of "}" in)
[var post] (split post-idx in)
- [_ post] (split 1 post)]
+ #let [[_ post] (? (: (, Text Text) ["" ""])
+ (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)
diff --git a/source/lux/data/tuple.lux b/source/lux/data/tuple.lux
index f89f9b5ee..6eef74670 100644
--- a/source/lux/data/tuple.lux
+++ b/source/lux/data/tuple.lux
@@ -24,8 +24,7 @@
(def #export (uncurry f)
(All [a b c]
- (-> (-> a b c)
- (-> (, a b) c)))
+ (-> (-> a b c) (-> (, a b) c)))
(lambda [xy]
(let [[x y] xy]
(f x y))))
diff --git a/source/lux/math.lux b/source/lux/math.lux
index f6fad566f..0f247cea8 100644
--- a/source/lux/math.lux
+++ b/source/lux/math.lux
@@ -3,7 +3,8 @@
## 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>]
@@ -58,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 (: (, Int Int) [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
index a601739a1..78882c854 100644
--- a/source/lux/meta/ast.lux
+++ b/source/lux/meta/ast.lux
@@ -3,7 +3,17 @@
## 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 (control (show #as S #refer #all)
+ (eq #as E #refer #all))
+ (data bool
+ (number int
+ real)
+ char
+ (text #refer #all #open ("text:" Text/Monoid))
+ ident
+ (list #refer (#only List interpose) #open ("" List/Functor List/Fold))
+ )))
## [Types]
## (deftype (AST' w)
@@ -41,3 +51,63 @@
[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> (S;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 (S;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 (eq x y)
+## (case [x y]
+## (\template [<tag> <struct>]
+## [[(<tag> x') (<tag> y')]
+## (:: <struct> (E;eq 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 (E;= (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 (E;= (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/program.lux b/source/program.lux
index 69b9e811d..140710a4a 100644
--- a/source/program.lux
+++ b/source/program.lux
@@ -13,7 +13,8 @@
hash
(ord #as O)
(show #as S)
- number)
+ number
+ enum)
(data bool
char
(either #as e)
@@ -21,7 +22,7 @@
io
list
maybe
- (number (int #refer (#only))
+ (number (int #refer (#only) #open ("i:" Int/Show))
(real #refer (#only)))
(text #refer (#only <>) #open ("text:" Text/Monoid))
(writer #refer (#only))
diff --git a/src/lux/parser.clj b/src/lux/parser.clj
index 2609bf9a5..dbd6ca2c5 100644
--- a/src/lux/parser.clj
+++ b/src/lux/parser.clj
@@ -10,25 +10,6 @@
(lux [base :as & :refer [deftags |do return fail |case]]
[lexer :as &lexer])))
-;; [Tags]
-(deftags ""
- "White_Space"
- "Comment"
- "Bool"
- "Int"
- "Real"
- "Char"
- "Text"
- "Symbol"
- "Tag"
- "Open_Paren"
- "Close_Paren"
- "Open_Bracket"
- "Close_Bracket"
- "Open_Brace"
- "Close_Brace"
- )
-
;; [Utils]
(do-template [<name> <close-tag> <description> <tag>]
(defn <name> [parse]
@@ -41,8 +22,8 @@
_
(fail (str "[Parser Error] Unbalanced " <description> ".")))))
- ^:private parse-form $Close_Paren "parantheses" &/$FormS
- ^:private parse-tuple $Close_Bracket "brackets" &/$TupleS
+ ^:private parse-form &lexer/$Close_Paren "parantheses" &/$FormS
+ ^:private parse-tuple &lexer/$Close_Bracket "brackets" &/$TupleS
)
(defn ^:private parse-record [parse]
@@ -50,7 +31,7 @@
token &lexer/lex
:let [elems (&/fold &/|++ (&/|list) elems*)]]
(|case token
- [meta ($Close_Brace _)]
+ [meta (&lexer/$Close_Brace _)]
(if (even? (&/|length elems))
(return (&/V &/$RecordS (&/|as-pairs elems)))
(fail (str "[Parser Error] Records must have an even number of elements.")))
@@ -63,42 +44,42 @@
(|do [token &lexer/lex
:let [[meta token*] token]]
(|case token*
- ($White_Space _)
+ (&lexer/$White_Space _)
(return (&/|list))
- ($Comment _)
+ (&lexer/$Comment _)
(return (&/|list))
- ($Bool ?value)
+ (&lexer/$Bool ?value)
(return (&/|list (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value)))))
- ($Int ?value)
+ (&lexer/$Int ?value)
(return (&/|list (&/T meta (&/V &/$IntS (Long/parseLong ?value)))))
- ($Real ?value)
+ (&lexer/$Real ?value)
(return (&/|list (&/T meta (&/V &/$RealS (Double/parseDouble ?value)))))
- ($Char ^String ?value)
+ (&lexer/$Char ^String ?value)
(return (&/|list (&/T meta (&/V &/$CharS (.charAt ?value 0)))))
- ($Text ?value)
+ (&lexer/$Text ?value)
(return (&/|list (&/T meta (&/V &/$TextS ?value))))
- ($Symbol ?ident)
+ (&lexer/$Symbol ?ident)
(return (&/|list (&/T meta (&/V &/$SymbolS ?ident))))
- ($Tag ?ident)
+ (&lexer/$Tag ?ident)
(return (&/|list (&/T meta (&/V &/$TagS ?ident))))
- ($Open_Paren _)
+ (&lexer/$Open_Paren _)
(|do [syntax (parse-form parse)]
(return (&/|list (&/T meta syntax))))
- ($Open_Bracket _)
+ (&lexer/$Open_Bracket _)
(|do [syntax (parse-tuple parse)]
(return (&/|list (&/T meta syntax))))
- ($Open_Brace _)
+ (&lexer/$Open_Brace _)
(|do [syntax (parse-record parse)]
(return (&/|list (&/T meta syntax))))
diff --git a/src/lux/type.clj b/src/lux/type.clj
index 82eab3dd4..8300d470c 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -724,9 +724,9 @@
(fn [state]
(|case ((|do [F1 (deref ?eid)]
(fn [state]
- (|case [((|do [F2 (deref ?aid)]
- (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2)))
- state)]
+ (|case ((|do [F2 (deref ?aid)]
+ (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2)))
+ state)
(&/$Right state* output)
(return* state* output)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 15:46:44 +0000