aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2015-08-28 06:37:46 -0400
committerEduardo Julian2015-08-28 06:37:46 -0400
commitf403ee7a9662f81c91aa124f0573c5957a88ebe5 (patch)
treeee5d447757614421f408decede0c88a8cbfc859b
parent37a9044d8ec523a282c0470d65380ce5cff27084 (diff)
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.
Diffstat
-rw-r--r--source/lux.lux885
-rw-r--r--source/lux/control/monad.lux6
-rw-r--r--source/lux/data/id.lux13
-rw-r--r--source/lux/data/list.lux51
-rw-r--r--source/lux/meta/ast.lux2
-rw-r--r--source/lux/meta/macro.lux16
-rw-r--r--source/lux/meta/syntax.lux18
-rw-r--r--src/lux/analyser.clj401
-rw-r--r--src/lux/analyser/base.clj230
-rw-r--r--src/lux/analyser/case.clj380
-rw-r--r--src/lux/analyser/env.clj38
-rw-r--r--src/lux/analyser/host.clj158
-rw-r--r--src/lux/analyser/lambda.clj22
-rw-r--r--src/lux/analyser/lux.clj277
-rw-r--r--src/lux/analyser/module.clj266
-rw-r--r--src/lux/analyser/record.clj122
-rw-r--r--src/lux/base.clj529
-rw-r--r--src/lux/compiler.clj18
-rw-r--r--src/lux/compiler/base.clj45
-rw-r--r--src/lux/compiler/cache.clj8
-rw-r--r--src/lux/compiler/case.clj92
-rw-r--r--src/lux/compiler/host.clj26
-rw-r--r--src/lux/compiler/lux.clj79
-rw-r--r--src/lux/compiler/module.clj4
-rw-r--r--src/lux/compiler/type.clj89
-rw-r--r--src/lux/host.clj6
-rw-r--r--src/lux/lexer.clj66
-rw-r--r--src/lux/parser.clj62
-rw-r--r--src/lux/reader.clj54
-rw-r--r--src/lux/type.clj645
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))"
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-05 01:14:19 +0000