aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--stdlib/source/lux.lux10
-rw-r--r--stdlib/source/lux/compiler.lux2
-rw-r--r--stdlib/source/lux/control/effect.lux6
-rw-r--r--stdlib/source/lux/data/format/json.lux48
-rw-r--r--stdlib/source/lux/data/text/format.lux4
-rw-r--r--stdlib/source/lux/host.lux141
-rw-r--r--stdlib/source/lux/macro/ast.lux6
-rw-r--r--stdlib/source/lux/macro/poly.lux26
-rw-r--r--stdlib/source/lux/macro/poly/eq.lux4
-rw-r--r--stdlib/source/lux/macro/poly/functor.lux10
-rw-r--r--stdlib/source/lux/macro/poly/text-encoder.lux4
-rw-r--r--stdlib/source/lux/macro/syntax.lux10
-rw-r--r--stdlib/source/lux/type.lux46
-rw-r--r--stdlib/source/lux/type/check.lux8
14 files changed, 184 insertions, 141 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
index e2782012b..bff74ff0c 100644
--- a/stdlib/source/lux.lux
+++ b/stdlib/source/lux.lux
@@ -5463,13 +5463,11 @@
(macro: #export (@post tokens)
(case tokens
- (^ (list test pattern expr))
+ (^ (list test expr))
(do Monad<Lux>
- [g!output (gensym "")
- exp-type get-expected-type]
- (wrap (list (` (let [(~ g!output) (: (~ (type->ast exp-type)) (~ expr))
- (~ pattern) (~ g!output)]
- (if (~ test)
+ [g!output (gensym "")]
+ (wrap (list (` (let [(~ g!output) (~ expr)]
+ (if ((~ test) (~ g!output))
(~ g!output)
(error! (with-cursor (~ (text$ (Text/append "Post-condition failed: " (ast-to-text test))))))))))))
diff --git a/stdlib/source/lux/compiler.lux b/stdlib/source/lux/compiler.lux
index 66391a5a1..d1f71a6c3 100644
--- a/stdlib/source/lux/compiler.lux
+++ b/stdlib/source/lux/compiler.lux
@@ -349,7 +349,7 @@
(:: Monad<Lux> wrap name)
_
- (fail (Text/append "AST is not a local symbol: " (ast;ast-to-text ast)))))
+ (fail (Text/append "AST is not a local symbol: " (ast;to-text ast)))))
(macro: #export (with-gensyms tokens)
{#;doc (doc "Creates new symbols and offers them to the body expression."
diff --git a/stdlib/source/lux/control/effect.lux b/stdlib/source/lux/control/effect.lux
index 142e308ea..29db302da 100644
--- a/stdlib/source/lux/control/effect.lux
+++ b/stdlib/source/lux/control/effect.lux
@@ -261,7 +261,7 @@
effect
_
- (error! (format "Wrong type format: " (type;type-to-text type-app)))))
+ (error! (format "Wrong type format: " (%type type-app)))))
(def: (clean-effect effect)
(-> Type Type)
@@ -270,7 +270,7 @@
(#;UnivQ (list) body)
_
- (error! (format "Wrong effect format: " (type;type-to-text effect)))))
+ (error! (format "Wrong effect format: " (%type effect)))))
(def: g!functor AST (ast;symbol ["" "%E"]))
@@ -306,7 +306,7 @@
(~ (ast;symbol var))))))))
_
- (compiler;fail (format "Invalid type to lift: " (type;type-to-text output)))))
+ (compiler;fail (format "Invalid type to lift: " (%type output)))))
(#;Right node)
(do @
diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux
index 04e462feb..675aabfde 100644
--- a/stdlib/source/lux/data/format/json.lux
+++ b/stdlib/source/lux/data/format/json.lux
@@ -748,16 +748,16 @@
.val. (Codec<JSON,?>//encode new-*env* :val:)
#let [:x:+ (case g!vars
#;Nil
- (->Codec//encode (type;type-to-ast :x:))
+ (->Codec//encode (type;to-ast :x:))
_
(` (All (~ g!type-fun) [(~@ g!vars)]
(-> (~@ (List/map ->Codec//encode g!vars))
- (~ (->Codec//encode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]]
+ (~ (->Codec//encode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]]
(wrap (` (: (~ :x:+)
(lambda [(~@ g!vars) (~ g!input)]
(|> (~ g!input)
- (_map_ (: (-> [Text (~ (type;type-to-ast :val:))]
+ (_map_ (: (-> [Text (~ (type;to-ast :val:))]
[Text JSON])
(lambda [[(~ g!key) (~ g!val)]]
[(~ g!key)
@@ -768,12 +768,12 @@
(do @
[:sub: (poly;maybe :x:)
.sub. (Codec<JSON,?>//encode *env* :sub:)]
- (wrap (` (: (~ (->Codec//encode (type;type-to-ast :x:)))
+ (wrap (` (: (~ (->Codec//encode (type;to-ast :x:)))
(;;gen-nullable (~ .sub.))))))
(do @
[:sub: (poly;list :x:)
.sub. (Codec<JSON,?>//encode *env* :sub:)]
- (wrap (` (: (~ (->Codec//encode (type;type-to-ast :x:)))
+ (wrap (` (: (~ (->Codec//encode (type;to-ast :x:)))
(|>. (_map_ (~ .sub.)) vector;from-list ;;gen-array)))))
(with-gensyms [g!type-fun g!case g!input]
(do @
@@ -790,12 +790,12 @@
cases)
#let [:x:+ (case g!vars
#;Nil
- (->Codec//encode (type;type-to-ast :x:))
+ (->Codec//encode (type;to-ast :x:))
_
(` (All (~ g!type-fun) [(~@ g!vars)]
(-> (~@ (List/map ->Codec//encode g!vars))
- (~ (->Codec//encode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]]
+ (~ (->Codec//encode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]]
(wrap (` (: (~ :x:+)
(lambda [(~@ g!vars) (~ g!input)]
(case (~ g!input)
@@ -814,12 +814,12 @@
slots)
#let [:x:+ (case g!vars
#;Nil
- (->Codec//encode (type;type-to-ast :x:))
+ (->Codec//encode (type;to-ast :x:))
_
(` (All (~ g!type-fun) [(~@ g!vars)]
(-> (~@ (List/map ->Codec//encode g!vars))
- (~ (->Codec//encode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]]
+ (~ (->Codec//encode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]]
(wrap (` (: (~ :x:+)
(lambda [(~@ g!vars) (~ g!input)]
(;;json (~ (ast;record synthesis))))
@@ -837,12 +837,12 @@
members)
#let [:x:+ (case g!vars
#;Nil
- (->Codec//encode (type;type-to-ast :x:))
+ (->Codec//encode (type;to-ast :x:))
_
(` (All (~ g!type-fun) [(~@ g!vars)]
(-> (~@ (List/map ->Codec//encode g!vars))
- (~ (->Codec//encode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]
+ (~ (->Codec//encode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]
#let [.tuple. (` [(~@ (List/map product;left pattern-matching))])]]
(wrap (` (: (~ :x:+)
(lambda [(~@ g!vars) (~ .tuple.)]
@@ -855,10 +855,10 @@
[[:func: :args:] (poly;apply :x:)
.func. (Codec<JSON,?>//encode *env* :func:)
.args. (mapM @ (Codec<JSON,?>//encode *env*) :args:)]
- (wrap (` (: (~ (->Codec//encode (type;type-to-ast :x:)))
+ (wrap (` (: (~ (->Codec//encode (type;to-ast :x:)))
((~ .func.) (~@ .args.))))))
(poly;bound *env* :x:)
- (compiler;fail (format "Can't create JSON encoder for: " (type;type-to-text :x:)))
+ (compiler;fail (format "Can't create JSON encoder for: " (%type :x:)))
))))
(poly: #export (Codec<JSON,?>//decode *env* :x:)
@@ -877,7 +877,7 @@
[(do @
[:sub: (<matcher> :x:)
.sub. (Codec<JSON,?>//decode *env* :sub:)]
- (wrap (` (: (~ (->Codec//decode (type;type-to-ast :x:)))
+ (wrap (` (: (~ (->Codec//decode (type;to-ast :x:)))
(<decoder> (~ .sub.))))))]
[Maybe poly;maybe ;;nullable]
@@ -899,12 +899,12 @@
.val. (Codec<JSON,?>//decode new-*env* :val:)
#let [:x:+ (case g!vars
#;Nil
- (->Codec//decode (type;type-to-ast :x:))
+ (->Codec//decode (type;to-ast :x:))
_
(` (All (~ g!type-fun) [(~@ g!vars)]
(-> (~@ (List/map ->Codec//decode g!vars))
- (~ (->Codec//decode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]]
+ (~ (->Codec//decode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]]
(wrap (` (: (~ :x:+)
(lambda [(~@ g!vars) (~ g!input)]
(do Monad<Error>
@@ -935,12 +935,12 @@
cases)
#let [:x:+ (case g!vars
#;Nil
- (->Codec//decode (type;type-to-ast :x:))
+ (->Codec//decode (type;to-ast :x:))
_
(` (All (~ g!type-fun) [(~@ g!vars)]
(-> (~@ (List/map ->Codec//decode g!vars))
- (~ (->Codec//decode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))
+ (~ (->Codec//decode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))
base-parser (` ($_ ;;either
(~@ (List/join pattern-matching))))
parser (case g!vars
@@ -967,12 +967,12 @@
slots)
#let [:x:+ (case g!vars
#;Nil
- (->Codec//decode (type;type-to-ast :x:))
+ (->Codec//decode (type;to-ast :x:))
_
(` (All (~ g!type-fun) [(~@ g!vars)]
(-> (~@ (List/map ->Codec//decode g!vars))
- (~ (->Codec//decode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]]
+ (~ (->Codec//decode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]]
(wrap (` (: (~ :x:+)
(lambda [(~@ g!vars) (~ g!input)]
(do Monad<Error>
@@ -994,12 +994,12 @@
members)
#let [:x:+ (case g!vars
#;Nil
- (->Codec//decode (type;type-to-ast :x:))
+ (->Codec//decode (type;to-ast :x:))
_
(` (All (~ g!type-fun) [(~@ g!vars)]
(-> (~@ (List/map ->Codec//decode g!vars))
- (~ (->Codec//decode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]
+ (~ (->Codec//decode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]
#let [.decoder. (case g!vars
#;Nil
(` (;;shape^ [(~@ (List/map product;right pattern-matching))]))
@@ -1013,12 +1013,12 @@
[[:func: :args:] (poly;apply :x:)
.func. (Codec<JSON,?>//decode *env* :func:)
.args. (mapM @ (Codec<JSON,?>//decode *env*) :args:)]
- (wrap (` (: (~ (->Codec//decode (type;type-to-ast :x:)))
+ (wrap (` (: (~ (->Codec//decode (type;to-ast :x:)))
((~ .func.) (~@ .args.))))))
(do @
[g!bound (poly;bound *env* :x:)]
(wrap g!bound))
- (compiler;fail (format "Can't create JSON decoder for: " (type;type-to-text :x:)))
+ (compiler;fail (format "Can't create JSON decoder for: " (%type :x:)))
))))
(syntax: #export (Codec<JSON,?> :x:)
diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux
index a8b289fe3..f30e7de42 100644
--- a/stdlib/source/lux/data/text/format.lux
+++ b/stdlib/source/lux/data/text/format.lux
@@ -44,8 +44,8 @@
[%c Char (:: char;Codec<Text,Char> encode)]
[%t Text (:: text;Codec<Text,Text> encode)]
[%ident Ident (:: ident;Codec<Text,Ident> encode)]
- [%ast AST ast;ast-to-text]
- [%type Type type;type-to-text]
+ [%ast AST ast;to-text]
+ [%type Type type;to-text]
)
(def: #export (%list formatter)
diff --git a/stdlib/source/lux/host.lux b/stdlib/source/lux/host.lux
index ca4958771..7149cab94 100644
--- a/stdlib/source/lux/host.lux
+++ b/stdlib/source/lux/host.lux
@@ -14,7 +14,7 @@
number
maybe
[product]
- [text "Text/" Eq<Text>]
+ [text "Text/" Eq<Text> Monoid<Text>]
text/format
[bool "Bool/" Codec<Text,Bool>])
[compiler #+ with-gensyms Functor<Lux> Monad<Lux>]
@@ -74,14 +74,14 @@
[(type: #export <name>
(#;HostT <class> #;Nil))]
- ["[Z" BooleanArray]
- ["[B" ByteArray]
- ["[S" ShortArray]
- ["[I" IntArray]
- ["[J" LongArray]
- ["[F" FloatArray]
- ["[D" DoubleArray]
- ["[C" CharArray]
+ ["[Z" Boolean-Array]
+ ["[B" Byte-Array]
+ ["[S" Short-Array]
+ ["[I" Int-Array]
+ ["[J" Long-Array]
+ ["[F" Float-Array]
+ ["[D" Double-Array]
+ ["[C" Char-Array]
)
(type: Code Text)
@@ -716,14 +716,14 @@
[(Text/= <name> name)
(wrap (#GenericClass <class> (list)))]
- ["[Z" "BooleanArray"]
- ["[B" "ByteArray"]
- ["[S" "ShortArray"]
- ["[I" "IntArray"]
- ["[J" "LongArray"]
- ["[F" "FloatArray"]
- ["[D" "DoubleArray"]
- ["[C" "CharArray"])]
+ ["[Z" "Boolean-Array"]
+ ["[B" "Byte-Array"]
+ ["[S" "Short-Array"]
+ ["[I" "Int-Array"]
+ ["[J" "Long-Array"]
+ ["[F" "Float-Array"]
+ ["[D" "Double-Array"]
+ ["[C" "Char-Array"])]
(cond (member? text;Eq<Text> (map product;left type-vars) name)
(wrap (#GenericTypeVar name))
@@ -752,8 +752,8 @@
(s;form (do s;Monad<Syntax>
[name (full-class-name^ imports)
params (s;some (generic-type^ imports type-vars))
- _ (s;assert (not (member? text;Eq<Text> (map product;left type-vars) name))
- (format name " can't be a type-parameter!"))]
+ _ (s;assert (format name " can't be a type-parameter!")
+ (not (member? text;Eq<Text> (map product;left type-vars) name)))]
(wrap (#GenericClass name params))))
))
@@ -1128,7 +1128,7 @@
(def: (annotation-param$ [name value])
(-> AnnotationParam Code)
- (format name "=" (ast;ast-to-text value)))
+ (format name "=" (ast;to-text value)))
(def: (annotation$ [name params])
(-> Annotation Code)
@@ -1197,7 +1197,7 @@
(spaced (list "constant" name
(with-brackets (spaced (map annotation$ anns)))
(generic-type$ class)
- (ast;ast-to-text value))
+ (ast;to-text value))
))
(#VariableField sm class)
@@ -1218,7 +1218,7 @@
(def: (constructor-arg$ [class term])
(-> ConstructorArg Code)
(with-brackets
- (spaced (list (generic-type$ class) (ast;ast-to-text term)))))
+ (spaced (list (generic-type$ class) (ast;to-text term)))))
(def: (method-def$ replacer super-class [[name pm anns] method-def])
(-> (-> AST AST) SuperClassDecl [MemberDecl MethodDef] Code)
@@ -1233,7 +1233,7 @@
(with-brackets (spaced (map generic-type$ exs)))
(with-brackets (spaced (map arg-decl$ arg-decls)))
(with-brackets (spaced (map constructor-arg$ constructor-args)))
- (ast;ast-to-text (pre-walk-replace replacer body))
+ (ast;to-text (pre-walk-replace replacer body))
)))
(#VirtualMethod final? strict-fp? type-vars arg-decls return-type body exs)
@@ -1248,7 +1248,7 @@
(with-brackets (spaced (map generic-type$ exs)))
(with-brackets (spaced (map arg-decl$ arg-decls)))
(generic-type$ return-type)
- (ast;ast-to-text (pre-walk-replace replacer body)))))
+ (ast;to-text (pre-walk-replace replacer body)))))
(#OverridenMethod strict-fp? class-decl type-vars arg-decls return-type body exs)
(let [super-replacer (parser->replacer (s;form (do s;Monad<Syntax>
@@ -1271,7 +1271,7 @@
(|> body
(pre-walk-replace replacer)
(pre-walk-replace super-replacer)
- (ast;ast-to-text))
+ (ast;to-text))
))))
(#StaticMethod strict-fp? type-vars arg-decls return-type body exs)
@@ -1285,7 +1285,7 @@
(with-brackets (spaced (map generic-type$ exs)))
(with-brackets (spaced (map arg-decl$ arg-decls)))
(generic-type$ return-type)
- (ast;ast-to-text (pre-walk-replace replacer body)))))
+ (ast;to-text (pre-walk-replace replacer body)))))
(#AbstractMethod type-vars arg-decls return-type exs)
(with-parens
@@ -1433,7 +1433,7 @@
"An optional super-class can be specified before the 1st vector. If not specified, java.lang.Object will be assumed."
(object [java.lang.Runnable]
[]
- (java.lang.Runnable run [] [] void
+ (java.lang.Runnable (run) void
(exec (do-something some-input)
[])))
)}
@@ -1504,11 +1504,21 @@
(syntax: #export (instance? {#let [imports (class-imports *compiler*)]}
{class (generic-type^ imports (list))}
- obj)
+ {obj (s;opt s;any)})
{#;doc (doc "Checks whether an object is an instance of a particular class."
"Caveat emptor: Can't check for polymorphism, so avoid using parameterized classes."
(instance? String "YOLO"))}
- (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text (format "instanceof" ":" (simple-class$ (list) class))))] [(~ obj)])))))
+ (case obj
+ (#;Some obj)
+ (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text (format "instanceof" ":" (simple-class$ (list) class))))] [(~ obj)]))))
+
+ #;None
+ (do @
+ [g!obj (compiler;gensym "obj")]
+ (wrap (list (` (: (-> (host (~' java.lang.Object)) Bool)
+ (lambda [(~ g!obj)]
+ (;_lux_proc ["jvm" (~ (ast;text (format "instanceof" ":" (simple-class$ (list) class))))] [(~ g!obj)])))))))
+ ))
(syntax: #export (synchronized lock body)
{#;doc (doc "Evaluates body, while holding a lock on a given object."
@@ -1516,15 +1526,7 @@
(exec (do-something ...)
(do-something-else ...)
(finish-the-computation ...))))}
- (wrap (list (` (;_lux_proc ["jvm" "synchronized"] [(~ lock) (~ body)]))))
- ## (with-gensyms [g!lock g!body g!_ g!e]
- ## (wrap (list (` (let [(~ g!lock) (~ lock)
- ## (~ g!_) (;_lux_proc ["jvm" "monitorenter"] [(~ g!lock)])
- ## (~ g!body) (~ body)
- ## (~ g!_) (;_lux_proc ["jvm" "monitorexit"] [(~ g!lock)])]
- ## (~ g!body)))))
- ## )
- )
+ (wrap (list (` (;_lux_proc ["jvm" "synchronized"] [(~ lock) (~ body)])))))
(syntax: #export (do-to obj {methods (s;some partial-call^)})
{#;doc (doc "Call a variety of methods on an object; then return the object."
@@ -1532,14 +1534,14 @@
(HttpServerRequest.setExpectMultipart [true])
(ReadStream.handler [(object [(Handler Buffer)]
[]
- ((Handler A) handle [] [(buffer A)] void
+ ((Handler A) (handle {buffer A}) void
(io;run (do Monad<IO>
[_ (write (Buffer.getBytes [] buffer) body)]
(wrap []))))
)])
(ReadStream.endHandler [[(object [(Handler Void)]
[]
- ((Handler A) handle [] [(_ A)] void
+ ((Handler A) (handle {_ A}) void
(exec (do Monad<Promise>
[#let [_ (io;run (close body))]
response (handler (request$ vreq body))]
@@ -1949,25 +1951,25 @@
"Also, classes which get imported into a module can also be referred-to with their short names in other macros that require JVM classes."
"Examples:"
(jvm-import java.lang.Object
- (new [] [])
- (equals [] [Object] boolean)
- (wait [] [int] #io #try void))
+ (new [])
+ (equals [Object] boolean)
+ (wait [int] #io #try void))
"Special options can also be given for the return values."
"#? means that the values will be returned inside a Maybe type. That way, null becomes #;None."
"#try means that the computation might throw an exception, and the return value will be wrapped by the Error type."
"#io means the computation has side effects, and will be wrapped by the IO type."
"These options must show up in the following order [#io #try #?] (although, each option can be used independently)."
(jvm-import java.lang.String
- (new [] [(Array byte)])
- (#static valueOf [] [char] String)
- (#static valueOf #as int-valueOf [] [int] String))
+ (new [(Array byte)])
+ (#static valueOf [char] String)
+ (#static valueOf #as int-valueOf [int] String))
(jvm-import #long (java.util.List e)
- (size [] [] int)
- (get [] [int] e))
+ (size [] int)
+ (get [int] e))
(jvm-import (java.util.ArrayList a)
- (toArray [T] [(Array T)] (Array T)))
+ ([T] toArray [(Array T)] (Array T)))
"#long makes it so the class-type that is generated is of the fully-qualified name."
"In this case, it avoids a clash between the java.util.List type, and Lux's own List type."
(jvm-import java.lang.Character$UnicodeScript
@@ -1975,11 +1977,11 @@
"All enum options to be imported must be specified."
(jvm-import #long (lux.concurrency.promise.JvmPromise A)
- (resolve [] [A] boolean)
- (poll [] [] A)
- (wasResolved [] [] boolean)
- (waitOn [] [lux.Function] void)
- (#static make [A] [A] (JvmPromise A)))
+ (resolve [A] boolean)
+ (poll [] A)
+ (wasResolved [] boolean)
+ (waitOn [lux.Function] void)
+ (#static [A] make [A] (JvmPromise A)))
"It should also be noted, the only types that may show up in method arguments or return values may be Java classes, arrays, primitives, void or type-parameters."
"Lux types, such as Maybe can't be named (otherwise, they'd be confused for Java classes)."
@@ -2030,7 +2032,7 @@
(#;AppT F A)
(case (type;apply-type F A)
#;None
- (compiler;fail (format "Can't apply type: " (type;type-to-text F) " to " (type;type-to-text A)))
+ (compiler;fail (format "Can't apply type: " (type;to-text F) " to " (type;to-text A)))
(#;Some type')
(type->class-name type'))
@@ -2042,7 +2044,7 @@
(:: Monad<Lux> wrap "java.lang.Object")
(^or #;VoidT (#;VarT _) (#;ExT _) (#;BoundT _) (#;SumT _) (#;ProdT _) (#;LambdaT _) (#;UnivQ _) (#;ExQ _))
- (compiler;fail (format "Can't convert to JvmType: " (type;type-to-text type)))
+ (compiler;fail (format "Can't convert to JvmType: " (type;to-text type)))
))
(syntax: #export (array-load idx array)
@@ -2135,3 +2137,30 @@
{#;doc (doc "Loads the class a a Class object."
(class-for java.lang.String))}
(wrap (list (` (;_lux_proc ["jvm" "load-class"] [(~ (ast;text (simple-class$ (list) type)))])))))
+
+(def: get-compiler
+ (Lux Compiler)
+ (lambda [compiler]
+ (#;Right [compiler compiler])))
+
+(def: (fully-qualify-class-name+ imports name)
+ (-> ClassImports Text (Maybe Text))
+ (cond (fully-qualified-class-name? name)
+ (#;Some name)
+
+ (member? text;Eq<Text> java.lang-classes name)
+ (#;Some (format "java.lang." name))
+
+ ## else
+ (get-import name imports)))
+
+(def: #export (resolve-class class)
+ (-> Text (Lux Text))
+ (do Monad<Lux>
+ [*compiler* get-compiler]
+ (case (fully-qualify-class-name+ (class-imports *compiler*) class)
+ (#;Some fqcn)
+ (wrap fqcn)
+
+ #;None
+ (compiler;fail (Text/append "Unknown class: " class)))))
diff --git a/stdlib/source/lux/macro/ast.lux b/stdlib/source/lux/macro/ast.lux
index cc1cffa5f..06ba2aaed 100644
--- a/stdlib/source/lux/macro/ast.lux
+++ b/stdlib/source/lux/macro/ast.lux
@@ -100,7 +100,7 @@
false)))
## [Values]
-(def: #export (ast-to-text ast)
+(def: #export (to-text ast)
(-> AST Text)
(case ast
(^template [<tag> <struct>]
@@ -120,12 +120,12 @@
(^template [<tag> <open> <close>]
[_ (<tag> members)]
- ($_ Text/append <open> (|> members (map ast-to-text) (interpose " ") (text;join-with "")) <close>))
+ ($_ Text/append <open> (|> members (map to-text) (interpose " ") (text;join-with "")) <close>))
([#;FormS "(" ")"]
[#;TupleS "[" "]"])
[_ (#;RecordS pairs)]
- ($_ Text/append "{" (|> pairs (map (lambda [[left right]] ($_ Text/append (ast-to-text left) " " (ast-to-text right)))) (interpose " ") (text;join-with "")) "}")
+ ($_ Text/append "{" (|> pairs (map (lambda [[left right]] ($_ Text/append (to-text left) " " (to-text right)))) (interpose " ") (text;join-with "")) "}")
))
(def: #export (replace source target ast)
diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux
index bb5c068f7..a2a7dd7d6 100644
--- a/stdlib/source/lux/macro/poly.lux
+++ b/stdlib/source/lux/macro/poly.lux
@@ -39,7 +39,7 @@
(:: compiler;Monad<Lux> wrap [])
_
- (compiler;fail (format "Not " <name> " type: " (type;type-to-text :type:))))))]
+ (compiler;fail (format "Not " <name> " type: " (%type :type:))))))]
[unit "Unit"]
[bool "Bool"]
@@ -70,7 +70,7 @@
<primitives>))))
(syntax: ($AST$ ast)
- (wrap (;list (ast;text (ast;ast-to-text ast)))))
+ (wrap (;list (ast;text (ast;to-text ast)))))
(do-template [<single> <multi> <flattener> <tag>]
[(def: #export <single>
@@ -81,7 +81,7 @@
(:: compiler;Monad<Lux> wrap [:left: :right:])
_
- (compiler;fail (format "Not a " ($AST$ <tag>) " type: " (type;type-to-text :type:))))))
+ (compiler;fail (format "Not a " ($AST$ <tag>) " type: " (%type :type:))))))
(def: #export <multi>
(Matcher (List Type))
@@ -89,7 +89,7 @@
(let [members (<flattener> (type;un-name :type:))]
(if (n.> +1 (list;size members))
(:: compiler;Monad<Lux> wrap members)
- (compiler;fail (format "Not a " ($AST$ <tag>) " type: " (type;type-to-text :type:)))))))]
+ (compiler;fail (format "Not a " ($AST$ <tag>) " type: " (%type :type:)))))))]
[sum sum+ type;flatten-sum #;SumT]
[prod prod+ type;flatten-prod #;ProdT]
@@ -103,7 +103,7 @@
(:: compiler;Monad<Lux> wrap [:left: :right:])
_
- (compiler;fail (format "Not a LambdaT type: " (type;type-to-text :type:))))))
+ (compiler;fail (format "Not a LambdaT type: " (%type :type:))))))
(def: #export func+
(Matcher [(List Type) Type])
@@ -111,7 +111,7 @@
(let [[ins out] (type;flatten-function (type;un-name :type:))]
(if (n.> +0 (list;size ins))
(:: compiler;Monad<Lux> wrap [ins out])
- (compiler;fail (format "Not a LambdaT type: " (type;type-to-text :type:)))))))
+ (compiler;fail (format "Not a LambdaT type: " (%type :type:)))))))
(def: #export tagged
(Matcher [(List Ident) Type])
@@ -123,7 +123,7 @@
(wrap [tags :def:]))
_
- (compiler;fail (format "Unnamed types can't have tags: " (type;type-to-text :type:))))))
+ (compiler;fail (format "Unnamed types can't have tags: " (%type :type:))))))
(def: #export polymorphic
(Matcher [(List AST) Type])
@@ -206,7 +206,7 @@
(:: compiler;Monad<Lux> wrap :arg:)
_
- (compiler;fail (format "Not " <name> " type: " (type;type-to-text :type:))))))]
+ (compiler;fail (format "Not " <name> " type: " (%type :type:))))))]
[maybe "Maybe"]
[list "List"]
@@ -229,10 +229,10 @@
(:: compiler;Monad<Lux> wrap poly-val)
#;None
- (compiler;fail (format "Unknown bound type: " (type;type-to-text :type:))))
+ (compiler;fail (format "Unknown bound type: " (%type :type:))))
_
- (compiler;fail (format "Not a bound type: " (type;type-to-text :type:))))))
+ (compiler;fail (format "Not a bound type: " (%type :type:))))))
(def: #export (var env var-id)
(-> Env Nat (Matcher Unit))
@@ -243,7 +243,7 @@
(:: compiler;Monad<Lux> wrap [])
_
- (compiler;fail (format "Not a bound type: " (type;type-to-text :type:))))))
+ (compiler;fail (format "Not a bound type: " (%type :type:))))))
(def: #export (recur env)
(-> Env (Matcher Unit))
@@ -263,7 +263,7 @@
(recur (n.inc base) :parts:')
_
- (compiler;fail (format "Type is not a recursive instance: " (type;type-to-text :type:)))))
+ (compiler;fail (format "Type is not a recursive instance: " (%type :type:)))))
)))
## [Syntax]
@@ -345,7 +345,7 @@
## [Derivers]
(def: #export (gen-type converter type-fun tvars type)
(-> (-> AST AST) AST (List AST) Type AST)
- (let [type' (type;type-to-ast type)]
+ (let [type' (type;to-ast type)]
(case tvars
#;Nil
(converter type')
diff --git a/stdlib/source/lux/macro/poly/eq.lux b/stdlib/source/lux/macro/poly/eq.lux
index b0506c5ed..025797751 100644
--- a/stdlib/source/lux/macro/poly/eq.lux
+++ b/stdlib/source/lux/macro/poly/eq.lux
@@ -94,10 +94,10 @@
[[:func: :args:] (poly;apply :x:)
.func. (|Eq| env :func:)
.args. (mapM @ (|Eq| env) :args:)]
- (wrap (` (: (~ (->Eq (type;type-to-ast :x:)))
+ (wrap (` (: (~ (->Eq (type;to-ast :x:)))
((~ .func.) (~@ .args.))))))
## Bound type-vars
(poly;bound env :x:)
## If all else fails...
- (compiler;fail (format "Can't create Eq for: " (type;type-to-text :x:)))
+ (compiler;fail (format "Can't create Eq for: " (%type :x:)))
))))
diff --git a/stdlib/source/lux/macro/poly/functor.lux b/stdlib/source/lux/macro/poly/functor.lux
index c9de93cbb..17fd7808f 100644
--- a/stdlib/source/lux/macro/poly/functor.lux
+++ b/stdlib/source/lux/macro/poly/functor.lux
@@ -80,7 +80,7 @@
(wrap (list analysis
synthesis))))
cases)]
- (wrap (` (: (~ (->Functor (type;type-to-ast :x:)))
+ (wrap (` (: (~ (->Functor (type;to-ast :x:)))
(struct (def: ((~ g!map) (~ g!func) (~ g!input))
(case (~ g!input)
(~@ (List/join pattern-matching)))))
@@ -95,7 +95,7 @@
body (|elem| g!slot :slot:)]
(wrap [g!slot body])))
members)]
- (wrap (` (: (~ (->Functor (type;type-to-ast :x:)))
+ (wrap (` (: (~ (->Functor (type;to-ast :x:)))
(struct (def: ((~ g!map) (~ g!func) (~ g!input))
(case (~ g!input)
[(~@ (List/map product;left pm))]
@@ -109,7 +109,7 @@
g!ins (seqM @
(list;repeat (list;size :ins:)
(compiler;gensym "g!arg")))]
- (wrap (` (: (~ (->Functor (type;type-to-ast :x:)))
+ (wrap (` (: (~ (->Functor (type;to-ast :x:)))
(struct (def: ((~ g!map) (~ g!func) (~ g!input))
(lambda [(~@ g!ins)]
(let [(~ g!out) ((~ g!input) (~@ g!ins))]
@@ -117,10 +117,10 @@
## No structure (as you'd expect from Identity)
(do @
[_ (poly;var new-env (n.dec num-vars) :x:)]
- (wrap (` (: (~ (->Functor (type;type-to-ast :x:)))
+ (wrap (` (: (~ (->Functor (type;to-ast :x:)))
(struct (def: ((~ g!map) (~ g!func) (~ g!input))
((~ g!func) (~ g!input))))))))
## Failure...
- (compiler;fail (format "Can't create Functor for: " (type;type-to-text :x:)))
+ (compiler;fail (format "Can't create Functor for: " (%type :x:)))
))
)))
diff --git a/stdlib/source/lux/macro/poly/text-encoder.lux b/stdlib/source/lux/macro/poly/text-encoder.lux
index 49d06daf4..c2ab30d7f 100644
--- a/stdlib/source/lux/macro/poly/text-encoder.lux
+++ b/stdlib/source/lux/macro/poly/text-encoder.lux
@@ -117,10 +117,10 @@
[[:func: :args:] (poly;apply :x:)
.func. (|Codec@Text//encode| env :func:)
.args. (mapM @ (|Codec@Text//encode| env) :args:)]
- (wrap (` (: (~ (->Codec//encode (type;type-to-ast :x:)))
+ (wrap (` (: (~ (->Codec//encode (type;to-ast :x:)))
((~ .func.) (~@ .args.))))))
## Bound type-variables
(poly;bound env :x:)
## Failure...
- (compiler;fail (format "Can't create Text encoder for: " (type;type-to-text :x:)))
+ (compiler;fail (format "Can't create Text encoder for: " (%type :x:)))
))))
diff --git a/stdlib/source/lux/macro/syntax.lux b/stdlib/source/lux/macro/syntax.lux
index c32d5d105..1d3ef021d 100644
--- a/stdlib/source/lux/macro/syntax.lux
+++ b/stdlib/source/lux/macro/syntax.lux
@@ -78,7 +78,7 @@
(def: (remaining-inputs asts)
(-> (List AST) Text)
($_ Text/append " | Remaining input: "
- (|> asts (map ast;ast-to-text) (interpose " ") (text;join-with ""))))
+ (|> asts (map ast;to-text) (interpose " ") (text;join-with ""))))
## [Syntaxs]
(def: #export any
@@ -121,7 +121,7 @@
(#;Cons [[_ (<tag> x)] tokens'])
(if (:: <eq> = v x)
(#;Right [tokens' []])
- (#;Left ($_ Text/append "Expected a " <desc> " but instead got " (ast;ast-to-text [_ (<tag> x)]) (remaining-inputs tokens))))
+ (#;Left ($_ Text/append "Expected a " <desc> " but instead got " (ast;to-text [_ (<tag> x)]) (remaining-inputs tokens))))
_
(#;Left ($_ Text/append "Can't parse " <desc> (remaining-inputs tokens))))))]
@@ -136,8 +136,8 @@
[ tag tag? tag! Ident #;TagS ident;Eq<Ident> "tag"]
)
-(def: #export (assert v message)
- (-> Bool Text (Syntax Unit))
+(def: #export (assert message v)
+ (-> Text Bool (Syntax Unit))
(lambda [tokens]
(if v
(#;Right [tokens []])
@@ -148,7 +148,7 @@
(Syntax Int)
(do Monad<Syntax>
[n int
- _ (assert (<comp> 0 n) <error>)]
+ _ (assert <error> (<comp> 0 n))]
(wrap n)))]
[pos-int i.> "Expected a positive integer: N > 0"]
diff --git a/stdlib/source/lux/type.lux b/stdlib/source/lux/type.lux
index bdae9c2bb..c16c8217b 100644
--- a/stdlib/source/lux/type.lux
+++ b/stdlib/source/lux/type.lux
@@ -102,6 +102,22 @@
)))
## [Values]
+(do-template [<name> <tag>]
+ [(def: #export (<name> type)
+ (-> Type [Nat Type])
+ (loop [num-args +0
+ type type]
+ (case type
+ (<tag> env sub-type)
+ (recur (n.inc num-args) sub-type)
+
+ _
+ [num-args type])))]
+
+ [flatten-univq #;UnivQ]
+ [flatten-exq #;ExQ]
+ )
+
(def: #export (flatten-function type)
(-> Type [(List Type) Type])
(case type
@@ -155,12 +171,12 @@
_
#;None))
-(def: #export (type-to-ast type)
+(def: #export (to-ast type)
(-> Type AST)
(case type
(#;HostT name params)
(` (#;HostT (~ (ast;text name))
- (list (~@ (List/map type-to-ast params)))))
+ (list (~@ (List/map to-ast params)))))
(^template [<tag>]
<tag>
@@ -174,13 +190,13 @@
(^template [<tag>]
(<tag> left right)
- (` (<tag> (~ (type-to-ast left))
- (~ (type-to-ast right)))))
+ (` (<tag> (~ (to-ast left))
+ (~ (to-ast right)))))
([#;LambdaT] [#;AppT])
(^template [<tag> <macro> <flattener>]
(<tag> left right)
- (` (<macro> (~@ (List/map type-to-ast (<flattener> type))))))
+ (` (<macro> (~@ (List/map to-ast (<flattener> type))))))
([#;SumT | flatten-sum]
[#;ProdT & flatten-prod])
@@ -189,12 +205,12 @@
(^template [<tag>]
(<tag> env body)
- (` (<tag> (list (~@ (List/map type-to-ast env)))
- (~ (type-to-ast body)))))
+ (` (<tag> (list (~@ (List/map to-ast env)))
+ (~ (to-ast body)))))
([#;UnivQ] [#;ExQ])
))
-(def: #export (type-to-text type)
+(def: #export (to-text type)
(-> Type Text)
(case type
(#;HostT name params)
@@ -203,7 +219,7 @@
($_ Text/append "(^ " name ")")
_
- ($_ Text/append "(^ " name " " (|> params (List/map type-to-text) list;reverse (list;interpose " ") (List/fold Text/append "")) ")"))
+ ($_ Text/append "(^ " name " " (|> params (List/map to-text) list;reverse (list;interpose " ") (List/fold Text/append "")) ")"))
#;VoidT
"Void"
@@ -215,7 +231,7 @@
(<tag> _)
($_ Text/append <open>
(|> (<flatten> type)
- (List/map type-to-text)
+ (List/map to-text)
list;reverse
(list;interpose " ")
(List/fold Text/append ""))
@@ -227,11 +243,11 @@
(let [[ins out] (flatten-function type)]
($_ Text/append "(-> "
(|> ins
- (List/map type-to-text)
+ (List/map to-text)
list;reverse
(list;interpose " ")
(List/fold Text/append ""))
- " " (type-to-text out) ")"))
+ " " (to-text out) ")"))
(#;BoundT idx)
(Nat/encode idx)
@@ -244,13 +260,13 @@
(#;AppT fun param)
(let [[type-fun type-args] (flatten-apply type)]
- ($_ Text/append "(" (type-to-text type-fun) " " (|> type-args (List/map type-to-text) list;reverse (list;interpose " ") (List/fold Text/append "")) ")"))
+ ($_ Text/append "(" (to-text type-fun) " " (|> type-args (List/map to-text) list;reverse (list;interpose " ") (List/fold Text/append "")) ")"))
(#;UnivQ env body)
- ($_ Text/append "(All " (type-to-text body) ")")
+ ($_ Text/append "(All " (to-text body) ")")
(#;ExQ env body)
- ($_ Text/append "(Ex " (type-to-text body) ")")
+ ($_ Text/append "(Ex " (to-text body) ")")
(#;NamedT [module name] type)
($_ Text/append module ";" name)
diff --git a/stdlib/source/lux/type/check.lux b/stdlib/source/lux/type/check.lux
index 3291f3f56..16bfc9e2c 100644
--- a/stdlib/source/lux/type/check.lux
+++ b/stdlib/source/lux/type/check.lux
@@ -103,7 +103,7 @@
(lambda [context]
(case (type;apply-type t-func t-arg)
#;None
- (#;Left (format "Invalid type application: " (type;type-to-text t-func) " on " (type;type-to-text t-arg)))
+ (#;Left (format "Invalid type application: " (%type t-func) " on " (%type t-arg)))
(#;Some output)
(#;Right [context output]))))
@@ -146,7 +146,7 @@
(lambda [context]
(case (|> context (get@ #bindings) (dict;get id))
(#;Some (#;Some bound))
- (#;Left (format "Can't rebind type-var: " (%n id) " | Current type: " (type;type-to-text bound)))
+ (#;Left (format "Can't rebind type-var: " (%n id) " | Current type: " (%type bound)))
(#;Some #;None)
(#;Right [(update@ #bindings (dict;put id (#;Some type)) context)
@@ -330,8 +330,8 @@
(def: (fail-check expected actual)
(-> Type Type (Check []))
- (fail (format "Expected: " (type;type-to-text expected) "\n\n"
- "Actual: " (type;type-to-text actual))))
+ (fail (format "Expected: " (%type expected) "\n\n"
+ "Actual: " (%type actual))))
(def: success (Check []) (Check/wrap []))