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 [<name> <cmp> <type>]
- [(def__ #export (<name> x y)
+ [(def'' #export (<name> x y)
(-> <type> <type> Bool)
(<cmp> x y))]
@@ -1153,7 +1153,7 @@
)
(do-template [<name> <cmp> <type>]
- [(def__ #export (<name> x y)
+ [(def'' #export (<name> x y)
(-> <type> <type> <type>)
(<cmp> 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 [<name> <static?>]
(defn <name> [target field]
(if-let [type* (first (for [^Field =field (.getDeclaredFields (Class/forName target))
- :when (and (= field (.getName =field))
- (= <static?> (Modifier/isStatic (.getModifiers =field))))]
+ :when (and (.equals ^Object field (.getName =field))
+ (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =field))))]
(.getType =field)))]
(|do [=type (class->type type*)]
(return =type))
@@ -92,9 +92,9 @@
(do-template [<name> <static?>]
(defn <name> [target method-name args]
(if-let [method (first (for [^Method =method (.getDeclaredMethods (Class/forName target))
- :when (and (= method-name (.getName =method))
- (= <static?> (Modifier/isStatic (.getModifiers =method)))
- (&/fold2 #(and %1 (= %2 %3))
+ :when (and (.equals ^Object method-name (.getName =method))
+ (.equals ^Object <static?> (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