aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorEduardo Julian2015-08-10 18:25:39 -0400
committerEduardo Julian2015-08-10 18:25:39 -0400
commit4134c811399abfce64b54a821e427d2b153f3e57 (patch)
treedc9bb9a1c4bf8981410d570c2390c4be788f5b72 /src
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 'src')
-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
9 files changed, 462 insertions, 236 deletions
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)))