diff options
Diffstat (limited to '')
| -rw-r--r-- | source/lux.lux | 429 | ||||
| -rw-r--r-- | src/lux/analyser.clj | 2 | ||||
| -rw-r--r-- | src/lux/analyser/case.clj | 7 | ||||
| -rw-r--r-- | src/lux/analyser/lux.clj | 14 | ||||
| -rw-r--r-- | src/lux/base.clj | 25 | ||||
| -rw-r--r-- | src/lux/type.clj | 389 |
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) |