From 21777826feb4affa53bf150588b70fc11bb92512 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 4 Mar 2020 00:38:54 -0400 Subject: Test for codec composition + adjustments to JS-generation code. --- stdlib/source/lux/abstract/algebra.lux | 1 - stdlib/source/lux/data/format/json.lux | 22 +- .../language/lux/phase/extension/generation/js.lux | 17 ++ .../lux/phase/extension/generation/js/common.lux | 230 +++++++++++++++++++++ .../lux/phase/extension/generation/js/host.lux | 135 ++++++++++++ .../compiler/language/lux/phase/generation/js.lux | 55 ++--- .../language/lux/phase/generation/js/case.lux | 82 ++++---- .../language/lux/phase/generation/js/extension.lux | 15 -- .../lux/phase/generation/js/extension/common.lux | 227 -------------------- .../lux/phase/generation/js/extension/host.lux | 133 ------------ .../language/lux/phase/generation/js/function.lux | 37 ++-- .../language/lux/phase/generation/js/loop.lux | 17 +- .../language/lux/phase/generation/js/reference.lux | 10 +- .../language/lux/phase/generation/js/runtime.lux | 41 ++-- .../language/lux/phase/generation/js/structure.lux | 25 +-- .../language/lux/phase/generation/reference.lux | 52 ++--- stdlib/source/test/lux/abstract.lux | 2 + stdlib/source/test/lux/abstract/codec.lux | 36 +++- stdlib/source/test/lux/extension.lux | 14 +- 19 files changed, 605 insertions(+), 546 deletions(-) create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux create mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux delete mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/extension.lux delete mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/extension/common.lux delete mode 100644 stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/extension/host.lux (limited to 'stdlib') diff --git a/stdlib/source/lux/abstract/algebra.lux b/stdlib/source/lux/abstract/algebra.lux index 2813ed0e7..0d066fb4f 100644 --- a/stdlib/source/lux/abstract/algebra.lux +++ b/stdlib/source/lux/abstract/algebra.lux @@ -3,7 +3,6 @@ [control functor]]) -## Types (type: #export (Algebra f a) (-> (f a) a)) diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index 60d57abab..c42093710 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -51,6 +51,10 @@ [Object (Dictionary String JSON)] ) +(def: #export object + (-> (List [String JSON]) JSON) + (|>> (dictionary.from-list text.hash) #..Object)) + (syntax: #export (json token) {#.doc (doc "A simple way to produce JSON literals." (json #1) @@ -66,15 +70,15 @@ (^template [ ] [_ ( value)] (wrap (list (` (: JSON ( (~ ( value)))))))) - ([#.Bit code.bit #Boolean] - [#.Frac code.frac #Number] - [#.Text code.text #String]) + ([#.Bit code.bit #..Boolean] + [#.Frac code.frac #..Number] + [#.Text code.text #..String]) [_ (#.Tag ["" "null"])] - (wrap (list (` (: JSON #Null)))) + (wrap (list (` (: JSON #..Null)))) [_ (#.Tuple members)] - (wrap (list (` (: JSON (#Array ((~! row) (~+ (list@map wrapper members)))))))) + (wrap (list (` (: JSON (#..Array ((~! row) (~+ (list@map wrapper members)))))))) [_ (#.Record pairs)] (do ..monad @@ -87,7 +91,9 @@ _ (macro.fail "Wrong syntax for JSON object."))) pairs)] - (wrap (list (` (: JSON (#Object ((~! dictionary.from-list) (~! text.hash) (list (~+ pairs'))))))))) + (wrap (list (` (: JSON (#..Object ((~! dictionary.from-list) + (~! text.hash) + (list (~+ pairs'))))))))) _ (wrap (list token))))) @@ -115,7 +121,7 @@ (#try.Failure ($_ text@compose "Missing field '" key "' on object."))) _ - (#try.Failure ($_ text@compose "Cannot get field '" key "' of a non-object.")))) + (#try.Failure ($_ text@compose "Cannot get field '" key "' on a non-object.")))) (def: #export (set key value json) {#.doc "A JSON object field setter."} @@ -125,7 +131,7 @@ (#try.Success (#Object (dictionary.put key value obj))) _ - (#try.Failure ($_ text@compose "Cannot set field '" key "' of a non-object.")))) + (#try.Failure ($_ text@compose "Cannot set field '" key "' on a non-object.")))) (template [ ] [(def: #export ( key json) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js.lux new file mode 100644 index 000000000..81d2fe57b --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js.lux @@ -0,0 +1,17 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + ["." / #_ + ["#." common] + ["#." host] + [//// + [generation + [js + [runtime (#+ Bundle)]]]]]) + +(def: #export bundle + Bundle + (dictionary.merge /common.bundle + /host.bundle)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux new file mode 100644 index 000000000..966815a29 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux @@ -0,0 +1,230 @@ +(.module: + [lux #* + [host (#+ import:)] + [abstract + ["." monad (#+ do)]] + [control + ["." try] + ["<>" parser + ["" synthesis (#+ Parser)]]] + [data + ["." product] + [number + ["f" frac]] + [collection + ["." list ("#@." functor)] + ["." dictionary]]] + [target + ["_" js (#+ Literal Expression Statement)]]] + ["." //// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["//" js #_ + ["#." runtime (#+ Operation Phase Handler Bundle)] + ["#." primitive]]] + [// + [synthesis (#+ %synthesis)] + [/// + ["#" phase]]]]]) + +(def: #export (custom [parser handler]) + (All [s] + (-> [(Parser s) + (-> Text Phase s (Operation Expression))] + Handler)) + (function (_ extension-name phase input) + (case (.run parser input) + (#try.Success input') + (handler extension-name phase input') + + (#try.Failure error) + (/////.throw extension.invalid-syntax [extension-name %synthesis input])))) + +## [Procedures] +## [[Bits]] +(template [ ] + [(def: ( [paramG subjectG]) + (Binary Expression) + ( subjectG (//runtime.i64//to-number paramG)))] + + [i64//left-shift //runtime.i64//left-shift] + [i64//arithmetic-right-shift //runtime.i64//arithmetic-right-shift] + [i64//logical-right-shift //runtime.i64//logic-right-shift] + ) + +## [[Numbers]] +(import: #long java/lang/Double + (#static MIN_VALUE double) + (#static MAX_VALUE double)) + +(template [ ] + [(def: ( _) + (Nullary Expression) + (//primitive.f64 ))] + + [f64//smallest (java/lang/Double::MIN_VALUE)] + [f64//min (f.* -1.0 (java/lang/Double::MAX_VALUE))] + [f64//max (java/lang/Double::MAX_VALUE)] + ) + +(def: f64//decode + (Unary Expression) + (|>> list + (_.apply/* (_.var "parseFloat")) + _.return + (_.closure (list)) + //runtime.lux//try)) + +(def: i64//char + (Unary Expression) + (|>> //runtime.i64//to-number + (list) + (_.apply/* (_.var "String.fromCharCode")))) + +## [[Text]] +(def: (text//concat [leftG rightG]) + (Binary Expression) + (|> leftG (_.do "concat" (list rightG)))) + +(def: (text//clip [startG endG subjectG]) + (Trinary Expression) + (//runtime.text//clip startG endG subjectG)) + +(def: (text//index [startG partG subjectG]) + (Trinary Expression) + (//runtime.text//index startG partG subjectG)) + +## [[IO]] +(def: (io//log messageG) + (Unary Expression) + ($_ _., + (//runtime.io//log messageG) + //runtime.unit)) + +(def: (io//exit codeG) + (Unary Expression) + (let [@@process (_.var "process") + @@window (_.var "window") + @@location (_.var "location")] + ($_ _.or + ($_ _.and + (_.not (_.= _.undefined (_.type-of @@process))) + (_.the "exit" @@process) + (_.do "exit" (list (//runtime.i64//to-number codeG)) @@process)) + (_.do "close" (list) @@window) + (_.do "reload" (list) @@location)))) + +(def: (io//current-time _) + (Nullary Expression) + (|> (_.new (_.var "Date") (list)) + (_.do "getTime" (list)) + //runtime.i64//from-number)) + +## TODO: Get rid of this ASAP +(def: lux::syntax-char-case! + (..custom [($_ <>.and + .any + .any + (<>.some (.tuple ($_ <>.and + (.tuple (<>.many .i64)) + .any)))) + (function (_ extension-name phase [input else conditionals]) + (do /////.monad + [inputG (phase input) + elseG (phase else) + conditionalsG (: (Operation (List [(List Literal) + Statement])) + (monad.map @ (function (_ [chars branch]) + (do @ + [branchG (phase branch)] + (wrap [(list@map (|>> .int _.int) chars) + (_.return branchG)]))) + conditionals))] + (wrap (_.apply/* (_.closure (list) + (_.switch (_.the //runtime.i64-low-field inputG) + conditionalsG + (#.Some (_.return elseG)))) + (list)))))])) + +## [Bundles] +(def: lux-procs + Bundle + (|> /.empty + (/.install "syntax char case!" lux::syntax-char-case!) + (/.install "is" (binary (product.uncurry _.=))) + (/.install "try" (unary //runtime.lux//try)))) + +(def: i64-procs + Bundle + (<| (/.prefix "i64") + (|> /.empty + (/.install "and" (binary (product.uncurry //runtime.i64//and))) + (/.install "or" (binary (product.uncurry //runtime.i64//or))) + (/.install "xor" (binary (product.uncurry //runtime.i64//xor))) + (/.install "left-shift" (binary i64//left-shift)) + (/.install "logical-right-shift" (binary i64//logical-right-shift)) + (/.install "arithmetic-right-shift" (binary i64//arithmetic-right-shift)) + (/.install "=" (binary (product.uncurry //runtime.i64//=))) + (/.install "<" (binary (product.uncurry //runtime.i64//<))) + (/.install "+" (binary (product.uncurry //runtime.i64//+))) + (/.install "-" (binary (product.uncurry //runtime.i64//-))) + (/.install "*" (binary (product.uncurry //runtime.i64//*))) + (/.install "/" (binary (product.uncurry //runtime.i64///))) + (/.install "%" (binary (product.uncurry //runtime.i64//%))) + (/.install "f64" (unary //runtime.i64//to-number)) + (/.install "char" (unary i64//char)) + ))) + +(def: f64-procs + Bundle + (<| (/.prefix "f64") + (|> /.empty + (/.install "+" (binary (product.uncurry _.+))) + (/.install "-" (binary (product.uncurry _.-))) + (/.install "*" (binary (product.uncurry _.*))) + (/.install "/" (binary (product.uncurry _./))) + (/.install "%" (binary (product.uncurry _.%))) + (/.install "=" (binary (product.uncurry _.=))) + (/.install "<" (binary (product.uncurry _.<))) + (/.install "smallest" (nullary f64//smallest)) + (/.install "min" (nullary f64//min)) + (/.install "max" (nullary f64//max)) + (/.install "i64" (unary //runtime.i64//from-number)) + (/.install "encode" (unary (_.do "toString" (list)))) + (/.install "decode" (unary f64//decode))))) + +(def: text-procs + Bundle + (<| (/.prefix "text") + (|> /.empty + (/.install "=" (binary (product.uncurry _.=))) + (/.install "<" (binary (product.uncurry _.<))) + (/.install "concat" (binary text//concat)) + (/.install "index" (trinary text//index)) + (/.install "size" (unary (|>> (_.the "length") //runtime.i64//from-number))) + (/.install "char" (binary (product.uncurry //runtime.text//char))) + (/.install "clip" (trinary text//clip)) + ))) + +(def: io-procs + Bundle + (<| (/.prefix "io") + (|> /.empty + (/.install "log" (unary io//log)) + (/.install "error" (unary //runtime.io//error)) + (/.install "exit" (unary io//exit)) + (/.install "current-time" (nullary io//current-time))))) + +(def: #export bundle + Bundle + (<| (/.prefix "lux") + (|> lux-procs + (dictionary.merge i64-procs) + (dictionary.merge f64-procs) + (dictionary.merge text-procs) + (dictionary.merge io-procs) + ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux new file mode 100644 index 000000000..592446e93 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux @@ -0,0 +1,135 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["" synthesis (#+ Parser)]]] + [data + [collection + ["." dictionary]]] + [target + ["_" js (#+ Expression)]]] + ["." // #_ + ["#." common (#+ custom)] + ["//#" /// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["//" js #_ + ["#." runtime (#+ Operation Phase Handler Bundle + with-vars)]]] + ["///#" //// #_ + ["#." phase]]]]]) + +(def: array::new + (Unary Expression) + (|>> //runtime.i64//to-number list (_.new (_.var "Array")))) + +(def: array::length + (Unary Expression) + (|>> (_.the "length") //runtime.i64//from-number)) + +(def: (array::read [indexG arrayG]) + (Binary Expression) + (_.at indexG arrayG)) + +(def: (array::write [indexG valueG arrayG]) + (Trinary Expression) + (//runtime.array//write indexG valueG arrayG)) + +(def: (array::delete [indexG arrayG]) + (Binary Expression) + (//runtime.array//delete indexG arrayG)) + +(def: array + Bundle + (<| (/.prefix "array") + (|> /.empty + (/.install "new" (unary array::new)) + (/.install "length" (unary array::length)) + (/.install "read" (binary array::read)) + (/.install "write" (trinary array::write)) + (/.install "delete" (binary array::delete)) + ))) + +(def: object::new + (custom + [($_ <>.and .any (<>.some .any)) + (function (_ extension phase [constructorS inputsS]) + (do ////////phase.monad + [constructorG (phase constructorS) + inputsG (monad.map @ phase inputsS)] + (wrap (_.new constructorG inputsG))))])) + +(def: object::get + Handler + (custom + [($_ <>.and .text .any) + (function (_ extension phase [fieldS objectS]) + (do ////////phase.monad + [objectG (phase objectS)] + (wrap (_.the fieldS objectG))))])) + +(def: object::do + Handler + (custom + [($_ <>.and .text .any (<>.some .any)) + (function (_ extension phase [methodS objectS inputsS]) + (do ////////phase.monad + [objectG (phase objectS) + inputsG (monad.map @ phase inputsS)] + (wrap (_.do methodS inputsG objectG))))])) + +(template [ ] + [(def: (Nullary Expression) (function.constant )) + (def: (Unary Expression) (_.= ))] + + [object::null object::null? _.null] + [object::undefined object::undefined? _.undefined] + ) + +(def: object + Bundle + (<| (/.prefix "object") + (|> /.empty + (/.install "new" object::new) + (/.install "get" object::get) + (/.install "do" object::do) + (/.install "null" (nullary object::null)) + (/.install "null?" (unary object::null?)) + (/.install "undefined" (nullary object::undefined)) + (/.install "undefined?" (unary object::undefined?)) + ))) + +(def: js::constant + (custom + [.text + (function (_ extension phase name) + (do ////////phase.monad + [] + (wrap (_.var name))))])) + +(def: js::apply + (custom + [($_ <>.and .any (<>.some .any)) + (function (_ extension phase [abstractionS inputsS]) + (do ////////phase.monad + [abstractionG (phase abstractionS) + inputsG (monad.map @ phase inputsS)] + (wrap (_.apply/* abstractionG inputsG))))])) + +(def: #export bundle + Bundle + (<| (/.prefix "js") + (|> /.empty + (/.install "constant" js::constant) + (/.install "apply" js::apply) + (/.install "type-of" (unary _.type-of)) + (dictionary.merge ..array) + (dictionary.merge ..object) + ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux index c0cd734b3..ebfbda2a0 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux @@ -2,60 +2,63 @@ [lux #* [abstract [monad (#+ do)]]] - [/ + ["." / #_ [runtime (#+ Phase)] - ["." primitive] - ["." structure] - ["." reference ("#@." system)] - ["." function] - ["." case] - ["." loop] - ["." /// + ["#." primitive] + ["#." structure] + ["#." reference ("#@." system)] + ["#." case] + ["#." loop] + ["#." function] + ["//#" /// #_ ["." extension] - [// + ["/#" // #_ [analysis (#+)] - ["." synthesis]]]]) + ["." synthesis] + ["//#" /// #_ + ["#." phase ("#@." monad)]]]]]) (def: #export (generate synthesis) Phase (case synthesis (^template [ ] (^ ( value)) - (:: ///.monad wrap ( value))) - ([synthesis.bit primitive.bit] - [synthesis.i64 primitive.i64] - [synthesis.f64 primitive.f64] - [synthesis.text primitive.text]) + (//////phase@wrap ( value))) + ([synthesis.bit /primitive.bit] + [synthesis.i64 /primitive.i64] + [synthesis.f64 /primitive.f64] + [synthesis.text /primitive.text]) (^ (synthesis.variant variantS)) - (structure.variant generate variantS) + (/structure.variant generate variantS) (^ (synthesis.tuple members)) - (structure.tuple generate members) + (/structure.tuple generate members) (#synthesis.Reference value) - (reference@reference value) + (/reference@reference value) (^ (synthesis.branch/case case)) - (case.case generate case) + (/case.case generate case) (^ (synthesis.branch/let let)) - (case.let generate let) + (/case.let generate let) (^ (synthesis.branch/if if)) - (case.if generate if) + (/case.if generate if) (^ (synthesis.loop/scope scope)) - (loop.scope generate scope) + (/loop.scope generate scope) (^ (synthesis.loop/recur updates)) - (loop.recur generate updates) + (/loop.recur generate updates) (^ (synthesis.function/abstraction abstraction)) - (function.function generate abstraction) + (/function.function generate abstraction) (^ (synthesis.function/apply application)) - (function.apply generate application) + (/function.apply generate application) (#synthesis.Extension extension) - (extension.apply generate extension))) + (extension.apply generate extension) + )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux index d9956579c..79b63ba13 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux @@ -16,14 +16,16 @@ ["#." runtime (#+ Operation Phase)] ["#." reference] ["#." primitive] - ["#/" // #_ + ["/#" // #_ ["#." reference] - ["#/" // ("#@." monad) - [synthesis - ["." case]] - ["#/" // #_ - [reference (#+ Register)] - ["#." synthesis (#+ Synthesis Path)]]]]]) + ["/#" // #_ + ["#." synthesis #_ + ["#/." case]] + ["/#" // #_ + ["#." synthesis (#+ Synthesis Path)] + ["//#" /// #_ + [reference (#+ Register)] + ["#." phase ("#@." monad)]]]]]]) (def: #export register (///reference.local _.var)) @@ -31,7 +33,7 @@ (def: #export (let generate [valueS register bodyS]) (-> Phase [Synthesis Register Synthesis] (Operation Computation)) - (do ////.monad + (do ///////phase.monad [valueO (generate valueS) bodyO (generate bodyS)] ## TODO: Find some way to do 'let' without paying the price of the closure. @@ -42,7 +44,7 @@ (def: #export (record-get generate valueS pathP) (-> Phase Synthesis (List (Either Nat Nat)) (Operation Expression)) - (do ////.monad + (do ///////phase.monad [valueO (generate valueS)] (wrap (list@fold (function (_ side source) (.let [method (.case side @@ -58,7 +60,7 @@ (def: #export (if generate [testS thenS elseS]) (-> Phase [Synthesis Synthesis Synthesis] (Operation Computation)) - (do ////.monad + (do ///////phase.monad [testO (generate testS) thenO (generate thenS) elseO (generate elseS)] @@ -138,20 +140,20 @@ (-> Phase Path (Operation Statement)) (.case pathP (^ (/////synthesis.path/then bodyS)) - (do ////.monad + (do ///////phase.monad [body! (generate bodyS)] (wrap (_.return body!))) #/////synthesis.Pop - (////@wrap pop-cursor!) + (///////phase@wrap pop-cursor!) (#/////synthesis.Bind register) - (////@wrap (_.define (..register register) ..peek-cursor)) + (///////phase@wrap (_.define (..register register) ..peek-cursor)) (^template [ <=>] (^ ( value)) - (////@wrap (_.when (|> value (<=> ..peek-cursor) _.not) - fail-pm!))) + (///////phase@wrap (_.when (|> value (<=> ..peek-cursor) _.not) + fail-pm!))) ([/////synthesis.path/bit //primitive.bit _.=] [/////synthesis.path/i64 (<| //primitive.i64 .int) //runtime.i64//=] [/////synthesis.path/f64 //primitive.f64 _.=] @@ -159,62 +161,62 @@ (^template [ ] (^ ( idx)) - (////@wrap ( false idx)) + (///////phase@wrap ( false idx)) (^ ( idx nextP)) (|> nextP (pattern-matching' generate) - (:: ////.monad map (_.then ( true idx))))) + (:: ///////phase.monad map (_.then ( true idx))))) ([/////synthesis.side/left /////synthesis.simple-left-side ..left-choice] [/////synthesis.side/right /////synthesis.simple-right-side ..right-choice]) (^ (/////synthesis.member/left 0)) - (////@wrap (push-cursor! (_.at (_.i32 +0) ..peek-cursor))) + (///////phase@wrap (push-cursor! (_.at (_.i32 +0) ..peek-cursor))) ## Extra optimization (^ (/////synthesis.path/seq (/////synthesis.member/left 0) (/////synthesis.!bind-top register thenP))) - (do ////.monad + (do ///////phase.monad [then! (pattern-matching' generate thenP)] - (////@wrap ($_ _.then - (_.define (..register register) (_.at (_.i32 +0) ..peek-cursor)) - then!))) + (///////phase@wrap ($_ _.then + (_.define (..register register) (_.at (_.i32 +0) ..peek-cursor)) + then!))) (^template [ ] (^ ( lefts)) - (////@wrap (push-cursor! ( (_.i32 (.int lefts)) ..peek-cursor))) + (///////phase@wrap (push-cursor! ( (_.i32 (.int lefts)) ..peek-cursor))) ## Extra optimization (^ (/////synthesis.path/seq ( lefts) (/////synthesis.!bind-top register thenP))) - (do ////.monad + (do ///////phase.monad [then! (pattern-matching' generate thenP)] - (////@wrap ($_ _.then - (_.define (..register register) ( (_.i32 (.int lefts)) ..peek-cursor)) - then!)))) + (///////phase@wrap ($_ _.then + (_.define (..register register) ( (_.i32 (.int lefts)) ..peek-cursor)) + then!)))) ([/////synthesis.member/left //runtime.tuple//left] [/////synthesis.member/right //runtime.tuple//right]) (^ (/////synthesis.!bind-top register thenP)) - (do ////.monad + (do ///////phase.monad [then! (pattern-matching' generate thenP)] - (////@wrap ($_ _.then - (_.define (..register register) ..peek-and-pop-cursor) - then!))) + (///////phase@wrap ($_ _.then + (_.define (..register register) ..peek-and-pop-cursor) + then!))) (^ (/////synthesis.!multi-pop nextP)) - (.let [[extra-pops nextP'] (case.count-pops nextP)] - (do ////.monad + (.let [[extra-pops nextP'] (////synthesis/case.count-pops nextP)] + (do ///////phase.monad [next! (pattern-matching' generate nextP')] - (////@wrap ($_ _.then - (multi-pop-cursor! (n.+ 2 extra-pops)) - next!)))) + (///////phase@wrap ($_ _.then + (multi-pop-cursor! (n.+ 2 extra-pops)) + next!)))) (^template [ ] (^ ( leftP rightP)) - (do ////.monad + (do ///////phase.monad [left! (pattern-matching' generate leftP) right! (pattern-matching' generate rightP)] (wrap ( left! right!)))) @@ -223,16 +225,16 @@ (def: (pattern-matching generate pathP) (-> Phase Path (Operation Statement)) - (do ////.monad + (do ///////phase.monad [pattern-matching! (pattern-matching' generate pathP)] (wrap ($_ _.then (_.do-while (_.boolean false) pattern-matching!) - (_.throw (_.string case.pattern-matching-error)))))) + (_.throw (_.string ////synthesis/case.pattern-matching-error)))))) (def: #export (case generate [valueS pathP]) (-> Phase [Synthesis Path] (Operation Computation)) - (do ////.monad + (do ///////phase.monad [stack-init (generate valueS) path! (pattern-matching generate pathP) #let [closure (<| (_.closure (list)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/extension.lux deleted file mode 100644 index 71739bfc9..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/extension.lux +++ /dev/null @@ -1,15 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - [// - [runtime (#+ Bundle)]] - [/ - ["." common] - ["." host]]) - -(def: #export bundle - Bundle - (dictionary.merge common.bundle - host.bundle)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/extension/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/extension/common.lux deleted file mode 100644 index c5c4d15ff..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/extension/common.lux +++ /dev/null @@ -1,227 +0,0 @@ -(.module: - [lux #* - [host (#+ import:)] - [abstract - ["." monad (#+ do)]] - [control - ["." try] - ["<>" parser - ["" synthesis (#+ Parser)]]] - [data - ["." product] - [number - ["f" frac]] - [collection - ["." list ("#@." functor)] - ["." dictionary]]] - [target - ["_" js (#+ Literal Expression Statement)]]] - ["." /// #_ - ["#." runtime (#+ Operation Phase Handler Bundle)] - ["#." primitive] - ["/#" // #_ - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["/#" // - ["." extension - ["." bundle]] - [// - [synthesis (#+ %synthesis)]]]]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text Phase s (Operation Expression))] - Handler)) - (function (_ extension-name phase input) - (case (.run parser input) - (#try.Success input') - (handler extension-name phase input') - - (#try.Failure error) - (/////.throw extension.invalid-syntax [extension-name %synthesis input])))) - -## [Procedures] -## [[Bits]] -(template [ ] - [(def: ( [paramG subjectG]) - (Binary Expression) - ( subjectG (///runtime.i64//to-number paramG)))] - - [i64//left-shift ///runtime.i64//left-shift] - [i64//arithmetic-right-shift ///runtime.i64//arithmetic-right-shift] - [i64//logical-right-shift ///runtime.i64//logic-right-shift] - ) - -## [[Numbers]] -(import: #long java/lang/Double - (#static MIN_VALUE double) - (#static MAX_VALUE double)) - -(template [ ] - [(def: ( _) - (Nullary Expression) - (///primitive.f64 ))] - - [f64//smallest (java/lang/Double::MIN_VALUE)] - [f64//min (f.* -1.0 (java/lang/Double::MAX_VALUE))] - [f64//max (java/lang/Double::MAX_VALUE)] - ) - -(def: f64//decode - (Unary Expression) - (|>> list - (_.apply/* (_.var "parseFloat")) - _.return - (_.closure (list)) - ///runtime.lux//try)) - -(def: i64//char - (Unary Expression) - (|>> ///runtime.i64//to-number - (list) - (_.apply/* (_.var "String.fromCharCode")))) - -## [[Text]] -(def: (text//concat [leftG rightG]) - (Binary Expression) - (|> leftG (_.do "concat" (list rightG)))) - -(def: (text//clip [startG endG subjectG]) - (Trinary Expression) - (///runtime.text//clip startG endG subjectG)) - -(def: (text//index [startG partG subjectG]) - (Trinary Expression) - (///runtime.text//index startG partG subjectG)) - -## [[IO]] -(def: (io//log messageG) - (Unary Expression) - ($_ _., - (///runtime.io//log messageG) - ///runtime.unit)) - -(def: (io//exit codeG) - (Unary Expression) - (let [@@process (_.var "process") - @@window (_.var "window") - @@location (_.var "location")] - ($_ _.or - ($_ _.and - (_.not (_.= _.undefined (_.type-of @@process))) - (_.the "exit" @@process) - (_.do "exit" (list (///runtime.i64//to-number codeG)) @@process)) - (_.do "close" (list) @@window) - (_.do "reload" (list) @@location)))) - -(def: (io//current-time _) - (Nullary Expression) - (|> (_.new (_.var "Date") (list)) - (_.do "getTime" (list)) - ///runtime.i64//from-number)) - -## TODO: Get rid of this ASAP -(def: lux::syntax-char-case! - (..custom [($_ <>.and - .any - .any - (<>.some (.tuple ($_ <>.and - (.tuple (<>.many .i64)) - .any)))) - (function (_ extension-name phase [input else conditionals]) - (do /////.monad - [inputG (phase input) - elseG (phase else) - conditionalsG (: (Operation (List [(List Literal) - Statement])) - (monad.map @ (function (_ [chars branch]) - (do @ - [branchG (phase branch)] - (wrap [(list@map (|>> .int _.int) chars) - (_.return branchG)]))) - conditionals))] - (wrap (_.apply/* (_.closure (list) - (_.switch (_.the ///runtime.i64-low-field inputG) - conditionalsG - (#.Some (_.return elseG)))) - (list)))))])) - -## [Bundles] -(def: lux-procs - Bundle - (|> bundle.empty - (bundle.install "syntax char case!" lux::syntax-char-case!) - (bundle.install "is" (binary (product.uncurry _.=))) - (bundle.install "try" (unary ///runtime.lux//try)))) - -(def: i64-procs - Bundle - (<| (bundle.prefix "i64") - (|> bundle.empty - (bundle.install "and" (binary (product.uncurry ///runtime.i64//and))) - (bundle.install "or" (binary (product.uncurry ///runtime.i64//or))) - (bundle.install "xor" (binary (product.uncurry ///runtime.i64//xor))) - (bundle.install "left-shift" (binary i64//left-shift)) - (bundle.install "logical-right-shift" (binary i64//logical-right-shift)) - (bundle.install "arithmetic-right-shift" (binary i64//arithmetic-right-shift)) - (bundle.install "=" (binary (product.uncurry ///runtime.i64//=))) - (bundle.install "<" (binary (product.uncurry ///runtime.i64//<))) - (bundle.install "+" (binary (product.uncurry ///runtime.i64//+))) - (bundle.install "-" (binary (product.uncurry ///runtime.i64//-))) - (bundle.install "*" (binary (product.uncurry ///runtime.i64//*))) - (bundle.install "/" (binary (product.uncurry ///runtime.i64///))) - (bundle.install "%" (binary (product.uncurry ///runtime.i64//%))) - (bundle.install "f64" (unary ///runtime.i64//to-number)) - (bundle.install "char" (unary i64//char)) - ))) - -(def: f64-procs - Bundle - (<| (bundle.prefix "f64") - (|> bundle.empty - (bundle.install "+" (binary (product.uncurry _.+))) - (bundle.install "-" (binary (product.uncurry _.-))) - (bundle.install "*" (binary (product.uncurry _.*))) - (bundle.install "/" (binary (product.uncurry _./))) - (bundle.install "%" (binary (product.uncurry _.%))) - (bundle.install "=" (binary (product.uncurry _.=))) - (bundle.install "<" (binary (product.uncurry _.<))) - (bundle.install "smallest" (nullary f64//smallest)) - (bundle.install "min" (nullary f64//min)) - (bundle.install "max" (nullary f64//max)) - (bundle.install "i64" (unary ///runtime.i64//from-number)) - (bundle.install "encode" (unary (_.do "toString" (list)))) - (bundle.install "decode" (unary f64//decode))))) - -(def: text-procs - Bundle - (<| (bundle.prefix "text") - (|> bundle.empty - (bundle.install "=" (binary (product.uncurry _.=))) - (bundle.install "<" (binary (product.uncurry _.<))) - (bundle.install "concat" (binary text//concat)) - (bundle.install "index" (trinary text//index)) - (bundle.install "size" (unary (|>> (_.the "length") ///runtime.i64//from-number))) - (bundle.install "char" (binary (product.uncurry ///runtime.text//char))) - (bundle.install "clip" (trinary text//clip)) - ))) - -(def: io-procs - Bundle - (<| (bundle.prefix "io") - (|> bundle.empty - (bundle.install "log" (unary io//log)) - (bundle.install "error" (unary ///runtime.io//error)) - (bundle.install "exit" (unary io//exit)) - (bundle.install "current-time" (nullary io//current-time))))) - -(def: #export bundle - Bundle - (<| (bundle.prefix "lux") - (|> lux-procs - (dictionary.merge i64-procs) - (dictionary.merge f64-procs) - (dictionary.merge text-procs) - (dictionary.merge io-procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/extension/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/extension/host.lux deleted file mode 100644 index c44e1bdff..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/extension/host.lux +++ /dev/null @@ -1,133 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["" synthesis (#+ Parser)]]] - [data - [collection - ["." dictionary]]] - [target - ["_" js (#+ Expression)]]] - ["." // #_ - ["#." common (#+ custom)] - ["/#" // #_ - ["#." runtime (#+ Operation Phase Handler Bundle - with-vars)] - ["#." primitive] - ["/#" // #_ - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["/#" // - ["." extension - ["." bundle]]]]]]) - -(def: array::new - (Unary Expression) - (|>> ///runtime.i64//to-number list (_.new (_.var "Array")))) - -(def: array::length - (Unary Expression) - (|>> (_.the "length") ///runtime.i64//from-number)) - -(def: (array::read [indexG arrayG]) - (Binary Expression) - (_.at indexG arrayG)) - -(def: (array::write [indexG valueG arrayG]) - (Trinary Expression) - (///runtime.array//write indexG valueG arrayG)) - -(def: (array::delete [indexG arrayG]) - (Binary Expression) - (///runtime.array//delete indexG arrayG)) - -(def: array - Bundle - (<| (bundle.prefix "array") - (|> bundle.empty - (bundle.install "new" (unary array::new)) - (bundle.install "length" (unary array::length)) - (bundle.install "read" (binary array::read)) - (bundle.install "write" (trinary array::write)) - (bundle.install "delete" (binary array::delete)) - ))) - -(def: object::new - (custom - [($_ <>.and .any (<>.some .any)) - (function (_ extension phase [constructorS inputsS]) - (do /////.monad - [constructorG (phase constructorS) - inputsG (monad.map @ phase inputsS)] - (wrap (_.new constructorG inputsG))))])) - -(def: object::get - Handler - (custom - [($_ <>.and .text .any) - (function (_ extension phase [fieldS objectS]) - (do /////.monad - [objectG (phase objectS)] - (wrap (_.the fieldS objectG))))])) - -(def: object::do - Handler - (custom - [($_ <>.and .text .any (<>.some .any)) - (function (_ extension phase [methodS objectS inputsS]) - (do /////.monad - [objectG (phase objectS) - inputsG (monad.map @ phase inputsS)] - (wrap (_.do methodS inputsG objectG))))])) - -(template [ ] - [(def: (Nullary Expression) (function.constant )) - (def: (Unary Expression) (_.= ))] - - [object::null object::null? _.null] - [object::undefined object::undefined? _.undefined] - ) - -(def: object - Bundle - (<| (bundle.prefix "object") - (|> bundle.empty - (bundle.install "new" object::new) - (bundle.install "get" object::get) - (bundle.install "do" object::do) - (bundle.install "null" (nullary object::null)) - (bundle.install "null?" (unary object::null?)) - (bundle.install "undefined" (nullary object::undefined)) - (bundle.install "undefined?" (unary object::undefined?)) - ))) - -(def: js::constant - (custom - [.text - (function (_ extension phase name) - (do /////.monad - [] - (wrap (_.var name))))])) - -(def: js::apply - (custom - [($_ <>.and .any (<>.some .any)) - (function (_ extension phase [abstractionS inputsS]) - (do /////.monad - [abstractionG (phase abstractionS) - inputsG (monad.map @ phase inputsS)] - (wrap (_.apply/* abstractionG inputsG))))])) - -(def: #export bundle - Bundle - (<| (bundle.prefix "js") - (|> bundle.empty - (bundle.install "constant" js::constant) - (bundle.install "apply" js::apply) - (bundle.install "type-of" (unary _.type-of)) - (dictionary.merge ..array) - (dictionary.merge ..object) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux index ec48162c5..75399ef04 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux @@ -14,35 +14,35 @@ [runtime (#+ Operation Phase)] ["#." reference] ["#." case] - ["#/" // + ["/#" // #_ ["#." reference] - ["#/" // ("#@." monad) - ["." // #_ - [reference (#+ Register Variable)] + ["//#" /// #_ + [analysis (#+ Variant Tuple Environment Abstraction Application Analysis)] + [synthesis (#+ Synthesis)] + ["#." generation] + ["//#" /// #_ [arity (#+ Arity)] - [analysis (#+ Variant Tuple Environment Abstraction Application Analysis)] - [synthesis (#+ Synthesis)]]]]]) + [reference (#+ Register Variable)] + ["#." phase ("#@." monad)]]]]]) (def: #export (apply generate [functionS argsS+]) (-> Phase (Application Synthesis) (Operation Computation)) - (do ////.monad + (do ///////phase.monad [functionO (generate functionS) argsO+ (monad.map @ generate argsS+)] (wrap (_.apply/* functionO argsO+)))) -(def: #export capture - (///reference.foreign _.var)) - (def: (with-closure inits function-definition) (-> (List Expression) Computation (Operation Computation)) - (////@wrap + (///////phase@wrap (case inits #.Nil function-definition _ - (let [closure (_.closure (|> (list.enumerate inits) - (list@map (|>> product.left ..capture))) + (let [capture (///reference.foreign _.var) + closure (_.closure (|> (list.enumerate inits) + (list@map (|>> product.left capture))) (_.return function-definition))] (_.apply/* closure inits))))) @@ -55,14 +55,15 @@ (def: #export (function generate [environment arity bodyS]) (-> Phase (Abstraction Synthesis) (Operation Computation)) - (do ////.monad - [[function-name bodyO] (///.with-context + (do ///////phase.monad + [[function-name bodyO] (/////generation.with-context (do @ - [function-name ///.context] - (///.with-anchor (_.var function-name) + [function-name /////generation.context] + (/////generation.with-anchor (_.var function-name) (generate bodyS)))) + #let [capture (:: //reference.system variable)] closureO+ (: (Operation (List Expression)) - (monad.map @ (:: //reference.system variable) environment)) + (monad.map @ capture environment)) #let [arityO (|> arity .int _.i32) @num-args (_.var "num_args") @self (_.var function-name) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/loop.lux index 101c49b95..3479de19b 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/loop.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/loop.lux @@ -14,18 +14,19 @@ ["." // #_ [runtime (#+ Operation Phase)] ["#." case] - ["#/" // - ["#/" // - [// - [synthesis (#+ Scope Synthesis)]]]]]) + ["///#" //// #_ + [synthesis (#+ Scope Synthesis)] + ["#." generation] + ["//#" /// #_ + ["#." phase]]]]) (def: @scope (_.var "scope")) (def: #export (scope generate [start initsS+ bodyS]) (-> Phase (Scope Synthesis) (Operation Computation)) - (do ////.monad + (do ///////phase.monad [initsO+ (monad.map @ generate initsS+) - bodyO (///.with-anchor @scope + bodyO (/////generation.with-anchor @scope (generate bodyS)) #let [closure (_.function @scope (|> initsS+ @@ -36,7 +37,7 @@ (def: #export (recur generate argsS+) (-> Phase (List Synthesis) (Operation Computation)) - (do ////.monad - [@scope ///.anchor + (do ///////phase.monad + [@scope /////generation.anchor argsO+ (monad.map @ generate argsS+)] (wrap (_.apply/* @scope argsO+)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/reference.lux index 4ac7483fa..183b35650 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/reference.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/reference.lux @@ -2,10 +2,10 @@ [lux #* [target ["_" js (#+ Expression)]]] - [// - [// - ["." reference]]]) + [/// + ["/" reference]]) (def: #export system - (reference.system (: (-> Text Expression) _.var) - (: (-> Text Expression) _.var))) + (let [constant (: (-> Text Expression) _.var) + variable constant] + (/.system constant variable))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux index 949e663c7..1c1b7379d 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux @@ -18,21 +18,22 @@ [syntax (#+ syntax:)]] [target ["_" js (#+ Expression Var Computation Statement)]]] - ["." /// - ["//." // - [// - ["/////." name] - ["." synthesis]]]] + ["." ///// #_ + ["#." synthesis] + ["#." generation] + ["//#" /// #_ + ["#." phase] + ["#." name]]] ) (template [ ] [(type: #export ( Var Expression Statement))] - [Operation ///.Operation] - [Phase ///.Phase] - [Handler ///.Handler] - [Bundle ///.Bundle] + [Operation /////generation.Operation] + [Phase /////generation.Phase] + [Handler /////generation.Handler] + [Bundle /////generation.Bundle] ) (type: #export (Generator i) @@ -53,7 +54,7 @@ (def: #export variant-flag-field "_lux_flag") (def: #export variant-value-field "_lux_value") -(def: #export unit Computation (_.string synthesis.unit)) +(def: #export unit Computation (_.string /////synthesis.unit)) (def: #export (flag value) (-> Bit Computation) @@ -85,12 +86,12 @@ (def: variable (-> Text Var) - (|>> /////name.normalize + (|>> ///////name.normalize _.var)) (def: runtime-name (-> Text Var) - (|>> /////name.normalize + (|>> ///////name.normalize (format ..prefix "$") _.var)) @@ -103,7 +104,7 @@ (wrap (list (` (let [(~+ (|> vars (list;map (function (_ var) (list (code.local-identifier var) - (` (_.var (~ (code.text (/////name.normalize var)))))))) + (` (_.var (~ (code.text (///////name.normalize var)))))))) list.concat))] (~ body)))))) @@ -734,10 +735,10 @@ (def: #export generate (Operation Any) - (///.with-buffer - (do ////.monad - [_ (///.save! true ["" ..prefix] - ($_ _.then - _.use-strict - ..runtime))] - (///.save-buffer! ..artifact)))) + (/////generation.with-buffer + (do ///////phase.monad + [_ (/////generation.save! true ["" ..prefix] + ($_ _.then + _.use-strict + ..runtime))] + (/////generation.save-buffer! ..artifact)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/structure.lux index c721c991c..a1f05d050 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/structure.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/structure.lux @@ -7,10 +7,11 @@ ["." // #_ ["#." runtime (#+ Operation Phase)] ["#." primitive] - ["#//" /// - ["#/" // #_ - [analysis (#+ Variant Tuple)] - ["#." synthesis (#+ Synthesis)]]]]) + ["///#" //// #_ + [analysis (#+ Variant Tuple)] + ["#." synthesis (#+ Synthesis)] + ["//#" /// + ["#." phase ("#@." monad)]]]]) (def: unit Expression (//primitive.text /////synthesis.unit)) @@ -18,21 +19,21 @@ (-> Phase (Tuple Synthesis) (Operation Expression)) (case elemsS+ #.Nil - (:: ////.monad wrap ..unit) + (///////phase@wrap ..unit) (#.Cons singletonS #.Nil) (generate singletonS) _ - (do ////.monad + (do ///////phase.monad [elemsT+ (monad.map @ generate elemsS+)] (wrap (_.array elemsT+))))) (def: #export (variant generate [lefts right? valueS]) (-> Phase (Variant Synthesis) (Operation Expression)) - (:: ////.monad map - (//runtime.variant (_.i32 (.int (if right? - (inc lefts) - lefts))) - (//runtime.flag right?)) - (generate valueS))) + (let [tag (if right? + (inc lefts) + lefts)] + (///////phase@map (//runtime.variant (_.i32 (.int tag)) + (//runtime.flag right?)) + (generate valueS)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux index 8a80953e9..e75c8e41e 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux @@ -6,11 +6,12 @@ [text ["%" format (#+ format)]]] [type (#+ :share)]] - ["." // - ["#/" // ("#@." monad) - ["#/" // #_ - [synthesis (#+ Synthesis)] - ["#." reference (#+ Register Variable Reference)]]]]) + ["." //// #_ + [synthesis (#+ Synthesis)] + ["#." generation] + ["//#" /// #_ + ["#." reference (#+ Register Variable Reference)] + ["#." phase ("#@." monad)]]]) (signature: #export (System expression) (: (-> Register expression) @@ -18,13 +19,13 @@ (: (-> Register expression) foreign) (: (All [anchor directive] - (-> Variable (//.Operation anchor expression directive))) + (-> Variable (////generation.Operation anchor expression directive))) variable) (: (All [anchor directive] - (-> Name (//.Operation anchor expression directive))) + (-> Name (////generation.Operation anchor expression directive))) constant) (: (All [anchor directive] - (-> Reference (//.Operation anchor expression directive))) + (-> Reference (////generation.Operation anchor expression directive))) reference)) (def: (variable-maker prefix variable) @@ -33,17 +34,16 @@ (-> Register expression))) (|>> %.nat (format prefix) variable)) -(def: #export foreign - (All [expression] - (-> (-> Text expression) - (-> Register expression))) - (variable-maker "f")) +(template [ ] + [(def: #export + (All [expression] + (-> (-> Text expression) + (-> Register expression))) + (variable-maker ))] -(def: #export local - (All [expression] - (-> (-> Text expression) - (-> Register expression))) - (variable-maker "l")) + ["f" foreign] + ["l" local] + ) (def: #export (system constant variable) (All [expression] @@ -55,27 +55,27 @@ {(-> Text expression) variable} {(All [anchor directive] - (-> Variable (//.Operation anchor expression directive))) - (|>> (case> (#////reference.Local register) + (-> Variable (////generation.Operation anchor expression directive))) + (|>> (case> (#//////reference.Local register) (local register) - (#////reference.Foreign register) + (#//////reference.Foreign register) (foreign register)) - ///@wrap)}) + //////phase@wrap)}) constant (:share [expression] {(-> Text expression) constant} {(All [anchor directive] - (-> Name (//.Operation anchor expression directive))) - (|>> //.remember (///@map constant))})] + (-> Name (////generation.Operation anchor expression directive))) + (|>> ////generation.remember (//////phase@map constant))})] (structure (def: local local) (def: foreign foreign) (def: variable variable) (def: constant constant) (def: reference - (|>> (case> (#////reference.Constant value) + (|>> (case> (#//////reference.Constant value) (constant value) - (#////reference.Variable value) + (#//////reference.Variable value) (variable value))))))) diff --git a/stdlib/source/test/lux/abstract.lux b/stdlib/source/test/lux/abstract.lux index 4d37ed458..cbc89fce9 100644 --- a/stdlib/source/test/lux/abstract.lux +++ b/stdlib/source/test/lux/abstract.lux @@ -2,10 +2,12 @@ [lux #* ["_" test (#+ Test)]] ["." / #_ + ["#." codec] ["#." interval]]) (def: #export test Test ($_ _.and + /codec.test /interval.test )) diff --git a/stdlib/source/test/lux/abstract/codec.lux b/stdlib/source/test/lux/abstract/codec.lux index b6bbdd91e..84a3997b3 100644 --- a/stdlib/source/test/lux/abstract/codec.lux +++ b/stdlib/source/test/lux/abstract/codec.lux @@ -5,7 +5,12 @@ [control ["." try]] [data - ["%" text/format (#+ format)]] + ["." bit ("#@." equivalence)] + ["%" text/format (#+ format)] + [format + ["." json (#+ JSON)]] + [collection + [dictionary]]] [math ["r" random (#+ Random)]]] {1 @@ -13,6 +18,35 @@ [// [equivalence (#+ Equivalence)]]]}) +(def: json + (Codec JSON Bit) + (let [field "value"] + (structure + (def: encode + (|>> #json.Boolean + [field] + list + (json.object))) + (def: decode + (json.get-boolean field))))) + +(def: codec + (Codec Text Bit) + (/.compose json.codec ..json)) + +(def: #export test + Test + (do r.monad + [expected r.bit] + (<| (_.context (%.name (name-of /.Codec))) + (_.test "Composition." + (case (|> expected (:: ..codec encode) (:: ..codec decode)) + (#try.Success actual) + (bit@= expected actual) + + (#try.Failure error) + false))))) + (def: #export (spec (^open "/@.") (^open "/@.") generator) (All [m a] (-> (Equivalence a) (Codec m a) (Random a) Test)) (do r.monad diff --git a/stdlib/source/test/lux/extension.lux b/stdlib/source/test/lux/extension.lux index 23c33c620..6160294c4 100644 --- a/stdlib/source/test/lux/extension.lux +++ b/stdlib/source/test/lux/extension.lux @@ -14,12 +14,14 @@ ["%" format (#+ format)]]] [tool [compiler - ["." analysis] - ["." synthesis] - ["." directive] - [phase - [analysis - ["." type]]]]] + [language + [lux + ["." analysis] + ["." synthesis] + ["." directive] + [phase + [analysis + ["." type]]]]]]] ["_" test (#+ Test)]] {1 ["." / (#+ analysis: synthesis: generation: directive:)]}) -- cgit v1.2.3