From c218bc693aa3703fee666c3ca1c068201c07d2a9 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 6 Jun 2019 22:44:00 -0400 Subject: WIP: Class definition. --- stdlib/source/lux/host.jvm.lux | 21 +- stdlib/source/lux/tool/compiler/default/init.lux | 9 +- .../source/lux/tool/compiler/default/platform.lux | 4 +- .../lux/tool/compiler/phase/extension/analysis.lux | 14 +- .../compiler/phase/extension/analysis/common.lux | 285 --------- .../tool/compiler/phase/extension/analysis/jvm.lux | 642 +++++++++++++++------ .../tool/compiler/phase/extension/analysis/lux.lux | 285 +++++++++ .../tool/compiler/phase/extension/statement.lux | 347 ----------- .../compiler/phase/extension/statement/lux.lux | 347 +++++++++++ stdlib/source/program/compositor.lux | 7 +- stdlib/source/test/lux/host.jvm.lux | 56 +- .../test/lux/tool/compiler/phase/analysis.lux | 4 +- .../compiler/phase/extension/analysis/common.lux | 201 ------- .../tool/compiler/phase/extension/analysis/lux.lux | 201 +++++++ 14 files changed, 1363 insertions(+), 1060 deletions(-) delete mode 100644 stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/extension/analysis/lux.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/extension/statement.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/extension/statement/lux.lux delete mode 100644 stdlib/source/test/lux/tool/compiler/phase/extension/analysis/common.lux create mode 100644 stdlib/source/test/lux/tool/compiler/phase/extension/analysis/lux.lux (limited to 'stdlib') diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux index c6d636e82..0c15560c0 100644 --- a/stdlib/source/lux/host.jvm.lux +++ b/stdlib/source/lux/host.jvm.lux @@ -207,6 +207,7 @@ (type: Method-Definition (#ConstructorMethod [Bit (List Var) + Text (List Argument) (List (Typed Code)) Code @@ -526,7 +527,7 @@ (def: (method->parser class-name [[method-name _ _] meth-def]) (-> Text [Member-Declaration Method-Definition] (Parser Code)) (case meth-def - (#ConstructorMethod strict? type-vars args constructor-args return-expr exs) + (#ConstructorMethod strict? type-vars self-name args constructor-args return-expr exs) (make-constructor-parser class-name args) (#StaticMethod strict? type-vars args return-type return-expr exs) @@ -753,8 +754,10 @@ strict-fp? (p.parses? (s.this! (' #strict))) method-vars (p.default (list) ..vars^) #let [total-vars (list@compose class-vars method-vars)] - [_ arguments] (s.form (p.and (s.this! (' new)) - (arguments^ imports total-vars))) + [_ self-name arguments] (s.form ($_ p.and + (s.this! (' new)) + s.local-identifier + (arguments^ imports total-vars))) constructor-args (constructor-args^ imports total-vars) exs (throws-decl^ imports total-vars) annotations (annotations^ imports) @@ -762,7 +765,7 @@ (wrap [{#member-name constructor-method-name #member-privacy pm #member-anns annotations} - (#ConstructorMethod strict-fp? method-vars arguments constructor-args body exs)])))) + (#ConstructorMethod strict-fp? method-vars self-name arguments constructor-args body exs)])))) (def: (virtual-method-def^ imports class-vars) (-> Class-Imports (List Var) (Parser [Member-Declaration Method-Definition])) @@ -1100,13 +1103,14 @@ (def: (method-def$ replacer super-class [[name pm anns] method-def]) (-> (-> Code Code) Class [Member-Declaration Method-Definition] Code) (case method-def - (#ConstructorMethod strict-fp? type-vars arguments constructor-args body exs) + (#ConstructorMethod strict-fp? type-vars self-name arguments constructor-args body exs) (` ("init" (~ (privacy-modifier$ pm)) (~ (code.bit strict-fp?)) [(~+ (list@map annotation$ anns))] [(~+ (list@map var$ type-vars))] [(~+ (list@map class$ exs))] + (~ (code.text self-name)) [(~+ (list@map argument$ arguments))] [(~+ (list@map constructor-arg$ constructor-args))] (~ (pre-walk-replace replacer body)) @@ -1248,7 +1252,12 @@ (p.fail "") (list@compose field-parsers method-parsers)))]] (wrap (list (` ("jvm class" - (~ (declaration$ declaration)) + (~ (declaration$ (update@ #class-name + (|>> (format (text.replace-all ..binary-class-separator + ..syntax-class-separator + current-module) + ..syntax-class-separator)) + declaration))) (~ (class$ super)) [(~+ (list@map class$ interfaces))] (~ (inheritance-modifier$ im)) diff --git a/stdlib/source/lux/tool/compiler/default/init.lux b/stdlib/source/lux/tool/compiler/default/init.lux index a7a861289..28c0efb76 100644 --- a/stdlib/source/lux/tool/compiler/default/init.lux +++ b/stdlib/source/lux/tool/compiler/default/init.lux @@ -35,7 +35,8 @@ ["." extension [".E" analysis] [".E" synthesis] - [".E" statement]]] + [statement + [".S" lux]]]] [meta [archive ["." signature] @@ -58,19 +59,21 @@ #.version //.version #.mode #.Build}) -(def: #export (state expander host generate generation-bundle program) +(def: #export (state expander host generate generation-bundle host-statement-bundle program) (All [anchor expression statement] (-> Expander (generation.Host expression statement) (generation.Phase anchor expression statement) (generation.Bundle anchor expression statement) + (///statement.Bundle anchor expression statement) (-> expression statement) (///statement.State+ anchor expression statement))) (let [synthesis-state [synthesisE.bundle ///synthesis.init] generation-state [generation-bundle (generation.state host)] eval (//evaluation.evaluator expander synthesis-state generation-state generate) analysis-state [(analysisE.bundle eval) (///analysis.state ..info host)]] - [(statementE.bundle expander program) + [(dictionary.merge (luxS.bundle expander program) + host-statement-bundle) {#///statement.analysis {#///statement.state analysis-state #///statement.phase (analysisP.phase expander)} #///statement.synthesis {#///statement.state synthesis-state diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux index 164a81730..10a27403e 100644 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ b/stdlib/source/lux/tool/compiler/default/platform.lux @@ -56,11 +56,12 @@ (as-is (///statement.State+ anchor expression statement)) (as-is (generation.Bundle anchor expression statement))] - (def: #export (initialize expander platform generation-bundle program) + (def: #export (initialize expander platform generation-bundle host-statement-bundle program) (All (-> Expander + (///statement.Bundle anchor expression statement) (-> expression statement) (! (Error )))) (|> platform @@ -70,6 +71,7 @@ (get@ #host platform) (get@ #phase platform) generation-bundle + host-statement-bundle program)) (:: error.functor map product.left) (:: (get@ #&monad platform) wrap)) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis.lux index ca2d75e4d..694f0345f 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis.lux @@ -8,13 +8,13 @@ [default [evaluation (#+ Eval)]] [analysis (#+ Bundle)]] - [/ - ["." common] - ["." (~~ (.for {"{old}" jvm - "JVM" jvm}))]])) + ["." / #_ + ["#." lux] + ["#." (~~ (.for {"{old}" jvm + "JVM" jvm}))]])) (def: #export (bundle eval) (-> Eval Bundle) - (dictionary.merge (`` (for {(~~ (static @.old)) jvm.bundle - (~~ (static @.jvm)) jvm.bundle})) - (common.bundle eval))) + (dictionary.merge (`` (for {(~~ (static @.old)) /jvm.bundle + (~~ (static @.jvm)) /jvm.bundle})) + (/lux.bundle eval))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux deleted file mode 100644 index 51402fad8..000000000 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux +++ /dev/null @@ -1,285 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - [io (#+ IO)] - ["." exception (#+ exception:)] - ["<>" parser - ["" code (#+ Parser)]]] - [data - ["." maybe] - ["." error] - ["." text - format] - [collection - ["." list ("#@." functor)] - ["." dictionary (#+ Dictionary)]]] - [type - ["." check]] - ["." macro]] - ["." /// - ["#." bundle] - ["#/" // - [analysis - [".A" type] - [".A" case] - [".A" function]] - ["#/" // - [default - [evaluation (#+ Eval)]] - ["#." analysis (#+ Analysis Operation Phase Handler Bundle)]]]]) - -(def: #export (custom [syntax handler]) - (All [s] - (-> [(Parser s) - (-> Text Phase s (Operation Analysis))] - Handler)) - (function (_ extension-name analyse args) - (case (.run syntax args) - (#error.Success inputs) - (handler extension-name analyse inputs) - - (#error.Failure error) - (/////analysis.throw ///.invalid-syntax [extension-name %code args])))) - -(def: (simple inputsT+ outputT) - (-> (List Type) Type Handler) - (let [num-expected (list.size inputsT+)] - (function (_ extension-name analyse args) - (let [num-actual (list.size args)] - (if (n/= num-expected num-actual) - (do ////.monad - [_ (typeA.infer outputT) - argsA (monad.map @ - (function (_ [argT argC]) - (typeA.with-type argT - (analyse argC))) - (list.zip2 inputsT+ args))] - (wrap (#/////analysis.Extension extension-name argsA))) - (/////analysis.throw ///.incorrect-arity [extension-name num-expected num-actual])))))) - -(def: #export (nullary valueT) - (-> Type Handler) - (simple (list) valueT)) - -(def: #export (unary inputT outputT) - (-> Type Type Handler) - (simple (list inputT) outputT)) - -(def: #export (binary subjectT paramT outputT) - (-> Type Type Type Handler) - (simple (list subjectT paramT) outputT)) - -(def: #export (trinary subjectT param0T param1T outputT) - (-> Type Type Type Type Handler) - (simple (list subjectT param0T param1T) outputT)) - -## TODO: Get rid of this ASAP -(as-is - (exception: #export (char-text-must-be-size-1 {text Text}) - (exception.report - ["Text" (%t text)])) - - (def: text-char - (Parser text.Char) - (do <>.monad - [raw .text] - (case (text.size raw) - 1 (wrap (|> raw (text.nth 0) maybe.assume)) - _ (<>.fail (exception.construct ..char-text-must-be-size-1 [raw]))))) - - (def: lux::syntax-char-case! - (..custom [($_ <>.and - .any - (.tuple (<>.some (<>.and (.tuple (<>.many ..text-char)) - .any))) - .any) - (function (_ extension-name phase [input conditionals else]) - (do ////.monad - [input (typeA.with-type text.Char - (phase input)) - expectedT (///.lift macro.expected-type) - conditionals (monad.map @ (function (_ [cases branch]) - (do @ - [branch (typeA.with-type expectedT - (phase branch))] - (wrap [cases branch]))) - conditionals) - else (typeA.with-type expectedT - (phase else))] - (wrap (|> conditionals - (list@map (function (_ [cases branch]) - (/////analysis.tuple - (list (/////analysis.tuple (list@map (|>> /////analysis.nat) cases)) - branch)))) - (list& input else) - (#/////analysis.Extension extension-name)))))]))) - -## "lux is" represents reference/pointer equality. -(def: lux::is - Handler - (function (_ extension-name analyse args) - (do ////.monad - [[var-id varT] (typeA.with-env check.var)] - ((binary varT varT Bit extension-name) - analyse args)))) - -## "lux try" provides a simple way to interact with the host platform's -## error-handling facilities. -(def: lux::try - Handler - (function (_ extension-name analyse args) - (case args - (^ (list opC)) - (do ////.monad - [[var-id varT] (typeA.with-env check.var) - _ (typeA.infer (type (Either Text varT))) - opA (typeA.with-type (type (IO varT)) - (analyse opC))] - (wrap (#/////analysis.Extension extension-name (list opA)))) - - _ - (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) - -(def: lux::in-module - Handler - (function (_ extension-name analyse argsC+) - (case argsC+ - (^ (list [_ (#.Text module-name)] exprC)) - (/////analysis.with-current-module module-name - (analyse exprC)) - - _ - (/////analysis.throw ///.invalid-syntax [extension-name %code argsC+])))) - -(def: (lux::check eval) - (-> Eval Handler) - (function (_ extension-name analyse args) - (case args - (^ (list typeC valueC)) - (do ////.monad - [count (///.lift macro.count) - actualT (:: @ map (|>> (:coerce Type)) - (eval count Type typeC)) - _ (typeA.infer actualT)] - (typeA.with-type actualT - (analyse valueC))) - - _ - (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) - -(def: (lux::coerce eval) - (-> Eval Handler) - (function (_ extension-name analyse args) - (case args - (^ (list typeC valueC)) - (do ////.monad - [count (///.lift macro.count) - actualT (:: @ map (|>> (:coerce Type)) - (eval count Type typeC)) - _ (typeA.infer actualT) - [valueT valueA] (typeA.with-inference - (analyse valueC))] - (wrap valueA)) - - _ - (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) - -(def: (caster input output) - (-> Type Type Handler) - (function (_ extension-name analyse args) - (case args - (^ (list valueC)) - (do ////.monad - [_ (typeA.infer output)] - (typeA.with-type input - (analyse valueC))) - - _ - (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) - -(def: (bundle::lux eval) - (-> Eval Bundle) - (|> ///bundle.empty - (///bundle.install "syntax char case!" lux::syntax-char-case!) - (///bundle.install "is" lux::is) - (///bundle.install "try" lux::try) - (///bundle.install "check" (lux::check eval)) - (///bundle.install "coerce" (lux::coerce eval)) - (///bundle.install "macro" (..caster .Macro' .Macro)) - (///bundle.install "check type" (..caster .Type .Type)) - (///bundle.install "in-module" lux::in-module))) - -(def: bundle::io - Bundle - (<| (///bundle.prefix "io") - (|> ///bundle.empty - (///bundle.install "log" (unary Text Any)) - (///bundle.install "error" (unary Text Nothing)) - (///bundle.install "exit" (unary Int Nothing)) - (///bundle.install "current-time" (nullary Int))))) - -(def: I64* (type (I64 Any))) - -(def: bundle::i64 - Bundle - (<| (///bundle.prefix "i64") - (|> ///bundle.empty - (///bundle.install "and" (binary I64* I64* I64)) - (///bundle.install "or" (binary I64* I64* I64)) - (///bundle.install "xor" (binary I64* I64* I64)) - (///bundle.install "left-shift" (binary Nat I64* I64)) - (///bundle.install "logical-right-shift" (binary Nat I64* I64)) - (///bundle.install "arithmetic-right-shift" (binary Nat I64* I64)) - (///bundle.install "=" (binary I64* I64* Bit)) - (///bundle.install "<" (binary Int Int Bit)) - (///bundle.install "+" (binary I64* I64* I64)) - (///bundle.install "-" (binary I64* I64* I64)) - (///bundle.install "*" (binary Int Int Int)) - (///bundle.install "/" (binary Int Int Int)) - (///bundle.install "%" (binary Int Int Int)) - (///bundle.install "f64" (unary Int Frac)) - (///bundle.install "char" (unary Int Text))))) - -(def: bundle::f64 - Bundle - (<| (///bundle.prefix "f64") - (|> ///bundle.empty - (///bundle.install "+" (binary Frac Frac Frac)) - (///bundle.install "-" (binary Frac Frac Frac)) - (///bundle.install "*" (binary Frac Frac Frac)) - (///bundle.install "/" (binary Frac Frac Frac)) - (///bundle.install "%" (binary Frac Frac Frac)) - (///bundle.install "=" (binary Frac Frac Bit)) - (///bundle.install "<" (binary Frac Frac Bit)) - (///bundle.install "smallest" (nullary Frac)) - (///bundle.install "min" (nullary Frac)) - (///bundle.install "max" (nullary Frac)) - (///bundle.install "i64" (unary Frac Int)) - (///bundle.install "encode" (unary Frac Text)) - (///bundle.install "decode" (unary Text (type (Maybe Frac))))))) - -(def: bundle::text - Bundle - (<| (///bundle.prefix "text") - (|> ///bundle.empty - (///bundle.install "=" (binary Text Text Bit)) - (///bundle.install "<" (binary Text Text Bit)) - (///bundle.install "concat" (binary Text Text Text)) - (///bundle.install "index" (trinary Nat Text Text (type (Maybe Nat)))) - (///bundle.install "size" (unary Text Nat)) - (///bundle.install "char" (binary Nat Text Nat)) - (///bundle.install "clip" (trinary Nat Nat Text Text)) - ))) - -(def: #export (bundle eval) - (-> Eval Bundle) - (<| (///bundle.prefix "lux") - (|> ///bundle.empty - (dictionary.merge (bundle::lux eval)) - (dictionary.merge bundle::i64) - (dictionary.merge bundle::f64) - (dictionary.merge bundle::text) - (dictionary.merge bundle::io) - ))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux index 616f030a9..a013c564e 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux @@ -5,8 +5,8 @@ [abstract ["." monad (#+ do)]] [control - ["p" parser - ["s" code (#+ Parser)] + ["<>" parser + ["" code (#+ Parser)] ["" text]] ["." exception (#+ exception:)] pipe] @@ -31,7 +31,7 @@ ["." reflection] [".T" lux (#+ Mapping)]]]]] ["." // #_ - ["#." common (#+ custom)] + ["#." lux (#+ custom)] ["/#" // ["#." bundle] ["/#" // ("#@." monad) @@ -45,7 +45,7 @@ ["#." synthesis]]]]]) (def: inheritance-relationship-type-name "_jvm_inheritance") -(def: (inheritance-relationship-type class super-class super-interfaces) +(def: #export (inheritance-relationship-type class super-class super-interfaces) (-> .Type .Type (List .Type) .Type) (#.Primitive ..inheritance-relationship-type-name (list& class super-class super-interfaces))) @@ -83,7 +83,7 @@ (def: member (Parser Member) - ($_ p.and s.text s.text)) + ($_ <>.and .text .text)) (type: Method-Signature {#method .Type @@ -149,29 +149,29 @@ Bundle (<| (///bundle.prefix "conversion") (|> ///bundle.empty - (///bundle.install "double-to-float" (//common.unary ..double ..float)) - (///bundle.install "double-to-int" (//common.unary ..double ..int)) - (///bundle.install "double-to-long" (//common.unary ..double ..long)) - (///bundle.install "float-to-double" (//common.unary ..float ..double)) - (///bundle.install "float-to-int" (//common.unary ..float ..int)) - (///bundle.install "float-to-long" (//common.unary ..float ..long)) - (///bundle.install "int-to-byte" (//common.unary ..int ..byte)) - (///bundle.install "int-to-char" (//common.unary ..int ..char)) - (///bundle.install "int-to-double" (//common.unary ..int ..double)) - (///bundle.install "int-to-float" (//common.unary ..int ..float)) - (///bundle.install "int-to-long" (//common.unary ..int ..long)) - (///bundle.install "int-to-short" (//common.unary ..int ..short)) - (///bundle.install "long-to-double" (//common.unary ..long ..double)) - (///bundle.install "long-to-float" (//common.unary ..long ..float)) - (///bundle.install "long-to-int" (//common.unary ..long ..int)) - (///bundle.install "long-to-short" (//common.unary ..long ..short)) - (///bundle.install "long-to-byte" (//common.unary ..long ..byte)) - (///bundle.install "char-to-byte" (//common.unary ..char ..byte)) - (///bundle.install "char-to-short" (//common.unary ..char ..short)) - (///bundle.install "char-to-int" (//common.unary ..char ..int)) - (///bundle.install "char-to-long" (//common.unary ..char ..long)) - (///bundle.install "byte-to-long" (//common.unary ..byte ..long)) - (///bundle.install "short-to-long" (//common.unary ..short ..long)) + (///bundle.install "double-to-float" (//lux.unary ..double ..float)) + (///bundle.install "double-to-int" (//lux.unary ..double ..int)) + (///bundle.install "double-to-long" (//lux.unary ..double ..long)) + (///bundle.install "float-to-double" (//lux.unary ..float ..double)) + (///bundle.install "float-to-int" (//lux.unary ..float ..int)) + (///bundle.install "float-to-long" (//lux.unary ..float ..long)) + (///bundle.install "int-to-byte" (//lux.unary ..int ..byte)) + (///bundle.install "int-to-char" (//lux.unary ..int ..char)) + (///bundle.install "int-to-double" (//lux.unary ..int ..double)) + (///bundle.install "int-to-float" (//lux.unary ..int ..float)) + (///bundle.install "int-to-long" (//lux.unary ..int ..long)) + (///bundle.install "int-to-short" (//lux.unary ..int ..short)) + (///bundle.install "long-to-double" (//lux.unary ..long ..double)) + (///bundle.install "long-to-float" (//lux.unary ..long ..float)) + (///bundle.install "long-to-int" (//lux.unary ..long ..int)) + (///bundle.install "long-to-short" (//lux.unary ..long ..short)) + (///bundle.install "long-to-byte" (//lux.unary ..long ..byte)) + (///bundle.install "char-to-byte" (//lux.unary ..char ..byte)) + (///bundle.install "char-to-short" (//lux.unary ..char ..short)) + (///bundle.install "char-to-int" (//lux.unary ..char ..int)) + (///bundle.install "char-to-long" (//lux.unary ..char ..long)) + (///bundle.install "byte-to-long" (//lux.unary ..byte ..long)) + (///bundle.install "short-to-long" (//lux.unary ..short ..long)) ))) (template [ ] @@ -179,19 +179,19 @@ Bundle (<| (///bundle.prefix ) (|> ///bundle.empty - (///bundle.install "+" (//common.binary )) - (///bundle.install "-" (//common.binary )) - (///bundle.install "*" (//common.binary )) - (///bundle.install "/" (//common.binary )) - (///bundle.install "%" (//common.binary )) - (///bundle.install "=" (//common.binary Bit)) - (///bundle.install "<" (//common.binary Bit)) - (///bundle.install "and" (//common.binary )) - (///bundle.install "or" (//common.binary )) - (///bundle.install "xor" (//common.binary )) - (///bundle.install "shl" (//common.binary Integer )) - (///bundle.install "shr" (//common.binary Integer )) - (///bundle.install "ushr" (//common.binary Integer )) + (///bundle.install "+" (//lux.binary )) + (///bundle.install "-" (//lux.binary )) + (///bundle.install "*" (//lux.binary )) + (///bundle.install "/" (//lux.binary )) + (///bundle.install "%" (//lux.binary )) + (///bundle.install "=" (//lux.binary Bit)) + (///bundle.install "<" (//lux.binary Bit)) + (///bundle.install "and" (//lux.binary )) + (///bundle.install "or" (//lux.binary )) + (///bundle.install "xor" (//lux.binary )) + (///bundle.install "shl" (//lux.binary Integer )) + (///bundle.install "shr" (//lux.binary Integer )) + (///bundle.install "ushr" (//lux.binary Integer )) )))] [bundle::int reflection.int ..long] @@ -203,13 +203,13 @@ Bundle (<| (///bundle.prefix ) (|> ///bundle.empty - (///bundle.install "+" (//common.binary )) - (///bundle.install "-" (//common.binary )) - (///bundle.install "*" (//common.binary )) - (///bundle.install "/" (//common.binary )) - (///bundle.install "%" (//common.binary )) - (///bundle.install "=" (//common.binary Bit)) - (///bundle.install "<" (//common.binary Bit)) + (///bundle.install "+" (//lux.binary )) + (///bundle.install "-" (//lux.binary )) + (///bundle.install "*" (//lux.binary )) + (///bundle.install "/" (//lux.binary )) + (///bundle.install "%" (//lux.binary )) + (///bundle.install "=" (//lux.binary Bit)) + (///bundle.install "<" (//lux.binary Bit)) )))] [bundle::float reflection.float ..float] @@ -220,8 +220,8 @@ Bundle (<| (///bundle.prefix reflection.char) (|> ///bundle.empty - (///bundle.install "=" (//common.binary ..char ..char Bit)) - (///bundle.install "<" (//common.binary ..char ..char Bit)) + (///bundle.install "=" (//lux.binary ..char ..char Bit)) + (///bundle.install "<" (//lux.binary ..char ..char Bit)) ))) (def: #export boxes @@ -635,7 +635,7 @@ (def: object::instance? Handler (..custom - [($_ p.and s.text s.any) + [($_ <>.and .text .any) (function (_ extension-name analyse [sub-class objectC]) (do ////.monad [_ (typeA.infer Bit) @@ -842,7 +842,7 @@ (def: static::put Handler (..custom - [($_ p.and ..member s.any) + [($_ <>.and ..member .any) (function (_ extension-name analyse [[class field] valueC]) (do ////.monad [_ (typeA.infer Any) @@ -863,7 +863,7 @@ (def: virtual::get Handler (..custom - [($_ p.and ..member s.any) + [($_ <>.and ..member .any) (function (_ extension-name analyse [[class field] objectC]) (do ////.monad [[objectT objectA] (typeA.with-inference @@ -885,7 +885,7 @@ (def: virtual::put Handler (..custom - [($_ p.and ..member s.any s.any) + [($_ <>.and ..member .any .any) (function (_ extension-name analyse [[class field] valueC objectC]) (do ////.monad [[objectT objectA] (typeA.with-inference @@ -1127,7 +1127,7 @@ (def: typed-input (Parser [Text Code]) - (s.tuple (p.and s.text s.any))) + (.tuple (<>.and .text .any))) (def: (decorate-inputs typesT inputsA) (-> (List Text) (List Analysis) (List Analysis)) @@ -1139,7 +1139,7 @@ (def: invoke::static Handler (..custom - [($_ p.and ..member (p.some ..typed-input)) + [($_ <>.and ..member (<>.some ..typed-input)) (function (_ extension-name analyse [[class method] argsTC]) (do ////.monad [#let [argsT (list@map product.left argsTC)] @@ -1154,7 +1154,7 @@ (def: invoke::virtual Handler (..custom - [($_ p.and ..member s.any (p.some ..typed-input)) + [($_ <>.and ..member .any (<>.some ..typed-input)) (function (_ extension-name analyse [[class method] objectC argsTC]) (do ////.monad [#let [argsT (list@map product.left argsTC)] @@ -1176,7 +1176,7 @@ (def: invoke::special Handler (..custom - [($_ p.and ..member s.any (p.some ..typed-input)) + [($_ <>.and ..member .any (<>.some ..typed-input)) (function (_ extension-name analyse [[class method] objectC argsTC]) (do ////.monad [#let [argsT (list@map product.left argsTC)] @@ -1191,7 +1191,7 @@ (def: invoke::interface Handler (..custom - [($_ p.and ..member s.any (p.some ..typed-input)) + [($_ <>.and ..member .any (<>.some ..typed-input)) (function (_ extension-name analyse [[class-name method] objectC argsTC]) (do ////.monad [#let [argsT (list@map product.left argsTC)] @@ -1216,7 +1216,7 @@ (def: invoke::constructor (..custom - [($_ p.and s.text (p.some ..typed-input)) + [($_ <>.and .text (<>.some ..typed-input)) (function (_ extension-name analyse [class argsTC]) (do ////.monad [#let [argsT (list@map product.left argsTC)] @@ -1247,113 +1247,81 @@ ))) ))) -(def: var +(def: #export var (Parser Var) - s.text) + .text) (def: bound (Parser Bound) - (p.or (s.identifier! ["" ">"]) - (s.identifier! ["" "<"]))) + (<>.or (.identifier! ["" ">"]) + (.identifier! ["" "<"]))) (def: generic (Parser Generic) - (p.rec + (<>.rec (function (_ generic) (let [wildcard (: (Parser (Maybe [Bound Generic])) - (p.or (s.identifier! ["" "?"]) - (s.form (p.and ..bound generic)))) + (<>.or (.identifier! ["" "?"]) + (.form (<>.and ..bound generic)))) class (: (Parser Class) - (s.form (p.and s.text (p.some generic))))] - ($_ p.or + (.form (<>.and .text (<>.some generic))))] + ($_ <>.or ..var wildcard class))))) -(def: class +(def: #export class (Parser Class) - (s.form (p.and s.text (p.some ..generic)))) + (.form (<>.and .text (<>.some ..generic)))) (def: primitive (Parser Primitive) - ($_ p.or - (s.identifier! ["" reflection.boolean]) - (s.identifier! ["" reflection.byte]) - (s.identifier! ["" reflection.short]) - (s.identifier! ["" reflection.int]) - (s.identifier! ["" reflection.long]) - (s.identifier! ["" reflection.float]) - (s.identifier! ["" reflection.double]) - (s.identifier! ["" reflection.char]) + ($_ <>.or + (.identifier! ["" reflection.boolean]) + (.identifier! ["" reflection.byte]) + (.identifier! ["" reflection.short]) + (.identifier! ["" reflection.int]) + (.identifier! ["" reflection.long]) + (.identifier! ["" reflection.float]) + (.identifier! ["" reflection.double]) + (.identifier! ["" reflection.char]) )) -(def: type +(def: #export type (Parser Type) - (p.rec + (<>.rec (function (_ type) - ($_ p.or + ($_ <>.or ..primitive ..generic - (s.tuple type))))) + (.tuple type))))) -(def: typed +(def: #export typed (Parser (Typed Code)) - (s.tuple (p.and ..type s.any))) + (.tuple (<>.and ..type .any))) (type: #export (Annotation-Parameter a) [Text a]) (def: annotation-parameter (Parser (Annotation-Parameter Code)) - (s.tuple (p.and s.text s.any))) + (.tuple (<>.and .text .any))) (type: #export (Annotation a) [Text (List (Annotation-Parameter a))]) -(def: annotation +(def: #export annotation (Parser (Annotation Code)) - (s.form (p.and s.text (p.some ..annotation-parameter)))) + (.form (<>.and .text (<>.some ..annotation-parameter)))) -(def: argument +(def: #export argument (Parser Argument) - (s.tuple (p.and s.text ..type))) + (.tuple (<>.and .text ..type))) -(def: return +(def: #export return (Parser Return) - (p.or (s.identifier! ["" reflection.void]) - ..type)) - -(type: #export (Overriden-Method a) - [Class - Text - Bit - (List (Annotation a)) - (List Var) - Text - (List Argument) - Return - (List Class) - a]) - -(type: #export (Method-Definition a) - (#Overriden-Method (Overriden-Method a))) - -(def: overriden-method-definition - (Parser (Overriden-Method Code)) - (<| s.form - (p.after (s.text! "override")) - ($_ p.and - ..class - s.text - s.bit - (s.tuple (p.some ..annotation)) - (s.tuple (p.some ..var)) - s.text - (s.tuple (p.some ..argument)) - ..return - (s.tuple (p.some ..class)) - s.any - ))) + (<>.or (.identifier! ["" reflection.void]) + ..type)) (def: (generic-analysis generic) (-> Generic Analysis) @@ -1479,14 +1447,378 @@ [invalid-overriden-methods] ) +(type: #export Visibility + #PublicV + #PrivateV + #ProtectedV + #DefaultV) + +(type: #export Finality Bit) +(type: #export Strictness Bit) + +(def: #export public-tag "public") +(def: #export private-tag "private") +(def: #export protected-tag "protected") +(def: #export default-tag "default") + +(def: #export visibility + (Parser Visibility) + ($_ <>.or + (.text! ..public-tag) + (.text! ..private-tag) + (.text! ..protected-tag) + (.text! ..default-tag))) + +(type: #export (Constructor a) + [Visibility + Strictness + (List (Annotation a)) + (List Var) + (List Class) ## Exceptions + Text + (List Argument) + (List (Typed a)) + a]) + +(def: #export constructor-tag "init") + +(def: #export constructor-definition + (Parser (Constructor Code)) + (<| .form + (<>.after (.text! ..constructor-tag)) + ($_ <>.and + ..visibility + .bit + (.tuple (<>.some ..annotation)) + (.tuple (<>.some ..var)) + (.tuple (<>.some ..class)) + .text + (.tuple (<>.some ..argument)) + (.tuple (<>.some ..typed)) + .any))) + +(def: #export (analyse-constructor-method analyse selfT mapping method) + (-> Phase .Type Mapping (Constructor Code) (Operation Analysis)) + (let [[visibility strict-fp? + annotations vars exceptions + self-name arguments super-arguments body] method] + (do ////.monad + [annotationsA (monad.map @ (function (_ [name parameters]) + (do @ + [parametersA (monad.map @ (function (_ [name value]) + (do @ + [valueA (analyse value)] + (wrap [name valueA]))) + parameters)] + (wrap [name parametersA]))) + annotations) + super-arguments (monad.map @ (function (_ [jvmT super-argC]) + (do @ + [luxT (typeA.with-env + (luxT.type mapping jvmT)) + super-argA (typeA.with-type luxT + (analyse super-argC))] + (wrap [jvmT super-argA]))) + super-arguments) + arguments' (typeA.with-env + (monad.map check.monad + (function (_ [name jvmT]) + (do check.monad + [luxT (luxT.type mapping jvmT)] + (wrap [name luxT]))) + arguments)) + [scope bodyA] (|> arguments' + (#.Cons [self-name selfT]) + list.reverse + (list@fold scope.with-local (analyse body)) + (typeA.with-type .Any) + /////analysis.with-scope)] + (wrap (/////analysis.tuple (list (/////analysis.text ..constructor-tag) + (/////analysis.text (case visibility + #PublicV ..public-tag + #PrivateV ..private-tag + #ProtectedV ..protected-tag + #DefaultV ..default-tag)) + (/////analysis.bit strict-fp?) + (/////analysis.tuple (list@map annotation-analysis annotationsA)) + (/////analysis.tuple (list@map var-analysis vars)) + (/////analysis.text self-name) + (/////analysis.tuple (list@map (function (_ [argument argumentJT]) + (/////analysis.tuple + (list (/////analysis.text argument) + (type-analysis argumentJT)))) + arguments)) + (/////analysis.tuple (list@map class-analysis + exceptions)) + (/////analysis.tuple (list@map typed-analysis + super-arguments)) + (#/////analysis.Function + (scope.environment scope) + (/////analysis.tuple (list bodyA))) + )))))) + +(type: #export (Virtual-Method a) + [Text + Visibility + Finality + Strictness + (List (Annotation a)) + (List Var) + Text + (List Argument) + Return + (List Class) ## Exceptions + a]) + +(def: virtual-tag "virtual") + +(def: #export virtual-method-definition + (Parser (Virtual-Method Code)) + (<| .form + (<>.after (.text! ..virtual-tag)) + ($_ <>.and + .text + ..visibility + .bit + .bit + (.tuple (<>.some ..annotation)) + (.tuple (<>.some ..var)) + .text + (.tuple (<>.some ..argument)) + ..return + (.tuple (<>.some ..class)) + .any))) + +(def: #export (analyse-virtual-method analyse selfT mapping method) + (-> Phase .Type Mapping (Virtual-Method Code) (Operation Analysis)) + (let [[method-name visibility + final? strict-fp? annotations vars + self-name arguments return exceptions + body] method] + (do ////.monad + [annotationsA (monad.map @ (function (_ [name parameters]) + (do @ + [parametersA (monad.map @ (function (_ [name value]) + (do @ + [valueA (analyse value)] + (wrap [name valueA]))) + parameters)] + (wrap [name parametersA]))) + annotations) + returnT (typeA.with-env + (luxT.return mapping return)) + arguments' (typeA.with-env + (monad.map check.monad + (function (_ [name jvmT]) + (do check.monad + [luxT (luxT.type mapping jvmT)] + (wrap [name luxT]))) + arguments)) + [scope bodyA] (|> arguments' + (#.Cons [self-name selfT]) + list.reverse + (list@fold scope.with-local (analyse body)) + (typeA.with-type returnT) + /////analysis.with-scope)] + (wrap (/////analysis.tuple (list (/////analysis.text ..virtual-tag) + (/////analysis.text method-name) + (/////analysis.text (case visibility + #PublicV ..public-tag + #PrivateV ..private-tag + #ProtectedV ..protected-tag + #DefaultV ..default-tag)) + (/////analysis.bit final?) + (/////analysis.bit strict-fp?) + (/////analysis.tuple (list@map annotation-analysis annotationsA)) + (/////analysis.tuple (list@map var-analysis vars)) + (/////analysis.text self-name) + (/////analysis.tuple (list@map (function (_ [argument argumentJT]) + (/////analysis.tuple + (list (/////analysis.text argument) + (type-analysis argumentJT)))) + arguments)) + (return-analysis return) + (/////analysis.tuple (list@map class-analysis + exceptions)) + (#/////analysis.Function + (scope.environment scope) + (/////analysis.tuple (list bodyA))) + )))))) + +(type: #export (Static-Method a) + [Text + Visibility + Strictness + (List (Annotation a)) + (List Var) + (List Class) ## Exceptions + (List Argument) + Return + a]) + +(def: #export static-tag "static") + +(def: #export static-method-definition + (Parser (Static-Method Code)) + (<| .form + (<>.after (.text! ..static-tag)) + ($_ <>.and + .text + ..visibility + .bit + (.tuple (<>.some ..annotation)) + (.tuple (<>.some ..var)) + (.tuple (<>.some ..class)) + (.tuple (<>.some ..argument)) + ..return + .any))) + +(def: #export (analyse-static-method analyse mapping method) + (-> Phase Mapping (Static-Method Code) (Operation Analysis)) + (let [[method-name visibility + strict-fp? annotations vars exceptions + arguments return + body] method] + (do ////.monad + [annotationsA (monad.map @ (function (_ [name parameters]) + (do @ + [parametersA (monad.map @ (function (_ [name value]) + (do @ + [valueA (analyse value)] + (wrap [name valueA]))) + parameters)] + (wrap [name parametersA]))) + annotations) + returnT (typeA.with-env + (luxT.return mapping return)) + arguments' (typeA.with-env + (monad.map check.monad + (function (_ [name jvmT]) + (do check.monad + [luxT (luxT.type mapping jvmT)] + (wrap [name luxT]))) + arguments)) + [scope bodyA] (|> arguments' + list.reverse + (list@fold scope.with-local (analyse body)) + (typeA.with-type returnT) + /////analysis.with-scope)] + (wrap (/////analysis.tuple (list (/////analysis.text ..static-tag) + (/////analysis.text method-name) + (/////analysis.text (case visibility + #PublicV ..public-tag + #PrivateV ..private-tag + #ProtectedV ..protected-tag + #DefaultV ..default-tag)) + (/////analysis.bit strict-fp?) + (/////analysis.tuple (list@map annotation-analysis annotationsA)) + (/////analysis.tuple (list@map var-analysis vars)) + (/////analysis.tuple (list@map (function (_ [argument argumentJT]) + (/////analysis.tuple + (list (/////analysis.text argument) + (type-analysis argumentJT)))) + arguments)) + (return-analysis return) + (/////analysis.tuple (list@map class-analysis + exceptions)) + (#/////analysis.Function + (scope.environment scope) + (/////analysis.tuple (list bodyA))) + )))))) + +(type: #export (Overriden-Method a) + [Class + Text + Bit + (List (Annotation a)) + (List Var) + Text + (List Argument) + Return + (List Class) + a]) + +(def: #export overriden-tag "override") + +(def: #export overriden-method-definition + (Parser (Overriden-Method Code)) + (<| .form + (<>.after (.text! ..overriden-tag)) + ($_ <>.and + ..class + .text + .bit + (.tuple (<>.some ..annotation)) + (.tuple (<>.some ..var)) + .text + (.tuple (<>.some ..argument)) + ..return + (.tuple (<>.some ..class)) + .any + ))) + +(def: #export (analyse-overriden-method analyse selfT mapping method) + (-> Phase .Type Mapping (Overriden-Method Code) (Operation Analysis)) + (let [[parent-type method-name + strict-fp? annotations vars + self-name arguments return exceptions + body] method] + (do ////.monad + [annotationsA (monad.map @ (function (_ [name parameters]) + (do @ + [parametersA (monad.map @ (function (_ [name value]) + (do @ + [valueA (analyse value)] + (wrap [name valueA]))) + parameters)] + (wrap [name parametersA]))) + annotations) + returnT (typeA.with-env + (luxT.return mapping return)) + arguments' (typeA.with-env + (monad.map check.monad + (function (_ [name jvmT]) + (do check.monad + [luxT (luxT.type mapping jvmT)] + (wrap [name luxT]))) + arguments)) + [scope bodyA] (|> arguments' + (#.Cons [self-name selfT]) + list.reverse + (list@fold scope.with-local (analyse body)) + (typeA.with-type returnT) + /////analysis.with-scope)] + (wrap (/////analysis.tuple (list (/////analysis.text ..overriden-tag) + (class-analysis parent-type) + (/////analysis.text method-name) + (/////analysis.bit strict-fp?) + (/////analysis.tuple (list@map annotation-analysis annotationsA)) + (/////analysis.tuple (list@map var-analysis vars)) + (/////analysis.text self-name) + (/////analysis.tuple (list@map (function (_ [argument argumentJT]) + (/////analysis.tuple + (list (/////analysis.text argument) + (type-analysis argumentJT)))) + arguments)) + (return-analysis return) + (/////analysis.tuple (list@map class-analysis + exceptions)) + (#/////analysis.Function + (scope.environment scope) + (/////analysis.tuple (list bodyA))) + )))))) + +(type: #export (Method-Definition a) + (#Overriden-Method (Overriden-Method a))) + (def: class::anonymous Handler (..custom - [($_ p.and + [($_ <>.and ..class - (s.tuple (p.some ..class)) - (s.tuple (p.some ..typed)) - (s.tuple (p.some ..overriden-method-definition))) + (.tuple (<>.some ..class)) + (.tuple (<>.some ..typed)) + (.tuple (<>.some ..overriden-method-definition))) (function (_ extension-name analyse [super-class super-interfaces constructor-args @@ -1515,55 +1847,7 @@ (analyse term))] (wrap [type termA]))) constructor-args) - methodsA (monad.map @ (function (_ [parent-type method-name - strict-fp? annotations vars - self-name arguments return exceptions - body]) - - (do @ - [annotationsA (monad.map @ (function (_ [name parameters]) - (do @ - [parametersA (monad.map @ (function (_ [name value]) - (do @ - [valueA (analyse value)] - (wrap [name valueA]))) - parameters)] - (wrap [name parametersA]))) - annotations) - returnT (typeA.with-env - (luxT.return luxT.fresh return)) - arguments' (typeA.with-env - (monad.map check.monad - (function (_ [name jvmT]) - (do check.monad - [luxT (luxT.type luxT.fresh jvmT)] - (wrap [name luxT]))) - arguments)) - [scope bodyA] (|> arguments' - (#.Cons [self-name selfT]) - list.reverse - (list@fold scope.with-local (analyse body)) - (typeA.with-type returnT) - /////analysis.with-scope)] - (wrap (/////analysis.tuple (list (class-analysis parent-type) - (/////analysis.text method-name) - (/////analysis.bit strict-fp?) - (/////analysis.tuple (list@map annotation-analysis annotationsA)) - (/////analysis.tuple (list@map var-analysis vars)) - (/////analysis.text self-name) - (/////analysis.tuple (list@map (function (_ [argument argumentJT]) - (/////analysis.tuple - (list (/////analysis.text argument) - (type-analysis argumentJT)))) - arguments)) - (return-analysis return) - (/////analysis.tuple (list@map class-analysis - exceptions)) - (#/////analysis.Function - (scope.environment scope) - (/////analysis.tuple (list bodyA))) - ))))) - methods) + methodsA (monad.map @ (analyse-overriden-method analyse selfT luxT.fresh) methods) required-abstract-methods (////.lift (all-abstract-methods (list& super-class super-interfaces))) available-methods (////.lift (all-methods (list& super-class super-interfaces))) #let [overriden-methods (list@map (function (_ [parent-type method-name diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/lux.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/lux.lux new file mode 100644 index 000000000..51402fad8 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/lux.lux @@ -0,0 +1,285 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + [io (#+ IO)] + ["." exception (#+ exception:)] + ["<>" parser + ["" code (#+ Parser)]]] + [data + ["." maybe] + ["." error] + ["." text + format] + [collection + ["." list ("#@." functor)] + ["." dictionary (#+ Dictionary)]]] + [type + ["." check]] + ["." macro]] + ["." /// + ["#." bundle] + ["#/" // + [analysis + [".A" type] + [".A" case] + [".A" function]] + ["#/" // + [default + [evaluation (#+ Eval)]] + ["#." analysis (#+ Analysis Operation Phase Handler Bundle)]]]]) + +(def: #export (custom [syntax handler]) + (All [s] + (-> [(Parser s) + (-> Text Phase s (Operation Analysis))] + Handler)) + (function (_ extension-name analyse args) + (case (.run syntax args) + (#error.Success inputs) + (handler extension-name analyse inputs) + + (#error.Failure error) + (/////analysis.throw ///.invalid-syntax [extension-name %code args])))) + +(def: (simple inputsT+ outputT) + (-> (List Type) Type Handler) + (let [num-expected (list.size inputsT+)] + (function (_ extension-name analyse args) + (let [num-actual (list.size args)] + (if (n/= num-expected num-actual) + (do ////.monad + [_ (typeA.infer outputT) + argsA (monad.map @ + (function (_ [argT argC]) + (typeA.with-type argT + (analyse argC))) + (list.zip2 inputsT+ args))] + (wrap (#/////analysis.Extension extension-name argsA))) + (/////analysis.throw ///.incorrect-arity [extension-name num-expected num-actual])))))) + +(def: #export (nullary valueT) + (-> Type Handler) + (simple (list) valueT)) + +(def: #export (unary inputT outputT) + (-> Type Type Handler) + (simple (list inputT) outputT)) + +(def: #export (binary subjectT paramT outputT) + (-> Type Type Type Handler) + (simple (list subjectT paramT) outputT)) + +(def: #export (trinary subjectT param0T param1T outputT) + (-> Type Type Type Type Handler) + (simple (list subjectT param0T param1T) outputT)) + +## TODO: Get rid of this ASAP +(as-is + (exception: #export (char-text-must-be-size-1 {text Text}) + (exception.report + ["Text" (%t text)])) + + (def: text-char + (Parser text.Char) + (do <>.monad + [raw .text] + (case (text.size raw) + 1 (wrap (|> raw (text.nth 0) maybe.assume)) + _ (<>.fail (exception.construct ..char-text-must-be-size-1 [raw]))))) + + (def: lux::syntax-char-case! + (..custom [($_ <>.and + .any + (.tuple (<>.some (<>.and (.tuple (<>.many ..text-char)) + .any))) + .any) + (function (_ extension-name phase [input conditionals else]) + (do ////.monad + [input (typeA.with-type text.Char + (phase input)) + expectedT (///.lift macro.expected-type) + conditionals (monad.map @ (function (_ [cases branch]) + (do @ + [branch (typeA.with-type expectedT + (phase branch))] + (wrap [cases branch]))) + conditionals) + else (typeA.with-type expectedT + (phase else))] + (wrap (|> conditionals + (list@map (function (_ [cases branch]) + (/////analysis.tuple + (list (/////analysis.tuple (list@map (|>> /////analysis.nat) cases)) + branch)))) + (list& input else) + (#/////analysis.Extension extension-name)))))]))) + +## "lux is" represents reference/pointer equality. +(def: lux::is + Handler + (function (_ extension-name analyse args) + (do ////.monad + [[var-id varT] (typeA.with-env check.var)] + ((binary varT varT Bit extension-name) + analyse args)))) + +## "lux try" provides a simple way to interact with the host platform's +## error-handling facilities. +(def: lux::try + Handler + (function (_ extension-name analyse args) + (case args + (^ (list opC)) + (do ////.monad + [[var-id varT] (typeA.with-env check.var) + _ (typeA.infer (type (Either Text varT))) + opA (typeA.with-type (type (IO varT)) + (analyse opC))] + (wrap (#/////analysis.Extension extension-name (list opA)))) + + _ + (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: lux::in-module + Handler + (function (_ extension-name analyse argsC+) + (case argsC+ + (^ (list [_ (#.Text module-name)] exprC)) + (/////analysis.with-current-module module-name + (analyse exprC)) + + _ + (/////analysis.throw ///.invalid-syntax [extension-name %code argsC+])))) + +(def: (lux::check eval) + (-> Eval Handler) + (function (_ extension-name analyse args) + (case args + (^ (list typeC valueC)) + (do ////.monad + [count (///.lift macro.count) + actualT (:: @ map (|>> (:coerce Type)) + (eval count Type typeC)) + _ (typeA.infer actualT)] + (typeA.with-type actualT + (analyse valueC))) + + _ + (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) + +(def: (lux::coerce eval) + (-> Eval Handler) + (function (_ extension-name analyse args) + (case args + (^ (list typeC valueC)) + (do ////.monad + [count (///.lift macro.count) + actualT (:: @ map (|>> (:coerce Type)) + (eval count Type typeC)) + _ (typeA.infer actualT) + [valueT valueA] (typeA.with-inference + (analyse valueC))] + (wrap valueA)) + + _ + (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) + +(def: (caster input output) + (-> Type Type Handler) + (function (_ extension-name analyse args) + (case args + (^ (list valueC)) + (do ////.monad + [_ (typeA.infer output)] + (typeA.with-type input + (analyse valueC))) + + _ + (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: (bundle::lux eval) + (-> Eval Bundle) + (|> ///bundle.empty + (///bundle.install "syntax char case!" lux::syntax-char-case!) + (///bundle.install "is" lux::is) + (///bundle.install "try" lux::try) + (///bundle.install "check" (lux::check eval)) + (///bundle.install "coerce" (lux::coerce eval)) + (///bundle.install "macro" (..caster .Macro' .Macro)) + (///bundle.install "check type" (..caster .Type .Type)) + (///bundle.install "in-module" lux::in-module))) + +(def: bundle::io + Bundle + (<| (///bundle.prefix "io") + (|> ///bundle.empty + (///bundle.install "log" (unary Text Any)) + (///bundle.install "error" (unary Text Nothing)) + (///bundle.install "exit" (unary Int Nothing)) + (///bundle.install "current-time" (nullary Int))))) + +(def: I64* (type (I64 Any))) + +(def: bundle::i64 + Bundle + (<| (///bundle.prefix "i64") + (|> ///bundle.empty + (///bundle.install "and" (binary I64* I64* I64)) + (///bundle.install "or" (binary I64* I64* I64)) + (///bundle.install "xor" (binary I64* I64* I64)) + (///bundle.install "left-shift" (binary Nat I64* I64)) + (///bundle.install "logical-right-shift" (binary Nat I64* I64)) + (///bundle.install "arithmetic-right-shift" (binary Nat I64* I64)) + (///bundle.install "=" (binary I64* I64* Bit)) + (///bundle.install "<" (binary Int Int Bit)) + (///bundle.install "+" (binary I64* I64* I64)) + (///bundle.install "-" (binary I64* I64* I64)) + (///bundle.install "*" (binary Int Int Int)) + (///bundle.install "/" (binary Int Int Int)) + (///bundle.install "%" (binary Int Int Int)) + (///bundle.install "f64" (unary Int Frac)) + (///bundle.install "char" (unary Int Text))))) + +(def: bundle::f64 + Bundle + (<| (///bundle.prefix "f64") + (|> ///bundle.empty + (///bundle.install "+" (binary Frac Frac Frac)) + (///bundle.install "-" (binary Frac Frac Frac)) + (///bundle.install "*" (binary Frac Frac Frac)) + (///bundle.install "/" (binary Frac Frac Frac)) + (///bundle.install "%" (binary Frac Frac Frac)) + (///bundle.install "=" (binary Frac Frac Bit)) + (///bundle.install "<" (binary Frac Frac Bit)) + (///bundle.install "smallest" (nullary Frac)) + (///bundle.install "min" (nullary Frac)) + (///bundle.install "max" (nullary Frac)) + (///bundle.install "i64" (unary Frac Int)) + (///bundle.install "encode" (unary Frac Text)) + (///bundle.install "decode" (unary Text (type (Maybe Frac))))))) + +(def: bundle::text + Bundle + (<| (///bundle.prefix "text") + (|> ///bundle.empty + (///bundle.install "=" (binary Text Text Bit)) + (///bundle.install "<" (binary Text Text Bit)) + (///bundle.install "concat" (binary Text Text Text)) + (///bundle.install "index" (trinary Nat Text Text (type (Maybe Nat)))) + (///bundle.install "size" (unary Text Nat)) + (///bundle.install "char" (binary Nat Text Nat)) + (///bundle.install "clip" (trinary Nat Nat Text Text)) + ))) + +(def: #export (bundle eval) + (-> Eval Bundle) + (<| (///bundle.prefix "lux") + (|> ///bundle.empty + (dictionary.merge (bundle::lux eval)) + (dictionary.merge bundle::i64) + (dictionary.merge bundle::f64) + (dictionary.merge bundle::text) + (dictionary.merge bundle::io) + ))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/statement.lux b/stdlib/source/lux/tool/compiler/phase/extension/statement.lux deleted file mode 100644 index 992d5a932..000000000 --- a/stdlib/source/lux/tool/compiler/phase/extension/statement.lux +++ /dev/null @@ -1,347 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - [io (#+ IO)] - ["." exception (#+ exception:)] - ["p" parser - ["s" code (#+ Parser)]]] - [data - ["." product] - ["." maybe] - ["." error] - [text - format] - [collection - ["." list ("#;." functor)] - ["." dictionary]]] - ["." macro - ["." code]] - ["." type (#+ :share :by-example) ("#@." equivalence) - ["." check]]] - ["." // - ["#." bundle] - ["#." analysis] - ["#/" // - ["#." macro (#+ Expander)] - ["#." generation] - [analysis - ["." module] - [".A" type]] - ["#/" // #_ - ["#." analysis] - ["#." synthesis (#+ Synthesis)] - ["#." statement (#+ Import Requirements Phase Operation Handler Bundle)] - [default - ["#." evaluation]]]]]) - -## TODO: Inline "evaluate!'" into "evaluate!" ASAP -(def: (evaluate!' generate code//type codeS) - (All [anchor expression statement] - (-> (///generation.Phase anchor expression statement) - Type - Synthesis - (Operation anchor expression statement [Type expression Any]))) - (////statement.lift-generation - (do ///.monad - [codeT (generate codeS) - count ///generation.next - codeV (///generation.evaluate! (format "evaluate" (%n count)) codeT)] - (wrap [code//type codeT codeV])))) - -(def: (evaluate! type codeC) - (All [anchor expression statement] - (-> Type Code (Operation anchor expression statement [Type expression Any]))) - (do ///.monad - [state (//.lift ///.get-state) - #let [analyse (get@ [#////statement.analysis #////statement.phase] state) - synthesize (get@ [#////statement.synthesis #////statement.phase] state) - generate (get@ [#////statement.generation #////statement.phase] state)] - [_ codeA] (////statement.lift-analysis - (////analysis.with-scope - (typeA.with-fresh-env - (typeA.with-type type - (analyse codeC))))) - codeS (////statement.lift-synthesis - (synthesize codeA))] - (evaluate!' generate type codeS))) - -## TODO: Inline "definition'" into "definition" ASAP -(def: (definition' generate name code//type codeS) - (All [anchor expression statement] - (-> (///generation.Phase anchor expression statement) - Name - Type - Synthesis - (Operation anchor expression statement [Type expression Text Any]))) - (////statement.lift-generation - (do ///.monad - [codeT (generate codeS) - [target-name value statement] (///generation.define! name codeT) - _ (///generation.save! false name statement)] - (wrap [code//type codeT target-name value])))) - -(def: (definition name expected codeC) - (All [anchor expression statement] - (-> Name (Maybe Type) Code - (Operation anchor expression statement [Type expression Text Any]))) - (do ///.monad - [state (//.lift ///.get-state) - #let [analyse (get@ [#////statement.analysis #////statement.phase] state) - synthesize (get@ [#////statement.synthesis #////statement.phase] state) - generate (get@ [#////statement.generation #////statement.phase] state)] - [_ code//type codeA] (////statement.lift-analysis - (////analysis.with-scope - (typeA.with-fresh-env - (case expected - #.None - (do @ - [[code//type codeA] (typeA.with-inference (analyse codeC)) - code//type (typeA.with-env - (check.clean code//type))] - (wrap [code//type codeA])) - - (#.Some expected) - (do @ - [codeA (typeA.with-type expected - (analyse codeC))] - (wrap [expected codeA])))))) - codeS (////statement.lift-synthesis - (synthesize codeA))] - (definition' generate name code//type codeS))) - -(def: (refresh expander) - (All [anchor expression statement] - (-> Expander (Operation anchor expression statement Any))) - (do ///.monad - [[bundle state] ///.get-state - #let [eval (////evaluation.evaluator expander - (get@ [#////statement.synthesis #////statement.state] state) - (get@ [#////statement.generation #////statement.state] state) - (get@ [#////statement.generation #////statement.phase] state))]] - (///.set-state [bundle - (update@ [#////statement.analysis #////statement.state] - (: (-> ////analysis.State+ ////analysis.State+) - (|>> product.right - [(//analysis.bundle eval)])) - state)]))) - -(def: (lux::def expander) - (-> Expander Handler) - (function (_ extension-name phase inputsC+) - (case inputsC+ - (^ (list [_ (#.Identifier ["" short-name])] valueC annotationsC [_ (#.Bit exported?)])) - (do ///.monad - [current-module (////statement.lift-analysis - (//.lift macro.current-module-name)) - #let [full-name [current-module short-name]] - [_ annotationsT annotations] (evaluate! Code annotationsC) - #let [annotations (:coerce Code annotations)] - [type valueT valueN value] (..definition full-name #.None valueC) - _ (////statement.lift-analysis - (module.define short-name (#.Right [exported? type annotations value]))) - #let [_ (log! (format "Definition " (%name full-name)))] - _ (////statement.lift-generation - (///generation.learn full-name valueN)) - _ (..refresh expander)] - (wrap ////statement.no-requirements)) - - _ - (///.throw //.invalid-syntax [extension-name %code inputsC+])))) - -(def: (custom [syntax handler]) - (All [anchor expression statement s] - (-> [(Parser s) - (-> Text - (Phase anchor expression statement) - s - (Operation anchor expression statement Requirements))] - (Handler anchor expression statement))) - (function (_ extension-name phase inputs) - (case (s.run syntax inputs) - (#error.Success inputs) - (handler extension-name phase inputs) - - (#error.Failure error) - (///.throw //.invalid-syntax [extension-name %code inputs])))) - -(def: (def::type-tagged expander) - (-> Expander Handler) - (..custom - [($_ p.and s.local-identifier s.any s.any (s.tuple (p.some s.text)) s.bit) - (function (_ extension-name phase [short-name valueC annotationsC tags exported?]) - (do ///.monad - [current-module (////statement.lift-analysis - (//.lift macro.current-module-name)) - #let [full-name [current-module short-name]] - [_ annotationsT annotations] (evaluate! Code annotationsC) - #let [annotations (:coerce Code annotations)] - [type valueT valueN value] (..definition full-name (#.Some .Type) valueC) - _ (////statement.lift-analysis - (do ///.monad - [_ (module.define short-name (#.Right [exported? type annotations value]))] - (module.declare-tags tags exported? (:coerce Type value)))) - #let [_ (log! (format "Definition " (%name full-name)))] - _ (////statement.lift-generation - (///generation.learn full-name valueN)) - _ (..refresh expander)] - (wrap ////statement.no-requirements)))])) - -(def: imports - (Parser (List Import)) - (|> (s.tuple (p.and s.text s.text)) - p.some - s.tuple)) - -(def: def::module - Handler - (..custom - [($_ p.and s.any ..imports) - (function (_ extension-name phase [annotationsC imports]) - (do ///.monad - [[_ annotationsT annotationsV] (evaluate! Code annotationsC) - #let [annotationsV (:coerce Code annotationsV)] - _ (////statement.lift-analysis - (do @ - [_ (monad.map @ (function (_ [module alias]) - (do @ - [_ (module.import module)] - (case alias - "" (wrap []) - _ (module.alias alias module)))) - imports)] - (module.set-annotations annotationsV)))] - (wrap {#////statement.imports imports - #////statement.referrals (list)})))])) - -(exception: #export (cannot-alias-an-alias {local Alias} {foreign Alias} {target Name}) - (exception.report - ["Local alias" (%name local)] - ["Foreign alias" (%name foreign)] - ["Target definition" (%name target)])) - -(def: (define-alias alias original) - (-> Text Name (////analysis.Operation Any)) - (do ///.monad - [current-module (//.lift macro.current-module-name) - constant (//.lift (macro.find-def original))] - (case constant - (#.Left de-aliased) - (///.throw ..cannot-alias-an-alias [[current-module alias] original de-aliased]) - - (#.Right [exported? original-type original-annotations original-value]) - (module.define alias (#.Left original))))) - -(def: def::alias - Handler - (..custom - [($_ p.and s.local-identifier s.identifier) - (function (_ extension-name phase [alias def-name]) - (do ///.monad - [_ (//.lift - (///.sub [(get@ [#////statement.analysis #////statement.state]) - (set@ [#////statement.analysis #////statement.state])] - (define-alias alias def-name)))] - (wrap ////statement.no-requirements)))])) - -(template [ ] - [(def: - (All [anchor expression statement] - (Handler anchor expression statement)) - (function (handler extension-name phase inputsC+) - (case inputsC+ - (^ (list [_ (#.Text name)] valueC)) - (do ///.monad - [[_ handlerT handlerV] (evaluate! (:by-example [anchor expression statement] - {(Handler anchor expression statement) - handler} - ) - valueC) - _ (<| - (//.install name) - (:share [anchor expression statement] - {(Handler anchor expression statement) - handler} - { - (:assume handlerV)}))] - (wrap ////statement.no-requirements)) - - _ - (///.throw //.invalid-syntax [extension-name %code inputsC+]))))] - - [def::analysis ////analysis.Handler ////statement.lift-analysis] - [def::synthesis ////synthesis.Handler ////statement.lift-synthesis] - [def::generation (///generation.Handler anchor expression statement) ////statement.lift-generation] - [def::statement (////statement.Handler anchor expression statement) (<|)] - ) - -## TODO; Both "prepare-program" and "define-program" exist only -## because the old compiler couldn"t handle a fully-inlined definition -## for "def::program". Inline them ASAP. -(def: (prepare-program analyse synthesize programC) - (All [anchor expression statement output] - (-> ////analysis.Phase - ////synthesis.Phase - Code - (Operation anchor expression statement Synthesis))) - (do ///.monad - [[_ programA] (////statement.lift-analysis - (////analysis.with-scope - (typeA.with-fresh-env - (typeA.with-type (type (-> (List Text) (IO Any))) - (analyse programC)))))] - (////statement.lift-synthesis - (synthesize programA)))) - -(def: (define-program generate program programS) - (All [anchor expression statement output] - (-> (///generation.Phase anchor expression statement) - (-> expression statement) - Synthesis - (///generation.Operation anchor expression statement Any))) - (do ///.monad - [programG (generate programS)] - (///generation.save! false ["" ""] (program programG)))) - -(def: (def::program program) - (All [anchor expression statement] - (-> (-> expression statement) (Handler anchor expression statement))) - (function (handler extension-name phase inputsC+) - (case inputsC+ - (^ (list programC)) - (do ///.monad - [state (//.lift ///.get-state) - #let [analyse (get@ [#////statement.analysis #////statement.phase] state) - synthesize (get@ [#////statement.synthesis #////statement.phase] state) - generate (get@ [#////statement.generation #////statement.phase] state)] - programS (prepare-program analyse synthesize programC) - _ (////statement.lift-generation - (define-program generate program programS))] - (wrap ////statement.no-requirements)) - - _ - (///.throw //.invalid-syntax [extension-name %code inputsC+])))) - -(def: (bundle::def expander program) - (All [anchor expression statement] - (-> Expander (-> expression statement) (Bundle anchor expression statement))) - (<| (//bundle.prefix "def") - (|> //bundle.empty - (dictionary.put "module" def::module) - (dictionary.put "alias" def::alias) - (dictionary.put "type tagged" (def::type-tagged expander)) - (dictionary.put "analysis" def::analysis) - (dictionary.put "synthesis" def::synthesis) - (dictionary.put "generation" def::generation) - (dictionary.put "statement" def::statement) - (dictionary.put "program" (def::program program)) - ))) - -(def: #export (bundle expander program) - (All [anchor expression statement] - (-> Expander (-> expression statement) (Bundle anchor expression statement))) - (<| (//bundle.prefix "lux") - (|> //bundle.empty - (dictionary.put "def" (lux::def expander)) - (dictionary.merge (..bundle::def expander program))))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/statement/lux.lux b/stdlib/source/lux/tool/compiler/phase/extension/statement/lux.lux new file mode 100644 index 000000000..0ae210fa5 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/statement/lux.lux @@ -0,0 +1,347 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + [io (#+ IO)] + ["." exception (#+ exception:)] + ["p" parser + ["s" code (#+ Parser)]]] + [data + ["." product] + ["." maybe] + ["." error] + [text + format] + [collection + ["." list ("#;." functor)] + ["." dictionary]]] + ["." macro + ["." code]] + ["." type (#+ :share :by-example) ("#@." equivalence) + ["." check]]] + ["." /// + ["#." bundle] + ["#." analysis] + ["#/" // + ["#." macro (#+ Expander)] + ["#." generation] + [analysis + ["." module] + [".A" type]] + ["#/" // #_ + ["#." analysis] + ["#." synthesis (#+ Synthesis)] + ["#." statement (#+ Import Requirements Phase Operation Handler Bundle)] + [default + ["#." evaluation]]]]]) + +(def: #export (custom [syntax handler]) + (All [anchor expression statement s] + (-> [(Parser s) + (-> Text + (Phase anchor expression statement) + s + (Operation anchor expression statement Requirements))] + (Handler anchor expression statement))) + (function (_ extension-name phase inputs) + (case (s.run syntax inputs) + (#error.Success inputs) + (handler extension-name phase inputs) + + (#error.Failure error) + (////.throw ///.invalid-syntax [extension-name %code inputs])))) + +## TODO: Inline "evaluate!'" into "evaluate!" ASAP +(def: (evaluate!' generate code//type codeS) + (All [anchor expression statement] + (-> (////generation.Phase anchor expression statement) + Type + Synthesis + (Operation anchor expression statement [Type expression Any]))) + (/////statement.lift-generation + (do ////.monad + [codeT (generate codeS) + count ////generation.next + codeV (////generation.evaluate! (format "evaluate" (%n count)) codeT)] + (wrap [code//type codeT codeV])))) + +(def: (evaluate! type codeC) + (All [anchor expression statement] + (-> Type Code (Operation anchor expression statement [Type expression Any]))) + (do ////.monad + [state (///.lift ////.get-state) + #let [analyse (get@ [#/////statement.analysis #/////statement.phase] state) + synthesize (get@ [#/////statement.synthesis #/////statement.phase] state) + generate (get@ [#/////statement.generation #/////statement.phase] state)] + [_ codeA] (/////statement.lift-analysis + (/////analysis.with-scope + (typeA.with-fresh-env + (typeA.with-type type + (analyse codeC))))) + codeS (/////statement.lift-synthesis + (synthesize codeA))] + (evaluate!' generate type codeS))) + +## TODO: Inline "definition'" into "definition" ASAP +(def: (definition' generate name code//type codeS) + (All [anchor expression statement] + (-> (////generation.Phase anchor expression statement) + Name + Type + Synthesis + (Operation anchor expression statement [Type expression Text Any]))) + (/////statement.lift-generation + (do ////.monad + [codeT (generate codeS) + [target-name value statement] (////generation.define! name codeT) + _ (////generation.save! false name statement)] + (wrap [code//type codeT target-name value])))) + +(def: (definition name expected codeC) + (All [anchor expression statement] + (-> Name (Maybe Type) Code + (Operation anchor expression statement [Type expression Text Any]))) + (do ////.monad + [state (///.lift ////.get-state) + #let [analyse (get@ [#/////statement.analysis #/////statement.phase] state) + synthesize (get@ [#/////statement.synthesis #/////statement.phase] state) + generate (get@ [#/////statement.generation #/////statement.phase] state)] + [_ code//type codeA] (/////statement.lift-analysis + (/////analysis.with-scope + (typeA.with-fresh-env + (case expected + #.None + (do @ + [[code//type codeA] (typeA.with-inference (analyse codeC)) + code//type (typeA.with-env + (check.clean code//type))] + (wrap [code//type codeA])) + + (#.Some expected) + (do @ + [codeA (typeA.with-type expected + (analyse codeC))] + (wrap [expected codeA])))))) + codeS (/////statement.lift-synthesis + (synthesize codeA))] + (definition' generate name code//type codeS))) + +(def: (refresh expander) + (All [anchor expression statement] + (-> Expander (Operation anchor expression statement Any))) + (do ////.monad + [[bundle state] ////.get-state + #let [eval (/////evaluation.evaluator expander + (get@ [#/////statement.synthesis #/////statement.state] state) + (get@ [#/////statement.generation #/////statement.state] state) + (get@ [#/////statement.generation #/////statement.phase] state))]] + (////.set-state [bundle + (update@ [#/////statement.analysis #/////statement.state] + (: (-> /////analysis.State+ /////analysis.State+) + (|>> product.right + [(///analysis.bundle eval)])) + state)]))) + +(def: (lux::def expander) + (-> Expander Handler) + (function (_ extension-name phase inputsC+) + (case inputsC+ + (^ (list [_ (#.Identifier ["" short-name])] valueC annotationsC [_ (#.Bit exported?)])) + (do ////.monad + [current-module (/////statement.lift-analysis + (///.lift macro.current-module-name)) + #let [full-name [current-module short-name]] + [_ annotationsT annotations] (evaluate! Code annotationsC) + #let [annotations (:coerce Code annotations)] + [type valueT valueN value] (..definition full-name #.None valueC) + _ (/////statement.lift-analysis + (module.define short-name (#.Right [exported? type annotations value]))) + #let [_ (log! (format "Definition " (%name full-name)))] + _ (/////statement.lift-generation + (////generation.learn full-name valueN)) + _ (..refresh expander)] + (wrap /////statement.no-requirements)) + + _ + (////.throw ///.invalid-syntax [extension-name %code inputsC+])))) + +(def: (def::type-tagged expander) + (-> Expander Handler) + (..custom + [($_ p.and s.local-identifier s.any s.any (s.tuple (p.some s.text)) s.bit) + (function (_ extension-name phase [short-name valueC annotationsC tags exported?]) + (do ////.monad + [current-module (/////statement.lift-analysis + (///.lift macro.current-module-name)) + #let [full-name [current-module short-name]] + [_ annotationsT annotations] (evaluate! Code annotationsC) + #let [annotations (:coerce Code annotations)] + [type valueT valueN value] (..definition full-name (#.Some .Type) valueC) + _ (/////statement.lift-analysis + (do ////.monad + [_ (module.define short-name (#.Right [exported? type annotations value]))] + (module.declare-tags tags exported? (:coerce Type value)))) + #let [_ (log! (format "Definition " (%name full-name)))] + _ (/////statement.lift-generation + (////generation.learn full-name valueN)) + _ (..refresh expander)] + (wrap /////statement.no-requirements)))])) + +(def: imports + (Parser (List Import)) + (|> (s.tuple (p.and s.text s.text)) + p.some + s.tuple)) + +(def: def::module + Handler + (..custom + [($_ p.and s.any ..imports) + (function (_ extension-name phase [annotationsC imports]) + (do ////.monad + [[_ annotationsT annotationsV] (evaluate! Code annotationsC) + #let [annotationsV (:coerce Code annotationsV)] + _ (/////statement.lift-analysis + (do @ + [_ (monad.map @ (function (_ [module alias]) + (do @ + [_ (module.import module)] + (case alias + "" (wrap []) + _ (module.alias alias module)))) + imports)] + (module.set-annotations annotationsV)))] + (wrap {#/////statement.imports imports + #/////statement.referrals (list)})))])) + +(exception: #export (cannot-alias-an-alias {local Alias} {foreign Alias} {target Name}) + (exception.report + ["Local alias" (%name local)] + ["Foreign alias" (%name foreign)] + ["Target definition" (%name target)])) + +(def: (define-alias alias original) + (-> Text Name (/////analysis.Operation Any)) + (do ////.monad + [current-module (///.lift macro.current-module-name) + constant (///.lift (macro.find-def original))] + (case constant + (#.Left de-aliased) + (////.throw ..cannot-alias-an-alias [[current-module alias] original de-aliased]) + + (#.Right [exported? original-type original-annotations original-value]) + (module.define alias (#.Left original))))) + +(def: def::alias + Handler + (..custom + [($_ p.and s.local-identifier s.identifier) + (function (_ extension-name phase [alias def-name]) + (do ////.monad + [_ (///.lift + (////.sub [(get@ [#/////statement.analysis #/////statement.state]) + (set@ [#/////statement.analysis #/////statement.state])] + (define-alias alias def-name)))] + (wrap /////statement.no-requirements)))])) + +(template [ ] + [(def: + (All [anchor expression statement] + (Handler anchor expression statement)) + (function (handler extension-name phase inputsC+) + (case inputsC+ + (^ (list [_ (#.Text name)] valueC)) + (do ////.monad + [[_ handlerT handlerV] (evaluate! (:by-example [anchor expression statement] + {(Handler anchor expression statement) + handler} + ) + valueC) + _ (<| + (///.install name) + (:share [anchor expression statement] + {(Handler anchor expression statement) + handler} + { + (:assume handlerV)}))] + (wrap /////statement.no-requirements)) + + _ + (////.throw ///.invalid-syntax [extension-name %code inputsC+]))))] + + [def::analysis /////analysis.Handler /////statement.lift-analysis] + [def::synthesis /////synthesis.Handler /////statement.lift-synthesis] + [def::generation (////generation.Handler anchor expression statement) /////statement.lift-generation] + [def::statement (/////statement.Handler anchor expression statement) (<|)] + ) + +## TODO; Both "prepare-program" and "define-program" exist only +## because the old compiler couldn"t handle a fully-inlined definition +## for "def::program". Inline them ASAP. +(def: (prepare-program analyse synthesize programC) + (All [anchor expression statement output] + (-> /////analysis.Phase + /////synthesis.Phase + Code + (Operation anchor expression statement Synthesis))) + (do ////.monad + [[_ programA] (/////statement.lift-analysis + (/////analysis.with-scope + (typeA.with-fresh-env + (typeA.with-type (type (-> (List Text) (IO Any))) + (analyse programC)))))] + (/////statement.lift-synthesis + (synthesize programA)))) + +(def: (define-program generate program programS) + (All [anchor expression statement output] + (-> (////generation.Phase anchor expression statement) + (-> expression statement) + Synthesis + (////generation.Operation anchor expression statement Any))) + (do ////.monad + [programG (generate programS)] + (////generation.save! false ["" ""] (program programG)))) + +(def: (def::program program) + (All [anchor expression statement] + (-> (-> expression statement) (Handler anchor expression statement))) + (function (handler extension-name phase inputsC+) + (case inputsC+ + (^ (list programC)) + (do ////.monad + [state (///.lift ////.get-state) + #let [analyse (get@ [#/////statement.analysis #/////statement.phase] state) + synthesize (get@ [#/////statement.synthesis #/////statement.phase] state) + generate (get@ [#/////statement.generation #/////statement.phase] state)] + programS (prepare-program analyse synthesize programC) + _ (/////statement.lift-generation + (define-program generate program programS))] + (wrap /////statement.no-requirements)) + + _ + (////.throw ///.invalid-syntax [extension-name %code inputsC+])))) + +(def: (bundle::def expander program) + (All [anchor expression statement] + (-> Expander (-> expression statement) (Bundle anchor expression statement))) + (<| (///bundle.prefix "def") + (|> ///bundle.empty + (dictionary.put "module" def::module) + (dictionary.put "alias" def::alias) + (dictionary.put "type tagged" (def::type-tagged expander)) + (dictionary.put "analysis" def::analysis) + (dictionary.put "synthesis" def::synthesis) + (dictionary.put "generation" def::generation) + (dictionary.put "statement" def::statement) + (dictionary.put "program" (def::program program)) + ))) + +(def: #export (bundle expander program) + (All [anchor expression statement] + (-> Expander (-> expression statement) (Bundle anchor expression statement))) + (<| (///bundle.prefix "lux") + (|> ///bundle.empty + (dictionary.put "def" (lux::def expander)) + (dictionary.merge (..bundle::def expander program))))) diff --git a/stdlib/source/program/compositor.lux b/stdlib/source/program/compositor.lux index c39544019..7d058ec0e 100644 --- a/stdlib/source/program/compositor.lux +++ b/stdlib/source/program/compositor.lux @@ -78,11 +78,12 @@ (#error.Failure error) (:: io.monad wrap (#error.Failure error))))) -(def: #export (compiler expander platform bundle program service) +(def: #export (compiler expander platform generation-bundle host-statement-bundle program service) (All [anchor expression statement] (-> Expander (IO (Platform IO anchor expression statement)) (generation.Bundle anchor expression statement) + (statement.Bundle anchor expression statement) (-> expression statement) Service (IO Any))) @@ -97,7 +98,7 @@ {(Platform IO anchor expression statement) platform} {(IO (Error (statement.State+ anchor expression statement))) - (platform.initialize expander platform bundle program)}) + (platform.initialize expander platform generation-bundle host-statement-bundle program)}) [archive state] (:share [anchor expression statement] {(Platform IO anchor expression statement) platform} @@ -112,5 +113,5 @@ ## TODO: Fix the interpreter... (undefined) ## (<| (or-crash! "Interpretation failed:") - ## (interpreter.run (error.with io.monad) console platform configuration bundle)) + ## (interpreter.run (error.with io.monad) console platform configuration generation-bundle)) ))) diff --git a/stdlib/source/test/lux/host.jvm.lux b/stdlib/source/test/lux/host.jvm.lux index c9446b857..f142a1912 100644 --- a/stdlib/source/test/lux/host.jvm.lux +++ b/stdlib/source/test/lux/host.jvm.lux @@ -11,28 +11,32 @@ {1 ["." / (#+ import: class: interface: object)]}) -(import: (java/util/concurrent/Callable a)) +(import: #long (java/util/concurrent/Callable a)) -(import: java/lang/Exception - (new [String])) +(import: #long java/lang/String) -(import: java/lang/Object) +(import: #long java/lang/Exception + (new [java/lang/String])) -(import: (java/lang/Class a) - (getName [] String)) +(import: #long java/lang/Object) -(import: java/lang/System +(import: #long (java/lang/Class a) + (getName [] java/lang/String)) + +(import: #long java/lang/Runnable) + +(import: #long java/lang/System (#static out java/io/PrintStream) (#static currentTimeMillis [] #io long) - (#static getenv [String] #io #? String)) + (#static getenv [java/lang/String] #io #? java/lang/String)) -(class: #final (TestClass A) [Runnable] +(class: #final (TestClass A) [java/lang/Runnable] ## Fields (#private foo boolean) (#private bar A) (#private baz java/lang/Object) ## Methods - (#public [] (new {value A}) [] + (#public [] (new self {value A}) [] (exec (:= ::foo #1) (:= ::bar value) (:= ::baz "") @@ -41,23 +45,23 @@ "") (#public #static (static) java/lang/Object "") - (Runnable [] (run self) void - [])) + (java/lang/Runnable [] (run self) void + [])) (def: test-runnable - (object [] [Runnable] + (object [] [java/lang/Runnable] [] - (Runnable [] (run self) void - []))) + (java/lang/Runnable [] (run self) void + []))) (def: test-callable - (object [a] [(Callable a)] + (object [a] [(java/util/concurrent/Callable a)] [] - (Callable [] (call self) a - (undefined)))) + (java/util/concurrent/Callable [] (call self) a + (undefined)))) (interface: TestInterface - ([] foo [boolean String] void #throws [Exception])) + ([] foo [boolean java/lang/String] void #throws [java/lang/Exception])) (def: conversions Test @@ -85,26 +89,26 @@ [sample (r.ascii 1)] ($_ _.and (_.test "Can check if an object is of a certain class." - (and (case (/.check String sample) (#.Some _) true #.None false) - (case (/.check Long sample) (#.Some _) false #.None true) - (case (/.check Object sample) (#.Some _) true #.None false) - (case (/.check Object (/.null)) (#.Some _) false #.None true))) + (and (case (/.check java/lang/String sample) (#.Some _) true #.None false) + (case (/.check java/lang/Long sample) (#.Some _) false #.None true) + (case (/.check java/lang/Object sample) (#.Some _) true #.None false) + (case (/.check java/lang/Object (/.null)) (#.Some _) false #.None true))) (_.test "Can run code in a 'synchronized' block." (/.synchronized sample #1)) (_.test "Can access Class instances." - (text;= "java.lang.Class" (Class::getName (/.class-for java/lang/Class)))) + (text;= "java.lang.Class" (java/lang/Class::getName (/.class-for java/lang/Class)))) (_.test "Can check if a value is null." (and (/.null? (/.null)) (not (/.null? sample)))) (_.test "Can safely convert nullable references into Maybe values." - (and (|> (: (Maybe Object) (/.??? (/.null))) + (and (|> (: (Maybe java/lang/Object) (/.??? (/.null))) (case> #.None #1 _ #0)) - (|> (: (Maybe Object) (/.??? sample)) + (|> (: (Maybe java/lang/Object) (/.??? sample)) (case> (#.Some _) #1 _ #0)))) ))) diff --git a/stdlib/source/test/lux/tool/compiler/phase/analysis.lux b/stdlib/source/test/lux/tool/compiler/phase/analysis.lux index d24feb8be..06b09fbf9 100644 --- a/stdlib/source/test/lux/tool/compiler/phase/analysis.lux +++ b/stdlib/source/test/lux/tool/compiler/phase/analysis.lux @@ -10,7 +10,7 @@ ["/#" // #_ [extension [analysis - ["#." common]]]]]) + ["#." lux]]]]]) (def: #export test Test @@ -20,5 +20,5 @@ /reference.test /case.test /function.test - //common.test + //lux.test )) diff --git a/stdlib/source/test/lux/tool/compiler/phase/extension/analysis/common.lux b/stdlib/source/test/lux/tool/compiler/phase/extension/analysis/common.lux deleted file mode 100644 index e45656025..000000000 --- a/stdlib/source/test/lux/tool/compiler/phase/extension/analysis/common.lux +++ /dev/null @@ -1,201 +0,0 @@ -(.module: - [lux (#- i64 int primitive) - [abstract ["." monad (#+ do)]] - [data - text/format - ["." name]] - ["r" math/random (#+ Random) ("#@." monad)] - ["_" test (#+ Test)] - [control - pipe - [io (#+ IO)] - [concurrency - ["." atom]]] - [data - ["." error] - ["." product]] - ["." type ("#@." equivalence)] - [macro - ["." code]]] - [//// - [analysis - ["_." primitive]]] - {1 - ["." / - ["///#" //// - [analysis - ["#." scope] - ["#." type]]]]}) - -(template [ ] - [(def: ( procedure params output-type) - (-> Text (List Code) Type Bit) - (|> (////scope.with-scope "" - (////type.with-type output-type - (_primitive.phase (` ((~ (code.text procedure)) (~+ params)))))) - (////.run _primitive.state) - (case> (#error.Success _) - - - (#error.Failure error) - )))] - - [check-success+ true false] - [check-failure+ false true] - ) - -(def: primitive - (Random [Type Code]) - (r.filter (|>> product.left (is? Any) not) _primitive.primitive)) - -(def: lux - Test - (do r.monad - [[primT primC] ..primitive - [antiT antiC] (|> ..primitive - (r.filter (|>> product.left (type@= primT) not)))] - ($_ _.and - (_.test "Can test for reference equality." - (check-success+ "lux is" (list primC primC) Bit)) - (_.test "Reference equality must be done with elements of the same type." - (check-failure+ "lux is" (list primC antiC) Bit)) - (_.test "Can 'try' risky IO computations." - (check-success+ "lux try" - (list (` ("lux io error" "YOLO"))) - (type (Either Text primT)))) - ))) - -(def: i64 - Test - (do r.monad - [subjectC (|> r.nat (:: @ map code.nat)) - signedC (|> r.int (:: @ map code.int)) - paramC (|> r.nat (:: @ map code.nat))] - ($_ _.and - (_.test "i64 'and'." - (check-success+ "lux i64 and" (list paramC subjectC) Nat)) - (_.test "i64 'or'." - (check-success+ "lux i64 or" (list paramC subjectC) Nat)) - (_.test "i64 'xor'." - (check-success+ "lux i64 xor" (list paramC subjectC) Nat)) - (_.test "i64 left-shift." - (check-success+ "lux i64 left-shift" (list paramC subjectC) Nat)) - (_.test "i64 logical-right-shift." - (check-success+ "lux i64 logical-right-shift" (list paramC subjectC) Nat)) - (_.test "i64 arithmetic-right-shift." - (check-success+ "lux i64 arithmetic-right-shift" (list paramC signedC) Int)) - (_.test "i64 equivalence." - (check-success+ "lux i64 =" (list paramC subjectC) Bit)) - (_.test "i64 addition." - (check-success+ "lux i64 +" (list paramC subjectC) Int)) - (_.test "i64 subtraction." - (check-success+ "lux i64 -" (list paramC subjectC) Int)) - ))) - -(def: int - Test - (do r.monad - [subjectC (|> r.int (:: @ map code.int)) - paramC (|> r.int (:: @ map code.int))] - ($_ _.and - (_.test "Can multiply integers." - (check-success+ "lux i64 *" (list paramC subjectC) Int)) - (_.test "Can divide integers." - (check-success+ "lux i64 /" (list paramC subjectC) Int)) - (_.test "Can calculate remainder of integers." - (check-success+ "lux i64 %" (list paramC subjectC) Int)) - (_.test "Can compare integers." - (check-success+ "lux i64 <" (list paramC subjectC) Bit)) - (_.test "Can convert integer to text." - (check-success+ "lux i64 char" (list subjectC) Text)) - (_.test "Can convert integer to fraction." - (check-success+ "lux i64 f64" (list subjectC) Frac)) - ))) - -(def: frac - Test - (do r.monad - [subjectC (|> r.safe-frac (:: @ map code.frac)) - paramC (|> r.safe-frac (:: @ map code.frac)) - encodedC (|> r.safe-frac (:: @ map (|>> %f code.text)))] - ($_ _.and - (_.test "Can add frac numbers." - (check-success+ "lux f64 +" (list paramC subjectC) Frac)) - (_.test "Can subtract frac numbers." - (check-success+ "lux f64 -" (list paramC subjectC) Frac)) - (_.test "Can multiply frac numbers." - (check-success+ "lux f64 *" (list paramC subjectC) Frac)) - (_.test "Can divide frac numbers." - (check-success+ "lux f64 /" (list paramC subjectC) Frac)) - (_.test "Can calculate remainder of frac numbers." - (check-success+ "lux f64 %" (list paramC subjectC) Frac)) - (_.test "Can test equivalence of frac numbers." - (check-success+ "lux f64 =" (list paramC subjectC) Bit)) - (_.test "Can compare frac numbers." - (check-success+ "lux f64 <" (list paramC subjectC) Bit)) - (_.test "Can obtain minimum frac number." - (check-success+ "lux f64 min" (list) Frac)) - (_.test "Can obtain maximum frac number." - (check-success+ "lux f64 max" (list) Frac)) - (_.test "Can obtain smallest frac number." - (check-success+ "lux f64 smallest" (list) Frac)) - (_.test "Can convert frac number to integer." - (check-success+ "lux f64 i64" (list subjectC) Int)) - (_.test "Can convert frac number to text." - (check-success+ "lux f64 encode" (list subjectC) Text)) - (_.test "Can convert text to frac number." - (check-success+ "lux f64 decode" (list encodedC) (type (Maybe Frac)))) - ))) - -(def: text - Test - (do r.monad - [subjectC (|> (r.unicode 5) (:: @ map code.text)) - paramC (|> (r.unicode 5) (:: @ map code.text)) - replacementC (|> (r.unicode 5) (:: @ map code.text)) - fromC (|> r.nat (:: @ map code.nat)) - toC (|> r.nat (:: @ map code.nat))] - ($_ _.and - (_.test "Can test text equivalence." - (check-success+ "lux text =" (list paramC subjectC) Bit)) - (_.test "Compare texts in lexicographical order." - (check-success+ "lux text <" (list paramC subjectC) Bit)) - (_.test "Can concatenate one text to another." - (check-success+ "lux text concat" (list subjectC paramC) Text)) - (_.test "Can find the index of a piece of text inside a larger one that (may) contain it." - (check-success+ "lux text index" (list fromC paramC subjectC) (type (Maybe Nat)))) - (_.test "Can query the size/length of a text." - (check-success+ "lux text size" (list subjectC) Nat)) - (_.test "Can obtain the character code of a text at a given index." - (check-success+ "lux text char" (list fromC subjectC) Nat)) - (_.test "Can clip a piece of text between 2 indices." - (check-success+ "lux text clip" (list fromC toC subjectC) Text)) - ))) - -(def: io - Test - (do r.monad - [logC (|> (r.unicode 5) (:: @ map code.text)) - exitC (|> r.int (:: @ map code.int))] - ($_ _.and - (_.test "Can log messages to standard output." - (check-success+ "lux io log" (list logC) Any)) - (_.test "Can throw a run-time error." - (check-success+ "lux io error" (list logC) Nothing)) - (_.test "Can exit the program." - (check-success+ "lux io exit" (list exitC) Nothing)) - (_.test "Can query the current time (as milliseconds since epoch)." - (check-success+ "lux io current-time" (list) Int)) - ))) - -(def: #export test - Test - (<| (_.context (name.module (name-of /._))) - ($_ _.and - ..lux - ..i64 - ..int - ..frac - ..text - ..io - ))) diff --git a/stdlib/source/test/lux/tool/compiler/phase/extension/analysis/lux.lux b/stdlib/source/test/lux/tool/compiler/phase/extension/analysis/lux.lux new file mode 100644 index 000000000..e45656025 --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/phase/extension/analysis/lux.lux @@ -0,0 +1,201 @@ +(.module: + [lux (#- i64 int primitive) + [abstract ["." monad (#+ do)]] + [data + text/format + ["." name]] + ["r" math/random (#+ Random) ("#@." monad)] + ["_" test (#+ Test)] + [control + pipe + [io (#+ IO)] + [concurrency + ["." atom]]] + [data + ["." error] + ["." product]] + ["." type ("#@." equivalence)] + [macro + ["." code]]] + [//// + [analysis + ["_." primitive]]] + {1 + ["." / + ["///#" //// + [analysis + ["#." scope] + ["#." type]]]]}) + +(template [ ] + [(def: ( procedure params output-type) + (-> Text (List Code) Type Bit) + (|> (////scope.with-scope "" + (////type.with-type output-type + (_primitive.phase (` ((~ (code.text procedure)) (~+ params)))))) + (////.run _primitive.state) + (case> (#error.Success _) + + + (#error.Failure error) + )))] + + [check-success+ true false] + [check-failure+ false true] + ) + +(def: primitive + (Random [Type Code]) + (r.filter (|>> product.left (is? Any) not) _primitive.primitive)) + +(def: lux + Test + (do r.monad + [[primT primC] ..primitive + [antiT antiC] (|> ..primitive + (r.filter (|>> product.left (type@= primT) not)))] + ($_ _.and + (_.test "Can test for reference equality." + (check-success+ "lux is" (list primC primC) Bit)) + (_.test "Reference equality must be done with elements of the same type." + (check-failure+ "lux is" (list primC antiC) Bit)) + (_.test "Can 'try' risky IO computations." + (check-success+ "lux try" + (list (` ("lux io error" "YOLO"))) + (type (Either Text primT)))) + ))) + +(def: i64 + Test + (do r.monad + [subjectC (|> r.nat (:: @ map code.nat)) + signedC (|> r.int (:: @ map code.int)) + paramC (|> r.nat (:: @ map code.nat))] + ($_ _.and + (_.test "i64 'and'." + (check-success+ "lux i64 and" (list paramC subjectC) Nat)) + (_.test "i64 'or'." + (check-success+ "lux i64 or" (list paramC subjectC) Nat)) + (_.test "i64 'xor'." + (check-success+ "lux i64 xor" (list paramC subjectC) Nat)) + (_.test "i64 left-shift." + (check-success+ "lux i64 left-shift" (list paramC subjectC) Nat)) + (_.test "i64 logical-right-shift." + (check-success+ "lux i64 logical-right-shift" (list paramC subjectC) Nat)) + (_.test "i64 arithmetic-right-shift." + (check-success+ "lux i64 arithmetic-right-shift" (list paramC signedC) Int)) + (_.test "i64 equivalence." + (check-success+ "lux i64 =" (list paramC subjectC) Bit)) + (_.test "i64 addition." + (check-success+ "lux i64 +" (list paramC subjectC) Int)) + (_.test "i64 subtraction." + (check-success+ "lux i64 -" (list paramC subjectC) Int)) + ))) + +(def: int + Test + (do r.monad + [subjectC (|> r.int (:: @ map code.int)) + paramC (|> r.int (:: @ map code.int))] + ($_ _.and + (_.test "Can multiply integers." + (check-success+ "lux i64 *" (list paramC subjectC) Int)) + (_.test "Can divide integers." + (check-success+ "lux i64 /" (list paramC subjectC) Int)) + (_.test "Can calculate remainder of integers." + (check-success+ "lux i64 %" (list paramC subjectC) Int)) + (_.test "Can compare integers." + (check-success+ "lux i64 <" (list paramC subjectC) Bit)) + (_.test "Can convert integer to text." + (check-success+ "lux i64 char" (list subjectC) Text)) + (_.test "Can convert integer to fraction." + (check-success+ "lux i64 f64" (list subjectC) Frac)) + ))) + +(def: frac + Test + (do r.monad + [subjectC (|> r.safe-frac (:: @ map code.frac)) + paramC (|> r.safe-frac (:: @ map code.frac)) + encodedC (|> r.safe-frac (:: @ map (|>> %f code.text)))] + ($_ _.and + (_.test "Can add frac numbers." + (check-success+ "lux f64 +" (list paramC subjectC) Frac)) + (_.test "Can subtract frac numbers." + (check-success+ "lux f64 -" (list paramC subjectC) Frac)) + (_.test "Can multiply frac numbers." + (check-success+ "lux f64 *" (list paramC subjectC) Frac)) + (_.test "Can divide frac numbers." + (check-success+ "lux f64 /" (list paramC subjectC) Frac)) + (_.test "Can calculate remainder of frac numbers." + (check-success+ "lux f64 %" (list paramC subjectC) Frac)) + (_.test "Can test equivalence of frac numbers." + (check-success+ "lux f64 =" (list paramC subjectC) Bit)) + (_.test "Can compare frac numbers." + (check-success+ "lux f64 <" (list paramC subjectC) Bit)) + (_.test "Can obtain minimum frac number." + (check-success+ "lux f64 min" (list) Frac)) + (_.test "Can obtain maximum frac number." + (check-success+ "lux f64 max" (list) Frac)) + (_.test "Can obtain smallest frac number." + (check-success+ "lux f64 smallest" (list) Frac)) + (_.test "Can convert frac number to integer." + (check-success+ "lux f64 i64" (list subjectC) Int)) + (_.test "Can convert frac number to text." + (check-success+ "lux f64 encode" (list subjectC) Text)) + (_.test "Can convert text to frac number." + (check-success+ "lux f64 decode" (list encodedC) (type (Maybe Frac)))) + ))) + +(def: text + Test + (do r.monad + [subjectC (|> (r.unicode 5) (:: @ map code.text)) + paramC (|> (r.unicode 5) (:: @ map code.text)) + replacementC (|> (r.unicode 5) (:: @ map code.text)) + fromC (|> r.nat (:: @ map code.nat)) + toC (|> r.nat (:: @ map code.nat))] + ($_ _.and + (_.test "Can test text equivalence." + (check-success+ "lux text =" (list paramC subjectC) Bit)) + (_.test "Compare texts in lexicographical order." + (check-success+ "lux text <" (list paramC subjectC) Bit)) + (_.test "Can concatenate one text to another." + (check-success+ "lux text concat" (list subjectC paramC) Text)) + (_.test "Can find the index of a piece of text inside a larger one that (may) contain it." + (check-success+ "lux text index" (list fromC paramC subjectC) (type (Maybe Nat)))) + (_.test "Can query the size/length of a text." + (check-success+ "lux text size" (list subjectC) Nat)) + (_.test "Can obtain the character code of a text at a given index." + (check-success+ "lux text char" (list fromC subjectC) Nat)) + (_.test "Can clip a piece of text between 2 indices." + (check-success+ "lux text clip" (list fromC toC subjectC) Text)) + ))) + +(def: io + Test + (do r.monad + [logC (|> (r.unicode 5) (:: @ map code.text)) + exitC (|> r.int (:: @ map code.int))] + ($_ _.and + (_.test "Can log messages to standard output." + (check-success+ "lux io log" (list logC) Any)) + (_.test "Can throw a run-time error." + (check-success+ "lux io error" (list logC) Nothing)) + (_.test "Can exit the program." + (check-success+ "lux io exit" (list exitC) Nothing)) + (_.test "Can query the current time (as milliseconds since epoch)." + (check-success+ "lux io current-time" (list) Int)) + ))) + +(def: #export test + Test + (<| (_.context (name.module (name-of /._))) + ($_ _.and + ..lux + ..i64 + ..int + ..frac + ..text + ..io + ))) -- cgit v1.2.3