aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2015-08-16 15:37:46 -0400
committerEduardo Julian2015-08-16 15:37:46 -0400
commitdf3e4ba2df6462812174e69ea5c334a7edbbd5c7 (patch)
tree70fb6de01255324f4fc57d789ac9face3ff8eb73
parent3d18954a2307b48c955f5bdd3790a92ffeb7284c (diff)
Introduced named types (#NamedT Ident Type).
-rw-r--r--source/lux.lux429
-rw-r--r--src/lux/analyser.clj2
-rw-r--r--src/lux/analyser/case.clj7
-rw-r--r--src/lux/analyser/lux.clj14
-rw-r--r--src/lux/base.clj25
-rw-r--r--src/lux/type.clj389
6 files changed, 474 insertions, 392 deletions
diff --git a/source/lux.lux b/source/lux.lux
index 4c4b02f8a..b6d71e893 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -10,59 +10,69 @@
(_jvm_interface "Function" []
("apply" ["java.lang.Object"] "java.lang.Object" ["public" "abstract"]))
-(_lux_declare-tags [#DataT #VariantT #TupleT #LambdaT #BoundT #VarT #ExT #AllT #AppT])
+(_lux_declare-tags [#DataT #VariantT #TupleT #LambdaT #BoundT #VarT #ExT #AllT #AppT #NamedT])
(_lux_declare-tags [#None #Some])
(_lux_declare-tags [#Nil #Cons])
## Basic types
-(_lux_def Bool (#DataT "java.lang.Boolean"))
+(_lux_def Bool (#NamedT ["lux" "Bool"]
+ (#DataT "java.lang.Boolean")))
(_lux_export Bool)
-(_lux_def Int (#DataT "java.lang.Long"))
+(_lux_def Int (#NamedT ["lux" "Int"]
+ (#DataT "java.lang.Long")))
(_lux_export Int)
-(_lux_def Real (#DataT "java.lang.Double"))
+(_lux_def Real (#NamedT ["lux" "Real"]
+ (#DataT "java.lang.Double")))
(_lux_export Real)
-(_lux_def Char (#DataT "java.lang.Character"))
+(_lux_def Char (#NamedT ["lux" "Char"]
+ (#DataT "java.lang.Character")))
(_lux_export Char)
-(_lux_def Text (#DataT "java.lang.String"))
+(_lux_def Text (#NamedT ["lux" "Text"]
+ (#DataT "java.lang.String")))
(_lux_export Text)
-(_lux_def Unit (#TupleT #Nil))
+(_lux_def Unit (#NamedT ["lux" "Unit"]
+ (#TupleT #Nil)))
(_lux_export Unit)
-(_lux_def Void (#VariantT #Nil))
+(_lux_def Void (#NamedT ["lux" "Void"]
+ (#VariantT #Nil)))
(_lux_export Void)
-(_lux_def Ident (#TupleT (#Cons Text (#Cons Text #Nil))))
+(_lux_def Ident (#NamedT ["lux" "Ident"]
+ (#TupleT (#Cons Text (#Cons Text #Nil)))))
(_lux_export Ident)
## (deftype (List a)
## (| #Nil
## (#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)))))
+ (#NamedT ["lux" "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))))))
(_lux_export List)
## (deftype (Maybe a)
## (| #None
## (#Some a)))
(_lux_def Maybe
- (#AllT (#Some #Nil) "lux;Maybe" "a"
- (#VariantT (#Cons ## "lux;None"
- (#TupleT #Nil)
- (#Cons ## "lux;Some"
- (#BoundT "a")
- #Nil)))))
+ (#NamedT ["lux" "Maybe"]
+ (#AllT (#Some #Nil) "lux;Maybe" "a"
+ (#VariantT (#Cons ## "lux;None"
+ (#TupleT #Nil)
+ (#Cons ## "lux;Some"
+ (#BoundT "a")
+ #Nil))))))
(_lux_export Maybe)
## (deftype #rec Type
@@ -73,51 +83,57 @@
## (#BoundT Text)
## (#VarT Int)
## (#AllT (Maybe (List (, Text Type))) Text Text Type)
-## (#AppT Type Type)))
+## (#AppT Type Type)
+## (#NamedT Ident Type)
+## ))
(_lux_def Type
- (_lux_case (#AppT (#BoundT "Type") (#BoundT "_"))
- Type
- (_lux_case (#AppT List (#TupleT (#Cons Text (#Cons Type #Nil))))
- TypeEnv
- (_lux_case (#AppT List Type)
- TypeList
- (#AppT (#AllT (#Some #Nil) "Type" "_"
- (#VariantT (#Cons ## "lux;DataT"
- Text
- (#Cons ## "lux;VariantT"
- TypeList
- (#Cons ## "lux;TupleT"
- 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)))))
+ (#NamedT ["lux" "Type"]
+ (_lux_case (#AppT (#BoundT "Type") (#BoundT "_"))
+ Type
+ (_lux_case (#AppT List (#TupleT (#Cons Text (#Cons Type #Nil))))
+ TypeEnv
+ (_lux_case (#AppT List Type)
+ TypeList
+ (#AppT (#AllT (#Some #Nil) "Type" "_"
+ (#VariantT (#Cons ## "lux;DataT"
+ Text
+ (#Cons ## "lux;VariantT"
+ TypeList
+ (#Cons ## "lux;TupleT"
+ 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)))
+ (#Cons ## "lux;NamedT"
+ (#TupleT (#Cons Ident (#Cons Type #Nil)))
+ #Nil))))))))))))
+ Void))))))
(_lux_export Type)
## (deftype (Bindings k v)
## (& #counter Int
## #mappings (List (, k v))))
(_lux_def 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)))])]))
+ (#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)))])])))
(_lux_export Bindings)
(_lux_declare-tags [#counter #mappings])
@@ -127,38 +143,41 @@
## #locals (Bindings k v)
## #closure (Bindings k v)))
(_lux_def 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))))))))
+ (#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)))))))))
(_lux_export Env)
(_lux_declare-tags [#name #inner-closures #locals #closure])
## (deftype Cursor
## (, Text Int Int))
(_lux_def Cursor
- (#TupleT (#Cons Text (#Cons Int (#Cons Int #Nil)))))
+ (#NamedT ["lux" "Cursor"]
+ (#TupleT (#Cons Text (#Cons Int (#Cons Int #Nil))))))
(_lux_export Cursor)
## (deftype (Meta m v)
## (| (#Meta m v)))
(_lux_def Meta
- (#AllT (#Some #Nil) "lux;Meta" "m"
- (#AllT #None "" "v"
- (#VariantT (#Cons ## "lux;Meta"
- (#TupleT (#Cons (#BoundT "m")
- (#Cons (#BoundT "v")
- #Nil)))
- #Nil)))))
+ (#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))))))
(_lux_export Meta)
(_lux_declare-tags [#Meta])
@@ -174,45 +193,47 @@
## (#TupleS (List (w (AST' w))))
## (#RecordS (List (, (w (AST' w)) (w (AST' w)))))))
(_lux_def AST'
- (_lux_case (#AppT (#BoundT "w")
- (#AppT (#BoundT "lux;AST'")
- (#BoundT "w")))
- AST
- (_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)
- )))))))))
- )))))
+ (#NamedT ["lux" "AST'"]
+ (_lux_case (#AppT (#BoundT "w")
+ (#AppT (#BoundT "lux;AST'")
+ (#BoundT "w")))
+ AST
+ (_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)
+ )))))))))
+ ))))))
(_lux_export AST')
(_lux_declare-tags [#BoolS #IntS #RealS #CharS #TextS #SymbolS #TagS #FormS #TupleS #RecordS])
## (deftype AST
## (Meta Cursor (AST' (Meta Cursor))))
(_lux_def AST
- (_lux_case (#AppT Meta Cursor)
- w
- (#AppT w (#AppT AST' w))))
+ (#NamedT ["lux" "AST"]
+ (_lux_case (#AppT Meta Cursor)
+ w
+ (#AppT w (#AppT AST' w)))))
(_lux_export AST)
(_lux_def ASTList (#AppT List AST))
@@ -221,13 +242,14 @@
## (| (#Left l)
## (#Right r)))
(_lux_def Either
- (#AllT (#Some #Nil) "lux;Either" "l"
- (#AllT #None "" "r"
- (#VariantT (#Cons ## "lux;Left"
- (#BoundT "l")
- (#Cons ## "lux;Right"
- (#BoundT "r")
- #Nil))))))
+ (#NamedT ["lux" "Either"]
+ (#AllT (#Some #Nil) "lux;Either" "l"
+ (#AllT #None "" "r"
+ (#VariantT (#Cons ## "lux;Left"
+ (#BoundT "l")
+ (#Cons ## "lux;Right"
+ (#BoundT "r")
+ #Nil)))))))
(_lux_export Either)
(_lux_declare-tags [#Left #Right])
@@ -245,9 +267,10 @@
## (deftype Source
## (List (Meta Cursor Text)))
(_lux_def Source
- (#AppT [List
- (#AppT [(#AppT [Meta Cursor])
- Text])]))
+ (#NamedT ["lux" "Source"]
+ (#AppT [List
+ (#AppT [(#AppT [Meta Cursor])
+ Text])])))
(_lux_export Source)
## (deftype Host
@@ -255,13 +278,14 @@
## #loader (^ java.net.URLClassLoader)
## #classes (^ clojure.lang.Atom)))
(_lux_def 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])])])))
+ (#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])])]))))
(_lux_declare-tags [#writer #loader #classes])
## (deftype (DefData' m)
@@ -289,11 +313,12 @@
## (| (#Local Int)
## (#Global Ident)))
(_lux_def LuxVar
- (#VariantT (#Cons [## "lux;Local"
- Int
- (#Cons [## "lux;Global"
- Ident
- #Nil])])))
+ (#NamedT ["lux" "LuxVar"]
+ (#VariantT (#Cons [## "lux;Local"
+ Int
+ (#Cons [## "lux;Global"
+ Ident
+ #Nil])]))))
(_lux_export LuxVar)
(_lux_declare-tags [#Local #Global])
@@ -339,39 +364,41 @@
## #host Host
## ))
(_lux_def 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;types"
- (#AppT [(#AppT [Bindings Int]) Type])
- (#Cons [## "lux;expected"
- Type
- (#Cons [## "lux;seed"
- Int
- (#Cons [## "lux;eval?"
- Bool
- (#Cons [## "lux;host"
- Host
- #Nil])])])])])])])])]))])
- Void]))
+ (#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;types"
+ (#AppT [(#AppT [Bindings Int]) Type])
+ (#Cons [## "lux;expected"
+ Type
+ (#Cons [## "lux;seed"
+ Int
+ (#Cons [## "lux;eval?"
+ Bool
+ (#Cons [## "lux;host"
+ Host
+ #Nil])])])])])])])])]))])
+ Void])))
(_lux_export Compiler)
(_lux_declare-tags [#source #cursor #modules #envs #types #expected #seed #eval? #host])
## (deftype Macro
## (-> (List AST) (StateE Compiler (List AST))))
(_lux_def Macro
- (#LambdaT ASTList
- (#AppT (#AppT StateE Compiler)
- ASTList)))
+ (#NamedT ["lux" "Macro"]
+ (#LambdaT ASTList
+ (#AppT (#AppT StateE Compiler)
+ ASTList))))
(_lux_export Macro)
## Base functions & macros
@@ -477,35 +504,35 @@
(_lux_: Macro
(_lux_lambda _ tokens
(_lux_case tokens
- (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])
- (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"]))
- (#Cons [(_meta (#SymbolS ["" ""]))
- (#Cons [arg
- (#Cons [(_lux_case args'
- #Nil
- body
-
- _
- (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"]))
- (#Cons [(_meta (#TupleS args'))
- (#Cons [body #Nil])])]))))
- #Nil])])])])))
- #Nil]))
-
- (#Cons [(#Meta [_ (#SymbolS self)]) (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])])
- (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"]))
- (#Cons [(_meta (#SymbolS self))
- (#Cons [arg
- (#Cons [(_lux_case args'
- #Nil
- body
-
- _
- (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"]))
- (#Cons [(_meta (#TupleS args'))
- (#Cons [body #Nil])])]))))
- #Nil])])])])))
- #Nil]))
+ (#Cons (#Meta _ (#TupleS (#Cons arg args'))) (#Cons body #Nil))
+ (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda"))
+ (#Cons (_meta (#SymbolS "" ""))
+ (#Cons arg
+ (#Cons (_lux_case args'
+ #Nil
+ body
+
+ _
+ (_meta (#FormS (#Cons (_meta (#SymbolS "lux" "lambda''"))
+ (#Cons (_meta (#TupleS args'))
+ (#Cons body #Nil))))))
+ #Nil))))))
+ #Nil))
+
+ (#Cons (#Meta _ (#SymbolS self)) (#Cons (#Meta _ (#TupleS (#Cons arg args'))) (#Cons body #Nil)))
+ (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda"))
+ (#Cons (_meta (#SymbolS self))
+ (#Cons arg
+ (#Cons (_lux_case args'
+ #Nil
+ body
+
+ _
+ (_meta (#FormS (#Cons (_meta (#SymbolS "lux" "lambda''"))
+ (#Cons (_meta (#TupleS args'))
+ (#Cons body #Nil))))))
+ #Nil))))))
+ #Nil))
_
(fail "Wrong syntax for lambda")))))
@@ -2136,6 +2163,9 @@
(#AllT ?env ?name ?arg ?body)
($ text:++ "(All " ?name " [" ?arg "] " (type:show ?body) ")")
+
+ (#NamedT name type)
+ (ident->text name)
))
(def (beta-reduce env type)
@@ -2169,6 +2199,9 @@
_
type)
+ (#NamedT name type)
+ (beta-reduce env type)
+
_
type
))
@@ -2188,6 +2221,9 @@
(do Maybe/Monad
[type-fn* (apply-type F A)]
(apply-type type-fn* param))
+
+ (#NamedT name type)
+ (apply-type type param)
_
#None))
@@ -2204,6 +2240,8 @@
(#AllT _ _ _ body)
(resolve-struct-type body)
+ (#NamedT name type)
+ (resolve-struct-type type)
_
#None))
@@ -3046,7 +3084,10 @@
(` (#AllT (~ env') (~ (text$ name)) (~ (text$ arg)) (~ (type->syntax type)))))
(#AppT fun arg)
- (` (#AppT (~ (type->syntax fun)) (~ (type->syntax arg))))))
+ (` (#AppT (~ (type->syntax fun)) (~ (type->syntax arg))))
+
+ (#NamedT [module name] type)
+ (` (#NamedT [(~ (text$ module)) (~ (text$ name))] (~ (type->syntax type))))))
(defmacro #export (loop tokens)
(case tokens
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index 7810c415b..3b6a93005 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -532,7 +532,7 @@
(|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)))))
+ (assert false (prn-str 'analyse-basic-ast (&/show-ast token)))))
(&/$Right state* output)
(return* state* output)
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index 395ae6976..483002adc 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -113,6 +113,9 @@
(fail "##9##")))]
(adjust-type* up type*))
+ (&/$NamedT ?name ?type)
+ (adjust-type* up ?type)
+
_
(assert false (prn 'adjust-type* (&type/show-type type)))
))
@@ -202,7 +205,7 @@
(fail "[Pattern-matching Error] Record requires record-type.")))
(&/$TagS ?ident)
- (|do [;; :let [_ (println "#00")]
+ (|do [;; :let [_ (println "#00" (&/ident->text ?ident))]
[=module =name] (&&/resolved-ident ?ident)
;; :let [_ (println "#01")]
value-type* (adjust-type value-type)
@@ -219,7 +222,7 @@
(&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident))
?values))
- (|do [;; :let [_ (println "#10" ?ident)]
+ (|do [;; :let [_ (println "#10" (&/ident->text ?ident))]
[=module =name] (&&/resolved-ident ?ident)
;; :let [_ (println "#11")]
value-type* (adjust-type value-type)
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 79b804088..8a79e0494 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -401,6 +401,7 @@
;; (when (= "PList/Dict" ?name)
;; (prn 'DEF ?name (&/show-ast ?value)))
(|do [module-name &/get-module-name
+ ;; :let [_ (println 'DEF/PRE (str module-name ";" ?name))]
? (&&module/defined? module-name ?name)]
(if ?
(fail (str "[Analyser Error] Can't redefine " (str module-name ";" ?name)))
@@ -416,15 +417,20 @@
(return (&/|list)))
_
- (do (println 'DEF (str module-name ";" ?name))
+ (do ;; (println 'DEF (str module-name ";" ?name))
(|do [_ (compile-token (&/V &&/$def (&/T ?name =value)))
- :let [_ (println 'DEF/COMPILED (str module-name ";" ?name))]]
+ :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name))
+ _ (println 'DEF (str module-name ";" ?name))]]
(return (&/|list)))))
))))
(defn analyse-declare-macro [analyse compile-token ?name]
- (|do [module-name &/get-module-name
- _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))]
+ (|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)))
+ ;; :let [_ (prn 'analyse-declare-macro ?name "2")]
+ ]
(return (&/|list))))
(defn ensure-undeclared-tags [module tags]
diff --git a/src/lux/base.clj b/src/lux/base.clj
index e39f76409..44875d1df 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -58,7 +58,8 @@
"VarT"
"ExT"
"AllT"
- "AppT")
+ "AppT"
+ "NamedT")
;; [Fields]
;; Binding
@@ -229,7 +230,7 @@
(defn |head [xs]
(|case xs
($Nil)
- (assert false)
+ (assert false (prn-str '|head))
($Cons x _)
x))
@@ -237,7 +238,7 @@
(defn |tail [xs]
(|case xs
($Nil)
- (assert false)
+ (assert false (prn-str '|tail))
($Cons _ xs*)
xs*))
@@ -787,9 +788,8 @@
($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)))
+ _
+ (assert false (prn-str 'show-ast (adt->text ast)))
))
(defn ident->text [ident]
@@ -898,19 +898,6 @@
(and (= xmodule ymodule)
(= xname yname))))
-;; (defn |list-put [idx val xs]
-;; (|case [idx xs]
-;; [_ ($Nil)]
-;; (V $None nil)
-
-;; [0 ($Cons x xs*)]
-;; (V $Some (V $Cons (T val xs*)))
-
-;; [_ ($Cons x xs*)]
-;; (|case (|list-put idx val xs*)
-;; ($None) (V $None nil)
-;; ($Some xs**) (V $Some (V $Cons (T x xs**))))))
-
(defn |list-put [idx val xs]
(|case xs
($Nil)
diff --git a/src/lux/type.clj b/src/lux/type.clj
index 2516fbc1d..e78b5616a 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -26,14 +26,6 @@
_
false))
-(def Bool (&/V &/$DataT "java.lang.Boolean"))
-(def Int (&/V &/$DataT "java.lang.Long"))
-(def Real (&/V &/$DataT "java.lang.Double"))
-(def Char (&/V &/$DataT "java.lang.Character"))
-(def Text (&/V &/$DataT "java.lang.String"))
-(def Unit (&/V &/$TupleT (&/|list)))
-(def $Void (&/V &/$VariantT (&/|list)))
-
(def ^:private empty-env (&/V &/$Some (&/V &/$Nil nil)))
(def ^:private no-env (&/V &/$None nil))
(defn Data$ [name]
@@ -46,154 +38,174 @@
(&/V &/$LambdaT (&/T in out)))
(defn App$ [fun arg]
(&/V &/$AppT (&/T fun arg)))
-
(defn Tuple$ [members]
;; (assert (|list? members))
(&/V &/$TupleT members))
-
(defn Variant$ [members]
;; (assert (|list? members))
(&/V &/$VariantT members))
-
(defn All$ [env name arg body]
(&/V &/$AllT (&/T env name arg body)))
+(defn Named$ [name type]
+ (&/V &/$NamedT (&/T 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 IO
- (All$ empty-env "IO" "a"
- (Lambda$ Unit (Bound$ "a"))))
+ (Named$ (&/T "lux/data" "IO")
+ (All$ empty-env "IO" "a"
+ (Lambda$ Unit (Bound$ "a")))))
(def List
- (All$ empty-env "lux;List" "a"
- (Variant$ (&/|list
- ;; lux;Nil
- Unit
- ;; lux;Cons
- (Tuple$ (&/|list (Bound$ "a")
- (App$ (Bound$ "lux;List")
- (Bound$ "a"))))
- ))))
+ (Named$ (&/T "lux" "List")
+ (All$ empty-env "lux;List" "a"
+ (Variant$ (&/|list
+ ;; lux;Nil
+ Unit
+ ;; lux;Cons
+ (Tuple$ (&/|list (Bound$ "a")
+ (App$ (Bound$ "lux;List")
+ (Bound$ "a"))))
+ )))))
(def Maybe
- (All$ empty-env "lux;Maybe" "a"
- (Variant$ (&/|list
- ;; lux;None
- Unit
- ;; lux;Some
- (Bound$ "a")
- ))))
+ (Named$ (&/T "lux" "Maybe")
+ (All$ empty-env "lux;Maybe" "a"
+ (Variant$ (&/|list
+ ;; lux;None
+ Unit
+ ;; lux;Some
+ (Bound$ "a")
+ )))))
(def Type
- (let [Type (App$ (Bound$ "Type") (Bound$ "_"))
- TypeList (App$ List Type)
- TypeEnv (App$ List (Tuple$ (&/|list Text Type)))
- TypePair (Tuple$ (&/|list 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
- )))
- $Void)))
+ (Named$ (&/T "lux" "Type")
+ (let [Type (App$ (Bound$ "Type") (Bound$ "_"))
+ TypeList (App$ List Type)
+ TypeEnv (App$ List (Tuple$ (&/|list Text Type)))
+ TypePair (Tuple$ (&/|list 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))
+ )))
+ $Void))))
(def 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")))))))))
+ (Named$ (&/T "lux" "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"))))))))))
(def 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
- ))))))
+ (Named$ (&/T "lux" "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
+ )))))))
(def Cursor
- (Tuple$ (&/|list Text Int Int)))
+ (Named$ (&/T "lux" "Cursor")
+ (Tuple$ (&/|list Text Int Int))))
(def Meta
- (All$ empty-env "lux;Meta" "m"
- (All$ no-env "" "v"
- (Variant$ (&/|list
- ;; &/$Meta
- (Tuple$ (&/|list (Bound$ "m")
- (Bound$ "v"))))))))
-
-(def Ident (Tuple$ (&/|list Text Text)))
+ (Named$ (&/T "lux" "Meta")
+ (All$ empty-env "lux;Meta" "m"
+ (All$ no-env "" "v"
+ (Variant$ (&/|list
+ ;; &/$Meta
+ (Tuple$ (&/|list (Bound$ "m")
+ (Bound$ "v")))))))))
(def 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*))))
- ))))
+ (Named$ (&/T "lux" "AST'")
+ (let [AST* (App$ (Bound$ "w")
+ (App$ (Bound$ "lux;AST'")
+ (Bound$ "w")))
+ AST*List (App$ List AST*)]
+ (All$ empty-env "lux;AST'" "w"
+ (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 (App$ Meta Cursor)]
- (App$ w (App$ AST* w))))
+ (Named$ (&/T "lux" "AST")
+ (let [w (App$ Meta Cursor)]
+ (App$ w (App$ AST* w)))))
(def ^:private ASTList (App$ List AST))
(def Either
- (All$ empty-env "lux;Either" "l"
- (All$ no-env "" "r"
- (Variant$ (&/|list
- ;; &/$Left
- (Bound$ "l")
- ;; &/$Right
- (Bound$ "r"))))))
+ (Named$ (&/T "lux" "Either")
+ (All$ empty-env "lux;Either" "l"
+ (All$ no-env "" "r"
+ (Variant$ (&/|list
+ ;; &/$Left
+ (Bound$ "l")
+ ;; &/$Right
+ (Bound$ "r")))))))
(def StateE
(All$ empty-env "lux;StateE" "s"
@@ -204,19 +216,21 @@
(Bound$ "a"))))))))
(def Source
- (App$ List
- (App$ (App$ Meta Cursor)
- Text)))
+ (Named$ (&/T "lux" "Source")
+ (App$ List
+ (App$ (App$ Meta Cursor)
+ Text))))
(def Host
- (Tuple$
- (&/|list
- ;; "lux;writer"
- (Data$ "org.objectweb.asm.ClassWriter")
- ;; "lux;loader"
- (Data$ "java.lang.ClassLoader")
- ;; "lux;classes"
- (Data$ "clojure.lang.Atom"))))
+ (Named$ (&/T "lux" "Host")
+ (Tuple$
+ (&/|list
+ ;; "lux;writer"
+ (Data$ "org.objectweb.asm.ClassWriter")
+ ;; "lux;loader"
+ (Data$ "java.lang.ClassLoader")
+ ;; "lux;classes"
+ (Data$ "clojure.lang.Atom")))))
(def DefData*
(All$ empty-env "lux;DefData'" ""
@@ -232,11 +246,12 @@
))))
(def LuxVar
- (Variant$ (&/|list
- ;; "lux;Local"
- Int
- ;; "lux;Global"
- Ident)))
+ (Named$ (&/T "lux" "LuxVar")
+ (Variant$ (&/|list
+ ;; "lux;Local"
+ Int
+ ;; "lux;Global"
+ Ident))))
(def $Module
(All$ empty-env "lux;$Module" "Compiler"
@@ -264,37 +279,39 @@
))))
(def $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
- )))
- $Void))
+ (Named$ (&/T "lux" "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
+ )))
+ $Void)))
(def Macro
- (Lambda$ ASTList
- (App$ (App$ StateE $Compiler)
- ASTList)))
+ (Named$ (&/T "lux" "Macro")
+ (Lambda$ ASTList
+ (App$ (App$ StateE $Compiler)
+ ASTList))))
(defn bound? [id]
(fn [state]
@@ -512,8 +529,11 @@
(str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")"))
?name)
+ (&/$NamedT ?name ?type)
+ (&/ident->text ?name)
+
_
- (assert false (prn-str 'show-type (aget type 0)))))
+ (assert false (prn-str 'show-type (&/adt->text type)))))
(defn type= [x y]
(or (clojure.lang.Util/identical x y)
@@ -566,6 +586,12 @@
(type= xbody ybody)
)
+ [(&/$NamedT ?xname ?xtype) _]
+ (type= ?xtype y)
+
+ [_ (&/$NamedT ?yname ?ytype)]
+ (type= x ?ytype)
+
[_ _]
false
)]
@@ -640,9 +666,12 @@
(&/$AppT F A)
(|do [type-fn* (apply-type F A)]
(apply-type type-fn* param))
+
+ (&/$NamedT ?name ?type)
+ (apply-type ?type param)
_
- (fail (str "[Type System] Not type function:\n" (show-type type-fn) "\n"))))
+ (fail (str "[Type System] Not a type function:\n" (show-type type-fn) "\n"))))
(defn as-obj [class]
(case class
@@ -805,7 +834,7 @@
(show-type a)))))
(&/|interpose "\n\n")
(&/fold str "")))
- (assert false))]
+ (assert false (prn-str 'check* '[(&/$AppT F A) _] (&/|length fixpoints) (show-type expected) (show-type actual))))]
(|case (fp-get fp-pair fixpoints)
(&/$Some ?)
(if ?
@@ -870,6 +899,12 @@
(return (&/T fixpoints nil))
(fail (check-error expected actual)))
+ [(&/$NamedT ?ename ?etype) _]
+ (check* class-loader fixpoints ?etype actual)
+
+ [_ (&/$NamedT ?aname ?atype)]
+ (check* class-loader fixpoints expected ?atype)
+
[_ _]
(fail (check-error expected actual))
)))
@@ -892,11 +927,15 @@
=return (apply-lambda func* param)]
(clean $var =return))))
+ (&/$NamedT ?name ?type)
+ (apply-lambda ?type param)
+
_
(fail (str "[Type System] Not a function type:\n" (show-type func) "\n"))
))
(defn actual-type [type]
+ "(-> Type (Lux Type))"
(|case type
(&/$AppT ?all ?param)
(|do [type* (apply-type ?all ?param)]
@@ -904,6 +943,9 @@
(&/$VarT ?id)
(deref ?id)
+
+ (&/$NamedT ?name ?type)
+ (actual-type ?type)
_
(return type)
@@ -911,6 +953,9 @@
(defn variant-case [tag type]
(|case type
+ (&/$NamedT ?name ?type)
+ (variant-case tag ?type)
+
(&/$VariantT ?cases)
(|case (&/|at tag ?cases)
(&/$Some case-type)