aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--source/lux.lux2396
-rw-r--r--src/lux/analyser.clj3
-rw-r--r--src/lux/analyser/lux.clj195
-rw-r--r--src/lux/analyser/module.clj5
-rw-r--r--src/lux/base.clj31
-rw-r--r--src/lux/compiler.clj2
-rw-r--r--src/lux/compiler/case.clj4
-rw-r--r--src/lux/compiler/lux.clj22
-rw-r--r--src/lux/lexer.clj5
-rw-r--r--src/lux/macro.clj25
-rw-r--r--src/lux/parser.clj22
-rw-r--r--src/lux/type.clj36
12 files changed, 1483 insertions, 1263 deletions
diff --git a/source/lux.lux b/source/lux.lux
index 36e678886..973d5727b 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -77,15 +77,14 @@
## (& #counter Int
## #mappings (List (, k v))))
(def' Bindings
- (:' Type
- (#AllT [#None "Bindings" "k"
- (#AllT [#None "" "v"
- (#RecordT (#Cons [["lux;counter" Int]
- (#Cons [["lux;mappings" (#AppT [List
- (#TupleT (#Cons [(#BoundT "k")
- (#Cons [(#BoundT "v")
- #Nil])]))])]
- #Nil])]))])])))
+ (#AllT [#None "Bindings" "k"
+ (#AllT [#None "" "v"
+ (#RecordT (#Cons [["lux;counter" Int]
+ (#Cons [["lux;mappings" (#AppT [List
+ (#TupleT (#Cons [(#BoundT "k")
+ (#Cons [(#BoundT "v")
+ #Nil])]))])]
+ #Nil])]))])]))
## (deftype (Env k v)
## (& #name Text
@@ -93,42 +92,38 @@
## #locals (Bindings k v)
## #closure (Bindings k v)))
(def' Env
- (:' Type
- (#AllT [#None "Env" "k"
- (#AllT [#None "" "v"
- (#RecordT (#Cons [["lux;name" Text]
- (#Cons [["lux;inner-closures" Int]
- (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")])
- (#BoundT "v")])]
- (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")])
- (#BoundT "v")])]
- #Nil])])])]))])])))
+ (#AllT [#None "Env" "k"
+ (#AllT [#None "" "v"
+ (#RecordT (#Cons [["lux;name" Text]
+ (#Cons [["lux;inner-closures" Int]
+ (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")])
+ (#BoundT "v")])]
+ (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")])
+ (#BoundT "v")])]
+ #Nil])])])]))])]))
## (deftype Cursor
## (, Text Int Int))
(def' Cursor
- (:' Type
- (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))))
+ (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])])))
## (deftype (Meta m v)
## (| (#Meta (, m v))))
(def' Meta
- (:' Type
- (#AllT [#None "Meta" "m"
- (#AllT [#None "" "v"
- (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m")
- (#Cons [(#BoundT "v")
- #Nil])]))]
- #Nil]))])])))
+ (#AllT [#None "Meta" "m"
+ (#AllT [#None "" "v"
+ (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m")
+ (#Cons [(#BoundT "v")
+ #Nil])]))]
+ #Nil]))])]))
(export' Meta)
## (def' Reader
## (List (Meta Cursor Text)))
(def' Reader
- (:' Type
- (#AppT [List
- (#AppT [(#AppT [Meta Cursor])
- Text])])))
+ (#AppT [List
+ (#AppT [(#AppT [Meta Cursor])
+ Text])]))
(export' Reader)
## (deftype HostState
@@ -136,11 +131,10 @@
## #loader (^ java.net.URLClassLoader)
## #eval-ctor Int))
(def' HostState
- (:' Type
- (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")]
- (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")]
- (#Cons [["lux;eval-ctor" Int]
- #Nil])])]))))
+ (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")]
+ (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")]
+ (#Cons [["lux;eval-ctor" Int]
+ #Nil])])])))
## (deftype CompilerState
## (& #source (Maybe Reader)
@@ -150,14 +144,13 @@
## #types (Bindings Int Type)
## #host HostState))
(def' CompilerState
- (:' Type
- (#RecordT (#Cons [["lux;source" (#AppT [Maybe Reader])]
- (#Cons [["lux;modules" (#AppT [List Void])]
- (#Cons [["lux;module-aliases" (#AppT [List Void])]
- (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) Void])])]
- (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])]
- (#Cons [["lux;host" HostState]
- #Nil])])])])])]))))
+ (#RecordT (#Cons [["lux;source" (#AppT [Maybe Reader])]
+ (#Cons [["lux;modules" (#AppT [List Void])]
+ (#Cons [["lux;module-aliases" (#AppT [List Void])]
+ (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) Void])])]
+ (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])]
+ (#Cons [["lux;host" HostState]
+ #Nil])])])])])])))
(export' CompilerState)
## (deftype (Syntax' w)
@@ -170,41 +163,39 @@
## (#Tag (, Text Text))
## (#Form (List (w (Syntax' w))))
## (#Tuple (List (w (Syntax' w))))
-## (#Record (List (, Text (w (Syntax' w)))))))
+## (#Record (List (, (w (Syntax' w)) (w (Syntax' w)))))))
(def' Syntax'
- (:' Type
- (case' (#AppT [(#BoundT "w")
- (#AppT [(#BoundT "Syntax'")
- (#BoundT "w")])])
- Syntax'
- (case' (#AppT [List Syntax'])
- Syntax'List
- (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" Syntax'List]
- (#Cons [["lux;Tuple" Syntax'List]
- (#Cons [["lux;Record" (#AppT [List (#TupleT (#Cons [Text (#Cons [Syntax' #Nil])]))])]
- #Nil])
- ])])])])])])])])])
- )])
- )))))
+ (case' (#AppT [(#BoundT "w")
+ (#AppT [(#BoundT "Syntax'")
+ (#BoundT "w")])])
+ Syntax'
+ (case' (#AppT [List Syntax'])
+ Syntax'List
+ (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" Syntax'List]
+ (#Cons [["lux;Tuple" Syntax'List]
+ (#Cons [["lux;Record" (#AppT [List (#TupleT (#Cons [Text (#Cons [Syntax' #Nil])]))])]
+ #Nil])
+ ])])])])])])])])])
+ )])
+ ))))
(export' Syntax')
## (deftype Syntax
## (Meta Cursor (Syntax' (Meta Cursor))))
(def' Syntax
- (:' Type
- (case' (#AppT [Meta Cursor])
- w
- (#AppT [w (#AppT [Syntax' w])]))))
+ (case' (#AppT [Meta Cursor])
+ w
+ (#AppT [w (#AppT [Syntax' w])])))
(export' Syntax)
(def' SyntaxList (#AppT [List Syntax]))
@@ -213,25 +204,23 @@
## (| (#Left l)
## (#Right r)))
(def' Either
- (:' Type
- (#AllT [#None "_" "l"
- (#AllT [#None "" "r"
- (#VariantT (#Cons [["lux;Left" (#BoundT "l")]
- (#Cons [["lux;Right" (#BoundT "r")]
- #Nil])]))])])))
+ (#AllT [#None "_" "l"
+ (#AllT [#None "" "r"
+ (#VariantT (#Cons [["lux;Left" (#BoundT "l")]
+ (#Cons [["lux;Right" (#BoundT "r")]
+ #Nil])]))])]))
(export' Either)
## (deftype Macro
## (-> (List Syntax) CompilerState
## (Either Text (, CompilerState (List Syntax)))))
(def' Macro
- (:' Type
- (#LambdaT [SyntaxList
- (#LambdaT [CompilerState
- (#AppT [(#AppT [Either Text])
- (#TupleT (#Cons [CompilerState
- (#Cons [SyntaxList
- #Nil])]))])])])))
+ (#LambdaT [SyntaxList
+ (#LambdaT [CompilerState
+ (#AppT [(#AppT [Either Text])
+ (#TupleT (#Cons [CompilerState
+ (#Cons [SyntaxList
+ #Nil])]))])])]))
(export' Macro)
## Base functions & macros
@@ -279,17 +268,40 @@
(lambda' _ state
(#Left msg)))))
-## (def' let'
-## (:' Macro
-## (lambda' _ tokens
-## (case' tokens
-## (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])])
-## (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "case'"]))
-## (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])))
-## #Nil]))
+(def' Ident
+ (#TupleT (#Cons [Text (#Cons [Text #Nil])])))
+(export' Ident)
+
+(def' $text
+ (:' (#LambdaT [Text Syntax])
+ (lambda' _ text
+ (_meta (#Text text)))))
+(export' $text)
+
+(def' $symbol
+ (:' (#LambdaT [Ident Syntax])
+ (lambda' _ ident
+ (_meta (#Symbol ident)))))
+(export' $symbol)
+
+(def' $tag
+ (:' (#LambdaT [Ident Syntax])
+ (lambda' _ ident
+ (_meta (#Tag ident)))))
+(export' $tag)
+
+(def' $form
+ (:' (#LambdaT [(#AppT [List Syntax]) Syntax])
+ (lambda' _ tokens
+ (_meta (#Form tokens)))))
+(export' $form)
+
+(def' $tuple
+ (:' (#LambdaT [(#AppT [List Syntax]) Syntax])
+ (lambda' _ tokens
+ (_meta (#Tuple tokens)))))
+(export' $tuple)
-## _
-## (#Left "Wrong syntax for let'")))))
(def' let'
(:' Macro
(lambda' _ tokens
@@ -303,7 +315,7 @@
_
(fail "Wrong syntax for let'")))))
-(def' lambda
+(def' lambda_
(:' Macro
(lambda' _ tokens
(case' tokens
@@ -317,7 +329,7 @@
body
_
- (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda"]))
+ (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"]))
(#Cons [(_meta (#Tuple args'))
(#Cons [body #Nil])])]))))
#Nil])])])])))
@@ -333,7 +345,7 @@
body
_
- (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda"]))
+ (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"]))
(#Cons [(_meta (#Tuple args'))
(#Cons [body #Nil])])]))))
#Nil])])])])))
@@ -341,80 +353,99 @@
_
(fail "Wrong syntax for lambda")))))
-(export' lambda)
-(def' def
+(def' def_
(:' Macro
- (lambda [tokens]
+ (lambda_ [tokens]
(case' tokens
- (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [body #Nil])])
- (return (:' SyntaxList
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) tokens])))
- #Nil])))
-
- (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))])
- (#Cons [body #Nil])])
+ (#Cons [(#Meta [_ (#Tag ["" "export"])])
+ (#Cons [(#Meta [_ (#Form (#Cons [name args]))])
+ (#Cons [type (#Cons [body #Nil])])])])
(return (:' SyntaxList
(#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"]))
- (#Cons [(_meta (#Symbol name))
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda"]))
- (#Cons [(_meta (#Symbol name))
- (#Cons [(_meta (#Tuple args))
- (#Cons [body #Nil])])])])))
+ (#Cons [name
+ (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"]))
+ (#Cons [type
+ (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"]))
+ (#Cons [name
+ (#Cons [(_meta (#Tuple args))
+ (#Cons [body #Nil])])])])))
+ #Nil])])])))
#Nil])])])))
- #Nil])))
+ (#Cons [(_meta (#Form (#Cons [($symbol ["" "export'"]) (#Cons [name #Nil])])))
+ #Nil])])))
- (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [type (#Cons [body #Nil])])])
+ (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])])
(return (:' SyntaxList
(#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"]))
- (#Cons [(_meta (#Symbol name))
+ (#Cons [name
(#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"]))
(#Cons [type
(#Cons [body
#Nil])])])))
#Nil])])])))
- #Nil])))
+ (#Cons [(_meta (#Form (#Cons [($symbol ["" "export'"]) (#Cons [name #Nil])])))
+ #Nil])])))
- (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))])
+ (#Cons [(#Meta [_ (#Form (#Cons [name args]))])
(#Cons [type (#Cons [body #Nil])])])
(return (:' SyntaxList
(#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"]))
- (#Cons [(_meta (#Symbol name))
+ (#Cons [name
(#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"]))
(#Cons [type
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda"]))
- (#Cons [(_meta (#Symbol name))
+ (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"]))
+ (#Cons [name
(#Cons [(_meta (#Tuple args))
(#Cons [body #Nil])])])])))
#Nil])])])))
#Nil])])])))
#Nil])))
+ (#Cons [name (#Cons [type (#Cons [body #Nil])])])
+ (return (:' SyntaxList
+ (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"]))
+ (#Cons [name
+ (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"]))
+ (#Cons [type
+ (#Cons [body
+ #Nil])])])))
+ #Nil])])])))
+ #Nil])))
+
_
(fail "Wrong syntax for def")
))))
-(export' def)
-(def (defmacro tokens)
+(def_ #export (defmacro tokens)
Macro
(case' tokens
- (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol fn-name)]) args]))])
- (#Cons [body #Nil])])
+ (#Cons [usage (#Cons [body #Nil])])
(return (:' SyntaxList
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "def"]))
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol fn-name)) args])))
- (#Cons [(_meta (#Symbol ["lux" "Macro"]))
+ (#Cons [(_meta (#Form (#Cons [($symbol ["lux" "def_"])
+ (#Cons [usage
+ (#Cons [($symbol ["lux" "Macro"])
(#Cons [body
#Nil])])
])])))
#Nil])))
+ (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [usage (#Cons [body #Nil])])])
+ (return (:' SyntaxList
+ (#Cons [(_meta (#Form (#Cons [($symbol ["lux" "def_"])
+ (#Cons [($tag ["" "export"])
+ (#Cons [usage
+ (#Cons [($symbol ["lux" "Macro"])
+ (#Cons [body
+ #Nil])])
+ ])])])))
+ #Nil])))
+
_
(fail "Wrong syntax for defmacro")))
-(defmacro (comment tokens)
+(defmacro #export (comment tokens)
(return (:' SyntaxList #Nil)))
-(export' comment)
(defmacro (->' tokens)
(case' tokens
@@ -494,7 +525,7 @@
_
(fail "Wrong syntax for $'")))
-(def (fold f init xs)
+(def_ #export (fold f init xs)
(All' [a b]
(->' (->' (B' a) (B' b) (B' a))
(B' a)
@@ -507,42 +538,119 @@
(#Cons [x xs'])
(fold f (f init x) xs')))
-(def (reverse list)
+(def_ #export (reverse list)
(All' [a]
(->' ($' List (B' a)) ($' List (B' a))))
(fold (:' (All' [a]
(->' ($' List (B' a)) (B' a) ($' List (B' a))))
- (lambda [tail head]
- (#Cons [head tail])))
+ (lambda_ [tail head]
+ (#Cons [head tail])))
#Nil
list))
-(defmacro (list xs)
+(defmacro #export (list xs)
(return (:' SyntaxList
(#Cons [(fold (:' (->' Syntax Syntax Syntax)
- (lambda [tail head]
- (_meta (#Form (#Cons [(_meta (#Tag ["lux" "Cons"]))
- (#Cons [(_meta (#Tuple (#Cons [head (#Cons [tail #Nil])])))
- #Nil])])))))
+ (lambda_ [tail head]
+ (_meta (#Form (#Cons [(_meta (#Tag ["lux" "Cons"]))
+ (#Cons [(_meta (#Tuple (#Cons [head (#Cons [tail #Nil])])))
+ #Nil])])))))
(_meta (#Tag ["lux" "Nil"]))
(reverse xs))
#Nil]))))
-(export' list)
-(defmacro (list& xs)
+(defmacro #export (list& xs)
(case' (reverse xs)
(#Cons [last init])
(return (:' SyntaxList
(list (fold (:' (->' Syntax Syntax Syntax)
- (lambda [tail head]
- (_meta (#Form (list (_meta (#Tag ["lux" "Cons"]))
- (_meta (#Tuple (list head tail))))))))
+ (lambda_ [tail head]
+ (_meta (#Form (list (_meta (#Tag ["lux" "Cons"]))
+ (_meta (#Tuple (list head tail))))))))
last
init))))
_
(fail "Wrong syntax for list&")))
-(export' list&)
+
+(defmacro #export (lambda tokens)
+ (let' [name tokens'] (:' (#TupleT (list Ident ($' List Syntax)))
+ (case' tokens
+ (#Cons [(#Meta [_ (#Symbol name)]) tokens'])
+ [name tokens']
+
+ _
+ [["" ""] tokens]))
+ (case' tokens'
+ (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])])
+ (case' args
+ #Nil
+ (fail "lambda requires a non-empty arguments tuple.")
+
+ (#Cons [harg targs])
+ (let' body' (fold (:' (->' Syntax Syntax Syntax)
+ (lambda_ [body' arg]
+ ($form (list ($symbol ["" "lambda'"])
+ ($symbol ["" ""])
+ arg
+ body'))))
+ body
+ (reverse targs))
+ (return (:' SyntaxList
+ (list ($form (list ($symbol ["" "lambda'"])
+ ($symbol name)
+ harg
+ body')))))))
+
+ _
+ (fail "Wrong syntax for lambda"))))
+
+(defmacro #export (def tokens)
+ (case' tokens
+ (#Cons [(#Meta [_ (#Tag ["" "export"])])
+ (#Cons [(#Meta [_ (#Form (#Cons [name args]))])
+ (#Cons [type (#Cons [body #Nil])])])])
+ (return (:' SyntaxList
+ (list ($form (list ($symbol ["" "def'"])
+ name
+ ($form (list ($symbol ["" ":'"])
+ type
+ ($form (list ($symbol ["lux" "lambda"])
+ name
+ ($tuple args)
+ body))))))
+ ($form (list ($symbol ["" "export'"]) name)))))
+
+ (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])])
+ (return (:' SyntaxList
+ (list ($form (list ($symbol ["" "def'"])
+ name
+ ($form (list ($symbol ["" ":'"])
+ type
+ body))))
+ ($form (list ($symbol ["" "export'"]) name)))))
+
+ (#Cons [(#Meta [_ (#Form (#Cons [name args]))])
+ (#Cons [type (#Cons [body #Nil])])])
+ (return (:' SyntaxList
+ (list ($form (list ($symbol ["" "def'"])
+ name
+ ($form (list ($symbol ["" ":'"])
+ type
+ ($form (list ($symbol ["lux" "lambda"])
+ name
+ ($tuple args)
+ body)))))))))
+
+ (#Cons [name (#Cons [type (#Cons [body #Nil])])])
+ (return (:' SyntaxList
+ (list ($form (list ($symbol ["" "def'"])
+ name
+ ($form (list ($symbol ["" ":'"]) type body)))))))
+
+ _
+ (fail "Wrong syntax for def")
+ ))
(def (as-pairs xs)
(All' [a]
@@ -554,7 +662,7 @@
_
#Nil))
-(defmacro (let tokens)
+(defmacro #export (let tokens)
(case' tokens
(#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])
(return (:' SyntaxList
@@ -574,9 +682,8 @@
_
(fail "Wrong syntax for let")))
-(export' let)
-(def (map f xs)
+(def #export (map f xs)
(All' [a b]
(->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b))))
(case' xs
@@ -586,11 +693,32 @@
(#Cons [x xs'])
(#Cons [(f x) (map f xs')])))
+(def #export (any? p xs)
+ (All' [a]
+ (->' (->' (B' a) Bool) ($' List (B' a)) Bool))
+ (case' xs
+ #Nil
+ false
+
+ (#Cons [x xs'])
+ (case' (p x)
+ true true
+ false (any? p xs'))))
+
+(def (spliced? token)
+ (->' Syntax Bool)
+ (case' token
+ (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [_ #Nil])]))])
+ true
+
+ _
+ false))
+
(def (wrap-meta content)
- (->' ($' Syntax' ($' Meta Cursor)) Syntax)
+ (->' Syntax Syntax)
(_meta (#Form (list (_meta (#Tag ["lux" "Meta"]))
(_meta (#Tuple (list (_meta (#Tuple (list (_meta (#Text "")) (_meta (#Int -1)) (_meta (#Int -1)))))
- (_meta content))))))))
+ content)))))))
(def (untemplate-list tokens)
(->' ($' List Syntax) Syntax)
@@ -602,48 +730,110 @@
(_meta (#Form (list (_meta (#Tag ["lux" "Cons"]))
(_meta (#Tuple (list token (untemplate-list tokens')))))))))
+## (def (untemplate token)
+## (->' Syntax Syntax)
+## (case' token
+## (#Meta [_ (#Bool value)])
+## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Bool"])) (_meta (#Bool value)))))
+
+## (#Meta [_ (#Int value)])
+## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Int"])) (_meta (#Int value)))))
+
+## (#Meta [_ (#Real value)])
+## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Real"])) (_meta (#Real value)))))
+
+## (#Meta [_ (#Char value)])
+## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Char"])) (_meta (#Char value)))))
+
+## (#Meta [_ (#Text value)])
+## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Text"])) (_meta (#Text value)))))
+
+## (#Meta [_ (#Tag [module name])])
+## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Tag"])) (_meta (#Tuple (list (_meta (#Text module)) (_meta (#Text name))))))))
+
+## (#Meta [_ (#Symbol [module name])])
+## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Symbol"])) (_meta (#Tuple (list (_meta (#Text module)) (_meta (#Text name))))))))
+
+## (#Meta [_ (#Tuple elems)])
+## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Tuple"])) (untemplate-list (map untemplate elems)))))
+
+## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~"])]) (#Cons [(#Meta [_ unquoted]) #Nil])]))])
+## (_meta unquoted)
+
+## (#Meta [_ (#Form elems)])
+## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Form"])) (untemplate-list (map untemplate elems)))))
+
+## (#Meta [_ (#Record fields)])
+## (wrap-meta (#Record (map (:' (->' (#TupleT (list Text Syntax)) (#TupleT (list Text Syntax)))
+## (lambda [kv]
+## (let [[k v] kv]
+## [k (untemplate v)])))
+## fields)))
+## ))
+
+(def (splice untemplate tag elems)
+ (->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax)
+ (case' (any? spliced? elems)
+ true
+ (let [elems' (map (:' (->' Syntax Syntax)
+ (lambda [elem]
+ (case' elem
+ (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [spliced #Nil])]))])
+ spliced
+
+ _
+ (_meta (#Form (list ($symbol ["lux" "list"]) elem))))))
+ elems)]
+ (wrap-meta ($form (list tag
+ (wrap-meta ($form (list& ($tag ["lux" "$"])
+ ($tag ["lux" "list:++"])
+ elems')))))))
+
+ false
+ (wrap-meta ($form (list tag (untemplate-list (map untemplate elems)))))))
+
(def (untemplate token)
(->' Syntax Syntax)
(case' token
(#Meta [_ (#Bool value)])
- (wrap-meta (#Form (list (_meta (#Tag ["lux" "Bool"])) (_meta (#Bool value)))))
+ (wrap-meta ($form (list (_meta (#Tag ["lux" "Bool"])) (_meta (#Bool value)))))
(#Meta [_ (#Int value)])
- (wrap-meta (#Form (list (_meta (#Tag ["lux" "Int"])) (_meta (#Int value)))))
+ (wrap-meta ($form (list (_meta (#Tag ["lux" "Int"])) (_meta (#Int value)))))
(#Meta [_ (#Real value)])
- (wrap-meta (#Form (list (_meta (#Tag ["lux" "Real"])) (_meta (#Real value)))))
+ (wrap-meta ($form (list (_meta (#Tag ["lux" "Real"])) (_meta (#Real value)))))
(#Meta [_ (#Char value)])
- (wrap-meta (#Form (list (_meta (#Tag ["lux" "Char"])) (_meta (#Char value)))))
+ (wrap-meta ($form (list (_meta (#Tag ["lux" "Char"])) (_meta (#Char value)))))
(#Meta [_ (#Text value)])
- (wrap-meta (#Form (list (_meta (#Tag ["lux" "Text"])) (_meta (#Text value)))))
+ (wrap-meta ($form (list (_meta (#Tag ["lux" "Text"])) (_meta (#Text value)))))
(#Meta [_ (#Tag [module name])])
- (wrap-meta (#Form (list (_meta (#Tag ["lux" "Tag"])) (_meta (#Tuple (list (_meta (#Text module)) (_meta (#Text name))))))))
+ (wrap-meta ($form (list (_meta (#Tag ["lux" "Tag"])) (_meta (#Tuple (list (_meta (#Text module)) (_meta (#Text name))))))))
(#Meta [_ (#Symbol [module name])])
- (wrap-meta (#Form (list (_meta (#Tag ["lux" "Symbol"])) (_meta (#Tuple (list (_meta (#Text module)) (_meta (#Text name))))))))
+ (wrap-meta ($form (list (_meta (#Tag ["lux" "Symbol"])) (_meta (#Tuple (list (_meta (#Text module)) (_meta (#Text name))))))))
(#Meta [_ (#Tuple elems)])
- (wrap-meta (#Form (list (_meta (#Tag ["lux" "Tuple"])) (untemplate-list (map untemplate elems)))))
+ (splice untemplate ($tag ["lux" "Tuple"]) elems)
- (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~"])]) (#Cons [(#Meta [_ unquoted]) #Nil])]))])
- (_meta unquoted)
+ (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~"])]) (#Cons [unquoted #Nil])]))])
+ unquoted
(#Meta [_ (#Form elems)])
- (wrap-meta (#Form (list (_meta (#Tag ["lux" "Form"])) (untemplate-list (map untemplate elems)))))
+ (splice untemplate ($tag ["lux" "Form"]) elems)
(#Meta [_ (#Record fields)])
- (wrap-meta (#Record (map (:' (->' (#TupleT (list Text Syntax)) (#TupleT (list Text Syntax)))
- (lambda [kv]
- (let [[k v] kv]
- [k (untemplate v)])))
- fields)))
+ (wrap-meta (_meta (#Record (map (:' (->' (#TupleT (list Text Syntax)) (#TupleT (list Text Syntax)))
+ (lambda [kv]
+ (let [[k v] kv]
+ [k (untemplate v)])))
+ fields))))
))
-(defmacro (` tokens)
+(defmacro #export (` tokens)
(case' tokens
(#Cons [template #Nil])
(return (:' SyntaxList
@@ -651,9 +841,8 @@
_
(fail "Wrong syntax for `")))
-(export' `)
-(defmacro (if tokens)
+(defmacro #export (if tokens)
(case' tokens
(#Cons [test (#Cons [then (#Cons [else #Nil])])])
(return (:' SyntaxList
@@ -663,14 +852,56 @@
_
(fail "Wrong syntax for if")))
-(export' if)
-## (def (id x)
-## (All [a] (-> a a))
-## x)
-## (export' id)
+## (deftype (Lux a)
+## (-> CompilerState (Either Text (, CompilerState a))))
+(def #export Lux
+ Type
+ (All' [a]
+ (->' CompilerState ($' Either Text (#TupleT (list CompilerState (B' a)))))))
-## (defmacro (^ tokens)
+## (defsig (Monad m)
+## (: (All [a] (-> a (m a)))
+## return)
+## (: (All [a b] (-> (-> a (m b)) (m a) (m b)))
+## bind))
+(def' Monad
+ (All' [m]
+ (#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))]
+ ["lux;bind" (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b)))
+ ($' (B' m) (B' a))
+ ($' (B' m) (B' b))))]))))
+
+(def Maybe:Monad
+ ($' Monad Maybe)
+ {#lux;return
+ (lambda return [x]
+ (#Some x))
+
+ #lux;bind
+ (lambda [f ma]
+ (case' ma
+ #None #None
+ (#Some a) (f a)))})
+
+(def Lux:Monad
+ ($' Monad Lux)
+ {#lux;return
+ (lambda return [x]
+ (lambda [state]
+ (#Right [state x])))
+
+ #lux;bind
+ (lambda [f ma]
+ (lambda [state]
+ (case' (ma state)
+ (#Left msg)
+ (#Left msg)
+
+ (#Right [state' a])
+ (f a state'))))})
+
+## (defmacro #export (^ tokens)
## (case' tokens
## (#Cons [(#Meta [_ (#Symbol ["" class-name])]) #Nil])
## (return (:' SyntaxList
@@ -678,14 +909,8 @@
## _
## (fail "Wrong syntax for ^")))
-## (export' ^)
-## (defmacro (, tokens)
-## (return (:' SyntaxList
-## (list (` (#TupleT (list (~@ tokens))))))))
-## (export' ,)
-
-## (defmacro (-> tokens)
+## (defmacro #export (-> tokens)
## (case' (reverse tokens)
## (#Cons [output inputs])
## (return (:' SyntaxList
@@ -697,946 +922,913 @@
## _
## (fail "Wrong syntax for ->")))
-## (export' ->)
-
-## (defmacro (| members)
-## (let [members' (map (:' (->' Syntax Syntax)
-## (lambda [m]
-## (case' m
-## (#Meta [_ (#Tag [module name])])
-## (` [(~ ($ text-++ module ";" name)) (#Tuple (list))])
-
-## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag [module name])]) (#Cons [value #Nil])]))])
-## (` [(~ ($ text-++ module ";" name)) (~ value)]))))
-## members)]
-## (return (list (` (#VariantT (~ (untemplate-list members))))))))
-## (export' |)
-
-## (defmacro (& members)
-## (let [members' (map (:' (->' Syntax Syntax)
-## (lambda [m]
-## (case' m
-## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag [module name])]) (#Cons [value #Nil])]))])
-## (` [(~ ($ text-++ module ";" name)) (~ value)]))))
-## members)]
-## (return (list (` (#RecordT (~ (untemplate-list members))))))))
-## (export' &)
-
-## (def (text:= x y)
-## (-> Text Text Bool)
-## (jvm-invokevirtual java.lang.Object "equals" [java.lang.Object]
-## x [y]))
-
-## (def #export (int:+ x y)
-## (-> Int Int Int)
-## (jvm-ladd x y))
-
-## (def (replace-ident ident value syntax)
-## (-> (, Text Text) Syntax Syntax Syntax)
-## (let [[module name] ident]
-## (case' syntax
-## (#Meta [_ (#Symbol [?module ?name])])
-## (if (and (text:= module ?module)
-## (text:= name ?name))
-## value
-## syntax)
-
-## (#Meta [_ (#Form members)])
-## (_meta (#Form (map (replace-ident ident value) members)))
-
-## (#Meta [_ (#Tuple members)])
-## (_meta (#Tuple (map (replace-ident ident value) members)))
-
-## (#Meta [_ (#Record members)])
-## (_meta (#Record (map (lambda [kv]
-## (case' kv
-## [k v]
-## [k (replace-ident ident value v)]))
-## members)))
-
-## _
-## syntax)))
-
-## (defmacro (All tokens)
-## (let [[name args body] (case' tokens
-## (#Cons [(#Meta [_ (#Symbol ["" name])]) (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])])])
-## [name args body]
-
-## (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])])
-## ["" args body])
-## rolled (fold (:' (-> Syntax Syntax Syntax)
-## (lambda [body arg]
-## (case' arg
-## (#Meta [_ (#Symbol [arg-module arg-name])])
-## (` (#AllT #None "" (~ (_meta (#Text arg-name))) (~ (replace-ident [arg-module arg-name]
-## (` (#BoundT (~ (#Text ($ text:++ arg-module ";" arg-name)))))
-## body)))))))
-## body
-## args)]
-## (case' rolled
-## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag ["lux" "AllT"])]) (#Cons [env (#Cons [(#Meta [_ (#Text "")]) (#Cons [(#Meta [_ (#Text arg-name)]) (#Cons [body #Nil])])])])]))])
-## (return (list (` (#AllT (~ env) (~ (#Text name)) (~ (#Text arg-name))
-## (~ (replace-ident arg-name (` (#BoundT (~ (#Text name))))
-## body)))))))))
-## (export' All)
-
-## (defsig (Eq a)
-## (: (-> a a Bool)
-## =))
-
-## (defstruct Text:Eq (Eq Text)
-## (def = text=))
-
-## (defstruct Ident:Eq (Eq Ident)
-## (def (= x y)
-## (let [[m1 n1] x
-## [m2 n2] y]
-## (and (text:= m1 m2)
-## (text:= n1 n2)))))
-
-## (deftype (Dict k v)
-## (: (-> k v (Dict k v) (Dict k v))
-## put)
-## (: (-> k (Dict k v) (Maybe v))
-## get)
-## (: (-> k (Dict k v) (Dict k v))
-## remove))
-
-## (deftype (PList k v)
-## (| (#PList (, (Eq k) (List (, k v))))))
-
-## (def (some f xs)
-## (All [a b]
-## (-> (-> a (Maybe b)) (List a) (Maybe b)))
-## (case' xs
-## #Nil
-## #None
-
-## (#Cons [x xs'])
-## (if-let [y (f x)]
-## (#Some y)
-## (some f xs'))
-## ))
-
-## (defstruct PList:Dict (Dict PList)
-## (def (get k plist)
-## (let [(#PList [{#= =} kvs]) plist]
-## (some (:' (-> (, ))
-## (lambda [kv]
-## (let [[k' v'] kv]
-## (when (= k k')
-## v'))))
-## kvs))))
-
-## (deftype CompilerState
-## (& #source (Maybe Reader)
-## #modules (List Void)
-## #module-aliases (List Void)
-## #envs (List (Env Text Void))
-## #types (Bindings Int Type)
-## #writer (^ org.objectweb.asm.ClassWriter)
-## #loader (^ java.net.URLClassLoader)
-## #eval-ctor Int))
-## (deftype CompilerState
-## (& (#source (Maybe Reader))
-## (#modules (PList Text Void))
-## (#module-aliases (PList Text Text))
-## (#envs (List (Env Text Void)))
-## (#types (Bindings Int Type))
-## (#host (& (#writer (^ org.objectweb.asm.ClassWriter))
-## (#loader (^ java.net.URLClassLoader))
-## (#eval-ctor Int)))))
-## (def (find-macro ident)
-## (lambda [state]
-## (let [[module name] ident]
-## (case' state
-## {#source source #modules modules #module-aliases module-aliases
-## #envs envs #types types
-## #writer writer #loader loader #eval-ctor eval-ctor}
-## (when-let [bindings (get module modules)
-## bound (get name bindings)]
-## (case' bound
-## (#Macro macro)
-## (#Some macro)
-
-## _
-## #None))))))
-
-## (def (walk-type type)
-## (-> Syntax ($' Lux Syntax))
-## (case' type
-## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol sym)]) args]))])
-## (do' [macro' (find-macro sym)]
-## (case' macro'
-## (#Some macro)
-## (do' [expansion (macro args)]
-## (case' expansion
-## (#Cons [expansion' #Nil])
-## (walk-type expansion')
-
-## _
-## (fail "Macro can't expand to more than 1 output.")))
-
-## #None
-## (do' [args' (map% walk-type args)]
-## (return (fold (:' (-> Syntax Syntax Syntax)
-## (lambda [f a]
-## (` (#AppT [(~ f) (~ a)]))))
-## sym
-## args')))))
-
-## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag tag)]) args]))])
-## ...
-
-## (#Meta [_ (#Symbol _)])
-## (return type)
-
-## _
-## (fail "Wrong syntax for walk-type")))
-
-## (defmacro (->type tokens)
-## (case' tokens
-## (#Cons [type #Nil])
-## (do' [type' (walk-type type)]
-## (return (list type')))
-
-## _
-## (fail "Wrong syntax for ->type")))
-
-## (defmacro (: tokens)
-## (case' tokens
-## (#Cons [type (#Cons [value #Nil])])
-## (return (list (` (:' (->type (~ type)) (~ value)))))
-
-## _
-## (fail "Wrong syntax for :")))
-
-## (defmacro (:! tokens)
-## (case' tokens
-## (#Cons [type (#Cons [value #Nil])])
-## (return (list (` (:!' (->type (~ type)) (~ value)))))
-
-## _
-## (fail "Wrong syntax for :!")))
-
-
-
-## (def (print x)
-## (-> (^ java.lang.Object) [])
-## (jvm-invokevirtual java.io.PrintStream "print" [java.lang.Object]
-## (jvm-getstatic java.lang.System "out") [x]))
-
-## (def (println x)
-## (-> (^ java.lang.Object) [])
-## (jvm-invokevirtual java.io.PrintStream "println" [java.lang.Object]
-## (jvm-getstatic java.lang.System "out") [x]))
-
-## (deftype (IO a)
-## (-> (,) a))
-
-## (defmacro (io tokens)
-## (case' tokens
-## (#Cons [value #Nil])
-## (return (list (` (lambda [_] (~ value)))))))
-
-## (def (. f g)
-## (All [a b c]
-## (-> (-> b c) (-> a b) (-> a c)))
-## (lambda [x] (f (g x))))
-## (def (++ xs ys)
-## (All [a]
-## (-> (List a) (List a) (List a)))
-## (case' xs
-## #Nil
-## ys
-
-## (#Cons [x xs'])
-## (#Cons [x (++ xs' ys)])))
-
-## (def concat
-## (All [a]
-## (-> (List (List a)) (List a)))
-## (fold ++ #Nil))
-
-## (def flat-map
-## (All [a b]
-## (-> (-> a (List b)) (List a) (List b)))
-## (. concat map))
-
-## (def (filter p xs)
-## (All [a]
-## (-> (-> a Bool) (List a) (List a)))
-## (case' xs
-## #Nil
-## #Nil
-
-## (#Cons [x xs'])
-## (if (p x)
-## (#Cons [x (filter p xs')])
-## (filter p xs'))))
+## (defmacro #export (, tokens)
+## (return (:' SyntaxList
+## (list (` (#TupleT (list (~@ tokens))))))))
-## (deftype (Lux a)
-## (-> CompilerState (Either Text (, CompilerState a))))
+## (defmacro #export (| tokens)
+## (do Lux:Monad
+## [pairs (map% Lux:Monad
+## (lambda [token]
+## (case' token
+## (#Tag ident)
+## (;return (` [(~ ($text (ident->text ident))) (,)]))
+
+## (#Form (#Cons [(#Tag ident) (#Cons [value #Nil])]))
+## (;return (` [(~ ($text (ident->text ident))) (~ value)]))
+
+## _
+## (fail "Wrong syntax for |")))
+## tokens)]
+## (` (#VariantT (list (~@ pairs))))))
+
+## (defmacro #export (& tokens)
+## (if (not (int:= 2 (length tokens)))
+## (fail "& expects an even number of arguments.")
+## (do Lux:Monad
+## [pairs (map% Lux:Monad
+## (lambda [pair]
+## (case' pair
+## [(#Tag ident) value]
+## (;return (` [(~ ($text (ident->text ident))) (~ value)]))
+
+## _
+## (fail "Wrong syntax for &")))
+## (as-pairs tokens))]
+## (` (#RecordT (list (~@ pairs)))))))
+
+## (defmacro #export (All tokens)
+## (case' (:' (, Ident SyntaxList)
+## (case' tokens
+## (#Cons [(#Meta [_ (#Symbol self-ident)]) tokens'])
+## [self-ident tokens']
+
+## _
+## [["" ""] tokens]))
+## [self-ident tokens']
+## (case' tokens'
+## (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])])
+## (do Lux:Monad
+## [idents (map% Lux:Monad get-ident args)]
+## (case' idents
+## #Nil
+## (return (list body))
+
+## (#Cons [harg targs])
+## (let [replacements (map (:' (-> Ident (, Ident Syntax))
+## (lambda [ident]
+## (let [[module name] ident]
+## [ident (_meta (#Bound ($ text:++ module ";" name)))])))
+## (list& self-ident idents))
+## body' (fold (lambda [body' arg']
+## (let [[module name] arg']
+## (` (#AllT [#None "" (~ ($text ($ text:++ module ";" name)))
+## (~ body')]))))
+## (replace-syntax replacements body)
+## (reverse targs))
+## [smodule sname] self-ident
+## [amodule aname] harg]
+## (return (list (` (#AllT [#None (~ ($text ($ text:++ smodule ";" sname)))
+## (~ ($text ($ text:++ amodule ";" aname)))
+## (~ body')])))))))
+
+## _
+## (fail "Wrong syntax for All"))
+## ))
-## (def (return val)
-## (All [a]
-## (-> a (Lux a)))
-## (lambda [state]
-## (#Right [state val])))
+## (def (ident->text ident)
+## (->' Ident Text)
+## (let [[module name] ident]
+## ($ text:++ module ";" name)))
+
+## (def (map% monad f xs)
+## (All' [m a b]
+## (->' ($' Monad (B' m))
+## (->' (B' a) ($' (B' m) (B' b)))
+## ($' (B' m) ($' List (B' b)))))
+## (let [{#;return ;return #;bind ;bind} monad]
+## (case' xs
+## #Nil
+## (;return #Nil)
+
+## (#Cons [x xs'])
+## (do monad
+## [x' (f x)
+## xs'' (map% monad f xs')]
+## (;return (#Cons [x' xs'']))))))
-## (def (fail msg)
-## (All [a]
-## (-> Text (Lux a)))
-## (lambda [_]
-## (#Left msg)))
-
-## (def (bind f v)
-## (All [m a b] (-> (-> a (m b)) (m a) (m b)))
-## (lambda [state]
-## (case' (v state)
-## (#Right [state' x])
-## (f x state')
-
-## (#Left msg)
-## (#Left msg))))
-
-## (def (first pair)
-## (All [a b] (-> (, a b) a))
-## (case' pair
-## [f s]
-## f))
-
-## (def (second pair)
-## (All [a b] (-> (, a b) b))
-## (case' pair
-## [f s]
-## s))
-
-## (defmacro (loop tokens)
-## (case' tokens
-## (#Cons [bindings (#Cons [body #Nil])])
-## (let [pairs (as-pairs bindings)]
-## (return (list (#Form (#Cons [(` (lambda (~ (#Symbol ["lux" "recur"])) (~ (#Tuple (map first pairs)))
-## (~ body)))
-## (map second pairs)])))))))
-
-## (defmacro (export tokens)
-## (return (map (lambda [t] (` (export' (~ t))))
-## tokens)))
-
-## (defmacro (and tokens)
-## (let [as-if (case' tokens
-## #Nil
-## (` true)
-
-## (#Cons [init tests])
-## (fold (lambda [prev next]
-## (` (if (~ prev) (~ next) false)))
-## init
-## tokens)
-## )]
-## (return (list as-if))))
-
-## (defmacro (or tokens)
-## (let [as-if (case' tokens
-## #Nil
-## (` false)
-
-## (#Cons [init tests])
-## (fold (lambda [prev next]
-## (` (if (~ prev) true (~ next))))
-## init
-## tokens)
-## )]
-## (return (list as-if))))
-
-## (def (not x)
-## (-> Bool Bool)
-## (case' x
-## true false
-## false true))
-
-## (defmacro (|> tokens)
-## (case' tokens
-## (#Cons [init apps])
-## (return (list (fold (lambda [acc app]
-## (case' app
-## (#Form parts)
-## (#Form (++ parts (list acc)))
-
-## _
-## (` ((~ app) (~ acc)))))
-## init
-## apps)))))
-
-## (defmacro ($ tokens)
+## (defmacro (do tokens)
## (case' tokens
-## (#Cons [op (#Cons [init args])])
-## (return (list (fold (lambda [acc elem]
-## (` ((~ op) (~ acc) (~ elem))))
-## init
-## args)))))
-
-## (def (const x)
-## (All [a b]
-## (-> a (-> b a)))
-## (lambda [_]
-## x))
-
-## (def (int> x y)
-## (-> Int Int Bool)
-## (jvm-lgt x y))
-
-## (def (int< x y)
-## (-> Int Int Bool)
-## (jvm-llt x y))
-
-## (def inc
-## (-> Int Int)
-## (int+ 1))
-
-## (def dec
-## (-> Int Int)
-## (int+ -1))
-
-## (def (repeat n x)
-## (All [a] (-> Int a (List a)))
-## (if (int> n 0)
-## (#Cons [x (repeat (dec n) x)])
-## #Nil))
-
-## (def size
-## (All [a]
-## (-> (List a) Int))
-## (fold (lambda [acc _] (inc acc)) 0))
-
-## (def (last xs)
-## (All [a]
-## (-> (List a) (Maybe a)))
-## (case' xs
-## #Nil #None
-## (#Cons [x #Nil]) (#Some x)
-## (#Cons [_ xs']) (last xs')))
-
-## (def (init xs)
-## (All [a]
-## (-> (List a) (Maybe (List a))))
-## (case' xs
-## #Nil #None
-## (#Cons [_ #Nil]) (#Some #Nil)
-## (#Cons [x xs']) (case' (init xs')
-## (#Some xs'')
-## (#Some (#Cons [x xs'']))
-
-## _
-## (#Some (#Cons [x #Nil])))))
-
-## (defmacro (cond tokens)
-## (case' (reverse tokens)
-## (#Cons [else branches'])
-## (return (list (fold (lambda [else branch]
-## (case' branch
-## [test then]
-## (` (if (~ test) (~ then) (~ else)))))
-## else
-## (|> branches' reverse as-pairs))))))
-
-## (def (interleave xs ys)
-## (All [a]
-## (-> (List a) (List a) (List a)))
-## (case' [xs ys]
-## [(#Cons [x xs']) (#Cons [y ys'])]
-## (list+ x y (interleave xs' ys'))
-
-## _
-## #Nil))
-
-## (def (interpose sep xs)
-## (All [a]
-## (-> a (List a) (List a)))
-## (case' xs
-## #Nil
-## xs
-
-## (#Cons [x #Nil])
-## xs
-
-## (#Cons [x xs'])
-## (list+ x sep (interpose sep xs'))))
-
-## (def (empty? xs)
-## (All [a]
-## (-> (List a) Bool))
-## (case' xs
-## #Nil true
-## _ false))
-
-## ## (do-template [<name> <op>]
-## ## (def (<name> p xs)
-## ## (case xs
-## ## #Nil true
-## ## (#Cons [x xs']) (<op> (p x) (<name> p xs'))))
-
-## ## [every? and]
-## ## [any? or])
-
-## (deftype Ordering
-## (| #< #> #=))
-
-## (defsig (Ord a)
-## (: (-> a a Ordering)
-## compare))
-
-## (defsig (Enum a)
-## (: (Ord a)
-## order)
-
-## (: (-> a a)
-## succ)
-
-## (: (-> a a)
-## pred))
-
-## (def (range enum from to)
-## (All [a]
-## (-> (Enum a) a a (List a)))
-## (using [enum order]
-## (case' (compare from to)
-## #<
-## (list& from (range enum (succ from) to))
-
-## _
-## #Nil)))
-
-## (def (range from to)
-## (-> Int Int (List Int))
-## (if (int< from to)
-## (#Cons [from (range (inc from) to)])
-## #Nil))
-
-## (def (tuple->list tuple)
-## (-> Syntax (List Syntax))
-## (case' tuple
-## (#Meta [_ (#Tuple list)])
-## list))
-
-## (def (zip2 xs ys)
-## (All [a b]
-## (-> (List a) (List b) (List (, a b))))
-## (case' [xs ys]
-## [(#Cons [x xs']) (#Cons [y ys'])]
-## (#Cons [[x y] (zip2 xs' ys')])
+## (#Cons [monad (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])])
+## (return (:' SyntaxList
+## (list (` (case' (~ monad)
+## {#;return ;return #;bind ;bind}
+## (~ (fold (:' (-> Syntax (, Syntax Syntax) Syntax)
+## (lambda [body' binding]
+## (let [[lhs rhs] binding]
+## (` (;bind (lambda [(~ lhs)] (~ body')) (~ rhs))))))
+## body
+## (reverse (as-pairs bindings)))))))))
## _
-## #Nil))
-
-## (def (get-ident x)
-## (-> Syntax Text)
-## (case' x
-## (#Meta [_ (#Symbol [_ ident])])
-## ident))
-
-## (def (text-++ x y)
-## (-> Text Text Text)
-## (jvm-invokevirtual java.lang.String "concat" [java.lang.String]
-## x [y]))
-
-## (def (show-env env)
-## ...
-## (|> env (map first) (interpose ", ") (fold text-++ "")))
-
-## (def (apply-template env template)
-## (case' template
-## (#Meta [_ (#Symbol [_ ident])])
-## (case' (get ident env)
-## (#Some subst)
-## subst
-
-## _
-## template)
-
-## (#Meta [_ (#Tuple elems)])
-## (_meta (#Tuple (map (apply-template env) elems)))
+## (fail "Wrong syntax for do")))
-## (#Meta [_ (#Form elems)])
-## (_meta (#Form (map (apply-template env) elems)))
-
-## (#Meta [_ (#Record members)])
-## (_meta (#Record (map (lambda [kv]
-## (case' kv
-## [slot value]
-## [(apply-template env slot) (apply-template env value)]))
-## members)))
+## (def #export (find-macro ident state)
+## (->' Ident ($' Lux Macro))
+## (let [[module name] ident]
+## (case' state
+## {#source source #modules modules #module-aliases module-aliases
+## #envs envs #types types #host host}
+## (case' (:' ($' Maybe Macro)
+## (do Maybe:Monad
+## [bindings (get module modules)
+## gdef (get name bindings)]
+## (case' gdef
+## (#MacroD macro')
+## macro'
+
+## _
+## #None)))
+## (#Some macro)
+## (#Right [state macro])
+
+## #None
+## (#Left ($ text:++ "There is no macro by the name: " module ";" name))))))
+
+## ## (def (id x)
+## ## (All [a] (-> a a))
+## ## x)
+## ## (export' id)
+
+## ## (def (text:= x y)
+## ## (-> Text Text Bool)
+## ## (jvm-invokevirtual java.lang.Object "equals" [java.lang.Object]
+## ## x [y]))
+
+## ## (def #export (int:+ x y)
+## ## (-> Int Int Int)
+## ## (jvm-ladd x y))
+
+## ## (def (replace-ident ident value syntax)
+## ## (-> (, Text Text) Syntax Syntax Syntax)
+## ## (let [[module name] ident]
+## ## (case' syntax
+## ## (#Meta [_ (#Symbol [?module ?name])])
+## ## (if (and (text:= module ?module)
+## ## (text:= name ?name))
+## ## value
+## ## syntax)
+
+## ## (#Meta [_ (#Form members)])
+## ## (_meta (#Form (map (replace-ident ident value) members)))
+
+## ## (#Meta [_ (#Tuple members)])
+## ## (_meta (#Tuple (map (replace-ident ident value) members)))
+
+## ## (#Meta [_ (#Record members)])
+## ## (_meta (#Record (map (lambda [kv]
+## ## (case' kv
+## ## [k v]
+## ## [k (replace-ident ident value v)]))
+## ## members)))
+
+## ## _
+## ## syntax)))
+
+## ## (defsig (Eq a)
+## ## (: (-> a a Bool)
+## ## =))
+
+## ## (defstruct Text:Eq (Eq Text)
+## ## (def = text=))
+
+## ## (defstruct Ident:Eq (Eq Ident)
+## ## (def (= x y)
+## ## (let [[m1 n1] x
+## ## [m2 n2] y]
+## ## (and (text:= m1 m2)
+## ## (text:= n1 n2)))))
+
+## ## (deftype (Dict k v)
+## ## (: (-> k v (Dict k v) (Dict k v))
+## ## put)
+## ## (: (-> k (Dict k v) (Maybe v))
+## ## get)
+## ## (: (-> k (Dict k v) (Dict k v))
+## ## remove))
+
+## ## (deftype (PList k v)
+## ## (| (#PList (, (Eq k) (List (, k v))))))
+
+## ## (def (some f xs)
+## ## (All [a b]
+## ## (-> (-> a (Maybe b)) (List a) (Maybe b)))
+## ## (case' xs
+## ## #Nil
+## ## #None
+
+## ## (#Cons [x xs'])
+## ## (if-let [y (f x)]
+## ## (#Some y)
+## ## (some f xs'))
+## ## ))
+
+## ## (defstruct PList:Dict (Dict PList)
+## ## (def (get k plist)
+## ## (let [(#PList [{#= =} kvs]) plist]
+## ## (some (:' (-> (, ))
+## ## (lambda [kv]
+## ## (let [[k' v'] kv]
+## ## (when (= k k')
+## ## v'))))
+## ## kvs))))
+
+## ## (def (walk-type type)
+## ## (-> Syntax ($' Lux Syntax))
+## ## (case' type
+## ## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol sym)]) args]))])
+## ## (do' [macro' (find-macro sym)]
+## ## (case' macro'
+## ## (#Some macro)
+## ## (do' [expansion (macro args)]
+## ## (case' expansion
+## ## (#Cons [expansion' #Nil])
+## ## (walk-type expansion')
+
+## ## _
+## ## (fail "Macro can't expand to more than 1 output.")))
+
+## ## #None
+## ## (do' [args' (map% walk-type args)]
+## ## (return (fold (:' (-> Syntax Syntax Syntax)
+## ## (lambda [f a]
+## ## (` (#AppT [(~ f) (~ a)]))))
+## ## sym
+## ## args')))))
+
+## ## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag tag)]) args]))])
+## ## ...
+
+## ## (#Meta [_ (#Symbol _)])
+## ## (return type)
+
+## ## _
+## ## (fail "Wrong syntax for walk-type")))
+
+## ## (defmacro (->type tokens)
+## ## (case' tokens
+## ## (#Cons [type #Nil])
+## ## (do' [type' (walk-type type)]
+## ## (return (list type')))
-## _
-## template))
+## ## _
+## ## (fail "Wrong syntax for ->type")))
-## (defmacro (do-templates tokens)
-## (case' tokens
-## (#Cons [bindings (#Cons [(#Meta [_ (#Tuple templates)]) data])])
-## (let [bindings-list (map get-ident (tuple->list bindings))
-## data-lists (map tuple->list data)
-## apply (lambda [env] (map (apply-template env) templates))]
-## (|> data-lists
-## (map (. apply (zip2 bindings-list)))
-## return))))
-
-## ## (do-template [<name> <offset>]
-## ## (def <name> (int+ <offset>))
-
-## ## [inc 1]
-## ## [dec -1])
-
-## (def (int= x y)
-## (-> Int Int Bool)
-## (jvm-leq x y))
-
-## (def (int% x y)
-## (-> Int Int Int)
-## (jvm-lrem x y))
-
-## (def (int>= x y)
-## (-> Int Int Bool)
-## (or (int= x y)
-## (int> x y)))
-
-## (do-templates [<name> <cmp>]
-## [(def (<name> x y)
-## (-> Int Int Int)
-## (if (<cmp> x y)
-## x
-## y))]
-
-## [max int>]
-## [min int<])
-
-## (do-templates [<name> <cmp>]
-## [(def (<name> n)
-## (-> Int Bool)
-## (<cmp> n 0))]
-
-## [neg? int<]
-## [pos? int>=])
-
-## (def (even? n)
-## (-> Int Bool)
-## (int= 0 (int% n 0)))
-
-## (def (odd? n)
-## (-> Int Bool)
-## (not (even? n)))
-
-## (do-templates [<name> <done> <step>]
-## [(def (<name> n xs)
-## (All [a]
-## (-> Int (List a) (List a)))
-## (if (int> n 0)
-## (case' xs
-## #Nil #Nil
-## (#Cons [x xs']) <step>)
-## <done>))]
-
-## [take #Nil (list+ x (take (dec n) xs'))]
-## [drop xs (drop (dec n) xs')])
-
-## (do-templates [<name> <done> <step>]
-## [(def (<name> f xs)
-## (All [a]
-## (-> (-> a Bool) (List a) (List a)))
-## (case' xs
-## #Nil #Nil
-## (#Cons [x xs']) (if (f x) <step> #Nil)))]
-
-## [take-while #Nil (list+ x (take-while f xs'))]
-## [drop-while xs (drop-while f xs')])
-
-## ## (defmacro (get@ tokens)
-## ## (let [output (case' tokens
-## ## (#Cons [tag (#Cons [record #Nil])])
-## ## (` (get@' (~ tag) (~ record)))
-
-## ## (#Cons [tag #Nil])
-## ## (` (lambda [record] (get@' (~ tag) record))))]
-## ## (return (list output))))
-
-## ## (defmacro (set@ tokens)
-## ## (let [output (case' tokens
-## ## (#Cons [tag (#Cons [value (#Cons [record #Nil])])])
-## ## (` (set@' (~ tag) (~ value) (~ record)))
-
-## ## (#Cons [tag (#Cons [value #Nil])])
-## ## (` (lambda [record] (set@' (~ tag) (~ value) record)))
-
-## ## (#Cons [tag #Nil])
-## ## (` (lambda [value record] (set@' (~ tag) value record))))]
-## ## (return (list output))))
-
-## ## (defmacro (update@ tokens)
-## ## (let [output (case' tokens
-## ## (#Cons [tag (#Cons [func (#Cons [record #Nil])])])
-## ## (` (let [_record_ (~ record)]
-## ## (set@' (~ tag) ((~ func) (get@' (~ tag) _record_)) _record_)))
-
-## ## (#Cons [tag (#Cons [func #Nil])])
-## ## (` (lambda [record]
-## ## (` (set@' (~ tag) ((~ func) (get@' (~ tag) record)) record))))
-
-## ## (#Cons [tag #Nil])
-## ## (` (lambda [func record]
-## ## (set@' (~ tag) (func (get@' (~ tag) record)) record))))]
-## ## (return (list output))))
-
-## (def (show-int int)
-## (-> Int Text)
-## (jvm-invokevirtual java.lang.Object "toString" []
-## int []))
-
-## (def gensym
-## (LuxStateM Syntax)
-## (lambda [state]
-## [(update@ [#gen-seed] inc state)
-## (_meta (#Symbol ($ text-++ "__" (show-int (get@ [#gen-seed] state)) "__")))]))
-
-## ## (do-template [<name> <member>]
-## ## (def (<name> pair)
-## ## (case' pair
-## ## [f s]
-## ## <member>))
-
-## ## [first f]
-## ## [second s])
-
-## (def (show-syntax syntax)
-## (-> Syntax Text)
-## (case' syntax
-## (#Meta [_ (#Bool value)])
-## (jvm-invokevirtual java.lang.Object "toString" []
-## value [])
+## ## (defmacro (: tokens)
+## ## (case' tokens
+## ## (#Cons [type (#Cons [value #Nil])])
+## ## (return (list (` (:' (->type (~ type)) (~ value)))))
-## (#Meta [_ (#Int value)])
-## (jvm-invokevirtual java.lang.Object "toString" []
-## value [])
+## ## _
+## ## (fail "Wrong syntax for :")))
-## (#Meta [_ (#Real value)])
-## (jvm-invokevirtual java.lang.Object "toString" []
-## value [])
+## ## (defmacro (:! tokens)
+## ## (case' tokens
+## ## (#Cons [type (#Cons [value #Nil])])
+## ## (return (list (` (:!' (->type (~ type)) (~ value)))))
-## (#Meta [_ (#Char value)])
-## (jvm-invokevirtual java.lang.Object "toString" []
-## value [])
+## ## _
+## ## (fail "Wrong syntax for :!")))
-## (#Meta [_ (#Text value)])
-## (jvm-invokevirtual java.lang.Object "toString" []
-## value [])
-## (#Meta [_ (#Symbol [module name])])
-## ($ text-++ module ";" name)
-## (#Meta [_ (#Tag [module name])])
-## ($ text-++ "#" module ";" name)
+## ## (def (print x)
+## ## (-> (^ java.lang.Object) [])
+## ## (jvm-invokevirtual java.io.PrintStream "print" [java.lang.Object]
+## ## (jvm-getstatic java.lang.System "out") [x]))
-## (#Meta [_ (#Tuple members)])
-## ($ text-++ "[" (fold text-++ "" (interpose " " (map show-syntax members))) "]")
+## ## (def (println x)
+## ## (-> (^ java.lang.Object) [])
+## ## (jvm-invokevirtual java.io.PrintStream "println" [java.lang.Object]
+## ## (jvm-getstatic java.lang.System "out") [x]))
-## (#Meta [_ (#Form members)])
-## ($ text-++ "(" (fold text-++ "" (interpose " " (map show-syntax members))) ")")
-## ))
+## ## (deftype (IO a)
+## ## (-> (,) a))
-## (defmacro (do tokens)
-## (case' tokens
-## (#Cons [(#Meta [_ monad]) (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])])
-## (let [output (fold (lambda [body binding]
-## (case' binding
-## [lhs rhs]
-## (` (lux;bind (lambda [(~ lhs)] (~ body))
-## (~ rhs)))))
-## body
-## (reverse (as-pairs bindings)))]
-## (return (list (` (using (~ monad) (~ output))))))))
-
-## (def (map% f xs)
-## (All [m a b]
-## (-> (-> a (m b)) (List a) (m (List b))))
-## (case' xs
-## #Nil
-## (return xs)
-
-## (#Cons [x xs'])
-## (do [y (f x)
-## ys (map% f xs')]
-## (return (#Cons [y ys])))))
-
-## ## (defmacro ($keys tokens)
+## ## (defmacro (io tokens)
## ## (case' tokens
-## ## (#Cons [(#Meta [_ (#Tuple fields)]) #Nil])
-## ## (return (list (_meta (#Record (map (lambda [slot]
-## ## (case' slot
-## ## (#Meta [_ (#Tag [module name])])
-## ## [($ text-++ module ";" name) (_meta (#Symbol [module name]))]))
-## ## fields)))))))
-
-## ## (defmacro ($or tokens)
+## ## (#Cons [value #Nil])
+## ## (return (list (` (lambda [_] (~ value)))))))
+
+## ## (def (. f g)
+## ## (All [a b c]
+## ## (-> (-> b c) (-> a b) (-> a c)))
+## ## (lambda [x]
+## ## (f (g x))))
+
+## ## (def (++ xs ys)
+## ## (All [a]
+## ## (-> (List a) (List a) (List a)))
+## ## (case' xs
+## ## #Nil
+## ## ys
+
+## ## (#Cons [x xs'])
+## ## (#Cons [x (++ xs' ys)])))
+
+## ## (def concat
+## ## (All [a]
+## ## (-> (List (List a)) (List a)))
+## ## (fold ++ #Nil))
+
+## ## (def flat-map
+## ## (All [a b]
+## ## (-> (-> a (List b)) (List a) (List b)))
+## ## (. concat map))
+
+## ## (def (filter p xs)
+## ## (All [a]
+## ## (-> (-> a Bool) (List a) (List a)))
+## ## (case' xs
+## ## #Nil
+## ## #Nil
+
+## ## (#Cons [x xs'])
+## ## (if (p x)
+## ## (#Cons [x (filter p xs')])
+## ## (filter p xs'))))
+
+## ## (deftype (Lux a)
+## ## (-> CompilerState (Either Text (, CompilerState a))))
+
+## ## (def (first pair)
+## ## (All [a b] (-> (, a b) a))
+## ## (case' pair
+## ## [f s]
+## ## f))
+
+## ## (def (second pair)
+## ## (All [a b] (-> (, a b) b))
+## ## (case' pair
+## ## [f s]
+## ## s))
+
+## ## (defmacro (loop tokens)
## ## (case' tokens
-## ## (#Cons [(#Meta [_ (#Tuple patterns)]) (#Cons [body #Nil])])
-## ## (return (flat-map (lambda [pattern] (list pattern body))
-## ## patterns))))
-
-## (def (macro-expand syntax)
-## (-> Syntax (LuxStateM (List Syntax)))
-## (case' syntax
-## (#Form (#Cons [(#Symbol macro-name) args]))
-## (do [macro (get-macro macro-name)]
-## ((:'! macro Macro) args))))
-
-## (defmacro (case tokens)
-## (case' tokens
-## (#Cons value branches)
-## (loop [kind #Pattern
-## pieces branches
-## new-pieces (list)]
-## (case' pieces
-## #Nil
-## (return (list (' (case' (~ value) (~@ new-pieces)))))
-
-## (#Cons piece pieces')
-## (let [[kind' expanded more-pieces] (case' kind
-## #Body
-## [#Pattern (list piece) #Nil]
-
-## #Pattern
-## (do [expansion (macro-expand piece)]
-## (case' expansion
-## #Nil
-## [#Pattern #Nil #Nil]
-
-## (#Cons exp #Nil)
-## [#Body (list exp) #Nil]
-
-## (#Cons exp exps)
-## [#Body (list exp) exps]))
-## )]
-## (recur kind' (++ expanded new-pieces) (++ more-pieces pieces))))
-## )))
-
-## (def (defsyntax tokens)
-## ...)
-
-## (deftype (State s a)
-## (-> s (, s a)))
-
-## (deftype (Parser a)
-## (State (List Syntax) a))
-
-## (def (parse-ctor tokens)
-## (Parser (, Syntax (List Syntax)))
-## (case tokens
-## (list+ (#Symbol name) tokens')
-## [tokens' [(#Symbol name) (list)]]
-
-## (list+ (#Form (list+ (#Symbol name) args)) tokens')
-## [tokens' [(#Symbol name) args]]))
-
-## (defsyntax (defsig
-## [[name args] parse-ctor]
-## [anns ($+ $1)])
-## (let [def-body (fold (lambda [body arg] (` (lambda [(~ arg)] (~ body))))
-## (` (#Record (~ (untemplate-list ...))))
-## args)]
-## (return (list (` (def (~ name) (~ def-body)))))))
-
-## (defsyntax (defstruct
-## [[name args] parse-ctor]
-## signature
-## [defs ($+ $1)])
-## (let [def-body (fold (lambda [body arg] (` (lambda [(~ arg)] (~ body))))
-## (` (#Record (~ (untemplate-list ...))))
-## args)]
-## (return (list (` (def (~ name)
-## (:' (~ def-body) (~ signature))))))))
-
-## (defsig (Monad m)
-## (:' (All [a] (-> a (m a)))
-## return)
-## (:' (All [a b] (-> (-> a (m b)) (m a) (m b)))
-## bind))
-
-## (defstruct ListMonad (Monad List)
-## (def (return x)
-## (list x))
-
-## (def bind (. concat map)))
-
-## (defsig (Eq a)
-## (:' = (-> a a Bool)))
-
-## (defstruct (List_Eq A_Eq)
-## (All [a] (-> (Eq a) (Eq (List a))))
-
-## (def (= xs ys)
-## (and (= (length xs) (length ys))
-## (map (lambda [[x y]]
-## (with A_Eq
-## (= x y)))
-## (zip2 xs ys)))))
-
-## ## (def (with tokens)
+## ## (#Cons [bindings (#Cons [body #Nil])])
+## ## (let [pairs (as-pairs bindings)]
+## ## (return (list (#Form (#Cons [(` (lambda (~ (#Symbol ["lux" "recur"])) (~ (#Tuple (map first pairs)))
+## ## (~ body)))
+## ## (map second pairs)])))))))
+
+## ## (defmacro (and tokens)
+## ## (let [as-if (case' tokens
+## ## #Nil
+## ## (` true)
+
+## ## (#Cons [init tests])
+## ## (fold (lambda [prev next]
+## ## (` (if (~ prev) (~ next) false)))
+## ## init
+## ## tokens)
+## ## )]
+## ## (return (list as-if))))
+
+## ## (defmacro (or tokens)
+## ## (let [as-if (case' tokens
+## ## #Nil
+## ## (` false)
+
+## ## (#Cons [init tests])
+## ## (fold (lambda [prev next]
+## ## (` (if (~ prev) true (~ next))))
+## ## init
+## ## tokens)
+## ## )]
+## ## (return (list as-if))))
+
+## ## (def (not x)
+## ## (-> Bool Bool)
+## ## (case' x
+## ## true false
+## ## false true))
+
+## ## (defmacro (|> tokens)
+## ## (case' tokens
+## ## (#Cons [init apps])
+## ## (return (list (fold (lambda [acc app]
+## ## (case' app
+## ## (#Form parts)
+## ## (#Form (++ parts (list acc)))
+
+## ## _
+## ## (` ((~ app) (~ acc)))))
+## ## init
+## ## apps)))))
+
+## ## (defmacro ($ tokens)
+## ## (case' tokens
+## ## (#Cons [op (#Cons [init args])])
+## ## (return (list (fold (lambda [acc elem]
+## ## (` ((~ op) (~ acc) (~ elem))))
+## ## init
+## ## args)))))
+
+## ## (def (const x)
+## ## (All [a b]
+## ## (-> a (-> b a)))
+## ## (lambda [_]
+## ## x))
+
+## ## (def (int> x y)
+## ## (-> Int Int Bool)
+## ## (jvm-lgt x y))
+
+## ## (def (int< x y)
+## ## (-> Int Int Bool)
+## ## (jvm-llt x y))
+
+## ## (def inc
+## ## (-> Int Int)
+## ## (int+ 1))
+
+## ## (def dec
+## ## (-> Int Int)
+## ## (int+ -1))
+
+## ## (def (repeat n x)
+## ## (All [a] (-> Int a (List a)))
+## ## (if (int> n 0)
+## ## (#Cons [x (repeat (dec n) x)])
+## ## #Nil))
+
+## ## (def size
+## ## (All [a]
+## ## (-> (List a) Int))
+## ## (fold (lambda [acc _] (inc acc)) 0))
+
+## ## (def (last xs)
+## ## (All [a]
+## ## (-> (List a) (Maybe a)))
+## ## (case' xs
+## ## #Nil #None
+## ## (#Cons [x #Nil]) (#Some x)
+## ## (#Cons [_ xs']) (last xs')))
+
+## ## (def (init xs)
+## ## (All [a]
+## ## (-> (List a) (Maybe (List a))))
+## ## (case' xs
+## ## #Nil #None
+## ## (#Cons [_ #Nil]) (#Some #Nil)
+## ## (#Cons [x xs']) (case' (init xs')
+## ## (#Some xs'')
+## ## (#Some (#Cons [x xs'']))
+
+## ## _
+## ## (#Some (#Cons [x #Nil])))))
+
+## ## (defmacro (cond tokens)
+## ## (case' (reverse tokens)
+## ## (#Cons [else branches'])
+## ## (return (list (fold (lambda [else branch]
+## ## (case' branch
+## ## [test then]
+## ## (` (if (~ test) (~ then) (~ else)))))
+## ## else
+## ## (|> branches' reverse as-pairs))))))
+
+## ## (def (interleave xs ys)
+## ## (All [a]
+## ## (-> (List a) (List a) (List a)))
+## ## (case' [xs ys]
+## ## [(#Cons [x xs']) (#Cons [y ys'])]
+## ## (list+ x y (interleave xs' ys'))
+
+## ## _
+## ## #Nil))
+
+## ## (def (interpose sep xs)
+## ## (All [a]
+## ## (-> a (List a) (List a)))
+## ## (case' xs
+## ## #Nil
+## ## xs
+
+## ## (#Cons [x #Nil])
+## ## xs
+
+## ## (#Cons [x xs'])
+## ## (list+ x sep (interpose sep xs'))))
+
+## ## (def (empty? xs)
+## ## (All [a]
+## ## (-> (List a) Bool))
+## ## (case' xs
+## ## #Nil true
+## ## _ false))
+
+## ## ## (do-template [<name> <op>]
+## ## ## (def (<name> p xs)
+## ## ## (case xs
+## ## ## #Nil true
+## ## ## (#Cons [x xs']) (<op> (p x) (<name> p xs'))))
+
+## ## ## [every? and]
+## ## ## [any? or])
+
+## ## (def (tuple->list tuple)
+## ## (-> Syntax (List Syntax))
+## ## (case' tuple
+## ## (#Meta [_ (#Tuple list)])
+## ## list))
+
+## ## (def (zip2 xs ys)
+## ## (All [a b]
+## ## (-> (List a) (List b) (List (, a b))))
+## ## (case' [xs ys]
+## ## [(#Cons [x xs']) (#Cons [y ys'])]
+## ## (#Cons [[x y] (zip2 xs' ys')])
+
+## ## _
+## ## #Nil))
+
+## ## (def (get-ident x)
+## ## (-> Syntax Text)
+## ## (case' x
+## ## (#Meta [_ (#Symbol [_ ident])])
+## ## ident))
+
+## ## (def (text-++ x y)
+## ## (-> Text Text Text)
+## ## (jvm-invokevirtual java.lang.String "concat" [java.lang.String]
+## ## x [y]))
+
+## ## (def (show-env env)
+## ## ...
+## ## (|> env (map first) (interpose ", ") (fold text-++ "")))
+
+## ## (def (apply-template env template)
+## ## (case' template
+## ## (#Meta [_ (#Symbol [_ ident])])
+## ## (case' (get ident env)
+## ## (#Some subst)
+## ## subst
+
+## ## _
+## ## template)
+
+## ## (#Meta [_ (#Tuple elems)])
+## ## (_meta (#Tuple (map (apply-template env) elems)))
+
+## ## (#Meta [_ (#Form elems)])
+## ## (_meta (#Form (map (apply-template env) elems)))
+
+## ## (#Meta [_ (#Record members)])
+## ## (_meta (#Record (map (lambda [kv]
+## ## (case' kv
+## ## [slot value]
+## ## [(apply-template env slot) (apply-template env value)]))
+## ## members)))
+
+## ## _
+## ## template))
+
+## ## (defmacro (do-templates tokens)
+## ## (case' tokens
+## ## (#Cons [bindings (#Cons [(#Meta [_ (#Tuple templates)]) data])])
+## ## (let [bindings-list (map get-ident (tuple->list bindings))
+## ## data-lists (map tuple->list data)
+## ## apply (lambda [env] (map (apply-template env) templates))]
+## ## (|> data-lists
+## ## (map (. apply (zip2 bindings-list)))
+## ## return))))
+
+## ## ## (do-template [<name> <offset>]
+## ## ## (def <name> (int+ <offset>))
+
+## ## ## [inc 1]
+## ## ## [dec -1])
+
+## ## (def (int= x y)
+## ## (-> Int Int Bool)
+## ## (jvm-leq x y))
+
+## ## (def (int% x y)
+## ## (-> Int Int Int)
+## ## (jvm-lrem x y))
+
+## ## (def (int>= x y)
+## ## (-> Int Int Bool)
+## ## (or (int= x y)
+## ## (int> x y)))
+
+## ## (do-templates [<name> <cmp>]
+## ## [(def (<name> x y)
+## ## (-> Int Int Int)
+## ## (if (<cmp> x y)
+## ## x
+## ## y))]
+
+## ## [max int>]
+## ## [min int<])
+
+## ## (do-templates [<name> <cmp>]
+## ## [(def (<name> n)
+## ## (-> Int Bool)
+## ## (<cmp> n 0))]
+
+## ## [neg? int<]
+## ## [pos? int>=])
+
+## ## (def (even? n)
+## ## (-> Int Bool)
+## ## (int= 0 (int% n 0)))
+
+## ## (def (odd? n)
+## ## (-> Int Bool)
+## ## (not (even? n)))
+
+## ## (do-templates [<name> <done> <step>]
+## ## [(def (<name> n xs)
+## ## (All [a]
+## ## (-> Int (List a) (List a)))
+## ## (if (int> n 0)
+## ## (case' xs
+## ## #Nil #Nil
+## ## (#Cons [x xs']) <step>)
+## ## <done>))]
+
+## ## [take #Nil (list+ x (take (dec n) xs'))]
+## ## [drop xs (drop (dec n) xs')])
+
+## ## (do-templates [<name> <done> <step>]
+## ## [(def (<name> f xs)
+## ## (All [a]
+## ## (-> (-> a Bool) (List a) (List a)))
+## ## (case' xs
+## ## #Nil #Nil
+## ## (#Cons [x xs']) (if (f x) <step> #Nil)))]
+
+## ## [take-while #Nil (list+ x (take-while f xs'))]
+## ## [drop-while xs (drop-while f xs')])
+
+## ## ## (defmacro (get@ tokens)
+## ## ## (let [output (case' tokens
+## ## ## (#Cons [tag (#Cons [record #Nil])])
+## ## ## (` (get@' (~ tag) (~ record)))
+
+## ## ## (#Cons [tag #Nil])
+## ## ## (` (lambda [record] (get@' (~ tag) record))))]
+## ## ## (return (list output))))
+
+## ## ## (defmacro (set@ tokens)
+## ## ## (let [output (case' tokens
+## ## ## (#Cons [tag (#Cons [value (#Cons [record #Nil])])])
+## ## ## (` (set@' (~ tag) (~ value) (~ record)))
+
+## ## ## (#Cons [tag (#Cons [value #Nil])])
+## ## ## (` (lambda [record] (set@' (~ tag) (~ value) record)))
+
+## ## ## (#Cons [tag #Nil])
+## ## ## (` (lambda [value record] (set@' (~ tag) value record))))]
+## ## ## (return (list output))))
+
+## ## ## (defmacro (update@ tokens)
+## ## ## (let [output (case' tokens
+## ## ## (#Cons [tag (#Cons [func (#Cons [record #Nil])])])
+## ## ## (` (let [_record_ (~ record)]
+## ## ## (set@' (~ tag) ((~ func) (get@' (~ tag) _record_)) _record_)))
+
+## ## ## (#Cons [tag (#Cons [func #Nil])])
+## ## ## (` (lambda [record]
+## ## ## (` (set@' (~ tag) ((~ func) (get@' (~ tag) record)) record))))
+
+## ## ## (#Cons [tag #Nil])
+## ## ## (` (lambda [func record]
+## ## ## (set@' (~ tag) (func (get@' (~ tag) record)) record))))]
+## ## ## (return (list output))))
+
+## ## (def (show-int int)
+## ## (-> Int Text)
+## ## (jvm-invokevirtual java.lang.Object "toString" []
+## ## int []))
+
+## ## (def gensym
+## ## (LuxStateM Syntax)
+## ## (lambda [state]
+## ## [(update@ [#gen-seed] inc state)
+## ## (_meta (#Symbol ($ text-++ "__" (show-int (get@ [#gen-seed] state)) "__")))]))
+
+## ## ## (do-template [<name> <member>]
+## ## ## (def (<name> pair)
+## ## ## (case' pair
+## ## ## [f s]
+## ## ## <member>))
+
+## ## ## [first f]
+## ## ## [second s])
+
+## ## (def (show-syntax syntax)
+## ## (-> Syntax Text)
+## ## (case' syntax
+## ## (#Meta [_ (#Bool value)])
+## ## (jvm-invokevirtual java.lang.Object "toString" []
+## ## value [])
+
+## ## (#Meta [_ (#Int value)])
+## ## (jvm-invokevirtual java.lang.Object "toString" []
+## ## value [])
+
+## ## (#Meta [_ (#Real value)])
+## ## (jvm-invokevirtual java.lang.Object "toString" []
+## ## value [])
+
+## ## (#Meta [_ (#Char value)])
+## ## (jvm-invokevirtual java.lang.Object "toString" []
+## ## value [])
+
+## ## (#Meta [_ (#Text value)])
+## ## (jvm-invokevirtual java.lang.Object "toString" []
+## ## value [])
+
+## ## (#Meta [_ (#Symbol [module name])])
+## ## ($ text-++ module ";" name)
+
+## ## (#Meta [_ (#Tag [module name])])
+## ## ($ text-++ "#" module ";" name)
+
+## ## (#Meta [_ (#Tuple members)])
+## ## ($ text-++ "[" (fold text-++ "" (interpose " " (map show-syntax members))) "]")
+
+## ## (#Meta [_ (#Form members)])
+## ## ($ text-++ "(" (fold text-++ "" (interpose " " (map show-syntax members))) ")")
+## ## ))
+
+## ## (defmacro (do tokens)
+## ## (case' tokens
+## ## (#Cons [(#Meta [_ monad]) (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])])
+## ## (let [output (fold (lambda [body binding]
+## ## (case' binding
+## ## [lhs rhs]
+## ## (` (lux;bind (lambda [(~ lhs)] (~ body))
+## ## (~ rhs)))))
+## ## body
+## ## (reverse (as-pairs bindings)))]
+## ## (return (list (` (using (~ monad) (~ output))))))))
+
+## ## (def (map% f xs)
+## ## (All [m a b]
+## ## (-> (-> a (m b)) (List a) (m (List b))))
+## ## (case' xs
+## ## #Nil
+## ## (return xs)
+
+## ## (#Cons [x xs'])
+## ## (do [y (f x)
+## ## ys (map% f xs')]
+## ## (return (#Cons [y ys])))))
+
+## ## ## (defmacro ($keys tokens)
+## ## ## (case' tokens
+## ## ## (#Cons [(#Meta [_ (#Tuple fields)]) #Nil])
+## ## ## (return (list (_meta (#Record (map (lambda [slot]
+## ## ## (case' slot
+## ## ## (#Meta [_ (#Tag [module name])])
+## ## ## [($ text-++ module ";" name) (_meta (#Symbol [module name]))]))
+## ## ## fields)))))))
+
+## ## ## (defmacro ($or tokens)
+## ## ## (case' tokens
+## ## ## (#Cons [(#Meta [_ (#Tuple patterns)]) (#Cons [body #Nil])])
+## ## ## (return (flat-map (lambda [pattern] (list pattern body))
+## ## ## patterns))))
+
+## ## (def (macro-expand syntax)
+## ## (-> Syntax (LuxStateM (List Syntax)))
+## ## (case' syntax
+## ## (#Form (#Cons [(#Symbol macro-name) args]))
+## ## (do [macro (get-macro macro-name)]
+## ## ((:'! macro Macro) args))))
+
+## ## (defmacro (case tokens)
+## ## (case' tokens
+## ## (#Cons value branches)
+## ## (loop [kind #Pattern
+## ## pieces branches
+## ## new-pieces (list)]
+## ## (case' pieces
+## ## #Nil
+## ## (return (list (' (case' (~ value) (~@ new-pieces)))))
+
+## ## (#Cons piece pieces')
+## ## (let [[kind' expanded more-pieces] (case' kind
+## ## #Body
+## ## [#Pattern (list piece) #Nil]
+
+## ## #Pattern
+## ## (do [expansion (macro-expand piece)]
+## ## (case' expansion
+## ## #Nil
+## ## [#Pattern #Nil #Nil]
+
+## ## (#Cons exp #Nil)
+## ## [#Body (list exp) #Nil]
+
+## ## (#Cons exp exps)
+## ## [#Body (list exp) exps]))
+## ## )]
+## ## (recur kind' (++ expanded new-pieces) (++ more-pieces pieces))))
+## ## )))
+
+## ## (def (defsyntax tokens)
## ## ...)
-## ## (import "lux")
-## ## (module-alias "lux" "l")
-## ## (def-alias "lux;map" "map")
+## ## (deftype (State s a)
+## ## (-> s (, s a)))
+
+## ## (deftype (Parser a)
+## ## (State (List Syntax) a))
-## ## (def (require tokens)
+## ## (def (parse-ctor tokens)
+## ## (Parser (, Syntax (List Syntax)))
## ## (case tokens
-## ## ...))
-
-## ## (require lux #as l #refer [map])
-
-## (defsyntax #export (All [name (%? %name)] [args %args] body)
-## (let [name' (case name
-## #None ""
-## (#Some name) name)
-## arg-replacements (map (lambda [arg]
-## [(#Symbol ["" arg]) (` (#Bound (~ arg)))])
-## args)
-## args' (map (lambda [arg]
-## (#Symbol ["" arg]))
-## args)
-## body' (replace-syntax arg-replacements body)]
-## (return (list (` (#AllT [#None (~ name') (#Tuple (list (~@ args')))
-## (~ body')]))))))
-
-## (def (walk-syntax type)
-## (case type
-## (#Meta [_ (#Form (\list& op args))])
-## (case op
-## (#Meta [_ (#Symbol ident)])
-## (do' [macro?? (find-macro ident)]
-## (case macro??
-## (#Some macro)
-## (do' [expansion (macro args)]
-## (flat-map% walk-syntax expansion))
-
-## #None
-## (do' [flat-map% (map% walk-syntax args)]
-## (return (list (fold (lambda [fun arg]
-## (` (#AppT [(~ fun) (~ arg)])))
-## op
-## args))))))
-
-## _
-## (do' [flat-map% (map% walk-syntax args)]
-## (return (list (_meta (#Form (list op args')))))))
-
-## _
-## (return (list type))))
-
-## (defsyntax #export (type type-syntax)
-## (walk-syntax type-syntax))
-
-## (defsyntax #export (deftype [[name args] %usage] body)
-## (return (list (` (def (~ name)
-## (:' Type
-## (type (All [(~@ args)]
-## (~ body)))))))))
+## ## (list+ (#Symbol name) tokens')
+## ## [tokens' [(#Symbol name) (list)]]
+
+## ## (list+ (#Form (list+ (#Symbol name) args)) tokens')
+## ## [tokens' [(#Symbol name) args]]))
+
+## ## (defsyntax (defsig
+## ## [[name args] parse-ctor]
+## ## [anns ($+ $1)])
+## ## (let [def-body (fold (lambda [body arg] (` (lambda [(~ arg)] (~ body))))
+## ## (` (#Record (~ (untemplate-list ...))))
+## ## args)]
+## ## (return (list (` (def (~ name) (~ def-body)))))))
+
+## ## (defsyntax (defstruct
+## ## [[name args] parse-ctor]
+## ## signature
+## ## [defs ($+ $1)])
+## ## (let [def-body (fold (lambda [body arg] (` (lambda [(~ arg)] (~ body))))
+## ## (` (#Record (~ (untemplate-list ...))))
+## ## args)]
+## ## (return (list (` (def (~ name)
+## ## (:' (~ def-body) (~ signature))))))))
+
+## ## ## (def (with tokens)
+## ## ## ...)
+
+## ## (import' lux)
+## ## (module-alias' lux l)
+## ## (import lux #as l #use [map])
+
+## ## (defsyntax #export (All [name (%? %name)] [args %args] body)
+## ## (let [name' (case name
+## ## #None ""
+## ## (#Some name) name)
+## ## arg-replacements (map (lambda [arg]
+## ## [(#Symbol ["" arg]) (` (#Bound (~ arg)))])
+## ## args)
+## ## args' (map (lambda [arg]
+## ## (#Symbol ["" arg]))
+## ## args)
+## ## body' (replace-syntax arg-replacements body)]
+## ## (return (list (` (#AllT [#None (~ name') (#Tuple (list (~@ args')))
+## ## (~ body')]))))))
+
+## ## (def (walk-syntax type)
+## ## (case type
+## ## (#Meta [_ (#Form (\list& op args))])
+## ## (case op
+## ## (#Meta [_ (#Symbol ident)])
+## ## (do' [macro?? (find-macro ident)]
+## ## (case macro??
+## ## (#Some macro)
+## ## (do' [expansion (macro args)]
+## ## (flat-map% walk-syntax expansion))
+
+## ## #None
+## ## (do' [flat-map% (map% walk-syntax args)]
+## ## (return (list (fold (lambda [fun arg]
+## ## (` (#AppT [(~ fun) (~ arg)])))
+## ## op
+## ## args))))))
+
+## ## _
+## ## (do' [flat-map% (map% walk-syntax args)]
+## ## (return (list (_meta (#Form (list op args')))))))
+
+## ## _
+## ## (return (list type))))
+
+## ## (defsyntax #export (type type-syntax)
+## ## (walk-syntax type-syntax))
+
+## ## (defsyntax #export (deftype [[name args] %usage] body)
+## ## (return (list (` (def (~ name)
+## ## (:' Type
+## ## (type (All [(~@ args)]
+## ## (~ body)))))))))
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index 6976f47f0..e4511fdeb 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -6,7 +6,6 @@
[reader :as &reader]
[parser :as &parser]
[type :as &type]
- [macro :as &macro]
[host :as &host])
(lux.analyser [base :as &&]
[lux :as &&lux]
@@ -61,7 +60,7 @@
(&&lux/analyse-tuple analyse exo-type ?elems)
[["lux;Meta" [meta ["lux;Record" ?elems]]]]
- (&&lux/analyse-record analyse ?elems)
+ (&&lux/analyse-record analyse exo-type ?elems)
[["lux;Meta" [meta ["lux;Tag" ?ident]]]]
(&&lux/analyse-variant analyse exo-type ?ident (_meta (&/V "lux;Tuple" (|list))))
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 8d7819fd3..87db5a125 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -5,7 +5,6 @@
(lux [base :as & :refer [|do return return* fail fail* |let |list]]
[parser :as &parser]
[type :as &type]
- [macro :as &macro]
[host :as &host])
(lux.analyser [base :as &&]
[lambda :as &&lambda]
@@ -29,22 +28,22 @@
;; (prn "^^ analyse-tuple ^^")
;; (prn 'analyse-tuple (str "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")
;; (&type/show-type exo-type))
- (matchv ::M/objects [exo-type]
- [["lux;TupleT" ?members]]
- (|do [=elems (&/map% (fn [ve]
- (|let [[elem-t elem] ve]
- (&&/analyse-1 analyse elem-t elem)))
- (&/zip2 ?members ?elems))]
- (return (&/|list (&/V "Expression" (&/T (&/V "tuple" =elems)
- exo-type)))))
+ (|do [exo-type* (&type/actual-type exo-type)]
+ (matchv ::M/objects [exo-type*]
+ [["lux;TupleT" ?members]]
+ (|do [=elems (&/map% (fn [ve]
+ (|let [[elem-t elem] ve]
+ (&&/analyse-1 analyse elem-t elem)))
+ (&/zip2 ?members ?elems))]
+ (return (&/|list (&/V "Expression" (&/T (&/V "tuple" =elems)
+ exo-type)))))
- [_]
- (fail "[Analyser Error] Tuples require tuple-types.")))
+ [_]
+ (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*))))))
(defn analyse-variant [analyse exo-type ident ?value]
;; (prn "^^ analyse-variant ^^")
(|do [;; :let [_ (prn 'analyse-variant/exo-type (&type/show-type exo-type))]
- ?tag (&&/resolved-ident ident)
exo-type* (matchv ::M/objects [exo-type]
[["lux;VarT" ?id]]
(&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)]
@@ -54,6 +53,7 @@
[_]
(&type/actual-type exo-type))
+ ?tag (&&/resolved-ident ident)
;; :let [_ (prn 'analyse-variant/exo-type* (&type/show-type exo-type*))]
]
(matchv ::M/objects [exo-type*]
@@ -71,24 +71,34 @@
(fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*))))))
(defn analyse-record [analyse exo-type ?elems]
- (|do [=elems (&/map% (fn [kv]
+ (|do [exo-type* (matchv ::M/objects [exo-type]
+ [["lux;VarT" ?id]]
+ (|do [exo-type* (&type/deref ?id)]
+ (&type/actual-type exo-type*))
+
+ [_]
+ (&type/actual-type exo-type))
+ types (matchv ::M/objects [exo-type*]
+ [["lux;RecordT" ?table]]
+ (return ?table)
+
+ [_]
+ (fail "[Analyser Error] The type of a record must be a record type."))
+ =slots (&/map% (fn [kv]
(matchv ::M/objects [kv]
- [[k v]]
- (|do [=v (&&/analyse-1 analyse v)]
- (return (to-array [k =v])))))
- ?elems)
- =elems-types (&/map% (fn [kv]
- (matchv ::M/objects [kv]
- [[k v]]
- (|do [module (if (= "" k)
- &/get-module-name
- (return k))
- =v (&&/expr-type v)]
- (return (to-array [module =v])))))
- =elems)
- ;; :let [_ (prn 'analyse-tuple =elems)]
- ]
- (return (&/|list (&/V "Expression" (&/T (&/V "lux;record" =elems) (&/V "lux;RecordT" =elems-types)))))))
+ [[["lux;Meta" [_ ["lux;Tag" ?ident]]] ?value]]
+ (|do [?tag (&&/resolved-ident ?ident)
+ slot-type (if-let [slot-type (&/|get ?tag types)]
+ (return slot-type)
+ (fail (str "[Analyser Error] Record type does not have slot: " ?tag)))
+ ;; :let [_ (prn 'slot ?tag (&/show-ast ?value) (&type/show-type slot-type))]
+ =value (&&/analyse-1 analyse slot-type ?value)]
+ (return (&/T ?tag =value)))
+
+ [_]
+ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")))
+ ?elems)]
+ (return (&/|list (&/V "Expression" (&/T (&/V "record" =slots) (&/V "lux;RecordT" exo-type)))))))
(defn ^:private show-frame [frame]
(str "{{" (->> frame (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS)
@@ -124,7 +134,7 @@
_ (if (and (= &type/Type endo-type) (= &type/Type exo-type))
(do ;; (println "OH YEAH" (if (= "" ?module) module-name ?module)
;; ?name)
- (return nil))
+ (return nil))
(&type/check exo-type endo-type))
;; :let [_ (println "Type-checked:" exo-type endo-type)]
]
@@ -136,32 +146,32 @@
[["lux;Cons" [?genv ["lux;Nil" _]]]]
(if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident))]
(do ;; (prn 'GOT_GLOBAL local-ident)
- (matchv ::M/objects [global]
- [["Expression" [["global" [?module* ?name*]] _]]]
- (&/run-state (|do [$def (&&module/find-def ?module* ?name*)
- ;; :let [_ (println "Found def:" ?module* ?name*)]
- endo-type (matchv ::M/objects [$def]
- [["lux;ValueD" ?type]]
- (return ?type)
-
- [["lux;MacroD" _]]
- (return &type/Macro)
-
- [["lux;TypeD" _]]
- (return &type/Type))
- ;; :let [_ (println "Got endo-type:" endo-type)]
- _ (if (and (= &type/Type endo-type) (= &type/Type exo-type))
- (do ;; (println "OH YEAH" ?module* ?name*)
- (return nil))
- (&type/check exo-type endo-type))
- ;; :let [_ (println "Type-checked:" exo-type endo-type)]
- ]
- (return (&/|list (&/V "Expression" (&/T (&/V "global" (&/T ?module* ?name*))
- endo-type)))))
- state)
-
- [_]
- (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))
+ (matchv ::M/objects [global]
+ [["Expression" [["global" [?module* ?name*]] _]]]
+ (&/run-state (|do [$def (&&module/find-def ?module* ?name*)
+ ;; :let [_ (println "Found def:" ?module* ?name*)]
+ endo-type (matchv ::M/objects [$def]
+ [["lux;ValueD" ?type]]
+ (return ?type)
+
+ [["lux;MacroD" _]]
+ (return &type/Macro)
+
+ [["lux;TypeD" _]]
+ (return &type/Type))
+ ;; :let [_ (println "Got endo-type:" endo-type)]
+ _ (if (and (= &type/Type endo-type) (= &type/Type exo-type))
+ (do ;; (println "OH YEAH" ?module* ?name*)
+ (return nil))
+ (&type/check exo-type endo-type))
+ ;; :let [_ (println "Type-checked:" exo-type endo-type)]
+ ]
+ (return (&/|list (&/V "Expression" (&/T (&/V "global" (&/T ?module* ?name*))
+ endo-type)))))
+ state)
+
+ [_]
+ (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))
(fail* ""))
[["lux;Cons" [top-outer _]]]
@@ -198,32 +208,32 @@
(return (&/|list =fn)))
[["lux;Cons" [?arg ?args*]]]
- (do ;; (prn 'analyse-apply*/=fn (&type/show-type ?fun-type))
- (matchv ::M/objects [?fun-type]
- [["lux;AllT" _]]
- (&type/with-var
- (fn [$var]
- (|do [type* (&type/apply-type ?fun-type $var)
- output (analyse-apply* analyse exo-type (&/V "Expression" (&/T ?fun-expr type*)) ?args)]
- (matchv ::M/objects [output]
- [["lux;Cons" [["Expression" [?expr* ?type*]] ["lux;Nil" _]]]]
- (|do [type** (&type/clean $var ?type*)]
- (return (&/|list (&/V "Expression" (&/T ?expr* type**)))))
-
- [_]
- (assert false (prn-str 'analyse-apply*/output (aget output 0)))))))
-
- [["lux;LambdaT" [?input-t ?output-t]]]
- ;; (|do [=arg (&&/analyse-1 analyse ?input-t ?arg)]
- ;; (return (&/|list (&/V "Expression" (&/T (&/V "apply" (&/T =fn =arg))
- ;; ?output-t)))))
- (|do [=arg (&&/analyse-1 analyse ?input-t ?arg)]
- (analyse-apply* analyse exo-type (&/V "Expression" (&/T (&/V "apply" (&/T =fn =arg))
- ?output-t))
- ?args*))
-
- [_]
- (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type)))))
+ (|do [?fun-type* (&type/actual-type ?fun-type)]
+ (matchv ::M/objects [?fun-type*]
+ [["lux;AllT" _]]
+ (&type/with-var
+ (fn [$var]
+ (|do [type* (&type/apply-type ?fun-type* $var)
+ output (analyse-apply* analyse exo-type (&/V "Expression" (&/T ?fun-expr type*)) ?args)]
+ (matchv ::M/objects [output]
+ [["lux;Cons" [["Expression" [?expr* ?type*]] ["lux;Nil" _]]]]
+ (|do [type** (&type/clean $var ?type*)]
+ (return (&/|list (&/V "Expression" (&/T ?expr* type**)))))
+
+ [_]
+ (assert false (prn-str 'analyse-apply*/output (aget output 0)))))))
+
+ [["lux;LambdaT" [?input-t ?output-t]]]
+ ;; (|do [=arg (&&/analyse-1 analyse ?input-t ?arg)]
+ ;; (return (&/|list (&/V "Expression" (&/T (&/V "apply" (&/T =fn =arg))
+ ;; ?output-t)))))
+ (|do [=arg (&&/analyse-1 analyse ?input-t ?arg)]
+ (analyse-apply* analyse exo-type (&/V "Expression" (&/T (&/V "apply" (&/T =fn =arg))
+ ?output-t))
+ ?args*))
+
+ [_]
+ (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*)))))
)))
(defn analyse-apply [analyse exo-type =fn ?args]
@@ -279,12 +289,16 @@
(return (&/V "Expression" (&/T (&/V "lambda" (&/T =scope =captured =body)) exo-type))))
[_]
- (fail (str "[Analyser Error] Functions require function types: " (&type/show-type exo-type)))))
+ (fail (str "[Analyser Error] Functions require function types: "
+ ;; (str (aget ?self 0) ";" (aget ?self 1))
+ ;; (str (aget ?arg 0) ";" (aget ?arg 1))
+ ;; (&/show-ast ?body)
+ (&type/show-type exo-type)))))
(defn analyse-lambda** [analyse exo-type ?self ?arg ?body]
;; (prn 'analyse-lambda**/&& (aget exo-type 0))
(matchv ::M/objects [exo-type]
- [["lux;AllT" _]]
+ [["lux;AllT" [_env _self _arg _body]]]
(&type/with-var
(fn [$var]
(|do [exo-type* (&type/apply-type exo-type $var)
@@ -294,18 +308,20 @@
(|do [? (&type/bound? ?id)]
(if ?
(|do [dtype (&type/deref ?id)]
- (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id (&type/show-type dtype))))
+ (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))
(return output)))))))
[_]
- (analyse-lambda* analyse exo-type ?self ?arg ?body)))
+ (|do [exo-type* (&type/actual-type exo-type)]
+ (analyse-lambda* analyse exo-type* ?self ?arg ?body))
+ ))
(defn analyse-lambda [analyse exo-type ?self ?arg ?body]
(|do [output (analyse-lambda** analyse exo-type ?self ?arg ?body)]
(return (&/|list output))))
(defn analyse-def [analyse ?name ?value]
- ;; (prn 'analyse-def/CODE ?name (&/show-ast ?value))
+ (prn 'analyse-def/CODE ?name (&/show-ast ?value))
(|do [module-name &/get-module-name
? (&&module/defined? module-name ?name)]
(if ?
@@ -316,8 +332,9 @@
;; :let [_ (prn 'analyse-def/_1)]
=value-type (&&/expr-type =value)
;; :let [_ (prn 'analyse-def/_2)]
- :let [;; _ (prn 'analyse-def/TYPE ?name (&type/show-type =value-type))
- ;; _ (println)
+ :let [_ (prn 'analyse-def/TYPE ?name ;; (&type/show-type =value-type)
+ )
+ _ (println)
def-data (cond (&type/type= &type/Macro =value-type)
(&/V "lux;MacroD" (&/V "lux;None" nil))
diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj
index 944e98580..ac5968026 100644
--- a/src/lux/analyser/module.clj
+++ b/src/lux/analyser/module.clj
@@ -27,10 +27,11 @@
nil)
[_]
- (fail "[Analyser Error] Can't create a new global definition outside of a global environment."))))
+ (fail* "[Analyser Error] Can't create a new global definition outside of a global environment."))))
(defn exists? [name]
(fn [state]
+ ;; (prn `exists? name (->> state (&/get$ &/$MODULES) (&/|contains? name)))
(return* state
(->> state (&/get$ &/$MODULES) (&/|contains? name)))))
@@ -38,7 +39,7 @@
(fn [state]
(if-let [real-name (->> state (&/get$ &/$MODULE-ALIASES) (&/|get name))]
(return* state real-name)
- (fail (str "Unknown alias: " name)))))
+ (fail* (str "Unknown alias: " name)))))
(defn find-def [module name]
(fn [state]
diff --git a/src/lux/base.clj b/src/lux/base.clj
index 6a4d93007..4f3e6f028 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -429,20 +429,6 @@
[_]
(return nil)))
-(defn repeat% [monad]
- (fn [state]
- (matchv ::M/objects [(monad state)]
- [["lux;Right" [?state ?head]]]
- (do ;; (prn 'repeat-m/?state ?state)
- (matchv ::M/objects [((repeat% monad) ?state)]
- [["lux;Right" [?state* ?tail]]]
- (do ;; (prn 'repeat-m/?state* ?state*)
- (return* ?state* (|cons ?head ?tail)))))
-
- [["lux;Left" ?message]]
- (do ;; (println "Failed at last:" ?message)
- (return* state (V "lux;Nil" nil))))))
-
(def source-consumed?
(fn [state]
(matchv ::M/objects [(get$ $SOURCE state)]
@@ -475,6 +461,12 @@
)))
))
+(defn repeat% [monad]
+ (try-all% (|list (|do [head monad
+ tail (repeat% monad)]
+ (return (|cons head tail)))
+ (return (|list)))))
+
(defn exhaust% [step]
(fn [state]
(matchv ::M/objects [(step state)]
@@ -485,7 +477,7 @@
((|do [? source-consumed?]
(if ?
(return nil)
- (fail* msg)))
+ (fail msg)))
state)
;; (if (= "[Reader Error] EOF" msg)
;; ((|do [? source-consumed?
@@ -599,7 +591,7 @@
(try (let [top (|head (get$ $ENVS state))]
(return* state top))
(catch Throwable _
- (fail "No local environment.")))))
+ (fail* "No local environment.")))))
(defn ->seq [xs]
(matchv ::M/objects [xs]
@@ -705,6 +697,13 @@
[["lux;Meta" [_ ["lux;Tuple" ?elems]]]]
(str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]")
+ [["lux;Meta" [_ ["lux;Record" ?elems]]]]
+ (str "{" (->> ?elems
+ (|map (fn [elem]
+ (|let [[k v] elem]
+ (str "#" (show-ast k) " " (show-ast v)))))
+ (|interpose " ") (fold str "")) "}")
+
[["lux;Meta" [_ ["lux;Form" ?elems]]]]
(str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")")
))
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 59e3d9c36..6a9cc58c6 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -367,7 +367,7 @@
(defn ^:private compile-module [name]
(fn [state]
(if (->> state (&/get$ &/$MODULES) (&/|contains? name))
- (fail "[Compiler Error] Can't redefine a module!")
+ (fail* "[Compiler Error] Can't redefine a module!")
(let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
(&host/->class name) nil "java/lang/Object" nil))]
diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj
index d6a259476..2f051903b 100644
--- a/src/lux/compiler/case.clj
+++ b/src/lux/compiler/case.clj
@@ -29,6 +29,7 @@
[["BoolTestAC" ?value]]
(doto writer
+ (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Boolean"))
(.visitInsn Opcodes/DUP)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Boolean") "booleanValue" "()Z")
(.visitLdcInsn ?value)
@@ -38,6 +39,7 @@
[["IntTestAC" ?value]]
(doto writer
+ (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Long"))
(.visitInsn Opcodes/DUP)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Long") "longValue" "()J")
(.visitLdcInsn ?value)
@@ -48,6 +50,7 @@
[["RealTestAC" ?value]]
(doto writer
+ (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Double"))
(.visitInsn Opcodes/DUP)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Double") "doubleValue" "()D")
(.visitLdcInsn ?value)
@@ -58,6 +61,7 @@
[["CharTestAC" ?value]]
(doto writer
+ (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Character"))
(.visitInsn Opcodes/DUP)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Character") "charValue" "()C")
(.visitLdcInsn ?value)
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index f9a56e74e..5ceeca1bc 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -68,26 +68,26 @@
(return nil)))
(defn compile-record [compile *type* ?elems]
+ ;; (prn 'compile-record (str "{{" (->> ?elems &/|keys (&/|interpose " ") (&/fold str "")) "}}"))
(|do [*writer* &/get-writer
- :let [num-elems (&/|length ?elems)
+ :let [elems* (->> ?elems
+ &/->seq
+ (sort #(compare (&/|first %1) (&/|first %2)))
+ &/->list)
+ ;; _ (prn 'compile-record (str "{{" (->> elems* &/|keys (&/|interpose " ") (&/fold str "")) "}}"))
+ num-elems (&/|length elems*)
_ (doto *writer*
- (.visitLdcInsn (int (* 2 num-elems)))
+ (.visitLdcInsn (int num-elems))
(.visitTypeInsn Opcodes/ANEWARRAY (&host/->class "java.lang.Object")))]
_ (&/map% (fn [idx+kv]
(|let [[idx [k v]] idx+kv]
- (|do [:let [idx* (* 2 idx)
- _ (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int idx*))
- (.visitLdcInsn k)
- (.visitInsn Opcodes/AASTORE))]
- :let [_ (doto *writer*
+ (|do [:let [_ (doto *writer*
(.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int (inc idx*))))]
+ (.visitLdcInsn (int idx)))]
ret (compile v)
:let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
(return ret))))
- (&/zip2 (&/|range num-elems) ?elems))]
+ (&/zip2 (&/|range num-elems) elems*))]
(return nil)))
(defn compile-variant [compile *type* ?tag ?value]
diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj
index ca63576ef..38fe77264 100644
--- a/src/lux/lexer.clj
+++ b/src/lux/lexer.clj
@@ -102,7 +102,10 @@
(def ^:private lex-tag
(|do [[_ [meta _]] (&reader/read-text "#")
- [_ [_ ident]] lex-ident]
+ ;; :let [_ (prn 'lex-tag)]
+ [_ [_ ident]] lex-ident
+ ;; :let [_ (prn 'lex-tag [(aget ident 0) (aget ident 1)])]
+ ]
(return (&/V "lux;Meta" (&/T meta (&/V "Tag" ident))))))
(do-template [<name> <text> <tag>]
diff --git a/src/lux/macro.clj b/src/lux/macro.clj
deleted file mode 100644
index d5fee9eab..000000000
--- a/src/lux/macro.clj
+++ /dev/null
@@ -1,25 +0,0 @@
-(ns lux.macro
- (:require [clojure.core.match :as M :refer [match matchv]]
- clojure.core.match.array
- (lux [base :as & :refer [fail* return*]])))
-
-;; [Resources]
-(defn expand [loader macro-class tokens]
- (fn [state]
- ;; (prn 'expand macro-class tokens state)
- (let [expansion (-> (.loadClass loader macro-class)
- (.getField "_datum")
- (.get nil)
- (.apply tokens)
- (.apply state))]
- ;; (if (or (= "lux$_BQUOTE_" macro-class)
- ;; (= "lux$if" macro-class))
- ;; (matchv ::M/objects [expansion]
- ;; [["lux;Right" [state* nodes]]]
- ;; (doseq [node (&/->seq nodes)]
- ;; (prn 'expansion macro-class (&/show-ast node)))
-
- ;; [_]
- ;; nil))
- expansion)
- ))
diff --git a/src/lux/parser.clj b/src/lux/parser.clj
index a21dd5ba6..85074be7d 100644
--- a/src/lux/parser.clj
+++ b/src/lux/parser.clj
@@ -9,7 +9,7 @@
(do-template [<name> <close-tag> <description> <tag>]
(defn <name> [parse]
(|do [elems (&/repeat% parse)
- token &lexer/lex]
+ token &lexer/lex]
(matchv ::M/objects [token]
[["lux;Meta" [meta [<close-token> _]]]]
(return (&/V <tag> (&/fold &/|++ (&/|list) elems)))
@@ -22,13 +22,19 @@
)
(defn ^:private parse-record [parse]
- (|do [elems* (&/repeat% parse)
- token &lexer/lex
- :let [elems (&/fold &/|++ (&/|list) elems*)]]
+ (|do [;; :let [_ (prn 'parse-record 0)]
+ elems* (&/repeat% parse)
+ ;; :let [_ (prn 'parse-record 1)]
+ token &lexer/lex
+ ;; :let [_ (prn 'parse-record 2)]
+ :let [elems (&/fold &/|++ (&/|list) elems*)]
+ ;; :let [_ (prn 'parse-record 3)]
+ ]
(matchv ::M/objects [token]
[["lux;Meta" [meta ["Close_Brace" _]]]]
(if (even? (&/|length elems))
- (return (&/V "lux;Record" (&/|as-pairs elems)))
+ (do ;; (prn 'PARSED_RECORD (&/|length elems))
+ (return (&/V "lux;Record" (&/|as-pairs elems))))
(fail (str "[Parser Error] Records must have an even number of elements.")))
[_]
@@ -37,9 +43,9 @@
;; [Interface]
(def parse
(|do [token &lexer/lex
- ;; :let [_ (prn 'parse/token token)]
- ;; :let [_ (prn 'parse (aget token 0))]
- ]
+ ;; :let [_ (prn 'parse/token token)]
+ ;; :let [_ (prn 'parse (aget token 0))]
+ ]
(matchv ::M/objects [token]
[["lux;Meta" [meta ["White_Space" _]]]]
(return (&/|list))
diff --git a/src/lux/type.clj b/src/lux/type.clj
index dcaf0bf5e..73b244569 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -177,10 +177,11 @@
(fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound)))
[["lux;None" _]]
- (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V "lux;Some" type) %)
- ts))
- state)
- nil)))
+ (do ;; (prn 'set-var id (show-type type))
+ (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V "lux;Some" type) %)
+ ts))
+ state)
+ nil))))
(fail* (str "[Type Error] Unknown type-var: " id)))))
;; [Exports]
@@ -309,7 +310,7 @@
(&/|map (fn [kv]
(matchv ::M/objects [kv]
[[k v]]
- (str "(#" k " " (show-type v) ")"))))
+ (str "#" k " " (show-type v)))))
(&/|interpose " ")
(&/fold str "")) ")")
@@ -326,7 +327,15 @@
(str "(" (show-type ?lambda) " " (show-type ?param) ")")
[["lux;AllT" [?env ?name ?arg ?body]]]
- (str "(All " ?name " " ?arg " " (show-type ?body) ")")
+ (let [[args body] (loop [args (list ?arg)
+ body* ?body]
+ (matchv ::M/objects [body*]
+ [["lux;AllT" [?env* ?name* ?arg* ?body*]]]
+ (recur (cons ?arg* args) ?body*)
+
+ [_]
+ [args body*]))]
+ (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")"))
))
(defn type= [x y]
@@ -524,6 +533,21 @@
(|do [bound (deref ?id)]
(check* fixpoints expected bound))))
+ ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [F2 A2]]]
+ ;; (|do [_ (check* fixpoints F1 F2)
+ ;; _ (check* fixpoints A1 A2)]
+ ;; (return (&/T fixpoints nil)))
+
+ [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]]
+ (|do [[fixpoints _] (check* fixpoints (&/V "lux;VarT" ?id) F2)
+ [fixpoints _] (check* fixpoints A1 A2)]
+ (return (&/T fixpoints nil)))
+
+ [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]]
+ (|do [[fixpoints _] (check* fixpoints F1 (&/V "lux;VarT" ?id))
+ [fixpoints _] (check* fixpoints A1 A2)]
+ (return (&/T fixpoints nil)))
+
[["lux;AppT" [F A]] _]
(let [fp-pair (&/T expected actual)
;; _ (prn 'LEFT_APP (&/|length fixpoints))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-26 22:16:53 +0000