From e86b31726a19b0706f3618467775ba8ce6030393 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 24 May 2015 18:55:08 -0400 Subject: - Cleaned-up a few things in lux.lux - Replace most instances of "=" with ".equals". - Added an optimization to lux.type/type= that drastically speeds-up type comparisons. --- source/lux.lux | 210 ++++++++-------- src/lux/analyser.clj | 2 +- src/lux/analyser/base.clj | 2 +- src/lux/analyser/case.clj | 10 +- src/lux/analyser/lux.clj | 8 +- src/lux/analyser/module.clj | 2 +- src/lux/base.clj | 14 +- src/lux/compiler.clj | 2 +- src/lux/host.clj | 12 +- src/lux/lexer.clj | 19 +- src/lux/type.clj | 591 ++++++++++++++++++++++---------------------- 11 files changed, 432 insertions(+), 440 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 9b5601eb4..ac47e81eb 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -360,7 +360,7 @@ (fail "Wrong syntax for let'"))))) (_lux_declare-macro let') -(_lux_def lambda_ +(_lux_def lambda' (_lux_: Macro (_lux_lambda _ tokens (_lux_case tokens @@ -374,7 +374,7 @@ body _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) (#Cons [(_meta (#TupleS args')) (#Cons [body #Nil])])])))) #Nil])])])]))) @@ -390,7 +390,7 @@ body _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) (#Cons [(_meta (#TupleS args')) (#Cons [body #Nil])])])))) #Nil])])])]))) @@ -398,11 +398,11 @@ _ (fail "Wrong syntax for lambda"))))) -(_lux_declare-macro lambda_) +(_lux_declare-macro lambda') -(_lux_def def_ +(_lux_def def' (_lux_: Macro - (lambda_ [tokens] + (lambda' [tokens] (_lux_case tokens (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) @@ -412,7 +412,7 @@ (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) (#Cons [name (#Cons [(_meta (#TupleS args)) (#Cons [body #Nil])])])]))) @@ -440,7 +440,7 @@ (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) (#Cons [name (#Cons [(_meta (#TupleS args)) (#Cons [body #Nil])])])]))) @@ -462,14 +462,14 @@ _ (fail "Wrong syntax for def") )))) -(_lux_declare-macro def_) +(_lux_declare-macro def') -(def_ #export (defmacro tokens) +(def' #export (defmacro tokens) Macro (_lux_case tokens (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) (return (_lux_: SyntaxList - (#Cons [($form (#Cons [($symbol ["lux" "def_"]) + (#Cons [($form (#Cons [($symbol ["lux" "def'"]) (#Cons [($form (#Cons [name args])) (#Cons [($symbol ["lux" "Macro"]) (#Cons [body @@ -480,7 +480,7 @@ (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) (return (_lux_: SyntaxList - (#Cons [($form (#Cons [($symbol ["lux" "def_"]) + (#Cons [($form (#Cons [($symbol ["lux" "def'"]) (#Cons [($tag ["" "export"]) (#Cons [($form (#Cons [name args])) (#Cons [($symbol ["lux" "Macro"]) @@ -575,7 +575,7 @@ _ (fail "Wrong syntax for $'"))) -(def_ #export (fold f init xs) +(def' #export (fold f init xs) (All' [a b] (->' (->' (B' a) (B' b) (B' a)) (B' a) @@ -588,19 +588,19 @@ (#Cons [x xs']) (fold f (f init x) xs'))) -(def_ #export (reverse list) +(def' #export (reverse list) (All' [a] (->' ($' List (B' a)) ($' List (B' a)))) (fold (_lux_: (All' [a] (->' ($' List (B' a)) (B' a) ($' List (B' a)))) - (lambda_ [tail head] + (lambda' [tail head] (#Cons [head tail]))) #Nil list)) (defmacro #export (list xs) (return (_lux_: SyntaxList - (#Cons [(fold (lambda_ [tail head] + (#Cons [(fold (lambda' [tail head] (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) #Nil])])))) @@ -612,7 +612,7 @@ (_lux_case (reverse xs) (#Cons [last init]) (return (_lux_: SyntaxList - (list (fold (lambda_ [tail head] + (list (fold (lambda' [tail head] (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) (_meta (#TupleS (list head tail))))))) last @@ -640,7 +640,7 @@ (list ($form (list ($symbol ["" "_lux_lambda"]) ($symbol name) harg - (fold (lambda_ [body' arg] + (fold (lambda' [body' arg] ($form (list ($symbol ["" "_lux_lambda"]) ($symbol ["" ""]) arg @@ -651,7 +651,7 @@ _ (fail "Wrong syntax for lambda")))) -(defmacro (def__ tokens) +(defmacro (def'' tokens) (_lux_case tokens (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) @@ -698,7 +698,7 @@ (fail "Wrong syntax for def") )) -(def__ (as-pairs xs) +(def'' (as-pairs xs) (All' [a] (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) (_lux_case xs @@ -728,7 +728,7 @@ _ (fail "Wrong syntax for let"))) -(def__ #export (map f xs) +(def'' #export (map f xs) (All' [a b] (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) (_lux_case xs @@ -738,7 +738,7 @@ (#Cons [x xs']) (#Cons [(f x) (map f xs')]))) -(def__ #export (any? p xs) +(def'' #export (any? p xs) (All' [a] (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) (_lux_case xs @@ -750,7 +750,7 @@ true true false (any? p xs')))) -(def__ (spliced? token) +(def'' (spliced? token) (->' Syntax Bool) (_lux_case token (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) @@ -759,13 +759,13 @@ _ false)) -(def__ (wrap-meta content) +(def'' (wrap-meta content) (->' Syntax Syntax) (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"])) (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) content))))))) -(def__ (untemplate-list tokens) +(def'' (untemplate-list tokens) (->' ($' List Syntax) Syntax) (_lux_case tokens #Nil @@ -775,7 +775,7 @@ (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) (_meta (#TupleS (list token (untemplate-list tokens'))))))))) -(def__ (list:++ xs ys) +(def'' (list:++ xs ys) (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) (_lux_case xs (#Cons [x xs']) @@ -795,7 +795,7 @@ _ (fail "Wrong syntax for $"))) -(def__ (splice untemplate tag elems) +(def'' (splice untemplate tag elems) (->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) (_lux_case (any? spliced? elems) true @@ -818,7 +818,7 @@ false (wrap-meta ($form (list tag (untemplate-list (map untemplate elems))))))) -(def__ (untemplate subst token) +(def'' (untemplate subst token) (->' Text Syntax Syntax) (_lux_case token (#Meta [_ (#BoolS value)]) @@ -912,7 +912,7 @@ ## (deftype (Lux a) ## (-> Compiler (Either Text (, Compiler a)))) -(def__ #export Lux +(def'' #export Lux Type (All' [a] (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a))))))) @@ -922,7 +922,7 @@ ## return) ## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) ## bind)) -(def__ Monad +(def'' Monad Type (All' [m] (#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))] @@ -930,7 +930,7 @@ ($' (B' m) (B' a)) ($' (B' m) (B' b))))])))) -(def__ Maybe:Monad +(def'' Maybe:Monad ($' Monad Maybe) {#lux;return (lambda return [x] @@ -942,7 +942,7 @@ #None #None (#Some a) (f a)))}) -(def__ Lux:Monad +(def'' Lux:Monad ($' Monad Lux) {#lux;return (lambda [x] @@ -1009,7 +1009,7 @@ _ (fail "Wrong syntax for do"))) -(def__ (map% m f xs) +(def'' (map% m f xs) ## (All [m a b] ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) (All' [m a b] @@ -1029,13 +1029,13 @@ (;return (_lux_: List (#Cons [y ys])))) ))) -(def__ #export (. f g) +(def'' #export (. f g) (All' [a b c] (-> (-> (B' b) (B' c)) (-> (B' a) (B' b)) (-> (B' a) (B' c)))) (lambda [x] (f (g x)))) -(def__ (get-ident x) +(def'' (get-ident x) (-> Syntax ($' Maybe Text)) (_lux_case x (#Meta [_ (#SymbolS ["" sname])]) @@ -1044,7 +1044,7 @@ _ #None)) -(def__ (tuple->list tuple) +(def'' (tuple->list tuple) (-> Syntax ($' Maybe ($' List Syntax))) (_lux_case tuple (#Meta [_ (#TupleS members)]) @@ -1053,11 +1053,11 @@ _ #None)) -(def__ RepEnv +(def'' RepEnv Type ($' List (, Text Syntax))) -(def__ (make-env xs ys) +(def'' (make-env xs ys) (-> ($' List Text) ($' List Syntax) RepEnv) (_lux_case (_lux_: (, ($' List Text) ($' List Syntax)) [xs ys]) @@ -1067,12 +1067,12 @@ _ #Nil)) -(def__ (text:= x y) +(def'' (text:= x y) (-> Text Text Bool) (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] x [y])) -(def__ (get-rep key env) +(def'' (get-rep key env) (-> Text RepEnv ($' Maybe Syntax)) (_lux_case env #Nil @@ -1083,7 +1083,7 @@ (#Some v) (get-rep key env')))) -(def__ (apply-template env template) +(def'' (apply-template env template) (-> RepEnv Syntax Syntax) (_lux_case template (#Meta [_ (#SymbolS ["" sname])]) @@ -1110,7 +1110,7 @@ _ template)) -(def__ (join-map f xs) +(def'' (join-map f xs) (All' [a b] (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b)))) (_lux_case xs @@ -1140,7 +1140,7 @@ (fail "Wrong syntax for do-template"))) (do-template [ ] - [(def__ #export ( x y) + [(def'' #export ( x y) (-> Bool) ( x y))] @@ -1153,7 +1153,7 @@ ) (do-template [ ] - [(def__ #export ( x y) + [(def'' #export ( x y) (-> ) ( x y))] @@ -1169,29 +1169,29 @@ [real:% _jvm_drem Real] ) -(def__ (multiple? div n) +(def'' (multiple? div n) (-> Int Int Bool) (int:= 0 (int:% n div))) -(def__ #export (length list) +(def'' #export (length list) (-> List Int) (fold (lambda [acc _] (int:+ 1 acc)) 0 list)) -(def__ #export (not x) +(def'' #export (not x) (-> Bool Bool) (if x false true)) -(def__ #export (text:++ x y) +(def'' #export (text:++ x y) (-> Text Text Text) (_jvm_invokevirtual java.lang.String concat [java.lang.String] x [y])) -(def__ (ident->text ident) +(def'' (ident->text ident) (-> Ident Text) (let [[module name] ident] ($ text:++ module ";" name))) -(def__ (replace-syntax reps syntax) +(def'' (replace-syntax reps syntax) (-> RepEnv Syntax Syntax) (_lux_case syntax (#Meta [_ (#SymbolS ["" name])]) @@ -1255,7 +1255,7 @@ (fail "Wrong syntax for All")) )) -(def__ (get k plist) +(def'' (get k plist) (All [a] (-> Text ($' List (, Text a)) ($' Maybe a))) (_lux_case plist @@ -1267,7 +1267,7 @@ #Nil #None)) -(def__ #export (get-module-name state) +(def'' #export (get-module-name state) ($' Lux Text) (_lux_case state {#source source #modules modules #module-aliases module-aliases @@ -1280,7 +1280,7 @@ (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) (#Right [state module-name])))) -(def__ (find-macro' modules current-module module name) +(def'' (find-macro' modules current-module module name) (-> ($' List (, Text ($' List (, Text (, Bool ($' DefData' (-> ($' List Syntax) ($' StateE Compiler ($' List Syntax))))))))) Text Text Text ($' Maybe Macro)) @@ -1301,7 +1301,7 @@ _ #None))) -(def__ #export (find-macro ident) +(def'' #export (find-macro ident) (-> Ident ($' Lux ($' Maybe Macro))) (do Lux:Monad [current-module get-module-name] @@ -1313,12 +1313,12 @@ #seed seed} (#Right [state (find-macro' modules current-module module name)])))))) -(def__ (list:join xs) +(def'' (list:join xs) (All [a] (-> ($' List ($' List a)) ($' List a))) (fold list:++ #Nil xs)) -## (def__ #export (normalize ident) +## (def'' #export (normalize ident) ## (-> Ident ($' Lux Ident)) ## (_lux_case ident ## ["" name] @@ -1328,7 +1328,7 @@ ## _ ## (return ident))) -(def__ #export (normalize ident state) +(def'' #export (normalize ident state) (-> Ident ($' Lux Ident)) (_lux_case ident ["" name] @@ -1387,11 +1387,11 @@ (;return (_lux_: SyntaxList (list (`' (#;RecordT (;list (~@ pairs)))))))))) -(def__ #export (->text x) +(def'' #export (->text x) (-> (^ java.lang.Object) Text) (_jvm_invokevirtual java.lang.Object toString [] x [])) -(def__ #export (interpose sep xs) +(def'' #export (interpose sep xs) (All [a] (-> a ($' List a) ($' List a))) (_lux_case xs @@ -1404,7 +1404,7 @@ (#Cons [x xs']) (list& x sep (interpose sep xs')))) -(def__ #export (syntax:show syntax) +(def'' #export (syntax:show syntax) (-> Syntax Text) (_lux_case syntax (#Meta [_ (#BoolS value)]) @@ -1446,7 +1446,7 @@ "}") )) -(def__ #export (macro-expand syntax) +(def'' #export (macro-expand syntax) (-> Syntax ($' Lux ($' List Syntax))) (_lux_case syntax (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) @@ -1479,7 +1479,7 @@ _ (return (_lux_: SyntaxList (list syntax))))) -(def__ (walk-type type) +(def'' (walk-type type) (-> Syntax Syntax) (_lux_case type (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) @@ -1525,8 +1525,8 @@ (defmacro #export (:! tokens) (_lux_case tokens (#Cons [type (#Cons [value #Nil])]) - (return (_lux_: SyntaxList - (list (`' (_lux_:! (;type` (~ type)) (~ value)))))) + (return (: (List Syntax) + (list (`' (_lux_:! (;type` (~ type)) (~ value)))))) _ (fail "Wrong syntax for :!"))) @@ -1562,9 +1562,9 @@ _ (`' (;All (~ name) [(~@ args)] (~ type)))))] - (return (_lux_: SyntaxList - (list& (`' (_lux_def (~ name) (;type` (~ type')))) - with-export)))) + (return (: (List Syntax) + (list& (`' (_lux_def (~ name) (;type` (~ type')))) + with-export)))) #None (fail "Wrong syntax for deftype")) @@ -1636,11 +1636,11 @@ #None body'))] - (return (_lux_: SyntaxList - (list& (`' (_lux_def (~ name) (~ body''))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil))))) + (return (: (List Syntax) + (list& (`' (_lux_def (~ name) (~ body''))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil))))) #None (fail "Wrong syntax for def")))) @@ -1702,10 +1702,10 @@ _ (do Lux:Monad [patterns' (map% Lux:Monad macro-expand patterns)] - (;return (_lux_: SyntaxList - (list:join (map (: (-> Syntax (List Syntax)) - (lambda [pattern] (list pattern body))) - (list:join patterns'))))))) + (;return (: (List Syntax) + (list:join (map (: (-> Syntax (List Syntax)) + (lambda [pattern] (list pattern body))) + (list:join patterns'))))))) _ (fail "Wrong syntax for \\or"))) @@ -1804,11 +1804,11 @@ _ (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] - (return (_lux_: SyntaxList - (list& (`' (_lux_def (~ name) (~ sigs'))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil))))) + (return (: (List Syntax) + (list& (`' (_lux_def (~ name) (~ sigs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil))))) #None (fail "Wrong syntax for defsig")))) @@ -1828,8 +1828,8 @@ _ (fail "Structures require defined members!")))) tokens')] - (;return (_lux_: SyntaxList - (list ($record members)))))) + (;return (: (List Syntax) + (list ($record members)))))) (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) @@ -1858,11 +1858,11 @@ _ (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] - (return (_lux_: SyntaxList - (list& (`' (def (~ name) (~ type) (~ defs'))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil))))) + (return (: (List Syntax) + (list& (`' (def (~ name) (~ type) (~ defs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil))))) #None (fail "Wrong syntax for defsig")))) @@ -1957,11 +1957,11 @@ (list name) (list))))) lux)] - (#Right [state (_lux_: SyntaxList - (map (: (-> Text Syntax) - (lambda [name] - (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name])))))) - (list:join to-alias)))])) + (#Right [state (: (List Syntax) + (map (: (-> Text Syntax) + (lambda [name] + (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name])))))) + (list:join to-alias)))])) #None (#Left "Uh, oh... The universe is not working properly...")) @@ -2065,33 +2065,23 @@ [($tag [module name]) ($symbol ["" name])]))) slots)) _ (println (text:++ "Using pattern: " (syntax:show pattern)))] - (#Right [state (_lux_: SyntaxList - (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))])) + (#Right [state (: (List Syntax) + (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))])) _ (#Left "Can only \"use\" records.")))))) _ (let [dummy ($symbol ["" ""])] - (#Right [state (_lux_: SyntaxList - (list (` (_lux_case (~ struct) - (~ dummy) - (using (~ dummy) (~ body))))))]))) + (#Right [state (: (List Syntax) + (list (` (_lux_case (~ struct) + (~ dummy) + (using (~ dummy) + (~ body))))))]))) _ (#Left "Wrong syntax for defsig"))) -(defmacro #export (when tokens) - (case tokens - (\ (list test body)) - (return (_lux_: SyntaxList - (list (` (if (~ test) - (#Some (~ body)) - #None))))) - - _ - (fail "Wrong syntax for when"))) - (def #export (flip f) (All [a b c] (-> (-> a b c) (-> b a c))) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 3c5c5c956..ba0fe4e66 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -514,7 +514,7 @@ (defn ^:private analyse-ast [eval! exo-type token] (matchv ::M/objects [token] [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]] - (do (assert (= 1 (&/|length ?values)) "[Analyser Error] Can only tag 1 value.") + (do (assert (.equals ^Object (&/|length ?values) 1) "[Analyser Error] Can only tag 1 value.") (&&lux/analyse-variant (partial analyse-ast eval!) exo-type ?ident (&/|head ?values))) [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index a4c96c350..11e92f7b7 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -21,7 +21,7 @@ (defn resolved-ident [ident] (|let [[?module ?name] ident] - (|do [module* (if (= "" ?module) + (|do [module* (if (.equals "" ?module) &/get-module-name (return ?module))] (return (&/ident->text (&/T module* ?name)))))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index f27a541ee..43e5ee5e7 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -56,7 +56,7 @@ [["lux;TupleS" ?members]] (matchv ::M/objects [value-type] [["lux;TupleT" ?member-types]] - (if (not (= (&/|length ?member-types) (&/|length ?members))) + (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) (fail (str "[Analyser error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) (|do [[=tests =kont] (&/fold (fn [kont* vm] (|let [[v m] vm] @@ -74,7 +74,7 @@ (|do [value-type* (resolve-type value-type)] (matchv ::M/objects [value-type*] [["lux;RecordT" ?slot-types]] - (if (not (= (&/|length ?slot-types) (&/|length ?slots))) + (if (not (.equals ^Object (&/|length ?slot-types) (&/|length ?slots))) (fail (str "[Analyser error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]")) (|do [[=tests =kont] (&/fold (fn [kont* slot] (|let [[sn sv] slot] @@ -168,7 +168,7 @@ (return (&/V "TupleTotal" (&/T total? structs)))) [["TupleTotal" [total? ?values]] ["TupleTestAC" ?tests]] - (if (= (&/|length ?values) (&/|length ?tests)) + (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) (|do [structs (&/map2% (fn [v t] (merge-total v (&/T t ?body))) ?values ?tests)] @@ -187,11 +187,11 @@ (return (&/V "RecordTotal" (&/T total? structs)))) [["RecordTotal" [total? ?values]] ["RecordTestAC" ?tests]] - (if (= (&/|length ?values) (&/|length ?tests)) + (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) (|do [structs (&/map2% (fn [left right] (|let [[lslot sub-struct] left [rslot value]right] - (if (= lslot rslot) + (if (.equals ^Object lslot rslot) (|do [sub-struct* (merge-total sub-struct (&/T value ?body))] (return (&/T lslot sub-struct*))) (fail "[Pattern-matching error] Record slots mismatch.")))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 7600f34ff..dff936fbe 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -110,7 +110,7 @@ [inner outer] (&/|split-with no-binding? stack)] (matchv ::M/objects [outer] [["lux;Nil" _]] - ((|do [[[r-module r-name] $def] (&&module/find-def (if (= "" ?module) module-name ?module) + ((|do [[[r-module r-name] $def] (&&module/find-def (if (.equals "" ?module) module-name ?module) ?name) endo-type (matchv ::M/objects [$def] [["lux;ValueD" ?type]] @@ -121,7 +121,8 @@ [["lux;TypeD" _]] (return &type/Type)) - _ (if (and (= &type/Type endo-type) (= &type/Type exo-type)) + _ (if (and (clojure.lang.Util/identical &type/Type endo-type) + (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) @@ -142,7 +143,8 @@ [["lux;TypeD" _]] (return &type/Type)) - _ (if (and (= &type/Type endo-type) (= &type/Type exo-type)) + _ (if (and (clojure.lang.Util/identical &type/Type endo-type) + (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index f36dc044a..f882f1275 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -68,7 +68,7 @@ (if-let [$def (&/|get name $module)] (matchv ::M/objects [$def] [[exported? $$def]] - (if (or exported? (= current-module module)) + (if (or exported? (.equals ^Object current-module module)) (matchv ::M/objects [$$def] [["lux;AliasD" [?r-module ?r-name]]] ((find-def ?r-module ?r-name) diff --git a/src/lux/base.clj b/src/lux/base.clj index edf6781ea..7f551cdb0 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -85,7 +85,7 @@ nil [["lux;Cons" [[k v] table*]]] - (if (= k slot) + (if (.equals ^Object k slot) v (|get slot table*)))) @@ -95,7 +95,7 @@ (V "lux;Cons" (T (T slot value) (V "lux;Nil" nil))) [["lux;Cons" [[k v] table*]]] - (if (= k slot) + (if (.equals ^Object k slot) (V "lux;Cons" (T (T slot value) table*)) (V "lux;Cons" (T (T k v) (|put slot value table*)))))) @@ -105,7 +105,7 @@ table [["lux;Cons" [[k v] table*]]] - (if (= k slot) + (if (.equals ^Object k slot) table* (V "lux;Cons" (T (T k v) (|remove slot table*)))))) @@ -115,7 +115,7 @@ table [["lux;Cons" [[k* v] table*]]] - (if (= k k*) + (if (.equals ^Object k k*) (V "lux;Cons" (T (T k* (f v)) table*)) (V "lux;Cons" (T (T k* v) (|update k f table*)))))) @@ -233,7 +233,7 @@ false [["lux;Cons" [[k* _] table*]]] - (or (= k k*) + (or (.equals ^Object k k*) (|contains? k table*)))) (defn fold [f init xs] @@ -384,7 +384,7 @@ ((exhaust% step) state*) [["lux;Left" msg]] - (if (= "[Reader Error] EOF" msg) + (if (.equals "[Reader Error] EOF" msg) (return* state nil) (fail* msg))))) @@ -570,7 +570,7 @@ (str "#" ?module ";" ?tag) [["lux;Meta" [_ ["lux;SymbolS" [?module ?ident]]]]] - (if (= "" ?module) + (if (.equals "" ?module) ?ident (str ?module ";" ?ident)) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 6fb9e2c6d..e491fbdfe 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -346,7 +346,7 @@ (defn ^:private compile-module [name] (fn [state] (if (->> state (&/get$ &/$MODULES) (&/|contains? name)) - (if (= name "lux") + (if (.equals ^Object name "lux") (return* state nil) (fail* "[Compiler Error] Can't redefine a module!")) (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) diff --git a/src/lux/host.clj b/src/lux/host.clj index 77687dbef..8817ea338 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -18,7 +18,7 @@ (str (.getName pkg) ".") "") (.getSimpleName class)))] - (if (= "void" base) + (if (.equals "void" base) (return &type/$Void) (return (&/V "lux;DataT" (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) base))) @@ -78,8 +78,8 @@ (do-template [ ] (defn [target field] (if-let [type* (first (for [^Field =field (.getDeclaredFields (Class/forName target)) - :when (and (= field (.getName =field)) - (= (Modifier/isStatic (.getModifiers =field))))] + :when (and (.equals ^Object field (.getName =field)) + (.equals ^Object (Modifier/isStatic (.getModifiers =field))))] (.getType =field)))] (|do [=type (class->type type*)] (return =type)) @@ -92,9 +92,9 @@ (do-template [ ] (defn [target method-name args] (if-let [method (first (for [^Method =method (.getDeclaredMethods (Class/forName target)) - :when (and (= method-name (.getName =method)) - (= (Modifier/isStatic (.getModifiers =method))) - (&/fold2 #(and %1 (= %2 %3)) + :when (and (.equals ^Object method-name (.getName =method)) + (.equals ^Object (Modifier/isStatic (.getModifiers =method))) + (&/fold2 #(and %1 (.equals ^Object %2 %3)) true args (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))))] diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index d2ab4a5d7..a137ca863 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -6,16 +6,15 @@ ;; [Utils] (defn ^:private escape-char [escaped] - (condp = escaped - "\\t" (return "\t") - "\\b" (return "\b") - "\\n" (return "\n") - "\\r" (return "\r") - "\\f" (return "\f") - "\\\"" (return "\"") - "\\\\" (return "\\") - ;; else - (fail (str "[Lexer Error] Unknown escape character: " escaped)))) + (cond (.equals ^Object escaped "\\t") (return "\t") + (.equals ^Object escaped "\\b") (return "\b") + (.equals ^Object escaped "\\n") (return "\n") + (.equals ^Object escaped "\\r") (return "\r") + (.equals ^Object escaped "\\f") (return "\f") + (.equals ^Object escaped "\\\"") (return "\"") + (.equals ^Object escaped "\\\\") (return "\\") + :else + (fail (str "[Lexer Error] Unknown escape character: " escaped)))) (defn ^:private lex-text-body [_] (&/try-all% (&/|list (|do [[_ [prefix escaped]] (&reader/read-regex2 #"(?s)^([^\"\\]*)(\\.)") diff --git a/src/lux/type.clj b/src/lux/type.clj index a2cf83624..25e3e1053 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -228,7 +228,7 @@ (fn [state] ((|do [mappings* (&/map% (fn [binding] (|let [[?id ?type] binding] - (if (= id ?id) + (if (.equals ^Object id ?id) (return binding) (matchv ::M/objects [?type] [["lux;None" _]] @@ -237,7 +237,7 @@ [["lux;Some" ?type*]] (matchv ::M/objects [?type*] [["lux;VarT" ?id*]] - (if (= id ?id*) + (if (.equals ^Object id ?id*) (return (&/T ?id (&/V "lux;None" nil))) (return binding)) @@ -269,7 +269,7 @@ (defn ^:private clean* [?tid type] (matchv ::M/objects [type] [["lux;VarT" ?id]] - (if (= ?tid ?id) + (if (.equals ^Object ?tid ?id) (deref ?id) (return type)) @@ -390,53 +390,52 @@ )) (defn type= [x y] - (let [output (matchv ::M/objects [x y] - [["lux;DataT" xname] ["lux;DataT" yname]] - (= xname yname) - - [["lux;TupleT" xelems] ["lux;TupleT" yelems]] - (&/fold2 (fn [old x y] - (and old (type= x y))) - true - xelems yelems) - - [["lux;VariantT" xcases] ["lux;VariantT" ycases]] - (&/fold2 (fn [old xcase ycase] - (|let [[xname xtype] xcase - [yname ytype] ycase] - (and old (= xname yname) (type= xtype ytype)))) - true - xcases ycases) - - [["lux;RecordT" xslots] ["lux;RecordT" yslots]] - (&/fold2 (fn [old xslot yslot] - (|let [[xname xtype] xslot - [yname ytype] yslot] - (and old (= xname yname) (type= xtype ytype)))) - true - xslots yslots) - - [["lux;LambdaT" [xinput xoutput]] ["lux;LambdaT" [yinput youtput]]] - (and (type= xinput yinput) - (type= xoutput youtput)) - - [["lux;VarT" xid] ["lux;VarT" yid]] - (= xid yid) - - [["lux;BoundT" xname] ["lux;BoundT" yname]] - (= xname yname) - - [["lux;ExT" xid] ["lux;ExT" yid]] - (= xid yid) - - [["lux;AppT" [xlambda xparam]] ["lux;AppT" [ylambda yparam]]] - (and (type= xlambda ylambda) (type= xparam yparam)) - - [["lux;AllT" [xenv xname xarg xbody]] ["lux;AllT" [yenv yname yarg ybody]]] - (or (and (not= "" xname) - (= xname yname)) - (and (= xname yname) - (= xarg yarg) + (or (clojure.lang.Util/identical x y) + (let [output (matchv ::M/objects [x y] + [["lux;DataT" xname] ["lux;DataT" yname]] + (.equals ^Object xname yname) + + [["lux;TupleT" xelems] ["lux;TupleT" yelems]] + (&/fold2 (fn [old x y] + (and old (type= x y))) + true + xelems yelems) + + [["lux;VariantT" xcases] ["lux;VariantT" ycases]] + (&/fold2 (fn [old xcase ycase] + (|let [[xname xtype] xcase + [yname ytype] ycase] + (and old (.equals ^Object xname yname) (type= xtype ytype)))) + true + xcases ycases) + + [["lux;RecordT" xslots] ["lux;RecordT" yslots]] + (&/fold2 (fn [old xslot yslot] + (|let [[xname xtype] xslot + [yname ytype] yslot] + (and old (.equals ^Object xname yname) (type= xtype ytype)))) + true + xslots yslots) + + [["lux;LambdaT" [xinput xoutput]] ["lux;LambdaT" [yinput youtput]]] + (and (type= xinput yinput) + (type= xoutput youtput)) + + [["lux;VarT" xid] ["lux;VarT" yid]] + (.equals ^Object xid yid) + + [["lux;BoundT" xname] ["lux;BoundT" yname]] + (.equals ^Object xname yname) + + [["lux;ExT" xid] ["lux;ExT" yid]] + (.equals ^Object xid yid) + + [["lux;AppT" [xlambda xparam]] ["lux;AppT" [ylambda yparam]]] + (and (type= xlambda ylambda) (type= xparam yparam)) + + [["lux;AllT" [xenv xname xarg xbody]] ["lux;AllT" [yenv yname yarg ybody]]] + (and (.equals ^Object xname yname) + (.equals ^Object xarg yarg) ;; (matchv ::M/objects [xenv yenv] ;; [["lux;None" _] ["lux;None" _]] ;; true @@ -451,12 +450,12 @@ ;; [_ _] ;; false) (type= xbody ybody) - )) + ) - [_ _] - false - )] - output)) + [_ _] + false + )] + output))) (defn ^:private fp-get [k fixpoints] (|let [[e a] k] @@ -553,272 +552,274 @@ (defn ^:private check* [fixpoints expected actual] ;; (swap! counter update-in [[(aget expected 0) (aget actual 0)]] ;; #(inc (or % 0))) - (matchv ::M/objects [expected actual] - [["lux;VarT" ?eid] ["lux;VarT" ?aid]] - (if (= ?eid ?aid) - (return (&/T fixpoints nil)) - (|do [ebound (fn [state] - (matchv ::M/objects [((deref ?eid) state)] - [["lux;Right" [state* ebound]]] - (return* state* (&/V "lux;Some" ebound)) - - [["lux;Left" _]] - (return* state (&/V "lux;None" nil)))) - abound (fn [state] - (matchv ::M/objects [((deref ?aid) state)] - [["lux;Right" [state* abound]]] - (return* state* (&/V "lux;Some" abound)) - - [["lux;Left" _]] - (return* state (&/V "lux;None" nil))))] - (matchv ::M/objects [ebound abound] - [["lux;None" _] ["lux;None" _]] - (|do [_ (set-var ?eid actual)] - (return (&/T fixpoints nil))) - - [["lux;Some" etype] ["lux;None" _]] - (check* fixpoints etype actual) - - [["lux;None" _] ["lux;Some" atype]] - (check* fixpoints expected atype) - - [["lux;Some" etype] ["lux;Some" atype]] - (check* fixpoints etype atype)))) - - [["lux;VarT" ?id] _] - (fn [state] - (matchv ::M/objects [((set-var ?id actual) state)] - [["lux;Right" [state* _]]] - (return* state* (&/T fixpoints nil)) - - [["lux;Left" _]] - ((|do [bound (deref ?id)] - (check* fixpoints bound actual)) - state))) - - [_ ["lux;VarT" ?id]] - (fn [state] - (matchv ::M/objects [((set-var ?id expected) state)] - [["lux;Right" [state* _]]] - (return* state* (&/T fixpoints nil)) + (if (clojure.lang.Util/identical expected actual) + (return (&/T fixpoints nil)) + (matchv ::M/objects [expected actual] + [["lux;VarT" ?eid] ["lux;VarT" ?aid]] + (if (.equals ^Object ?eid ?aid) + (return (&/T fixpoints nil)) + (|do [ebound (fn [state] + (matchv ::M/objects [((deref ?eid) state)] + [["lux;Right" [state* ebound]]] + (return* state* (&/V "lux;Some" ebound)) + + [["lux;Left" _]] + (return* state (&/V "lux;None" nil)))) + abound (fn [state] + (matchv ::M/objects [((deref ?aid) state)] + [["lux;Right" [state* abound]]] + (return* state* (&/V "lux;Some" abound)) + + [["lux;Left" _]] + (return* state (&/V "lux;None" nil))))] + (matchv ::M/objects [ebound abound] + [["lux;None" _] ["lux;None" _]] + (|do [_ (set-var ?eid actual)] + (return (&/T fixpoints nil))) + + [["lux;Some" etype] ["lux;None" _]] + (check* fixpoints etype actual) + + [["lux;None" _] ["lux;Some" atype]] + (check* fixpoints expected atype) + + [["lux;Some" etype] ["lux;Some" atype]] + (check* fixpoints etype atype)))) + + [["lux;VarT" ?id] _] + (fn [state] + (matchv ::M/objects [((set-var ?id actual) state)] + [["lux;Right" [state* _]]] + (return* state* (&/T fixpoints nil)) - [["lux;Left" _]] - ((|do [bound (deref ?id)] - (check* fixpoints expected bound)) - state))) + [["lux;Left" _]] + ((|do [bound (deref ?id)] + (check* fixpoints bound actual)) + state))) + + [_ ["lux;VarT" ?id]] + (fn [state] + (matchv ::M/objects [((set-var ?id expected) state)] + [["lux;Right" [state* _]]] + (return* state* (&/T fixpoints nil)) - [["lux;AppT" [["lux;VarT" ?eid] A1]] ["lux;AppT" [["lux;VarT" ?aid] A2]]] - (fn [state] - (matchv ::M/objects [((|do [F1 (deref ?eid)] - (fn [state] - (matchv ::M/objects [((|do [F2 (deref ?aid)] - (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) - state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" _]] - ((check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) - state)))) - state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" _]] - (matchv ::M/objects [((|do [F2 (deref ?aid)] - (check* fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + [["lux;Left" _]] + ((|do [bound (deref ?id)] + (check* fixpoints expected bound)) + state))) + + [["lux;AppT" [["lux;VarT" ?eid] A1]] ["lux;AppT" [["lux;VarT" ?aid] A2]]] + (fn [state] + (matchv ::M/objects [((|do [F1 (deref ?eid)] + (fn [state] + (matchv ::M/objects [((|do [F2 (deref ?aid)] + (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) + state)] + [["lux;Right" [state* output]]] + (return* state* output) + + [["lux;Left" _]] + ((check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) + state)))) state)] [["lux;Right" [state* output]]] (return* state* output) [["lux;Left" _]] - ((|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) - [fixpoints** _] (check* fixpoints* A1 A2)] - (return (&/T fixpoints** nil))) - state)))) - ;; (|do [_ (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) - ;; _ (check* fixpoints A1 A2)] - ;; (return (&/T fixpoints nil))) - - [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] - (fn [state] - (matchv ::M/objects [((|do [F1 (deref ?id)] - (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) - state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" _]] - ((|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) - e* (apply-type F2 A1) - a* (apply-type F2 A2) - [fixpoints** _] (check* fixpoints* e* a*)] - (return (&/T fixpoints** nil))) - state))) - ;; [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] - ;; (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) - ;; e* (apply-type F2 A1) - ;; a* (apply-type F2 A2) - ;; [fixpoints** _] (check* fixpoints* e* a*)] - ;; (return (&/T fixpoints** nil))) - - [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] - (fn [state] - (matchv ::M/objects [((|do [F2 (deref ?id)] - (check* fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) - state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" _]] - ((|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) - e* (apply-type F1 A1) - a* (apply-type F1 A2) - [fixpoints** _] (check* fixpoints* e* a*)] - (return (&/T fixpoints** nil))) - state))) - ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] - ;; (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) - ;; e* (apply-type F1 A1) - ;; a* (apply-type F1 A2) - ;; [fixpoints** _] (check* fixpoints* e* a*)] - ;; (return (&/T fixpoints** nil))) - - [["lux;AppT" [F A]] _] - (let [fp-pair (&/T expected actual) - _ (when (> (&/|length fixpoints) 40) - (println 'FIXPOINTS (->> (&/|keys fixpoints) - (&/|map (fn [pair] - (|let [[e a] pair] - (str (show-type e) ":+:" - (show-type a))))) - (&/|interpose "\n\n") - (&/fold str ""))) - (assert false))] - (matchv ::M/objects [(fp-get fp-pair fixpoints)] - [["lux;Some" ?]] - (if ? - (return (&/T fixpoints nil)) - (fail (check-error expected actual))) - - [["lux;None" _]] - (|do [expected* (apply-type F A)] - (check* (fp-put fp-pair true fixpoints) expected* actual)))) - - [_ ["lux;AppT" [F A]]] - (|do [actual* (apply-type F A)] - (check* fixpoints expected actual*)) - - [["lux;AllT" _] _] - (with-var - (fn [$arg] - (|do [expected* (apply-type expected $arg)] - (check* fixpoints expected* actual)))) - - [_ ["lux;AllT" _]] - (with-var - (fn [$arg] - (|do [actual* (apply-type actual $arg)] - (check* fixpoints expected actual*)))) - - [["lux;DataT" "boolean"] ["lux;DataT" "java.lang.Boolean"]] - (return (&/T fixpoints nil)) + (matchv ::M/objects [((|do [F2 (deref ?aid)] + (check* fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + state)] + [["lux;Right" [state* output]]] + (return* state* output) + + [["lux;Left" _]] + ((|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) + [fixpoints** _] (check* fixpoints* A1 A2)] + (return (&/T fixpoints** nil))) + state)))) + ;; (|do [_ (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) + ;; _ (check* fixpoints A1 A2)] + ;; (return (&/T fixpoints nil))) + + [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] + (fn [state] + (matchv ::M/objects [((|do [F1 (deref ?id)] + (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) + state)] + [["lux;Right" [state* output]]] + (return* state* output) - [["lux;DataT" "byte"] ["lux;DataT" "java.lang.Byte"]] - (return (&/T fixpoints nil)) + [["lux;Left" _]] + ((|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) + e* (apply-type F2 A1) + a* (apply-type F2 A2) + [fixpoints** _] (check* fixpoints* e* a*)] + (return (&/T fixpoints** nil))) + state))) + ;; [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] + ;; (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) + ;; e* (apply-type F2 A1) + ;; a* (apply-type F2 A2) + ;; [fixpoints** _] (check* fixpoints* e* a*)] + ;; (return (&/T fixpoints** nil))) + + [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] + (fn [state] + (matchv ::M/objects [((|do [F2 (deref ?id)] + (check* fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + state)] + [["lux;Right" [state* output]]] + (return* state* output) - [["lux;DataT" "short"] ["lux;DataT" "java.lang.Short"]] - (return (&/T fixpoints nil)) + [["lux;Left" _]] + ((|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) + e* (apply-type F1 A1) + a* (apply-type F1 A2) + [fixpoints** _] (check* fixpoints* e* a*)] + (return (&/T fixpoints** nil))) + state))) + ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] + ;; (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) + ;; e* (apply-type F1 A1) + ;; a* (apply-type F1 A2) + ;; [fixpoints** _] (check* fixpoints* e* a*)] + ;; (return (&/T fixpoints** nil))) + + [["lux;AppT" [F A]] _] + (let [fp-pair (&/T expected actual) + _ (when (> (&/|length fixpoints) 40) + (println 'FIXPOINTS (->> (&/|keys fixpoints) + (&/|map (fn [pair] + (|let [[e a] pair] + (str (show-type e) ":+:" + (show-type a))))) + (&/|interpose "\n\n") + (&/fold str ""))) + (assert false))] + (matchv ::M/objects [(fp-get fp-pair fixpoints)] + [["lux;Some" ?]] + (if ? + (return (&/T fixpoints nil)) + (fail (check-error expected actual))) + + [["lux;None" _]] + (|do [expected* (apply-type F A)] + (check* (fp-put fp-pair true fixpoints) expected* actual)))) + + [_ ["lux;AppT" [F A]]] + (|do [actual* (apply-type F A)] + (check* fixpoints expected actual*)) + + [["lux;AllT" _] _] + (with-var + (fn [$arg] + (|do [expected* (apply-type expected $arg)] + (check* fixpoints expected* actual)))) + + [_ ["lux;AllT" _]] + (with-var + (fn [$arg] + (|do [actual* (apply-type actual $arg)] + (check* fixpoints expected actual*)))) + + [["lux;DataT" "boolean"] ["lux;DataT" "java.lang.Boolean"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "int"] ["lux;DataT" "java.lang.Integer"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "byte"] ["lux;DataT" "java.lang.Byte"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "long"] ["lux;DataT" "java.lang.Long"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "short"] ["lux;DataT" "java.lang.Short"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "float"] ["lux;DataT" "java.lang.Float"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "int"] ["lux;DataT" "java.lang.Integer"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "double"] ["lux;DataT" "java.lang.Double"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "long"] ["lux;DataT" "java.lang.Long"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "char"] ["lux;DataT" "java.lang.Character"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "float"] ["lux;DataT" "java.lang.Float"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "java.lang.Boolean"] ["lux;DataT" "boolean"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "double"] ["lux;DataT" "java.lang.Double"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "java.lang.Byte"] ["lux;DataT" "byte"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "char"] ["lux;DataT" "java.lang.Character"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "java.lang.Short"] ["lux;DataT" "short"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "java.lang.Boolean"] ["lux;DataT" "boolean"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "java.lang.Integer"] ["lux;DataT" "int"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "java.lang.Byte"] ["lux;DataT" "byte"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "java.lang.Long"] ["lux;DataT" "long"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "java.lang.Short"] ["lux;DataT" "short"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "java.lang.Float"] ["lux;DataT" "float"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "java.lang.Integer"] ["lux;DataT" "int"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "java.lang.Double"] ["lux;DataT" "double"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "java.lang.Long"] ["lux;DataT" "long"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "java.lang.Character"] ["lux;DataT" "char"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "java.lang.Float"] ["lux;DataT" "float"]] + (return (&/T fixpoints nil)) - [["lux;DataT" e!name] ["lux;DataT" a!name]] - (if (or (= e!name a!name) - (.isAssignableFrom (Class/forName e!name) (Class/forName a!name))) + [["lux;DataT" "java.lang.Double"] ["lux;DataT" "double"]] (return (&/T fixpoints nil)) - (fail (str "[Type Error] Names don't match: " e!name " & " a!name))) - - [["lux;LambdaT" [eI eO]] ["lux;LambdaT" [aI aO]]] - (|do [[fixpoints* _] (check* fixpoints aI eI)] - (check* fixpoints* eO aO)) - - [["lux;TupleT" e!members] ["lux;TupleT" a!members]] - (|do [fixpoints* (&/fold2% (fn [fp e a] - (|do [[fp* _] (check* fp e a)] - (return fp*))) - fixpoints - e!members a!members)] - (return (&/T fixpoints* nil))) - - [["lux;VariantT" e!cases] ["lux;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 (= e!name a!name) - (|do [[fp* _] (check* fp e!type a!type)] - (return fp*)) - (fail (check-error expected actual))))) - fixpoints - e!cases a!cases)] - (return (&/T fixpoints* nil))) - - [["lux;RecordT" e!slots] ["lux;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 (= e!name a!name) - (|do [[fp* _] (check* fp e!type a!type)] - (return fp*)) - (fail (check-error expected actual))))) - fixpoints - e!slots a!slots)] - (return (&/T fixpoints* nil))) - - [["lux;ExT" e!id] ["lux;ExT" a!id]] - (if (= e!id a!id) + + [["lux;DataT" "java.lang.Character"] ["lux;DataT" "char"]] (return (&/T fixpoints nil)) - (check-error expected actual)) - [_ _] - (fail (println-str "[Type Error] Can't type-check: " (show-type expected) (show-type actual))) - )) + [["lux;DataT" e!name] ["lux;DataT" a!name]] + (if (or (.equals ^Object e!name a!name) + (.isAssignableFrom (Class/forName e!name) (Class/forName a!name))) + (return (&/T fixpoints nil)) + (fail (str "[Type Error] Names don't match: " e!name " & " a!name))) + + [["lux;LambdaT" [eI eO]] ["lux;LambdaT" [aI aO]]] + (|do [[fixpoints* _] (check* fixpoints aI eI)] + (check* fixpoints* eO aO)) + + [["lux;TupleT" e!members] ["lux;TupleT" a!members]] + (|do [fixpoints* (&/fold2% (fn [fp e a] + (|do [[fp* _] (check* fp e a)] + (return fp*))) + fixpoints + e!members a!members)] + (return (&/T fixpoints* nil))) + + [["lux;VariantT" e!cases] ["lux;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* fp e!type a!type)] + (return fp*)) + (fail (check-error expected actual))))) + fixpoints + e!cases a!cases)] + (return (&/T fixpoints* nil))) + + [["lux;RecordT" e!slots] ["lux;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* fp e!type a!type)] + (return fp*)) + (fail (check-error expected actual))))) + fixpoints + e!slots a!slots)] + (return (&/T fixpoints* nil))) + + [["lux;ExT" e!id] ["lux;ExT" a!id]] + (if (.equals ^Object e!id a!id) + (return (&/T fixpoints nil)) + (check-error expected actual)) + + [_ _] + (fail (println-str "[Type Error] Can't type-check: " (show-type expected) (show-type actual))) + ))) (defn check [expected actual] (|do [_ (check* init-fixpoints expected actual)] -- cgit v1.2.3