aboutsummaryrefslogtreecommitdiff
path: root/source
diff options
context:
space:
mode:
Diffstat (limited to 'source')
-rw-r--r--source/lux.lux181
1 files changed, 113 insertions, 68 deletions
diff --git a/source/lux.lux b/source/lux.lux
index 111aac611..637c4607f 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -22,6 +22,9 @@
(def' Void (#VariantT #Nil))
(export' Void)
+(def' Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])])))
+(export' Ident)
+
## (deftype (List a)
## (| #Nil
## (#Cons (, a (List a)))))
@@ -137,23 +140,20 @@
Syntax
(case' (#AppT [List Syntax])
SyntaxList
- (case' (#TupleT (#Cons [Text (#Cons [Text #Nil])]))
- Ident
- (#AllT [#None "Syntax'" "w"
- (#VariantT (#Cons [["lux;Bool" Bool]
- (#Cons [["lux;Int" Int]
- (#Cons [["lux;Real" Real]
- (#Cons [["lux;Char" Char]
- (#Cons [["lux;Text" Text]
- (#Cons [["lux;Symbol" Ident]
- (#Cons [["lux;Tag" Ident]
- (#Cons [["lux;Form" SyntaxList]
- (#Cons [["lux;Tuple" SyntaxList]
- (#Cons [["lux;Record" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])]
- #Nil])
- ])])])])])])])])])
- )])
- ))))
+ (#AllT [#None "Syntax'" "w"
+ (#VariantT (#Cons [["lux;Bool" Bool]
+ (#Cons [["lux;Int" Int]
+ (#Cons [["lux;Real" Real]
+ (#Cons [["lux;Char" Char]
+ (#Cons [["lux;Text" Text]
+ (#Cons [["lux;Symbol" Ident]
+ (#Cons [["lux;Tag" Ident]
+ (#Cons [["lux;Form" SyntaxList]
+ (#Cons [["lux;Tuple" SyntaxList]
+ (#Cons [["lux;Record" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])]
+ #Nil])
+ ])])])])])])])])])
+ )]))))
(export' Syntax')
## (deftype Syntax
@@ -209,13 +209,15 @@
## (deftype (DefData' m)
## (| #TypeD
## (#ValueD Type)
-## (#MacroD m)))
+## (#MacroD m)
+## (#AliasD Ident)))
(def' DefData'
(#AllT [#None "DefData'" ""
(#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)]
(#Cons [["lux;ValueD" Type]
(#Cons [["lux;MacroD" (#BoundT "")]
- #Nil])])]))]))
+ (#Cons [["lux;AliasD" Ident]
+ #Nil])])])]))]))
## (deftype #rec CompilerState
## (& #source (Maybe Reader)
@@ -297,10 +299,6 @@
(lambda' _ state
(#Left msg)))))
-(def' Ident
- (#TupleT (#Cons [Text (#Cons [Text #Nil])])))
-(export' Ident)
-
(def' $text
(:' (#LambdaT [Text Syntax])
(lambda' _ text
@@ -835,7 +833,6 @@
(wrap-meta ($form (list ($tag ["lux" "Text"]) (_meta (#Text value)))))
(#Meta [_ (#Tag [module name])])
- (case' name)
(let [module' (case' module
""
subst
@@ -1191,39 +1188,6 @@
(let [[module name] ident]
($ text:++ module ";" name)))
-(defmacro #export (| tokens)
- (do Lux:Monad
- [pairs (map% Lux:Monad
- (:' (-> Syntax ($' Lux Syntax))
- (lambda [token]
- (case' token
- (#Meta [_ (#Tag ident)])
- (;return (:' Syntax (`' [(~ ($text (ident->text ident))) (;,)])))
-
- (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag ident)]) (#Cons [value #Nil])]))])
- (;return (:' Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))
-
- _
- (fail "Wrong syntax for |"))))
- tokens)]
- (;return (:' SyntaxList (list (`' (#;VariantT (;list (~@ pairs)))))))))
-
-(defmacro #export (& tokens)
- (if (not (multiple? 2 (length tokens)))
- (fail "& expects an even number of arguments.")
- (do Lux:Monad
- [pairs (map% Lux:Monad
- (:' (-> (, Syntax Syntax) ($' Lux Syntax))
- (lambda [pair]
- (case' pair
- [(#Meta [_ (#Tag ident)]) value]
- (;return (:' Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))
-
- _
- (fail "Wrong syntax for &"))))
- (as-pairs tokens))]
- (;return (:' SyntaxList (list (`' (#;RecordT (;list (~@ pairs))))))))))
-
(def__ (replace-syntax reps syntax)
(-> RepEnv Syntax Syntax)
(case' syntax
@@ -1352,6 +1316,45 @@
_
(#Right [state ident])))
+(defmacro #export (| tokens)
+ (do Lux:Monad
+ [pairs (map% Lux:Monad
+ (:' (-> Syntax ($' Lux Syntax))
+ (lambda [token]
+ (case' token
+ (#Meta [_ (#Tag ident)])
+ (do Lux:Monad
+ [ident (normalize ident)]
+ (;return (:' Syntax (`' [(~ ($text (ident->text ident))) (;,)]))))
+
+ (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag ident)]) (#Cons [value #Nil])]))])
+ (do Lux:Monad
+ [ident (normalize ident)]
+ (;return (:' Syntax (`' [(~ ($text (ident->text ident))) (~ value)]))))
+
+ _
+ (fail "Wrong syntax for |"))))
+ tokens)]
+ (;return (:' SyntaxList (list (`' (#;VariantT (;list (~@ pairs)))))))))
+
+(defmacro #export (& tokens)
+ (if (not (multiple? 2 (length tokens)))
+ (fail "& expects an even number of arguments.")
+ (do Lux:Monad
+ [pairs (map% Lux:Monad
+ (:' (-> (, Syntax Syntax) ($' Lux Syntax))
+ (lambda [pair]
+ (case' pair
+ [(#Meta [_ (#Tag ident)]) value]
+ (do Lux:Monad
+ [ident (normalize ident)]
+ (;return (:' Syntax (`' [(~ ($text (ident->text ident))) (~ value)]))))
+
+ _
+ (fail "Wrong syntax for &"))))
+ (as-pairs tokens))]
+ (;return (:' SyntaxList (list (`' (#;RecordT (;list (~@ pairs))))))))))
+
(def__ (->text x)
(-> (^ java.lang.Object) Text)
(jvm-invokevirtual java.lang.Object toString [] x []))
@@ -1674,11 +1677,22 @@
[inc 1]
[dec -1])
-(def #export (int:show int)
+(def (int:show int)
(-> Int Text)
(jvm-invokevirtual java.lang.Object toString []
int []))
+(defmacro #export (` tokens)
+ (do Lux:Monad
+ [module-name get-module-name]
+ (case tokens
+ (\ (list template))
+ (;return (: (List Syntax)
+ (list (untemplate (: Text module-name) template))))
+
+ _
+ (fail "Wrong syntax for `"))))
+
(def #export (gensym prefix state)
(-> Text (Lux Syntax))
(case state
@@ -1842,16 +1856,47 @@
[Real:Show Real (->text x)]
[Char:Show Char ($ text:++ "#\"" (->text x) "\"")])
-(defmacro #export (` tokens)
- (do Lux:Monad
- [module-name get-module-name]
- (case tokens
- (\ (list template))
- (;return (: (List Syntax)
- (list (untemplate (: Text module-name) template))))
-
- _
- (fail "Wrong syntax for `"))))
+(defsig #export (Ord a)
+ (: (-> a a Bool)
+ <)
+ (: (-> a a Bool)
+ <=)
+ (: (-> a a Bool)
+ >)
+ (: (-> a a Bool)
+ >=))
+
+(do-template [<name> <form> <message>]
+ [(defmacro #export (<name> tokens)
+ (case (reverse tokens)
+ (\ (list& last init))
+ (return (: (List Syntax)
+ (list (fold (: (-> Syntax Syntax Syntax)
+ (lambda [post pre] (` <form>)))
+ last
+ init))))
+
+ _
+ (fail <message>)))]
+
+ [and (if (~ pre) true (~ post)) "and requires >=1 elements."]
+ [or (if (~ pre) (~ post) false) "or requires >=1 elements."])
+
+(do-template [<name> <type> <lt> <gt> <eq>]
+ [(defstruct #export <name> (Ord <type>)
+ (def (< x y)
+ (<lt> x y))
+ (def (<= x y)
+ (or (<lt> x y)
+ (<eq> x y)))
+ (def (> x y)
+ (<gt> x y))
+ (def (>= x y)
+ (or (<gt> x y)
+ (<eq> x y))))]
+
+ [Int:Ord Int jvm-llt jvm-lgt jvm-leq]
+ [Real:Ord Real jvm-dlt jvm-dgt jvm-deq])
## (def #export (print x)
## (-> Text (IO (,)))
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-13 02:16:40 +0000