diff options
30 files changed, 2320 insertions, 2288 deletions
diff --git a/source/lux.lux b/source/lux.lux index 97030a7ef..4120b262c 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -11,50 +11,51 @@ ("apply" ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) ## Basic types -(_lux_def Bool (11 ["lux" "Bool"] - (4 "java.lang.Boolean"))) +(_lux_def Bool (9 ["lux" "Bool"] + (0 "java.lang.Boolean"))) (_lux_export Bool) -(_lux_def Int (11 ["lux" "Int"] - (4 "java.lang.Long"))) +(_lux_def Int (9 ["lux" "Int"] + (0 "java.lang.Long"))) (_lux_export Int) -(_lux_def Real (11 ["lux" "Real"] - (4 "java.lang.Double"))) +(_lux_def Real (9 ["lux" "Real"] + (0 "java.lang.Double"))) (_lux_export Real) -(_lux_def Char (11 ["lux" "Char"] - (4 "java.lang.Character"))) +(_lux_def Char (9 ["lux" "Char"] + (0 "java.lang.Character"))) (_lux_export Char) -(_lux_def Text (11 ["lux" "Text"] - (4 "java.lang.String"))) +(_lux_def Text (9 ["lux" "Text"] + (0 "java.lang.String"))) (_lux_export Text) -(_lux_def Void (11 ["lux" "Void"] - (0 []))) -(_lux_export Void) - -(_lux_def Unit (11 ["lux" "Unit"] - (1 []))) +(_lux_def Unit (9 ["lux" "Unit"] + (2 (0)))) (_lux_export Unit) -(_lux_def Ident (11 ["lux" "Ident"] - (3 Text Text))) +(_lux_def Void (9 ["lux" "Void"] + (1 (0)))) +(_lux_export Void) + +(_lux_def Ident (9 ["lux" "Ident"] + (2 (1 Text (1 Text (0)))))) (_lux_export Ident) ## (deftype (List a) ## (| #Nil ## (#Cons a (List a)))) (_lux_def List - (11 ["lux" "List"] - (9 (1 (0)) "lux;List" "a" - (2 ## "lux;Nil" - Unit - ## "lux;Cons" - (3 (6 "a") - (10 (6 "lux;List") (6 "a"))) - )))) + (9 ["lux" "List"] + (7 (1 (0)) "lux;List" "a" + (1 (1 ## "lux;Nil" + (2 (0)) + (1 ## "lux;Cons" + (2 (1 (4 "a") + (1 (8 (4 "lux;List") (4 "a")) + (0)))) + (0))))))) (_lux_export List) (_lux_declare-tags [#Nil #Cons] List) @@ -62,78 +63,76 @@ ## (| #None ## (1 a))) (_lux_def Maybe - (11 ["lux" "Maybe"] - (9 (1 #Nil) "lux;Maybe" "a" - (2 ## "lux;None" - Unit - ## "lux;Some" - (6 "a") - )))) + (9 ["lux" "Maybe"] + (7 (1 (0)) "lux;Maybe" "a" + (1 (1 ## "lux;None" + (2 (0)) + (1 ## "lux;Some" + (4 "a") + (0))))))) (_lux_export Maybe) (_lux_declare-tags [#None #Some] Maybe) ## (deftype #rec Type -## (| #VoidT -## #UnitT -## (#SumT Type Type) -## (#ProdT Type Type) -## (#DataT Text) +## (| (#DataT Text) +## (#VariantT (List Type)) +## (#TupleT (List Type)) ## (#LambdaT Type Type) ## (#BoundT Text) ## (#VarT Int) -## (#ExT Int) ## (#AllT (Maybe (List (, Text Type))) Text Text Type) ## (#AppT Type Type) ## (#NamedT Ident Type) -## )) +## )) (_lux_def Type - (11 ["lux" "Type"] - (_lux_case (10 (6 "Type") (6 "_")) - Type - (_lux_case (10 List (3 Text Type)) - TypeEnv - (10 (9 (#Some #Nil) "Type" "_" - (2 ## lux;VoidT - Unit - (2 ## lux;UnitT - Unit - (2 ## lux;SumT - (3 Type Type) - (2 ## lux;ProdT - (3 Type Type) - (2 ## "lux;DataT" - Text - (2 ## "lux;LambdaT" - (3 Type Type) - (2 ## "lux;BoundT" - Text - (2 ## "lux;VarT" - Int - (2 ## "lux;ExT" + (9 ["lux" "Type"] + (_lux_case (8 (4 "Type") (4 "_")) + Type + (_lux_case (8 List (2 (1 Text (1 Type (0))))) + TypeEnv + (_lux_case (8 List Type) + TypeList + (8 (7 (1 (0)) "Type" "_" + (1 (1 ## "lux;DataT" + Text + (1 ## "lux;VariantT" + TypeList + (1 ## "lux;TupleT" + TypeList + (1 ## "lux;LambdaT" + (2 (1 Type (1 Type (0)))) + (1 ## "lux;BoundT" + Text + (1 ## "lux;VarT" Int - (2 ## "lux;AllT" - (3 (10 Maybe TypeEnv) (3 Text (3 Text Type))) - (2 ## "lux;AppT" - (3 Type Type) - ## "lux;NamedT" - (3 Ident Type))))))))))))) - Void))))) + (1 ## "lux;ExT" + Int + (1 ## "lux;AllT" + (2 (1 (8 Maybe TypeEnv) (1 Text (1 Text (1 Type (0)))))) + (1 ## "lux;AppT" + (2 (1 Type (1 Type (0)))) + (1 ## "lux;NamedT" + (2 (1 Ident (1 Type (0)))) + (0))))))))))))) + Void)))))) (_lux_export Type) -(_lux_declare-tags [#VoidT #UnitT #SumT #ProdT #DataT #LambdaT #BoundT #VarT #ExT #AllT #AppT #NamedT] Type) +(_lux_declare-tags [#DataT #VariantT #TupleT #LambdaT #BoundT #VarT #ExT #AllT #AppT #NamedT] Type) ## (deftype (Bindings k v) ## (& #counter Int ## #mappings (List (, k v)))) (_lux_def Bindings (#NamedT ["lux" "Bindings"] - (#AllT (#Some #Nil) "lux;Bindings" "k" - (#AllT #None "" "v" - (#ProdT ## lux;counter - Int - ## lux;mappings - (#AppT List - (#ProdT (#BoundT "k") - (#BoundT "v")))))))) + (#AllT [(#Some #Nil) "lux;Bindings" "k" + (#AllT [#None "" "v" + (#TupleT (#Cons ## "lux;counter" + Int + (#Cons ## "lux;mappings" + (#AppT [List + (#TupleT (#Cons [(#BoundT "k") + (#Cons [(#BoundT "v") + #Nil])]))]) + #Nil)))])]))) (_lux_export Bindings) (_lux_declare-tags [#counter #mappings] Bindings) @@ -146,16 +145,17 @@ (#NamedT ["lux" "Env"] (#AllT (#Some #Nil) "lux;Env" "k" (#AllT #None "" "v" - (#ProdT ## "lux;name" - Text - (#ProdT ## "lux;inner-closures" - Int - (#ProdT ## "lux;locals" - (#AppT (#AppT Bindings (#BoundT "k")) - (#BoundT "v")) - ## "lux;closure" - (#AppT (#AppT Bindings (#BoundT "k")) - (#BoundT "v"))))))))) + (#TupleT (#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))))))))) (_lux_export Env) (_lux_declare-tags [#name #inner-closures #locals #closure] Env) @@ -163,7 +163,7 @@ ## (, Text Int Int)) (_lux_def Cursor (#NamedT ["lux" "Cursor"] - (#ProdT Text (#ProdT Int Int)))) + (#TupleT (#Cons Text (#Cons Int (#Cons Int #Nil)))))) (_lux_export Cursor) ## (deftype (Meta m v) @@ -172,9 +172,13 @@ (#NamedT ["lux" "Meta"] (#AllT (#Some #Nil) "lux;Meta" "m" (#AllT #None "" "v" - (#ProdT (#BoundT "m") - (#BoundT "v")))))) + (#VariantT (#Cons ## "lux;Meta" + (#TupleT (#Cons (#BoundT "m") + (#Cons (#BoundT "v") + #Nil))) + #Nil)))))) (_lux_export Meta) +(_lux_declare-tags [#Meta] Meta) ## (deftype (AST' w) ## (| (#BoolS Bool) @@ -196,28 +200,29 @@ (_lux_case (#AppT [List AST]) ASTList (#AllT (#Some #Nil) "lux;AST'" "w" - (#SumT ## "lux;BoolS" - Bool - (#SumT ## "lux;IntS" - Int - (#SumT ## "lux;RealS" - Real - (#SumT ## "lux;CharS" - Char - (#SumT ## "lux;TextS" - Text - (#SumT ## "lux;SymbolS" - Ident - (#SumT ## "lux;TagS" - Ident - (#SumT ## "lux;FormS" - ASTList - (#SumT ## "lux;TupleS" - ASTList - ## "lux;RecordS" - (#AppT List (#ProdT AST AST)) - )))))))) - )))))) + (#VariantT (#Cons ## "lux;BoolS" + Bool + (#Cons ## "lux;IntS" + Int + (#Cons ## "lux;RealS" + Real + (#Cons ## "lux;CharS" + Char + (#Cons ## "lux;TextS" + Text + (#Cons ## "lux;SymbolS" + Ident + (#Cons ## "lux;TagS" + Ident + (#Cons ## "lux;FormS" + ASTList + (#Cons ## "lux;TupleS" + ASTList + (#Cons ## "lux;RecordS" + (#AppT List (#TupleT (#Cons AST (#Cons AST #Nil)))) + #Nil) + ))))))))) + )))))) (_lux_export AST') (_lux_declare-tags [#BoolS #IntS #RealS #CharS #TextS #SymbolS #TagS #FormS #TupleS #RecordS] AST') @@ -239,30 +244,32 @@ (#NamedT ["lux" "Either"] (#AllT (#Some #Nil) "lux;Either" "l" (#AllT #None "" "r" - (#SumT ## "lux;Left" - (#BoundT "l") - ## "lux;Right" - (#BoundT "r")))))) + (#VariantT (#Cons ## "lux;Left" + (#BoundT "l") + (#Cons ## "lux;Right" + (#BoundT "r") + #Nil))))))) (_lux_export Either) (_lux_declare-tags [#Left #Right] Either) ## (deftype (StateE s a) ## (-> s (Either Text (, s a)))) (_lux_def StateE - (#AllT (#Some #Nil) "lux;StateE" "s" - (#AllT #None "" "a" - (#LambdaT (#BoundT "s") - (#AppT (#AppT [Either Text]) - (#ProdT (#BoundT "s") - (#BoundT "a"))))))) + (#AllT [(#Some #Nil) "lux;StateE" "s" + (#AllT [#None "" "a" + (#LambdaT [(#BoundT "s") + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [(#BoundT "s") + (#Cons [(#BoundT "a") + #Nil])]))])])])])) ## (deftype Source ## (List (Meta Cursor Text))) (_lux_def Source (#NamedT ["lux" "Source"] - (#AppT List - (#AppT (#AppT Meta Cursor) - Text)))) + (#AppT [List + (#AppT [(#AppT [Meta Cursor]) + Text])]))) (_lux_export Source) ## (deftype Host @@ -271,12 +278,13 @@ ## #classes (^ clojure.lang.Atom))) (_lux_def Host (#NamedT ["lux" "Host"] - (#ProdT ## "lux;writer" - (#DataT "org.objectweb.asm.ClassWriter") - (#ProdT ## "lux;loader" - (#DataT "java.lang.ClassLoader") - ## "lux;classes" - (#DataT "clojure.lang.Atom"))))) + (#TupleT (#Cons [## "lux;writer" + (#DataT "org.objectweb.asm.ClassWriter") + (#Cons [## "lux;loader" + (#DataT "java.lang.ClassLoader") + (#Cons [## "lux;classes" + (#DataT "clojure.lang.Atom") + #Nil])])])))) (_lux_declare-tags [#writer #loader #classes] Host) ## (deftype (DefData' m) @@ -287,15 +295,17 @@ (_lux_def DefData' (#NamedT ["lux" "DefData'"] (#AllT [(#Some #Nil) "lux;DefData'" "" - (#SumT ## "lux;ValueD" - (#ProdT Type - Unit) - (#SumT ## "lux;TypeD" - Type - (#SumT ## "lux;MacroD" - (#BoundT "") - ## "lux;AliasD" - Ident)))]))) + (#VariantT (#Cons [## "lux;ValueD" + (#TupleT (#Cons [Type + (#Cons [Unit + #Nil])])) + (#Cons [## "lux;TypeD" + Type + (#Cons [## "lux;MacroD" + (#BoundT "") + (#Cons [## "lux;AliasD" + Ident + #Nil])])])]))]))) (_lux_export DefData') (_lux_declare-tags [#ValueD #TypeD #MacroD #AliasD] DefData') @@ -304,10 +314,11 @@ ## (#Global Ident))) (_lux_def LuxVar (#NamedT ["lux" "LuxVar"] - (#SumT ## "lux;Local" - Int - ## "lux;Global" - Ident))) + (#VariantT (#Cons [## "lux;Local" + Int + (#Cons [## "lux;Global" + Ident + #Nil])])))) (_lux_export LuxVar) (_lux_declare-tags [#Local #Global] LuxVar) @@ -320,28 +331,34 @@ ## )) (_lux_def Module (#NamedT ["lux" "Module"] - (#AllT (#Some #Nil) "lux;Module" "Compiler" - (#ProdT ## "lux;module-aliases" - (#AppT List (#ProdT Text Text)) - (#ProdT ## "lux;defs" - (#AppT List (#ProdT Text - (#ProdT Bool - (#AppT DefData' (#LambdaT ASTList - (#AppT (#AppT StateE (#BoundT "Compiler")) - ASTList)))))) - (#ProdT ## "lux;imports" - (#AppT List Text) - (#ProdT ## "lux;tags" - (#AppT List - (#ProdT Text - (#ProdT Int - (#ProdT (#AppT List Ident) - Type)))) - ## "lux;types" - (#AppT List - (#ProdT Text - (#ProdT (#AppT List Ident) - Type)))))))))) + (#AllT [(#Some #Nil) "lux;Module" "Compiler" + (#TupleT (#Cons [## "lux;module-aliases" + (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))]) + (#Cons [## "lux;defs" + (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [ASTList + (#AppT [(#AppT [StateE (#BoundT "Compiler")]) + ASTList])])]) + #Nil])])) + #Nil])]))]) + (#Cons [## "lux;imports" + (#AppT [List Text]) + (#Cons [## "lux;tags" + (#AppT [List + (#TupleT (#Cons Text + (#Cons (#TupleT (#Cons Int + (#Cons (#AppT [List Ident]) + (#Cons Type + #Nil)))) + #Nil)))]) + (#Cons [## "lux;types" + (#AppT [List + (#TupleT (#Cons Text + (#Cons (#TupleT (#Cons (#AppT [List Ident]) + (#Cons Type + #Nil))) + #Nil)))]) + #Nil])])])])]))]))) (_lux_export Module) (_lux_declare-tags [#module-aliases #defs #imports #tags #types] Module) @@ -358,28 +375,30 @@ ## )) (_lux_def Compiler (#NamedT ["lux" "Compiler"] - (#AppT (#AllT (#Some #Nil) "lux;Compiler" "" - (#ProdT ## "lux;source" - Source - (#ProdT ## "lux;cursor" - Cursor - (#ProdT ## "lux;modules" - (#AppT List (#ProdT Text - (#AppT Module (#AppT (#BoundT "lux;Compiler") (#BoundT ""))))) - (#ProdT ## "lux;envs" - (#AppT List (#AppT (#AppT [Env Text]) - (#ProdT LuxVar Type))) - (#ProdT ## "lux;type-vars" - (#AppT (#AppT Bindings Int) Type) - (#ProdT ## "lux;expected" - Type - (#ProdT ## "lux;seed" - Int - (#ProdT ## "lux;eval?" - Bool - ## "lux;host" - Host))))))))) - Void))) + (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" + (#TupleT (#Cons [## "lux;source" + Source + (#Cons [## "lux;cursor" + Cursor + (#Cons [## "lux;modules" + (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) + #Nil])]))]) + (#Cons [## "lux;envs" + (#AppT [List (#AppT [(#AppT [Env Text]) + (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])]) + (#Cons [## "lux;type-vars" + (#AppT [(#AppT [Bindings Int]) Type]) + (#Cons [## "lux;expected" + Type + (#Cons [## "lux;seed" + Int + (#Cons [## "lux;eval?" + Bool + (#Cons [## "lux;host" + Host + #Nil])])])])])])])])]))]) + Void]))) (_lux_export Compiler) (_lux_declare-tags [#source #cursor #modules #envs #type-vars #expected #seed #eval? #host] Compiler) @@ -407,7 +426,7 @@ (#AppT Meta Cursor)) AST) (_lux_lambda _ data - [_cursor data]))) + (#Meta _cursor data)))) ## (def (return x) ## (All [a] @@ -419,8 +438,9 @@ (#LambdaT (#BoundT "a") (#LambdaT Compiler (#AppT (#AppT Either Text) - (#ProdT Compiler - (#BoundT "a")))))) + (#TupleT (#Cons Compiler + (#Cons (#BoundT "a") + #Nil))))))) (_lux_lambda _ val (_lux_lambda _ state (#Right state val))))) @@ -435,8 +455,9 @@ (#LambdaT Text (#LambdaT Compiler (#AppT (#AppT Either Text) - (#ProdT Compiler - (#BoundT "a")))))) + (#TupleT (#Cons Compiler + (#Cons (#BoundT "a") + #Nil))))))) (_lux_lambda _ msg (_lux_lambda _ state (#Left msg))))) @@ -472,7 +493,7 @@ (_meta (#TupleS tokens))))) (_lux_def record$ - (_lux_: (#LambdaT (#AppT List (#ProdT AST AST)) AST) + (_lux_: (#LambdaT (#AppT List (#TupleT (#Cons AST (#Cons AST #Nil)))) AST) (_lux_lambda _ tokens (_meta (#RecordS tokens))))) @@ -493,7 +514,7 @@ (_lux_: Macro (_lux_lambda _ tokens (_lux_case tokens - (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil)) + (#Cons (#Meta _ (#TupleS (#Cons arg args'))) (#Cons body #Nil)) (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda")) (#Cons (_meta (#SymbolS "" "")) (#Cons arg @@ -508,7 +529,7 @@ #Nil)))))) #Nil)) - (#Cons [_ (#SymbolS self)] (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil))) + (#Cons (#Meta _ (#SymbolS self)) (#Cons (#Meta _ (#TupleS (#Cons arg args'))) (#Cons body #Nil))) (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda")) (#Cons (_meta (#SymbolS self)) (#Cons arg @@ -531,9 +552,9 @@ (_lux_: Macro (lambda'' [tokens] (_lux_case tokens - (#Cons [_ (#TagS ["" "export"])] - (#Cons [_ (#FormS (#Cons name args))] - (#Cons type (#Cons body #Nil)))) + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) @@ -547,7 +568,7 @@ (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) #Nil])])) - (#Cons [_ (#TagS "" "export")] (#Cons name (#Cons type (#Cons body #Nil)))) + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) @@ -558,8 +579,8 @@ (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) #Nil])])) - (#Cons [_ (#FormS (#Cons name args))] - (#Cons type (#Cons body #Nil))) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) @@ -572,7 +593,7 @@ #Nil])])]))) #Nil])) - (#Cons name (#Cons type (#Cons body #Nil))) + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) @@ -590,7 +611,7 @@ (def'' (defmacro tokens) Macro (_lux_case tokens - (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [body #Nil])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"]) (#Cons [(form$ (#Cons [name args])) (#Cons [(symbol$ ["lux" "Macro"]) @@ -600,7 +621,7 @@ (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) #Nil])])) - (#Cons [[_ (#TagS ["" "export"])] (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [body #Nil])])]) + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"]) (#Cons [(tag$ ["" "export"]) (#Cons [(form$ (#Cons [name args])) @@ -640,12 +661,12 @@ (defmacro (All' tokens) (_lux_case tokens - (#Cons [[_ (#TupleS #Nil)] + (#Cons [(#Meta [_ (#TupleS #Nil)]) (#Cons [body #Nil])]) (return (#Cons [body #Nil])) - (#Cons [[_ (#TupleS (#Cons [[_ (#SymbolS ["" arg-name])] other-args]))] + (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) (#Cons [body #Nil])]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) @@ -664,7 +685,7 @@ (defmacro (B' tokens) (_lux_case tokens - (#Cons [[_ (#SymbolS ["" bound-name])] + (#Cons [(#Meta [_ (#SymbolS ["" bound-name])]) #Nil]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) (#Cons [(_meta (#TextS bound-name)) @@ -732,15 +753,15 @@ (fail "Wrong syntax for list&"))) (defmacro (lambda' tokens) - (let'' [name tokens'] (_lux_: (#ProdT Ident ($' List AST)) + (let'' [name tokens'] (_lux_: (#TupleT (list Ident ($' List AST))) (_lux_case tokens - (#Cons [[_ (#SymbolS name)] tokens']) + (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) [name tokens'] _ [["" ""] tokens])) (_lux_case tokens' - (#Cons [[_ (#TupleS args)] (#Cons [body #Nil])]) + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) (_lux_case args #Nil (fail "lambda' requires a non-empty arguments tuple.") @@ -762,8 +783,8 @@ (defmacro (def''' tokens) (_lux_case tokens - (#Cons [[_ (#TagS ["" "export"])] - (#Cons [[_ (#FormS (#Cons [name args]))] + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])])]) (return (list (form$ (list (symbol$ ["" "_lux_def"]) name @@ -775,7 +796,7 @@ body)))))) (form$ (list (symbol$ ["" "_lux_export"]) name)))) - (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) (return (list (form$ (list (symbol$ ["" "_lux_def"]) name (form$ (list (symbol$ ["" "_lux_:"]) @@ -783,7 +804,7 @@ body)))) (form$ (list (symbol$ ["" "_lux_export"]) name)))) - (#Cons [[_ (#FormS (#Cons [name args]))] + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) (return (list (form$ (list (symbol$ ["" "_lux_def"]) name @@ -805,7 +826,7 @@ (def''' (as-pairs xs) (All' [a] - (->' ($' List (B' a)) ($' List (#ProdT (B' a) (B' a))))) + (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) (_lux_case xs (#Cons [x (#Cons [y xs'])]) (#Cons [[x y] (as-pairs xs')]) @@ -815,8 +836,8 @@ (defmacro (let' tokens) (_lux_case tokens - (#Cons [[_ (#TupleS bindings)] (#Cons [body #Nil])]) - (return (list (foldL (_lux_: (->' AST (#ProdT AST AST) + (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) + (return (list (foldL (_lux_: (->' AST (#TupleT (list AST AST)) AST) (lambda' [body binding] (_lux_case binding @@ -853,7 +874,7 @@ (def''' (spliced? token) (->' AST Bool) (_lux_case token - [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [_ #Nil])]))] + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) true _ @@ -861,8 +882,9 @@ (def''' (wrap-meta content) (->' AST AST) - (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) - content)))) + (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"])) + (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) + content))))))) (def''' (untemplate-list tokens) (->' ($' List AST) AST) @@ -901,7 +923,7 @@ true (let' [elems' (map (lambda' [elem] (_lux_case elem - [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [spliced #Nil])]))] + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) spliced _ @@ -922,23 +944,23 @@ (def''' (untemplate replace? subst token) (->' Bool Text AST AST) - (_lux_case (_lux_: (#ProdT Bool AST) [replace? token]) - [_ [_ (#BoolS value)]] + (_lux_case (_lux_: (#TupleT (list Bool AST)) [replace? token]) + [_ (#Meta [_ (#BoolS value)])] (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value))))) - [_ [_ (#IntS value)]] + [_ (#Meta [_ (#IntS value)])] (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value))))) - [_ [_ (#RealS value)]] + [_ (#Meta [_ (#RealS value)])] (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value))))) - [_ [_ (#CharS value)]] + [_ (#Meta [_ (#CharS value)])] (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value))))) - [_ [_ (#TextS value)]] + [_ (#Meta [_ (#TextS value)])] (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value))))) - [_ [_ (#TagS [module name])]] + [_ (#Meta [_ (#TagS [module name])])] (let' [module' (_lux_case module "" subst @@ -947,7 +969,7 @@ module)] (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))) - [_ [_ (#SymbolS [module name])]] + [_ (#Meta [_ (#SymbolS [module name])])] (let' [module' (_lux_case module "" subst @@ -956,19 +978,19 @@ module)] (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) - [_ [_ (#TupleS elems)]] + [_ (#Meta [_ (#TupleS elems)])] (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) - [true [_ (#FormS (#Cons [[_ (#SymbolS ["" "~"])] (#Cons [unquoted #Nil])]))]] + [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])] unquoted - [_ [meta (#FormS elems)]] - (let' [[_ form'] (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)] - [meta form']) + [_ (#Meta [meta (#FormS elems)])] + (let' [(#Meta [_ form']) (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)] + (#Meta [meta form'])) - [_ [_ (#RecordS fields)]] + [_ (#Meta [_ (#RecordS fields)])] (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) - (untemplate-list (map (_lux_: (->' (#ProdT AST AST) AST) + (untemplate-list (map (_lux_: (->' (#TupleT (list AST AST)) AST) (lambda' [kv] (let' [[k v] kv] (tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v)))))) @@ -994,17 +1016,16 @@ (defmacro #export (|> tokens) (_lux_case tokens (#Cons [init apps]) - (return (list (foldL (_lux_: (->' AST AST AST) - (lambda' [acc app] - (_lux_case app - [_ (#TupleS parts)] - (tuple$ (list:++ parts (list acc))) + (return (list (foldL (lambda' [acc app] + (_lux_case app + (#Meta [_ (#TupleS parts)]) + (tuple$ (list:++ parts (list acc))) - [_ (#FormS parts)] - (form$ (list:++ parts (list acc))) + (#Meta [_ (#FormS parts)]) + (form$ (list:++ parts (list acc))) - _ - (`' ((~ app) (~ acc)))))) + _ + (`' ((~ app) (~ acc))))) init apps))) @@ -1026,7 +1047,7 @@ (def''' #export Lux Type (All' [a] - (->' Compiler ($' Either Text (#ProdT Compiler (B' a)))))) + (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a))))))) ## (defsig (Monad m) ## (: (All [a] (-> a (m a))) @@ -1037,44 +1058,44 @@ Type (#NamedT ["lux" "Monad"] (All' [m] - (#ProdT (All' [a] (->' (B' a) ($' (B' m) (B' a)))) - (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) - ($' (B' m) (B' a)) - ($' (B' m) (B' b)))))))) + (#TupleT (list (All' [a] (->' (B' a) ($' (B' m) (B' a)))) + (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) + ($' (B' m) (B' a)) + ($' (B' m) (B' b))))))))) (_lux_declare-tags [#return #bind] Monad) (def''' Maybe/Monad ($' Monad Maybe) {#return (lambda' return [x] - (#Some x)) + (#Some x)) #bind (lambda' [f ma] - (_lux_case ma - #None #None - (#Some a) (f a)))}) + (_lux_case ma + #None #None + (#Some a) (f a)))}) (def''' Lux/Monad ($' Monad Lux) {#return (lambda' [x] - (lambda' [state] - (#Right state x))) + (lambda' [state] + (#Right state x))) #bind (lambda' [f ma] - (lambda' [state] - (_lux_case (ma state) - (#Left msg) - (#Left msg) + (lambda' [state] + (_lux_case (ma state) + (#Left msg) + (#Left msg) - (#Right state' a) - (f a state'))))}) + (#Right state' a) + (f a state'))))}) (defmacro #export (^ tokens) (_lux_case tokens - (#Cons [_ (#SymbolS "" class-name)] #Nil) + (#Cons (#Meta _ (#SymbolS "" class-name)) #Nil) (return (list (`' (#;DataT (~ (_meta (#TextS class-name))))))) _ @@ -1083,8 +1104,7 @@ (defmacro #export (-> tokens) (_lux_case (reverse tokens) (#Cons output inputs) - (return (list (foldL (_lux_: (->' AST AST AST) - (lambda' [o i] (`' (#;LambdaT (~ i) (~ o))))) + (return (list (foldL (lambda' [o i] (`' (#;LambdaT (~ i) (~ o)))) output inputs))) @@ -1092,32 +1112,23 @@ (fail "Wrong syntax for ->"))) (defmacro #export (, tokens) - (_lux_case (reverse tokens) - (#Cons last prevs) - (return (list (foldL (_lux_: (->' AST AST AST) - (lambda' [r l] (`' (#;ProdT (~ l) (~ r))))) - last - prevs))) - - _ - (fail ", must have at least 2 members.")) - ) + (return (list (`' (#;TupleT (~ (untemplate-list tokens))))))) (defmacro (do tokens) (_lux_case tokens - (#Cons monad (#Cons [_ (#TupleS bindings)] (#Cons body #Nil))) + (#Cons monad (#Cons (#Meta _ (#TupleS bindings)) (#Cons body #Nil))) (let' [body' (foldL (_lux_: (-> AST (, AST AST) AST) (lambda' [body' binding] - (let' [[var value] binding] - (_lux_case var - [_ (#TagS "" "let")] - (`' (;let' (~ value) (~ body'))) - - _ - (`' (bind (_lux_lambda (~ (symbol$ ["" ""])) - (~ var) - (~ body')) - (~ value))))))) + (let' [[var value] binding] + (_lux_case var + (#Meta _ (#TagS "" "let")) + (`' (;let' (~ value) (~ body'))) + + _ + (`' (bind (_lux_lambda (~ (symbol$ ["" ""])) + (~ var) + (~ body')) + (~ value))))))) body (reverse (as-pairs bindings)))] (return (list (`' (_lux_case (~ monad) @@ -1156,7 +1167,7 @@ (def''' (get-ident x) (-> AST ($' Maybe Ident)) (_lux_case x - [_ (#SymbolS sname)] + (#Meta [_ (#SymbolS sname)]) (#Some sname) _ @@ -1165,7 +1176,7 @@ (def''' (get-name x) (-> AST ($' Maybe Text)) (_lux_case x - [_ (#SymbolS ["" sname])] + (#Meta [_ (#SymbolS ["" sname])]) (#Some sname) _ @@ -1174,7 +1185,7 @@ (def''' (tuple->list tuple) (-> AST ($' Maybe ($' List AST))) (_lux_case tuple - [_ (#TupleS members)] + (#Meta [_ (#TupleS members)]) (#Some members) _ @@ -1213,7 +1224,7 @@ (def''' (apply-template env template) (-> RepEnv AST AST) (_lux_case template - [_ (#SymbolS ["" sname])] + (#Meta [_ (#SymbolS ["" sname])]) (_lux_case (get-rep sname env) (#Some subst) subst @@ -1221,13 +1232,13 @@ _ template) - [_ (#TupleS elems)] + (#Meta [_ (#TupleS elems)]) (tuple$ (map (apply-template env) elems)) - [_ (#FormS elems)] + (#Meta [_ (#FormS elems)]) (form$ (map (apply-template env) elems)) - [_ (#RecordS members)] + (#Meta [_ (#RecordS members)]) (record$ (map (_lux_: (-> (, AST AST) (, AST AST)) (lambda' [kv] (let' [[slot value] kv] @@ -1249,7 +1260,7 @@ (defmacro #export (do-template tokens) (_lux_case tokens - (#Cons [[_ (#TupleS bindings)] (#Cons [[_ (#TupleS templates)] data])]) + (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List AST)))) [(map% Maybe/Monad get-name bindings) (map% Maybe/Monad tuple->list data)]) @@ -1334,7 +1345,7 @@ (def''' (replace-syntax reps syntax) (-> RepEnv AST AST) (_lux_case syntax - [_ (#SymbolS ["" name])] + (#Meta [_ (#SymbolS ["" name])]) (_lux_case (get-rep name reps) (#Some replacement) replacement @@ -1342,18 +1353,18 @@ #None syntax) - [_ (#FormS parts)] - [_ (#FormS (map (replace-syntax reps) parts))] + (#Meta [_ (#FormS parts)]) + (#Meta [_ (#FormS (map (replace-syntax reps) parts))]) - [_ (#TupleS members)] - [_ (#TupleS (map (replace-syntax reps) members))] + (#Meta [_ (#TupleS members)]) + (#Meta [_ (#TupleS (map (replace-syntax reps) members))]) - [_ (#RecordS slots)] - [_ (#RecordS (map (_lux_: (-> (, AST AST) (, AST AST)) - (lambda' [slot] - (let' [[k v] slot] - [(replace-syntax reps k) (replace-syntax reps v)]))) - slots))] + (#Meta [_ (#RecordS slots)]) + (#Meta [_ (#RecordS (map (_lux_: (-> (, AST AST) (, AST AST)) + (lambda' [slot] + (let' [[k v] slot] + [(replace-syntax reps k) (replace-syntax reps v)]))) + slots))]) _ syntax) @@ -1362,13 +1373,13 @@ (defmacro #export (All tokens) (let' [[self-ident tokens'] (_lux_: (, Text ASTList) (_lux_case tokens - (#Cons [[_ (#SymbolS ["" self-ident])] tokens']) + (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) [self-ident tokens'] _ ["" tokens]))] (_lux_case tokens' - (#Cons [[_ (#TupleS args)] (#Cons [body #Nil])]) + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) (_lux_case (map% Maybe/Monad get-name args) (#Some idents) (_lux_case idents @@ -1379,9 +1390,8 @@ (let' [replacements (map (_lux_: (-> Text (, Text AST)) (lambda' [ident] [ident (`' (#;BoundT (~ (text$ ident))))])) (list& self-ident idents)) - body' (foldL (_lux_: (-> AST Text AST) - (lambda' [body' arg'] - (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')])))) + body' (foldL (lambda' [body' arg'] + (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')]))) (replace-syntax replacements body) (reverse targs))] ## (#;Some #;Nil) @@ -1503,7 +1513,7 @@ (def''' (macro-expand token) (-> AST ($' Lux ($' List AST))) (_lux_case token - [_ (#FormS (#Cons [[_ (#SymbolS macro-name)] args]))] + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) (do Lux/Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] @@ -1523,7 +1533,7 @@ (def''' (macro-expand-all syntax) (-> AST ($' Lux ($' List AST))) (_lux_case syntax - [_ (#FormS (#Cons [[_ (#SymbolS macro-name)] args]))] + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) (do Lux/Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] @@ -1539,13 +1549,13 @@ [parts' (map% Lux/Monad macro-expand-all (list& (symbol$ macro-name) args))] (wrap (list (form$ (list:join parts'))))))) - [_ (#FormS (#Cons [harg targs]))] + (#Meta [_ (#FormS (#Cons [harg targs]))]) (do Lux/Monad [harg+ (macro-expand-all harg) targs+ (map% Lux/Monad macro-expand-all targs)] (wrap (list (form$ (list:++ harg+ (list:join targs+)))))) - [_ (#TupleS members)] + (#Meta [_ (#TupleS members)]) (do Lux/Monad [members' (map% Lux/Monad macro-expand-all members)] (wrap (list (tuple$ (list:join members'))))) @@ -1556,15 +1566,14 @@ (def''' (walk-type type) (-> AST AST) (_lux_case type - [_ (#FormS (#Cons [[_ (#TagS tag)] parts]))] - (form$ (#Cons (tag$ tag) (map walk-type parts))) + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) + (form$ (#Cons [(tag$ tag) (map walk-type parts)])) - [_ (#TupleS members)] + (#Meta [_ (#TupleS members)]) (tuple$ (map walk-type members)) - [_ (#FormS (#Cons [type-fn args]))] - (foldL (_lux_: (-> AST AST AST) - (lambda' [type-fn arg] (`' (#;AppT (~ type-fn) (~ arg))))) + (#Meta [_ (#FormS (#Cons [type-fn args]))]) + (foldL (lambda' [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) (walk-type type-fn) (map walk-type args)) @@ -1619,50 +1628,40 @@ (def''' (unfold-type-def type) (-> AST ($' Lux (, AST ($' Maybe ($' List AST))))) (_lux_case type - [_ (#FormS (#Cons [_ (#SymbolS "" "|")] cases))] + (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" "|")) cases))) (do Lux/Monad [members (map% Lux/Monad (: (-> AST ($' Lux (, Text AST))) (lambda' [case] (_lux_case case - [_ (#TagS "" member-name)] + (#Meta _ (#TagS "" member-name)) (return [member-name (`' Unit)]) - [_ (#FormS (#Cons [_ (#TagS "" member-name)] (#Cons member-type #Nil)))] + (#Meta _ (#FormS (#Cons (#Meta _ (#TagS "" member-name)) (#Cons member-type #Nil)))) (return [member-name member-type]) _ (fail "Wrong syntax for variant case.")))) - cases) - variant-type (: (Lux AST) - (_lux_case (reverse members) - (#Cons last prevs) - (return (foldL (_lux_: (->' AST AST AST) - (lambda' [r l] (`' (#;SumT (~ l) (~ r))))) - (second last) - (map second prevs))) - - _ - (fail "| must have at least 2 members.")))] - (return [variant-type + cases)] + (return [(`' (#;VariantT (~ (untemplate-list (map second members))))) (#Some (|> members (map first) (map (: (-> Text AST) (lambda' [name] (tag$ ["" name]))))))])) - [_ (#FormS (#Cons [_ (#SymbolS "" "&")] pairs))] + (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" "&")) pairs))) (do Lux/Monad [members (map% Lux/Monad (: (-> (, AST AST) ($' Lux (, Text AST))) (lambda' [pair] (_lux_case pair - [[_ (#TagS "" member-name)] member-type] + [(#Meta _ (#TagS "" member-name)) member-type] (return [member-name member-type]) _ (fail "Wrong syntax for variant case.")))) (as-pairs pairs))] - (return [(`' (, (~@ (map second members)))) + (return [(`' (#TupleT (~ (untemplate-list (map second members))))) (#Some (|> members (map first) (map (: (-> Text AST) @@ -1674,24 +1673,24 @@ (defmacro #export (deftype tokens) (let' [[export? tokens'] (: (, Bool (List AST)) (_lux_case tokens - (#Cons [_ (#TagS "" "export")] tokens') + (#Cons (#Meta _ (#TagS "" "export")) tokens') [true tokens'] _ [false tokens])) [rec? tokens'] (: (, Bool (List AST)) (_lux_case tokens' - (#Cons [_ (#TagS "" "rec")] tokens') + (#Cons (#Meta _ (#TagS "" "rec")) tokens') [true tokens'] _ [false tokens'])) parts (: (Maybe (, Text (List AST) AST)) (_lux_case tokens' - (#Cons [_ (#SymbolS "" name)] (#Cons type #Nil)) + (#Cons (#Meta _ (#SymbolS "" name)) (#Cons type #Nil)) (#Some name #Nil type) - (#Cons [_ (#FormS (#Cons [_ (#SymbolS "" name)] args))] (#Cons type #Nil)) + (#Cons (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" name)) args))) (#Cons type #Nil)) (#Some name args type) _ @@ -1747,8 +1746,7 @@ (_lux_case (reverse tokens) (#Cons value actions) (let' [dummy (symbol$ ["" ""])] - (return (list (foldL (: (-> AST AST AST) - (lambda' [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post))))) + (return (list (foldL (lambda' [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) value actions)))) @@ -1758,20 +1756,20 @@ (defmacro (def' tokens) (let' [[export? tokens'] (: (, Bool (List AST)) (_lux_case tokens - (#Cons [_ (#TagS "" "export")] tokens') + (#Cons (#Meta _ (#TagS "" "export")) tokens') [true tokens'] _ [false tokens])) parts (: (Maybe (, AST (List AST) (Maybe AST) AST)) (_lux_case tokens' - (#Cons [_ (#FormS (#Cons name args))] (#Cons type (#Cons body #Nil))) + (#Cons (#Meta _ (#FormS (#Cons name args))) (#Cons type (#Cons body #Nil))) (#Some name args (#Some type) body) (#Cons name (#Cons type (#Cons body #Nil))) (#Some name #Nil (#Some type) body) - (#Cons [_ (#FormS (#Cons name args))] (#Cons body #Nil)) + (#Cons (#Meta _ (#FormS (#Cons name args))) (#Cons body #Nil)) (#Some name args #None body) (#Cons name (#Cons body #Nil)) @@ -1817,7 +1815,7 @@ (lambda' expander [branch] (let' [[pattern body] branch] (_lux_case pattern - [_ (#FormS (#Cons [_ (#SymbolS macro-name)] macro-args))] + (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS macro-name)) macro-args))) (do Lux/Monad [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) expansions (map% Lux/Monad expander (as-pairs expansion))] @@ -1876,7 +1874,7 @@ (def' (symbol? ast) (-> AST Bool) (case ast - [_ (#SymbolS _)] + (#Meta _ (#SymbolS _)) true _ @@ -1884,7 +1882,7 @@ (defmacro #export (let tokens) (case tokens - (\ (list [_ (#TupleS bindings)] body)) + (\ (list (#Meta _ (#TupleS bindings)) body)) (if (multiple? 2 (length bindings)) (|> bindings as-pairs reverse (foldL (: (-> AST (, AST AST) AST) @@ -1904,7 +1902,7 @@ (def' (ast:show ast) (-> AST Text) (case ast - [_ ast] + (#Meta _ ast) (case ast (\or (#BoolS val) (#IntS val) (#RealS val)) (->text val) @@ -1940,10 +1938,10 @@ (defmacro #export (lambda tokens) (case (: (Maybe (, Ident AST (List AST) AST)) (case tokens - (\ (list [_ (#TupleS (#Cons head tail))] body)) + (\ (list (#Meta _ (#TupleS (#Cons head tail))) body)) (#Some ["" ""] head tail body) - (\ (list [_ (#SymbolS [_ name])] [_ (#TupleS (#Cons head tail))] body)) + (\ (list (#Meta _ (#SymbolS [_ name])) (#Meta _ (#TupleS (#Cons head tail))) body)) (#Some ["" name] head tail body) _ @@ -1969,20 +1967,20 @@ (defmacro #export (def tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens - (#Cons [_ (#TagS "" "export")] tokens') + (#Cons (#Meta _ (#TagS "" "export")) tokens') [true tokens'] _ [false tokens])) parts (: (Maybe (, AST (List AST) (Maybe AST) AST)) (case tokens' - (\ (list [_ (#FormS (#Cons name args))] type body)) + (\ (list (#Meta _ (#FormS (#Cons name args))) type body)) (#Some name args (#Some type) body) (\ (list name type body)) (#Some name #Nil (#Some type) body) - (\ (list [_ (#FormS (#Cons name args))] body)) + (\ (list (#Meta _ (#FormS (#Cons name args))) body)) (#Some name args #None body) (\ (list name body)) @@ -2030,17 +2028,17 @@ (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens - (\ (list& [_ (#TagS "" "export")] tokens')) + (\ (list& (#Meta _ (#TagS "" "export")) tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, Ident (List AST) (List AST))) (case tokens' - (\ (list& [_ (#FormS (list& [_ (#SymbolS name)] args))] sigs)) + (\ (list& (#Meta _ (#FormS (list& (#Meta _ (#SymbolS name)) args))) sigs)) (#Some name args sigs) - (\ (list& [_ (#SymbolS name)] sigs)) + (\ (list& (#Meta _ (#SymbolS name)) sigs)) (#Some name #Nil sigs) _ @@ -2054,7 +2052,7 @@ (: (-> AST (Lux (, Text AST))) (lambda [token] (case token - (\ [_ (#FormS (list [_ (#SymbolS _ "_lux_:")] type [_ (#SymbolS ["" name])]))]) + (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_:")) type (#Meta _ (#SymbolS ["" name])))))) (wrap (: (, Text AST) [name type])) _ @@ -2063,7 +2061,8 @@ #let [[_module _name] name+ def-name (symbol$ name) tags (: (List AST) (map (. (: (-> Text AST) (lambda [n] (tag$ ["" n]))) first) members)) - sig-type (: AST (` (, (~@ (map second members))))) + types (map second members) + sig-type (: AST (` (#;TupleT (~ (untemplate-list types))))) sig-decl (: AST (` (_lux_declare-tags [(~@ tags)] (~ def-name)))) sig+ (: AST (case args @@ -2141,20 +2140,24 @@ (def (type:show type) (-> Type Text) (case type - #VoidT - "(|)" + (#DataT name) + ($ text:++ "(^ " name ")") - #UnitT - "(,)" - - (#SumT left right) - ($ text:++ "(| " (type:show left) " " (type:show right) ")") + (#TupleT members) + (case members + #;Nil + "(,)" - (#ProdT left right) - ($ text:++ "(, " (type:show left) " " (type:show right) ")") + _ + ($ text:++ "(, " (|> members (map type:show) (interpose " ") (foldL text:++ "")) ")")) - (#DataT name) - ($ text:++ "(^ " name ")") + (#VariantT members) + (case members + #;Nil + "(|)" + + _ + ($ text:++ "(| " (|> members (map type:show) (interpose " ") (foldL text:++ "")) ")")) (#LambdaT input output) ($ text:++ "(-> " (type:show input) " " (type:show output) ")") @@ -2181,11 +2184,11 @@ (def (beta-reduce env type) (-> (List (, Text Type)) Type Type) (case type - (#SumT left right) - (#SumT (beta-reduce env left) (beta-reduce env right)) + (#VariantT ?cases) + (#VariantT (map (beta-reduce env) ?cases)) - (#ProdT left right) - (#ProdT (beta-reduce env left) (beta-reduce env right)) + (#TupleT ?members) + (#TupleT (map (beta-reduce env) ?members)) (#AppT ?type-fn ?type-arg) (#AppT (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) @@ -2241,16 +2244,9 @@ (def (resolve-struct-type type) (-> Type (Maybe (List Type))) (case type - (#ProdT left right) - (case right - (#ProdT _) - (do Maybe/Monad - [rights (resolve-struct-type right)] - (wrap (list& left rights))) - - _ - (#Some (list left right))) - + (#TupleT slots) + (#Some slots) + (#AppT fun arg) (do Maybe/Monad [output (apply-type fun arg)] @@ -2342,7 +2338,7 @@ (: (-> AST (Lux (, AST AST))) (lambda [token] (case token - (\ [_ (#FormS (list [_ (#SymbolS _ "_lux_def")] [_ (#SymbolS tag-name)] value))]) + (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_def")) (#Meta _ (#SymbolS tag-name)) value)))) (wrap (: (, AST AST) [(tag$ tag-name) value])) _ @@ -2353,14 +2349,14 @@ (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens - (\ (list& [_ (#TagS "" "export")] tokens')) + (\ (list& (#Meta _ (#TagS "" "export")) tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, AST (List AST) AST (List AST))) (case tokens' - (\ (list& [_ (#FormS (list& name args))] type defs)) + (\ (list& (#Meta _ (#FormS (list& name args))) type defs)) (#Some name args type defs) (\ (list& name type defs)) @@ -2393,8 +2389,7 @@ [(defmacro #export (<name> tokens) (case (reverse tokens) (\ (list& last init)) - (return (list (foldL (: (-> AST AST AST) - (lambda [post pre] (` <form>))) + (return (list (foldL (lambda [post pre] (` <form>)) last init))) @@ -2422,7 +2417,7 @@ (: (-> AST (Lux Text)) (lambda [def] (case def - [_ (#SymbolS "" name)] + (#Meta _ (#SymbolS "" name)) (return name) _ @@ -2432,7 +2427,7 @@ (def (parse-alias tokens) (-> (List AST) (Lux (, (Maybe Text) (List AST)))) (case tokens - (\ (list& [_ (#TagS "" "as")] [_ (#SymbolS "" alias)] tokens')) + (\ (list& (#Meta _ (#TagS "" "as")) (#Meta _ (#SymbolS "" alias)) tokens')) (return (: (, (Maybe Text) (List AST)) [(#Some alias) tokens'])) _ @@ -2441,17 +2436,17 @@ (def (parse-referrals tokens) (-> (List AST) (Lux (, Referrals (List AST)))) (case tokens - (\ (list& [_ (#TagS "" "refer")] referral tokens')) + (\ (list& (#Meta _ (#TagS "" "refer")) referral tokens')) (case referral - [_ (#TagS "" "all")] + (#Meta _ (#TagS "" "all")) (return (: (, Referrals (List AST)) [#All tokens'])) - (\ [_ (#FormS (list& [_ (#TagS "" "only")] defs))]) + (\ (#Meta _ (#FormS (list& (#Meta _ (#TagS "" "only")) defs)))) (do Lux/Monad [defs' (extract-defs defs)] (return (: (, Referrals (List AST)) [(#Only defs') tokens']))) - (\ [_ (#FormS (list& [_ (#TagS "" "exclude")] defs))]) + (\ (#Meta _ (#FormS (list& (#Meta _ (#TagS "" "exclude")) defs)))) (do Lux/Monad [defs' (extract-defs defs)] (return (: (, Referrals (List AST)) [(#Exclude defs') tokens']))) @@ -2465,7 +2460,7 @@ (def (extract-symbol syntax) (-> AST (Lux Ident)) (case syntax - [_ (#SymbolS ident)] + (#Meta _ (#SymbolS ident)) (return ident) _ @@ -2474,7 +2469,7 @@ (def (parse-openings tokens) (-> (List AST) (Lux (, (Maybe Openings) (List AST)))) (case tokens - (\ (list& [_ (#TagS "" "open")] [_ (#FormS (list& [_ (#TextS prefix)] structs))] tokens')) + (\ (list& (#Meta _ (#TagS "" "open")) (#Meta _ (#FormS (list& (#Meta _ (#TextS prefix)) structs))) tokens')) (do Lux/Monad [structs' (map% Lux/Monad extract-symbol structs)] (return (: (, (Maybe Openings) (List AST)) [(#Some prefix structs') tokens']))) @@ -2488,10 +2483,10 @@ (: (-> AST (Lux AST)) (lambda [token] (case token - [_ (#SymbolS "" sub-name)] + (#Meta _ (#SymbolS "" sub-name)) (return (symbol$ ["" ($ text:++ super-name "/" sub-name)])) - (\ [_ (#FormS (list& [_ (#SymbolS "" sub-name)] parts))]) + (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS "" sub-name)) parts)))) (return (form$ (list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts))) _ @@ -2505,10 +2500,10 @@ (: (-> AST (Lux (List Import))) (lambda [token] (case token - [_ (#SymbolS "" m-name)] + (#Meta _ (#SymbolS "" m-name)) (wrap (list [m-name #None #All #None])) - (\ [_ (#FormS (list& [_ (#SymbolS "" m-name)] extra))]) + (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS "" m-name)) extra)))) (do Lux/Monad [alias+extra (parse-alias extra) #let [[alias extra] alias+extra] @@ -2700,10 +2695,10 @@ (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix))))))) structs)))]] (wrap ($ list:++ - (: (List AST) (list (` (_lux_import (~ (text$ m-name)))))) - (: (List AST) (case m-alias - #None (list) - (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name))))))) + (list (` (_lux_import (~ (text$ m-name))))) + (case m-alias + #None (list) + (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name)))))) (map (: (-> Text AST) (lambda [def] (` (_lux_def (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) @@ -2714,10 +2709,9 @@ _ (wrap (: (List AST) - (list:++ (map (: (-> Text AST) - (lambda [m-name] (` (_lux_import (~ (text$ m-name)))))) + (list:++ (map (lambda [m-name] (` (_lux_import (~ (text$ m-name))))) unknowns) - (: (List AST) (list (` (import (~@ tokens))))))))))) + (list (` (import (~@ tokens)))))))))) (def (try-both f x1 x2) (All [a b] @@ -2854,7 +2848,7 @@ (case tokens (\ (list struct body)) (case struct - [_ (#SymbolS name)] + (#Meta _ (#SymbolS name)) (do Lux/Monad [struct-type (find-var-type name) output (resolve-type-tags struct-type)] @@ -2880,6 +2874,12 @@ _ (fail "Wrong syntax for using"))) +(def (flip f) + (All [a b c] + (-> (-> a b c) (-> b a c))) + (lambda [y x] + (f x y))) + (defmacro #export (cond tokens) (if (i= 0 (i% (length tokens) 2)) (fail "cond requires an even number of arguments.") @@ -2910,7 +2910,7 @@ (defmacro #export (get@ tokens) (case tokens - (\ (list [_ (#TagS slot')] record)) + (\ (list (#Meta _ (#TagS slot')) record)) (do Lux/Monad [slot (normalize slot') output (resolve-tag slot) @@ -2952,11 +2952,11 @@ (defmacro #export (open tokens) (case tokens - (\ (list& [_ (#SymbolS struct-name)] tokens')) + (\ (list& (#Meta _ (#SymbolS struct-name)) tokens')) (do Lux/Monad [@module get-module-name #let [prefix (case tokens' - (\ (list [_ (#TextS prefix)])) + (\ (list (#Meta _ (#TextS prefix)))) prefix _ @@ -2999,12 +2999,12 @@ (: (-> AST AST (Lux AST)) (lambda [so-far part] (case part - [_ (#SymbolS slot)] - (return (: AST (` (get@ (~ (tag$ slot)) (~ so-far))))) + (#Meta _ (#SymbolS slot)) + (return (` (get@ (~ (tag$ slot)) (~ so-far)))) - (\ [_ (#FormS (list& [_ (#SymbolS slot)] args))]) - (return (: AST (` ((get@ (~ (tag$ slot)) (~ so-far)) - (~@ args))))) + (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS slot)) args)))) + (return (` ((get@ (~ (tag$ slot)) (~ so-far)) + (~@ args)))) _ (fail "Wrong syntax for ::")))) @@ -3016,7 +3016,7 @@ (defmacro #export (set@ tokens) (case tokens - (\ (list [_ (#TagS slot')] value record)) + (\ (list (#Meta _ (#TagS slot')) value record)) (do Lux/Monad [slot (normalize slot') output (resolve-tag slot) @@ -3051,7 +3051,7 @@ (defmacro #export (update@ tokens) (case tokens - (\ (list [_ (#TagS slot')] fun record)) + (\ (list (#Meta _ (#TagS slot')) fun record)) (do Lux/Monad [slot (normalize slot') output (resolve-tag slot) @@ -3086,9 +3086,9 @@ (defmacro #export (\template tokens) (case tokens - (\ (list [_ (#TupleS data)] - [_ (#TupleS bindings)] - [_ (#TupleS templates)])) + (\ (list (#Meta _ (#TupleS data)) + (#Meta _ (#TupleS bindings)) + (#Meta _ (#TupleS templates)))) (case (: (Maybe (List AST)) (do Maybe/Monad [bindings' (map% Maybe/Monad get-name bindings) @@ -3132,29 +3132,26 @@ (def (type->syntax type) (-> Type AST) (case type - (\template [<tag>] - [<tag> - (` <tag>)]) - [[#VoidT] [#UnitT]] - - (\template [<tag>] - [(<tag> left right) - (` (<tag> (~ (type->syntax left)) (~ (type->syntax right))))]) - [[#SumT] [#ProdT]] - (#DataT name) (` (#;DataT (~ (text$ name)))) + + (#;VariantT cases) + (` (#;VariantT (~ (untemplate-list (map type->syntax cases))))) + (#TupleT parts) + (` (#;TupleT (~ (untemplate-list (map type->syntax parts))))) + (#LambdaT in out) (` (#;LambdaT (~ (type->syntax in)) (~ (type->syntax out)))) (#BoundT name) (` (#;BoundT (~ (text$ name)))) + + (#VarT id) + (` (#;VarT (~ (int$ id)))) - (\template [<tag>] - [(<tag> id) - (` (<tag> (~ (int$ id))))]) - [[#VarT] [#ExT]] + (#ExT id) + (` (#;ExT (~ (int$ id)))) (#AllT env name arg type) (let [env' (: AST @@ -3174,7 +3171,7 @@ (defmacro #export (loop tokens) (case tokens - (\ (list [_ (#TupleS bindings)] body)) + (\ (list (#Meta _ (#TupleS bindings)) body)) (let [pairs (as-pairs bindings) vars (map first pairs) inits (map second pairs)] @@ -3204,6 +3201,4 @@ (fail "Wrong syntax for loop"))) (defmacro #export (export tokens) - (return (map (: (-> AST AST) - (lambda [token] (` (_lux_export (~ token))))) - tokens))) + (return (map (lambda [token] (` (_lux_export (~ token)))) tokens))) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux index 8a7974e8b..c87c4fdc3 100644 --- a/source/lux/control/monad.lux +++ b/source/lux/control/monad.lux @@ -53,15 +53,15 @@ ## [Syntax] (defmacro #export (do tokens state) (case tokens - ## (\ (list monad [_ (#;TupleS bindings)] body)) - (#;Cons [monad (#;Cons [[_ (#;TupleS bindings)] (#;Cons [body #;Nil])])]) + ## (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) + (#;Cons [monad (#;Cons [(#;Meta [_ (#;TupleS bindings)]) (#;Cons [body #;Nil])])]) (let [g!map (symbol$ ["" " map "]) g!join (symbol$ ["" " join "]) body' (foldL (: (-> AST (, AST AST) AST) (lambda [body' binding] (let [[var value] binding] (case var - [_ (#;TagS ["" "let"])] + (#;Meta [_ (#;TagS ["" "let"])]) (` (;let (~ value) (~ body'))) _ diff --git a/source/lux/data/id.lux b/source/lux/data/id.lux index d8bb30a3d..3ad6b056b 100644 --- a/source/lux/data/id.lux +++ b/source/lux/data/id.lux @@ -13,19 +13,20 @@ ## [Types] (deftype #export (Id a) - a) + (| (#Id a))) ## [Structures] (defstruct #export Id/Functor (Functor Id) (def (F;map f fa) - (f fa))) + (let [(#Id a) fa] + (#Id (f a))))) (defstruct #export Id/Monad (Monad Id) (def M;_functor Id/Functor) - (def M;wrap id) - (def M;join id)) + (def (M;wrap a) (#Id a)) + (def (M;join mma) (let [(#Id ma) mma] ma))) (defstruct #export Id/CoMonad (CoMonad Id) (def CM;_functor Id/Functor) - (def CM;unwrap id) - (def CM;split id)) + (def (CM;unwrap wa) (let [(#Id a) wa] a)) + (def (CM;split wa) (#Id wa))) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 97333f570..5a8357251 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -23,13 +23,13 @@ ## (#Cons (, a (List a))))) (deftype #export (PList k v) - (, (E;Eq k) (List (, k v)))) + (| (#PList (, (E;Eq k) (List (, k v)))))) ## [Constructors] (def #export (plist eq) (All [k v] (-> (E;Eq k) (PList k v))) - [eq #;Nil]) + (#PList [eq #;Nil])) ## [Functions] (def #export (foldL f init xs) @@ -252,7 +252,8 @@ ## true ## [(#;Cons [x xs']) (#;Cons [y ys'])] -## (and (:: eq (E;= x y)) (= xs' ys')) +## (and (:: eq (E;= x y)) +## (E;= xs' ys')) ## ))) (defstruct #export List/Monoid (All [a] @@ -280,7 +281,7 @@ (foldL ++ unit mma)))) (defstruct #export PList/Dict (Dict PList) - (def (D;get k [eq kvs]) + (def (D;get k (#PList [eq kvs])) (loop [kvs kvs] (case kvs #;Nil @@ -291,27 +292,27 @@ (#;Some v') (recur kvs'))))) - (def (D;put k v [eq kvs]) - [eq (loop [kvs kvs] - (case kvs - #;Nil - (#;Cons [k v] kvs) - - (#;Cons [k' v'] kvs') - (if (:: eq (E;= k k')) - (#;Cons [k v] kvs') - (#;Cons [k' v'] (recur kvs')))))]) - - (def (D;remove k [eq kvs]) - [eq (loop [kvs kvs] - (case kvs - #;Nil - kvs - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - kvs' - (#;Cons [[k' v'] (recur kvs')]))))])) + (def (D;put k v (#PList [eq kvs])) + (#PList [eq (loop [kvs kvs] + (case kvs + #;Nil + (#;Cons [k v] kvs) + + (#;Cons [k' v'] kvs') + (if (:: eq (E;= k k')) + (#;Cons [k v] kvs') + (#;Cons [k' v'] (recur kvs')))))])) + + (def (D;remove k (#PList [eq kvs])) + (#PList [eq (loop [kvs kvs] + (case kvs + #;Nil + kvs + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + kvs' + (#;Cons [[k' v'] (recur kvs')]))))]))) (defstruct #export List/Stack (S;Stack List) (def S;empty (list)) diff --git a/source/lux/meta/ast.lux b/source/lux/meta/ast.lux index 3d2f30db2..f01f08af1 100644 --- a/source/lux/meta/ast.lux +++ b/source/lux/meta/ast.lux @@ -31,7 +31,7 @@ (do-template [<name> <type> <tag>] [(def #export (<name> x) (-> <type> AST) - [_cursor (<tag> x)])] + (#;Meta _cursor (<tag> x)))] [bool$ Bool #;BoolS] [int$ Int #;IntS] diff --git a/source/lux/meta/macro.lux b/source/lux/meta/macro.lux index e6963b3d6..15f3582fa 100644 --- a/source/lux/meta/macro.lux +++ b/source/lux/meta/macro.lux @@ -12,18 +12,18 @@ (def #export (defmacro tokens state) Macro (case tokens - (#;Cons [[_ (#;FormS (#;Cons [name args]))] (#;Cons [body #;Nil])]) - (#;Right [state (#;Cons [(` ((~ [["" -1 -1] (#;SymbolS ["lux" "def"])]) ((~ name) (~@ args)) - (~ [["" -1 -1] (#;SymbolS ["lux" "Macro"])]) + (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])]) + (#;Right [state (#;Cons [(` ((~ (#;Meta ["" -1 -1] (#;SymbolS ["lux" "def"]))) ((~ name) (~@ args)) + (~ (#;Meta ["" -1 -1] (#;SymbolS ["lux" "Macro"]))) (~ body))) - (#;Cons [(` ((~ [["" -1 -1] (#;SymbolS ["" "_lux_declare-macro"])]) (~ name))) + (#;Cons [(` ((~ (#;Meta ["" -1 -1] (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) #;Nil])])]) - (#;Cons [[_ (#;TagS ["" "export"])] (#;Cons [[_ (#;FormS (#;Cons [name args]))] (#;Cons [body #;Nil])])]) - (#;Right [state (#;Cons [(` ((~ [["" -1 -1] (#;SymbolS ["lux" "def"])]) (~ [["" -1 -1] (#;TagS ["" "export"])]) ((~ name) (~@ args)) - (~ [["" -1 -1] (#;SymbolS ["lux" "Macro"])]) + (#;Cons [(#;Meta [_ (#;TagS ["" "export"])]) (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])]) + (#;Right [state (#;Cons [(` ((~ (#;Meta ["" -1 -1] (#;SymbolS ["lux" "def"]))) (~ (#;Meta ["" -1 -1] (#;TagS ["" "export"]))) ((~ name) (~@ args)) + (~ (#;Meta ["" -1 -1] (#;SymbolS ["lux" "Macro"]))) (~ body))) - (#;Cons [(` ((~ [["" -1 -1] (#;SymbolS ["" "_lux_declare-macro"])]) (~ name))) + (#;Cons [(` ((~ (#;Meta ["" -1 -1] (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) #;Nil])])]) _ diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index db6a5774a..b9834f972 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -73,7 +73,7 @@ [(def #export (<name> tokens) (Parser <type>) (case tokens - (#;Cons [[_ (<tag> x)] tokens']) + (#;Cons [(#;Meta [_ (<tag> x)]) tokens']) (#;Some [tokens' x]) _ @@ -92,7 +92,7 @@ [(def #export (<name> tokens) (Parser Text) (case tokens - (#;Cons [[_ (<tag> ["" x])] tokens']) + (#;Cons [(#;Meta [_ (<tag> ["" x])]) tokens']) (#;Some [tokens' x]) _ @@ -113,7 +113,7 @@ [(def #export (<name> v tokens) (-> <type> (Parser (,))) (case tokens - (#;Cons [[_ (<tag> x)] tokens']) + (#;Cons [(#;Meta [_ (<tag> x)]) tokens']) (if (<eq> v x) (#;Some [tokens' []]) #;None) @@ -135,7 +135,7 @@ (All [a] (-> (Parser a) (Parser a))) (case tokens - (#;Cons [[_ (<tag> form)] tokens']) + (#;Cons [(#;Meta [_ (<tag> form)]) tokens']) (case (p form) (#;Some [#;Nil x]) (#;Some [tokens' x]) _ #;None) @@ -215,24 +215,24 @@ (defmacro #export (defsyntax tokens) (let [[exported? tokens] (: (, Bool (List AST)) (case tokens - (\ (list& [_ (#;TagS ["" "export"])] tokens')) + (\ (list& (#;Meta [_ (#;TagS ["" "export"])]) tokens')) [true tokens'] _ [false tokens]))] (case tokens - (\ (list [_ (#;FormS (list& [_ (#;SymbolS ["" name])] args))] + (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))]) body)) (do Lux/Monad [names+parsers (M;map% Lux/Monad (: (-> AST (Lux (, AST AST))) (lambda [arg] (case arg - (\ [_ (#;TupleS (list [_ (#;SymbolS var-name)] - parser))]) + (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)]) + parser))])) (wrap [(symbol$ var-name) parser]) - (\ [_ (#;SymbolS var-name)]) + (\ (#;Meta [_ (#;SymbolS var-name)])) (wrap [(symbol$ var-name) (` id^)]) _ diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 41a59fc00..8c88328f5 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -10,7 +10,7 @@ (:require (clojure [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail return* fail* |case $$]] + (lux [base :as & :refer [|let |do return fail return* fail* |case]] [reader :as &reader] [parser :as &parser] [type :as &type] @@ -23,24 +23,24 @@ ;; [Utils] (defn ^:private parse-handler [[catch+ finally+] token] (|case token - [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_catch")] - (&/$Cons [_ (&/$TextS ?ex-class)] - (&/$Cons [_ (&/$SymbolS "" ?ex-arg)] - (&/$Cons ?catch-body - (&/$Nil))))))] - (return (&/P (&/|++ catch+ (&/|list ($$ &/P ?ex-class ?ex-arg ?catch-body))) finally+)) - - [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_finally")] - (&/$Cons ?finally-body - (&/$Nil))))] - (return (&/P catch+ (&/Some$ ?finally-body))) + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_catch")) + (&/$Cons (&/$Meta _ (&/$TextS ?ex-class)) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?ex-arg)) + (&/$Cons ?catch-body + (&/$Nil))))))) + (return (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+)) + + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_finally")) + (&/$Cons ?finally-body + (&/$Nil))))) + (return (&/T catch+ (&/V &/$Some ?finally-body))) _ (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token))))) (defn ^:private parse-tag [ast] (|case ast - [_ (&/$TagS "" name)] + (&/$Meta _ (&/$TagS "" name)) (return name) _ @@ -49,44 +49,44 @@ (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new-array")] - (&/$Cons [_ (&/$SymbolS _ ?class)] - (&/$Cons [_ (&/$IntS ?length)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_new-array")) + (&/$Cons (&/$Meta _ (&/$SymbolS _ ?class)) + (&/$Cons (&/$Meta _ (&/$IntS ?length)) (&/$Nil))))) (&&host/analyse-jvm-new-array analyse ?class ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aastore")) (&/$Cons ?array - (&/$Cons [_ (&/$IntS ?idx)] + (&/$Cons (&/$Meta _ (&/$IntS ?idx)) (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aaload")) (&/$Cons ?array - (&/$Cons [_ (&/$IntS ?idx)] + (&/$Cons (&/$Meta _ (&/$IntS ?idx)) (&/$Nil))))) (&&host/analyse-jvm-aaload analyse ?array ?idx) ;; Classes & interfaces - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_class")] - (&/$Cons [_ (&/$TextS ?name)] - (&/$Cons [_ (&/$TextS ?super-class)] - (&/$Cons [_ (&/$TupleS ?interfaces)] - (&/$Cons [_ (&/$TupleS ?fields)] - (&/$Cons [_ (&/$TupleS ?methods)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_class")) + (&/$Cons (&/$Meta _ (&/$TextS ?name)) + (&/$Cons (&/$Meta _ (&/$TextS ?super-class)) + (&/$Cons (&/$Meta _ (&/$TupleS ?interfaces)) + (&/$Cons (&/$Meta _ (&/$TupleS ?fields)) + (&/$Cons (&/$Meta _ (&/$TupleS ?methods)) (&/$Nil)))))))) (&&host/analyse-jvm-class analyse compile-token ?name ?super-class ?interfaces ?fields ?methods) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_interface")] - (&/$Cons [_ (&/$TextS ?name)] - (&/$Cons [_ (&/$TupleS ?supers)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_interface")) + (&/$Cons (&/$Meta _ (&/$TextS ?name)) + (&/$Cons (&/$Meta _ (&/$TupleS ?supers)) ?methods)))) (&&host/analyse-jvm-interface analyse compile-token ?name ?supers ?methods) ;; Programs - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_program")] - (&/$Cons [_ (&/$SymbolS "" ?args)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_program")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?args)) (&/$Cons ?body (&/$Nil))))) (&&host/analyse-jvm-program analyse compile-token ?args ?body) @@ -97,86 +97,86 @@ (defn ^:private aba6 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Primitive conversions - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2f")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2f")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2f analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2i")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2i")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2i analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2l")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2l")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2l analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2d")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2d")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2d analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2i")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2i")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2i analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2l")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2l")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2l analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2b")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2b")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2b analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2c")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2c")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2c analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2d")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2d")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2d analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2f")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2f")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2f analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2l")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2l")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2l analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2s")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2s")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2s analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2d")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2d")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2d analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2f")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2f")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2f analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2i")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2i")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2i analyse exo-type ?value) ;; Bitwise operators - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iand")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iand")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iand analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ior")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ior")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ior analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ixor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ixor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ixor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ishl analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ishr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iushr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_land")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_land")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-land analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lxor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lxor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lxor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lshl analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lshr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) _ @@ -185,106 +185,106 @@ (defn ^:private aba5 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Objects - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_null?")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_null?")) (&/$Cons ?object (&/$Nil)))) (&&host/analyse-jvm-null? analyse exo-type ?object) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_instanceof")] - (&/$Cons [_ (&/$TextS ?class)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_instanceof")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) (&/$Cons ?object (&/$Nil))))) (&&host/analyse-jvm-instanceof analyse exo-type ?class ?object) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TupleS ?classes)] - (&/$Cons [_ (&/$TupleS ?args)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_new")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) (&/$Nil)))))) (&&host/analyse-jvm-new analyse exo-type ?class ?classes ?args) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getstatic")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?field)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getstatic")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) (&/$Nil))))) (&&host/analyse-jvm-getstatic analyse exo-type ?class ?field) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getfield")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?field)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getfield")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) (&/$Cons ?object (&/$Nil)))))) (&&host/analyse-jvm-getfield analyse exo-type ?class ?field ?object) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putstatic")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?field)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putstatic")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) (&/$Cons ?value (&/$Nil)))))) (&&host/analyse-jvm-putstatic analyse exo-type ?class ?field ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putfield")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?field)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putfield")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) (&/$Cons ?object (&/$Cons ?value (&/$Nil))))))) (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?object ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokestatic")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?classes)] - (&/$Cons [_ (&/$TupleS ?args)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokestatic")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) (&/$Nil))))))) (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method ?classes ?args) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokevirtual")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?classes)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokevirtual")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) (&/$Cons ?object - (&/$Cons [_ (&/$TupleS ?args)] + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) (&/$Nil)))))))) (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method ?classes ?object ?args) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokeinterface")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?classes)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokeinterface")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) (&/$Cons ?object - (&/$Cons [_ (&/$TupleS ?args)] + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) (&/$Nil)))))))) (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method ?classes ?object ?args) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokespecial")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?classes)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokespecial")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) (&/$Cons ?object - (&/$Cons [_ (&/$TupleS ?args)] + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) (&/$Nil)))))))) (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method ?classes ?object ?args) ;; Exceptions - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_try")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_try")) (&/$Cons ?body ?handlers))) - (|do [catches+finally (&/fold% parse-handler (&/P (&/|list) &/None$) ?handlers)] + (|do [catches+finally (&/fold% parse-handler (&/T (&/|list) (&/V &/$None nil)) ?handlers)] (&&host/analyse-jvm-try analyse exo-type ?body catches+finally)) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_throw")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_throw")) (&/$Cons ?ex (&/$Nil)))) (&&host/analyse-jvm-throw analyse exo-type ?ex) ;; Syncronization/monitos - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_monitorenter")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorenter")) (&/$Cons ?monitor (&/$Nil)))) (&&host/analyse-jvm-monitorenter analyse exo-type ?monitor) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_monitorexit")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorexit")) (&/$Cons ?monitor (&/$Nil)))) (&&host/analyse-jvm-monitorexit analyse exo-type ?monitor) @@ -295,53 +295,53 @@ (defn ^:private aba4 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Float arithmetic - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fdiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fdiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fdiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_frem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_frem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-frem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_feq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_feq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-feq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_flt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_flt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-flt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fgt analyse exo-type ?x ?y) ;; Double arithmetic - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ddiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ddiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ddiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_drem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_drem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-drem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_deq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_deq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-deq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dlt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dlt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dlt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dgt analyse exo-type ?x ?y) _ @@ -351,63 +351,63 @@ (|case token ;; Host special forms ;; Characters - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ceq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ceq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ceq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_clt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_clt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-clt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_cgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-cgt analyse exo-type ?x ?y) ;; Integer arithmetic - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_isub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_isub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-isub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_imul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_imul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-imul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_idiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_idiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-idiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_irem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_irem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-irem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ieq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ieq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ieq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ilt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ilt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ilt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_igt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_igt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-igt analyse exo-type ?x ?y) ;; Long arithmetic - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ladd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ladd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ladd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ldiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ldiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ldiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lrem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lrem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lrem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_leq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_leq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-leq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_llt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_llt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-llt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lgt analyse exo-type ?x ?y) _ @@ -418,60 +418,60 @@ (&/$SymbolS ?ident) (&&lux/analyse-symbol analyse exo-type ?ident) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_case")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_case")) (&/$Cons ?value ?branches))) (&&lux/analyse-case analyse exo-type ?value ?branches) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_lambda")] - (&/$Cons [_ (&/$SymbolS "" ?self)] - (&/$Cons [_ (&/$SymbolS "" ?arg)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_lambda")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?self)) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?arg)) (&/$Cons ?body (&/$Nil)))))) (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_def")] - (&/$Cons [_ (&/$SymbolS "" ?name)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_def")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name)) (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-def analyse compile-token ?name ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-macro")] - (&/$Cons [_ (&/$SymbolS "" ?name)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-macro")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name)) (&/$Nil)))) (&&lux/analyse-declare-macro analyse compile-token ?name) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-tags")] - (&/$Cons [_ (&/$TupleS tags)] - (&/$Cons [_ (&/$SymbolS "" type-name)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-tags")) + (&/$Cons (&/$Meta _ (&/$TupleS tags)) + (&/$Cons (&/$Meta _ (&/$SymbolS "" type-name)) (&/$Nil))))) (|do [tags* (&/map% parse-tag tags)] (&&lux/analyse-declare-tags tags* type-name)) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_import")] - (&/$Cons [_ (&/$TextS ?path)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_import")) + (&/$Cons (&/$Meta _ (&/$TextS ?path)) (&/$Nil)))) (&&lux/analyse-import analyse compile-module compile-token ?path) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:")) (&/$Cons ?type (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-check analyse eval! exo-type ?type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:!")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:!")) (&/$Cons ?type (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-coerce analyse eval! exo-type ?type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_export")] - (&/$Cons [_ (&/$SymbolS "" ?ident)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_export")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?ident)) (&/$Nil)))) (&&lux/analyse-export analyse compile-token ?ident) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_alias")] - (&/$Cons [_ (&/$TextS ?alias)] - (&/$Cons [_ (&/$TextS ?module)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_alias")) + (&/$Cons (&/$Meta _ (&/$TextS ?alias)) + (&/$Cons (&/$Meta _ (&/$TextS ?module)) (&/$Nil))))) (&&lux/analyse-alias analyse compile-token ?alias ?module) @@ -483,23 +483,23 @@ ;; Standard special forms (&/$BoolS ?value) (|do [_ (&type/check exo-type &type/Bool)] - (return (&/|list (&/P (&/S &&/$bool ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$bool ?value) exo-type)))) (&/$IntS ?value) (|do [_ (&type/check exo-type &type/Int)] - (return (&/|list (&/P (&/S &&/$int ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$int ?value) exo-type)))) (&/$RealS ?value) (|do [_ (&type/check exo-type &type/Real)] - (return (&/|list (&/P (&/S &&/$real ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$real ?value) exo-type)))) (&/$CharS ?value) (|do [_ (&type/check exo-type &type/Char)] - (return (&/|list (&/P (&/S &&/$char ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$char ?value) exo-type)))) (&/$TextS ?value) (|do [_ (&type/check exo-type &type/Text)] - (return (&/|list (&/P (&/S &&/$text ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$text ?value) exo-type)))) (&/$TupleS ?elems) (&&lux/analyse-tuple analyse exo-type ?elems) @@ -528,21 +528,20 @@ (defn ^:private analyse-basic-ast [analyse eval! compile-module compile-token exo-type token] ;; (prn 'analyse-basic-ast (&/show-ast token)) (|case token - [meta ?token] + (&/$Meta meta ?token) (fn [state] - (|case ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) - ;; (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) - ;; (catch Error e - ;; (prn e) - ;; (assert false (prn-str 'analyse-basic-ast (&/show-ast token))))) + (|case (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) + (catch Error e + (prn e) + (assert false (prn-str 'analyse-basic-ast (&/show-ast token))))) (&/$Right state* output) (return* state* output) (&/$Left "") - (fail* (add-loc (&/$get-cursor state) (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) + (fail* (add-loc (&/get$ &/$cursor state) (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) (&/$Left msg) - (fail* (add-loc (&/$get-cursor state) msg)) + (fail* (add-loc (&/get$ &/$cursor state) msg)) )) )) @@ -554,44 +553,42 @@ [(&/$VarT ?e-id) (&/$VarT ?a-id)] (if (= ?e-id ?a-id) (|do [?output-type* (&type/deref ?e-id)] - (return (&/P ?output-term ?output-type*))) - (return (&/P ?output-term ?output-type))) + (return (&/T ?output-term ?output-type*))) + (return (&/T ?output-term ?output-type))) [_ _] - (return (&/P ?output-term ?output-type))) + (return (&/T ?output-term ?output-type))) )))) (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] - ;; (prn 'analyse-ast (&/adt->text token)) ;; (prn 'analyse-ast (&/show-ast token)) - (|let [[cursor _] token] - (&/with-cursor cursor - (&/with-expected-type exo-type - (|case token - [meta (&/$FormS (&/$Cons [_ (&/$IntS idx)] ?values))] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) - - [meta (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))] - (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] - [module tag-name] (&/normalize ?ident) - ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/P module tag-name)))] - idx (&&module/tag-index module tag-name) - ;; :let [_ (println 'analyse-ast/_2 idx)] - ] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) - - [meta (&/$FormS (&/$Cons ?fn ?args))] - (fn [state] - (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) - (&/$Right state* =fn) - (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) - ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) - - _ - ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) - - _ - (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token)))))) + (&/with-cursor (aget token 1 0) + (&/with-expected-type exo-type + (|case token + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$IntS idx)) ?values))) + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) + + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values))) + (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] + [module tag-name] (&/normalize ?ident) + ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/T module tag-name)))] + idx (&&module/tag-index module tag-name) + ;; :let [_ (println 'analyse-ast/_2 idx)] + ] + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) + + (&/$Meta meta (&/$FormS (&/$Cons ?fn ?args))) + (fn [state] + (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) + (&/$Right state* =fn) + (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) + + _ + ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) + + _ + (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token))))) ;; [Resources] (defn analyse [eval! compile-module compile-token] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 622f0b853..fe1e0d55b 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -13,120 +13,120 @@ [type :as &type]))) ;; [Tags] -(deftags - ["bool" - "int" - "real" - "char" - "text" - "unit" - "sum" - "prod" - "apply" - "case" - "lambda" - "ann" - "def" - "declare-macro" - "var" - "captured" - - "jvm-getstatic" - "jvm-getfield" - "jvm-putstatic" - "jvm-putfield" - "jvm-invokestatic" - "jvm-instanceof" - "jvm-invokevirtual" - "jvm-invokeinterface" - "jvm-invokespecial" - "jvm-null?" - "jvm-null" - "jvm-new" - "jvm-new-array" - "jvm-aastore" - "jvm-aaload" - "jvm-class" - "jvm-interface" - "jvm-try" - "jvm-throw" - "jvm-monitorenter" - "jvm-monitorexit" - "jvm-program" - - "jvm-iadd" - "jvm-isub" - "jvm-imul" - "jvm-idiv" - "jvm-irem" - "jvm-ieq" - "jvm-ilt" - "jvm-igt" - - "jvm-ceq" - "jvm-clt" - "jvm-cgt" - - "jvm-ladd" - "jvm-lsub" - "jvm-lmul" - "jvm-ldiv" - "jvm-lrem" - "jvm-leq" - "jvm-llt" - "jvm-lgt" - - "jvm-fadd" - "jvm-fsub" - "jvm-fmul" - "jvm-fdiv" - "jvm-frem" - "jvm-feq" - "jvm-flt" - "jvm-fgt" - - "jvm-dadd" - "jvm-dsub" - "jvm-dmul" - "jvm-ddiv" - "jvm-drem" - "jvm-deq" - "jvm-dlt" - "jvm-dgt" - - "jvm-d2f" - "jvm-d2i" - "jvm-d2l" - - "jvm-f2d" - "jvm-f2i" - "jvm-f2l" - - "jvm-i2b" - "jvm-i2c" - "jvm-i2d" - "jvm-i2f" - "jvm-i2l" - "jvm-i2s" - - "jvm-l2d" - "jvm-l2f" - "jvm-l2i" - - "jvm-iand" - "jvm-ior" - "jvm-ixor" - "jvm-ishl" - "jvm-ishr" - "jvm-iushr" - - "jvm-land" - "jvm-lor" - "jvm-lxor" - "jvm-lshl" - "jvm-lshr" - "jvm-lushr" - ]) +(deftags "" + "bool" + "int" + "real" + "char" + "text" + "variant" + "tuple" + "apply" + "case" + "lambda" + "ann" + "def" + "declare-macro" + "var" + "captured" + + "jvm-getstatic" + "jvm-getfield" + "jvm-putstatic" + "jvm-putfield" + "jvm-invokestatic" + "jvm-instanceof" + "jvm-invokevirtual" + "jvm-invokeinterface" + "jvm-invokespecial" + "jvm-null?" + "jvm-null" + "jvm-new" + "jvm-new-array" + "jvm-aastore" + "jvm-aaload" + "jvm-class" + "jvm-interface" + "jvm-try" + "jvm-throw" + "jvm-monitorenter" + "jvm-monitorexit" + "jvm-program" + + "jvm-iadd" + "jvm-isub" + "jvm-imul" + "jvm-idiv" + "jvm-irem" + "jvm-ieq" + "jvm-ilt" + "jvm-igt" + + "jvm-ceq" + "jvm-clt" + "jvm-cgt" + + "jvm-ladd" + "jvm-lsub" + "jvm-lmul" + "jvm-ldiv" + "jvm-lrem" + "jvm-leq" + "jvm-llt" + "jvm-lgt" + + "jvm-fadd" + "jvm-fsub" + "jvm-fmul" + "jvm-fdiv" + "jvm-frem" + "jvm-feq" + "jvm-flt" + "jvm-fgt" + + "jvm-dadd" + "jvm-dsub" + "jvm-dmul" + "jvm-ddiv" + "jvm-drem" + "jvm-deq" + "jvm-dlt" + "jvm-dgt" + + "jvm-d2f" + "jvm-d2i" + "jvm-d2l" + + "jvm-f2d" + "jvm-f2i" + "jvm-f2l" + + "jvm-i2b" + "jvm-i2c" + "jvm-i2d" + "jvm-i2f" + "jvm-i2l" + "jvm-i2s" + + "jvm-l2d" + "jvm-l2f" + "jvm-l2i" + + "jvm-iand" + "jvm-ior" + "jvm-ixor" + "jvm-ishl" + "jvm-ishr" + "jvm-iushr" + + "jvm-land" + "jvm-lor" + "jvm-lxor" + "jvm-lshl" + "jvm-lshr" + "jvm-lushr" + + ) ;; [Exports] (defn expr-type [syntax+] @@ -147,4 +147,4 @@ (|do [module* (if (.equals "" ?module) &/get-module-name (return ?module))] - (return (&/P module* ?name))))) + (return (&/T module* ?name))))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 6bb767d3e..483002adc 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -9,7 +9,7 @@ (ns lux.analyser.case (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [deftags |do return fail |let |case $$]] + (lux [base :as & :refer [deftags |do return fail |let |case]] [parser :as &parser] [type :as &type]) (lux.analyser [base :as &&] @@ -18,33 +18,31 @@ [record :as &&record]))) ;; [Tags] -(deftags - ["DefaultTotal" - "BoolTotal" - "IntTotal" - "RealTotal" - "CharTotal" - "TextTotal" - "UnitTotal" - "ProdTotal" - "SumTotal"] +(deftags "" + "DefaultTotal" + "BoolTotal" + "IntTotal" + "RealTotal" + "CharTotal" + "TextTotal" + "TupleTotal" + "VariantTotal" ) -(deftags - ["StoreTestAC" - "BoolTestAC" - "IntTestAC" - "RealTestAC" - "CharTestAC" - "TextTestAC" - "UnitTestAC" - "ProdTestAC" - "SumTestAC"] +(deftags "" + "StoreTestAC" + "BoolTestAC" + "IntTestAC" + "RealTestAC" + "CharTestAC" + "TextTestAC" + "TupleTestAC" + "VariantTestAC" ) ;; [Utils] (def ^:private unit - (&/P (&/cursor$ "" -1 -1) (&/S &/$TupleS (&/|list)))) + (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS (&/|list))))) (defn ^:private resolve-type [type] (|case type @@ -66,229 +64,269 @@ _ (&type/actual-type type))) -(let [cleaner (fn [_abody ena] - (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] - (|do [_ (&type/set-var _avar (&/S &/$BoundT _aarg))] - (&type/clean* _avar _abody))))] - (defn adjust-type* [up type] - "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" - ;; (prn 'adjust-type* (&type/show-type type)) - (|case type - (&/$AllT _aenv _aname _aarg _abody) - (&type/with-var - (fn [$var] - (|do [=type (&type/apply-type type $var)] - (adjust-type* (&/Cons$ ($$ &/P _aenv _aname _aarg $var) up) =type)))) - - (&/$SumT ?left ?right) - (|do [=left (&/fold% cleaner ?left up) - =right (&/fold% cleaner ?right up)] - (return (&type/Sum$ =left =right))) - - (&/$ProdT ?left ?right) - (|do [=left (&/fold% cleaner ?left up) - =right (&/fold% cleaner ?right up)] - (return (&type/Prod$ =left =right))) - - (&/$AppT ?tfun ?targ) - (|do [=type (&type/apply-type ?tfun ?targ)] - (adjust-type* up =type)) - - (&/$VarT ?id) - (|do [type* (&/try-all% (&/|list (&type/deref ?id) - (fail "##9##")))] - (adjust-type* up type*)) - - (&/$NamedT ?name ?type) - (adjust-type* up ?type) - - _ - (assert false (prn 'adjust-type* (&type/show-type type))) - ))) +(defn adjust-type* [up type] + "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" + ;; (prn 'adjust-type* (&type/show-type type)) + (|case type + (&/$AllT _aenv _aname _aarg _abody) + (&type/with-var + (fn [$var] + (|do [=type (&type/apply-type type $var)] + (adjust-type* (&/|cons (&/T _aenv _aname _aarg $var) up) =type)))) + + (&/$TupleT ?members) + (|do [(&/$TupleT ?members*) (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&type/Tuple$ (&/|map (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + v + up)) + ?members*)))) + + (&/$VariantT ?members) + (|do [(&/$VariantT ?members*) (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&/V &/$VariantT (&/|map (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + v + up)) + ?members*)))) + + (&/$AppT ?tfun ?targ) + (|do [=type (&type/apply-type ?tfun ?targ)] + (adjust-type* up =type)) + + (&/$VarT ?id) + (|do [type* (&/try-all% (&/|list (&type/deref ?id) + (fail "##9##")))] + (adjust-type* up type*)) + + (&/$NamedT ?name ?type) + (adjust-type* up ?type) + + _ + (assert false (prn 'adjust-type* (&type/show-type type))) + )) (defn adjust-type [type] "(-> Type (Lux Type))" (adjust-type* (&/|list) type)) -(defn ^:private resolve-tag [tag type] - (|do [[=module =name] (&&/resolved-ident tag) - type* (adjust-type type) - idx (&module/tag-index =module =name) - group (&module/tag-group =module =name) - ;; :let [_ (prn 'resolve-tag =module =name (&/adt->text group))] - case-type (&type/variant-case idx type*)] - (return ($$ &/P idx (&/|length group) case-type)))) - (defn ^:private analyse-pattern [value-type pattern kont] - (|let [[meta pattern*] pattern - ;; _ (prn 'analyse-pattern (&/show-ast pattern) (&type/show-type value-type)) - ] + (|let [(&/$Meta _ pattern*) pattern] (|case pattern* (&/$SymbolS "" name) (|do [=kont (&env/with-local name value-type kont) idx &env/next-local-idx] - (return (&/P (&/S $StoreTestAC idx) =kont))) + (return (&/T (&/V $StoreTestAC idx) =kont))) + + (&/$SymbolS ident) + (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) (&/$BoolS ?value) (|do [_ (&type/check value-type &type/Bool) =kont kont] - (return (&/P (&/S $BoolTestAC ?value) =kont))) + (return (&/T (&/V $BoolTestAC ?value) =kont))) (&/$IntS ?value) (|do [_ (&type/check value-type &type/Int) =kont kont] - (return (&/P (&/S $IntTestAC ?value) =kont))) + (return (&/T (&/V $IntTestAC ?value) =kont))) (&/$RealS ?value) (|do [_ (&type/check value-type &type/Real) =kont kont] - (return (&/P (&/S $RealTestAC ?value) =kont))) + (return (&/T (&/V $RealTestAC ?value) =kont))) (&/$CharS ?value) (|do [_ (&type/check value-type &type/Char) =kont kont] - (return (&/P (&/S $CharTestAC ?value) =kont))) + (return (&/T (&/V $CharTestAC ?value) =kont))) (&/$TextS ?value) (|do [_ (&type/check value-type &type/Text) =kont kont] - (return (&/P (&/S $TextTestAC ?value) =kont))) + (return (&/T (&/V $TextTestAC ?value) =kont))) - (&/$TupleS (&/$Nil)) - (|do [_ (&type/check value-type &type/Unit) - =kont kont] - (return (&/P (&/S $UnitTestAC nil) =kont))) - - (&/$TupleS (&/$Cons ?_left ?tail)) + (&/$TupleS ?members) (|do [value-type* (adjust-type value-type)] + (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*)) + (|case value-type* + (&/$TupleT ?member-types) + (do ;; (prn 'PM/TUPLE-2 (&/|length ?member-types) (&/|length ?members)) + (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) + (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) + (|do [[=tests =kont] (&/fold (fn [kont* vm] + (|let [[v m] vm] + (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] + (return (&/T (&/|cons =test =tests) =kont))))) + (|do [=kont kont] + (return (&/T (&/|list) =kont))) + (&/|reverse (&/zip2 ?member-types ?members)))] + (return (&/T (&/V $TupleTestAC =tests) =kont))))) + + _ + (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) + + (&/$RecordS pairs) + (|do [?members (&&record/order-record pairs) + ;; :let [_ (prn 'PRE (&type/show-type value-type))] + value-type* (adjust-type value-type) + ;; :let [_ (prn 'POST (&type/show-type value-type*))] + ;; value-type* (resolve-type value-type) + ] (|case value-type* - (&/$ProdT ?left ?right) - (|do [[=left [=right =kont]] (analyse-pattern ?left ?_left - (|do [[=right =kont] (|case ?tail - (&/$Cons ?_right (&/$Nil)) - (analyse-pattern ?right ?_right kont) - - (&/$Nil) - (fail "[Pattern-matching Error] Pattern-matching mismatch. Tuple has wrong size.") - - _ - (analyse-pattern ?right (&/P meta (&/S &/$TupleS ?tail)) kont))] - (return (&/P =right =kont))))] - (return (&/P (&/S $ProdTestAC (&/P =left =right)) =kont))) + (&/$TupleT ?member-types) + (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) + (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require record[" (&/|length ?member-types) "]. Given record[" (&/|length ?members) "]")) + (|do [[=tests =kont] (&/fold (fn [kont* vm] + (|let [[v m] vm] + (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] + (return (&/T (&/|cons =test =tests) =kont))))) + (|do [=kont kont] + (return (&/T (&/|list) =kont))) + (&/|reverse (&/zip2 ?member-types ?members)))] + (return (&/T (&/V $TupleTestAC =tests) =kont)))) _ - (fail (str "[Pattern-matching Error] Tuples require product-types: " (&type/show-type value-type*))))) - - (&/$RecordS pairs) - (|do [?members (&&record/order-record pairs)] - (analyse-pattern value-type (&/P meta (&/S &/$TupleS ?members)) kont)) + (fail "[Pattern-matching Error] Record requires record-type."))) (&/$TagS ?ident) - (|do [[idx group-count case-type] (resolve-tag ?ident value-type) - [=test =kont] (analyse-pattern case-type unit kont)] - (return (&/P (&/S $SumTestAC ($$ &/P idx group-count =test)) =kont))) - - (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values)) - (|do [[idx group-count case-type] (resolve-tag ?ident value-type) + (|do [;; :let [_ (println "#00" (&/ident->text ?ident))] + [=module =name] (&&/resolved-ident ?ident) + ;; :let [_ (println "#01")] + value-type* (adjust-type value-type) + ;; :let [_ (println "#02")] + idx (&module/tag-index =module =name) + group (&module/tag-group =module =name) + ;; :let [_ (println "#03")] + case-type (&type/variant-case idx value-type*) + ;; :let [_ (println "#04")] + [=test =kont] (analyse-pattern case-type unit kont) + ;; :let [_ (println "#05")] + ] + (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) + + (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) + ?values)) + (|do [;; :let [_ (println "#10" (&/ident->text ?ident))] + [=module =name] (&&/resolved-ident ?ident) + ;; :let [_ (println "#11")] + value-type* (adjust-type value-type) + ;; :let [_ (println "#12" (&type/show-type value-type*))] + idx (&module/tag-index =module =name) + group (&module/tag-group =module =name) + ;; :let [_ (println "#13")] + case-type (&type/variant-case idx value-type*) + ;; :let [_ (println "#14" (&type/show-type case-type))] [=test =kont] (case (&/|length ?values) 0 (analyse-pattern case-type unit kont) 1 (analyse-pattern case-type (&/|head ?values) kont) ;; 1+ - (analyse-pattern case-type (&/P (&/cursor$ "" -1 -1) (&/S &/$TupleS ?values)) kont)) + (analyse-pattern case-type (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont)) ;; :let [_ (println "#15")] ] - (return (&/P (&/S $SumTestAC ($$ &/P idx group-count =test)) =kont))) + (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) ))) (defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns] (|do [pattern+body (analyse-pattern value-type pattern (&&/analyse-1 analyse exo-type body))] - (return (&/Cons$ pattern+body patterns)))) + (return (&/|cons pattern+body patterns)))) (let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] (defn ^:private merge-total [struct test+body] (|let [[test ?body] test+body] (|case [struct test] [($DefaultTotal total?) ($StoreTestAC ?idx)] - (return (&/S $DefaultTotal true)) + (return (&/V $DefaultTotal true)) [[?tag [total? ?values]] ($StoreTestAC ?idx)] - (return (&/S ?tag (&/P true ?values))) + (return (&/V ?tag (&/T true ?values))) [($DefaultTotal total?) ($BoolTestAC ?value)] - (return (&/S $BoolTotal (&/P total? (&/|list ?value)))) + (return (&/V $BoolTotal (&/T total? (&/|list ?value)))) [($BoolTotal total? ?values) ($BoolTestAC ?value)] - (return (&/S $BoolTotal (&/P total? (&/Cons$ ?value ?values)))) + (return (&/V $BoolTotal (&/T total? (&/|cons ?value ?values)))) [($DefaultTotal total?) ($IntTestAC ?value)] - (return (&/S $IntTotal (&/P total? (&/|list ?value)))) + (return (&/V $IntTotal (&/T total? (&/|list ?value)))) [($IntTotal total? ?values) ($IntTestAC ?value)] - (return (&/S $IntTotal (&/P total? (&/Cons$ ?value ?values)))) + (return (&/V $IntTotal (&/T total? (&/|cons ?value ?values)))) [($DefaultTotal total?) ($RealTestAC ?value)] - (return (&/S $RealTotal (&/P total? (&/|list ?value)))) + (return (&/V $RealTotal (&/T total? (&/|list ?value)))) [($RealTotal total? ?values) ($RealTestAC ?value)] - (return (&/S $RealTotal (&/P total? (&/Cons$ ?value ?values)))) + (return (&/V $RealTotal (&/T total? (&/|cons ?value ?values)))) [($DefaultTotal total?) ($CharTestAC ?value)] - (return (&/S $CharTotal (&/P total? (&/|list ?value)))) + (return (&/V $CharTotal (&/T total? (&/|list ?value)))) [($CharTotal total? ?values) ($CharTestAC ?value)] - (return (&/S $CharTotal (&/P total? (&/Cons$ ?value ?values)))) + (return (&/V $CharTotal (&/T total? (&/|cons ?value ?values)))) [($DefaultTotal total?) ($TextTestAC ?value)] - (return (&/S $TextTotal (&/P total? (&/|list ?value)))) + (return (&/V $TextTotal (&/T total? (&/|list ?value)))) [($TextTotal total? ?values) ($TextTestAC ?value)] - (return (&/S $TextTotal (&/P total? (&/Cons$ ?value ?values)))) - - [($DefaultTotal total?) ($UnitTestAC)] - (return (&/S $UnitTotal nil)) - - [($UnitTotal) ($UnitTestAC)] - (return (&/S $UnitTotal nil)) - - [($DefaultTotal total?) ($ProdTestAC ?left ?right)] - (|do [:let [_default (&/S $DefaultTotal total?)] - =left (merge-total _default (&/P ?left ?body)) - =right (merge-total _default (&/P ?right ?body))] - (return (&/S $ProdTotal ($$ &/P total? =left =right)))) - - [($ProdTotal total? ?_left ?_right) ($ProdTestAC ?left ?right)] - (|do [=left (merge-total ?_left (&/P ?left ?body)) - =right (merge-total ?_right (&/P ?right ?body))] - (return (&/S $ProdTotal ($$ &/P total? =left =right)))) - - [($DefaultTotal total?) ($SumTestAC ?tag ?count ?test)] - (|do [sub-struct (merge-total (&/S $DefaultTotal total?) - (&/P ?test ?body)) - structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count (&/S $DefaultTotal total?))) + (return (&/V $TextTotal (&/T total? (&/|cons ?value ?values)))) + + [($DefaultTotal total?) ($TupleTestAC ?tests)] + (|do [structs (&/map% (fn [t] + (merge-total (&/V $DefaultTotal total?) (&/T t ?body))) + ?tests)] + (return (&/V $TupleTotal (&/T total? structs)))) + + [($TupleTotal total? ?values) ($TupleTestAC ?tests)] + (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) + (|do [structs (&/map2% (fn [v t] + (merge-total v (&/T t ?body))) + ?values ?tests)] + (return (&/V $TupleTotal (&/T total? structs)))) + (fail "[Pattern-matching Error] Inconsistent tuple-size.")) + + [($DefaultTotal total?) ($VariantTestAC ?tag ?count ?test)] + (|do [sub-struct (merge-total (&/V $DefaultTotal total?) + (&/T ?test ?body)) + structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count (&/V $DefaultTotal total?))) (&/$Some list) (return list) (&/$None) (fail "[Pattern-matching Error] YOLO"))] - (return (&/S $SumTotal (&/P total? structs)))) + (return (&/V $VariantTotal (&/T total? structs)))) - [($SumTotal total? ?branches) ($SumTestAC ?tag ?count ?test)] + [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)] (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches) (&/$Some sub) sub (&/$None) - (&/S $DefaultTotal total?)) - (&/P ?test ?body)) + (&/V $DefaultTotal total?)) + (&/T ?test ?body)) structs (|case (&/|list-put ?tag sub-struct ?branches) (&/$Some list) (return list) (&/$None) (fail "[Pattern-matching Error] YOLO"))] - (return (&/S $SumTotal (&/P total? structs)))) + (return (&/V $VariantTotal (&/T total? structs)))) )))) (defn ^:private check-totality [value-type struct] @@ -313,39 +351,33 @@ ($TextTotal ?total _) (return ?total) - ($UnitTotal) - (return true) - - ($ProdTotal ?total ?_left ?_right) + ($TupleTotal ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] (|case value-type* - (&/$ProdT ?left ?right) - (|do [=left (check-totality ?left ?_left) - =right (check-totality ?right ?_right)] - (return (and =left =right))) + (&/$TupleT ?members) + (|do [totals (&/map2% (fn [sub-struct ?member] + (check-totality ?member sub-struct)) + ?structs ?members)] + (return (&/fold #(and %1 %2) true totals))) _ (fail "[Pattern-maching Error] Tuple is not total.")))) - ($SumTotal ?total ?structs) + ($VariantTotal ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] - (|case [value-type* ?structs] - [(&/$SumT ?left ?right) (&/$Cons ?_left ?tail)] - (|do [=left (check-totality ?left ?_left) - =right (|case ?tail - (&/$Cons ?_right (&/$Nil)) - (check-totality ?right ?_right) - - (&/$Nil) - (fail "[Pattern-matching Error] Pattern-matching mismatch. Variant has wrong size.") - - _ - (check-totality ?right (&/S $SumTotal (&/P ?total ?tail))))] - (return (and =left =right))) + (|case value-type* + (&/$VariantT ?members) + (|do [totals (&/map2% (fn [sub-struct ?member] + ;; (prn '$VariantTotal + ;; (&/adt->text sub-struct) + ;; (&type/show-type ?member)) + (check-totality ?member sub-struct)) + ?structs ?members)] + (return (&/fold #(and %1 %2) true totals))) _ (fail "[Pattern-maching Error] Variant is not total.")))) @@ -362,7 +394,7 @@ (analyse-branch analyse exo-type value-type pattern body patterns))) (&/|list) branches) - struct (&/fold% merge-total (&/S $DefaultTotal false) patterns) + struct (&/fold% merge-total (&/V $DefaultTotal false) patterns) ? (check-totality value-type struct)] (if ? (return patterns) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 5686700e3..4e9dcd79f 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -15,31 +15,31 @@ ;; [Exports] (def next-local-idx (fn [state] - (return* state (->> state (&/$get-envs) &/|head (&/$get-locals) (&/$get-counter))))) + (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$counter))))) (defn with-local [name type body] ;; (prn 'with-local name) (fn [state] ;; (prn 'with-local name) - (let [old-mappings (->> state (&/$get-envs) &/|head (&/$get-locals) (&/$get-mappings)) - =return (body (&/$update-envs - (fn [stack] - (let [bound-unit (&/S &&/$var (&/S &/$Local (->> (&/|head stack) (&/$get-locals) (&/$get-counter))))] - (&/Cons$ (&/$update-locals #(->> % - (&/$update-counter inc) - (&/$update-mappings (fn [m] (&/|put name (&/P bound-unit type) m)))) - (&/|head stack)) - (&/|tail stack)))) - state))] + (let [old-mappings (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) + =return (body (&/update$ &/$envs + (fn [stack] + (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter))))] + (&/|cons (&/update$ &/$locals #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [m] (&/|put name (&/T bound-unit type) m)))) + (&/|head stack)) + (&/|tail stack)))) + state))] (|case =return (&/$Right ?state ?value) - (return* (&/$update-envs (fn [stack*] - (&/Cons$ (&/$update-locals #(->> % - (&/$update-counter dec) - (&/$set-mappings old-mappings)) - (&/|head stack*)) - (&/|tail stack*))) - ?state) + (return* (&/update$ &/$envs (fn [stack*] + (&/|cons (&/update$ &/$locals #(->> % + (&/update$ &/$counter dec) + (&/set$ &/$mappings old-mappings)) + (&/|head stack*)) + (&/|tail stack*))) + ?state) ?value) _ @@ -47,4 +47,4 @@ (def captured-vars (fn [state] - (return* state (->> state (&/$get-envs) &/|head (&/$get-closure) (&/$get-mappings))))) + (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$closure) (&/get$ &/$mappings))))) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 69aa95f12..64f297994 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -10,7 +10,7 @@ (:require (clojure [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail |case $$]] + (lux [base :as & :refer [|let |do return fail |case]] [parser :as &parser] [type :as &type] [host :as &host]) @@ -20,7 +20,7 @@ ;; [Utils] (defn ^:private extract-text [text] (|case text - [_ (&/$TextS ?text)] + (&/$Meta _ (&/$TextS ?text)) (return ?text) _ @@ -32,7 +32,7 @@ (|do [=expr (&&/analyse-1 analyse $var ?token) :let [[?item ?type] =expr] =type (&type/clean $var ?type)] - (return (&/P ?item =type)))))) + (return (&/T ?item =type)))))) (defn ^:private ensure-object [token] "(-> Analysis (Lux (,)))" @@ -47,20 +47,20 @@ "(-> Type Type)" (|case type (&/$DataT class) - (&type/Data$ (&type/as-obj class)) + (&/V &/$DataT (&type/as-obj class)) _ type)) ;; [Resources] (do-template [<name> <output-tag> <input-class> <output-class>] - (let [input-type (&type/Data$ <input-class>) - output-type (&type/Data$ <output-class>)] + (let [input-type (&/V &/$DataT <input-class>) + output-type (&/V &/$DataT <output-class>)] (defn <name> [analyse exo-type ?x ?y] (|do [=x (&&/analyse-1 analyse input-type ?x) =y (&&/analyse-1 analyse input-type ?y) _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S <output-tag> (&/P =x =y)) output-type)))))) + (return (&/|list (&/T (&/V <output-tag> (&/T =x =y)) output-type)))))) analyse-jvm-iadd &&/$jvm-iadd "java.lang.Integer" "java.lang.Integer" analyse-jvm-isub &&/$jvm-isub "java.lang.Integer" "java.lang.Integer" @@ -108,7 +108,7 @@ =type (&host/lookup-static-field class-loader ?class ?field) :let [output-type =type] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-getstatic (&/P ?class ?field)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-getstatic (&/T ?class ?field)) output-type))))) (defn analyse-jvm-getfield [analyse exo-type ?class ?field ?object] (|do [class-loader &/loader @@ -116,7 +116,7 @@ =object (&&/analyse-1 analyse ?object) :let [output-type =type] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-getfield ($$ &/P ?class ?field =object)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-getfield (&/T ?class ?field =object)) output-type))))) (defn analyse-jvm-putstatic [analyse exo-type ?class ?field ?value] (|do [class-loader &/loader @@ -124,7 +124,7 @@ =value (&&/analyse-1 analyse =type ?value) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-putstatic ($$ &/P ?class ?field =value)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-putstatic (&/T ?class ?field =value)) output-type))))) (defn analyse-jvm-putfield [analyse exo-type ?class ?field ?object ?value] (|do [class-loader &/loader @@ -133,7 +133,7 @@ =value (&&/analyse-1 analyse =type ?value) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-putfield ($$ &/P ?class ?field =object =value)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-putfield (&/T ?class ?field =object =value)) output-type))))) (defn analyse-jvm-invokestatic [analyse exo-type ?class ?method ?classes ?args] (|do [class-loader &/loader @@ -143,31 +143,31 @@ ;; [[&/$DataT _return-class]] ;; (prn 'analyse-jvm-invokestatic ?class ?method _return-class))] =args (&/map2% (fn [_class _arg] - (&&/analyse-1 analyse (&type/Data$ _class) _arg)) + (&&/analyse-1 analyse (&/V &/$DataT _class) _arg)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-invokestatic ($$ &/P ?class ?method =classes =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-invokestatic (&/T ?class ?method =classes =args)) output-type))))) (defn analyse-jvm-instanceof [analyse exo-type ?class ?object] (|do [=object (analyse-1+ analyse ?object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-instanceof (&/P ?class =object)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-instanceof (&/T ?class =object)) output-type))))) (do-template [<name> <tag>] (defn <name> [analyse exo-type ?class ?method ?classes ?object ?args] (|do [class-loader &/loader =classes (&/map% extract-text ?classes) =return (&host/lookup-virtual-method class-loader ?class ?method =classes) - =object (&&/analyse-1 analyse (&type/Data$ ?class) ?object) - =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&type/Data$ ?c) ?o)) + =object (&&/analyse-1 analyse (&/V &/$DataT ?class) ?object) + =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S <tag> ($$ &/P ?class ?method =classes =object =args)) output-type))))) + (return (&/|list (&/T (&/V <tag> (&/T ?class ?method =classes =object =args)) output-type))))) analyse-jvm-invokevirtual &&/$jvm-invokevirtual analyse-jvm-invokeinterface &&/$jvm-invokeinterface @@ -179,73 +179,73 @@ =return (if (= "<init>" ?method) (return &type/Unit) (&host/lookup-virtual-method class-loader ?class ?method =classes)) - =object (&&/analyse-1 analyse (&type/Data$ ?class) ?object) + =object (&&/analyse-1 analyse (&/V &/$DataT ?class) ?object) =args (&/map2% (fn [?c ?o] - (&&/analyse-1 analyse (&type/Data$ ?c) ?o)) + (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-invokespecial ($$ &/P ?class ?method =classes =object =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-invokespecial (&/T ?class ?method =classes =object =args)) output-type))))) (defn analyse-jvm-null? [analyse exo-type ?object] (|do [=object (analyse-1+ analyse ?object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-null? =object) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-null? =object) output-type))))) (defn analyse-jvm-null [analyse exo-type] - (|do [:let [output-type (&type/Data$ "null")] + (|do [:let [output-type (&/V &/$DataT "null")] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-null nil) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-null nil) output-type))))) (defn analyse-jvm-new [analyse exo-type ?class ?classes ?args] (|do [=classes (&/map% extract-text ?classes) =args (&/map% (partial analyse-1+ analyse) ?args) - :let [output-type (&type/Data$ ?class)] + :let [output-type (&/V &/$DataT ?class)] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-new ($$ &/P ?class =classes =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-new (&/T ?class =classes =args)) output-type))))) (defn analyse-jvm-new-array [analyse ?class ?length] - (return (&/|list (&/P (&/S &&/$jvm-new-array (&/P ?class ?length)) (&/S "array" (&/P (&type/Data$ ?class) - (&/S &/$Nil nil))))))) + (return (&/|list (&/T (&/V &&/$jvm-new-array (&/T ?class ?length)) (&/V "array" (&/T (&/V &/$DataT ?class) + (&/V &/$Nil nil))))))) (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] (|do [=array (analyse-1+ analyse ?array) =elem (analyse-1+ analyse ?elem) =array-type (&&/expr-type =array)] - (return (&/|list (&/P (&/S &&/$jvm-aastore ($$ &/P =array ?idx =elem)) =array-type))))) + (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T =array ?idx =elem)) =array-type))))) (defn analyse-jvm-aaload [analyse ?array ?idx] (|do [=array (analyse-1+ analyse ?array) =array-type (&&/expr-type =array)] - (return (&/|list (&/P (&/S &&/$jvm-aaload (&/P =array ?idx)) =array-type))))) + (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T =array ?idx)) =array-type))))) (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] (|case modif - [_ (&/$TextS "public")] + (&/$Meta _ (&/$TextS "public")) (return (assoc so-far :visibility "public")) - [_ (&/$TextS "private")] + (&/$Meta _ (&/$TextS "private")) (return (assoc so-far :visibility "private")) - [_ (&/$TextS "protected")] + (&/$Meta _ (&/$TextS "protected")) (return (assoc so-far :visibility "protected")) - [_ (&/$TextS "static")] + (&/$Meta _ (&/$TextS "static")) (return (assoc so-far :static? true)) - [_ (&/$TextS "final")] + (&/$Meta _ (&/$TextS "final")) (return (assoc so-far :final? true)) - [_ (&/$TextS "abstract")] + (&/$Meta _ (&/$TextS "abstract")) (return (assoc so-far :abstract? true)) - [_ (&/$TextS "synchronized")] + (&/$Meta _ (&/$TextS "synchronized")) (return (assoc so-far :concurrency "synchronized")) - [_ (&/$TextS "volatile")] + (&/$Meta _ (&/$TextS "volatile")) (return (assoc so-far :concurrency "volatile")) _ @@ -275,10 +275,10 @@ (|do [=interfaces (&/map% extract-text ?interfaces) =fields (&/map% (fn [?field] (|case ?field - [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] - (&/$Cons [_ (&/$TextS ?field-type)] - (&/$Cons [_ (&/$TupleS ?field-modifiers)] - (&/$Nil)))))] + (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?field-name)) + (&/$Cons (&/$Meta _ (&/$TextS ?field-type)) + (&/$Cons (&/$Meta _ (&/$TupleS ?field-modifiers)) + (&/$Nil)))))) (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] (return {:name ?field-name :modifiers =field-modifiers @@ -289,18 +289,18 @@ ?fields) =methods (&/map% (fn [?method] (|case ?method - [?idx [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] - (&/$Cons [_ (&/$TupleS ?method-inputs)] - (&/$Cons [_ (&/$TextS ?method-output)] - (&/$Cons [_ (&/$TupleS ?method-modifiers)] - (&/$Cons ?method-body - (&/$Nil)))))))]] + [?idx (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?method-name)) + (&/$Cons (&/$Meta _ (&/$TupleS ?method-inputs)) + (&/$Cons (&/$Meta _ (&/$TextS ?method-output)) + (&/$Cons (&/$Meta _ (&/$TupleS ?method-modifiers)) + (&/$Cons ?method-body + (&/$Nil))))))))] (|do [=method-inputs (&/map% (fn [minput] (|case minput - [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" ?input-name)] - (&/$Cons [_ (&/$TextS ?input-type)] - (&/$Nil))))] - (return (&/P ?input-name ?input-type)) + (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS "" ?input-name)) + (&/$Cons (&/$Meta _ (&/$TextS ?input-type)) + (&/$Nil))))) + (return (&/T ?input-name ?input-type)) _ (fail "[Analyser Error] Wrong syntax for method input."))) @@ -309,14 +309,14 @@ =method-body (&/with-scope (str ?name "_" ?idx) (&/fold (fn [body* input*] (|let [[iname itype] input*] - (&&env/with-local iname (&type/Data$ (as-otype itype)) + (&&env/with-local iname (&/V &/$DataT (as-otype itype)) body*))) (if (= "void" ?method-output) (analyse-1+ analyse ?method-body) - (&&/analyse-1 analyse (&type/Data$ (as-otype ?method-output)) ?method-body)) + (&&/analyse-1 analyse (&/V &/$DataT (as-otype ?method-output)) ?method-body)) (&/|reverse (if (:static? =method-modifiers) =method-inputs - (&/Cons$ (&/P "this" ?super-class) + (&/|cons (&/T ";this" ?super-class) =method-inputs)))))] (return {:name ?method-name :modifiers =method-modifiers @@ -327,18 +327,18 @@ _ (fail "[Analyser Error] Wrong syntax for method."))) (&/enumerate ?methods)) - _ (compile-token (&/S &&/$jvm-class ($$ &/P ?name ?super-class =interfaces =fields =methods)))] + _ (compile-token (&/V &&/$jvm-class (&/T ?name ?super-class =interfaces =fields =methods)))] (return (&/|list)))) (defn analyse-jvm-interface [analyse compile-token ?name ?supers ?methods] (|do [=supers (&/map% extract-text ?supers) =methods (&/map% (fn [method] (|case method - [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] - (&/$Cons [_ (&/$TupleS ?inputs)] - (&/$Cons [_ (&/$TextS ?output)] - (&/$Cons [_ (&/$TupleS ?modifiers)] - (&/$Nil))))))] + (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?method-name)) + (&/$Cons (&/$Meta _ (&/$TupleS ?inputs)) + (&/$Cons (&/$Meta _ (&/$TextS ?output)) + (&/$Cons (&/$Meta _ (&/$TupleS ?modifiers)) + (&/$Nil))))))) (|do [=inputs (&/map% extract-text ?inputs) =modifiers (analyse-modifiers ?modifiers)] (return {:name ?method-name @@ -349,29 +349,29 @@ _ (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) ?methods) - _ (compile-token (&/S &&/$jvm-interface ($$ &/P ?name =supers =methods)))] + _ (compile-token (&/V &&/$jvm-interface (&/T ?name =supers =methods)))] (return (&/|list)))) (defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] (|do [:let [[?catches ?finally] ?catches+?finally] =body (&&/analyse-1 analyse exo-type ?body) =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (|do [=catch-body (&&env/with-local ?ex-arg (&type/Data$ ?ex-class) + (|do [=catch-body (&&env/with-local ?ex-arg (&/V &/$DataT ?ex-class) (&&/analyse-1 analyse exo-type ?catch-body)) idx &&env/next-local-idx] - (return ($$ &/P ?ex-class idx =catch-body)))) + (return (&/T ?ex-class idx =catch-body)))) ?catches) - =finally (|case ?finally - (&/$None) (return &/None$) + =finally (|case [?finally] + (&/$None) (return (&/V &/$None nil)) (&/$Some ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] - (return (&/Some$ =finally))))] - (return (&/|list (&/P (&/S &&/$jvm-try ($$ &/P =body =catches =finally)) exo-type))))) + (return (&/V &/$Some =finally))))] + (return (&/|list (&/T (&/V &&/$jvm-try (&/T =body =catches =finally)) exo-type))))) (defn analyse-jvm-throw [analyse exo-type ?ex] (|do [=ex (analyse-1+ analyse ?ex) :let [[_obj _type] =ex] - _ (&type/check (&type/Data$ "java.lang.Throwable") _type)] - (return (&/|list (&/P (&/S &&/$jvm-throw =ex) &type/$Void))))) + _ (&type/check (&/V &/$DataT "java.lang.Throwable") _type)] + (return (&/|list (&/T (&/V &&/$jvm-throw =ex) &type/$Void))))) (do-template [<name> <tag>] (defn <name> [analyse exo-type ?monitor] @@ -379,18 +379,18 @@ _ (ensure-object =monitor) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S <tag> =monitor) output-type))))) + (return (&/|list (&/T (&/V <tag> =monitor) output-type))))) analyse-jvm-monitorenter &&/$jvm-monitorenter analyse-jvm-monitorexit &&/$jvm-monitorexit ) (do-template [<name> <tag> <from-class> <to-class>] - (let [output-type (&type/Data$ <to-class>)] + (let [output-type (&/V &/$DataT <to-class>)] (defn <name> [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&type/Data$ <from-class>) ?value) + (|do [=value (&&/analyse-1 analyse (&/V &/$DataT <from-class>) ?value) _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S <tag> =value) output-type)))))) + (return (&/|list (&/T (&/V <tag> =value) output-type)))))) analyse-jvm-d2f &&/$jvm-d2f "java.lang.Double" "java.lang.Float" analyse-jvm-d2i &&/$jvm-d2i "java.lang.Double" "java.lang.Integer" @@ -413,11 +413,11 @@ ) (do-template [<name> <tag> <from-class> <to-class>] - (let [output-type (&type/Data$ <to-class>)] + (let [output-type (&/V &/$DataT <to-class>)] (defn <name> [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&type/Data$ <from-class>) ?value) + (|do [=value (&&/analyse-1 analyse (&/V &/$DataT <from-class>) ?value) _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S <tag> =value) output-type)))))) + (return (&/|list (&/T (&/V <tag> =value) output-type)))))) analyse-jvm-iand &&/$jvm-iand "java.lang.Integer" "java.lang.Integer" analyse-jvm-ior &&/$jvm-ior "java.lang.Integer" "java.lang.Integer" @@ -436,7 +436,7 @@ (defn analyse-jvm-program [analyse compile-token ?args ?body] (|do [=body (&/with-scope "" - (&&env/with-local ?args (&type/App$ &type/List &type/Text) - (&&/analyse-1 analyse (&type/App$ &type/IO &type/Unit) ?body))) - _ (compile-token (&/S &&/$jvm-program =body))] + (&&env/with-local ?args (&/V &/$AppT (&/T &type/List &type/Text)) + (&&/analyse-1 analyse (&/V &/$AppT (&/T &type/IO &type/Unit)) ?body))) + _ (compile-token (&/V &&/$jvm-program =body))] (return (&/|list)))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index b30953f67..aeb5a4814 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -9,7 +9,7 @@ (ns lux.analyser.lambda (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail |case $$]] + (lux [base :as & :refer [|let |do return fail |case]] [host :as &host]) (lux.analyser [base :as &&] [env :as &env]))) @@ -22,19 +22,15 @@ (&env/with-local arg arg-type (|do [=return body =captured &env/captured-vars] - (return ($$ &/P scope-name =captured =return)))))))) + (return (&/T scope-name =captured =return)))))))) (defn close-over [scope name register frame] (|let [[_ register-type] register - register* (&/P (&/S &&/$captured ($$ &/P scope - (->> frame (&/$get-closure) (&/$get-counter)) - register)) + register* (&/T (&/V &&/$captured (&/T scope + (->> frame (&/get$ &/$closure) (&/get$ &/$counter)) + register)) register-type)] - (do ;; (prn 'close-over 'updating-closure - ;; [(->> frame (&/$get-closure) (&/$get-counter)) (->> frame (&/$get-closure) (&/$get-counter) inc)] - ;; [(->> frame (&/$get-closure) (&/$get-mappings) &/ident->text) - ;; (->> frame (&/$get-closure) (&/$get-mappings) (&/|put name register*) &/ident->text)]) - ($$ &/P register* (&/$update-closure #(->> % - (&/$update-counter inc) - (&/$update-mappings (fn [mps] (&/|put name register* mps)))) - frame))))) + (&/T register* (&/update$ &/$closure #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [mps] (&/|put name register* mps)))) + frame)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 20e435eb3..d241201f4 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -10,7 +10,7 @@ (:require (clojure [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return return* fail fail* |let |list |case $$]] + (lux [base :as & :refer [|do return return* fail fail* |let |list |case]] [parser :as &parser] [type :as &type] [host :as &host]) @@ -27,64 +27,52 @@ (|do [=expr (&&/analyse-1 analyse $var ?token) :let [[?item ?type] =expr] =type (&type/clean $var ?type)] - (return (&/P ?item =type)))))) + (return (&/T ?item =type)))))) (defn ^:private with-cursor [cursor form] (|case form - [_ syntax] - (&/P cursor syntax))) + (&/$Meta _ syntax) + (&/V &/$Meta (&/T cursor syntax)))) ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] - ;; (prn 'analyse-tuple/_0 (&type/show-type exo-type) (->> ?elems (&/|map &/show-ast) (&/->seq))) - (|case ?elems - (&/$Nil) - (|do [_ (&type/check exo-type &type/Unit)] - (return (&/|list (&/P (&/S &&/$unit nil) - exo-type)))) - - (&/$Cons single (&/$Nil)) - (fail (str "Tuples can't have only 1 element: " (&/show-ast single))) - - (&/$Cons head tail) - (|do [exo-type* (&type/actual-type exo-type) - ;; :let [_ (prn 'analyse-tuple/_0.25_0 (&/show-ast head) (&/adt->text exo-type*)) - ;; _ (prn 'analyse-tuple/_0.25_1 (&/show-ast head) (&type/show-type exo-type*))] - ] - (|case exo-type* - (&/$ProdT ?left ?right) - (|do [;; :let [_ (prn 'analyse-tuple/_0.5 (&/show-ast head) (&type/show-type ?left))] - =left (&&/analyse-1 analyse ?left head) - ;; :let [_ (prn 'analyse-tuple/_1 =left (&type/show-type ?left))] - =right (|case tail - (&/$Nil) - (fail "Tuples has wrong size.") - - (&/$Cons single (&/$Nil)) - (&&/analyse-1 analyse ?right single) - - _ - (&/ensure-1 (analyse-tuple analyse ?right tail))) - ;; :let [_ (prn 'analyse-tuple/_2 =right (&type/show-type ?right))] - ] - (return (&/|list (&/P (&/S &&/$prod (&/P =left =right)) - exo-type)))) + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$TupleT ?members) + (|do [=elems (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + ?members ?elems)] + (return (&/|list (&/T (&/V &&/$tuple =elems) + exo-type)))) - (&/$AllT _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-tuple analyse exo-type** ?elems)))) + (&/$AllT _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var)] + (analyse-tuple analyse exo-type** ?elems)))) - _ - (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*))))) - )) + _ + (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))))) + +(defn ^:private analyse-variant-body [analyse exo-type ?values] + (|do [output (|case ?values + (&/$Nil) + (analyse-tuple analyse exo-type (&/|list)) + + (&/$Cons ?value (&/$Nil)) + (analyse exo-type ?value) + + _ + (analyse-tuple analyse exo-type ?values) + )] + (|case output + (&/$Cons x (&/$Nil)) + (return x) + + _ + (fail "[Analyser Error] Can't expand to other than 1 element.")))) (defn analyse-variant [analyse exo-type idx ?values] - ;; (prn 'analyse-variant/_0 - ;; (&type/show-type exo-type) - ;; idx - ;; (->> ?values (&/|map &/show-ast) (&/->seq))) (|do [exo-type* (|case exo-type (&/$VarT ?id) (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] @@ -95,41 +83,82 @@ _ (&type/actual-type exo-type))] (|case exo-type* + (&/$VariantT ?cases) + (|case (&/|at idx ?cases) + (&/$Some vtype) + (|do [=value (analyse-variant-body analyse vtype ?values)] + (return (&/|list (&/T (&/V &&/$variant (&/T idx =value)) + exo-type)))) + + (&/$None) + (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*)))) + (&/$AllT _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] (analyse-variant analyse exo-type** idx ?values)))) - - ?variant - (|do [;; :let [_ (prn 'analyse-variant/_1 - ;; (&type/show-type ?variant) - ;; idx - ;; (->> ?values (&/|map &/show-ast) (&/->seq)))] - vtype (&type/variant-case idx ?variant) - ;; :let [_ (prn 'analyse-variant/_2 - ;; idx - ;; (&type/show-type vtype))] - =value (&/ensure-1 (|case ?values - (&/$Nil) - (analyse-tuple analyse vtype (&/|list)) - - (&/$Cons ?value (&/$Nil)) - (analyse vtype ?value) - - _ - (analyse-tuple analyse vtype ?values))) - ;; :let [_ (prn 'analyse-variant/_3 - ;; idx - ;; =value)] - ] - (return (&/|list (&/P (&/S &&/$sum (&/P idx =value)) - exo-type)))) - ))) + + _ + (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) +;; (defn analyse-variant [analyse exo-type ident ?values] +;; (|do [exo-type* (|case exo-type +;; (&/$VarT ?id) +;; (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] +;; (&type/actual-type exo-type*)) +;; (|do [_ (&type/set-var ?id &type/Type)] +;; (&type/actual-type &type/Type)))) + +;; _ +;; (&type/actual-type exo-type))] +;; (|case exo-type* +;; (&/$VariantT ?cases) +;; (|do [?tag (&&/resolved-ident ident)] +;; (if-let [vtype (&/|get ?tag ?cases)] +;; (|do [=value (analyse-variant-body analyse vtype ?values)] +;; (return (&/|list (&/T (&/V &&/$variant (&/T ?tag =value)) +;; exo-type)))) +;; (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) + +;; (&/$AllT _) +;; (&type/with-var +;; (fn [$var] +;; (|do [exo-type** (&type/apply-type exo-type* $var)] +;; (analyse-variant analyse exo-type** ident ?values)))) + +;; _ +;; (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 [members (&&record/order-record ?elems)] - (analyse-tuple analyse exo-type members))) + (|do [exo-type* (|case exo-type + (&/$VarT ?id) + (|do [exo-type* (&type/deref ?id)] + (&type/actual-type exo-type*)) + + (&/$AllT _) + (|do [$var &type/existential + =type (&type/apply-type exo-type $var)] + (&type/actual-type =type)) + ;; (&type/with-var + ;; (fn [$var] + ;; (|do [=type (&type/apply-type exo-type $var)] + ;; (&type/actual-type =type)))) + + _ + (&type/actual-type exo-type)) + types (|case exo-type* + (&/$TupleT ?table) + (return ?table) + + _ + (fail (str "[Analyser Error] The type of a record must be a record-type:\n" (&type/show-type exo-type*)))) + _ (&/assert! (= (&/|length types) (&/|length ?elems)) + (str "[Analyser Error] Record length mismatch. Expected: " (&/|length types) "; actual: " (&/|length ?elems))) + members (&&record/order-record ?elems) + =members (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + types members)] + (return (&/|list (&/T (&/V &&/$tuple =members) exo-type))))) (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) @@ -148,17 +177,14 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/P (&/S &&/$var (&/S &/$Global (&/P r-module r-name))) + (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) endo-type))))) (defn ^:private analyse-local [analyse exo-type name] (fn [state] - (|let [stack (&/$get-envs state) - no-binding? #(do ;; (prn 'analyse-local/_ (->> % &/adt->text)) - ;; (prn 'analyse-local/_1 (->> % (&/$get-locals) &/adt->text)) - ;; (prn 'analyse-local/_2 (->> % (&/$get-closure) &/adt->text)) - (and (->> % (&/$get-locals) (&/$get-mappings) (&/|contains? name) not) - (->> % (&/$get-closure) (&/$get-mappings) (&/|contains? name) not))) + (|let [stack (&/get$ &/$envs state) + no-binding? #(and (->> % (&/get$ &/$locals) (&/get$ &/$mappings) (&/|contains? name) not) + (->> % (&/get$ &/$closure) (&/get$ &/$mappings) (&/|contains? name) not)) [inner outer] (&/|split-with no-binding? stack)] (|case outer (&/$Nil) @@ -167,8 +193,8 @@ state) (&/$Cons ?genv (&/$Nil)) - (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/$get-locals) (&/$get-mappings) &/|keys &/->seq)) - (if-let [global (->> ?genv (&/$get-locals) (&/$get-mappings) (&/|get name))] + (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) &/|keys &/->seq)) + (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))] (do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0)) (|case global [(&/$Global ?module* name*) _] @@ -187,35 +213,32 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/P (&/S &&/$var (&/S &/$Global (&/P r-module r-name))) + (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) endo-type)))) state) - _ - (fail* "[Analyser Error] Can't have anything other than a global def in the global environment."))) + [_] + (do ;; (prn 'analyse-symbol/_2.1.2 ?module name name) + (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) (fail* "_{_ analyse-symbol _}_"))) (&/$Cons top-outer _) (do ;; (prn 'analyse-symbol/_3 ?module name) - (|let [scopes (&/|tail (&/folds #(&/Cons$ (&/$get-name %2) %1) - (&/|map #(&/$get-name %) outer) + (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$name %2) %1) + (&/|map #(&/get$ &/$name %) outer) (&/|reverse inner))) [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] (|let [[register new-inner] register+new-inner [register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)] - (&/P register* (&/Cons$ frame* new-inner)))) - (&/P (or (->> top-outer (&/$get-locals) (&/$get-mappings) (&/|get name)) - (->> top-outer (&/$get-closure) (&/$get-mappings) (&/|get name))) + (&/T register* (&/|cons frame* new-inner)))) + (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) + (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) (&/|list)) (&/|reverse inner) scopes)] ((|do [btype (&&/expr-type =local) - ;; :let [_ (prn 'analyse-local/_0 name) - ;; _ (prn 'analyse-local/_1 name (&type/show-type exo-type) (&type/show-type btype))] - _ (&type/check exo-type btype) - ;; :let [_ (prn 'analyse-local/_2 name 'CHECKED)] - ] + _ (&type/check exo-type btype)] (return (&/|list =local))) - (&/$set-envs (&/|++ inner* outer) state)))) + (&/set$ &/$envs (&/|++ inner* outer) state)))) )))) (defn analyse-symbol [analyse exo-type ident] @@ -230,7 +253,7 @@ (|case ?args (&/$Nil) (|do [_ (&type/check exo-type fun-type)] - (return (&/P fun-type (&/|list)))) + (return (&/T fun-type (&/|list)))) (&/$Cons ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] @@ -248,15 +271,15 @@ (|do [? (&type/bound? ?id) type** (if ? (&type/clean $var =output-t) - (|do [_ (&type/set-var ?id (&/S &/$BoundT _aarg))] + (|do [_ (&type/set-var ?id (&/V &/$BoundT _aarg))] (&type/clean $var =output-t)))] - (return (&/P type** =args))) + (return (&/T type** =args))) )))) (&/$LambdaT ?input-t ?output-t) (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) =arg (&&/analyse-1 analyse ?input-t ?arg)] - (return (&/P =output-t (&/Cons$ =arg =args)))) + (return (&/T =output-t (&/|cons =arg =args)))) ;; [[&/$VarT ?id-t]] ;; (|do [ (&type/deref ?id-t)]) @@ -277,25 +300,25 @@ macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] ;; :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] - :let [_ (when (or (= "using" (aget real-name 1)) - ;; (= "type" (aget real-name 1)) - ;; (= &&/$struct r-name) - ) - (->> (&/|map &/show-ast macro-expansion) - (&/|interpose "\n") - (&/fold str "") - (prn (&/ident->text real-name))))] + ;; :let [_ (when (or (= "defsig" (aget real-name 1)) + ;; ;; (= "type" (aget real-name 1)) + ;; ;; (= &&/$struct r-name) + ;; ) + ;; (->> (&/|map &/show-ast macro-expansion) + ;; (&/|interpose "\n") + ;; (&/fold str "") + ;; (prn (&/ident->text real-name))))] ] (&/flat-map% (partial analyse exo-type) macro-expansion)) _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/P (&/S &&/$apply (&/P =fn =args)) + (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args)) =output-t)))))) _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/P (&/S &&/$apply (&/P =fn =args)) + (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args)) =output-t))))) ))) @@ -306,7 +329,7 @@ =value (analyse-1+ analyse ?value) =value-type (&&/expr-type =value) =match (&&case/analyse-branches analyse exo-type =value-type (&/|as-pairs ?branches))] - (return (&/|list (&/P (&/S &&/$case (&/P =value =match)) + (return (&/|list (&/T (&/V &&/$case (&/T =value =match)) exo-type))))) (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] @@ -325,7 +348,7 @@ (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* ?arg ?arg-t (&&/analyse-1 analyse ?return-t ?body))] - (return (&/P (&/S &&/$lambda ($$ &/P =scope =captured =body)) exo-type*))) + (return (&/T (&/V &&/$lambda (&/T =scope =captured =body)) exo-type*))) _ (fail (str "[Analyser Error] Functions require function types: " @@ -347,22 +370,22 @@ ] (|case dtype (&/$BoundT ?vname) - (return (&/P _expr exo-type)) + (return (&/T _expr exo-type)) (&/$ExT _) - (return (&/P _expr exo-type)) + (return (&/T _expr exo-type)) (&/$VarT ?_id) (|do [?? (&type/bound? ?_id)] - ;; (return (&/P _expr exo-type)) + ;; (return (&/T _expr exo-type)) (if ?? (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))) - (return (&/P _expr exo-type))) + (return (&/T _expr exo-type))) ) _ (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))) - (return (&/P _expr exo-type)))))))) + (return (&/T _expr exo-type)))))))) _ (|do [exo-type* (&type/actual-type exo-type)] @@ -395,7 +418,7 @@ _ (do ;; (println 'DEF (str module-name ";" ?name)) - (|do [_ (compile-token (&/S &&/$def (&/P ?name =value))) + (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) _ (println 'DEF (str module-name ";" ?name))]] (return (&/|list))))) @@ -405,16 +428,16 @@ (|do [;; :let [_ (prn 'analyse-declare-macro ?name "0")] module-name &/get-module-name ;; :let [_ (prn 'analyse-declare-macro ?name "1")] - _ (compile-token (&/S &&/$declare-macro (&/P module-name ?name))) + _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name))) ;; :let [_ (prn 'analyse-declare-macro ?name "2")] ] (return (&/|list)))) (defn analyse-declare-tags [tags type-name] (|do [module-name &/get-module-name - ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/P module-name type-name)) (&/->seq tags))] + ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags))] [_ def-data] (&&module/find-def module-name type-name) - ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/P module-name type-name)) (&/->seq tags) (&/adt->text def-data))] + ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags) (&/adt->text def-data))] def-type (&&module/ensure-type-def def-data) _ (&&module/declare-tags module-name tags def-type)] (return (&/|list)))) @@ -446,7 +469,7 @@ ==type (eval! =type) _ (&type/check exo-type ==type) =value (&&/analyse-1 analyse ==type ?value)] - (return (&/|list (&/P (&/S &&/$ann (&/P =value =type)) + (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) ==type))))) (defn analyse-coerce [analyse eval! exo-type ?type ?value] @@ -454,5 +477,5 @@ ==type (eval! =type) _ (&type/check exo-type ==type) =value (analyse-1+ analyse ?value)] - (return (&/|list (&/P (&/S &&/$ann (&/P =value =type)) + (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) ==type))))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index bc9647f9f..d23953f5e 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -12,70 +12,69 @@ [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [defrtags |let |do return return* fail fail* |case $$]] + (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]] [type :as &type] [host :as &host]))) ;; [Utils] -(defrtags - ["module-aliases" - "defs" - "imports" - "tags" - "types"]) +(deftags "" + "module-aliases" + "defs" + "imports" + "tags" + "types") (def ^:private +init+ - ($$ &/P - ;; "lux;module-aliases" - (&/|table) - ;; "lux;defs" - (&/|table) - ;; "lux;imports" - (&/|list) - ;; "lux;tags" - (&/|table) - ;; "lux;types" - (&/|table) - )) + (&/T ;; "lux;module-aliases" + (&/|table) + ;; "lux;defs" + (&/|table) + ;; "lux;imports" + (&/|list) + ;; "lux;tags" + (&/|table) + ;; "lux;types" + (&/|table) + )) ;; [Exports] (defn add-import [module] "(-> Text (Lux (,)))" (|do [current-module &/get-module-name] (fn [state] - (return* (&/$update-modules - (fn [ms] - (&/|update current-module - (fn [m] ($update-imports (partial &/Cons$ module) m)) - ms)) - state) + (return* (&/update$ &/$modules + (fn [ms] + (&/|update current-module + (fn [m] (&/update$ $imports (partial &/|cons module) m)) + ms)) + state) nil)))) (defn set-imports [imports] "(-> (List Text) (Lux (,)))" (|do [current-module &/get-module-name] (fn [state] - (return* (&/$update-modules - (fn [ms] - (&/|update current-module - (fn [m] ($set-imports imports m)) - ms)) - state) + (return* (&/update$ &/$modules + (fn [ms] + (&/|update current-module + (fn [m] (&/set$ $imports imports m)) + ms)) + state) nil)))) (defn define [module name def-data type] ;; (prn 'define module name (aget def-data 0) (&type/show-type type)) (fn [state] - (|case (&/$get-envs state) + (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) (return* (->> state - (&/$update-modules - (fn [ms] - (&/|update module - (fn [m] - ($update-defs - #(&/|put name (&/P false def-data) %) - m)) - ms)))) + (&/update$ &/$modules + (fn [ms] + (&/|update module + (fn [m] + (&/update$ $defs + #(&/|put name (&/T false def-data) %) + m)) + ms)))) nil) _ @@ -84,8 +83,8 @@ (defn def-type [module name] "(-> Text Text (Lux Type))" (fn [state] - (if-let [$module (->> state (&/$get-modules) (&/|get module))] - (if-let [$def (->> $module ($get-defs) (&/|get name))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|case $def [_ (&/$TypeD _)] (return* state &type/Type) @@ -105,31 +104,31 @@ (defn type-def [module name] "(-> Text Text (Lux Type))" (fn [state] - (if-let [$module (->> state (&/$get-modules) (&/|get module))] - (if-let [$def (->> $module ($get-defs) (&/|get name))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|case $def [_ (&/$TypeD _type)] (return* state _type) _ - (fail* (str "[Analyser Error] Not a type: " (&/ident->text (&/P module name))))) - (fail* (str "[Analyser Error] Unknown definition: " (&/ident->text (&/P module name))))) + (fail* (str "[Analyser Error] Not a type: " (&/ident->text (&/T module name))))) + (fail* (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T module name))))) (fail* (str "[Analyser Error] Unknown module: " module))))) (defn def-alias [a-module a-name r-module r-name type] ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type)) (fn [state] - (|case (&/$get-envs state) + (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) (return* (->> state - (&/$update-modules - (fn [ms] - (&/|update a-module - (fn [m] - ($update-defs - #(&/|put a-name (&/P false (&/S &/$AliasD (&/P r-module r-name))) %) - m)) - ms)))) + (&/update$ &/$modules + (fn [ms] + (&/|update a-module + (fn [m] + (&/update$ $defs + #(&/|put a-name (&/T false (&/V &/$AliasD (&/T r-module r-name))) %) + m)) + ms)))) nil) _ @@ -138,30 +137,26 @@ (defn exists? [name] "(-> Text (Lux Bool))" (fn [state] - ;; (prn 'exists?/_0 &/$modules name) - ;; (prn 'exists?/_2 (&/adt->text state)) - ;; (prn 'exists?/_3 (&/adt->text (->> state (&/$get-modules)))) - ;; (prn 'exists?/_4 (&/adt->text (->> state (&/$get-modules) (&/|contains? name)))) (return* state - (->> state (&/$get-modules) (&/|contains? name))))) + (->> state (&/get$ &/$modules) (&/|contains? name))))) (defn alias [module alias reference] (fn [state] (return* (->> state - (&/$update-modules - (fn [ms] - (&/|update module - #($update-module-aliases - (fn [aliases] - (&/|put alias reference aliases)) - %) - ms)))) + (&/update$ &/$modules + (fn [ms] + (&/|update module + #(&/update$ $module-aliases + (fn [aliases] + (&/|put alias reference aliases)) + %) + ms)))) nil))) (defn dealias [name] (|do [current-module &/get-module-name] (fn [state] - (if-let [real-name (->> state (&/$get-modules) (&/|get current-module) ($get-module-aliases) (&/|get name))] + (if-let [real-name (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $module-aliases) (&/|get name))] (return* state real-name) (fail* (str "Unknown alias: " name)))))) @@ -169,9 +164,9 @@ (|do [current-module &/get-module-name] (fn [state] ;; (prn 'find-def/_0 module name 'current-module current-module) - (if-let [$module (->> state (&/$get-modules) (&/|get module))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module))) - (if-let [$def (->> $module ($get-defs) (&/|get name))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|let [[exported? $$def] $def] (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) (if (or exported? (.equals ^Object current-module module)) @@ -182,7 +177,7 @@ state)) _ - (return* state (&/P (&/P module name) $$def))) + (return* state (&/T (&/T module name) $$def))) (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))))) (fail* (str "[Analyser Error] Module doesn't exist: " module)))))) @@ -203,7 +198,7 @@ (defn declare-macro [module name] (fn [state] - (if-let [$module (->> state (&/$get-modules) (&/|get module) ($get-defs))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))] (if-let [$def (&/|get name $module)] (|case $def [exported? (&/$ValueD ?type _)] @@ -213,15 +208,15 @@ (.getField &/datum-field) (.get nil))]] (fn [state*] - (return* (&/$update-modules - (fn [$modules] - (&/|update module - (fn [m] - ($update-defs - #(&/|put name (&/P exported? (&/S &/$MacroD macro)) %) - m)) - $modules)) - state*) + (return* (&/update$ &/$modules + (fn [$modules] + (&/|update module + (fn [m] + (&/update$ $defs + #(&/|put name (&/T exported? (&/V &/$MacroD macro)) %) + m)) + $modules)) + state*) nil))) state) @@ -235,21 +230,21 @@ (defn export [module name] (fn [state] - (|case (&/$get-envs state) + (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) - (if-let [$def (->> state (&/$get-modules) (&/|get module) ($get-defs) (&/|get name))] + (if-let [$def (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs) (&/|get name))] (|case $def [true _] (fail* (str "[Analyser Error] Definition has already been exported: " module ";" name)) [false ?data] (return* (->> state - (&/$update-modules (fn [ms] - (&/|update module (fn [m] - ($update-defs - #(&/|put name (&/P true ?data) %) - m)) - ms)))) + (&/update$ &/$modules (fn [ms] + (&/|update module (fn [m] + (&/update$ $defs + #(&/|put name (&/T true ?data) %) + m)) + ms)))) nil)) (fail* (str "[Analyser Error] Can't export an inexistent definition: " (str module &/+name-separator+ name)))) @@ -265,61 +260,61 @@ (do ;; (prn 'defs k ?exported?) (|case ?def (&/$AliasD ?r-module ?r-name) - ($$ &/P ?exported? k (str "A" ?r-module ";" ?r-name)) + (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) (&/$MacroD _) - ($$ &/P ?exported? k "M") + (&/T ?exported? k "M") (&/$TypeD _) - ($$ &/P ?exported? k "T") + (&/T ?exported? k "T") _ - ($$ &/P ?exported? k "V"))))) - (->> state (&/$get-modules) (&/|get module) ($get-defs))))))) + (&/T ?exported? k "V"))))) + (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))))))) (def imports (|do [module &/get-module-name] (fn [state] - (return* state (->> state (&/$get-modules) (&/|get module) ($get-imports)))))) + (return* state (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $imports)))))) (defn create-module [name] "(-> Text (Lux (,)))" (fn [state] - (return* (&/$update-modules #(&/|put name +init+ %) state) nil))) + (return* (&/update$ &/$modules #(&/|put name +init+ %) state) nil))) (defn enter-module [name] "(-> Text (Lux (,)))" (fn [state] (return* (->> state - (&/$update-modules #(&/|put name +init+ %)) - (&/$set-envs (&/|list (&/env name)))) + (&/update$ &/$modules #(&/|put name +init+ %)) + (&/set$ &/$envs (&/|list (&/env name)))) nil))) -(do-template [<name> <getter> <type>] +(do-template [<name> <tag> <type>] (defn <name> [module] <type> (fn [state] - (if-let [=module (->> state (&/$get-modules) (&/|get module))] - (return* state (<getter> =module)) + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (return* state (&/get$ <tag> =module)) (fail* (str "[Lux Error] Unknown module: " module))) )) - tags-by-module $get-tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" - types-by-module $get-types "(-> Text (Lux (List (, Text (, (List Text) Type)))))" + tags-by-module $tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" + types-by-module $types "(-> Text (Lux (List (, Text (, (List Text) Type)))))" ) (defn ensure-undeclared-tags [module tags] (|do [tags-table (tags-by-module module) _ (&/map% (fn [tag] (if (&/|get tag tags-table) - (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/P module tag)))) + (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T module tag)))) (return nil))) tags)] (return nil))) (defn ensure-undeclared-type [module name] (|do [types-table (types-by-module module) - _ (&/assert! (nil? (&/|get name types-table)) (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/P module name))))] + _ (&/assert! (nil? (&/|get name types-table)) (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/T module name))))] (return nil))) (defn declare-tags [module tag-names type] @@ -332,34 +327,37 @@ (str "[Module Error] Can't define tags for a type belonging to a foreign module: " (&/ident->text type-name))) _ (ensure-undeclared-type _module _name)] (fn [state] - (if-let [=module (->> state (&/$get-modules) (&/|get module))] - (let [tags (&/|map (fn [tag-name] (&/P module tag-name)) tag-names)] - (return* (&/$update-modules - (fn [=modules] - (&/|update module - #(->> % - ($set-tags (&/fold (fn [table idx+tag-name] - (|let [[idx tag-name] idx+tag-name] - (&/|put tag-name ($$ &/P idx tags type) table))) - ($get-tags %) - (&/enumerate tag-names))) - ($update-types (partial &/|put _name (&/P tags type)))) - =modules)) - state) + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (let [tags (&/|map (fn [tag-name] (&/T module tag-name)) tag-names)] + (return* (&/update$ &/$modules + (fn [=modules] + (&/|update module + #(->> % + (&/set$ $tags (&/fold (fn [table idx+tag-name] + (|let [[idx tag-name] idx+tag-name] + (&/|put tag-name (&/T idx tags type) table))) + (&/get$ $tags %) + (&/enumerate tag-names))) + (&/update$ $types (partial &/|put _name (&/T tags type)))) + =modules)) + state) nil)) (fail* (str "[Lux Error] Unknown module: " module)))))) -(do-template [<name> <member> <type>] - (defn <name> [module tag-name] - <type> - (fn [state] - (if-let [=module (->> state (&/$get-modules) (&/|get module))] - (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))] - (|let [[idx tags type] idx+tags] - (return* state <member>)) - (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name))))) - (fail* (str "[Module Error] Unknown module: " module))))) - - tag-index idx "(-> Text Text (Lux Int))" - tag-group tags "(-> Text Text (Lux (List Ident)))" - ) +(defn tag-index [module tag-name] + "(-> Text Text (Lux Int))" + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] + (return* state (aget idx+tags 0)) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Module Error] Unknown module: " module))))) + +(defn tag-group [module tag-name] + "(-> Text Text (Lux (List Ident)))" + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] + (return* state (aget idx+tags 1)) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Module Error] Unknown module: " module))))) diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj index 96c988544..2b4b7e095 100644 --- a/src/lux/analyser/record.clj +++ b/src/lux/analyser/record.clj @@ -13,6 +13,122 @@ (lux.analyser [base :as &&] [module :as &&module]))) +;; [Tags] +(deftags "" + "bool" + "int" + "real" + "char" + "text" + "variant" + "tuple" + "apply" + "case" + "lambda" + "ann" + "def" + "declare-macro" + "var" + "captured" + + "jvm-getstatic" + "jvm-getfield" + "jvm-putstatic" + "jvm-putfield" + "jvm-invokestatic" + "jvm-instanceof" + "jvm-invokevirtual" + "jvm-invokeinterface" + "jvm-invokespecial" + "jvm-null?" + "jvm-null" + "jvm-new" + "jvm-new-array" + "jvm-aastore" + "jvm-aaload" + "jvm-class" + "jvm-interface" + "jvm-try" + "jvm-throw" + "jvm-monitorenter" + "jvm-monitorexit" + "jvm-program" + + "jvm-iadd" + "jvm-isub" + "jvm-imul" + "jvm-idiv" + "jvm-irem" + "jvm-ieq" + "jvm-ilt" + "jvm-igt" + + "jvm-ceq" + "jvm-clt" + "jvm-cgt" + + "jvm-ladd" + "jvm-lsub" + "jvm-lmul" + "jvm-ldiv" + "jvm-lrem" + "jvm-leq" + "jvm-llt" + "jvm-lgt" + + "jvm-fadd" + "jvm-fsub" + "jvm-fmul" + "jvm-fdiv" + "jvm-frem" + "jvm-feq" + "jvm-flt" + "jvm-fgt" + + "jvm-dadd" + "jvm-dsub" + "jvm-dmul" + "jvm-ddiv" + "jvm-drem" + "jvm-deq" + "jvm-dlt" + "jvm-dgt" + + "jvm-d2f" + "jvm-d2i" + "jvm-d2l" + + "jvm-f2d" + "jvm-f2i" + "jvm-f2l" + + "jvm-i2b" + "jvm-i2c" + "jvm-i2d" + "jvm-i2f" + "jvm-i2l" + "jvm-i2s" + + "jvm-l2d" + "jvm-l2f" + "jvm-l2i" + + "jvm-iand" + "jvm-ior" + "jvm-ixor" + "jvm-ishl" + "jvm-ishr" + "jvm-iushr" + + "jvm-land" + "jvm-lor" + "jvm-lxor" + "jvm-lshl" + "jvm-lshr" + "jvm-lushr" + + ) + ;; [Exports] (defn order-record [pairs] "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))" @@ -20,7 +136,7 @@ (&/$Nil) (return (&/|list)) - (&/$Cons [[_ (&/$TagS tag1)] _] _) + (&/$Cons [(&/$Meta _ (&/$TagS tag1)) _] _) (|do [[module name] (&&/resolved-ident tag1)] (&&module/tag-group module name)) @@ -28,9 +144,9 @@ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) =pairs (&/map% (fn [kv] (|case kv - [[_ (&/$TagS k)] v] + [(&/$Meta _ (&/$TagS k)) v] (|do [=k (&&/resolved-ident k)] - (return (&/P (&/ident->text =k) v))) + (return (&/T (&/ident->text =k) v))) _ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) diff --git a/src/lux/base.clj b/src/lux/base.clj index d261145ae..6247524af 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -11,157 +11,99 @@ [clojure.core.match :as M :refer [matchv]] clojure.core.match.array)) -;; [ADTs] -(let [array-class (class (to-array []))] - (defn adt->text [adt] - (if (= array-class (class adt)) - (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]") - (pr-str adt)))) - -(defmacro deftags [names] - (assert (vector? names)) +;; [Tags] +(defmacro deftags [prefix & names] `(do ~@(for [[name idx] (map vector names (range (count names)))] - `(def ~(symbol (str "$" name)) (int ~idx))))) - -(defn ^:private unfold-accesses - ([elems] - (unfold-accesses 1 (count elems) elems)) - ([begin end elems] - (if (= begin end) - (list elems) - (cons (take begin elems) - (unfold-accesses (inc begin) end elems))))) - -(defmacro defrtags [tags] - (let [num-tags (count tags) - normals (butlast tags) - special (last tags) - tags+locs (cons [special (repeat (dec num-tags) 1)] - (map #(vector %1 (concat (repeat %2 1) [0])) - normals - (range num-tags)))] - `(do ~@(for [[tag loc] tags+locs - :let [getter (symbol (str "$get-" tag)) - setter (symbol (str "$set-" tag)) - updater (symbol (str "$update-" tag)) - record (gensym "record") - value (gensym "value")]] - `(do (defn ~getter [~record] - ;; (if (= '~'$get-source '~getter) - ;; (prn '~getter '~loc ~record (aget ~record ~@loc)) - ;; (prn '~getter '~loc ~record (adt->text (aget ~record ~@loc)))) - (aget ~record ~@loc)) - (defn ~setter [~value ~record] - ;; (if (= '~'$set-source '~setter) - ;; (prn '~setter '_1 '~loc ~record) - ;; (prn '~setter '_2 '~loc ~record (adt->text ~value))) - ;; (doto record# - ;; (aset ~@loc value#)) - ;; (doto record# - ;; (aset 1 (doto (aget record# 1) - ;; (aset 1 ...)))) - ~(reduce (fn [inner indices] - `(doto (aclone ~(if (= 1 (count indices)) - record - `(aget ~record ~@(butlast indices)))) - (aset ~(last indices) ~inner))) - value - (reverse (unfold-accesses loc))) - ) - (defn ~updater [f# ~record] - ;; (prn '~updater '~loc ~record) - ;; (doto record# - ;; (aset ~@loc (f# (aget record# ~@loc)))) - (~setter (f# (~getter ~record)) ~record))))) - )) + `(def ~(symbol (str "$" name)) ~idx)))) ;; List -(deftags - ["Nil" - "Cons"]) +(deftags "" + "Nil" + "Cons") ;; Maybe -(deftags - ["None" - "Some"]) +(deftags "" + "None" + "Some") + +;; Meta +(deftags "" + "Meta") ;; Either -(deftags - ["Left" - "Right"]) +(deftags "" + "Left" + "Right") ;; AST -(deftags - ["BoolS" - "IntS" - "RealS" - "CharS" - "TextS" - "SymbolS" - "TagS" - "FormS" - "TupleS" - "RecordS"]) +(deftags "" + "BoolS" + "IntS" + "RealS" + "CharS" + "TextS" + "SymbolS" + "TagS" + "FormS" + "TupleS" + "RecordS") ;; Type -(deftags - ["VoidT" - "UnitT" - "SumT" - "ProdT" - "DataT" - "LambdaT" - "BoundT" - "VarT" - "ExT" - "AllT" - "AppT" - "NamedT"]) +(deftags "" + "DataT" + "VariantT" + "TupleT" + "LambdaT" + "BoundT" + "VarT" + "ExT" + "AllT" + "AppT" + "NamedT") ;; Vars -(deftags - ["Local" - "Global"]) +(deftags "lux;" + "Local" + "Global") ;; Definitions -(deftags - ["ValueD" - "TypeD" - "MacroD" - "AliasD"]) +(deftags "lux;" + "ValueD" + "TypeD" + "MacroD" + "AliasD") ;; Binding -(defrtags - ["counter" - "mappings"]) +(deftags "" + "counter" + "mappings") ;; Env -(defrtags - ["name" - "inner-closures" - "locals" - "closure"]) +(deftags "" + "name" + "inner-closures" + "locals" + "closure") ;; Host -(defrtags - ["writer" - "loader" - "classes"]) +(deftags "" + "writer" + "loader" + "classes") ;; Compiler -(defrtags - ["source" - "cursor" - "modules" - "envs" - "type-vars" - "expected" - "seed" - "eval?" - "host"]) +(deftags "" + "source" + "cursor" + "modules" + "envs" + "type-vars" + "expected" + "seed" + "eval?" + "host") ;; [Exports] -;; Class fields (def datum-field "_datum") (def meta-field "_meta") (def name-field "_name") @@ -175,59 +117,55 @@ (def +name-separator+ ";") -(def prelude-name "lux") - -(defmacro $$ [op & args] - (assert (> (count args) 1) - (prn-str '$$ op args)) - (let [[last & others] (reverse args)] - (reduce (fn [right left] `(~op ~left ~right)) - last - others))) +(defn T [& elems] + (to-array elems)) -(defn S [^Long tag value] +(defn V [^Long tag value] (to-array [tag value])) -(defn P [left right] - (to-array [left right])) - ;; Constructors -(def None$ (S $None nil)) -(defn Some$ [x] (S $Some x)) +(def None$ (V $None nil)) +(defn Some$ [x] (V $Some x)) + +(def Nil$ (V $Nil nil)) +(defn Cons$ [h t] (V $Cons (T h t))) -(def Nil$ (S $Nil nil)) -(defn Cons$ [h t] (S $Cons (P h t))) +(defn get$ [slot ^objects record] + (aget record slot)) + +(defn set$ [slot value ^objects record] + (let [record* (aclone record) + size (alength record)] + (aset record* slot value) + record*)) + +(defmacro update$ [slot f record] + `(let [record# ~record] + (set$ ~slot (~f (get$ ~slot record#)) + record#))) (defn fail* [message] - (S $Left message)) + (V $Left message)) (defn return* [state value] - (S $Right (P state value))) - -(defn ^:private transform-tuple-pattern [pattern] - (case (count pattern) - 0 '_ - 1 (assert false "Can't have singleton tuples.") - 2 pattern - ;; else - (let [[last & others] (reverse pattern)] - (reduce (fn [r l] [l r]) last others)))) + (V $Right (T state value))) (defn transform-pattern [pattern] - (cond (vector? pattern) (transform-tuple-pattern (mapv transform-pattern pattern)) + (cond (vector? pattern) (mapv transform-pattern pattern) (seq? pattern) (let [parts (mapv transform-pattern (rest pattern))] (vec (cons (eval (first pattern)) (list (case (count parts) + 0 '_ 1 (first parts) ;; else - (transform-tuple-pattern parts)))))) + `[~@parts]))))) :else pattern )) (defmacro |case [value & branches] (assert (= 0 (mod (count branches) 2))) (let [value* (if (vector? value) - [`($$ P ~@value)] + [`(T ~@value)] [value])] `(matchv ::M/objects ~value* ~@(mapcat (fn [[pattern body]] @@ -245,8 +183,8 @@ (defmacro |list [& elems] (reduce (fn [tail head] - `(Cons$ ~head ~tail)) - `Nil$ + `(V $Cons (T ~head ~tail))) + `(V $Nil nil) (reverse elems))) (defmacro |table [& elems] @@ -266,18 +204,17 @@ (|get slot table*)))) (defn |put [slot value table] - ;; (prn '|put slot (adt->text value) (adt->text table)) (|case table ($Nil) - (Cons$ (P slot value) Nil$) + (V $Cons (T (T slot value) (V $Nil nil))) ($Cons [k v] table*) (if (.equals ^Object k slot) - (Cons$ (P slot value) table*) - (Cons$ (P k v) (|put slot value table*))) + (V $Cons (T (T slot value) table*)) + (V $Cons (T (T k v) (|put slot value table*)))) ;; _ - ;; (assert false (prn-str '|put slot (adt->text value) (adt->text table))) + ;; (assert false (prn-str '|put (aget table 0))) )) (defn |remove [slot table] @@ -288,7 +225,7 @@ ($Cons [k v] table*) (if (.equals ^Object k slot) table* - (Cons$ (P k v) (|remove slot table*))))) + (V $Cons (T (T k v) (|remove slot table*)))))) (defn |update [k f table] (|case table @@ -297,8 +234,8 @@ ($Cons [k* v] table*) (if (.equals ^Object k k*) - (Cons$ (P k* (f v)) table*) - (Cons$ (P k* v) (|update k f table*))))) + (V $Cons (T (T k* (f v)) table*)) + (V $Cons (T (T k* v) (|update k f table*)))))) (defn |head [xs] (|case xs @@ -319,11 +256,11 @@ ;; [Resources/Monads] (defn fail [message] (fn [_] - (S $Left message))) + (V $Left message))) (defn return [value] (fn [state] - (S $Right (P state value)))) + (V $Right (T state value)))) (defn bind [m-value step] (fn [state] @@ -351,13 +288,22 @@ (reverse (partition 2 steps)))) ;; [Resources/Combinators] +(defn |cons [head tail] + (V $Cons (T head tail))) + (defn |++ [xs ys] (|case xs ($Nil) ys ($Cons x xs*) - (Cons$ x (|++ xs* ys)))) + (V $Cons (T x (|++ xs* ys))))) + +(let [array-class (class (to-array []))] + (defn adt->text [adt] + (if (= array-class (class adt)) + (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]") + (pr-str adt)))) (defn |map [f xs] (|case xs @@ -365,7 +311,7 @@ xs ($Cons x xs*) - (Cons$ (f x) (|map f xs*)) + (V $Cons (T (f x) (|map f xs*))) _ (assert false (prn-str '|map f (adt->text xs))) @@ -386,7 +332,7 @@ ($Cons x xs*) (if (p x) - (Cons$ x (|filter p xs*)) + (V $Cons (T x (|filter p xs*))) (|filter p xs*)))) (defn flat-map [f xs] @@ -400,13 +346,13 @@ (defn |split-with [p xs] (|case xs ($Nil) - (P xs xs) + (T xs xs) ($Cons x xs*) (if (p x) (|let [[pre post] (|split-with p xs*)] - (P (Cons$ x pre) post)) - (P Nil$ xs)))) + (T (|cons x pre) post)) + (T (V $Nil nil) xs)))) (defn |contains? [k table] (|case table @@ -415,10 +361,7 @@ ($Cons [k* _] table*) (or (.equals ^Object k k*) - (|contains? k table*)) - - _ - (assert false (prn-str '|contains? k (adt->text table))))) + (|contains? k table*)))) (defn fold [f init xs] (|case xs @@ -443,15 +386,15 @@ (|list init) ($Cons x xs*) - (Cons$ init (folds f (f init x) xs*)))) + (|cons init (folds f (f init x) xs*)))) (defn |length [xs] (fold (fn [acc _] (inc acc)) 0 xs)) (let [|range* (fn |range* [from to] (if (< from to) - (Cons$ from (|range* (inc from) to)) - Nil$))] + (V $Cons (T from (|range* (inc from) to))) + (V $Nil nil)))] (defn |range [n] (|range* 0 n))) @@ -466,10 +409,10 @@ (defn zip2 [xs ys] (|case [xs ys] [($Cons x xs*) ($Cons y ys*)] - (Cons$ (P x y) (zip2 xs* ys*)) + (V $Cons (T (T x y) (zip2 xs* ys*))) [_ _] - Nil$)) + (V $Nil nil))) (defn |keys [plist] (|case plist @@ -477,7 +420,7 @@ (|list) ($Cons [k v] plist*) - (Cons$ k (|keys plist*)))) + (|cons k (|keys plist*)))) (defn |vals [plist] (|case plist @@ -485,7 +428,7 @@ (|list) ($Cons [k v] plist*) - (Cons$ v (|vals plist*)))) + (|cons v (|vals plist*)))) (defn |interpose [sep xs] (|case xs @@ -496,7 +439,7 @@ xs ($Cons x xs*) - (Cons$ x (Cons$ sep (|interpose sep xs*))))) + (V $Cons (T x (V $Cons (T sep (|interpose sep xs*))))))) (do-template [<name> <joiner>] (defn <name> [f xs] @@ -509,23 +452,23 @@ ys (<name> f xs*)] (return (<joiner> y ys))))) - map% Cons$ + map% |cons flat-map% |++) (defn list-join [xss] - (fold |++ Nil$ xss)) + (fold |++ (V $Nil nil) xss)) (defn |as-pairs [xs] (|case xs ($Cons x ($Cons y xs*)) - (Cons$ (P x y) (|as-pairs xs*)) + (V $Cons (T (T x y) (|as-pairs xs*))) _ - Nil$)) + (V $Nil nil))) (defn |reverse [xs] (fold (fn [tail head] - (Cons$ head tail)) + (|cons head tail)) (|list) xs)) @@ -561,7 +504,7 @@ (defn repeat% [monad] (try-all% (|list (|do [head monad tail (repeat% monad)] - (return (Cons$ head tail))) + (return (|cons head tail))) (return (|list))))) (defn exhaust% [step] @@ -608,28 +551,28 @@ (def loader (fn [state] - (return* state (->> state $get-host ($get-loader))))) + (return* state (->> state (get$ $host) (get$ $loader))))) (def classes (fn [state] - (return* state (->> state $get-host ($get-classes))))) + (return* state (->> state (get$ $host) (get$ $classes))))) (def +init-bindings+ - (P ;; "lux;counter" + (T ;; "lux;counter" 0 ;; "lux;mappings" (|table))) (defn env [name] - ($$ P ;; "lux;name" - name - ;; "lux;inner-closures" - 0 - ;; "lux;locals" - +init-bindings+ - ;; "lux;closure" - +init-bindings+ - )) + (T ;; "lux;name" + name + ;; "lux;inner-closures" + 0 + ;; "lux;locals" + +init-bindings+ + ;; "lux;closure" + +init-bindings+ + )) (let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String (class (byte-array [])) @@ -651,41 +594,41 @@ (defn host [_] (let [store (atom {})] - ($$ P ;; "lux;writer" - None$ - ;; "lux;loader" - (memory-class-loader store) - ;; "lux;classes" - store))) + (T ;; "lux;writer" + (V $None nil) + ;; "lux;loader" + (memory-class-loader store) + ;; "lux;classes" + store))) (defn init-state [_] - ($$ P ;; "lux;source" - None$ - ;; "lux;cursor" - ($$ P "" -1 -1) - ;; "lux;modules" - (|table) - ;; "lux;envs" - (|list) - ;; "lux;types" - +init-bindings+ - ;; "lux;expected" - (S $VoidT nil) - ;; "lux;seed" - 0 - ;; "lux;eval?" - false - ;; "lux;host" - (host nil) - )) + (T ;; "lux;source" + (V $None nil) + ;; "lux;cursor" + (T "" -1 -1) + ;; "lux;modules" + (|table) + ;; "lux;envs" + (|list) + ;; "lux;types" + +init-bindings+ + ;; "lux;expected" + (V $VariantT (|list)) + ;; "lux;seed" + 0 + ;; "lux;eval?" + false + ;; "lux;host" + (host nil) + )) (defn save-module [body] (fn [state] (|case (body state) ($Right state* output) (return* (->> state* - ($set-envs ($get-envs state)) - ($set-source ($get-source state))) + (set$ $envs (get$ $envs state)) + (set$ $source (get$ $source state))) output) ($Left msg) @@ -693,20 +636,20 @@ (defn with-eval [body] (fn [state] - (|case (body ($set-eval? true state)) + (|case (body (set$ $eval? true state)) ($Right state* output) - (return* ($set-eval? ($get-eval? state) state*) output) + (return* (set$ $eval? (get$ $eval? state) state*) output) ($Left msg) (fail* msg)))) (def get-eval (fn [state] - (return* state ($get-eval? state)))) + (return* state (get$ $eval? state)))) (def get-writer (fn [state] - (let [writer* (->> state ($get-host) ($get-writer))] + (let [writer* (->> state (get$ $host) (get$ $writer))] (|case writer* ($Some datum) (return* state datum) @@ -716,15 +659,15 @@ (def get-top-local-env (fn [state] - (try (let [top (|head ($get-envs state))] + (try (let [top (|head (get$ $envs state))] (return* state top)) (catch Throwable _ (fail* "No local environment."))))) (def gen-id (fn [state] - (let [seed ($get-seed state)] - (return* ($set-seed (inc seed) state) seed)))) + (let [seed (get$ $seed state)] + (return* (set$ $seed (inc seed) state) seed)))) (defn ->seq [xs] (|case xs @@ -737,26 +680,26 @@ (defn ->list [seq] (if (empty? seq) (|list) - (Cons$ (first seq) (->list (rest seq))))) + (|cons (first seq) (->list (rest seq))))) (defn |repeat [n x] (if (> n 0) - (Cons$ x (|repeat (dec n) x)) + (|cons x (|repeat (dec n) x)) (|list))) (def get-module-name (fn [state] - (|case (|reverse ($get-envs state)) + (|case (|reverse (get$ $envs state)) ($Nil) (fail* "[Analyser Error] Can't get the module-name without a module.") ($Cons ?global _) - (return* state ($get-name ?global))))) + (return* state (get$ $name ?global))))) (defn find-module [name] "(-> Text (Lux (Module Compiler)))" (fn [state] - (if-let [module (|get name ($get-modules state))] + (if-let [module (|get name (get$ $modules state))] (return* state module) (fail* (str "Unknown module: " name))))) @@ -767,10 +710,10 @@ (defn with-scope [name body] (fn [state] - (let [output (body ($update-envs #(Cons$ (env name) %) state))] + (let [output (body (update$ $envs #(|cons (env name) %) state))] (|case output ($Right state* datum) - (return* ($update-envs |tail state*) datum) + (return* (update$ $envs |tail state*) datum) _ output)))) @@ -780,24 +723,23 @@ (defn with-closure [body] (|do [closure-name (|do [top get-top-local-env] - (return (->> top ($get-inner-closures) str)))] + (return (->> top (get$ $inner-closures) str)))] (fn [state] (let [body* (with-scope closure-name body)] - (run-state body* ($update-envs #(Cons$ ($update-inner-closures inc (|head %)) - (|tail %)) - state)))))) + (run-state body* (update$ $envs #(|cons (update$ $inner-closures inc (|head %)) + (|tail %)) + state)))))) (def get-scope-name (fn [state] - (return* state (->> state ($get-envs) (|map #($get-name %)) |reverse)))) + (return* state (->> state (get$ $envs) (|map #(get$ $name %)) |reverse)))) (defn with-writer [writer body] (fn [state] - ;; (prn 'with-writer writer body) - (let [output (body ($update-host #($set-writer (Some$ writer) %) state))] + (let [output (body (update$ $host #(set$ $writer (V $Some writer) %) state))] (|case output ($Right ?state ?value) - (return* ($update-host #($set-writer (->> state ($get-host) ($get-writer)) %) ?state) + (return* (update$ $host #(set$ $writer (->> state (get$ $host) (get$ $writer)) %) ?state) ?value) _ @@ -806,11 +748,10 @@ (defn with-expected-type [type body] "(All [a] (-> Type (Lux a)))" (fn [state] - ;; (prn 'with-expected-type type state) - (let [output (body ($set-expected type state))] + (let [output (body (set$ $expected type state))] (|case output ($Right ?state ?value) - (return* ($set-expected ($get-expected state) ?state) + (return* (set$ $expected (get$ $expected state) ?state) ?value) _ @@ -818,20 +759,14 @@ (defn with-cursor [^objects cursor body] "(All [a] (-> Cursor (Lux a)))" - ;; (prn 'with-cursor/_0 (adt->text cursor)) (if (= "" (aget cursor 0)) body (fn [state] - (let [;; _ (prn 'with-cursor/_1 cursor) - state* ($set-cursor cursor state) - ;; _ (prn 'with-cursor/_2 state*) - output (body state*)] + (let [output (body (set$ $cursor cursor state))] (|case output ($Right ?state ?value) - (let [?state* ($set-cursor ($get-cursor state) ?state)] - ;; (prn 'with-cursor/_3 ?state*) - (return* ?state* - ?value)) + (return* (set$ $cursor (get$ $cursor state) ?state) + ?value) _ output))))) @@ -839,40 +774,40 @@ (defn show-ast [ast] ;; (prn 'show-ast/GOOD (aget ast 0) (aget ast 1 1 0)) (|case ast - [_ ($BoolS ?value)] + ($Meta _ ($BoolS ?value)) (pr-str ?value) - [_ ($IntS ?value)] + ($Meta _ ($IntS ?value)) (pr-str ?value) - [_ ($RealS ?value)] + ($Meta _ ($RealS ?value)) (pr-str ?value) - [_ ($CharS ?value)] + ($Meta _ ($CharS ?value)) (pr-str ?value) - [_ ($TextS ?value)] + ($Meta _ ($TextS ?value)) (str "\"" ?value "\"") - [_ ($TagS ?module ?tag)] + ($Meta _ ($TagS ?module ?tag)) (str "#" ?module ";" ?tag) - [_ ($SymbolS ?module ?ident)] + ($Meta _ ($SymbolS ?module ?ident)) (if (.equals "" ?module) ?ident (str ?module ";" ?ident)) - [_ ($TupleS ?elems)] + ($Meta _ ($TupleS ?elems)) (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") - [_ ($RecordS ?elems)] + ($Meta _ ($RecordS ?elems)) (str "{" (->> ?elems (|map (fn [elem] (|let [[k v] elem] (str (show-ast k) " " (show-ast v))))) (|interpose " ") (fold str "")) "}") - [_ ($FormS ?elems)] + ($Meta _ ($FormS ?elems)) (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") _ @@ -900,10 +835,10 @@ [($Cons x xs*) ($Cons y ys*)] (|do [z (f x y) zs (map2% f xs* ys*)] - (return (Cons$ z zs))) + (return (|cons z zs))) [($Nil) ($Nil)] - (return Nil$) + (return (V $Nil nil)) [_ _] (fail "Lists don't match in size."))) @@ -911,10 +846,10 @@ (defn map2 [f xs ys] (|case [xs ys] [($Cons x xs*) ($Cons y ys*)] - (Cons$ (f x y) (map2 f xs* ys*)) + (|cons (f x y) (map2 f xs* ys*)) [_ _] - Nil$)) + (V $Nil nil))) (defn fold2 [f init xs ys] (|case [xs ys] @@ -932,8 +867,8 @@ "(All [a] (-> Int (List a) (List (, Int a))))" (|case xs ($Cons x xs*) - (Cons$ (P idx x) - (enumerate* (inc idx) xs*)) + (V $Cons (T (T idx x) + (enumerate* (inc idx) xs*))) ($Nil) xs @@ -946,7 +881,7 @@ (def modules "(Lux (List Text))" (fn [state] - (return* state (|keys ($get-modules state))))) + (return* state (|keys (get$ $modules state))))) (defn when% [test body] "(-> Bool (Lux (,)) (Lux (,)))" @@ -960,23 +895,23 @@ (|case xs ($Cons x xs*) (cond (< idx 0) - None$ + (V $None nil) (= idx 0) - (Some$ x) + (V $Some x) :else ;; > 1 (|at (dec idx) xs*)) ($Nil) - None$ + (V $None nil) )) (defn normalize [ident] "(-> Ident (Lux Ident))" (|case ident ["" name] (|do [module get-module-name] - (return (P module name))) + (return (T module name))) _ (return ident))) (defn ident= [x y] @@ -988,24 +923,12 @@ (defn |list-put [idx val xs] (|case xs ($Nil) - None$ + (V $None nil) ($Cons x xs*) (if (= idx 0) - (Some$ (Cons$ val xs*)) + (V $Some (V $Cons (T val xs*))) (|case (|list-put (dec idx) val xs*) - ($None) None$ - ($Some xs**) (Some$ (Cons$ x xs**))) + ($None) (V $None nil) + ($Some xs**) (V $Some (V $Cons (T x xs**)))) ))) - -(defn ensure-1 [m-value] - (|do [output m-value] - (|case output - ($Cons x ($Nil)) - (return x) - - _ - (fail "[Error] Can't expand to other than 1 element.")))) - -(defn cursor$ [file-name line-num column-num] - ($$ P file-name line-num column-num)) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 4315ea75d..79d2c84f8 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -39,12 +39,8 @@ ;; [Utils/Compilers] (defn ^:private compile-expression [syntax] - ;; (prn 'compile-expression (&/adt->text syntax)) (|let [[?form ?type] syntax] (|case ?form - (&a/$unit) - (&&lux/compile-unit compile-expression ?type) - (&a/$bool ?value) (&&lux/compile-bool compile-expression ?type ?value) @@ -60,11 +56,8 @@ (&a/$text ?value) (&&lux/compile-text compile-expression ?type ?value) - (&a/$prod left right) - (&&lux/compile-prod compile-expression ?type left right) - - (&a/$sum tag value) - (&&lux/compile-sum compile-expression ?type tag value) + (&a/$tuple ?elems) + (&&lux/compile-tuple compile-expression ?type ?elems) (&a/$var (&/$Local ?idx)) (&&lux/compile-local compile-expression ?type ?idx) @@ -78,6 +71,9 @@ (&a/$apply ?fn ?args) (&&lux/compile-apply compile-expression ?type ?fn ?args) + (&a/$variant ?tag ?members) + (&&lux/compile-variant compile-expression ?type ?tag ?members) + (&a/$case ?value ?match) (&&case/compile-case compile-expression ?type ?value ?match) @@ -428,7 +424,7 @@ (fn [state] (|case ((&/with-writer =class (&/exhaust% compiler-step)) - (&/$set-source (&reader/from file-name file-content) state)) + (&/set$ &/$source (&reader/from file-name file-content) state)) (&/$Right ?state _) (&/run-state (|do [defs &a-module/defs imports &a-module/imports @@ -475,7 +471,7 @@ ;; [Resources] (defn compile-program [program-module] (init!) - (|case ((&/map% compile-module (&/|list &/prelude-name program-module)) (&/init-state nil)) + (|case ((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil)) (&/$Right ?state _) (do (println "Compilation complete!") (&&cache/clean ?state) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index e327d1de4..1e5f3a024 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -76,33 +76,26 @@ _ (load-class! loader real-name)]] (return nil))) -(do-template [<name> <class> <sig>] +(do-template [<name> <class> <sig> <dup>] (defn <name> [^MethodVisitor writer] (doto writer - (.visitMethodInsn Opcodes/INVOKESTATIC <class> "valueOf" (str <sig> (&host/->type-signature <class>))))) + (.visitMethodInsn Opcodes/INVOKESTATIC <class> "valueOf" (str <sig> (&host/->type-signature <class>)))) + ;; (doto writer + ;; ;; X + ;; (.visitTypeInsn Opcodes/NEW <class>) ;; XW + ;; (.visitInsn <dup>) ;; WXW + ;; (.visitInsn <dup>) ;; WWXW + ;; (.visitInsn Opcodes/POP) ;; WWX + ;; (.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>) ;; W + ;; ) + ) - wrap-boolean "java/lang/Boolean" "(Z)" - wrap-byte "java/lang/Byte" "(B)" - wrap-short "java/lang/Short" "(S)" - wrap-int "java/lang/Integer" "(I)" - wrap-long "java/lang/Long" "(J)" - wrap-float "java/lang/Float" "(F)" - wrap-double "java/lang/Double" "(D)" - wrap-char "java/lang/Character" "(C)" - ) - -(do-template [<name> <class> <sig> <method>] - (defn <name> [^MethodVisitor writer] - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST <class>) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL <class> <method> (str "()" <sig>)))) - - unwrap-boolean "java/lang/Boolean" "Z" "booleanValue" - unwrap-byte "java/lang/Byte" "B" "byteValue" - unwrap-short "java/lang/Short" "S" "shortValue" - unwrap-int "java/lang/Integer" "I" "intValue" - unwrap-long "java/lang/Long" "J" "longValue" - unwrap-float "java/lang/Float" "F" "floatValue" - unwrap-double "java/lang/Double" "D" "doubleValue" - unwrap-char "java/lang/Character" "C" "charValue" + wrap-boolean "java/lang/Boolean" "(Z)" Opcodes/DUP_X1 + wrap-byte "java/lang/Byte" "(B)" Opcodes/DUP_X1 + wrap-short "java/lang/Short" "(S)" Opcodes/DUP_X1 + wrap-int "java/lang/Integer" "(I)" Opcodes/DUP_X1 + wrap-long "java/lang/Long" "(J)" Opcodes/DUP_X2 + wrap-float "java/lang/Float" "(F)" Opcodes/DUP_X1 + wrap-double "java/lang/Double" "(D)" Opcodes/DUP_X2 + wrap-char "java/lang/Character" "(C)" Opcodes/DUP_X1 ) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 48b35c83a..dc224f52e 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -58,7 +58,7 @@ (defn clean [state] "(-> Compiler (,))" - (let [needed-modules (->> state (&/$get-modules) &/|keys &/->seq set) + (let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set) outdated? #(-> ^File % .getName (string/replace &host/module-separator "/") (->> (contains? needed-modules)) not) outdate-files (->> &&/output-dir (new File) .listFiles seq (filter outdated?)) program-file (new File &&/output-package)] @@ -120,7 +120,7 @@ ;; (prn '_group _group) (let [[_type _tags] (string/split _group (re-pattern (java.util.regex.Pattern/quote &&/type-separator)))] ;; (prn '[_type _tags] [_type _tags]) - (&/P _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator))))))))) + (&/T _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator))))))))) &/->list)))] ;; (prn 'load module defs) (|do [_ (&a-module/enter-module module) @@ -132,10 +132,10 @@ (|do [_ (case _ann "T" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) def-value (get-field &/datum-field def-class)] - (&a-module/define module _name (&/S &/$TypeD def-value) &type/Type)) + (&a-module/define module _name (&/V &/$TypeD def-value) &type/Type)) "M" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) def-value (get-field &/datum-field def-class)] - (|do [_ (&a-module/define module _name (&/S &/$ValueD (&/P &type/Macro def-value)) &type/Macro)] + (|do [_ (&a-module/define module _name (&/V &/$ValueD (&/T &type/Macro def-value)) &type/Macro)] (&a-module/declare-macro module _name))) "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 0a928a056..dd3258059 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -11,7 +11,7 @@ [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let |case $$]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -84,71 +84,63 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - (&a-case/$UnitTestAC) + (&a-case/$TupleTestAC ?members) (doto writer + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (-> (doto (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int idx)) + (.visitInsn Opcodes/AALOAD) + (compile-match test $next $sub-else) + (.visitLabel $sub-else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $else) + (.visitLabel $next)) + (->> (|let [[idx test] idx+member + $next (new Label) + $sub-else (new Label)]) + (doseq [idx+member (->> ?members &/enumerate &/->seq)]))) (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - (&a-case/$ProdTestAC left right) - (let [$post-left (new Label) - $post-right (new Label) - $pre-else (new Label)] - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD) - (compile-match left $post-left $pre-else) - (.visitLabel $post-left) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/AALOAD) - (compile-match right $post-right $pre-else) - (.visitLabel $post-right) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target) - (.visitLabel $pre-else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else))) - - (&a-case/$SumTestAC ?tag ?count ?test) - (let [$value-then (new Label) - $pre-else (new Label)] - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD) - (&&/unwrap-int) - (.visitLdcInsn (int ?tag)) - (.visitJumpInsn Opcodes/IF_ICMPNE $else) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/AALOAD) - (compile-match ?test $value-then $pre-else) - (.visitLabel $value-then) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target) - (.visitLabel $pre-else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else))) + (&a-case/$VariantTestAC ?tag ?count ?test) + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + (.visitLdcInsn ?tag) + (&&/wrap-long) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") + (.visitJumpInsn Opcodes/IFEQ $else) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD) + (-> (doto (compile-match ?test $value-then $value-else) + (.visitLabel $value-then) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $target) + (.visitLabel $value-else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $else)) + (->> (let [$value-then (new Label) + $value-else (new Label)])))) ))) (defn ^:private separate-bodies [patterns] (|let [[_ mappings patterns*] (&/fold (fn [$id+mappings+=matches pattern+body] (|let [[$id mappings =matches] $id+mappings+=matches [pattern body] pattern+body] - ($$ &/P (inc $id) (&/|put $id body mappings) (&/|put $id pattern =matches)))) - ($$ &/P 0 (&/|table) (&/|table)) + (&/T (inc $id) (&/|put $id body mappings) (&/|put $id pattern =matches)))) + (&/T 0 (&/|table) (&/|table)) patterns)] - (&/P mappings (&/|reverse patterns*)))) + (&/T mappings (&/|reverse patterns*)))) (defn ^:private compile-pattern-matching [^MethodVisitor writer compile mappings patterns $end] (let [entries (&/|map (fn [?branch+?body] (|let [[?branch ?body] ?branch+?body label (new Label)] - (&/P (&/P ?branch label) - (&/P label ?body)))) + (&/T (&/T ?branch label) + (&/T label ?body)))) mappings) mappings* (&/|map &/|first entries)] (doto writer diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index ead44085a..26ef73cb7 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -52,7 +52,7 @@ char-class "java.lang.Character"] (defn prepare-return! [^MethodVisitor *writer* *type*] (|case *type* - (&/$UnitT) + (&/$TupleT (&/$Nil)) (.visitInsn *writer* Opcodes/ACONST_NULL) (&/$DataT "boolean") @@ -421,14 +421,14 @@ $catch-finally (new Label) compile-finally (|case ?finally (&/$Some ?finally*) (|do [_ (return nil) - _ (compile ?finally*) - :let [_ (doto *writer* - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $end))]] - (return nil)) + _ (compile ?finally*) + :let [_ (doto *writer* + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $end))]] + (return nil)) (&/$None) (|do [_ (return nil) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] - (return nil))) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] + (return nil))) catch-boundaries (&/|map (fn [[?ex-class ?ex-idx ?catch-body]] [?ex-class (new Label) (new Label)]) ?catches) _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries) @@ -455,12 +455,12 @@ :let [_ (.visitLabel *writer* $catch-finally)] _ (|case ?finally (&/$Some ?finally*) (|do [_ (compile ?finally*) - :let [_ (.visitInsn *writer* Opcodes/POP)] - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil)) + :let [_ (.visitInsn *writer* Opcodes/POP)] + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil)) (&/$None) (|do [_ (return nil) - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil))) + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil))) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] :let [_ (.visitLabel *writer* $end)]] (return nil))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 10ee40839..83e294c1a 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -28,43 +28,27 @@ ClassWriter MethodVisitor))) -;; [Utils] -(defn ^:private array-of [^MethodVisitor *writer* type-name size] - (do (doto *writer* - (.visitLdcInsn (int size)) - (.visitTypeInsn Opcodes/ANEWARRAY type-name)) - (return nil))) - -(defn ^:private store-at [^MethodVisitor *writer* compile idx value] - (|do [:let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)))] - _ (compile value) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return nil))) - ;; [Exports] -(defn compile-unit [compile *type*] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] - (return nil))) - (defn compile-bool [compile *type* ?value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]] (return nil))) -(do-template [<name> <wrapper>] +(do-template [<name> <class> <sig> <caster>] (defn <name> [compile *type* value] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitLdcInsn value) - (<wrapper>))]] + :let [_ (try (doto *writer* + (.visitTypeInsn Opcodes/NEW <class>) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (<caster> value)) + (.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>)) + (catch Exception e + (assert false (prn-str '<name> (alength value) (aget value 0) (aget value 1)))))]] (return nil))) - compile-int &&/wrap-long - compile-real &&/wrap-double - compile-char &&/wrap-char + compile-int "java/lang/Long" "(J)V" long + compile-real "java/lang/Double" "(D)V" double + compile-char "java/lang/Character" "(C)V" char ) (defn compile-text [compile *type* ?value] @@ -72,28 +56,37 @@ :let [_ (.visitLdcInsn *writer* ?value)]] (return nil))) -(defn compile-prod [compile *type* left right] - ;; (prn 'compile-prod (&type/show-type *type*) - ;; (&/adt->text left) - ;; (&/adt->text right)) +(defn compile-tuple [compile *type* ?elems] (|do [^MethodVisitor *writer* &/get-writer - _ (array-of *writer* "java/lang/Object" 2) - _ (store-at *writer* compile 0 left) - ;; :let [_ (prn 'compile-prod (&type/show-type *type*) left right)] - _ (store-at *writer* compile 1 right)] + :let [num-elems (&/|length ?elems) + _ (doto *writer* + (.visitLdcInsn (int num-elems)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] + _ (&/map2% (fn [idx elem] + (|do [:let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int idx)))] + ret (compile elem) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return ret))) + (&/|range num-elems) ?elems)] (return nil))) -(defn compile-sum [compile *type* ?tag ?value] +(defn compile-variant [compile *type* ?tag ?value] ;; (prn 'compile-variant ?tag (class ?tag)) (|do [^MethodVisitor *writer* &/get-writer - _ (array-of *writer* "java/lang/Object" 2) :let [_ (doto *writer* + (.visitLdcInsn (int 2)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 0)) - (.visitLdcInsn (int ?tag)) - (&&/wrap-int) - (.visitInsn Opcodes/AASTORE))] - _ (store-at *writer* compile 1 ?value)] + (.visitLdcInsn ?tag) + (&&/wrap-long) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)))] + _ (compile ?value) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return nil))) (defn compile-local [compile *type* ?idx] @@ -138,7 +131,7 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI (.visitLdcInsn &/$TypeD) ;; VVIT - (&&/wrap-int) + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI @@ -165,7 +158,7 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI (.visitLdcInsn &/$ValueD) ;; VVIT - (&&/wrap-int) + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI diff --git a/src/lux/compiler/module.clj b/src/lux/compiler/module.clj index 50d8b0011..db73e8bb4 100644 --- a/src/lux/compiler/module.clj +++ b/src/lux/compiler/module.clj @@ -23,6 +23,6 @@ (return (&/|map (fn [pair] (|case pair [name [tags _]] - (&/P name (&/|map (fn [^objects tag] (aget tag 1)) tags)))) - (&module/$get-types module))) + (&/T name (&/|map (fn [^objects tag] (aget tag 1)) tags)))) + (&/get$ &module/$types module))) )) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index cfaa9668b..7e2bc6961 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -9,86 +9,83 @@ (ns lux.compiler.type (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let |case $$]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type]) [lux.analyser.base :as &a])) ;; [Utils] -(def ^:private unit$ - "Analysis" - (&/P (&/S &a/$unit nil) - &type/$Void)) - -(defn ^:private sum$ [tag body] - "(-> Int Analysis Analysis)" - (&/P (&/S &a/$sum (&/P tag body)) +(defn ^:private variant$ [tag body] + "(-> Text Analysis Analysis)" + (&/T (&/V &a/$variant (&/T tag body)) &type/$Void)) -(defn ^:private prod$ [left right] - "(-> Analysis Analysis Analysis)" - (&/P (&/S &a/$prod (&/P left right)) +(defn ^:private tuple$ [members] + "(-> (List Analysis) Analysis)" + (&/T (&/V &a/$tuple members) &type/$Void)) (defn ^:private text$ [text] "(-> Text Analysis)" - (&/P (&/S &a/$text text) + (&/T (&/V &a/$text text) &type/$Void)) (def ^:private $Nil "Analysis" - (sum$ &/$Nil unit$)) + (variant$ &/$Nil (tuple$ (&/|list)))) (defn ^:private Cons$ [head tail] "(-> Analysis Analysis Analysis)" - (sum$ &/$Cons (prod$ head tail))) + (variant$ &/$Cons (tuple$ (&/|list head tail)))) ;; [Exports] (defn ->analysis [type] "(-> Type Analysis)" (|case type (&/$DataT ?class) - (sum$ &/$DataT (text$ ?class)) + (variant$ &/$DataT (text$ ?class)) - (&/$ProdT left right) - (sum$ &/$ProdT - (prod$ (->analysis left) - (->analysis right))) + (&/$TupleT ?members) + (variant$ &/$TupleT + (&/fold (fn [tail head] + (Cons$ (->analysis head) tail)) + $Nil + (&/|reverse ?members))) - (&/$SumT left right) - (sum$ &/$SumT - (prod$ (->analysis left) - (->analysis right))) + (&/$VariantT ?members) + (variant$ &/$VariantT + (&/fold (fn [tail head] + (Cons$ (->analysis head) tail)) + $Nil + (&/|reverse ?members))) (&/$LambdaT ?input ?output) - (sum$ &/$LambdaT (prod$ (->analysis ?input) (->analysis ?output))) + (variant$ &/$LambdaT (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) (&/$AllT ?env ?name ?arg ?body) - (sum$ &/$AllT - ($$ prod$ - (|case ?env - (&/$None) - (sum$ &/$None unit$) + (variant$ &/$AllT + (tuple$ (&/|list (|case ?env + (&/$None) + (variant$ &/$None (tuple$ (&/|list))) - (&/$Some ??env) - (sum$ &/$Some - (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (Cons$ (prod$ (text$ hlabel) - (->analysis htype)) - tail))) - $Nil - (&/|reverse ??env)))) - (text$ ?name) - (text$ ?arg) - (->analysis ?body))) + (&/$Some ??env) + (variant$ &/$Some + (&/fold (fn [tail head] + (|let [[hlabel htype] head] + (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) + tail))) + $Nil + (&/|reverse ??env)))) + (text$ ?name) + (text$ ?arg) + (->analysis ?body)))) (&/$BoundT ?name) - (sum$ &/$BoundT (text$ ?name)) + (variant$ &/$BoundT (text$ ?name)) (&/$AppT ?fun ?arg) - (sum$ &/$AppT (prod$ (->analysis ?fun) (->analysis ?arg))) + (variant$ &/$AppT (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) (&/$NamedT [?module ?name] ?type) - (sum$ &/$NamedT (prod$ (prod$ (text$ ?module) (text$ ?name)) - (->analysis ?type))) + (variant$ &/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ ?module) (text$ ?name))) + (->analysis ?type)))) )) diff --git a/src/lux/host.clj b/src/lux/host.clj index d77e9b31c..dfd4df23d 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -29,8 +29,8 @@ (.getSimpleName class)))] (if (.equals "void" base) (return &type/Unit) - (return (&/S &/$DataT (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) - base))) + (return (&/V &/$DataT (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) + base))) ))) (defn ^:private method->type [^Method method] @@ -76,7 +76,7 @@ (&/$LambdaT _ _) (->type-signature function-class) - (&/$VoidT) + (&/$TupleT (&/$Nil)) "V" (&/$NamedT ?name ?type) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index 91693cc77..e848cc3fd 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -13,22 +13,22 @@ [lux.analyser.module :as &module])) ;; [Tags] -(deftags - ["White_Space" - "Comment" - "Bool" - "Int" - "Real" - "Char" - "Text" - "Symbol" - "Tag" - "Open_Paren" - "Close_Paren" - "Open_Bracket" - "Close_Bracket" - "Open_Brace" - "Close_Brace"] +(deftags "" + "White_Space" + "Comment" + "Bool" + "Int" + "Real" + "Char" + "Text" + "Symbol" + "Tag" + "Open_Paren" + "Close_Paren" + "Open_Bracket" + "Close_Bracket" + "Open_Brace" + "Close_Brace" ) ;; [Utils] @@ -58,19 +58,19 @@ ;; [Lexers] (def ^:private lex-white-space (|do [[meta white-space] (&reader/read-regex #"^(\s+)")] - (return (&/P meta (&/S $White_Space white-space))))) + (return (&/V &/$Meta (&/T meta (&/V $White_Space white-space)))))) (def ^:private lex-single-line-comment (|do [_ (&reader/read-text "##") [meta comment] (&reader/read-regex #"^(.*)$")] - (return (&/P meta (&/S $Comment comment))))) + (return (&/V &/$Meta (&/T meta (&/V $Comment comment)))))) (defn ^:private lex-multi-line-comment [_] (|do [_ (&reader/read-text "#(") [meta comment] (&/try-all% (&/|list (|do [[meta comment] (&reader/read-regex #"(?is)^(?!#\()(.*?(?=\)#))") ;; :let [_ (prn 'immediate comment)] _ (&reader/read-text ")#")] - (return (&/P meta comment))) + (return (&/T meta comment))) (|do [;; :let [_ (prn 'pre/_0)] [meta pre] (&reader/read-regex+ #"(?is)^(.*?)(#\(|$)") ;; :let [_ (prn 'pre pre)] @@ -79,10 +79,10 @@ [_ post] (&reader/read-regex #"(?is)^(.+?(?=\)#))") ;; :let [_ (prn 'post post (str pre "#(" inner ")#" post))] ] - (return (&/P meta (str pre "#(" inner ")#" post)))))) + (return (&/T meta (str pre "#(" inner ")#" post)))))) ;; :let [_ (prn 'lex-multi-line-comment (str comment ")#"))] _ (&reader/read-text ")#")] - (return (&/P meta (&/S $Comment comment))))) + (return (&/V &/$Meta (&/T meta (&/V $Comment comment)))))) (def ^:private lex-comment (&/try-all% (&/|list lex-single-line-comment @@ -91,7 +91,7 @@ (do-template [<name> <tag> <regex>] (def <name> (|do [[meta token] (&reader/read-regex <regex>)] - (return (&/P meta (&/S <tag> token))))) + (return (&/V &/$Meta (&/T meta (&/V <tag> token)))))) ^:private lex-bool $Bool #"^(true|false)" ^:private lex-int $Int #"^(-?0|-?[1-9][0-9]*)" @@ -105,13 +105,13 @@ (|do [[_ char] (&reader/read-regex #"^(.)")] (return char)))) _ (&reader/read-text "\"")] - (return (&/P meta (&/S $Char token))))) + (return (&/V &/$Meta (&/T meta (&/V $Char token)))))) (def ^:private lex-text (|do [[meta _] (&reader/read-text "\"") token (lex-text-body nil) _ (&reader/read-text "\"")] - (return (&/P meta (&/S $Text token))))) + (return (&/V &/$Meta (&/T meta (&/V $Text token)))))) (def ^:private lex-ident (&/try-all% (&/|list (|do [[meta token] (&reader/read-regex +ident-re+)] @@ -119,35 +119,35 @@ [_ local-token] (&reader/read-regex +ident-re+) ? (&module/exists? token)] (if ? - (return (&/P meta (&/P token local-token))) + (return (&/T meta (&/T token local-token))) (|do [unaliased (do ;; (prn "Unaliasing: " token ";" local-token) - (&module/dealias token))] + (&module/dealias token))] (do ;; (prn "Unaliased: " unaliased ";" local-token) - (return (&/P meta (&/P unaliased local-token))))))) - (return (&/P meta (&/P "" token))) + (return (&/T meta (&/T unaliased local-token))))))) + (return (&/T meta (&/T "" token))) ))) (|do [[meta _] (&reader/read-text ";;") [_ token] (&reader/read-regex +ident-re+) module-name &/get-module-name] - (return (&/P meta (&/P module-name token)))) + (return (&/T meta (&/T module-name token)))) (|do [[meta _] (&reader/read-text ";") [_ token] (&reader/read-regex +ident-re+)] - (return (&/P meta (&/P &/prelude-name token)))) + (return (&/T meta (&/T "lux" token)))) ))) (def ^:private lex-symbol (|do [[meta ident] lex-ident] - (return (&/P meta (&/S $Symbol ident))))) + (return (&/V &/$Meta (&/T meta (&/V $Symbol ident)))))) (def ^:private lex-tag (|do [[meta _] (&reader/read-text "#") [_ ident] lex-ident] - (return (&/P meta (&/S $Tag ident))))) + (return (&/V &/$Meta (&/T meta (&/V $Tag ident)))))) (do-template [<name> <text> <tag>] (def <name> (|do [[meta _] (&reader/read-text <text>)] - (return (&/P meta (&/S <tag> nil))))) + (return (&/V &/$Meta (&/T meta (&/V <tag> nil)))))) ^:private lex-open-paren "(" $Open_Paren ^:private lex-close-paren ")" $Close_Paren diff --git a/src/lux/parser.clj b/src/lux/parser.clj index c40221d63..eaa22db20 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -14,22 +14,22 @@ [lexer :as &lexer]))) ;; [Tags] -(deftags - ["White_Space" - "Comment" - "Bool" - "Int" - "Real" - "Char" - "Text" - "Symbol" - "Tag" - "Open_Paren" - "Close_Paren" - "Open_Bracket" - "Close_Bracket" - "Open_Brace" - "Close_Brace"] +(deftags "" + "White_Space" + "Comment" + "Bool" + "Int" + "Real" + "Char" + "Text" + "Symbol" + "Tag" + "Open_Paren" + "Close_Paren" + "Open_Bracket" + "Close_Bracket" + "Open_Brace" + "Close_Brace" ) ;; [Utils] @@ -38,8 +38,8 @@ (|do [elems (&/repeat% parse) token &lexer/lex] (|case token - [meta [<close-token> _]] - (return (&/S <tag> (&/fold &/|++ (&/|list) elems))) + (&/$Meta meta [<close-token> _]) + (return (&/V <tag> (&/fold &/|++ (&/|list) elems))) _ (fail (str "[Parser Error] Unbalanced " <description> "."))))) @@ -53,9 +53,9 @@ token &lexer/lex :let [elems (&/fold &/|++ (&/|list) elems*)]] (|case token - [meta ($Close_Brace _)] + (&/$Meta meta ($Close_Brace _)) (if (even? (&/|length elems)) - (return (&/S &/$RecordS (&/|as-pairs elems))) + (return (&/V &/$RecordS (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) _ @@ -64,7 +64,7 @@ ;; [Interface] (def parse (|do [token &lexer/lex - :let [[meta token*] token]] + :let [(&/$Meta meta token*) token]] (|case token* ($White_Space _) (return (&/|list)) @@ -73,37 +73,37 @@ (return (&/|list)) ($Bool ?value) - (return (&/|list (&/P meta (&/S &/$BoolS (Boolean/parseBoolean ?value))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value)))))) ($Int ?value) - (return (&/|list (&/P meta (&/S &/$IntS (Long/parseLong ?value))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$IntS (Long/parseLong ?value)))))) ($Real ?value) - (return (&/|list (&/P meta (&/S &/$RealS (Double/parseDouble ?value))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$RealS (Double/parseDouble ?value)))))) ($Char ^String ?value) - (return (&/|list (&/P meta (&/S &/$CharS (.charAt ?value 0))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$CharS (.charAt ?value 0)))))) ($Text ?value) - (return (&/|list (&/P meta (&/S &/$TextS ?value)))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TextS ?value))))) ($Symbol ?ident) - (return (&/|list (&/P meta (&/S &/$SymbolS ?ident)))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$SymbolS ?ident))))) ($Tag ?ident) - (return (&/|list (&/P meta (&/S &/$TagS ?ident)))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TagS ?ident))))) ($Open_Paren _) (|do [syntax (parse-form parse)] - (return (&/|list (&/P meta syntax)))) + (return (&/|list (&/V &/$Meta (&/T meta syntax))))) ($Open_Bracket _) (|do [syntax (parse-tuple parse)] - (return (&/|list (&/P meta syntax)))) + (return (&/|list (&/V &/$Meta (&/T meta syntax))))) ($Open_Brace _) (|do [syntax (parse-record parse)] - (return (&/|list (&/P meta syntax)))) + (return (&/|list (&/V &/$Meta (&/T meta syntax))))) _ (fail "[Parser Error] Unknown lexer token.") diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 24a0bf94d..e3f95b5f9 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -10,18 +10,18 @@ (:require [clojure.string :as string] clojure.core.match clojure.core.match.array - [lux.base :as & :refer [deftags |do return* return fail fail* |let |case $$]])) + [lux.base :as & :refer [deftags |do return* return fail fail* |let |case]])) ;; [Tags] -(deftags - ["No" - "Done" - "Yes"]) +(deftags "" + "No" + "Done" + "Yes") ;; [Utils] (defn ^:private with-line [body] (fn [state] - (|case (&/$get-source state) + (|case (&/get$ &/$source state) (&/$Nil) (fail* "[Reader Error] EOF") @@ -32,19 +32,19 @@ (fail* msg) ($Done output) - (return* (&/$set-source more state) + (return* (&/set$ &/$source more state) output) ($Yes output line*) - (return* (&/$set-source (&/Cons$ line* more) state) + (return* (&/set$ &/$source (&/|cons line* more) state) output)) ))) (defn ^:private with-lines [body] (fn [state] - (|case (body (&/$get-source state)) + (|case (body (&/get$ &/$source state)) (&/$Right reader* match) - (return* (&/$set-source reader* state) + (return* (&/set$ &/$source reader* state) match) (&/$Left msg) @@ -85,10 +85,10 @@ match-length (.length match) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/S $Done (&/P (&/cursor$ file-name line-num column-num) match)) - (&/S $Yes (&/P (&/P (&/cursor$ file-name line-num column-num) match) - (&/P (&/cursor$ file-name line-num column-num*) line))))) - (&/S $No (str "[Reader Error] Pattern failed: " regex)))))) + (&/V $Done (&/T (&/T file-name line-num column-num) match)) + (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) match) + (&/T (&/T file-name line-num column-num*) line))))) + (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex2 [regex] (with-line @@ -98,10 +98,10 @@ (let [match-length (.length match) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/S $Done (&/P (&/cursor$ file-name line-num column-num) (&/P tok1 tok2))) - (&/S $Yes (&/P (&/P (&/cursor$ file-name line-num column-num) (&/P tok1 tok2)) - (&/P (&/cursor$ file-name line-num column-num*) line))))) - (&/S $No (str "[Reader Error] Pattern failed: " regex)))))) + (&/V $Done (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) + (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)) + (&/T (&/T file-name line-num column-num*) line))))) + (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex+ [regex] (with-lines @@ -110,7 +110,7 @@ reader* reader] (|case reader* (&/$Nil) - (&/S &/$Left "[Reader Error] EOF") + (&/V &/$Left "[Reader Error] EOF") (&/$Cons [[file-name line-num column-num] ^String line] reader**) @@ -120,10 +120,10 @@ column-num* (+ column-num match-length)] (if (= column-num* (.length line)) (recur (str prefix match "\n") reader**) - (&/S &/$Right (&/P (&/Cons$ (&/P (&/cursor$ file-name line-num column-num*) line) + (&/V &/$Right (&/T (&/|cons (&/T (&/T file-name line-num column-num*) line) reader**) - (&/P (&/cursor$ file-name line-num column-num) (str prefix match)))))) - (&/S &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) + (&/T (&/T file-name line-num column-num) (str prefix match)))))) + (&/V &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) (defn read-text [^String text] (with-line @@ -133,10 +133,10 @@ (let [match-length (.length text) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/S $Done (&/P (&/cursor$ file-name line-num column-num) text)) - (&/S $Yes (&/P (&/P (&/cursor$ file-name line-num column-num) text) - (&/P (&/cursor$ file-name line-num column-num*) line))))) - (&/S $No (str "[Reader Error] Text failed: " text)))))) + (&/V $Done (&/T (&/T file-name line-num column-num) text)) + (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) text) + (&/T (&/T file-name line-num column-num*) line))))) + (&/V $No (str "[Reader Error] Text failed: " text)))))) (def ^:private ^String +source-dir+ "input/") (defn from [^String file-name ^String file-content] @@ -144,7 +144,7 @@ file-name (.substring file-name (.length +source-dir+))] (&/|map (fn [line+line-num] (|let [[line-num line] line+line-num] - (&/P (&/cursor$ file-name (inc line-num) 0) + (&/T (&/T file-name (inc line-num) 0) line))) (&/|filter (fn [line+line-num] (|let [[line-num line] line+line-num] diff --git a/src/lux/type.clj b/src/lux/type.clj index 37f3a99d4..9f3adb036 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -10,7 +10,7 @@ (:refer-clojure :exclude [deref apply merge bound?]) (:require clojure.core.match clojure.core.match.array - [lux.base :as & :refer [|do return* return fail fail* assert! |let |case $$]])) + [lux.base :as & :refer [|do return* return fail fail* assert! |let |case]])) (declare show-type) @@ -26,300 +26,302 @@ _ false)) -(def ^:private empty-env (&/Some$ &/Nil$)) -(def ^:private no-env &/None$) -(def Ident$ &/P) +(def ^:private empty-env (&/V &/$Some (&/V &/$Nil nil))) +(def ^:private no-env (&/V &/$None nil)) (defn Data$ [name] - (&/S &/$DataT name)) + (&/V &/$DataT name)) (defn Bound$ [name] - (&/S &/$BoundT name)) + (&/V &/$BoundT name)) (defn Var$ [id] - (&/S &/$VarT id)) + (&/V &/$VarT id)) (defn Lambda$ [in out] - (&/S &/$LambdaT (&/P in out))) + (&/V &/$LambdaT (&/T in out))) (defn App$ [fun arg] - (&/S &/$AppT (&/P fun arg))) -(defn Prod$ [left right] + (&/V &/$AppT (&/T fun arg))) +(defn Tuple$ [members] ;; (assert (|list? members)) - (&/S &/$ProdT (&/P left right))) -(defn Sum$ [left right] + (&/V &/$TupleT members)) +(defn Variant$ [members] ;; (assert (|list? members)) - (&/S &/$SumT (&/P left right))) + (&/V &/$VariantT members)) (defn All$ [env name arg body] - (&/S &/$AllT ($$ &/P env name arg body))) + (&/V &/$AllT (&/T env name arg body))) (defn Named$ [name type] - (&/S &/$NamedT (&/P name type))) + (&/V &/$NamedT (&/T name type))) -(def Bool (Named$ (Ident$ &/prelude-name "Bool") (Data$ "java.lang.Boolean"))) -(def Int (Named$ (Ident$ &/prelude-name "Int") (Data$ "java.lang.Long"))) -(def Real (Named$ (Ident$ &/prelude-name "Real") (Data$ "java.lang.Double"))) -(def Char (Named$ (Ident$ &/prelude-name "Char") (Data$ "java.lang.Character"))) -(def Text (Named$ (Ident$ &/prelude-name "Text") (Data$ "java.lang.String"))) -(def Unit (Named$ (Ident$ &/prelude-name "Unit") (&/S &/$UnitT nil))) -(def $Void (Named$ (Ident$ &/prelude-name "Void") (&/S &/$VoidT nil))) -(def Ident (Named$ (Ident$ &/prelude-name "Ident") (Prod$ Text Text))) + +(def Bool (Named$ (&/T "lux" "Bool") (&/V &/$DataT "java.lang.Boolean"))) +(def Int (Named$ (&/T "lux" "Int") (&/V &/$DataT "java.lang.Long"))) +(def Real (Named$ (&/T "lux" "Real") (&/V &/$DataT "java.lang.Double"))) +(def Char (Named$ (&/T "lux" "Char") (&/V &/$DataT "java.lang.Character"))) +(def Text (Named$ (&/T "lux" "Text") (&/V &/$DataT "java.lang.String"))) +(def Unit (Named$ (&/T "lux" "Unit") (&/V &/$TupleT (&/|list)))) +(def $Void (Named$ (&/T "lux" "Void") (&/V &/$VariantT (&/|list)))) +(def Ident (Named$ (&/T "lux" "Ident") (Tuple$ (&/|list Text Text)))) (def IO - (Named$ (Ident$ "lux/data" "IO") + (Named$ (&/T "lux/data" "IO") (All$ empty-env "IO" "a" (Lambda$ Unit (Bound$ "a"))))) (def List - (Named$ (Ident$ &/prelude-name "List") + (Named$ (&/T "lux" "List") (All$ empty-env "lux;List" "a" - (Sum$ - ;; lux;Nil - Unit - ;; lux;Cons - (Prod$ (Bound$ "a") - (App$ (Bound$ "lux;List") - (Bound$ "a"))) - )))) + (Variant$ (&/|list + ;; lux;Nil + Unit + ;; lux;Cons + (Tuple$ (&/|list (Bound$ "a") + (App$ (Bound$ "lux;List") + (Bound$ "a")))) + ))))) (def Maybe - (Named$ (Ident$ &/prelude-name "Maybe") + (Named$ (&/T "lux" "Maybe") (All$ empty-env "lux;Maybe" "a" - (Sum$ - ;; lux;None - Unit - ;; lux;Some - (Bound$ "a") - )))) + (Variant$ (&/|list + ;; lux;None + Unit + ;; lux;Some + (Bound$ "a") + ))))) (def Type - (Named$ (Ident$ &/prelude-name "Type") + (Named$ (&/T "lux" "Type") (let [Type (App$ (Bound$ "Type") (Bound$ "_")) TypeList (App$ List Type) - TypeEnv (App$ List (Prod$ Text Type)) - TypePair (Prod$ Type Type)] + TypeEnv (App$ List (Tuple$ (&/|list Text Type))) + TypePair (Tuple$ (&/|list Type Type))] (App$ (All$ empty-env "Type" "_" - ($$ Sum$ - ;; VoidT - Unit - ;; UnitT - Unit - ;; SumT - TypePair - ;; ProdT - TypePair - ;; DataT - Text - ;; LambdaT - TypePair - ;; BoundT - Text - ;; VarT - Int - ;; ExT - Int - ;; AllT - ($$ Prod$ (App$ Maybe TypeEnv) Text Text Type) - ;; AppT - TypePair - ;; NamedT - (Prod$ Ident Type) - )) + (Variant$ (&/|list + ;; DataT + Text + ;; VariantT + TypeList + ;; TupleT + TypeList + ;; LambdaT + TypePair + ;; BoundT + Text + ;; VarT + Int + ;; ExT + Int + ;; AllT + (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type)) + ;; AppT + TypePair + ;; NamedT + (Tuple$ (&/|list Ident Type)) + ))) $Void)))) (def Bindings - (Named$ (Ident$ &/prelude-name "Bindings") + (Named$ (&/T "lux" "Bindings") (All$ empty-env "lux;Bindings" "k" (All$ no-env "" "v" - (Prod$ - ;; "lux;counter" - Int - ;; "lux;mappings" - (App$ List - (Prod$ (Bound$ "k") - (Bound$ "v")))))))) + (Tuple$ (&/|list + ;; "lux;counter" + Int + ;; "lux;mappings" + (App$ List + (Tuple$ (&/|list (Bound$ "k") + (Bound$ "v")))))))))) (def Env - (Named$ (Ident$ &/prelude-name "Env") + (Named$ (&/T "lux" "Env") (let [bindings (App$ (App$ Bindings (Bound$ "k")) (Bound$ "v"))] (All$ empty-env "lux;Env" "k" (All$ no-env "" "v" - ($$ Prod$ - ;; "lux;name" - Text - ;; "lux;inner-closures" - Int - ;; "lux;locals" - bindings - ;; "lux;closure" - bindings - )))))) + (Tuple$ + (&/|list + ;; "lux;name" + Text + ;; "lux;inner-closures" + Int + ;; "lux;locals" + bindings + ;; "lux;closure" + bindings + ))))))) (def Cursor - (Named$ (Ident$ &/prelude-name "Cursor") - ($$ Prod$ Text Int Int))) + (Named$ (&/T "lux" "Cursor") + (Tuple$ (&/|list Text Int Int)))) (def Meta - (Named$ (Ident$ &/prelude-name "Meta") + (Named$ (&/T "lux" "Meta") (All$ empty-env "lux;Meta" "m" (All$ no-env "" "v" - (Prod$ (Bound$ "m") - (Bound$ "v")))))) + (Variant$ (&/|list + ;; &/$Meta + (Tuple$ (&/|list (Bound$ "m") + (Bound$ "v"))))))))) (def AST* - (Named$ (Ident$ &/prelude-name "AST'") + (Named$ (&/T "lux" "AST'") (let [AST* (App$ (Bound$ "w") (App$ (Bound$ "lux;AST'") (Bound$ "w"))) AST*List (App$ List AST*)] (All$ empty-env "lux;AST'" "w" - ($$ Sum$ - ;; &/$BoolS - Bool - ;; &/$IntS - Int - ;; &/$RealS - Real - ;; &/$CharS - Char - ;; &/$TextS - Text - ;; &/$SymbolS - Ident - ;; &/$TagS - Ident - ;; &/$FormS - AST*List - ;; &/$TupleS - AST*List - ;; &/$RecordS - (App$ List (Prod$ AST* AST*)) - ))))) + (Variant$ (&/|list + ;; &/$BoolS + Bool + ;; &/$IntS + Int + ;; &/$RealS + Real + ;; &/$CharS + Char + ;; &/$TextS + Text + ;; &/$SymbolS + Ident + ;; &/$TagS + Ident + ;; &/$FormS + AST*List + ;; &/$TupleS + AST*List + ;; &/$RecordS + (App$ List (Tuple$ (&/|list AST* AST*)))) + ))))) (def AST - (Named$ (Ident$ &/prelude-name "AST") + (Named$ (&/T "lux" "AST") (let [w (App$ Meta Cursor)] (App$ w (App$ AST* w))))) (def ^:private ASTList (App$ List AST)) (def Either - (Named$ (Ident$ &/prelude-name "Either") + (Named$ (&/T "lux" "Either") (All$ empty-env "lux;Either" "l" (All$ no-env "" "r" - (Sum$ - ;; &/$Left - (Bound$ "l") - ;; &/$Right - (Bound$ "r")))))) + (Variant$ (&/|list + ;; &/$Left + (Bound$ "l") + ;; &/$Right + (Bound$ "r"))))))) (def StateE (All$ empty-env "lux;StateE" "s" (All$ no-env "" "a" (Lambda$ (Bound$ "s") (App$ (App$ Either Text) - (Prod$ (Bound$ "s") - (Bound$ "a"))))))) + (Tuple$ (&/|list (Bound$ "s") + (Bound$ "a")))))))) (def Source - (Named$ (Ident$ &/prelude-name "Source") + (Named$ (&/T "lux" "Source") (App$ List (App$ (App$ Meta Cursor) Text)))) (def Host - (Named$ (Ident$ &/prelude-name "Host") - ($$ Prod$ - ;; "lux;writer" - (Data$ "org.objectweb.asm.ClassWriter") - ;; "lux;loader" - (Data$ "java.lang.ClassLoader") - ;; "lux;classes" - (Data$ "clojure.lang.Atom")))) + (Named$ (&/T "lux" "Host") + (Tuple$ + (&/|list + ;; "lux;writer" + (Data$ "org.objectweb.asm.ClassWriter") + ;; "lux;loader" + (Data$ "java.lang.ClassLoader") + ;; "lux;classes" + (Data$ "clojure.lang.Atom"))))) (def DefData* (All$ empty-env "lux;DefData'" "" - ($$ Sum$ - ;; "lux;ValueD" - (Prod$ Type Unit) - ;; "lux;TypeD" - Type - ;; "lux;MacroD" - (Bound$ "") - ;; "lux;AliasD" - Ident - ))) + (Variant$ (&/|list + ;; "lux;ValueD" + (Tuple$ (&/|list Type Unit)) + ;; "lux;TypeD" + Type + ;; "lux;MacroD" + (Bound$ "") + ;; "lux;AliasD" + Ident + )))) (def LuxVar - (Named$ (Ident$ &/prelude-name "LuxVar") - (Sum$ - ;; "lux;Local" - Int - ;; "lux;Global" - Ident))) + (Named$ (&/T "lux" "LuxVar") + (Variant$ (&/|list + ;; "lux;Local" + Int + ;; "lux;Global" + Ident)))) (def $Module (All$ empty-env "lux;$Module" "Compiler" - ($$ Prod$ - ;; "lux;module-aliases" - (App$ List (Prod$ Text Text)) - ;; "lux;defs" - (App$ List - (Prod$ Text - (Prod$ Bool - (App$ DefData* - (Lambda$ ASTList - (App$ (App$ StateE (Bound$ "Compiler")) - ASTList)))))) - ;; "lux;imports" - (App$ List Text) - ;; "lux;tags" - ;; (List (, Text (, Int (List Ident) Type))) - (App$ List - (Prod$ Text - ($$ Prod$ Int - (App$ List Ident) - Type))) - ;; "lux;types" - ;; (List (, Text (, (List Ident) Type))) - (App$ List - (Prod$ Text - (Prod$ (App$ List Ident) - Type))) - ))) + (Tuple$ + (&/|list + ;; "lux;module-aliases" + (App$ List (Tuple$ (&/|list Text Text))) + ;; "lux;defs" + (App$ List + (Tuple$ (&/|list Text + (Tuple$ (&/|list Bool + (App$ DefData* + (Lambda$ ASTList + (App$ (App$ StateE (Bound$ "Compiler")) + ASTList)))))))) + ;; "lux;imports" + (App$ List Text) + ;; "lux;tags" + ;; (List (, Text (, Int (List Ident) Type))) + (App$ List + (Tuple$ (&/|list Text + (Tuple$ (&/|list Int + (App$ List Ident) + Type))))) + ;; "lux;types" + ;; (List (, Text (, (List Ident) Type))) + (App$ List + (Tuple$ (&/|list Text + (Tuple$ (&/|list (App$ List Ident) + Type))))) + )))) (def $Compiler - (Named$ (Ident$ &/prelude-name "Compiler") + (Named$ (&/T "lux" "Compiler") (App$ (All$ empty-env "lux;Compiler" "" - ($$ Prod$ - ;; "lux;source" - Source - ;; "lux;cursor" - Cursor - ;; "lux;modules" - (App$ List (Prod$ Text - (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ ""))))) - ;; "lux;envs" - (App$ List - (App$ (App$ Env Text) - (Prod$ LuxVar Type))) - ;; "lux;types" - (App$ (App$ Bindings Int) Type) - ;; "lux;expected" - Type - ;; "lux;seed" - Int - ;; "lux;eval?" - Bool - ;; "lux;host" - Host - )) + (Tuple$ + (&/|list + ;; "lux;source" + Source + ;; "lux;cursor" + Cursor + ;; "lux;modules" + (App$ List (Tuple$ (&/|list Text + (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ "")))))) + ;; "lux;envs" + (App$ List + (App$ (App$ Env Text) + (Tuple$ (&/|list LuxVar Type)))) + ;; "lux;types" + (App$ (App$ Bindings Int) Type) + ;; "lux;expected" + Type + ;; "lux;seed" + Int + ;; "lux;eval?" + Bool + ;; "lux;host" + Host + ))) $Void))) (def Macro - (Named$ (Ident$ &/prelude-name "Macro") + (Named$ (&/T "lux" "Macro") (Lambda$ ASTList (App$ (App$ StateE $Compiler) ASTList)))) (defn bound? [id] (fn [state] - (if-let [type (->> state (&/$get-type-vars) (&/$get-mappings) (&/|get id))] + (if-let [type (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (|case type (&/$Some type*) (return* state true) @@ -330,7 +332,7 @@ (defn deref [id] (fn [state] - (if-let [type* (->> state (&/$get-type-vars) (&/$get-mappings) (&/|get id))] + (if-let [type* (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (|case type* (&/$Some type) (return* state type) @@ -341,37 +343,32 @@ (defn set-var [id type] (fn [state] - (if-let [tvar (->> state (&/$get-type-vars) (&/$get-mappings) (&/|get id))] + (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (|case tvar (&/$Some bound) (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) (&/$None) - (return* (&/$update-type-vars (fn [ts] (&/$update-mappings #(&/|put id (&/Some$ type) %) - ts)) - state) + (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/V &/$Some type) %) + ts)) + state) nil)) - (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/$get-type-vars) (&/$get-mappings) &/|length)))))) + (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))))) ;; [Exports] ;; Type vars (def ^:private create-var (fn [state] - (let [id (->> state &/$get-type-vars &/$get-counter)] - (return* (&/$update-type-vars #(do ;; (prn 'create-var/_0 (&/adt->text %)) - ;; (prn 'create-var/_1 (&/adt->text (->> % (&/$update-counter inc)))) - ;; (prn 'create-var/_2 (&/adt->text (->> % - ;; (&/$update-counter inc) - ;; (&/$update-mappings (fn [ms] (&/|put id &/None$ ms)))))) - (->> % - (&/$update-counter inc) - (&/$update-mappings (fn [ms] (&/|put id &/None$ ms))))) - state) + (let [id (->> state (&/get$ &/$type-vars) (&/get$ &/$counter))] + (return* (&/update$ &/$type-vars #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [ms] (&/|put id (&/V &/$None nil) ms)))) + state) id)))) (def existential (|do [seed &/gen-id] - (return (&/S &/$ExT seed)))) + (return (&/V &/$ExT seed)))) (declare clean*) (defn ^:private delete-var [id] @@ -393,19 +390,19 @@ (|case ?type* (&/$VarT ?id*) (if (.equals ^Object id ?id*) - (return (&/P ?id &/None$)) + (return (&/T ?id (&/V &/$None nil))) (return binding)) _ (|do [?type** (clean* id ?type*)] - (return (&/P ?id (&/Some$ ?type**))))) + (return (&/T ?id (&/V &/$Some ?type**))))) )))) - (->> state (&/$get-type-vars) (&/$get-mappings)))] + (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings)))] (fn [state] - (return* (&/$update-type-vars #(->> % - (&/$update-counter dec) - (&/$set-mappings (&/|remove id mappings*))) - state) + (return* (&/update$ &/$type-vars #(->> % + (&/update$ &/$counter dec) + (&/set$ &/$mappings (&/|remove id mappings*))) + state) nil))) state)))) @@ -438,15 +435,13 @@ =param (clean* ?tid ?param)] (return (App$ =lambda =param))) - (&/$SumT ?left ?right) - (|do [=left (clean* ?tid ?left) - =right (clean* ?tid ?right)] - (return (Sum$ =left =right))) - - (&/$ProdT ?left ?right) - (|do [=left (clean* ?tid ?left) - =right (clean* ?tid ?right)] - (return (Prod$ =left =right))) + (&/$TupleT ?members) + (|do [=members (&/map% (partial clean* ?tid) ?members)] + (return (Tuple$ =members))) + + (&/$VariantT ?members) + (|do [=members (&/map% (partial clean* ?tid) ?members)] + (return (Variant$ =members))) (&/$AllT ?env ?name ?arg ?body) (|do [=env (|case ?env @@ -456,9 +451,9 @@ (&/$Some ?env*) (|do [clean-env (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] - (return (&/P k =v)))) + (return (&/T k =v)))) ?env*)] - (return (&/Some$ clean-env)))) + (return (&/V &/$Some clean-env)))) body* (clean* ?tid ?body)] (return (All$ =env ?name ?arg body*))) @@ -478,36 +473,37 @@ (|case type (&/$LambdaT ?in ?out) (|let [[??out ?args] (unravel-fun ?out)] - (&/P ??out (&/Cons$ ?in ?args))) + (&/T ??out (&/|cons ?in ?args))) _ - (&/P type (&/|list)))) + (&/T type (&/|list)))) (defn ^:private unravel-app [fun-type] (|case fun-type (&/$AppT ?left ?right) (|let [[?fun-type ?args] (unravel-app ?left)] - (&/P ?fun-type (&/|++ ?args (&/|list ?right)))) + (&/T ?fun-type (&/|++ ?args (&/|list ?right)))) _ - (&/P fun-type (&/|list)))) + (&/T fun-type (&/|list)))) (defn show-type [^objects type] (|case type - (&/$VoidT) - "(|)" - - (&/$UnitT) - "(,)" - (&/$DataT name) (str "(^ " name ")") - (&/$ProdT left right) - (str "(, " (show-type left) " " (show-type right) ")") - - (&/$SumT left right) - (str "(| " (show-type left) " " (show-type right) ")") + (&/$TupleT elems) + (if (&/|empty? elems) + "(,)" + (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) + + (&/$VariantT cases) + (if (&/|empty? cases) + "(|)" + (str "(| " (->> cases + (&/|map show-type) + (&/|interpose " ") + (&/fold str "")) ")")) (&/$LambdaT input output) (|let [[?out ?ins] (unravel-fun type)] @@ -548,22 +544,18 @@ (defn type= [x y] (or (clojure.lang.Util/identical x y) (let [output (|case [x y] - [(&/$UnitT) (&/$UnitT)] - true - - [(&/$VoidT) (&/$VoidT)] - true - [(&/$DataT xname) (&/$DataT yname)] (.equals ^Object xname yname) - [(&/$ProdT xleft xright) (&/$ProdT yleft yright)] - (and (type= xleft yleft) - (type= xright yright)) + [(&/$TupleT xelems) (&/$TupleT yelems)] + (&/fold2 (fn [old x y] (and old (type= x y))) + true + xelems yelems) - [(&/$SumT xleft xright) (&/$SumT yleft yright)] - (and (type= xleft yleft) - (type= xright yright)) + [(&/$VariantT xcases) (&/$VariantT ycases)] + (&/fold2 (fn [old x y] (and old (type= x y))) + true + xcases ycases) [(&/$LambdaT xinput xoutput) (&/$LambdaT yinput youtput)] (and (type= xinput yinput) @@ -615,17 +607,17 @@ (|let [[e a] k] (|case fixpoints (&/$Nil) - &/None$ + (&/V &/$None nil) (&/$Cons [[e* a*] v*] fixpoints*) (if (and (type= e e*) (type= a a*)) - (&/Some$ v*) + (&/V &/$Some v*) (fp-get k fixpoints*)) ))) (defn ^:private fp-put [k v fixpoints] - (&/Cons$ (&/P k v) fixpoints)) + (&/|cons (&/T k v) fixpoints)) (defn ^:private check-error [expected actual] (str "[Type Checker]\nExpected: " (show-type expected) @@ -634,11 +626,11 @@ (defn beta-reduce [env type] (|case type - (&/$SumT ?left ?right) - (Sum$ (beta-reduce env ?left) (beta-reduce env ?right)) + (&/$VariantT ?members) + (Variant$ (&/|map (partial beta-reduce env) ?members)) - (&/$ProdT ?left ?right) - (Prod$ (beta-reduce env ?left) (beta-reduce env ?right)) + (&/$TupleT ?members) + (Tuple$ (&/|map (partial beta-reduce env) ?members)) (&/$AppT ?type-fn ?type-arg) (App$ (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) @@ -646,7 +638,7 @@ (&/$AllT ?local-env ?local-name ?local-arg ?local-def) (|case ?local-env (&/$None) - (All$ (&/Some$ env) ?local-name ?local-arg ?local-def) + (All$ (&/V &/$Some env) ?local-name ?local-arg ?local-def) (&/$Some _) type) @@ -685,7 +677,7 @@ (apply-type ?type param) _ - (fail (str "[Type Error] Not a type function:\n" (show-type type-fn) "\n")))) + (fail (str "[Type System] Not a type function:\n" (show-type type-fn) "\n")))) (defn as-obj [class] (case class @@ -705,35 +697,30 @@ (def ^:private init-fixpoints (&/|list)) (defn ^:private check* [class-loader fixpoints expected actual] - ;; (prn 'check*/_0 (&/adt->text expected) (&/adt->text actual)) - ;; (prn 'check*/_1 (show-type expected) (show-type actual)) (if (clojure.lang.Util/identical expected actual) - (return (&/P fixpoints nil)) + (return (&/T fixpoints nil)) (|case [expected actual] - [(&/$UnitT) (&/$UnitT)] - (return (&/P fixpoints nil)) - [(&/$VarT ?eid) (&/$VarT ?aid)] (if (.equals ^Object ?eid ?aid) - (return (&/P fixpoints nil)) + (return (&/T fixpoints nil)) (|do [ebound (fn [state] (|case ((deref ?eid) state) (&/$Right state* ebound) - (return* state* (&/Some$ ebound)) + (return* state* (&/V &/$Some ebound)) (&/$Left _) - (return* state &/None$))) + (return* state (&/V &/$None nil)))) abound (fn [state] (|case ((deref ?aid) state) (&/$Right state* abound) - (return* state* (&/Some$ abound)) + (return* state* (&/V &/$Some abound)) (&/$Left _) - (return* state &/None$)))] + (return* state (&/V &/$None nil))))] (|case [ebound abound] [(&/$None _) (&/$None _)] (|do [_ (set-var ?eid actual)] - (return (&/P fixpoints nil))) + (return (&/T fixpoints nil))) [(&/$Some etype) (&/$None _)] (check* class-loader fixpoints etype actual) @@ -748,7 +735,7 @@ (fn [state] (|case ((set-var ?id actual) state) (&/$Right state* _) - (return* state* (&/P fixpoints nil)) + (return* state* (&/T fixpoints nil)) (&/$Left _) ((|do [bound (deref ?id)] @@ -759,7 +746,7 @@ (fn [state] (|case ((set-var ?id expected) state) (&/$Right state* _) - (return* state* (&/P fixpoints nil)) + (return* state* (&/T fixpoints nil)) (&/$Left _) ((|do [bound (deref ?id)] @@ -770,9 +757,9 @@ (fn [state] (|case ((|do [F1 (deref ?eid)] (fn [state] - (|case ((|do [F2 (deref ?aid)] - (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) - state) + (|case [((|do [F2 (deref ?aid)] + (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) + state)] (&/$Right state* output) (return* state* output) @@ -793,11 +780,11 @@ (&/$Left _) ((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) [fixpoints** _] (check* class-loader fixpoints* A1 A2)] - (return (&/P fixpoints** nil))) + (return (&/T fixpoints** nil))) state)))) ;; (|do [_ (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) ;; _ (check* class-loader fixpoints A1 A2)] - ;; (return (&/P fixpoints nil))) + ;; (return (&/T fixpoints nil))) [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] (fn [state] @@ -812,14 +799,14 @@ e* (apply-type F2 A1) a* (apply-type F2 A2) [fixpoints** _] (check* class-loader fixpoints* e* a*)] - (return (&/P fixpoints** nil))) + (return (&/T fixpoints** nil))) state))) ;; [[&/$AppT [[&/$VarT ?id] A1]] [&/$AppT [F2 A2]]] ;; (|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?id) F2) ;; e* (apply-type F2 A1) ;; a* (apply-type F2 A2) ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] - ;; (return (&/P fixpoints** nil))) + ;; (return (&/T fixpoints** nil))) [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] (fn [state] @@ -834,22 +821,22 @@ e* (apply-type F1 A1) a* (apply-type F1 A2) [fixpoints** _] (check* class-loader fixpoints* e* a*)] - (return (&/P fixpoints** nil))) + (return (&/T fixpoints** nil))) state))) ;; [[&/$AppT [F1 A1]] [&/$AppT [[&/$VarT ?id] A2]]] ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (Var$ ?id)) ;; e* (apply-type F1 A1) ;; a* (apply-type F1 A2) ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] - ;; (return (&/P fixpoints** nil))) + ;; (return (&/T fixpoints** nil))) [(&/$AppT F A) _] - (let [fp-pair (&/P expected actual) + (let [fp-pair (&/T expected actual) _ (when (> (&/|length fixpoints) 40) (println 'FIXPOINTS (->> (&/|keys fixpoints) (&/|map (fn [pair] (|let [[e a] pair] - (str (show-type e) " :+: " + (str (show-type e) ":+:" (show-type a))))) (&/|interpose "\n\n") (&/fold str ""))) @@ -857,7 +844,7 @@ (|case (fp-get fp-pair fixpoints) (&/$Some ?) (if ? - (return (&/P fixpoints nil)) + (return (&/T fixpoints nil)) (fail (check-error expected actual))) (&/$None) @@ -883,33 +870,39 @@ [(&/$DataT e!name) (&/$DataT "null")] (if (contains? primitive-types e!name) (fail (str "[Type Error] Can't use \"null\" with primitive types.")) - (return (&/P fixpoints nil))) + (return (&/T fixpoints nil))) [(&/$DataT e!name) (&/$DataT a!name)] (let [e!name (as-obj e!name) a!name (as-obj a!name)] (if (or (.equals ^Object e!name a!name) (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader))) - (return (&/P fixpoints nil)) + (return (&/T fixpoints nil)) (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] (|do [[fixpoints* _] (check* class-loader fixpoints aI eI)] (check* class-loader fixpoints* eO aO)) - [(&/$ProdT e!left e!right) (&/$ProdT a!left a!right)] - (|do [[fixpoints* _] (check* class-loader fixpoints e!left a!left) - [fixpoints** _] (check* class-loader fixpoints* e!right a!right)] - (return (&/P fixpoints** nil))) + [(&/$TupleT e!members) (&/$TupleT a!members)] + (|do [fixpoints* (&/fold2% (fn [fp e a] + (|do [[fp* _] (check* class-loader fp e a)] + (return fp*))) + fixpoints + e!members a!members)] + (return (&/T fixpoints* nil))) - [(&/$SumT e!left e!right) (&/$SumT a!left a!right)] - (|do [[fixpoints* _] (check* class-loader fixpoints e!left a!left) - [fixpoints** _] (check* class-loader fixpoints* e!right a!right)] - (return (&/P fixpoints** nil))) + [(&/$VariantT e!cases) (&/$VariantT a!cases)] + (|do [fixpoints* (&/fold2% (fn [fp e a] + (|do [[fp* _] (check* class-loader fp e a)] + (return fp*))) + fixpoints + e!cases a!cases)] + (return (&/T fixpoints* nil))) [(&/$ExT e!id) (&/$ExT a!id)] (if (.equals ^Object e!id a!id) - (return (&/P fixpoints nil)) + (return (&/T fixpoints nil)) (fail (check-error expected actual))) [(&/$NamedT ?ename ?etype) _] @@ -918,9 +911,6 @@ [_ (&/$NamedT ?aname ?atype)] (check* class-loader fixpoints expected ?atype) - [_ (&/$VoidT)] - (return (&/P fixpoints nil)) - [_ _] (fail (check-error expected actual)) ))) @@ -947,7 +937,7 @@ (apply-lambda ?type param) _ - (fail (str "[Type Error] Not a function type:\n" (show-type func) "\n")) + (fail (str "[Type System] Not a function type:\n" (show-type func) "\n")) )) (defn actual-type [type] @@ -968,31 +958,20 @@ )) (defn variant-case [tag type] - ;; (prn 'variant-case tag (show-type type)) (|case type (&/$NamedT ?name ?type) (variant-case tag ?type) - (&/$SumT ?left ?right) - (case tag - 0 - (return ?left) - - 1 - (|case ?right - (&/$SumT ?left* _) - (return ?left*) - - _ - (return ?right)) + (&/$VariantT ?cases) + (|case (&/|at tag ?cases) + (&/$Some case-type) + (return case-type) - ;; else - (variant-case (dec tag) ?right)) + (&/$None) + (fail (str "[Type Error] Variant lacks case: " tag " | " (show-type type)))) _ - (fail (str "[Type Error] Type is not a variant: " (show-type type))) - ;; (assert false (str "[Type Error] Type is not a variant: " (show-type type))) - )) + (fail (str "[Type Error] Type is not a variant: " (show-type type))))) (defn type-name [type] "(-> Type (Lux Ident))" |