aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2015-08-23 02:54:00 -0400
committerEduardo Julian2015-08-23 02:54:00 -0400
commit9606c19f9947c8f2ff5647b4613ac2029ac3881f (patch)
treecf4f2fdd8e9d985ae6f4c8fbd2c1922b46e386bc
parentb059fa2a5efb4cab8b62d895e8c9adf1434bde2d (diff)
- Restructuring how sums & products work [part 1]
Diffstat (limited to '')
-rw-r--r--source/lux.lux489
-rw-r--r--src/lux/analyser.clj401
-rw-r--r--src/lux/analyser/base.clj230
-rw-r--r--src/lux/analyser/case.clj355
-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.clj255
-rw-r--r--src/lux/analyser/module.clj247
-rw-r--r--src/lux/analyser/record.clj122
-rw-r--r--src/lux/base.clj527
-rw-r--r--src/lux/compiler.clj18
-rw-r--r--src/lux/compiler/base.clj44
-rw-r--r--src/lux/compiler/cache.clj8
-rw-r--r--src/lux/compiler/case.clj89
-rw-r--r--src/lux/compiler/host.clj26
-rw-r--r--src/lux/compiler/lux.clj75
-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.clj627
24 files changed, 1959 insertions, 2053 deletions
diff --git a/source/lux.lux b/source/lux.lux
index 4120b262c..7c5fd5c8d 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -11,51 +11,50 @@
("apply" ["java.lang.Object"] "java.lang.Object" ["public" "abstract"]))
## Basic types
-(_lux_def Bool (9 ["lux" "Bool"]
- (0 "java.lang.Boolean")))
+(_lux_def Bool (11 ["lux" "Bool"]
+ (4 "java.lang.Boolean")))
(_lux_export Bool)
-(_lux_def Int (9 ["lux" "Int"]
- (0 "java.lang.Long")))
+(_lux_def Int (11 ["lux" "Int"]
+ (4 "java.lang.Long")))
(_lux_export Int)
-(_lux_def Real (9 ["lux" "Real"]
- (0 "java.lang.Double")))
+(_lux_def Real (11 ["lux" "Real"]
+ (4 "java.lang.Double")))
(_lux_export Real)
-(_lux_def Char (9 ["lux" "Char"]
- (0 "java.lang.Character")))
+(_lux_def Char (11 ["lux" "Char"]
+ (4 "java.lang.Character")))
(_lux_export Char)
-(_lux_def Text (9 ["lux" "Text"]
- (0 "java.lang.String")))
+(_lux_def Text (11 ["lux" "Text"]
+ (4 "java.lang.String")))
(_lux_export Text)
-(_lux_def Unit (9 ["lux" "Unit"]
- (2 (0))))
-(_lux_export Unit)
-
-(_lux_def Void (9 ["lux" "Void"]
- (1 (0))))
+(_lux_def Void (11 ["lux" "Void"]
+ (0 [])))
(_lux_export Void)
-(_lux_def Ident (9 ["lux" "Ident"]
- (2 (1 Text (1 Text (0))))))
+(_lux_def Unit (11 ["lux" "Unit"]
+ (1 [])))
+(_lux_export Unit)
+
+(_lux_def Ident (11 ["lux" "Ident"]
+ (3 Text Text)))
(_lux_export Ident)
## (deftype (List a)
## (| #Nil
## (#Cons a (List a))))
(_lux_def List
- (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)))))))
+ (11 ["lux" "List"]
+ (9 (1 (0)) "lux;List" "a"
+ (2 ## "lux;Nil"
+ Unit
+ ## "lux;Cons"
+ (3 (6 "a")
+ (10 (6 "lux;List") (6 "a")))
+ ))))
(_lux_export List)
(_lux_declare-tags [#Nil #Cons] List)
@@ -63,76 +62,78 @@
## (| #None
## (1 a)))
(_lux_def Maybe
- (9 ["lux" "Maybe"]
- (7 (1 (0)) "lux;Maybe" "a"
- (1 (1 ## "lux;None"
- (2 (0))
- (1 ## "lux;Some"
- (4 "a")
- (0)))))))
+ (11 ["lux" "Maybe"]
+ (9 (1 (0)) "lux;Maybe" "a"
+ (2 ## "lux;None"
+ Unit
+ ## "lux;Some"
+ (6 "a")
+ ))))
(_lux_export Maybe)
(_lux_declare-tags [#None #Some] Maybe)
## (deftype #rec Type
-## (| (#DataT Text)
-## (#VariantT (List Type))
-## (#TupleT (List Type))
+## (| #VoidT
+## #UnitT
+## (#SumT Type Type)
+## (#ProdT Type Type)
+## (#DataT Text)
## (#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
- (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"
+ (11 ["lux" "Type"]
+ (_lux_case (10 (6 "Type") (6 "_"))
+ Type
+ (_lux_case (10 List (3 Text Type))
+ TypeEnv
+ (10 (9 (1 (0)) "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"
Int
- (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))))))
+ (2 ## "lux;AllT"
+ (3 (10 Maybe TypeEnv) (3 Text (3 Text Type)))
+ (2 ## "lux;AppT"
+ (3 Type Type)
+ ## "lux;NamedT"
+ (3 Ident Type)))))))))))))
+ Void)))))
(_lux_export Type)
-(_lux_declare-tags [#DataT #VariantT #TupleT #LambdaT #BoundT #VarT #ExT #AllT #AppT #NamedT] Type)
+(_lux_declare-tags [#VoidT #UnitT #SumT #ProdT #DataT #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"
- (#TupleT (#Cons ## "lux;counter"
- Int
- (#Cons ## "lux;mappings"
- (#AppT [List
- (#TupleT (#Cons [(#BoundT "k")
- (#Cons [(#BoundT "v")
- #Nil])]))])
- #Nil)))])])))
+ (#AllT (#Some #Nil) "lux;Bindings" "k"
+ (#AllT #None "" "v"
+ (#ProdT ## lux;counter
+ Int
+ ## lux;mappings
+ (#AppT List
+ (#ProdT (#BoundT "k")
+ (#BoundT "v"))))))))
(_lux_export Bindings)
(_lux_declare-tags [#counter #mappings] Bindings)
@@ -145,17 +146,16 @@
(#NamedT ["lux" "Env"]
(#AllT (#Some #Nil) "lux;Env" "k"
(#AllT #None "" "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)))))))))
+ (#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")))))))))
(_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"]
- (#TupleT (#Cons Text (#Cons Int (#Cons Int #Nil))))))
+ (#ProdT Text (#ProdT Int Int))))
(_lux_export Cursor)
## (deftype (Meta m v)
@@ -172,13 +172,9 @@
(#NamedT ["lux" "Meta"]
(#AllT (#Some #Nil) "lux;Meta" "m"
(#AllT #None "" "v"
- (#VariantT (#Cons ## "lux;Meta"
- (#TupleT (#Cons (#BoundT "m")
- (#Cons (#BoundT "v")
- #Nil)))
- #Nil))))))
+ (#ProdT (#BoundT "m")
+ (#BoundT "v"))))))
(_lux_export Meta)
-(_lux_declare-tags [#Meta] Meta)
## (deftype (AST' w)
## (| (#BoolS Bool)
@@ -200,29 +196,28 @@
(_lux_case (#AppT [List AST])
ASTList
(#AllT (#Some #Nil) "lux;AST'" "w"
- (#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)
- )))))))))
- ))))))
+ (#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))
+ ))))))))
+ ))))))
(_lux_export AST')
(_lux_declare-tags [#BoolS #IntS #RealS #CharS #TextS #SymbolS #TagS #FormS #TupleS #RecordS] AST')
@@ -244,32 +239,30 @@
(#NamedT ["lux" "Either"]
(#AllT (#Some #Nil) "lux;Either" "l"
(#AllT #None "" "r"
- (#VariantT (#Cons ## "lux;Left"
- (#BoundT "l")
- (#Cons ## "lux;Right"
- (#BoundT "r")
- #Nil)))))))
+ (#SumT ## "lux;Left"
+ (#BoundT "l")
+ ## "lux;Right"
+ (#BoundT "r"))))))
(_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])
- (#TupleT (#Cons [(#BoundT "s")
- (#Cons [(#BoundT "a")
- #Nil])]))])])])]))
+ (#AllT (#Some #Nil) "lux;StateE" "s"
+ (#AllT #None "" "a"
+ (#LambdaT (#BoundT "s")
+ (#AppT (#AppT [Either Text])
+ (#ProdT (#BoundT "s")
+ (#BoundT "a")))))))
## (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
@@ -278,13 +271,12 @@
## #classes (^ clojure.lang.Atom)))
(_lux_def Host
(#NamedT ["lux" "Host"]
- (#TupleT (#Cons [## "lux;writer"
- (#DataT "org.objectweb.asm.ClassWriter")
- (#Cons [## "lux;loader"
- (#DataT "java.lang.ClassLoader")
- (#Cons [## "lux;classes"
- (#DataT "clojure.lang.Atom")
- #Nil])])]))))
+ (#ProdT ## "lux;writer"
+ (#DataT "org.objectweb.asm.ClassWriter")
+ (#ProdT ## "lux;loader"
+ (#DataT "java.lang.ClassLoader")
+ ## "lux;classes"
+ (#DataT "clojure.lang.Atom")))))
(_lux_declare-tags [#writer #loader #classes] Host)
## (deftype (DefData' m)
@@ -295,17 +287,15 @@
(_lux_def DefData'
(#NamedT ["lux" "DefData'"]
(#AllT [(#Some #Nil) "lux;DefData'" ""
- (#VariantT (#Cons [## "lux;ValueD"
- (#TupleT (#Cons [Type
- (#Cons [Unit
- #Nil])]))
- (#Cons [## "lux;TypeD"
- Type
- (#Cons [## "lux;MacroD"
- (#BoundT "")
- (#Cons [## "lux;AliasD"
- Ident
- #Nil])])])]))])))
+ (#SumT ## "lux;ValueD"
+ (#ProdT Type
+ Unit)
+ (#SumT ## "lux;TypeD"
+ Type
+ (#SumT ## "lux;MacroD"
+ (#BoundT "")
+ ## "lux;AliasD"
+ Ident)))])))
(_lux_export DefData')
(_lux_declare-tags [#ValueD #TypeD #MacroD #AliasD] DefData')
@@ -314,11 +304,10 @@
## (#Global Ident)))
(_lux_def LuxVar
(#NamedT ["lux" "LuxVar"]
- (#VariantT (#Cons [## "lux;Local"
- Int
- (#Cons [## "lux;Global"
- Ident
- #Nil])]))))
+ (#SumT ## "lux;Local"
+ Int
+ ## "lux;Global"
+ Ident)))
(_lux_export LuxVar)
(_lux_declare-tags [#Local #Global] LuxVar)
@@ -331,34 +320,28 @@
## ))
(_lux_def Module
(#NamedT ["lux" "Module"]
- (#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])])])])]))])))
+ (#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))))))))))
(_lux_export Module)
(_lux_declare-tags [#module-aliases #defs #imports #tags #types] Module)
@@ -375,30 +358,28 @@
## ))
(_lux_def Compiler
(#NamedT ["lux" "Compiler"]
- (#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])))
+ (#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)))
(_lux_export Compiler)
(_lux_declare-tags [#source #cursor #modules #envs #type-vars #expected #seed #eval? #host] Compiler)
@@ -426,7 +407,7 @@
(#AppT Meta Cursor))
AST)
(_lux_lambda _ data
- (#Meta _cursor data))))
+ [_cursor data])))
## (def (return x)
## (All [a]
@@ -438,9 +419,8 @@
(#LambdaT (#BoundT "a")
(#LambdaT Compiler
(#AppT (#AppT Either Text)
- (#TupleT (#Cons Compiler
- (#Cons (#BoundT "a")
- #Nil)))))))
+ (#ProdT Compiler
+ (#BoundT "a"))))))
(_lux_lambda _ val
(_lux_lambda _ state
(#Right state val)))))
@@ -455,9 +435,8 @@
(#LambdaT Text
(#LambdaT Compiler
(#AppT (#AppT Either Text)
- (#TupleT (#Cons Compiler
- (#Cons (#BoundT "a")
- #Nil)))))))
+ (#ProdT Compiler
+ (#BoundT "a"))))))
(_lux_lambda _ msg
(_lux_lambda _ state
(#Left msg)))))
@@ -493,7 +472,7 @@
(_meta (#TupleS tokens)))))
(_lux_def record$
- (_lux_: (#LambdaT (#AppT List (#TupleT (#Cons AST (#Cons AST #Nil)))) AST)
+ (_lux_: (#LambdaT (#AppT List (#ProdT AST AST)) AST)
(_lux_lambda _ tokens
(_meta (#RecordS tokens)))))
@@ -1068,30 +1047,30 @@
($' 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
@@ -1119,16 +1098,16 @@
(#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
- (#Meta _ (#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)
@@ -2483,10 +2462,10 @@
(: (-> AST (Lux AST))
(lambda [token]
(case token
- (#Meta _ (#SymbolS "" sub-name))
+ [_ (#SymbolS "" sub-name)]
(return (symbol$ ["" ($ text:++ super-name "/" sub-name)]))
- (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS "" sub-name)) parts))))
+ (\ [_ (#FormS (list& [_ (#SymbolS "" sub-name)] parts))])
(return (form$ (list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts)))
_
@@ -2500,10 +2479,10 @@
(: (-> AST (Lux (List Import)))
(lambda [token]
(case token
- (#Meta _ (#SymbolS "" m-name))
+ [_ (#SymbolS "" m-name)]
(wrap (list [m-name #None #All #None]))
- (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS "" m-name)) extra))))
+ (\ [_ (#FormS (list& [_ (#SymbolS "" m-name)] extra))])
(do Lux/Monad
[alias+extra (parse-alias extra)
#let [[alias extra] alias+extra]
@@ -2848,7 +2827,7 @@
(case tokens
(\ (list struct body))
(case struct
- (#Meta _ (#SymbolS name))
+ [_ (#SymbolS name)]
(do Lux/Monad
[struct-type (find-var-type name)
output (resolve-type-tags struct-type)]
@@ -2910,7 +2889,7 @@
(defmacro #export (get@ tokens)
(case tokens
- (\ (list (#Meta _ (#TagS slot')) record))
+ (\ (list [_ (#TagS slot')] record))
(do Lux/Monad
[slot (normalize slot')
output (resolve-tag slot)
@@ -2952,11 +2931,11 @@
(defmacro #export (open tokens)
(case tokens
- (\ (list& (#Meta _ (#SymbolS struct-name)) tokens'))
+ (\ (list& [_ (#SymbolS struct-name)] tokens'))
(do Lux/Monad
[@module get-module-name
#let [prefix (case tokens'
- (\ (list (#Meta _ (#TextS prefix))))
+ (\ (list [_ (#TextS prefix)]))
prefix
_
@@ -2999,10 +2978,10 @@
(: (-> AST AST (Lux AST))
(lambda [so-far part]
(case part
- (#Meta _ (#SymbolS slot))
+ [_ (#SymbolS slot)]
(return (` (get@ (~ (tag$ slot)) (~ so-far))))
- (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS slot)) args))))
+ (\ [_ (#FormS (list& [_ (#SymbolS slot)] args))])
(return (` ((get@ (~ (tag$ slot)) (~ so-far))
(~@ args))))
@@ -3016,7 +2995,7 @@
(defmacro #export (set@ tokens)
(case tokens
- (\ (list (#Meta _ (#TagS slot')) value record))
+ (\ (list [_ (#TagS slot')] value record))
(do Lux/Monad
[slot (normalize slot')
output (resolve-tag slot)
@@ -3051,7 +3030,7 @@
(defmacro #export (update@ tokens)
(case tokens
- (\ (list (#Meta _ (#TagS slot')) fun record))
+ (\ (list [_ (#TagS slot')] fun record))
(do Lux/Monad
[slot (normalize slot')
output (resolve-tag slot)
@@ -3086,9 +3065,9 @@
(defmacro #export (\template tokens)
(case tokens
- (\ (list (#Meta _ (#TupleS data))
- (#Meta _ (#TupleS bindings))
- (#Meta _ (#TupleS templates))))
+ (\ (list [_ (#TupleS data)]
+ [_ (#TupleS bindings)]
+ [_ (#TupleS templates)]))
(case (: (Maybe (List AST))
(do Maybe/Monad
[bindings' (map% Maybe/Monad get-name bindings)
@@ -3171,7 +3150,7 @@
(defmacro #export (loop tokens)
(case tokens
- (\ (list (#Meta _ (#TupleS bindings)) body))
+ (\ (list [_ (#TupleS bindings)] body))
(let [pairs (as-pairs bindings)
vars (map first pairs)
inits (map second pairs)]
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index 8c88328f5..41a59fc00 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 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)))
+ [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)))
_
(fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token)))))
(defn ^:private parse-tag [ast]
(|case ast
- (&/$Meta _ (&/$TagS "" name))
+ [_ (&/$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 (&/$Meta _ (&/$SymbolS _ "_jvm_new-array"))
- (&/$Cons (&/$Meta _ (&/$SymbolS _ ?class))
- (&/$Cons (&/$Meta _ (&/$IntS ?length))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new-array")]
+ (&/$Cons [_ (&/$SymbolS _ ?class)]
+ (&/$Cons [_ (&/$IntS ?length)]
(&/$Nil)))))
(&&host/analyse-jvm-new-array analyse ?class ?length)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aastore"))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")]
(&/$Cons ?array
- (&/$Cons (&/$Meta _ (&/$IntS ?idx))
+ (&/$Cons [_ (&/$IntS ?idx)]
(&/$Cons ?elem
(&/$Nil))))))
(&&host/analyse-jvm-aastore analyse ?array ?idx ?elem)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aaload"))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")]
(&/$Cons ?array
- (&/$Cons (&/$Meta _ (&/$IntS ?idx))
+ (&/$Cons [_ (&/$IntS ?idx)]
(&/$Nil)))))
(&&host/analyse-jvm-aaload analyse ?array ?idx)
;; Classes & interfaces
- (&/$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))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_class")]
+ (&/$Cons [_ (&/$TextS ?name)]
+ (&/$Cons [_ (&/$TextS ?super-class)]
+ (&/$Cons [_ (&/$TupleS ?interfaces)]
+ (&/$Cons [_ (&/$TupleS ?fields)]
+ (&/$Cons [_ (&/$TupleS ?methods)]
(&/$Nil))))))))
(&&host/analyse-jvm-class analyse compile-token ?name ?super-class ?interfaces ?fields ?methods)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_interface"))
- (&/$Cons (&/$Meta _ (&/$TextS ?name))
- (&/$Cons (&/$Meta _ (&/$TupleS ?supers))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_interface")]
+ (&/$Cons [_ (&/$TextS ?name)]
+ (&/$Cons [_ (&/$TupleS ?supers)]
?methods))))
(&&host/analyse-jvm-interface analyse compile-token ?name ?supers ?methods)
;; Programs
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_program"))
- (&/$Cons (&/$Meta _ (&/$SymbolS "" ?args))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_program")]
+ (&/$Cons [_ (&/$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 (&/$Meta _ (&/$SymbolS _ "_jvm_d2f")) (&/$Cons ?value (&/$Nil))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2f")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-d2f analyse exo-type ?value)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2i")) (&/$Cons ?value (&/$Nil))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2i")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-d2i analyse exo-type ?value)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2l")) (&/$Cons ?value (&/$Nil))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2l")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-d2l analyse exo-type ?value)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2d")) (&/$Cons ?value (&/$Nil))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2d")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-f2d analyse exo-type ?value)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2i")) (&/$Cons ?value (&/$Nil))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2i")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-f2i analyse exo-type ?value)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2l")) (&/$Cons ?value (&/$Nil))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2l")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-f2l analyse exo-type ?value)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2b")) (&/$Cons ?value (&/$Nil))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2b")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-i2b analyse exo-type ?value)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2c")) (&/$Cons ?value (&/$Nil))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2c")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-i2c analyse exo-type ?value)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2d")) (&/$Cons ?value (&/$Nil))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2d")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-i2d analyse exo-type ?value)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2f")) (&/$Cons ?value (&/$Nil))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2f")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-i2f analyse exo-type ?value)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2l")) (&/$Cons ?value (&/$Nil))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2l")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-i2l analyse exo-type ?value)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2s")) (&/$Cons ?value (&/$Nil))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2s")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-i2s analyse exo-type ?value)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2d")) (&/$Cons ?value (&/$Nil))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2d")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-l2d analyse exo-type ?value)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2f")) (&/$Cons ?value (&/$Nil))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2f")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-l2f analyse exo-type ?value)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2i")) (&/$Cons ?value (&/$Nil))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2i")] (&/$Cons ?value (&/$Nil))))
(&&host/analyse-jvm-l2i analyse exo-type ?value)
;; Bitwise operators
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iand")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iand")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-iand analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ior")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ior")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-ior analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ixor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ixor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-ixor analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-ishl analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-ishr analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-iushr analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_land")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_land")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-land analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-lor analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lxor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lxor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-lxor analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-lshl analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-lshr analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$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 (&/$Meta _ (&/$SymbolS _ "_jvm_null?"))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_null?")]
(&/$Cons ?object
(&/$Nil))))
(&&host/analyse-jvm-null? analyse exo-type ?object)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_instanceof"))
- (&/$Cons (&/$Meta _ (&/$TextS ?class))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_instanceof")]
+ (&/$Cons [_ (&/$TextS ?class)]
(&/$Cons ?object
(&/$Nil)))))
(&&host/analyse-jvm-instanceof analyse exo-type ?class ?object)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_new"))
- (&/$Cons (&/$Meta _ (&/$TextS ?class))
- (&/$Cons (&/$Meta _ (&/$TupleS ?classes))
- (&/$Cons (&/$Meta _ (&/$TupleS ?args))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new")]
+ (&/$Cons [_ (&/$TextS ?class)]
+ (&/$Cons [_ (&/$TupleS ?classes)]
+ (&/$Cons [_ (&/$TupleS ?args)]
(&/$Nil))))))
(&&host/analyse-jvm-new analyse exo-type ?class ?classes ?args)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getstatic"))
- (&/$Cons (&/$Meta _ (&/$TextS ?class))
- (&/$Cons (&/$Meta _ (&/$TextS ?field))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getstatic")]
+ (&/$Cons [_ (&/$TextS ?class)]
+ (&/$Cons [_ (&/$TextS ?field)]
(&/$Nil)))))
(&&host/analyse-jvm-getstatic analyse exo-type ?class ?field)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getfield"))
- (&/$Cons (&/$Meta _ (&/$TextS ?class))
- (&/$Cons (&/$Meta _ (&/$TextS ?field))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getfield")]
+ (&/$Cons [_ (&/$TextS ?class)]
+ (&/$Cons [_ (&/$TextS ?field)]
(&/$Cons ?object
(&/$Nil))))))
(&&host/analyse-jvm-getfield analyse exo-type ?class ?field ?object)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putstatic"))
- (&/$Cons (&/$Meta _ (&/$TextS ?class))
- (&/$Cons (&/$Meta _ (&/$TextS ?field))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putstatic")]
+ (&/$Cons [_ (&/$TextS ?class)]
+ (&/$Cons [_ (&/$TextS ?field)]
(&/$Cons ?value
(&/$Nil))))))
(&&host/analyse-jvm-putstatic analyse exo-type ?class ?field ?value)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putfield"))
- (&/$Cons (&/$Meta _ (&/$TextS ?class))
- (&/$Cons (&/$Meta _ (&/$TextS ?field))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putfield")]
+ (&/$Cons [_ (&/$TextS ?class)]
+ (&/$Cons [_ (&/$TextS ?field)]
(&/$Cons ?object
(&/$Cons ?value
(&/$Nil)))))))
(&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?object ?value)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokestatic"))
- (&/$Cons (&/$Meta _ (&/$TextS ?class))
- (&/$Cons (&/$Meta _ (&/$TextS ?method))
- (&/$Cons (&/$Meta _ (&/$TupleS ?classes))
- (&/$Cons (&/$Meta _ (&/$TupleS ?args))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokestatic")]
+ (&/$Cons [_ (&/$TextS ?class)]
+ (&/$Cons [_ (&/$TextS ?method)]
+ (&/$Cons [_ (&/$TupleS ?classes)]
+ (&/$Cons [_ (&/$TupleS ?args)]
(&/$Nil)))))))
(&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method ?classes ?args)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokevirtual"))
- (&/$Cons (&/$Meta _ (&/$TextS ?class))
- (&/$Cons (&/$Meta _ (&/$TextS ?method))
- (&/$Cons (&/$Meta _ (&/$TupleS ?classes))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokevirtual")]
+ (&/$Cons [_ (&/$TextS ?class)]
+ (&/$Cons [_ (&/$TextS ?method)]
+ (&/$Cons [_ (&/$TupleS ?classes)]
(&/$Cons ?object
- (&/$Cons (&/$Meta _ (&/$TupleS ?args))
+ (&/$Cons [_ (&/$TupleS ?args)]
(&/$Nil))))))))
(&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method ?classes ?object ?args)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokeinterface"))
- (&/$Cons (&/$Meta _ (&/$TextS ?class))
- (&/$Cons (&/$Meta _ (&/$TextS ?method))
- (&/$Cons (&/$Meta _ (&/$TupleS ?classes))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokeinterface")]
+ (&/$Cons [_ (&/$TextS ?class)]
+ (&/$Cons [_ (&/$TextS ?method)]
+ (&/$Cons [_ (&/$TupleS ?classes)]
(&/$Cons ?object
- (&/$Cons (&/$Meta _ (&/$TupleS ?args))
+ (&/$Cons [_ (&/$TupleS ?args)]
(&/$Nil))))))))
(&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method ?classes ?object ?args)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokespecial"))
- (&/$Cons (&/$Meta _ (&/$TextS ?class))
- (&/$Cons (&/$Meta _ (&/$TextS ?method))
- (&/$Cons (&/$Meta _ (&/$TupleS ?classes))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokespecial")]
+ (&/$Cons [_ (&/$TextS ?class)]
+ (&/$Cons [_ (&/$TextS ?method)]
+ (&/$Cons [_ (&/$TupleS ?classes)]
(&/$Cons ?object
- (&/$Cons (&/$Meta _ (&/$TupleS ?args))
+ (&/$Cons [_ (&/$TupleS ?args)]
(&/$Nil))))))))
(&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method ?classes ?object ?args)
;; Exceptions
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_try"))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_try")]
(&/$Cons ?body
?handlers)))
- (|do [catches+finally (&/fold% parse-handler (&/T (&/|list) (&/V &/$None nil)) ?handlers)]
+ (|do [catches+finally (&/fold% parse-handler (&/P (&/|list) &/None$) ?handlers)]
(&&host/analyse-jvm-try analyse exo-type ?body catches+finally))
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_throw"))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_throw")]
(&/$Cons ?ex
(&/$Nil))))
(&&host/analyse-jvm-throw analyse exo-type ?ex)
;; Syncronization/monitos
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorenter"))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_monitorenter")]
(&/$Cons ?monitor
(&/$Nil))))
(&&host/analyse-jvm-monitorenter analyse exo-type ?monitor)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorexit"))
+ (&/$FormS (&/$Cons [_ (&/$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 (&/$Meta _ (&/$SymbolS _ "_jvm_fadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-fadd analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-fsub analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-fmul analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fdiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fdiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-fdiv analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_frem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_frem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-frem analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_feq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_feq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-feq analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_flt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_flt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-flt analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-fgt analyse exo-type ?x ?y)
;; Double arithmetic
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-dadd analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-dsub analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-dmul analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ddiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ddiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-ddiv analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_drem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_drem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-drem analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_deq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_deq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-deq analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dlt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dlt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-dlt analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$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 (&/$Meta _ (&/$SymbolS _ "_jvm_ceq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ceq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-ceq analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_clt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_clt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-clt analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_cgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-cgt analyse exo-type ?x ?y)
;; Integer arithmetic
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-iadd analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_isub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_isub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-isub analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_imul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_imul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-imul analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_idiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_idiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-idiv analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_irem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_irem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-irem analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ieq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ieq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-ieq analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ilt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ilt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-ilt analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_igt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_igt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-igt analyse exo-type ?x ?y)
;; Long arithmetic
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ladd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ladd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-ladd analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-lsub analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-lmul analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ldiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ldiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-ldiv analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lrem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lrem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-lrem analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_leq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_leq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-leq analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_llt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_llt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
(&&host/analyse-jvm-llt analyse exo-type ?x ?y)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil)))))
+ (&/$FormS (&/$Cons [_ (&/$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 (&/$Meta _ (&/$SymbolS _ "_lux_case"))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_case")]
(&/$Cons ?value ?branches)))
(&&lux/analyse-case analyse exo-type ?value ?branches)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_lambda"))
- (&/$Cons (&/$Meta _ (&/$SymbolS "" ?self))
- (&/$Cons (&/$Meta _ (&/$SymbolS "" ?arg))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_lambda")]
+ (&/$Cons [_ (&/$SymbolS "" ?self)]
+ (&/$Cons [_ (&/$SymbolS "" ?arg)]
(&/$Cons ?body
(&/$Nil))))))
(&&lux/analyse-lambda analyse exo-type ?self ?arg ?body)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_def"))
- (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_def")]
+ (&/$Cons [_ (&/$SymbolS "" ?name)]
(&/$Cons ?value
(&/$Nil)))))
(&&lux/analyse-def analyse compile-token ?name ?value)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-macro"))
- (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-macro")]
+ (&/$Cons [_ (&/$SymbolS "" ?name)]
(&/$Nil))))
(&&lux/analyse-declare-macro analyse compile-token ?name)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-tags"))
- (&/$Cons (&/$Meta _ (&/$TupleS tags))
- (&/$Cons (&/$Meta _ (&/$SymbolS "" type-name))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-tags")]
+ (&/$Cons [_ (&/$TupleS tags)]
+ (&/$Cons [_ (&/$SymbolS "" type-name)]
(&/$Nil)))))
(|do [tags* (&/map% parse-tag tags)]
(&&lux/analyse-declare-tags tags* type-name))
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_import"))
- (&/$Cons (&/$Meta _ (&/$TextS ?path))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_import")]
+ (&/$Cons [_ (&/$TextS ?path)]
(&/$Nil))))
(&&lux/analyse-import analyse compile-module compile-token ?path)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:"))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:")]
(&/$Cons ?type
(&/$Cons ?value
(&/$Nil)))))
(&&lux/analyse-check analyse eval! exo-type ?type ?value)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:!"))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:!")]
(&/$Cons ?type
(&/$Cons ?value
(&/$Nil)))))
(&&lux/analyse-coerce analyse eval! exo-type ?type ?value)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_export"))
- (&/$Cons (&/$Meta _ (&/$SymbolS "" ?ident))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_export")]
+ (&/$Cons [_ (&/$SymbolS "" ?ident)]
(&/$Nil))))
(&&lux/analyse-export analyse compile-token ?ident)
- (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_alias"))
- (&/$Cons (&/$Meta _ (&/$TextS ?alias))
- (&/$Cons (&/$Meta _ (&/$TextS ?module))
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_alias")]
+ (&/$Cons [_ (&/$TextS ?alias)]
+ (&/$Cons [_ (&/$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 (&/T (&/V &&/$bool ?value) exo-type))))
+ (return (&/|list (&/P (&/S &&/$bool ?value) exo-type))))
(&/$IntS ?value)
(|do [_ (&type/check exo-type &type/Int)]
- (return (&/|list (&/T (&/V &&/$int ?value) exo-type))))
+ (return (&/|list (&/P (&/S &&/$int ?value) exo-type))))
(&/$RealS ?value)
(|do [_ (&type/check exo-type &type/Real)]
- (return (&/|list (&/T (&/V &&/$real ?value) exo-type))))
+ (return (&/|list (&/P (&/S &&/$real ?value) exo-type))))
(&/$CharS ?value)
(|do [_ (&type/check exo-type &type/Char)]
- (return (&/|list (&/T (&/V &&/$char ?value) exo-type))))
+ (return (&/|list (&/P (&/S &&/$char ?value) exo-type))))
(&/$TextS ?value)
(|do [_ (&type/check exo-type &type/Text)]
- (return (&/|list (&/T (&/V &&/$text ?value) exo-type))))
+ (return (&/|list (&/P (&/S &&/$text ?value) exo-type))))
(&/$TupleS ?elems)
(&&lux/analyse-tuple analyse exo-type ?elems)
@@ -528,20 +528,21 @@
(defn ^:private analyse-basic-ast [analyse eval! compile-module compile-token exo-type token]
;; (prn 'analyse-basic-ast (&/show-ast token))
(|case token
- (&/$Meta meta ?token)
+ [meta ?token]
(fn [state]
- (|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)))))
+ (|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)))))
(&/$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))
))
))
@@ -553,42 +554,44 @@
[(&/$VarT ?e-id) (&/$VarT ?a-id)]
(if (= ?e-id ?a-id)
(|do [?output-type* (&type/deref ?e-id)]
- (return (&/T ?output-term ?output-type*)))
- (return (&/T ?output-term ?output-type)))
+ (return (&/P ?output-term ?output-type*)))
+ (return (&/P ?output-term ?output-type)))
[_ _]
- (return (&/T ?output-term ?output-type)))
+ (return (&/P ?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))
- (&/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)))))
+ (|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))))))
;; [Resources]
(defn analyse [eval! compile-module compile-token]
diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj
index fe1e0d55b..622f0b853 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"
- "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"
-
- )
+(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"
+ ])
;; [Exports]
(defn expr-type [syntax+]
@@ -147,4 +147,4 @@
(|do [module* (if (.equals "" ?module)
&/get-module-name
(return ?module))]
- (return (&/T module* ?name)))))
+ (return (&/P module* ?name)))))
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index 483002adc..aab25d741 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,31 +18,31 @@
[record :as &&record])))
;; [Tags]
-(deftags ""
- "DefaultTotal"
- "BoolTotal"
- "IntTotal"
- "RealTotal"
- "CharTotal"
- "TextTotal"
- "TupleTotal"
- "VariantTotal"
+(deftags
+ ["DefaultTotal"
+ "BoolTotal"
+ "IntTotal"
+ "RealTotal"
+ "CharTotal"
+ "TextTotal"
+ "ProdTotal"
+ "SumTotal"]
)
-(deftags ""
- "StoreTestAC"
- "BoolTestAC"
- "IntTestAC"
- "RealTestAC"
- "CharTestAC"
- "TextTestAC"
- "TupleTestAC"
- "VariantTestAC"
+(deftags
+ ["StoreTestAC"
+ "BoolTestAC"
+ "IntTestAC"
+ "RealTestAC"
+ "CharTestAC"
+ "TextTestAC"
+ "ProdTestAC"
+ "SumTestAC"]
)
;; [Utils]
(def ^:private unit
- (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS (&/|list)))))
+ (&/P (&/cursor$ "" -1 -1) (&/S &/$TupleS (&/|list))))
(defn ^:private resolve-type [type]
(|case type
@@ -64,74 +64,66 @@
_
(&type/actual-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)))
- ))
+(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 [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)
+ 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]
+ (|let [[_ pattern*] pattern]
(|case pattern*
(&/$SymbolS "" name)
(|do [=kont (&env/with-local name value-type
kont)
idx &env/next-local-idx]
- (return (&/T (&/V $StoreTestAC idx) =kont)))
+ (return (&/P (&/S $StoreTestAC idx) =kont)))
(&/$SymbolS ident)
(fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident)))
@@ -139,194 +131,152 @@
(&/$BoolS ?value)
(|do [_ (&type/check value-type &type/Bool)
=kont kont]
- (return (&/T (&/V $BoolTestAC ?value) =kont)))
+ (return (&/P (&/S $BoolTestAC ?value) =kont)))
(&/$IntS ?value)
(|do [_ (&type/check value-type &type/Int)
=kont kont]
- (return (&/T (&/V $IntTestAC ?value) =kont)))
+ (return (&/P (&/S $IntTestAC ?value) =kont)))
(&/$RealS ?value)
(|do [_ (&type/check value-type &type/Real)
=kont kont]
- (return (&/T (&/V $RealTestAC ?value) =kont)))
+ (return (&/P (&/S $RealTestAC ?value) =kont)))
(&/$CharS ?value)
(|do [_ (&type/check value-type &type/Char)
=kont kont]
- (return (&/T (&/V $CharTestAC ?value) =kont)))
+ (return (&/P (&/S $CharTestAC ?value) =kont)))
(&/$TextS ?value)
(|do [_ (&type/check value-type &type/Text)
=kont kont]
- (return (&/T (&/V $TextTestAC ?value) =kont)))
+ (return (&/P (&/S $TextTestAC ?value) =kont)))
- (&/$TupleS ?members)
+ (&/$TupleS (&/$Cons ?_left ?tail))
(|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*
- (&/$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))))
+ (&/$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 (&/S &/$TupleS ?tail) kont))]
+ (return (&/P =right =kont))))]
+ (return (&/P (&/S $ProdTestAC =left =right) =kont)))
_
- (fail "[Pattern-matching Error] Record requires record-type.")))
+ (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 (&/S &/$TupleS ?members) kont))
(&/$TagS ?ident)
- (|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)))
+ (|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 (&/$Meta _ (&/$TagS ?ident))
+ (&/$FormS (&/$Cons [_ (&/$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))]
+ (|do [[idx group-count case-type] (resolve-tag ?ident value-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 (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont))
+ (analyse-pattern case-type (&/P (&/cursor$ "" -1 -1) (&/S &/$TupleS ?values)) kont))
;; :let [_ (println "#15")]
]
- (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont)))
+ (return (&/P (&/S $SumTestAC ($$ &/P idx group-count =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 (&/V $DefaultTotal true))
+ (return (&/S $DefaultTotal true))
[[?tag [total? ?values]] ($StoreTestAC ?idx)]
- (return (&/V ?tag (&/T true ?values)))
+ (return (&/S ?tag (&/P true ?values)))
[($DefaultTotal total?) ($BoolTestAC ?value)]
- (return (&/V $BoolTotal (&/T total? (&/|list ?value))))
+ (return (&/S $BoolTotal (&/P total? (&/|list ?value))))
[($BoolTotal total? ?values) ($BoolTestAC ?value)]
- (return (&/V $BoolTotal (&/T total? (&/|cons ?value ?values))))
+ (return (&/S $BoolTotal (&/P total? (&/Cons$ ?value ?values))))
[($DefaultTotal total?) ($IntTestAC ?value)]
- (return (&/V $IntTotal (&/T total? (&/|list ?value))))
+ (return (&/S $IntTotal (&/P total? (&/|list ?value))))
[($IntTotal total? ?values) ($IntTestAC ?value)]
- (return (&/V $IntTotal (&/T total? (&/|cons ?value ?values))))
+ (return (&/S $IntTotal (&/P total? (&/Cons$ ?value ?values))))
[($DefaultTotal total?) ($RealTestAC ?value)]
- (return (&/V $RealTotal (&/T total? (&/|list ?value))))
+ (return (&/S $RealTotal (&/P total? (&/|list ?value))))
[($RealTotal total? ?values) ($RealTestAC ?value)]
- (return (&/V $RealTotal (&/T total? (&/|cons ?value ?values))))
+ (return (&/S $RealTotal (&/P total? (&/Cons$ ?value ?values))))
[($DefaultTotal total?) ($CharTestAC ?value)]
- (return (&/V $CharTotal (&/T total? (&/|list ?value))))
+ (return (&/S $CharTotal (&/P total? (&/|list ?value))))
[($CharTotal total? ?values) ($CharTestAC ?value)]
- (return (&/V $CharTotal (&/T total? (&/|cons ?value ?values))))
+ (return (&/S $CharTotal (&/P total? (&/Cons$ ?value ?values))))
[($DefaultTotal total?) ($TextTestAC ?value)]
- (return (&/V $TextTotal (&/T total? (&/|list ?value))))
+ (return (&/S $TextTotal (&/P total? (&/|list ?value))))
[($TextTotal total? ?values) ($TextTestAC ?value)]
- (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?)))
+ (return (&/S $TextTotal (&/P total? (&/Cons$ ?value ?values))))
+
+ [($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?)))
(&/$Some list)
(return list)
(&/$None)
(fail "[Pattern-matching Error] YOLO"))]
- (return (&/V $VariantTotal (&/T total? structs))))
+ (return (&/S $SumTotal (&/P total? structs))))
- [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)]
+ [($SumTotal total? ?branches) ($SumTestAC ?tag ?count ?test)]
(|do [sub-struct (merge-total (|case (&/|at ?tag ?branches)
(&/$Some sub)
sub
(&/$None)
- (&/V $DefaultTotal total?))
- (&/T ?test ?body))
+ (&/S $DefaultTotal total?))
+ (&/P ?test ?body))
structs (|case (&/|list-put ?tag sub-struct ?branches)
(&/$Some list)
(return list)
(&/$None)
(fail "[Pattern-matching Error] YOLO"))]
- (return (&/V $VariantTotal (&/T total? structs))))
+ (return (&/S $SumTotal (&/P total? structs))))
))))
(defn ^:private check-totality [value-type struct]
@@ -351,33 +301,36 @@
($TextTotal ?total _)
(return ?total)
- ($TupleTotal ?total ?structs)
+ ($ProdTotal ?total ?_left ?_right)
(if ?total
(return true)
(|do [value-type* (resolve-type value-type)]
(|case value-type*
- (&/$TupleT ?members)
- (|do [totals (&/map2% (fn [sub-struct ?member]
- (check-totality ?member sub-struct))
- ?structs ?members)]
- (return (&/fold #(and %1 %2) true totals)))
+ (&/$ProdT ?left ?right)
+ (|do [=left (check-totality ?left ?_left)
+ =right (check-totality ?right ?_right)]
+ (return (and =left =right)))
_
(fail "[Pattern-maching Error] Tuple is not total."))))
- ($VariantTotal ?total ?structs)
+ ($SumTotal ?total ?structs)
(if ?total
(return true)
(|do [value-type* (resolve-type value-type)]
- (|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)))
+ (|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 ($SumTotal ?total ?tail)))]
+ (return (and =left =right)))
_
(fail "[Pattern-maching Error] Variant is not total."))))
@@ -394,7 +347,7 @@
(analyse-branch analyse exo-type value-type pattern body patterns)))
(&/|list)
branches)
- struct (&/fold% merge-total (&/V $DefaultTotal false) patterns)
+ struct (&/fold% merge-total (&/S $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 4e9dcd79f..5686700e3 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 (&/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))]
+ (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))]
(|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 64f297994..69aa95f12 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
- (&/$Meta _ (&/$TextS ?text))
+ [_ (&/$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 (&/T ?item =type))))))
+ (return (&/P ?item =type))))))
(defn ^:private ensure-object [token]
"(-> Analysis (Lux (,)))"
@@ -47,20 +47,20 @@
"(-> Type Type)"
(|case type
(&/$DataT class)
- (&/V &/$DataT (&type/as-obj class))
+ (&type/Data$ (&type/as-obj class))
_
type))
;; [Resources]
(do-template [<name> <output-tag> <input-class> <output-class>]
- (let [input-type (&/V &/$DataT <input-class>)
- output-type (&/V &/$DataT <output-class>)]
+ (let [input-type (&type/Data$ <input-class>)
+ output-type (&type/Data$ <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 (&/T (&/V <output-tag> (&/T =x =y)) output-type))))))
+ (return (&/|list (&/P (&/S <output-tag> (&/P =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 (&/T (&/V &&/$jvm-getstatic (&/T ?class ?field)) output-type)))))
+ (return (&/|list (&/P (&/S &&/$jvm-getstatic (&/P ?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 (&/T (&/V &&/$jvm-getfield (&/T ?class ?field =object)) output-type)))))
+ (return (&/|list (&/P (&/S &&/$jvm-getfield ($$ &/P ?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 (&/T (&/V &&/$jvm-putstatic (&/T ?class ?field =value)) output-type)))))
+ (return (&/|list (&/P (&/S &&/$jvm-putstatic ($$ &/P ?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 (&/T (&/V &&/$jvm-putfield (&/T ?class ?field =object =value)) output-type)))))
+ (return (&/|list (&/P (&/S &&/$jvm-putfield ($$ &/P ?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 (&/V &/$DataT _class) _arg))
+ (&&/analyse-1 analyse (&type/Data$ _class) _arg))
=classes
?args)
:let [output-type =return]
_ (&type/check exo-type output-type)]
- (return (&/|list (&/T (&/V &&/$jvm-invokestatic (&/T ?class ?method =classes =args)) output-type)))))
+ (return (&/|list (&/P (&/S &&/$jvm-invokestatic ($$ &/P ?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 (&/T (&/V &&/$jvm-instanceof (&/T ?class =object)) output-type)))))
+ (return (&/|list (&/P (&/S &&/$jvm-instanceof (&/P ?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 (&/V &/$DataT ?class) ?object)
- =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o))
+ =object (&&/analyse-1 analyse (&type/Data$ ?class) ?object)
+ =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&type/Data$ ?c) ?o))
=classes ?args)
:let [output-type =return]
_ (&type/check exo-type output-type)]
- (return (&/|list (&/T (&/V <tag> (&/T ?class ?method =classes =object =args)) output-type)))))
+ (return (&/|list (&/P (&/S <tag> ($$ &/P ?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 (&/V &/$DataT ?class) ?object)
+ =object (&&/analyse-1 analyse (&type/Data$ ?class) ?object)
=args (&/map2% (fn [?c ?o]
- (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o))
+ (&&/analyse-1 analyse (&type/Data$ ?c) ?o))
=classes ?args)
:let [output-type =return]
_ (&type/check exo-type output-type)]
- (return (&/|list (&/T (&/V &&/$jvm-invokespecial (&/T ?class ?method =classes =object =args)) output-type)))))
+ (return (&/|list (&/P (&/S &&/$jvm-invokespecial ($$ &/P ?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 (&/T (&/V &&/$jvm-null? =object) output-type)))))
+ (return (&/|list (&/P (&/S &&/$jvm-null? =object) output-type)))))
(defn analyse-jvm-null [analyse exo-type]
- (|do [:let [output-type (&/V &/$DataT "null")]
+ (|do [:let [output-type (&type/Data$ "null")]
_ (&type/check exo-type output-type)]
- (return (&/|list (&/T (&/V &&/$jvm-null nil) output-type)))))
+ (return (&/|list (&/P (&/S &&/$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 (&/V &/$DataT ?class)]
+ :let [output-type (&type/Data$ ?class)]
_ (&type/check exo-type output-type)]
- (return (&/|list (&/T (&/V &&/$jvm-new (&/T ?class =classes =args)) output-type)))))
+ (return (&/|list (&/P (&/S &&/$jvm-new ($$ &/P ?class =classes =args)) output-type)))))
(defn analyse-jvm-new-array [analyse ?class ?length]
- (return (&/|list (&/T (&/V &&/$jvm-new-array (&/T ?class ?length)) (&/V "array" (&/T (&/V &/$DataT ?class)
- (&/V &/$Nil nil)))))))
+ (return (&/|list (&/P (&/S &&/$jvm-new-array (&/P ?class ?length)) (&/S "array" (&/P (&type/Data$ ?class)
+ (&/S &/$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 (&/T (&/V &&/$jvm-aastore (&/T =array ?idx =elem)) =array-type)))))
+ (return (&/|list (&/P (&/S &&/$jvm-aastore ($$ &/P =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 (&/T (&/V &&/$jvm-aaload (&/T =array ?idx)) =array-type)))))
+ (return (&/|list (&/P (&/S &&/$jvm-aaload (&/P =array ?idx)) =array-type)))))
(defn ^:private analyse-modifiers [modifiers]
(&/fold% (fn [so-far modif]
(|case modif
- (&/$Meta _ (&/$TextS "public"))
+ [_ (&/$TextS "public")]
(return (assoc so-far :visibility "public"))
- (&/$Meta _ (&/$TextS "private"))
+ [_ (&/$TextS "private")]
(return (assoc so-far :visibility "private"))
- (&/$Meta _ (&/$TextS "protected"))
+ [_ (&/$TextS "protected")]
(return (assoc so-far :visibility "protected"))
- (&/$Meta _ (&/$TextS "static"))
+ [_ (&/$TextS "static")]
(return (assoc so-far :static? true))
- (&/$Meta _ (&/$TextS "final"))
+ [_ (&/$TextS "final")]
(return (assoc so-far :final? true))
- (&/$Meta _ (&/$TextS "abstract"))
+ [_ (&/$TextS "abstract")]
(return (assoc so-far :abstract? true))
- (&/$Meta _ (&/$TextS "synchronized"))
+ [_ (&/$TextS "synchronized")]
(return (assoc so-far :concurrency "synchronized"))
- (&/$Meta _ (&/$TextS "volatile"))
+ [_ (&/$TextS "volatile")]
(return (assoc so-far :concurrency "volatile"))
_
@@ -275,10 +275,10 @@
(|do [=interfaces (&/map% extract-text ?interfaces)
=fields (&/map% (fn [?field]
(|case ?field
- (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?field-name))
- (&/$Cons (&/$Meta _ (&/$TextS ?field-type))
- (&/$Cons (&/$Meta _ (&/$TupleS ?field-modifiers))
- (&/$Nil))))))
+ [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)]
+ (&/$Cons [_ (&/$TextS ?field-type)]
+ (&/$Cons [_ (&/$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 (&/$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))))))))]
+ [?idx [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)]
+ (&/$Cons [_ (&/$TupleS ?method-inputs)]
+ (&/$Cons [_ (&/$TextS ?method-output)]
+ (&/$Cons [_ (&/$TupleS ?method-modifiers)]
+ (&/$Cons ?method-body
+ (&/$Nil)))))))]]
(|do [=method-inputs (&/map% (fn [minput]
(|case minput
- (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS "" ?input-name))
- (&/$Cons (&/$Meta _ (&/$TextS ?input-type))
- (&/$Nil)))))
- (return (&/T ?input-name ?input-type))
+ [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" ?input-name)]
+ (&/$Cons [_ (&/$TextS ?input-type)]
+ (&/$Nil))))]
+ (return (&/P ?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 (&/V &/$DataT (as-otype itype))
+ (&&env/with-local iname (&type/Data$ (as-otype itype))
body*)))
(if (= "void" ?method-output)
(analyse-1+ analyse ?method-body)
- (&&/analyse-1 analyse (&/V &/$DataT (as-otype ?method-output)) ?method-body))
+ (&&/analyse-1 analyse (&type/Data$ (as-otype ?method-output)) ?method-body))
(&/|reverse (if (:static? =method-modifiers)
=method-inputs
- (&/|cons (&/T ";this" ?super-class)
+ (&/Cons$ (&/P "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 (&/V &&/$jvm-class (&/T ?name ?super-class =interfaces =fields =methods)))]
+ _ (compile-token (&/S &&/$jvm-class ($$ &/P ?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
- (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?method-name))
- (&/$Cons (&/$Meta _ (&/$TupleS ?inputs))
- (&/$Cons (&/$Meta _ (&/$TextS ?output))
- (&/$Cons (&/$Meta _ (&/$TupleS ?modifiers))
- (&/$Nil)))))))
+ [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)]
+ (&/$Cons [_ (&/$TupleS ?inputs)]
+ (&/$Cons [_ (&/$TextS ?output)]
+ (&/$Cons [_ (&/$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 (&/V &&/$jvm-interface (&/T ?name =supers =methods)))]
+ _ (compile-token (&/S &&/$jvm-interface ($$ &/P ?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 (&/V &/$DataT ?ex-class)
+ (|do [=catch-body (&&env/with-local ?ex-arg (&type/Data$ ?ex-class)
(&&/analyse-1 analyse exo-type ?catch-body))
idx &&env/next-local-idx]
- (return (&/T ?ex-class idx =catch-body))))
+ (return ($$ &/P ?ex-class idx =catch-body))))
?catches)
- =finally (|case [?finally]
- (&/$None) (return (&/V &/$None nil))
+ =finally (|case ?finally
+ (&/$None) (return &/None$)
(&/$Some ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)]
- (return (&/V &/$Some =finally))))]
- (return (&/|list (&/T (&/V &&/$jvm-try (&/T =body =catches =finally)) exo-type)))))
+ (return (&/Some$ =finally))))]
+ (return (&/|list (&/P (&/S &&/$jvm-try ($$ &/P =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 (&/V &/$DataT "java.lang.Throwable") _type)]
- (return (&/|list (&/T (&/V &&/$jvm-throw =ex) &type/$Void)))))
+ _ (&type/check (&type/Data$ "java.lang.Throwable") _type)]
+ (return (&/|list (&/P (&/S &&/$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 (&/T (&/V <tag> =monitor) output-type)))))
+ (return (&/|list (&/P (&/S <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 (&/V &/$DataT <to-class>)]
+ (let [output-type (&type/Data$ <to-class>)]
(defn <name> [analyse exo-type ?value]
- (|do [=value (&&/analyse-1 analyse (&/V &/$DataT <from-class>) ?value)
+ (|do [=value (&&/analyse-1 analyse (&type/Data$ <from-class>) ?value)
_ (&type/check exo-type output-type)]
- (return (&/|list (&/T (&/V <tag> =value) output-type))))))
+ (return (&/|list (&/P (&/S <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 (&/V &/$DataT <to-class>)]
+ (let [output-type (&type/Data$ <to-class>)]
(defn <name> [analyse exo-type ?value]
- (|do [=value (&&/analyse-1 analyse (&/V &/$DataT <from-class>) ?value)
+ (|do [=value (&&/analyse-1 analyse (&type/Data$ <from-class>) ?value)
_ (&type/check exo-type output-type)]
- (return (&/|list (&/T (&/V <tag> =value) output-type))))))
+ (return (&/|list (&/P (&/S <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 (&/V &/$AppT (&/T &type/List &type/Text))
- (&&/analyse-1 analyse (&/V &/$AppT (&/T &type/IO &type/Unit)) ?body)))
- _ (compile-token (&/V &&/$jvm-program =body))]
+ (&&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))]
(return (&/|list))))
diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj
index aeb5a4814..696c816e9 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,15 +22,19 @@
(&env/with-local arg arg-type
(|do [=return body
=captured &env/captured-vars]
- (return (&/T scope-name =captured =return))))))))
+ (return ($$ &/P scope-name =captured =return))))))))
(defn close-over [scope name register frame]
(|let [[_ register-type] register
- register* (&/T (&/V &&/$captured (&/T scope
- (->> frame (&/get$ &/$closure) (&/get$ &/$counter))
- register))
+ register* (&/P (&/S &&/$captured ($$ &/P scope
+ (->> frame (&/$get-closure) (&/$get-counter))
+ register))
register-type)]
- (&/T register* (&/update$ &/$closure #(->> %
- (&/update$ &/$counter inc)
- (&/update$ &/$mappings (fn [mps] (&/|put name register* mps))))
- frame))))
+ (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)))))
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index d241201f4..f7ed07ee4 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,52 +27,64 @@
(|do [=expr (&&/analyse-1 analyse $var ?token)
:let [[?item ?type] =expr]
=type (&type/clean $var ?type)]
- (return (&/T ?item =type))))))
+ (return (&/P ?item =type))))))
(defn ^:private with-cursor [cursor form]
(|case form
- (&/$Meta _ syntax)
- (&/V &/$Meta (&/T cursor syntax))))
+ [_ syntax]
+ (&/P cursor syntax)))
;; [Exports]
(defn analyse-tuple [analyse exo-type ?elems]
- (|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))))
-
- _
- (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)
+ ;; (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))))
- _
- (analyse-tuple analyse exo-type ?values)
- )]
- (|case output
- (&/$Cons x (&/$Nil))
- (return x)
+ (&/$AllT _)
+ (&type/with-var
+ (fn [$var]
+ (|do [exo-type** (&type/apply-type exo-type* $var)]
+ (analyse-tuple analyse exo-type** ?elems))))
- _
- (fail "[Analyser Error] Can't expand to other than 1 element."))))
+ _
+ (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))))
+ ))
(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)]
@@ -83,82 +95,41 @@
_
(&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))))
-
- _
- (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 [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))))
+ ?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))))
+ )))
- _
- (&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 analyse-record [analyse exo-type ?elems]
+ (|do [members (&&record/order-record ?elems)]
+ (analyse-tuple analyse exo-type members)))
(defn ^:private analyse-global [analyse exo-type module name]
(|do [[[r-module r-name] $def] (&&module/find-def module name)
@@ -177,14 +148,17 @@
(clojure.lang.Util/identical &type/Type exo-type))
(return nil)
(&type/check exo-type endo-type))]
- (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name)))
+ (return (&/|list (&/P (&/S &&/$var (&/S &/$Global (&/P r-module r-name)))
endo-type)))))
(defn ^:private analyse-local [analyse exo-type name]
(fn [state]
- (|let [stack (&/get$ &/$envs state)
- no-binding? #(and (->> % (&/get$ &/$locals) (&/get$ &/$mappings) (&/|contains? name) not)
- (->> % (&/get$ &/$closure) (&/get$ &/$mappings) (&/|contains? name) not))
+ (|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)))
[inner outer] (&/|split-with no-binding? stack)]
(|case outer
(&/$Nil)
@@ -193,8 +167,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*) _]
@@ -213,32 +187,31 @@
(clojure.lang.Util/identical &type/Type exo-type))
(return nil)
(&type/check exo-type endo-type))]
- (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name)))
+ (return (&/|list (&/P (&/S &&/$var (&/S &/$Global (&/P r-module r-name)))
endo-type))))
state)
- [_]
- (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* "[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)]
- (&/T register* (&/|cons frame* new-inner))))
- (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))
- (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name)))
+ (&/P register* (&/Cons$ frame* new-inner))))
+ (&/P (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)
_ (&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]
@@ -253,7 +226,7 @@
(|case ?args
(&/$Nil)
(|do [_ (&type/check exo-type fun-type)]
- (return (&/T fun-type (&/|list))))
+ (return (&/P fun-type (&/|list))))
(&/$Cons ?arg ?args*)
(|do [?fun-type* (&type/actual-type fun-type)]
@@ -271,15 +244,15 @@
(|do [? (&type/bound? ?id)
type** (if ?
(&type/clean $var =output-t)
- (|do [_ (&type/set-var ?id (&/V &/$BoundT _aarg))]
+ (|do [_ (&type/set-var ?id (&/S &/$BoundT _aarg))]
(&type/clean $var =output-t)))]
- (return (&/T type** =args)))
+ (return (&/P 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 (&/T =output-t (&/|cons =arg =args))))
+ (return (&/P =output-t (&/Cons$ =arg =args))))
;; [[&/$VarT ?id-t]]
;; (|do [ (&type/deref ?id-t)])
@@ -313,12 +286,12 @@
_
(|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)]
- (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args))
+ (return (&/|list (&/P (&/S &&/$apply (&/P =fn =args))
=output-t))))))
_
(|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)]
- (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args))
+ (return (&/|list (&/P (&/S &&/$apply (&/P =fn =args))
=output-t)))))
)))
@@ -329,7 +302,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 (&/T (&/V &&/$case (&/T =value =match))
+ (return (&/|list (&/P (&/S &&/$case (&/P =value =match))
exo-type)))))
(defn analyse-lambda* [analyse exo-type ?self ?arg ?body]
@@ -348,7 +321,7 @@
(|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type*
?arg ?arg-t
(&&/analyse-1 analyse ?return-t ?body))]
- (return (&/T (&/V &&/$lambda (&/T =scope =captured =body)) exo-type*)))
+ (return (&/P (&/S &&/$lambda ($$ &/P =scope =captured =body)) exo-type*)))
_
(fail (str "[Analyser Error] Functions require function types: "
@@ -370,22 +343,22 @@
]
(|case dtype
(&/$BoundT ?vname)
- (return (&/T _expr exo-type))
+ (return (&/P _expr exo-type))
(&/$ExT _)
- (return (&/T _expr exo-type))
+ (return (&/P _expr exo-type))
(&/$VarT ?_id)
(|do [?? (&type/bound? ?_id)]
- ;; (return (&/T _expr exo-type))
+ ;; (return (&/P _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 (&/T _expr exo-type)))
+ (return (&/P _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 (&/T _expr exo-type))))))))
+ (return (&/P _expr exo-type))))))))
_
(|do [exo-type* (&type/actual-type exo-type)]
@@ -418,7 +391,7 @@
_
(do ;; (println 'DEF (str module-name ";" ?name))
- (|do [_ (compile-token (&/V &&/$def (&/T ?name =value)))
+ (|do [_ (compile-token (&/S &&/$def (&/P ?name =value)))
:let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name))
_ (println 'DEF (str module-name ";" ?name))]]
(return (&/|list)))))
@@ -428,16 +401,16 @@
(|do [;; :let [_ (prn 'analyse-declare-macro ?name "0")]
module-name &/get-module-name
;; :let [_ (prn 'analyse-declare-macro ?name "1")]
- _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))
+ _ (compile-token (&/S &&/$declare-macro (&/P 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 (&/T module-name type-name)) (&/->seq tags))]
+ ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/P module-name type-name)) (&/->seq tags))]
[_ def-data] (&&module/find-def module-name type-name)
- ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags) (&/adt->text def-data))]
+ ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/P 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))))
@@ -469,7 +442,7 @@
==type (eval! =type)
_ (&type/check exo-type ==type)
=value (&&/analyse-1 analyse ==type ?value)]
- (return (&/|list (&/T (&/V &&/$ann (&/T =value =type))
+ (return (&/|list (&/P (&/S &&/$ann (&/P =value =type))
==type)))))
(defn analyse-coerce [analyse eval! exo-type ?type ?value]
@@ -477,5 +450,5 @@
==type (eval! =type)
_ (&type/check exo-type ==type)
=value (analyse-1+ analyse ?value)]
- (return (&/|list (&/T (&/V &&/$ann (&/T =value =type))
+ (return (&/|list (&/P (&/S &&/$ann (&/P =value =type))
==type)))))
diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj
index d23953f5e..909e7e2c4 100644
--- a/src/lux/analyser/module.clj
+++ b/src/lux/analyser/module.clj
@@ -12,69 +12,70 @@
[template :refer [do-template]])
clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]]
+ (lux [base :as & :refer [defrtags |let |do return return* fail fail* |case $$]]
[type :as &type]
[host :as &host])))
;; [Utils]
-(deftags ""
- "module-aliases"
- "defs"
- "imports"
- "tags"
- "types")
+(defrtags
+ ["module-aliases"
+ "defs"
+ "imports"
+ "tags"
+ "types"])
(def ^:private +init+
- (&/T ;; "lux;module-aliases"
- (&/|table)
- ;; "lux;defs"
- (&/|table)
- ;; "lux;imports"
- (&/|list)
- ;; "lux;tags"
- (&/|table)
- ;; "lux;types"
- (&/|table)
- ))
+ ($$ &/P
+ ;; "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 (&/T false def-data) %)
- m))
- ms))))
+ (&/$update-modules
+ (fn [ms]
+ (&/|update module
+ (fn [m]
+ ($update-defs
+ #(&/|put name (&/P false def-data) %)
+ m))
+ ms))))
nil)
_
@@ -83,8 +84,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)
@@ -104,31 +105,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 (&/T module name)))))
- (fail* (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T module name)))))
+ (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] 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 (&/T false (&/V &/$AliasD (&/T r-module r-name))) %)
- m))
- ms))))
+ (&/$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))))
nil)
_
@@ -137,26 +138,30 @@
(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))))))
@@ -164,9 +169,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))
@@ -177,7 +182,7 @@
state))
_
- (return* state (&/T (&/T module name) $$def)))
+ (return* state (&/P (&/P 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))))))
@@ -198,7 +203,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 _)]
@@ -208,15 +213,15 @@
(.getField &/datum-field)
(.get nil))]]
(fn [state*]
- (return* (&/update$ &/$modules
- (fn [$modules]
- (&/|update module
- (fn [m]
- (&/update$ $defs
- #(&/|put name (&/T exported? (&/V &/$MacroD macro)) %)
- m))
- $modules))
- state*)
+ (return* (&/$update-modules
+ (fn [$modules]
+ (&/|update module
+ (fn [m]
+ ($update-defs
+ #(&/|put name (&/P exported? (&/S &/$MacroD macro)) %)
+ m))
+ $modules))
+ state*)
nil)))
state)
@@ -230,21 +235,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 (&/T true ?data) %)
- m))
- ms))))
+ (&/$update-modules (fn [ms]
+ (&/|update module (fn [m]
+ ($update-defs
+ #(&/|put name (&/P true ?data) %)
+ m))
+ ms))))
nil))
(fail* (str "[Analyser Error] Can't export an inexistent definition: " (str module &/+name-separator+ name))))
@@ -260,61 +265,61 @@
(do ;; (prn 'defs k ?exported?)
(|case ?def
(&/$AliasD ?r-module ?r-name)
- (&/T ?exported? k (str "A" ?r-module ";" ?r-name))
+ ($$ &/P ?exported? k (str "A" ?r-module ";" ?r-name))
(&/$MacroD _)
- (&/T ?exported? k "M")
+ ($$ &/P ?exported? k "M")
(&/$TypeD _)
- (&/T ?exported? k "T")
+ ($$ &/P ?exported? k "T")
_
- (&/T ?exported? k "V")))))
- (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs)))))))
+ ($$ &/P ?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> <tag> <type>]
+(do-template [<name> <getter> <type>]
(defn <name> [module]
<type>
(fn [state]
- (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))]
- (return* state (&/get$ <tag> =module))
+ (if-let [=module (->> state (&/$get-modules) (&/|get module))]
+ (return* state (<getter> =module))
(fail* (str "[Lux Error] Unknown module: " module)))
))
- tags-by-module $tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))"
- types-by-module $types "(-> Text (Lux (List (, Text (, (List Text) Type)))))"
+ 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)))))"
)
(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 (&/T module tag))))
+ (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/P 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 (&/T module name))))]
+ _ (&/assert! (nil? (&/|get name types-table)) (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/P module name))))]
(return nil)))
(defn declare-tags [module tag-names type]
@@ -327,37 +332,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] (&/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)
+ (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)
nil))
(fail* (str "[Lux Error] Unknown module: " module))))))
(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))]
+ (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 tag: " (&/ident->text (&/P 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))]
+ (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 tag: " (&/ident->text (&/P 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 2b4b7e095..96c988544 100644
--- a/src/lux/analyser/record.clj
+++ b/src/lux/analyser/record.clj
@@ -13,122 +13,6 @@
(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)))"
@@ -136,7 +20,7 @@
(&/$Nil)
(return (&/|list))
- (&/$Cons [(&/$Meta _ (&/$TagS tag1)) _] _)
+ (&/$Cons [[_ (&/$TagS tag1)] _] _)
(|do [[module name] (&&/resolved-ident tag1)]
(&&module/tag-group module name))
@@ -144,9 +28,9 @@
(fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))
=pairs (&/map% (fn [kv]
(|case kv
- [(&/$Meta _ (&/$TagS k)) v]
+ [[_ (&/$TagS k)] v]
(|do [=k (&&/resolved-ident k)]
- (return (&/T (&/ident->text =k) v)))
+ (return (&/P (&/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 6247524af..2f0925586 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -11,99 +11,157 @@
[clojure.core.match :as M :refer [matchv]]
clojure.core.match.array))
-;; [Tags]
-(defmacro deftags [prefix & names]
+;; [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))
`(do ~@(for [[name idx] (map vector names (range (count names)))]
`(def ~(symbol (str "$" name)) ~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)))))
+ ))
+
;; List
-(deftags ""
- "Nil"
- "Cons")
+(deftags
+ ["Nil"
+ "Cons"])
;; Maybe
-(deftags ""
- "None"
- "Some")
-
-;; Meta
-(deftags ""
- "Meta")
+(deftags
+ ["None"
+ "Some"])
;; 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 ""
- "DataT"
- "VariantT"
- "TupleT"
- "LambdaT"
- "BoundT"
- "VarT"
- "ExT"
- "AllT"
- "AppT"
- "NamedT")
+(deftags
+ ["VoidT"
+ "UnitT"
+ "SumT"
+ "ProdT"
+ "DataT"
+ "LambdaT"
+ "BoundT"
+ "VarT"
+ "ExT"
+ "AllT"
+ "AppT"
+ "NamedT"])
;; Vars
-(deftags "lux;"
- "Local"
- "Global")
+(deftags
+ ["Local"
+ "Global"])
;; Definitions
-(deftags "lux;"
- "ValueD"
- "TypeD"
- "MacroD"
- "AliasD")
+(deftags
+ ["ValueD"
+ "TypeD"
+ "MacroD"
+ "AliasD"])
;; Binding
-(deftags ""
- "counter"
- "mappings")
+(defrtags
+ ["counter"
+ "mappings"])
;; Env
-(deftags ""
- "name"
- "inner-closures"
- "locals"
- "closure")
+(defrtags
+ ["name"
+ "inner-closures"
+ "locals"
+ "closure"])
;; Host
-(deftags ""
- "writer"
- "loader"
- "classes")
+(defrtags
+ ["writer"
+ "loader"
+ "classes"])
;; Compiler
-(deftags ""
- "source"
- "cursor"
- "modules"
- "envs"
- "type-vars"
- "expected"
- "seed"
- "eval?"
- "host")
+(defrtags
+ ["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")
@@ -117,55 +175,59 @@
(def +name-separator+ ";")
-(defn T [& elems]
- (to-array elems))
-
-(defn V [^Long tag value]
- (to-array [tag value]))
+(def prelude-name "lux")
-;; Constructors
-(def None$ (V $None nil))
-(defn Some$ [x] (V $Some x))
+(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)))
-(def Nil$ (V $Nil nil))
-(defn Cons$ [h t] (V $Cons (T h t)))
+(defn S [^Long tag value]
+ (to-array [tag value]))
-(defn get$ [slot ^objects record]
- (aget record slot))
+(defn P [left right]
+ (to-array [left right]))
-(defn set$ [slot value ^objects record]
- (let [record* (aclone record)
- size (alength record)]
- (aset record* slot value)
- record*))
+;; Constructors
+(def None$ (S $None nil))
+(defn Some$ [x] (S $Some x))
-(defmacro update$ [slot f record]
- `(let [record# ~record]
- (set$ ~slot (~f (get$ ~slot record#))
- record#)))
+(def Nil$ (S $Nil nil))
+(defn Cons$ [h t] (S $Cons (P h t)))
(defn fail* [message]
- (V $Left message))
+ (S $Left message))
(defn return* [state value]
- (V $Right (T 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))))
(defn transform-pattern [pattern]
- (cond (vector? pattern) (mapv transform-pattern pattern)
+ (cond (vector? pattern) (transform-tuple-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
- `[~@parts])))))
+ (transform-tuple-pattern parts))))))
:else pattern
))
(defmacro |case [value & branches]
(assert (= 0 (mod (count branches) 2)))
(let [value* (if (vector? value)
- [`(T ~@value)]
+ [`($$ P ~@value)]
[value])]
`(matchv ::M/objects ~value*
~@(mapcat (fn [[pattern body]]
@@ -183,8 +245,8 @@
(defmacro |list [& elems]
(reduce (fn [tail head]
- `(V $Cons (T ~head ~tail)))
- `(V $Nil nil)
+ `(Cons$ ~head ~tail))
+ `Nil$
(reverse elems)))
(defmacro |table [& elems]
@@ -204,17 +266,18 @@
(|get slot table*))))
(defn |put [slot value table]
+ ;; (prn '|put slot (adt->text value) (adt->text table))
(|case table
($Nil)
- (V $Cons (T (T slot value) (V $Nil nil)))
+ (Cons$ (P slot value) Nil$)
($Cons [k v] table*)
(if (.equals ^Object k slot)
- (V $Cons (T (T slot value) table*))
- (V $Cons (T (T k v) (|put slot value table*))))
+ (Cons$ (P slot value) table*)
+ (Cons$ (P k v) (|put slot value table*)))
;; _
- ;; (assert false (prn-str '|put (aget table 0)))
+ ;; (assert false (prn-str '|put slot (adt->text value) (adt->text table)))
))
(defn |remove [slot table]
@@ -225,7 +288,7 @@
($Cons [k v] table*)
(if (.equals ^Object k slot)
table*
- (V $Cons (T (T k v) (|remove slot table*))))))
+ (Cons$ (P k v) (|remove slot table*)))))
(defn |update [k f table]
(|case table
@@ -234,8 +297,8 @@
($Cons [k* v] table*)
(if (.equals ^Object k k*)
- (V $Cons (T (T k* (f v)) table*))
- (V $Cons (T (T k* v) (|update k f table*))))))
+ (Cons$ (P k* (f v)) table*)
+ (Cons$ (P k* v) (|update k f table*)))))
(defn |head [xs]
(|case xs
@@ -256,11 +319,11 @@
;; [Resources/Monads]
(defn fail [message]
(fn [_]
- (V $Left message)))
+ (S $Left message)))
(defn return [value]
(fn [state]
- (V $Right (T state value))))
+ (S $Right (P state value))))
(defn bind [m-value step]
(fn [state]
@@ -288,22 +351,13 @@
(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*)
- (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))))
+ (Cons$ x (|++ xs* ys))))
(defn |map [f xs]
(|case xs
@@ -311,7 +365,7 @@
xs
($Cons x xs*)
- (V $Cons (T (f x) (|map f xs*)))
+ (Cons$ (f x) (|map f xs*))
_
(assert false (prn-str '|map f (adt->text xs)))
@@ -332,7 +386,7 @@
($Cons x xs*)
(if (p x)
- (V $Cons (T x (|filter p xs*)))
+ (Cons$ x (|filter p xs*))
(|filter p xs*))))
(defn flat-map [f xs]
@@ -346,13 +400,13 @@
(defn |split-with [p xs]
(|case xs
($Nil)
- (T xs xs)
+ (P xs xs)
($Cons x xs*)
(if (p x)
(|let [[pre post] (|split-with p xs*)]
- (T (|cons x pre) post))
- (T (V $Nil nil) xs))))
+ (P (Cons$ x pre) post))
+ (P Nil$ xs))))
(defn |contains? [k table]
(|case table
@@ -361,7 +415,10 @@
($Cons [k* _] table*)
(or (.equals ^Object k k*)
- (|contains? k table*))))
+ (|contains? k table*))
+
+ _
+ (assert false (prn-str '|contains? k (adt->text table)))))
(defn fold [f init xs]
(|case xs
@@ -386,15 +443,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)
- (V $Cons (T from (|range* (inc from) to)))
- (V $Nil nil)))]
+ (Cons$ from (|range* (inc from) to))
+ Nil$))]
(defn |range [n]
(|range* 0 n)))
@@ -409,10 +466,10 @@
(defn zip2 [xs ys]
(|case [xs ys]
[($Cons x xs*) ($Cons y ys*)]
- (V $Cons (T (T x y) (zip2 xs* ys*)))
+ (Cons$ (P x y) (zip2 xs* ys*))
[_ _]
- (V $Nil nil)))
+ Nil$))
(defn |keys [plist]
(|case plist
@@ -420,7 +477,7 @@
(|list)
($Cons [k v] plist*)
- (|cons k (|keys plist*))))
+ (Cons$ k (|keys plist*))))
(defn |vals [plist]
(|case plist
@@ -428,7 +485,7 @@
(|list)
($Cons [k v] plist*)
- (|cons v (|vals plist*))))
+ (Cons$ v (|vals plist*))))
(defn |interpose [sep xs]
(|case xs
@@ -439,7 +496,7 @@
xs
($Cons x xs*)
- (V $Cons (T x (V $Cons (T sep (|interpose sep xs*)))))))
+ (Cons$ x (Cons$ sep (|interpose sep xs*)))))
(do-template [<name> <joiner>]
(defn <name> [f xs]
@@ -452,23 +509,23 @@
ys (<name> f xs*)]
(return (<joiner> y ys)))))
- map% |cons
+ map% Cons$
flat-map% |++)
(defn list-join [xss]
- (fold |++ (V $Nil nil) xss))
+ (fold |++ Nil$ xss))
(defn |as-pairs [xs]
(|case xs
($Cons x ($Cons y xs*))
- (V $Cons (T (T x y) (|as-pairs xs*)))
+ (Cons$ (P x y) (|as-pairs xs*))
_
- (V $Nil nil)))
+ Nil$))
(defn |reverse [xs]
(fold (fn [tail head]
- (|cons head tail))
+ (Cons$ head tail))
(|list)
xs))
@@ -504,7 +561,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]
@@ -551,28 +608,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+
- (T ;; "lux;counter"
+ (P ;; "lux;counter"
0
;; "lux;mappings"
(|table)))
(defn env [name]
- (T ;; "lux;name"
- name
- ;; "lux;inner-closures"
- 0
- ;; "lux;locals"
- +init-bindings+
- ;; "lux;closure"
- +init-bindings+
- ))
+ ($$ P ;; "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 []))
@@ -594,41 +651,41 @@
(defn host [_]
(let [store (atom {})]
- (T ;; "lux;writer"
- (V $None nil)
- ;; "lux;loader"
- (memory-class-loader store)
- ;; "lux;classes"
- store)))
+ ($$ P ;; "lux;writer"
+ None$
+ ;; "lux;loader"
+ (memory-class-loader store)
+ ;; "lux;classes"
+ store)))
(defn init-state [_]
- (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)
- ))
+ ($$ 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)
+ ))
(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)
@@ -636,20 +693,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)
@@ -659,15 +716,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
@@ -680,26 +737,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)))))
@@ -710,10 +767,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))))
@@ -723,23 +780,24 @@
(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]
- (let [output (body (update$ $host #(set$ $writer (V $Some writer) %) state))]
+ (prn 'with-writer writer body)
+ (let [output (body ($update-host #($set-writer (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)
_
@@ -748,10 +806,11 @@
(defn with-expected-type [type body]
"(All [a] (-> Type (Lux a)))"
(fn [state]
- (let [output (body (set$ $expected type state))]
+ ;; (prn 'with-expected-type 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)
_
@@ -759,14 +818,20 @@
(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 [output (body (set$ $cursor cursor state))]
+ (let [;; _ (prn 'with-cursor/_1 cursor)
+ state* ($set-cursor cursor state)
+ ;; _ (prn 'with-cursor/_2 state*)
+ output (body state*)]
(|case output
($Right ?state ?value)
- (return* (set$ $cursor (get$ $cursor state) ?state)
- ?value)
+ (let [?state* ($set-cursor ($get-cursor state) ?state)]
+ ;; (prn 'with-cursor/_3 ?state*)
+ (return* ?state*
+ ?value))
_
output)))))
@@ -774,40 +839,40 @@
(defn show-ast [ast]
;; (prn 'show-ast/GOOD (aget ast 0) (aget ast 1 1 0))
(|case ast
- ($Meta _ ($BoolS ?value))
+ [_ ($BoolS ?value)]
(pr-str ?value)
- ($Meta _ ($IntS ?value))
+ [_ ($IntS ?value)]
(pr-str ?value)
- ($Meta _ ($RealS ?value))
+ [_ ($RealS ?value)]
(pr-str ?value)
- ($Meta _ ($CharS ?value))
+ [_ ($CharS ?value)]
(pr-str ?value)
- ($Meta _ ($TextS ?value))
+ [_ ($TextS ?value)]
(str "\"" ?value "\"")
- ($Meta _ ($TagS ?module ?tag))
+ [_ ($TagS ?module ?tag)]
(str "#" ?module ";" ?tag)
- ($Meta _ ($SymbolS ?module ?ident))
+ [_ ($SymbolS ?module ?ident)]
(if (.equals "" ?module)
?ident
(str ?module ";" ?ident))
- ($Meta _ ($TupleS ?elems))
+ [_ ($TupleS ?elems)]
(str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]")
- ($Meta _ ($RecordS ?elems))
+ [_ ($RecordS ?elems)]
(str "{" (->> ?elems
(|map (fn [elem]
(|let [[k v] elem]
(str (show-ast k) " " (show-ast v)))))
(|interpose " ") (fold str "")) "}")
- ($Meta _ ($FormS ?elems))
+ [_ ($FormS ?elems)]
(str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")")
_
@@ -835,10 +900,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 (V $Nil nil))
+ (return Nil$)
[_ _]
(fail "Lists don't match in size.")))
@@ -846,10 +911,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*))
[_ _]
- (V $Nil nil)))
+ Nil$))
(defn fold2 [f init xs ys]
(|case [xs ys]
@@ -867,8 +932,8 @@
"(All [a] (-> Int (List a) (List (, Int a))))"
(|case xs
($Cons x xs*)
- (V $Cons (T (T idx x)
- (enumerate* (inc idx) xs*)))
+ (Cons$ (P idx x)
+ (enumerate* (inc idx) xs*))
($Nil)
xs
@@ -881,7 +946,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 (,)))"
@@ -895,23 +960,23 @@
(|case xs
($Cons x xs*)
(cond (< idx 0)
- (V $None nil)
+ None$
(= idx 0)
- (V $Some x)
+ (Some$ x)
:else ;; > 1
(|at (dec idx) xs*))
($Nil)
- (V $None nil)
+ None$
))
(defn normalize [ident]
"(-> Ident (Lux Ident))"
(|case ident
["" name] (|do [module get-module-name]
- (return (T module name)))
+ (return (P module name)))
_ (return ident)))
(defn ident= [x y]
@@ -923,12 +988,24 @@
(defn |list-put [idx val xs]
(|case xs
($Nil)
- (V $None nil)
+ None$
($Cons x xs*)
(if (= idx 0)
- (V $Some (V $Cons (T val xs*)))
+ (Some$ (Cons$ val xs*))
(|case (|list-put (dec idx) val xs*)
- ($None) (V $None nil)
- ($Some xs**) (V $Some (V $Cons (T x xs**))))
+ ($None) None$
+ ($Some xs**) (Some$ (Cons$ 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 79d2c84f8..4315ea75d 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -39,8 +39,12 @@
;; [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)
@@ -56,8 +60,11 @@
(&a/$text ?value)
(&&lux/compile-text compile-expression ?type ?value)
- (&a/$tuple ?elems)
- (&&lux/compile-tuple compile-expression ?type ?elems)
+ (&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/$var (&/$Local ?idx))
(&&lux/compile-local compile-expression ?type ?idx)
@@ -71,9 +78,6 @@
(&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)
@@ -424,7 +428,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
@@ -471,7 +475,7 @@
;; [Resources]
(defn compile-program [program-module]
(init!)
- (|case ((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil))
+ (|case ((&/map% compile-module (&/|list &/prelude-name 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 1e5f3a024..72d569ed1 100644
--- a/src/lux/compiler/base.clj
+++ b/src/lux/compiler/base.clj
@@ -76,26 +76,32 @@
_ (load-class! loader real-name)]]
(return nil)))
-(do-template [<name> <class> <sig> <dup>]
+(do-template [<name> <class> <sig>]
(defn <name> [^MethodVisitor writer]
(doto writer
- (.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
- ;; )
- )
+ (.visitMethodInsn Opcodes/INVOKESTATIC <class> "valueOf" (str <sig> (&host/->type-signature <class>)))))
- 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
+ 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
+ (.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"
)
diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj
index dc224f52e..48b35c83a 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])
- (&/T _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator)))))))))
+ (&/P _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 (&/V &/$TypeD def-value) &type/Type))
+ (&a-module/define module _name (&/S &/$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 (&/V &/$ValueD (&/T &type/Macro def-value)) &type/Macro)]
+ (|do [_ (&a-module/define module _name (&/S &/$ValueD (&/P &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 dd3258059..b30fcb4f8 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,63 +84,62 @@
(.visitInsn Opcodes/POP)
(.visitJumpInsn Opcodes/GOTO $target))
- (&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)]
+ (doto writer
+ (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn (int 0))
+ (.visitInsn Opcodes/AALOAD)
+ (compile-match left $post-left $else)
+ (.visitLabel $post-left)
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn (int 1))
+ (.visitInsn Opcodes/AALOAD)
+ (compile-match right $post-right $else)
+ (.visitLabel $post-right)
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $target)))
- (&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)]))))
+ (&a-case/$SumTestAC ?tag ?count ?test)
+ (let [$value-then (new Label)
+ $sum-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 $sum-else)
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn (int 1))
+ (.visitInsn Opcodes/AALOAD)
+ (compile-match ?test $value-then $sum-else)
+ (.visitLabel $value-then)
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $target)
+ (.visitLabel $sum-else)
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $else)))
)))
(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]
- (&/T (inc $id) (&/|put $id body mappings) (&/|put $id pattern =matches))))
- (&/T 0 (&/|table) (&/|table))
+ ($$ &/P (inc $id) (&/|put $id body mappings) (&/|put $id pattern =matches))))
+ ($$ &/P 0 (&/|table) (&/|table))
patterns)]
- (&/T mappings (&/|reverse patterns*))))
+ (&/P 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)]
- (&/T (&/T ?branch label)
- (&/T label ?body))))
+ (&/P (&/P ?branch label)
+ (&/P label ?body))))
mappings)
mappings* (&/|map &/|first entries)]
(doto writer
diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj
index 26ef73cb7..ead44085a 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*
- (&/$TupleT (&/$Nil))
+ (&/$UnitT)
(.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 83e294c1a..79383acc0 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -28,27 +28,43 @@
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> <class> <sig> <caster>]
+(do-template [<name> <wrapper>]
(defn <name> [compile *type* value]
(|do [^MethodVisitor *writer* &/get-writer
- :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)))))]]
+ :let [_ (doto *writer*
+ (.visitLdcInsn value)
+ (<wrapper>))]]
(return nil)))
- compile-int "java/lang/Long" "(J)V" long
- compile-real "java/lang/Double" "(D)V" double
- compile-char "java/lang/Character" "(C)V" char
+ compile-int &&/wrap-long
+ compile-real &&/wrap-double
+ compile-char &&/wrap-char
)
(defn compile-text [compile *type* ?value]
@@ -56,37 +72,28 @@
:let [_ (.visitLdcInsn *writer* ?value)]]
(return nil)))
-(defn compile-tuple [compile *type* ?elems]
+(defn compile-prod [compile *type* left right]
+ ;; (prn 'compile-prod (&type/show-type *type*)
+ ;; (&/adt->text left)
+ ;; (&/adt->text right))
(|do [^MethodVisitor *writer* &/get-writer
- :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)]
+ _ (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)]
(return nil)))
-(defn compile-variant [compile *type* ?tag ?value]
+(defn compile-sum [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 ?tag)
- (&&/wrap-long)
- (.visitInsn Opcodes/AASTORE)
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int 1)))]
- _ (compile ?value)
- :let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
+ (.visitLdcInsn (int ?tag))
+ (&&/wrap-int)
+ (.visitInsn Opcodes/AASTORE))]
+ _ (store-at *writer* compile 1 ?value)]
(return nil)))
(defn compile-local [compile *type* ?idx]
diff --git a/src/lux/compiler/module.clj b/src/lux/compiler/module.clj
index db73e8bb4..50d8b0011 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 _]]
- (&/T name (&/|map (fn [^objects tag] (aget tag 1)) tags))))
- (&/get$ &module/$types module)))
+ (&/P name (&/|map (fn [^objects tag] (aget tag 1)) tags))))
+ (&module/$get-types module)))
))
diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj
index 7e2bc6961..cfaa9668b 100644
--- a/src/lux/compiler/type.clj
+++ b/src/lux/compiler/type.clj
@@ -9,83 +9,86 @@
(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]
-(defn ^:private variant$ [tag body]
- "(-> Text Analysis Analysis)"
- (&/T (&/V &a/$variant (&/T tag body))
+(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))
&type/$Void))
-(defn ^:private tuple$ [members]
- "(-> (List Analysis) Analysis)"
- (&/T (&/V &a/$tuple members)
+(defn ^:private prod$ [left right]
+ "(-> Analysis Analysis Analysis)"
+ (&/P (&/S &a/$prod (&/P left right))
&type/$Void))
(defn ^:private text$ [text]
"(-> Text Analysis)"
- (&/T (&/V &a/$text text)
+ (&/P (&/S &a/$text text)
&type/$Void))
(def ^:private $Nil
"Analysis"
- (variant$ &/$Nil (tuple$ (&/|list))))
+ (sum$ &/$Nil unit$))
(defn ^:private Cons$ [head tail]
"(-> Analysis Analysis Analysis)"
- (variant$ &/$Cons (tuple$ (&/|list head tail))))
+ (sum$ &/$Cons (prod$ head tail)))
;; [Exports]
(defn ->analysis [type]
"(-> Type Analysis)"
(|case type
(&/$DataT ?class)
- (variant$ &/$DataT (text$ ?class))
+ (sum$ &/$DataT (text$ ?class))
- (&/$TupleT ?members)
- (variant$ &/$TupleT
- (&/fold (fn [tail head]
- (Cons$ (->analysis head) tail))
- $Nil
- (&/|reverse ?members)))
+ (&/$ProdT left right)
+ (sum$ &/$ProdT
+ (prod$ (->analysis left)
+ (->analysis right)))
- (&/$VariantT ?members)
- (variant$ &/$VariantT
- (&/fold (fn [tail head]
- (Cons$ (->analysis head) tail))
- $Nil
- (&/|reverse ?members)))
+ (&/$SumT left right)
+ (sum$ &/$SumT
+ (prod$ (->analysis left)
+ (->analysis right)))
(&/$LambdaT ?input ?output)
- (variant$ &/$LambdaT (tuple$ (&/|list (->analysis ?input) (->analysis ?output))))
+ (sum$ &/$LambdaT (prod$ (->analysis ?input) (->analysis ?output)))
(&/$AllT ?env ?name ?arg ?body)
- (variant$ &/$AllT
- (tuple$ (&/|list (|case ?env
- (&/$None)
- (variant$ &/$None (tuple$ (&/|list)))
+ (sum$ &/$AllT
+ ($$ prod$
+ (|case ?env
+ (&/$None)
+ (sum$ &/$None unit$)
- (&/$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))))
+ (&/$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)))
(&/$BoundT ?name)
- (variant$ &/$BoundT (text$ ?name))
+ (sum$ &/$BoundT (text$ ?name))
(&/$AppT ?fun ?arg)
- (variant$ &/$AppT (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg))))
+ (sum$ &/$AppT (prod$ (->analysis ?fun) (->analysis ?arg)))
(&/$NamedT [?module ?name] ?type)
- (variant$ &/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ ?module) (text$ ?name)))
- (->analysis ?type))))
+ (sum$ &/$NamedT (prod$ (prod$ (text$ ?module) (text$ ?name))
+ (->analysis ?type)))
))
diff --git a/src/lux/host.clj b/src/lux/host.clj
index dfd4df23d..d77e9b31c 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 (&/V &/$DataT (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "["))
- base)))
+ (return (&/S &/$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)
- (&/$TupleT (&/$Nil))
+ (&/$VoidT)
"V"
(&/$NamedT ?name ?type)
diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj
index e848cc3fd..91693cc77 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 (&/V &/$Meta (&/T meta (&/V $White_Space white-space))))))
+ (return (&/P meta (&/S $White_Space white-space)))))
(def ^:private lex-single-line-comment
(|do [_ (&reader/read-text "##")
[meta comment] (&reader/read-regex #"^(.*)$")]
- (return (&/V &/$Meta (&/T meta (&/V $Comment comment))))))
+ (return (&/P meta (&/S $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 (&/T meta comment)))
+ (return (&/P 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 (&/T meta (str pre "#(" inner ")#" post))))))
+ (return (&/P meta (str pre "#(" inner ")#" post))))))
;; :let [_ (prn 'lex-multi-line-comment (str comment ")#"))]
_ (&reader/read-text ")#")]
- (return (&/V &/$Meta (&/T meta (&/V $Comment comment))))))
+ (return (&/P meta (&/S $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 (&/V &/$Meta (&/T meta (&/V <tag> token))))))
+ (return (&/P meta (&/S <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 (&/V &/$Meta (&/T meta (&/V $Char token))))))
+ (return (&/P meta (&/S $Char token)))))
(def ^:private lex-text
(|do [[meta _] (&reader/read-text "\"")
token (lex-text-body nil)
_ (&reader/read-text "\"")]
- (return (&/V &/$Meta (&/T meta (&/V $Text token))))))
+ (return (&/P meta (&/S $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 (&/T meta (&/T token local-token)))
+ (return (&/P meta (&/P token local-token)))
(|do [unaliased (do ;; (prn "Unaliasing: " token ";" local-token)
- (&module/dealias token))]
+ (&module/dealias token))]
(do ;; (prn "Unaliased: " unaliased ";" local-token)
- (return (&/T meta (&/T unaliased local-token)))))))
- (return (&/T meta (&/T "" token)))
+ (return (&/P meta (&/P unaliased local-token)))))))
+ (return (&/P meta (&/P "" token)))
)))
(|do [[meta _] (&reader/read-text ";;")
[_ token] (&reader/read-regex +ident-re+)
module-name &/get-module-name]
- (return (&/T meta (&/T module-name token))))
+ (return (&/P meta (&/P module-name token))))
(|do [[meta _] (&reader/read-text ";")
[_ token] (&reader/read-regex +ident-re+)]
- (return (&/T meta (&/T "lux" token))))
+ (return (&/P meta (&/P &/prelude-name token))))
)))
(def ^:private lex-symbol
(|do [[meta ident] lex-ident]
- (return (&/V &/$Meta (&/T meta (&/V $Symbol ident))))))
+ (return (&/P meta (&/S $Symbol ident)))))
(def ^:private lex-tag
(|do [[meta _] (&reader/read-text "#")
[_ ident] lex-ident]
- (return (&/V &/$Meta (&/T meta (&/V $Tag ident))))))
+ (return (&/P meta (&/S $Tag ident)))))
(do-template [<name> <text> <tag>]
(def <name>
(|do [[meta _] (&reader/read-text <text>)]
- (return (&/V &/$Meta (&/T meta (&/V <tag> nil))))))
+ (return (&/P meta (&/S <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 eaa22db20..c40221d63 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 meta [<close-token> _])
- (return (&/V <tag> (&/fold &/|++ (&/|list) elems)))
+ [meta [<close-token> _]]
+ (return (&/S <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 meta ($Close_Brace _))
+ [meta ($Close_Brace _)]
(if (even? (&/|length elems))
- (return (&/V &/$RecordS (&/|as-pairs elems)))
+ (return (&/S &/$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 meta token*) token]]
+ :let [[meta token*] token]]
(|case token*
($White_Space _)
(return (&/|list))
@@ -73,37 +73,37 @@
(return (&/|list))
($Bool ?value)
- (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value))))))
+ (return (&/|list (&/P meta (&/S &/$BoolS (Boolean/parseBoolean ?value)))))
($Int ?value)
- (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$IntS (Long/parseLong ?value))))))
+ (return (&/|list (&/P meta (&/S &/$IntS (Long/parseLong ?value)))))
($Real ?value)
- (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$RealS (Double/parseDouble ?value))))))
+ (return (&/|list (&/P meta (&/S &/$RealS (Double/parseDouble ?value)))))
($Char ^String ?value)
- (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$CharS (.charAt ?value 0))))))
+ (return (&/|list (&/P meta (&/S &/$CharS (.charAt ?value 0)))))
($Text ?value)
- (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TextS ?value)))))
+ (return (&/|list (&/P meta (&/S &/$TextS ?value))))
($Symbol ?ident)
- (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$SymbolS ?ident)))))
+ (return (&/|list (&/P meta (&/S &/$SymbolS ?ident))))
($Tag ?ident)
- (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TagS ?ident)))))
+ (return (&/|list (&/P meta (&/S &/$TagS ?ident))))
($Open_Paren _)
(|do [syntax (parse-form parse)]
- (return (&/|list (&/V &/$Meta (&/T meta syntax)))))
+ (return (&/|list (&/P meta syntax))))
($Open_Bracket _)
(|do [syntax (parse-tuple parse)]
- (return (&/|list (&/V &/$Meta (&/T meta syntax)))))
+ (return (&/|list (&/P meta syntax))))
($Open_Brace _)
(|do [syntax (parse-record parse)]
- (return (&/|list (&/V &/$Meta (&/T meta syntax)))))
+ (return (&/|list (&/P meta syntax))))
_
(fail "[Parser Error] Unknown lexer token.")
diff --git a/src/lux/reader.clj b/src/lux/reader.clj
index e3f95b5f9..24a0bf94d 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))
- (&/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))))))
+ (&/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))))))
(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))
- (&/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))))))
+ (&/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))))))
(defn read-regex+ [regex]
(with-lines
@@ -110,7 +110,7 @@
reader* reader]
(|case reader*
(&/$Nil)
- (&/V &/$Left "[Reader Error] EOF")
+ (&/S &/$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**)
- (&/V &/$Right (&/T (&/|cons (&/T (&/T file-name line-num column-num*) line)
+ (&/S &/$Right (&/P (&/Cons$ (&/P (&/cursor$ file-name line-num column-num*) line)
reader**)
- (&/T (&/T file-name line-num column-num) (str prefix match))))))
- (&/V &/$Left (str "[Reader Error] Pattern failed: " regex))))))))
+ (&/P (&/cursor$ file-name line-num column-num) (str prefix match))))))
+ (&/S &/$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))
- (&/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))))))
+ (&/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))))))
(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]
- (&/T (&/T file-name (inc line-num) 0)
+ (&/P (&/cursor$ 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 9f3adb036..4193d8df4 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,302 +26,300 @@
_
false))
-(def ^:private empty-env (&/V &/$Some (&/V &/$Nil nil)))
-(def ^:private no-env (&/V &/$None nil))
+(def ^:private empty-env (&/Some$ &/Nil$))
+(def ^:private no-env &/None$)
+(def Ident$ &/P)
(defn Data$ [name]
- (&/V &/$DataT name))
+ (&/S &/$DataT name))
(defn Bound$ [name]
- (&/V &/$BoundT name))
+ (&/S &/$BoundT name))
(defn Var$ [id]
- (&/V &/$VarT id))
+ (&/S &/$VarT id))
(defn Lambda$ [in out]
- (&/V &/$LambdaT (&/T in out)))
+ (&/S &/$LambdaT (&/P in out)))
(defn App$ [fun arg]
- (&/V &/$AppT (&/T fun arg)))
-(defn Tuple$ [members]
+ (&/S &/$AppT (&/P fun arg)))
+(defn Prod$ [left right]
;; (assert (|list? members))
- (&/V &/$TupleT members))
-(defn Variant$ [members]
+ (&/S &/$ProdT (&/P left right)))
+(defn Sum$ [left right]
;; (assert (|list? members))
- (&/V &/$VariantT members))
+ (&/S &/$SumT (&/P left right)))
(defn All$ [env name arg body]
- (&/V &/$AllT (&/T env name arg body)))
+ (&/S &/$AllT ($$ &/P env name arg body)))
(defn Named$ [name type]
- (&/V &/$NamedT (&/T name type)))
+ (&/S &/$NamedT (&/P name type)))
-
-(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 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 IO
- (Named$ (&/T "lux/data" "IO")
+ (Named$ (Ident$ "lux/data" "IO")
(All$ empty-env "IO" "a"
(Lambda$ Unit (Bound$ "a")))))
(def List
- (Named$ (&/T "lux" "List")
+ (Named$ (Ident$ &/prelude-name "List")
(All$ empty-env "lux;List" "a"
- (Variant$ (&/|list
- ;; lux;Nil
- Unit
- ;; lux;Cons
- (Tuple$ (&/|list (Bound$ "a")
- (App$ (Bound$ "lux;List")
- (Bound$ "a"))))
- )))))
+ (Sum$
+ ;; lux;Nil
+ Unit
+ ;; lux;Cons
+ (Prod$ (Bound$ "a")
+ (App$ (Bound$ "lux;List")
+ (Bound$ "a")))
+ ))))
(def Maybe
- (Named$ (&/T "lux" "Maybe")
+ (Named$ (Ident$ &/prelude-name "Maybe")
(All$ empty-env "lux;Maybe" "a"
- (Variant$ (&/|list
- ;; lux;None
- Unit
- ;; lux;Some
- (Bound$ "a")
- )))))
+ (Sum$
+ ;; lux;None
+ Unit
+ ;; lux;Some
+ (Bound$ "a")
+ ))))
(def Type
- (Named$ (&/T "lux" "Type")
+ (Named$ (Ident$ &/prelude-name "Type")
(let [Type (App$ (Bound$ "Type") (Bound$ "_"))
TypeList (App$ List Type)
- TypeEnv (App$ List (Tuple$ (&/|list Text Type)))
- TypePair (Tuple$ (&/|list Type Type))]
+ TypeEnv (App$ List (Prod$ Text Type))
+ TypePair (Prod$ Type Type)]
(App$ (All$ empty-env "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))
- )))
+ ($$ 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)
+ ))
$Void))))
(def Bindings
- (Named$ (&/T "lux" "Bindings")
+ (Named$ (Ident$ &/prelude-name "Bindings")
(All$ empty-env "lux;Bindings" "k"
(All$ no-env "" "v"
- (Tuple$ (&/|list
- ;; "lux;counter"
- Int
- ;; "lux;mappings"
- (App$ List
- (Tuple$ (&/|list (Bound$ "k")
- (Bound$ "v"))))))))))
+ (Prod$
+ ;; "lux;counter"
+ Int
+ ;; "lux;mappings"
+ (App$ List
+ (Prod$ (Bound$ "k")
+ (Bound$ "v"))))))))
(def Env
- (Named$ (&/T "lux" "Env")
+ (Named$ (Ident$ &/prelude-name "Env")
(let [bindings (App$ (App$ Bindings (Bound$ "k"))
(Bound$ "v"))]
(All$ empty-env "lux;Env" "k"
(All$ no-env "" "v"
- (Tuple$
- (&/|list
- ;; "lux;name"
- Text
- ;; "lux;inner-closures"
- Int
- ;; "lux;locals"
- bindings
- ;; "lux;closure"
- bindings
- )))))))
+ ($$ Prod$
+ ;; "lux;name"
+ Text
+ ;; "lux;inner-closures"
+ Int
+ ;; "lux;locals"
+ bindings
+ ;; "lux;closure"
+ bindings
+ ))))))
(def Cursor
- (Named$ (&/T "lux" "Cursor")
- (Tuple$ (&/|list Text Int Int))))
+ (Named$ (Ident$ &/prelude-name "Cursor")
+ ($$ Prod$ Text Int Int)))
(def Meta
- (Named$ (&/T "lux" "Meta")
+ (Named$ (Ident$ &/prelude-name "Meta")
(All$ empty-env "lux;Meta" "m"
(All$ no-env "" "v"
- (Variant$ (&/|list
- ;; &/$Meta
- (Tuple$ (&/|list (Bound$ "m")
- (Bound$ "v")))))))))
+ (Prod$ (Bound$ "m")
+ (Bound$ "v"))))))
(def AST*
- (Named$ (&/T "lux" "AST'")
+ (Named$ (Ident$ &/prelude-name "AST'")
(let [AST* (App$ (Bound$ "w")
(App$ (Bound$ "lux;AST'")
(Bound$ "w")))
AST*List (App$ List AST*)]
(All$ empty-env "lux;AST'" "w"
- (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*))))
- )))))
+ ($$ 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*))
+ )))))
(def AST
- (Named$ (&/T "lux" "AST")
+ (Named$ (Ident$ &/prelude-name "AST")
(let [w (App$ Meta Cursor)]
(App$ w (App$ AST* w)))))
(def ^:private ASTList (App$ List AST))
(def Either
- (Named$ (&/T "lux" "Either")
+ (Named$ (Ident$ &/prelude-name "Either")
(All$ empty-env "lux;Either" "l"
(All$ no-env "" "r"
- (Variant$ (&/|list
- ;; &/$Left
- (Bound$ "l")
- ;; &/$Right
- (Bound$ "r")))))))
+ (Sum$
+ ;; &/$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)
- (Tuple$ (&/|list (Bound$ "s")
- (Bound$ "a"))))))))
+ (Prod$ (Bound$ "s")
+ (Bound$ "a")))))))
(def Source
- (Named$ (&/T "lux" "Source")
+ (Named$ (Ident$ &/prelude-name "Source")
(App$ List
(App$ (App$ Meta Cursor)
Text))))
(def Host
- (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")))))
+ (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"))))
(def DefData*
(All$ empty-env "lux;DefData'" ""
- (Variant$ (&/|list
- ;; "lux;ValueD"
- (Tuple$ (&/|list Type Unit))
- ;; "lux;TypeD"
- Type
- ;; "lux;MacroD"
- (Bound$ "")
- ;; "lux;AliasD"
- Ident
- ))))
+ ($$ Sum$
+ ;; "lux;ValueD"
+ (Prod$ Type Unit)
+ ;; "lux;TypeD"
+ Type
+ ;; "lux;MacroD"
+ (Bound$ "")
+ ;; "lux;AliasD"
+ Ident
+ )))
(def LuxVar
- (Named$ (&/T "lux" "LuxVar")
- (Variant$ (&/|list
- ;; "lux;Local"
- Int
- ;; "lux;Global"
- Ident))))
+ (Named$ (Ident$ &/prelude-name "LuxVar")
+ (Sum$
+ ;; "lux;Local"
+ Int
+ ;; "lux;Global"
+ Ident)))
(def $Module
(All$ empty-env "lux;$Module" "Compiler"
- (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)))))
- ))))
+ ($$ 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)))
+ )))
(def $Compiler
- (Named$ (&/T "lux" "Compiler")
+ (Named$ (Ident$ &/prelude-name "Compiler")
(App$ (All$ empty-env "lux;Compiler" ""
- (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
- )))
+ ($$ 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
+ ))
$Void)))
(def Macro
- (Named$ (&/T "lux" "Macro")
+ (Named$ (Ident$ &/prelude-name "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)
@@ -332,7 +330,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)
@@ -343,32 +341,37 @@
(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 (&/V &/$Some type) %)
- ts))
- state)
+ (return* (&/$update-type-vars (fn [ts] (&/$update-mappings #(&/|put id (&/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 #(->> %
- (&/update$ &/$counter inc)
- (&/update$ &/$mappings (fn [ms] (&/|put id (&/V &/$None nil) ms))))
- 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)
id))))
(def existential
(|do [seed &/gen-id]
- (return (&/V &/$ExT seed))))
+ (return (&/S &/$ExT seed))))
(declare clean*)
(defn ^:private delete-var [id]
@@ -390,19 +393,19 @@
(|case ?type*
(&/$VarT ?id*)
(if (.equals ^Object id ?id*)
- (return (&/T ?id (&/V &/$None nil)))
+ (return (&/P ?id &/None$))
(return binding))
_
(|do [?type** (clean* id ?type*)]
- (return (&/T ?id (&/V &/$Some ?type**)))))
+ (return (&/P ?id (&/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))))
@@ -435,13 +438,15 @@
=param (clean* ?tid ?param)]
(return (App$ =lambda =param)))
- (&/$TupleT ?members)
- (|do [=members (&/map% (partial clean* ?tid) ?members)]
- (return (Tuple$ =members)))
-
- (&/$VariantT ?members)
- (|do [=members (&/map% (partial clean* ?tid) ?members)]
- (return (Variant$ =members)))
+ (&/$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)))
(&/$AllT ?env ?name ?arg ?body)
(|do [=env (|case ?env
@@ -451,9 +456,9 @@
(&/$Some ?env*)
(|do [clean-env (&/map% (fn [[k v]]
(|do [=v (clean* ?tid v)]
- (return (&/T k =v))))
+ (return (&/P k =v))))
?env*)]
- (return (&/V &/$Some clean-env))))
+ (return (&/Some$ clean-env))))
body* (clean* ?tid ?body)]
(return (All$ =env ?name ?arg body*)))
@@ -473,37 +478,36 @@
(|case type
(&/$LambdaT ?in ?out)
(|let [[??out ?args] (unravel-fun ?out)]
- (&/T ??out (&/|cons ?in ?args)))
+ (&/P ??out (&/Cons$ ?in ?args)))
_
- (&/T type (&/|list))))
+ (&/P type (&/|list))))
(defn ^:private unravel-app [fun-type]
(|case fun-type
(&/$AppT ?left ?right)
(|let [[?fun-type ?args] (unravel-app ?left)]
- (&/T ?fun-type (&/|++ ?args (&/|list ?right))))
+ (&/P ?fun-type (&/|++ ?args (&/|list ?right))))
_
- (&/T fun-type (&/|list))))
+ (&/P fun-type (&/|list))))
(defn show-type [^objects type]
(|case type
+ (&/$VoidT)
+ "(|)"
+
+ (&/$UnitT)
+ "(,)"
+
(&/$DataT name)
(str "(^ " name ")")
- (&/$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 "")) ")"))
+ (&/$ProdT left right)
+ (str "(, " (show-type left) " " (show-type right) ")")
+
+ (&/$SumT left right)
+ (str "(| " (show-type left) " " (show-type right) ")")
(&/$LambdaT input output)
(|let [[?out ?ins] (unravel-fun type)]
@@ -547,15 +551,13 @@
[(&/$DataT xname) (&/$DataT yname)]
(.equals ^Object xname yname)
- [(&/$TupleT xelems) (&/$TupleT yelems)]
- (&/fold2 (fn [old x y] (and old (type= x y)))
- true
- xelems yelems)
+ [(&/$ProdT xleft xright) (&/$ProdT 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)
+ [(&/$SumT xleft xright) (&/$SumT yleft yright)]
+ (and (type= xleft yleft)
+ (type= xright yright))
[(&/$LambdaT xinput xoutput) (&/$LambdaT yinput youtput)]
(and (type= xinput yinput)
@@ -607,17 +609,17 @@
(|let [[e a] k]
(|case fixpoints
(&/$Nil)
- (&/V &/$None nil)
+ &/None$
(&/$Cons [[e* a*] v*] fixpoints*)
(if (and (type= e e*)
(type= a a*))
- (&/V &/$Some v*)
+ (&/Some$ v*)
(fp-get k fixpoints*))
)))
(defn ^:private fp-put [k v fixpoints]
- (&/|cons (&/T k v) fixpoints))
+ (&/Cons$ (&/P k v) fixpoints))
(defn ^:private check-error [expected actual]
(str "[Type Checker]\nExpected: " (show-type expected)
@@ -626,11 +628,11 @@
(defn beta-reduce [env type]
(|case type
- (&/$VariantT ?members)
- (Variant$ (&/|map (partial beta-reduce env) ?members))
+ (&/$SumT ?left ?right)
+ (Sum$ (beta-reduce env ?left) (beta-reduce env ?right))
- (&/$TupleT ?members)
- (Tuple$ (&/|map (partial beta-reduce env) ?members))
+ (&/$ProdT ?left ?right)
+ (Prod$ (beta-reduce env ?left) (beta-reduce env ?right))
(&/$AppT ?type-fn ?type-arg)
(App$ (beta-reduce env ?type-fn) (beta-reduce env ?type-arg))
@@ -638,7 +640,7 @@
(&/$AllT ?local-env ?local-name ?local-arg ?local-def)
(|case ?local-env
(&/$None)
- (All$ (&/V &/$Some env) ?local-name ?local-arg ?local-def)
+ (All$ (&/Some$ env) ?local-name ?local-arg ?local-def)
(&/$Some _)
type)
@@ -697,30 +699,32 @@
(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 (&/T fixpoints nil))
+ (return (&/P fixpoints nil))
(|case [expected actual]
[(&/$VarT ?eid) (&/$VarT ?aid)]
(if (.equals ^Object ?eid ?aid)
- (return (&/T fixpoints nil))
+ (return (&/P fixpoints nil))
(|do [ebound (fn [state]
(|case ((deref ?eid) state)
(&/$Right state* ebound)
- (return* state* (&/V &/$Some ebound))
+ (return* state* (&/Some$ ebound))
(&/$Left _)
- (return* state (&/V &/$None nil))))
+ (return* state &/None$)))
abound (fn [state]
(|case ((deref ?aid) state)
(&/$Right state* abound)
- (return* state* (&/V &/$Some abound))
+ (return* state* (&/Some$ abound))
(&/$Left _)
- (return* state (&/V &/$None nil))))]
+ (return* state &/None$)))]
(|case [ebound abound]
[(&/$None _) (&/$None _)]
(|do [_ (set-var ?eid actual)]
- (return (&/T fixpoints nil)))
+ (return (&/P fixpoints nil)))
[(&/$Some etype) (&/$None _)]
(check* class-loader fixpoints etype actual)
@@ -735,7 +739,7 @@
(fn [state]
(|case ((set-var ?id actual) state)
(&/$Right state* _)
- (return* state* (&/T fixpoints nil))
+ (return* state* (&/P fixpoints nil))
(&/$Left _)
((|do [bound (deref ?id)]
@@ -746,7 +750,7 @@
(fn [state]
(|case ((set-var ?id expected) state)
(&/$Right state* _)
- (return* state* (&/T fixpoints nil))
+ (return* state* (&/P fixpoints nil))
(&/$Left _)
((|do [bound (deref ?id)]
@@ -757,9 +761,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)
@@ -780,11 +784,11 @@
(&/$Left _)
((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid))
[fixpoints** _] (check* class-loader fixpoints* A1 A2)]
- (return (&/T fixpoints** nil)))
+ (return (&/P fixpoints** nil)))
state))))
;; (|do [_ (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid))
;; _ (check* class-loader fixpoints A1 A2)]
- ;; (return (&/T fixpoints nil)))
+ ;; (return (&/P fixpoints nil)))
[(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)]
(fn [state]
@@ -799,14 +803,14 @@
e* (apply-type F2 A1)
a* (apply-type F2 A2)
[fixpoints** _] (check* class-loader fixpoints* e* a*)]
- (return (&/T fixpoints** nil)))
+ (return (&/P 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 (&/T fixpoints** nil)))
+ ;; (return (&/P fixpoints** nil)))
[(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)]
(fn [state]
@@ -821,17 +825,17 @@
e* (apply-type F1 A1)
a* (apply-type F1 A2)
[fixpoints** _] (check* class-loader fixpoints* e* a*)]
- (return (&/T fixpoints** nil)))
+ (return (&/P 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 (&/T fixpoints** nil)))
+ ;; (return (&/P fixpoints** nil)))
[(&/$AppT F A) _]
- (let [fp-pair (&/T expected actual)
+ (let [fp-pair (&/P expected actual)
_ (when (> (&/|length fixpoints) 40)
(println 'FIXPOINTS (->> (&/|keys fixpoints)
(&/|map (fn [pair]
@@ -844,7 +848,7 @@
(|case (fp-get fp-pair fixpoints)
(&/$Some ?)
(if ?
- (return (&/T fixpoints nil))
+ (return (&/P fixpoints nil))
(fail (check-error expected actual)))
(&/$None)
@@ -870,39 +874,33 @@
[(&/$DataT e!name) (&/$DataT "null")]
(if (contains? primitive-types e!name)
(fail (str "[Type Error] Can't use \"null\" with primitive types."))
- (return (&/T fixpoints nil)))
+ (return (&/P 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 (&/T fixpoints nil))
+ (return (&/P 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))
- [(&/$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)))
+ [(&/$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)))
- [(&/$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)))
+ [(&/$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)))
[(&/$ExT e!id) (&/$ExT a!id)]
(if (.equals ^Object e!id a!id)
- (return (&/T fixpoints nil))
+ (return (&/P fixpoints nil))
(fail (check-error expected actual)))
[(&/$NamedT ?ename ?etype) _]
@@ -958,20 +956,31 @@
))
(defn variant-case [tag type]
+ ;; (prn 'variant-case tag (show-type type))
(|case type
(&/$NamedT ?name ?type)
(variant-case tag ?type)
- (&/$VariantT ?cases)
- (|case (&/|at tag ?cases)
- (&/$Some case-type)
- (return case-type)
+ (&/$SumT ?left ?right)
+ (case tag
+ 0
+ (return ?left)
- (&/$None)
- (fail (str "[Type Error] Variant lacks case: " tag " | " (show-type type))))
+ 1
+ (|case ?right
+ (&/$SumT ?left* _)
+ (return ?left*)
+
+ _
+ (return ?right))
+
+ ;; else
+ (variant-case (dec tag) ?right))
_
- (fail (str "[Type Error] Type is not a variant: " (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)))
+ ))
(defn type-name [type]
"(-> Type (Lux Ident))"
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-28 03:40:56 +0000