aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2015-08-10 18:25:39 -0400
committerEduardo Julian2015-08-10 18:25:39 -0400
commit4134c811399abfce64b54a821e427d2b153f3e57 (patch)
treedc9bb9a1c4bf8981410d570c2390c4be788f5b72
parent4fabf7e4f01d1e617620e9bc361ed27ba3b8b5e0 (diff)
- Changing tags so they're actually indices (part 1).
- Fixed a bug regarding type coercion (type-checking was ocurring unnecessarily). - Fixed another bug regarding Local/Global variables.
Diffstat (limited to '')
-rw-r--r--source/lux.lux308
-rw-r--r--src/lux/analyser.clj38
-rw-r--r--src/lux/analyser/base.clj1
-rw-r--r--src/lux/analyser/env.clj2
-rw-r--r--src/lux/analyser/lux.clj84
-rw-r--r--src/lux/analyser/module.clj47
-rw-r--r--src/lux/base.clj98
-rw-r--r--src/lux/compiler.clj4
-rw-r--r--src/lux/compiler/lux.clj15
-rw-r--r--src/lux/type.clj409
10 files changed, 652 insertions, 354 deletions
diff --git a/source/lux.lux b/source/lux.lux
index 7110cc709..d023406f8 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -10,6 +10,10 @@
(_jvm_interface "Function" []
("apply" ["java.lang.Object"] "java.lang.Object" ["public" "abstract"]))
+(_lux_declare-tags [#DataT #TupleT #VariantT #RecordT #LambdaT #BoundT #VarT #ExT #AllT #AppT])
+(_lux_declare-tags [#None #Some])
+(_lux_declare-tags [#Nil #Cons])
+
## Basic types
(_lux_def Bool (#DataT "java.lang.Boolean"))
(_lux_export Bool)
@@ -40,11 +44,13 @@
## (#Cons a (List a))))
(_lux_def List
(#AllT (#Some #Nil) "lux;List" "a"
- (#VariantT (#Cons ["lux;Nil" (#TupleT #Nil)]
- (#Cons ["lux;Cons" (#TupleT (#Cons (#BoundT "a")
- (#Cons (#AppT (#BoundT "lux;List") (#BoundT "a"))
- #Nil)))]
- #Nil)))))
+ (#VariantT (#Cons ## "lux;Nil"
+ (#TupleT #Nil)
+ (#Cons ## "lux;Cons"
+ (#TupleT (#Cons (#BoundT "a")
+ (#Cons (#AppT (#BoundT "lux;List") (#BoundT "a"))
+ #Nil)))
+ #Nil)))))
(_lux_export List)
## (deftype (Maybe a)
@@ -52,16 +58,18 @@
## (#Some a)))
(_lux_def Maybe
(#AllT (#Some #Nil) "lux;Maybe" "a"
- (#VariantT (#Cons ["lux;None" (#TupleT #Nil)]
- (#Cons ["lux;Some" (#BoundT "a")]
- #Nil)))))
+ (#VariantT (#Cons ## "lux;None"
+ (#TupleT #Nil)
+ (#Cons ## "lux;Some"
+ (#BoundT "a")
+ #Nil)))))
(_lux_export Maybe)
## (deftype #rec Type
## (| (#DataT Text)
## (#TupleT (List Type))
-## (#VariantT (List (, Text Type)))
-## (#RecordT (List (, Text Type)))
+## (#VariantT (List Type))
+## (#RecordT (List Type))
## (#LambdaT Type Type)
## (#BoundT Text)
## (#VarT Int)
@@ -72,19 +80,31 @@
Type
(_lux_case (#AppT List (#TupleT (#Cons Text (#Cons Type #Nil))))
TypeEnv
- (#AppT (#AllT (#Some #Nil) "Type" "_"
- (#VariantT (#Cons ["lux;DataT" Text]
- (#Cons ["lux;TupleT" (#AppT List Type)]
- (#Cons ["lux;VariantT" TypeEnv]
- (#Cons ["lux;RecordT" TypeEnv]
- (#Cons ["lux;LambdaT" (#TupleT (#Cons Type (#Cons Type #Nil)))]
- (#Cons ["lux;BoundT" Text]
- (#Cons ["lux;VarT" Int]
- (#Cons ["lux;AllT" (#TupleT (#Cons (#AppT Maybe TypeEnv) (#Cons Text (#Cons Text (#Cons Type #Nil)))))]
- (#Cons ["lux;AppT" (#TupleT (#Cons Type (#Cons Type #Nil)))]
- (#Cons ["lux;ExT" Int]
- #Nil))))))))))))
- Void))))
+ (_lux_case (#AppT List Type)
+ TypeList
+ (#AppT (#AllT (#Some #Nil) "Type" "_"
+ (#VariantT (#Cons ## "lux;DataT"
+ Text
+ (#Cons ## "lux;TupleT"
+ TypeList
+ (#Cons ## "lux;VariantT"
+ TypeList
+ (#Cons ## "lux;RecordT"
+ TypeList
+ (#Cons ## "lux;LambdaT"
+ (#TupleT (#Cons Type (#Cons Type #Nil)))
+ (#Cons ## "lux;BoundT"
+ Text
+ (#Cons ## "lux;VarT"
+ Int
+ (#Cons ## "lux;ExT"
+ Int
+ (#Cons ## "lux;AllT"
+ (#TupleT (#Cons (#AppT Maybe TypeEnv) (#Cons Text (#Cons Text (#Cons Type #Nil)))))
+ (#Cons ## "lux;AppT"
+ (#TupleT (#Cons Type (#Cons Type #Nil)))
+ #Nil))))))))))))
+ Void)))))
(_lux_export Type)
## (deftype (Bindings k v)
@@ -93,12 +113,14 @@
(_lux_def Bindings
(#AllT [(#Some #Nil) "lux;Bindings" "k"
(#AllT [#None "" "v"
- (#RecordT (#Cons [["lux;counter" Int]
- (#Cons [["lux;mappings" (#AppT [List
- (#TupleT (#Cons [(#BoundT "k")
- (#Cons [(#BoundT "v")
- #Nil])]))])]
- #Nil])]))])]))
+ (#RecordT (#Cons ## "lux;counter"
+ Int
+ (#Cons ## "lux;mappings"
+ (#AppT [List
+ (#TupleT (#Cons [(#BoundT "k")
+ (#Cons [(#BoundT "v")
+ #Nil])]))])
+ #Nil)))])]))
(_lux_export Bindings)
## (deftype (Env k v)
@@ -109,12 +131,16 @@
(_lux_def Env
(#AllT [(#Some #Nil) "lux;Env" "k"
(#AllT [#None "" "v"
- (#RecordT (#Cons [["lux;name" Text]
- (#Cons [["lux;inner-closures" Int]
- (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")])
- (#BoundT "v")])]
- (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")])
- (#BoundT "v")])]
+ (#RecordT (#Cons [## "lux;name"
+ Text
+ (#Cons [## "lux;inner-closures"
+ Int
+ (#Cons [## "lux;locals"
+ (#AppT [(#AppT [Bindings (#BoundT "k")])
+ (#BoundT "v")])
+ (#Cons [## "lux;closure"
+ (#AppT [(#AppT [Bindings (#BoundT "k")])
+ (#BoundT "v")])
#Nil])])])]))])]))
(_lux_export Env)
@@ -129,11 +155,13 @@
(_lux_def Meta
(#AllT [(#Some #Nil) "lux;Meta" "m"
(#AllT [#None "" "v"
- (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m")
- (#Cons [(#BoundT "v")
- #Nil])]))]
+ (#VariantT (#Cons [## "lux;Meta"
+ (#TupleT (#Cons [(#BoundT "m")
+ (#Cons [(#BoundT "v")
+ #Nil])]))
#Nil]))])]))
(_lux_export Meta)
+(_lux_declare-tags [#Meta])
## (deftype (AST' w)
## (| (#BoolS Bool)
@@ -154,20 +182,31 @@
(_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])]))])]
+ (#VariantT (#Cons [## "lux;BoolS"
+ Bool
+ (#Cons [## "lux;IntS"
+ Int
+ (#Cons [## "lux;RealS"
+ Real
+ (#Cons [## "lux;CharS"
+ Char
+ (#Cons [## "lux;TextS"
+ Text
+ (#Cons [## "lux;SymbolS"
+ Ident
+ (#Cons [## "lux;TagS"
+ Ident
+ (#Cons [## "lux;FormS"
+ ASTList
+ (#Cons [## "lux;TupleS"
+ ASTList
+ (#Cons [## "lux;RecordS"
+ (#AppT [List (#TupleT (#Cons [AST (#Cons [AST #Nil])]))])
#Nil])
])])])])])])])])])
)]))))
(_lux_export AST')
+(_lux_declare-tags [#BoolS #IntS #RealS #CharS #TextS #SymbolS #TagS #FormS #TupleS #RecordS])
## (deftype AST
## (Meta Cursor (AST' (Meta Cursor))))
@@ -185,10 +224,13 @@
(_lux_def Either
(#AllT [(#Some #Nil) "lux;Either" "l"
(#AllT [#None "" "r"
- (#VariantT (#Cons [["lux;Left" (#BoundT "l")]
- (#Cons [["lux;Right" (#BoundT "r")]
+ (#VariantT (#Cons [## "lux;Left"
+ (#BoundT "l")
+ (#Cons [## "lux;Right"
+ (#BoundT "r")
#Nil])]))])]))
(_lux_export Either)
+(_lux_declare-tags [#Left #Right])
## (deftype (StateE s a)
## (-> s (Either Text (, s a))))
@@ -214,9 +256,12 @@
## #loader (^ java.net.URLClassLoader)
## #classes (^ clojure.lang.Atom)))
(_lux_def HostState
- (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")]
- (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")]
- (#Cons [["lux;classes" (#DataT "clojure.lang.Atom")]
+ (#RecordT (#Cons [## "lux;writer"
+ (#DataT "org.objectweb.asm.ClassWriter")
+ (#Cons [## "lux;loader"
+ (#DataT "java.lang.ClassLoader")
+ (#Cons [## "lux;classes"
+ (#DataT "clojure.lang.Atom")
#Nil])])])))
## (deftype (DefData' m)
@@ -226,12 +271,16 @@
## (#AliasD Ident)))
(_lux_def DefData'
(#AllT [(#Some #Nil) "lux;DefData'" ""
- (#VariantT (#Cons [["lux;TypeD" Type]
- (#Cons [["lux;ValueD" (#TupleT (#Cons [Type
- (#Cons [Unit
- #Nil])]))]
- (#Cons [["lux;MacroD" (#BoundT "")]
- (#Cons [["lux;AliasD" Ident]
+ (#VariantT (#Cons [## "lux;TypeD"
+ Type
+ (#Cons [## "lux;ValueD"
+ (#TupleT (#Cons [Type
+ (#Cons [Unit
+ #Nil])]))
+ (#Cons [## "lux;MacroD"
+ (#BoundT "")
+ (#Cons [## "lux;AliasD"
+ Ident
#Nil])])])]))]))
(_lux_export DefData')
@@ -239,27 +288,40 @@
## (| (#Local Int)
## (#Global Ident)))
(_lux_def LuxVar
- (#VariantT (#Cons [["lux;Local" Int]
- (#Cons [["lux;Global" Ident]
+ (#VariantT (#Cons [## "lux;Local"
+ Int
+ (#Cons [## "lux;Global"
+ Ident
#Nil])])))
(_lux_export LuxVar)
## (deftype (Module Compiler)
## (& #module-aliases (List (, Text Text))
-## #defs (List (, Text (, Bool (DefData' (-> (List AST) (StateE Compiler (List AST)))))))
-## #imports (List Text)
+## #defs (List (, Text (, Bool (DefData' (-> (List AST) (StateE Compiler (List AST)))))))
+## #imports (List Text)
+## #tags (List (, Text (, Int (List Ident))))
## ))
(_lux_def Module
(#AllT [(#Some #Nil) "lux;Module" "Compiler"
- (#RecordT (#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])]
- #Nil])])]))]))
+ (#RecordT (#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])
+ #Nil)))
+ #Nil)))])
+ #Nil])])])]))]))
(_lux_export Module)
## (deftype #rec Compiler
@@ -271,21 +333,31 @@
## #seed Int
## #eval? Bool
## #expected Type
-## #cursor Cursor))
+## #cursor Cursor
+## ))
(_lux_def Compiler
(#AppT [(#AllT [(#Some #Nil) "lux;Compiler" ""
- (#RecordT (#Cons [["lux;source" Reader]
- (#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;types" (#AppT [(#AppT [Bindings Int]) Type])]
- (#Cons [["lux;host" HostState]
- (#Cons [["lux;seed" Int]
- (#Cons [["lux;eval?" Bool]
- (#Cons [["lux;expected" Type]
- (#Cons [["lux;cursor" Cursor]
+ (#RecordT (#Cons [## "lux;source"
+ Reader
+ (#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;types"
+ (#AppT [(#AppT [Bindings Int]) Type])
+ (#Cons [## "lux;host"
+ HostState
+ (#Cons [## "lux;seed"
+ Int
+ (#Cons [## "lux;eval?"
+ Bool
+ (#Cons [## "lux;expected"
+ Type
+ (#Cons [## "lux;cursor"
+ Cursor
#Nil])])])])])])])])]))])
Void]))
(_lux_export Compiler)
@@ -293,9 +365,9 @@
## (deftype Macro
## (-> (List AST) (StateE Compiler (List AST))))
(_lux_def Macro
- (#LambdaT [ASTList
- (#AppT [(#AppT [StateE Compiler])
- ASTList])]))
+ (#LambdaT ASTList
+ (#AppT (#AppT StateE Compiler)
+ ASTList)))
(_lux_export Macro)
## Base functions & macros
@@ -309,11 +381,11 @@
## (-> (AST' (Meta Cursor)) AST)
## (#Meta [["" -1 -1] data]))
(_lux_def _meta
- (_lux_: (#LambdaT [(#AppT [AST'
- (#AppT [Meta Cursor])])
- AST])
+ (_lux_: (#LambdaT (#AppT AST'
+ (#AppT Meta Cursor))
+ AST)
(_lux_lambda _ data
- (#Meta [_cursor data]))))
+ (#Meta _cursor data))))
## (def (return x)
## (All [a]
@@ -321,16 +393,16 @@
## (Either Text (, Compiler a))))
## ...)
(_lux_def return
- (_lux_: (#AllT [(#Some #Nil) "" "a"
- (#LambdaT [(#BoundT "a")
- (#LambdaT [Compiler
- (#AppT [(#AppT [Either Text])
- (#TupleT (#Cons [Compiler
- (#Cons [(#BoundT "a")
- #Nil])]))])])])])
+ (_lux_: (#AllT (#Some #Nil) "" "a"
+ (#LambdaT (#BoundT "a")
+ (#LambdaT Compiler
+ (#AppT (#AppT Either Text)
+ (#TupleT (#Cons Compiler
+ (#Cons (#BoundT "a")
+ #Nil)))))))
(_lux_lambda _ val
(_lux_lambda _ state
- (#Right [state val])))))
+ (#Right state val)))))
## (def (fail msg)
## (All [a]
@@ -338,49 +410,49 @@
## (Either Text (, Compiler a))))
## ...)
(_lux_def fail
- (_lux_: (#AllT [(#Some #Nil) "" "a"
- (#LambdaT [Text
- (#LambdaT [Compiler
- (#AppT [(#AppT [Either Text])
- (#TupleT (#Cons [Compiler
- (#Cons [(#BoundT "a")
- #Nil])]))])])])])
+ (_lux_: (#AllT (#Some #Nil) "" "a"
+ (#LambdaT Text
+ (#LambdaT Compiler
+ (#AppT (#AppT Either Text)
+ (#TupleT (#Cons Compiler
+ (#Cons (#BoundT "a")
+ #Nil)))))))
(_lux_lambda _ msg
(_lux_lambda _ state
(#Left msg)))))
(_lux_def text$
- (_lux_: (#LambdaT [Text AST])
+ (_lux_: (#LambdaT Text AST)
(_lux_lambda _ text
(_meta (#TextS text)))))
(_lux_def int$
- (_lux_: (#LambdaT [Int AST])
+ (_lux_: (#LambdaT Int AST)
(_lux_lambda _ value
(_meta (#IntS value)))))
(_lux_def symbol$
- (_lux_: (#LambdaT [Ident AST])
+ (_lux_: (#LambdaT Ident AST)
(_lux_lambda _ ident
(_meta (#SymbolS ident)))))
(_lux_def tag$
- (_lux_: (#LambdaT [Ident AST])
+ (_lux_: (#LambdaT Ident AST)
(_lux_lambda _ ident
(_meta (#TagS ident)))))
(_lux_def form$
- (_lux_: (#LambdaT [(#AppT [List AST]) AST])
+ (_lux_: (#LambdaT (#AppT List AST) AST)
(_lux_lambda _ tokens
(_meta (#FormS tokens)))))
(_lux_def tuple$
- (_lux_: (#LambdaT [(#AppT [List AST]) AST])
+ (_lux_: (#LambdaT (#AppT List AST) AST)
(_lux_lambda _ tokens
(_meta (#TupleS tokens)))))
(_lux_def record$
- (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [AST (#Cons [AST #Nil])]))]) AST])
+ (_lux_: (#LambdaT (#AppT List (#TupleT (#Cons AST (#Cons AST #Nil)))) AST)
(_lux_lambda _ tokens
(_meta (#RecordS tokens)))))
@@ -388,10 +460,10 @@
(_lux_: Macro
(_lux_lambda _ tokens
(_lux_case tokens
- (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])])
- (return (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_case"])
- (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])]))
- #Nil]))
+ (#Cons lhs (#Cons rhs (#Cons body #Nil)))
+ (return (#Cons (form$ (#Cons (symbol$ ["" "_lux_case"])
+ (#Cons rhs (#Cons lhs (#Cons body #Nil)))))
+ #Nil))
_
(fail "Wrong syntax for let''")))))
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index 0e58f530b..7810c415b 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -17,7 +17,8 @@
[host :as &host])
(lux.analyser [base :as &&]
[lux :as &&lux]
- [host :as &&host])))
+ [host :as &&host]
+ [module :as &&module])))
;; [Utils]
(defn ^:private parse-handler [[catch+ finally+] token]
@@ -37,6 +38,14 @@
_
(fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token)))))
+(defn ^:private parse-tag [ast]
+ (|case ast
+ (&/$Meta _ (&/$TagS "" name))
+ (return name)
+
+ _
+ (fail (str "[Analyser Error] Not a tag: " (&/show-ast ast)))))
+
(defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token]
(|case token
;; Arrays
@@ -431,6 +440,12 @@
(&/$Nil))))
(&&lux/analyse-declare-macro analyse compile-token ?name)
+ (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-tags"))
+ (&/$Cons (&/$Meta _ (&/$TupleS tags))
+ (&/$Nil))))
+ (|do [tags* (&/map% parse-tag tags)]
+ (&&lux/analyse-declare-tags tags*))
+
(&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_import"))
(&/$Cons (&/$Meta _ (&/$TextS ?path))
(&/$Nil))))
@@ -492,7 +507,9 @@
(&&lux/analyse-record analyse exo-type ?elems)
(&/$TagS ?ident)
- (&&lux/analyse-variant analyse exo-type ?ident (&/|list))
+ (|do [[module tag-name] (&/normalize ?ident)
+ idx (&&module/tag-index module tag-name)]
+ (&&lux/analyse-variant analyse exo-type idx (&/|list)))
(&/$SymbolS _ "_jvm_null")
(&&host/analyse-jvm-null analyse exo-type)
@@ -512,7 +529,10 @@
(|case token
(&/$Meta meta ?token)
(fn [state]
- (|case ((aba1 analyse eval! compile-module compile-token exo-type ?token) 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)))))
(&/$Right state* output)
(return* state* output)
@@ -540,11 +560,21 @@
))))
(defn ^:private analyse-ast [eval! compile-module compile-token exo-type 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)))
- (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type ?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]
diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj
index 3484e869d..218fc6dd9 100644
--- a/src/lux/analyser/base.clj
+++ b/src/lux/analyser/base.clj
@@ -28,6 +28,7 @@
"ann"
"def"
"declare-macro"
+ "var"
"captured"
"jvm-getstatic"
diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj
index 2f35218d8..614b38799 100644
--- a/src/lux/analyser/env.clj
+++ b/src/lux/analyser/env.clj
@@ -24,7 +24,7 @@
(let [old-mappings (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS))
=return (body (&/update$ &/$ENVS
(fn [stack]
- (let [bound-unit (&/V &/$Local (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER)))]
+ (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))))
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 45177ce46..ba4a173f0 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -71,7 +71,7 @@
_
(fail "[Analyser Error] Can't expand to other than 1 element."))))
-(defn analyse-variant [analyse exo-type ident ?values]
+(defn analyse-variant [analyse exo-type idx ?values]
(|do [exo-type* (|case exo-type
(&/$VarT ?id)
(&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)]
@@ -83,21 +83,50 @@
(&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*)))))
+ (|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** ident ?values))))
+ (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
@@ -158,7 +187,7 @@
(clojure.lang.Util/identical &type/Type exo-type))
(return nil)
(&type/check exo-type endo-type))]
- (return (&/|list (&/T (&/V &/$Global (&/T r-module r-name))
+ (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name)))
endo-type)))))
(defn ^:private analyse-local [analyse exo-type name]
@@ -194,7 +223,7 @@
(clojure.lang.Util/identical &type/Type exo-type))
(return nil)
(&type/check exo-type endo-type))]
- (return (&/|list (&/T (&/V &/$Global (&/T r-module r-name))
+ (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name)))
endo-type))))
state)
@@ -397,14 +426,39 @@
_
(do (println 'DEF (str module-name ";" ?name))
- (|do [_ (compile-token (&/V &&/$def (&/T ?name =value)))]
+ (|do [_ (compile-token (&/V &&/$def (&/T ?name =value)))
+ :let [_ (println 'DEF/COMPILED (str module-name ";" ?name))]]
(return (&/|list)))))
))))
(defn analyse-declare-macro [analyse compile-token ?name]
- (|do [module-name &/get-module-name]
- (|do [_ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))]
- (return (&/|list)))))
+ (|do [module-name &/get-module-name
+ _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))]
+ (return (&/|list))))
+
+(defn ensure-undeclared-tags [module tags]
+ (|do [;; :let [_ (prn 'ensure-undeclared-tags/_0)]
+ tags-table (&&module/tags-by-module module)
+ ;; :let [_ (prn 'ensure-undeclared-tags/_1)]
+ _ (&/map% (fn [tag]
+ (if (&/|get tag tags-table)
+ (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T module tag))))
+ (return nil)))
+ tags)
+ ;; :let [_ (prn 'ensure-undeclared-tags/_2)]
+ ]
+ (return nil)))
+
+(defn analyse-declare-tags [tags]
+ (|do [;; :let [_ (prn 'analyse-declare-tags/_0)]
+ module-name &/get-module-name
+ ;; :let [_ (prn 'analyse-declare-tags/_1)]
+ _ (ensure-undeclared-tags module-name tags)
+ ;; :let [_ (prn 'analyse-declare-tags/_2)]
+ _ (&&module/declare-tags module-name tags)
+ ;; :let [_ (prn 'analyse-declare-tags/_3)]
+ ]
+ (return (&/|list))))
(defn analyse-import [analyse compile-module compile-token ?path]
(|do [module-name &/get-module-name
@@ -440,6 +494,6 @@
(|do [=type (&&/analyse-1 analyse &type/Type ?type)
==type (eval! =type)
_ (&type/check exo-type ==type)
- =value (&&/analyse-1 analyse ==type ?value)]
+ =value (analyse-1+ analyse ?value)]
(return (&/|list (&/T (&/V &&/$ann (&/T =value =type))
==type)))))
diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj
index 35ae7e5b7..68554a019 100644
--- a/src/lux/analyser/module.clj
+++ b/src/lux/analyser/module.clj
@@ -18,14 +18,17 @@
;; [Utils]
(def ^:private $DEFS 0)
-(def ^:private $ALIASES 1)
-(def ^:private $IMPORTS 2)
+(def ^:private $IMPORTS 1)
+(def ^:private $ALIASES 2)
+(def ^:private $tags 3)
(def ^:private +init+
(&/R ;; "lux;defs"
(&/|table)
+ ;; "lux;imports"
+ (&/|list)
;; "lux;module-aliases"
(&/|table)
- ;; "lux;imports"
+ ;; "lux;tags"
(&/|list)
))
@@ -235,12 +238,50 @@
(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)))
(defn enter-module [name]
+ "(-> Text (Lux (,)))"
(fn [state]
(return* (->> state
(&/update$ &/$MODULES #(&/|put name +init+ %))
(&/set$ &/$ENVS (&/|list (&/env name))))
nil)))
+
+(defn tags-by-module [module]
+ "(-> Text (Lux (List (, Text (, Int (List Text))))))"
+ (fn [state]
+ (if-let [=module (->> state (&/get$ &/$MODULES) (&/|get module))]
+ (return* state (&/get$ $tags =module))
+ (fail* (str "[Lux Error] Unknown module: " module)))
+ ))
+
+(defn declare-tags [module tag-names]
+ "(-> Text (List Text) (Lux (,)))"
+ (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) table)))
+ (&/get$ $tags %)
+ (&/enumerate tag-names))
+ %)
+ =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))]
+ (return* state (aget idx+tags 0))
+ (fail* (str "[Lux Error] Unknown tag: " (&/ident->text (&/T module tag-name)))))
+ (fail* (str "[Lux Error] Unknown module: " module)))))
diff --git a/src/lux/base.clj b/src/lux/base.clj
index f690ef65f..73b2bb684 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -13,47 +13,53 @@
;; [Tags]
(defmacro deftags [prefix & names]
- `(do ~@(for [name names]
- `(def ~(symbol (str "$" name)) ~(str prefix name)))))
+ `(do ~@(for [[name idx] (map vector names (range (count names)))]
+ `(def ~(symbol (str "$" name)) ~idx))))
;; List
-(def $Nil "lux;Nil")
-(def $Cons "lux;Cons")
+(deftags ""
+ "Nil"
+ "Cons")
;; Maybe
-(def $None "lux;None")
-(def $Some "lux;Some")
+(deftags ""
+ "None"
+ "Some")
;; Meta
-(def $Meta "lux;Meta")
+(deftags ""
+ "Meta")
;; Either
-(def $Left "lux;Left")
-(def $Right "lux;Right")
+(deftags ""
+ "Left"
+ "Right")
;; AST
-(def $BoolS "lux;BoolS")
-(def $IntS "lux;IntS")
-(def $RealS "lux;RealS")
-(def $CharS "lux;CharS")
-(def $TextS "lux;TextS")
-(def $SymbolS "lux;SymbolS")
-(def $TagS "lux;TagS")
-(def $FormS "lux;FormS")
-(def $TupleS "lux;TupleS")
-(def $RecordS "lux;RecordS")
+(deftags ""
+ "BoolS"
+ "IntS"
+ "RealS"
+ "CharS"
+ "TextS"
+ "SymbolS"
+ "TagS"
+ "FormS"
+ "TupleS"
+ "RecordS")
;; Type
-(def $DataT "lux;DataT")
-(def $TupleT "lux;TupleT")
-(def $VariantT "lux;VariantT")
-(def $RecordT "lux;RecordT")
-(def $LambdaT "lux;LambdaT")
-(def $VarT "lux;VarT")
-(def $ExT "lux;ExT")
-(def $BoundT "lux;BoundT")
-(def $AppT "lux;AppT")
-(def $AllT "lux;AllT")
+(deftags ""
+ "DataT"
+ "TupleT"
+ "VariantT"
+ "RecordT"
+ "LambdaT"
+ "BoundT"
+ "VarT"
+ "ExT"
+ "AllT"
+ "AppT")
;; [Fields]
;; Binding
@@ -100,7 +106,7 @@
(defn T [& elems]
(to-array elems))
-(defn V [tag value]
+(defn V [^Long tag value]
(to-array [tag value]))
(defn R [& kvs]
@@ -726,6 +732,7 @@
output)))))
(defn show-ast [ast]
+ ;; (prn 'show-ast/GOOD (aget ast 0) (aget ast 1 1 0))
(|case ast
($Meta _ ($BoolS ?value))
(pr-str ?value)
@@ -762,6 +769,10 @@
($Meta _ ($FormS ?elems))
(str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")")
+
+ _
+ (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0)))
+ ;; (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0)))
))
(defn ident->text [ident]
@@ -814,6 +825,7 @@
false))
(defn ^:private enumerate* [idx xs]
+ "(All [a] (-> Int (List a) (List (, Int a))))"
(|case xs
($Cons x xs*)
(V $Cons (T (T idx x)
@@ -824,6 +836,7 @@
))
(defn enumerate [xs]
+ "(All [a] (-> (List a) (List (, Int a))))"
(enumerate* 0 xs))
(def modules
@@ -836,3 +849,28 @@
(if test
body
(return nil)))
+
+(defn |at [idx xs]
+ "(All [a] (-> Int (List a) (Maybe a)))"
+ ;; (prn '|at idx (aget idx 0))
+ (|case xs
+ ($Cons x xs*)
+ (cond (< idx 0)
+ (V $None nil)
+
+ (= idx 0)
+ (V $Some x)
+
+ :else ;; > 1
+ (|at (dec idx) xs*))
+
+ ($Nil)
+ (V $None nil)
+ ))
+
+(defn normalize [ident]
+ "(-> Ident (Lux Ident))"
+ (|case ident
+ ["" name] (|do [module get-module-name]
+ (return (T module name)))
+ _ (return ident)))
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 490491bd0..7622e3002 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -61,13 +61,13 @@
(&a/$record ?elems)
(&&lux/compile-record compile-expression ?type ?elems)
- (&/$Local ?idx)
+ (&a/$var (&/$Local ?idx))
(&&lux/compile-local compile-expression ?type ?idx)
(&a/$captured ?scope ?captured-id ?source)
(&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source)
- (&/$Global ?owner-class ?name)
+ (&a/$var (&/$Global ?owner-class ?name))
(&&lux/compile-global compile-expression ?type ?owner-class ?name)
(&a/$apply ?fn ?args)
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index 87327311c..9baefa21c 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -37,11 +37,13 @@
(do-template [<name> <class> <sig> <caster>]
(defn <name> [compile *type* value]
(|do [^MethodVisitor *writer* &/get-writer
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/NEW <class>)
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (<caster> value))
- (.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>))]]
+ :let [_ (try (doto *writer*
+ (.visitTypeInsn Opcodes/NEW <class>)
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn (<caster> value))
+ (.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>))
+ (catch Exception e
+ (assert false (prn-str '<name> (alength value) (aget value 0) (aget value 1)))))]]
(return nil)))
compile-int "java/lang/Long" "(J)V" long
@@ -99,6 +101,7 @@
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int 0))
(.visitLdcInsn ?tag)
+ (&&/wrap-long)
(.visitInsn Opcodes/AASTORE)
(.visitInsn Opcodes/DUP)
(.visitLdcInsn (int 1)))]
@@ -148,6 +151,7 @@
(.visitInsn Opcodes/DUP) ;; VV
(.visitLdcInsn (int 0)) ;; VVI
(.visitLdcInsn &/$TypeD) ;; VVIT
+ (&&/wrap-long)
(.visitInsn Opcodes/AASTORE) ;; V
(.visitInsn Opcodes/DUP) ;; VV
(.visitLdcInsn (int 1)) ;; VVI
@@ -174,6 +178,7 @@
(.visitInsn Opcodes/DUP) ;; VV
(.visitLdcInsn (int 0)) ;; VVI
(.visitLdcInsn &/$ValueD) ;; VVIT
+ (&&/wrap-long)
(.visitInsn Opcodes/AASTORE) ;; V
(.visitInsn Opcodes/DUP) ;; VV
(.visitLdcInsn (int 1)) ;; VVI
diff --git a/src/lux/type.clj b/src/lux/type.clj
index 0a80d4fbc..553318daf 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -23,39 +23,73 @@
(def Unit (&/V &/$TupleT (&/|list)))
(def $Void (&/V &/$VariantT (&/|list)))
+(def ^:private empty-env (&/V &/$Some (&/V &/$Nil nil)))
+(defn ^:private Bound$ [name]
+ (&/V &/$BoundT name))
+(defn ^:private Lambda$ [in out]
+ (&/V &/$LambdaT (&/T in out)))
+(defn ^:private App$ [fun arg]
+ (&/V &/$AppT (&/T fun arg)))
+(defn ^:private Tuple$ [members]
+ (&/V &/$TupleT members))
+(defn ^:private Variant$ [members]
+ (&/V &/$VariantT members))
+(defn ^:private Record$ [members]
+ (&/V &/$RecordT members))
+
(def IO
- (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "IO" "a"
- (&/V &/$LambdaT (&/T Unit (&/V &/$BoundT "a"))))))
+ (&/V &/$AllT (&/T empty-env "IO" "a"
+ (Lambda$ Unit (Bound$ "a")))))
(def List
- (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;List" "a"
- (&/V &/$VariantT (&/|list (&/T &/$Nil Unit)
- (&/T &/$Cons (&/V &/$TupleT (&/|list (&/V &/$BoundT "a")
- (&/V &/$AppT (&/T (&/V &/$BoundT "lux;List")
- (&/V &/$BoundT "a")))))))))))
+ (&/V &/$AllT (&/T empty-env "lux;List" "a"
+ (Variant$ (&/|list
+ ;; lux;Nil
+ Unit
+ ;; lux;Cons
+ (Tuple$ (&/|list (Bound$ "a")
+ (App$ (Bound$ "lux;List")
+ (Bound$ "a"))))
+ )))))
(def Maybe
- (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;Maybe" "a"
- (&/V &/$VariantT (&/|list (&/T &/$None Unit)
- (&/T &/$Some (&/V &/$BoundT "a")))))))
+ (&/V &/$AllT (&/T empty-env "lux;Maybe" "a"
+ (Variant$ (&/|list
+ ;; lux;None
+ Unit
+ ;; lux;Some
+ (Bound$ "a")
+ )))))
(def Type
- (let [Type (&/V &/$AppT (&/T (&/V &/$BoundT "Type") (&/V &/$BoundT "_")))
- TypeEnv (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list Text Type))))
- TypePair (&/V &/$TupleT (&/|list Type Type))]
- (&/V &/$AppT (&/T (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "Type" "_"
- (&/V &/$VariantT (&/|list (&/T &/$DataT Text)
- (&/T &/$TupleT (&/V &/$AppT (&/T List Type)))
- (&/T &/$VariantT TypeEnv)
- (&/T &/$RecordT TypeEnv)
- (&/T &/$LambdaT TypePair)
- (&/T &/$BoundT Text)
- (&/T &/$VarT Int)
- (&/T &/$AllT (&/V &/$TupleT (&/|list (&/V &/$AppT (&/T Maybe TypeEnv)) Text Text Type)))
- (&/T &/$AppT TypePair)
- (&/T &/$ExT Int)
- ))))
- $Void))))
+ (let [Type (App$ (Bound$ "Type") (Bound$ "_"))
+ TypeList (App$ List Type)
+ TypeEnv (App$ List (Tuple$ (&/|list Text Type)))
+ TypePair (Tuple$ (&/|list Type Type))]
+ (App$ (&/V &/$AllT (&/T empty-env "Type" "_"
+ (Variant$ (&/|list
+ ;; DataT
+ Text
+ ;; TupleT
+ (App$ List Type)
+ ;; VariantT
+ TypeList
+ ;; RecordT
+ TypeList
+ ;; LambdaT
+ TypePair
+ ;; BoundT
+ Text
+ ;; VarT
+ Int
+ ;; ExT
+ Int
+ ;; AllT
+ (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type))
+ ;; AppT
+ TypePair
+ ))))
+ $Void)))
(defn fAll [name arg body]
(&/V &/$AllT (&/T (&/V &/$None nil) name arg body)))
@@ -63,130 +97,187 @@
(def Bindings
(fAll "lux;Bindings" "k"
(fAll "" "v"
- (&/V &/$RecordT (&/|list (&/T "lux;counter" Int)
- (&/T "lux;mappings" (&/V &/$AppT (&/T List
- (&/V &/$TupleT (&/|list (&/V &/$BoundT "k")
- (&/V &/$BoundT "v")))))))))))
+ (Record$ (&/|list
+ ;; "lux;counter"
+ Int
+ ;; "lux;mappings"
+ (App$ List
+ (Tuple$ (&/|list (Bound$ "k")
+ (Bound$ "v")))))))))
(def Env
- (let [bindings (&/V &/$AppT (&/T (&/V &/$AppT (&/T Bindings (&/V &/$BoundT "k")))
- (&/V &/$BoundT "v")))]
+ (let [bindings (App$ (App$ Bindings (Bound$ "k"))
+ (Bound$ "v"))]
(fAll "lux;Env" "k"
(fAll "" "v"
- (&/V &/$RecordT
- (&/|list (&/T "lux;name" Text)
- (&/T "lux;inner-closures" Int)
- (&/T "lux;locals" bindings)
- (&/T "lux;closure" bindings)
- ))))))
+ (Record$
+ (&/|list
+ ;; "lux;name"
+ Text
+ ;; "lux;inner-closures"
+ Int
+ ;; "lux;locals"
+ bindings
+ ;; "lux;closure"
+ bindings
+ ))))))
(def Cursor
- (&/V &/$TupleT (&/|list Text Int Int)))
+ (Tuple$ (&/|list Text Int Int)))
(def Meta
(fAll &/$Meta "m"
(fAll "" "v"
- (&/V &/$VariantT (&/|list (&/T &/$Meta (&/V &/$TupleT (&/|list (&/V &/$BoundT "m")
- (&/V &/$BoundT "v")))))))))
+ (Variant$ (&/|list
+ ;; &/$Meta
+ (Tuple$ (&/|list (Bound$ "m")
+ (Bound$ "v"))))))))
-(def Ident (&/V &/$TupleT (&/|list Text Text)))
+(def Ident (Tuple$ (&/|list Text Text)))
(def AST*
- (let [AST* (&/V &/$AppT (&/T (&/V &/$BoundT "w")
- (&/V &/$AppT (&/T (&/V &/$BoundT "lux;AST'")
- (&/V &/$BoundT "w")))))
- AST*List (&/V &/$AppT (&/T List AST*))]
+ (let [AST* (App$ (Bound$ "w")
+ (App$ (Bound$ "lux;AST'")
+ (Bound$ "w")))
+ AST*List (App$ List AST*)]
(fAll "lux;AST'" "w"
- (&/V &/$VariantT (&/|list (&/T &/$BoolS Bool)
- (&/T &/$IntS Int)
- (&/T &/$RealS Real)
- (&/T &/$CharS Char)
- (&/T &/$TextS Text)
- (&/T &/$SymbolS Ident)
- (&/T &/$TagS Ident)
- (&/T &/$FormS AST*List)
- (&/T &/$TupleS AST*List)
- (&/T &/$RecordS (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list AST* AST*))))))
- ))))
+ (Variant$ (&/|list
+ ;; &/$BoolS
+ Bool
+ ;; &/$IntS
+ Int
+ ;; &/$RealS
+ Real
+ ;; &/$CharS
+ Char
+ ;; &/$TextS
+ Text
+ ;; &/$SymbolS
+ Ident
+ ;; &/$TagS
+ Ident
+ ;; &/$FormS
+ AST*List
+ ;; &/$TupleS
+ AST*List
+ ;; &/$RecordS
+ (App$ List (Tuple$ (&/|list AST* AST*))))
+ ))))
(def AST
- (let [w (&/V &/$AppT (&/T Meta Cursor))]
- (&/V &/$AppT (&/T w (&/V &/$AppT (&/T AST* w))))))
+ (let [w (App$ Meta Cursor)]
+ (App$ w (App$ AST* w))))
-(def ^:private ASTList (&/V &/$AppT (&/T List AST)))
+(def ^:private ASTList (App$ List AST))
(def Either
(fAll "lux;Either" "l"
(fAll "" "r"
- (&/V &/$VariantT (&/|list (&/T &/$Left (&/V &/$BoundT "l"))
- (&/T &/$Right (&/V &/$BoundT "r")))))))
+ (Variant$ (&/|list (&/T &/$Left (Bound$ "l"))
+ (&/T &/$Right (Bound$ "r")))))))
(def StateE
(fAll "lux;StateE" "s"
(fAll "" "a"
- (&/V &/$LambdaT (&/T (&/V &/$BoundT "s")
- (&/V &/$AppT (&/T (&/V &/$AppT (&/T Either Text))
- (&/V &/$TupleT (&/|list (&/V &/$BoundT "s")
- (&/V &/$BoundT "a"))))))))))
+ (Lambda$ (Bound$ "s")
+ (App$ (App$ Either Text)
+ (Tuple$ (&/|list (Bound$ "s")
+ (Bound$ "a"))))))))
(def Reader
- (&/V &/$AppT (&/T List
- (&/V &/$AppT (&/T (&/V &/$AppT (&/T Meta Cursor))
- Text)))))
+ (App$ List
+ (App$ (App$ Meta Cursor)
+ Text)))
(def HostState
- (&/V &/$RecordT
- (&/|list (&/T "lux;writer" (&/V &/$DataT "org.objectweb.asm.ClassWriter"))
- (&/T "lux;loader" (&/V &/$DataT "java.lang.ClassLoader"))
- (&/T "lux;classes" (&/V &/$DataT "clojure.lang.Atom")))))
+ (Record$
+ (&/|list
+ ;; "lux;writer"
+ (&/V &/$DataT "org.objectweb.asm.ClassWriter")
+ ;; "lux;loader"
+ (&/V &/$DataT "java.lang.ClassLoader")
+ ;; "lux;classes"
+ (&/V &/$DataT "clojure.lang.Atom"))))
(def DefData*
(fAll "lux;DefData'" ""
- (&/V &/$VariantT (&/|list (&/T "lux;TypeD" Type)
- (&/T "lux;ValueD" (&/V &/$TupleT (&/|list Type Unit)))
- (&/T "lux;MacroD" (&/V &/$BoundT ""))
- (&/T "lux;AliasD" Ident)))))
+ (Variant$ (&/|list
+ ;; "lux;TypeD"
+ Type
+ ;; "lux;ValueD"
+ (Tuple$ (&/|list Type Unit))
+ ;; "lux;MacroD"
+ (Bound$ "")
+ ;; "lux;AliasD"
+ Ident
+ ))))
(def LuxVar
- (&/V &/$VariantT (&/|list (&/T "lux;Local" Int)
- (&/T "lux;Global" Ident))))
+ (Variant$ (&/|list
+ ;; "lux;Local"
+ Int
+ ;; "lux;Global"
+ Ident)))
(def $Module
(fAll "lux;$Module" "Compiler"
- (&/V &/$RecordT
- (&/|list (&/T "lux;module-aliases" (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list Text Text)))))
- (&/T "lux;defs" (&/V &/$AppT (&/T List (&/V &/$TupleT
- (&/|list Text
- (&/V &/$TupleT (&/|list Bool
- (&/V &/$AppT (&/T DefData*
- (&/V &/$LambdaT (&/T ASTList
- (&/V &/$AppT (&/T (&/V &/$AppT (&/T StateE (&/V &/$BoundT "Compiler")))
- ASTList)))))))))))))
- (&/T "lux;imports" (&/V &/$AppT (&/T List Text)))))))
+ (Record$
+ (&/|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 (List Ident)))
+ (App$ List
+ (Tuple$ (&/|list Text
+ (Tuple$ (&/|list Int
+ (App$ List
+ Ident))))))
+ ))))
(def $Compiler
- (&/V &/$AppT (&/T (fAll "lux;Compiler" ""
- (&/V &/$RecordT
- (&/|list (&/T "lux;source" Reader)
- (&/T "lux;modules" (&/V &/$AppT (&/T List (&/V &/$TupleT
- (&/|list Text
- (&/V &/$AppT (&/T $Module (&/V &/$AppT (&/T (&/V &/$BoundT "lux;Compiler") (&/V &/$BoundT ""))))))))))
- (&/T "lux;envs" (&/V &/$AppT (&/T List
- (&/V &/$AppT (&/T (&/V &/$AppT (&/T Env Text))
- (&/V &/$TupleT (&/|list LuxVar Type)))))))
- (&/T "lux;types" (&/V &/$AppT (&/T (&/V &/$AppT (&/T Bindings Int)) Type)))
- (&/T "lux;host" HostState)
- (&/T "lux;seed" Int)
- (&/T "lux;eval?" Bool)
- (&/T "lux;expected" Type)
- (&/T "lux;cursor" Cursor)
- )))
- $Void)))
+ (App$ (fAll "lux;Compiler" ""
+ (Record$
+ (&/|list
+ ;; "lux;source"
+ Reader
+ ;; "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;host"
+ HostState
+ ;; "lux;seed"
+ Int
+ ;; "lux;eval?"
+ Bool
+ ;; "lux;expected"
+ Type
+ ;; "lux;cursor"
+ Cursor
+ )))
+ $Void))
(def Macro
- (&/V &/$LambdaT (&/T ASTList
- (&/V &/$AppT (&/T (&/V &/$AppT (&/T StateE $Compiler))
- ASTList)))))
+ (Lambda$ ASTList
+ (App$ (App$ StateE $Compiler)
+ ASTList)))
(defn bound? [id]
(fn [state]
@@ -297,30 +388,24 @@
(&/$LambdaT ?arg ?return)
(|do [=arg (clean* ?tid ?arg)
=return (clean* ?tid ?return)]
- (return (&/V &/$LambdaT (&/T =arg =return))))
+ (return (Lambda$ =arg =return)))
(&/$AppT ?lambda ?param)
(|do [=lambda (clean* ?tid ?lambda)
=param (clean* ?tid ?param)]
- (return (&/V &/$AppT (&/T =lambda =param))))
+ (return (App$ =lambda =param)))
(&/$TupleT ?members)
(|do [=members (&/map% (partial clean* ?tid) ?members)]
- (return (&/V &/$TupleT =members)))
+ (return (Tuple$ =members)))
(&/$VariantT ?members)
- (|do [=members (&/map% (fn [[k v]]
- (|do [=v (clean* ?tid v)]
- (return (&/T k =v))))
- ?members)]
- (return (&/V &/$VariantT =members)))
+ (|do [=members (&/map% (partial clean* ?tid) ?members)]
+ (return (Variant$ =members)))
(&/$RecordT ?members)
- (|do [=members (&/map% (fn [[k v]]
- (|do [=v (clean* ?tid v)]
- (return (&/T k =v))))
- ?members)]
- (return (&/V &/$RecordT =members)))
+ (|do [=members (&/map% (partial clean* ?tid) ?members)]
+ (return (Record$ =members)))
(&/$AllT ?env ?name ?arg ?body)
(|do [=env (|case ?env
@@ -380,23 +465,14 @@
(if (&/|empty? cases)
"(|)"
(str "(| " (->> cases
- (&/|map (fn [kv]
- (|case kv
- [k (&/$TupleT (&/$Nil))]
- (str "#" k)
-
- [k v]
- (str "(#" k " " (show-type v) ")"))))
+ (&/|map show-type)
(&/|interpose " ")
(&/fold str "")) ")"))
(&/$RecordT fields)
(str "(& " (->> fields
- (&/|map (fn [kv]
- (|case kv
- [k v]
- (str "#" k " " (show-type v)))))
+ (&/|map show-type)
(&/|interpose " ")
(&/fold str "")) ")")
@@ -429,7 +505,9 @@
[args body*]))]
(str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")"))
?name)
- ))
+
+ _
+ (assert false (prn-str 'show-type (aget type 0)))))
(defn type= [x y]
(or (clojure.lang.Util/identical x y)
@@ -438,24 +516,17 @@
(.equals ^Object xname yname)
[(&/$TupleT xelems) (&/$TupleT yelems)]
- (&/fold2 (fn [old x y]
- (and old (type= x y)))
+ (&/fold2 (fn [old x y] (and old (type= x y)))
true
xelems yelems)
[(&/$VariantT xcases) (&/$VariantT ycases)]
- (&/fold2 (fn [old xcase ycase]
- (|let [[xname xtype] xcase
- [yname ytype] ycase]
- (and old (.equals ^Object xname yname) (type= xtype ytype))))
+ (&/fold2 (fn [old x y] (and old (type= x y)))
true
xcases ycases)
[(&/$RecordT xslots) (&/$RecordT yslots)]
- (&/fold2 (fn [old xslot yslot]
- (|let [[xname xtype] xslot
- [yname ytype] yslot]
- (and old (.equals ^Object xname yname) (type= xtype ytype))))
+ (&/fold2 (fn [old x y] (and old (type= x y)))
true
xslots yslots)
@@ -522,23 +593,17 @@
(defn beta-reduce [env type]
(|case type
- (&/$VariantT ?cases)
- (&/V &/$VariantT (&/|map (fn [kv]
- (|let [[k v] kv]
- (&/T k (beta-reduce env v))))
- ?cases))
+ (&/$VariantT ?members)
+ (Variant$ (&/|map (partial beta-reduce env) ?members))
- (&/$RecordT ?fields)
- (&/V &/$RecordT (&/|map (fn [kv]
- (|let [[k v] kv]
- (&/T k (beta-reduce env v))))
- ?fields))
+ (&/$RecordT ?members)
+ (Record$ (&/|map (partial beta-reduce env) ?members))
(&/$TupleT ?members)
- (&/V &/$TupleT (&/|map (partial beta-reduce env) ?members))
+ (Tuple$ (&/|map (partial beta-reduce env) ?members))
(&/$AppT ?type-fn ?type-arg)
- (&/V &/$AppT (&/T (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)))
+ (App$ (beta-reduce env ?type-fn) (beta-reduce env ?type-arg))
(&/$AllT ?local-env ?local-name ?local-arg ?local-def)
(|case ?local-env
@@ -549,7 +614,7 @@
type)
(&/$LambdaT ?input ?output)
- (&/V &/$LambdaT (&/T (beta-reduce env ?input) (beta-reduce env ?output)))
+ (Lambda$ (beta-reduce env ?input) (beta-reduce env ?output))
(&/$BoundT ?name)
(if-let [bound (&/|get ?name env)]
@@ -660,13 +725,13 @@
(|case ((|do [F1 (deref ?eid)]
(fn [state]
(|case [((|do [F2 (deref ?aid)]
- (check* class-loader fixpoints (&/V &/$AppT (&/T F1 A1)) (&/V &/$AppT (&/T F2 A2))))
+ (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2)))
state)]
(&/$Right state* output)
(return* state* output)
(&/$Left _)
- ((check* class-loader fixpoints (&/V &/$AppT (&/T F1 A1)) actual)
+ ((check* class-loader fixpoints (App$ F1 A1) actual)
state))))
state)
(&/$Right state* output)
@@ -674,7 +739,7 @@
(&/$Left _)
(|case ((|do [F2 (deref ?aid)]
- (check* class-loader fixpoints expected (&/V &/$AppT (&/T F2 A2))))
+ (check* class-loader fixpoints expected (App$ F2 A2)))
state)
(&/$Right state* output)
(return* state* output)
@@ -691,7 +756,7 @@
[(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)]
(fn [state]
(|case ((|do [F1 (deref ?id)]
- (check* class-loader fixpoints (&/V &/$AppT (&/T F1 A1)) actual))
+ (check* class-loader fixpoints (App$ F1 A1) actual))
state)
(&/$Right state* output)
(return* state* output)
@@ -713,7 +778,7 @@
[(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)]
(fn [state]
(|case ((|do [F2 (deref ?id)]
- (check* class-loader fixpoints expected (&/V &/$AppT (&/T F2 A2))))
+ (check* class-loader fixpoints expected (App$ F2 A2)))
state)
(&/$Right state* output)
(return* state* output)
@@ -795,25 +860,17 @@
(return (&/T fixpoints* nil)))
[(&/$VariantT e!cases) (&/$VariantT a!cases)]
- (|do [fixpoints* (&/fold2% (fn [fp e!case a!case]
- (|let [[e!name e!type] e!case
- [a!name a!type] a!case]
- (if (.equals ^Object e!name a!name)
- (|do [[fp* _] (check* class-loader fp e!type a!type)]
- (return fp*))
- (fail (check-error expected actual)))))
+ (|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)))
[(&/$RecordT e!slots) (&/$RecordT a!slots)]
- (|do [fixpoints* (&/fold2% (fn [fp e!slot a!slot]
- (|let [[e!name e!type] e!slot
- [a!name a!type] a!slot]
- (if (.equals ^Object e!name a!name)
- (|do [[fp* _] (check* class-loader fp e!type a!type)]
- (return fp*))
- (fail (check-error expected actual)))))
+ (|do [fixpoints* (&/fold2% (fn [fp e a]
+ (|do [[fp* _] (check* class-loader fp e a)]
+ (return fp*)))
fixpoints
e!slots a!slots)]
(return (&/T fixpoints* nil)))