diff options
| -rw-r--r-- | stdlib/source/lux.lux | 10 | ||||
| -rw-r--r-- | stdlib/source/lux/compiler.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/lux/control/effect.lux | 6 | ||||
| -rw-r--r-- | stdlib/source/lux/data/format/json.lux | 48 | ||||
| -rw-r--r-- | stdlib/source/lux/data/text/format.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/lux/host.lux | 141 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/ast.lux | 6 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly.lux | 26 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly/eq.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly/functor.lux | 10 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly/text-encoder.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/syntax.lux | 10 | ||||
| -rw-r--r-- | stdlib/source/lux/type.lux | 46 | ||||
| -rw-r--r-- | stdlib/source/lux/type/check.lux | 8 |
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 [])) |