From ccf68d96c9c9e6bb6016ee8663289c3b3f6079d2 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 28 Apr 2015 01:18:39 -0400 Subject: - Fixed some errors in lux.lux. - Added the ability to export from def. - Added an optimized lambda macro. - Finished record analysis & compilation. - Fixed a bug in tuple, function & record analysis wherein AppT wasn't being performed prior to analysing the expression under analysis. - Fixed several bugs wherein "fail*" was needed but "fail" was used. - Added a case for records in base;show-ast. - Made an improvement for AllT in type;show-type. - Corrected an error in pattern-matching compilation wherein casts weren't being performed to make sure the source datum was of the necessary type for PM. - Removed the (now unnecessary) lux/macro. --- source/lux.lux | 2396 +++++++++++++++++++++++-------------------- src/lux/analyser.clj | 3 +- src/lux/analyser/lux.clj | 195 ++-- src/lux/analyser/module.clj | 5 +- src/lux/base.clj | 31 +- src/lux/compiler.clj | 2 +- src/lux/compiler/case.clj | 4 + src/lux/compiler/lux.clj | 22 +- src/lux/lexer.clj | 5 +- src/lux/macro.clj | 25 - src/lux/parser.clj | 22 +- src/lux/type.clj | 36 +- 12 files changed, 1483 insertions(+), 1263 deletions(-) delete mode 100644 src/lux/macro.clj 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 [ ] -## ## (def ( p xs) -## ## (case xs -## ## #Nil true -## ## (#Cons [x xs']) ( (p x) ( 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 [ ] -## ## (def (int+ )) - -## ## [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 [ ] -## [(def ( x y) -## (-> Int Int Int) -## (if ( x y) -## x -## y))] - -## [max int>] -## [min int<]) - -## (do-templates [ ] -## [(def ( n) -## (-> Int Bool) -## ( 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 [ ] -## [(def ( n xs) -## (All [a] -## (-> Int (List a) (List a))) -## (if (int> n 0) -## (case' xs -## #Nil #Nil -## (#Cons [x xs']) ) -## ))] - -## [take #Nil (list+ x (take (dec n) xs'))] -## [drop xs (drop (dec n) xs')]) - -## (do-templates [ ] -## [(def ( f xs) -## (All [a] -## (-> (-> a Bool) (List a) (List a))) -## (case' xs -## #Nil #Nil -## (#Cons [x xs']) (if (f x) #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 [ ] -## ## (def ( pair) -## ## (case' pair -## ## [f s] -## ## )) - -## ## [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 [ ] +## ## ## (def ( p xs) +## ## ## (case xs +## ## ## #Nil true +## ## ## (#Cons [x xs']) ( (p x) ( 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 [ ] +## ## ## (def (int+ )) + +## ## ## [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 [ ] +## ## [(def ( x y) +## ## (-> Int Int Int) +## ## (if ( x y) +## ## x +## ## y))] + +## ## [max int>] +## ## [min int<]) + +## ## (do-templates [ ] +## ## [(def ( n) +## ## (-> Int Bool) +## ## ( 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 [ ] +## ## [(def ( n xs) +## ## (All [a] +## ## (-> Int (List a) (List a))) +## ## (if (int> n 0) +## ## (case' xs +## ## #Nil #Nil +## ## (#Cons [x xs']) ) +## ## ))] + +## ## [take #Nil (list+ x (take (dec n) xs'))] +## ## [drop xs (drop (dec n) xs')]) + +## ## (do-templates [ ] +## ## [(def ( f xs) +## ## (All [a] +## ## (-> (-> a Bool) (List a) (List a))) +## ## (case' xs +## ## #Nil #Nil +## ## (#Cons [x xs']) (if (f x) #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 [ ] +## ## ## (def ( pair) +## ## ## (case' pair +## ## ## [f s] +## ## ## )) + +## ## ## [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 ¯o] [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 ¯o] [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 [ ] 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 [ ] (defn [parse] (|do [elems (&/repeat% parse) - token &lexer/lex] + token &lexer/lex] (matchv ::M/objects [token] [["lux;Meta" [meta [ _]]]] (return (&/V (&/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)) -- cgit v1.2.3