From f403ee7a9662f81c91aa124f0573c5957a88ebe5 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 28 Aug 2015 06:37:46 -0400 Subject: Due to several performance issues and my inability to optimize them away due to too many corner cases, I decided the abandon the path towards a more mathematical implementation of tuples & variants. --- source/lux.lux | 885 ++++++++++++++++++++++++++++----------------------------- 1 file changed, 440 insertions(+), 445 deletions(-) (limited to 'source/lux.lux') 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 ( tokens) (case (reverse tokens) (\ (list& last init)) - (return (list (foldL (: (-> AST AST AST) - (lambda [post pre] (`
))) + (return (list (foldL (lambda [post pre] (` )) 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 [] - [ - (` )]) - [[#VoidT] [#UnitT]] - - (\template [] - [( left right) - (` ( (~ (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 [] - [( id) - (` ( (~ (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))) -- cgit v1.2.3