diff options
Diffstat (limited to '')
21 files changed, 2052 insertions, 12 deletions
diff --git a/stdlib/source/lux/target/r.lux b/stdlib/source/lux/target/r.lux new file mode 100644 index 000000000..c60456ad2 --- /dev/null +++ b/stdlib/source/lux/target/r.lux @@ -0,0 +1,378 @@ +(.module: + [lux (#- Code or and list if function cond not int) + [control + [pipe (#+ case> cond> new>)] + ["." function] + [parser + ["<.>" code]]] + [data + ["." maybe ("#\." functor)] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [macro + [syntax (#+ syntax:)] + ["." template] + ["." code]] + [math + [number + ["f" frac]]] + [type + abstract]]) + +(abstract: #export (Code kind) + Text + + {} + + (template [<type> <super>+] + [(with_expansions [<kind> (template.identifier [<type> "'"])] + (abstract: #export (<kind> kind) Any) + (`` (type: #export <type> (|> Any <kind> (~~ (template.splice <super>+))))))] + + [Expression [Code]] + ) + + (template [<type> <super>+] + [(with_expansions [<kind> (template.identifier [<type> "'"])] + (abstract: #export (<kind> kind) Any) + (`` (type: #export (<type> <brand>) (|> <brand> <kind> (~~ (template.splice <super>+))))))] + + [Var [Expression' Code]] + ) + + (template [<var> <kind>] + [(abstract: #export <kind> Any) + (type: #export <var> (Var <kind>))] + + [SVar Single] + [PVar Poly] + ) + + (def: #export var + (-> Text SVar) + (|>> :abstraction)) + + (def: #export var_args + PVar + (:abstraction "...")) + + (def: #export manual + (-> Text Code) + (|>> :abstraction)) + + (def: #export code + (-> (Code Any) Text) + (|>> :representation)) + + (def: (self_contained code) + (-> Text Expression) + (:abstraction + (format "(" code ")"))) + + (def: nest + (-> Text Text) + (let [nested_new_line (format text.new_line text.tab)] + (|>> (format text.new_line) + (text.replace_all text.new_line nested_new_line)))) + + (def: (_block expression) + (-> Text Text) + (format "{" (nest expression) text.new_line "}")) + + (def: #export (block expression) + (-> Expression Expression) + (:abstraction + (format "{" (:representation expression) "}"))) + + (template [<name> <r>] + [(def: #export <name> + Expression + (..self_contained <r>))] + + [null "NULL"] + [n/a "NA"] + ) + + (template [<name>] + [(def: #export <name> Expression n/a)] + + [not_available] + [not_applicable] + [no_answer] + ) + + (def: #export bool + (-> Bit Expression) + (|>> (case> #0 "FALSE" + #1 "TRUE") + ..self_contained)) + + (def: #export (int value) + (-> Int Expression) + (..self_contained (format "as.integer(" (%.int value) ")"))) + + (def: #export float + (-> Frac Expression) + (|>> (cond> [(f.= f.positive_infinity)] + [(new> "1.0/0.0" [])] + + [(f.= f.negative_infinity)] + [(new> "-1.0/0.0" [])] + + [(f.= f.not_a_number)] + [(new> "0.0/0.0" [])] + + ## else + [%.frac]) + ..self_contained)) + + (def: sanitize + (-> Text Text) + (`` (|>> (~~ (template [<find> <replace>] + [(text.replace_all <find> <replace>)] + + ["\" "\\"] + ["|" "\|"] + [text.alarm "\a"] + [text.back_space "\b"] + [text.tab "\t"] + [text.new_line "\n"] + [text.carriage_return "\r"] + [text.double_quote (format "\" text.double_quote)] + )) + ))) + + (def: #export string + (-> Text Expression) + (|>> %.text ..sanitize ..self_contained)) + + (def: (composite_literal left_delimiter right_delimiter entry_serializer) + (All [a] (-> Text Text (-> a Text) + (-> (List a) Expression))) + (.function (_ entries) + (..self_contained + (format left_delimiter + (|> entries (list\map entry_serializer) (text.join_with ",")) + right_delimiter)))) + + (def: #export named_list + (-> (List [Text Expression]) Expression) + (composite_literal "list(" ")" (.function (_ [key value]) + (format key "=" (:representation value))))) + + (template [<name> <function>] + [(def: #export <name> + (-> (List Expression) Expression) + (composite_literal (format <function> "(") ")" ..code))] + + [vector "c"] + [list "list"] + ) + + (def: #export (slice from to list) + (-> Expression Expression Expression Expression) + (..self_contained + (format (:representation list) + "[" (:representation from) ":" (:representation to) "]"))) + + (def: #export (slice_from from list) + (-> Expression Expression Expression) + (..self_contained + (format (:representation list) + "[-1" ":-" (:representation from) "]"))) + + (def: #export (apply args func) + (-> (List Expression) Expression Expression) + (..self_contained + (format (:representation func) "(" (text.join_with "," (list\map ..code args)) ")"))) + + (def: #export (apply_kw args kw_args func) + (-> (List Expression) (List [Text Expression]) Expression Expression) + (..self_contained + (format (:representation func) + (format "(" + (text.join_with "," (list\map ..code args)) "," + (text.join_with "," (list\map (.function (_ [key val]) + (format key "=" (:representation val))) + kw_args)) + ")")))) + + (syntax: (arity_inputs {arity <code>.nat}) + (wrap (case arity + 0 (.list) + _ (|> arity + list.indices + (list\map (|>> %.nat code.local_identifier)))))) + + (syntax: (arity_types {arity <code>.nat}) + (wrap (list.repeat arity (` ..Expression)))) + + (template [<arity> <function>+] + [(with_expansions [<apply> (template.identifier ["apply/" <arity>]) + <inputs> (arity_inputs <arity>) + <types> (arity_types <arity>) + <definitions> (template.splice <function>+)] + (def: #export (<apply> function [<inputs>]) + (-> Expression [<types>] Expression) + (..apply (.list <inputs>) function)) + + (template [<function>] + [(`` (def: #export (~~ (template.identifier [<function> "/" <arity>])) + (-> [<types>] Expression) + (<apply> (..var <function>))))] + + <definitions>))] + + [0 + [["commandArgs"]]] + [1 + []] + [2 + []] + ) + + (def: #export (nth idx list) + (-> Expression Expression Expression) + (..self_contained + (format (:representation list) "[[" (:representation idx) "]]"))) + + (def: #export (if test then else) + (-> Expression Expression Expression Expression) + (..self_contained + (format "if(" (:representation test) ")" + " " (.._block (:representation then)) + " else " (.._block (:representation else))))) + + (def: #export (when test then) + (-> Expression Expression Expression) + (..self_contained + (format "if(" (:representation test) ") {" + (.._block (:representation then)) + text.new_line "}"))) + + (def: #export (cond clauses else) + (-> (List [Expression Expression]) Expression Expression) + (list\fold (.function (_ [test then] next) + (if test then next)) + else + (list.reverse clauses))) + + (template [<name> <op>] + [(def: #export (<name> param subject) + (-> Expression Expression Expression) + (..self_contained + (format (:representation subject) + " " <op> " " + (:representation param))))] + + [= "=="] + [< "<"] + [<= "<="] + [> ">"] + [>= ">="] + [+ "+"] + [- "-"] + [* "*"] + [/ "/"] + [%% "%%"] + [** "**"] + [or "||"] + [and "&&"] + ) + + (template [<name> <func>] + [(def: #export (<name> param subject) + (-> Expression Expression Expression) + (..apply (.list subject param) (..var <func>)))] + + [bit_or "bitwOr"] + [bit_and "bitwAnd"] + [bit_xor "bitwXor"] + [bit_shl "bitwShiftL"] + [bit_ushr "bitwShiftR"] + ) + + (def: #export (bit_not subject) + (-> Expression Expression) + (..apply (.list subject) (..var "bitwNot"))) + + (template [<name> <op>] + [(def: #export <name> + (-> Expression Expression) + (|>> :representation (format <op>) ..self_contained))] + + [not "!"] + [negate "-"] + ) + + (def: #export (length list) + (-> Expression Expression) + (..apply (.list list) (..var "length"))) + + (def: #export (range from to) + (-> Expression Expression Expression) + (..self_contained + (format (:representation from) ":" (:representation to)))) + + (def: #export (function inputs body) + (-> (List (Ex [k] (Var k))) Expression Expression) + (let [args (|> inputs (list\map ..code) (text.join_with ", "))] + (..self_contained + (format "function(" args ") " + (.._block (:representation body)))))) + + (def: #export (try body warning error finally) + (-> Expression (Maybe Expression) (Maybe Expression) (Maybe Expression) Expression) + (let [optional (: (-> Text (Maybe Expression) (-> Text Text) Text) + (.function (_ parameter value preparation) + (|> value + (maybe\map (|>> :representation preparation (format ", " parameter " = "))) + (maybe.default ""))))] + (..self_contained + (format "tryCatch(" + (.._block (:representation body)) + (optional "warning" warning function.identity) + (optional "error" error function.identity) + (optional "finally" finally .._block) + ")")))) + + (def: #export (while test body) + (-> Expression Expression Expression) + (..self_contained + (format "while (" (:representation test) ") " + (.._block (:representation body))))) + + (def: #export (for_in var inputs body) + (-> SVar Expression Expression Expression) + (..self_contained + (format "for (" (:representation var) " in " (:representation inputs) ")" + (.._block (:representation body))))) + + (template [<name> <keyword>] + [(def: #export (<name> message) + (-> Expression Expression) + (..apply (.list message) (..var <keyword>)))] + + [stop "stop"] + [print "print"] + ) + + (def: #export (set! var value) + (-> SVar Expression Expression) + (..self_contained + (format (:representation var) " <- " (:representation value)))) + + (def: #export (set_nth! idx value list) + (-> Expression Expression SVar Expression) + (..self_contained + (format (:representation list) "[[" (:representation idx) "]] <- " (:representation value)))) + + (def: #export (then pre post) + (-> Expression Expression Expression) + (:abstraction + (format (:representation pre) + text.new_line + (:representation post)))) + ) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux new file mode 100644 index 000000000..12f578ed2 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux @@ -0,0 +1,34 @@ +(.module: + [lux #* + ["." ffi] + [abstract + ["." monad (#+ do)]] + [control + ["<>" parser + ["<c>" code (#+ Parser)]]] + [data + [collection + ["." array (#+ Array)] + ["." dictionary] + ["." list]]] + ["." type + ["." check]] + ["@" target + ["_" r]]] + [// + ["/" lux (#+ custom)] + [// + ["." bundle] + [// + ["." analysis #_ + ["#/." type]] + [// + ["." analysis (#+ Analysis Operation Phase Handler Bundle)] + [/// + ["." phase]]]]]]) + +(def: #export bundle + Bundle + (<| (bundle.prefix "r") + (|> bundle.empty + ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r.lux new file mode 100644 index 000000000..cd0f6b7cc --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r.lux @@ -0,0 +1,17 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + ["." / #_ + ["#." common] + ["#." host] + [//// + [generation + [r + [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/r/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux new file mode 100644 index 000000000..cb82c6cb4 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux @@ -0,0 +1,179 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["." try] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." dictionary] + ["." set] + ["." list ("#\." functor fold)]]] + [math + [number + ["f" frac]]] + ["@" target + ["_" r (#+ Expression)]]] + ["." //// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["." reference] + ["//" r #_ + ["#." runtime (#+ Operation Phase Handler Bundle Generator)] + ["#." case]]] + [// + ["." synthesis (#+ %synthesis)] + ["." generation] + [/// + ["#" phase]]]]]) + +(def: #export (custom [parser handler]) + (All [s] + (-> [(Parser s) + (-> Text (Generator s))] + Handler)) + (function (_ extension_name phase archive input) + (case (<s>.run parser input) + (#try.Success input') + (handler extension_name phase archive input') + + (#try.Failure error) + (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) + +## (template: (!unary function) +## (|>> list _.apply/* (|> (_.constant function)))) + +## ## ## TODO: Get rid of this ASAP +## ## (def: lux::syntax_char_case! +## ## (..custom [($_ <>.and +## ## <s>.any +## ## <s>.any +## ## (<>.some (<s>.tuple ($_ <>.and +## ## (<s>.tuple (<>.many <s>.i64)) +## ## <s>.any)))) +## ## (function (_ extension_name phase archive [input else conditionals]) +## ## (do {! /////.monad} +## ## [@input (\ ! map _.var (generation.gensym "input")) +## ## inputG (phase archive input) +## ## elseG (phase archive else) +## ## conditionalsG (: (Operation (List [Expression Expression])) +## ## (monad.map ! (function (_ [chars branch]) +## ## (do ! +## ## [branchG (phase archive branch)] +## ## (wrap [(|> chars (list\map (|>> .int _.int (_.=/2 @input))) _.or) +## ## branchG]))) +## ## conditionals))] +## ## (wrap (_.let (list [@input inputG]) +## ## (list (list\fold (function (_ [test then] else) +## ## (_.if test then else)) +## ## elseG +## ## conditionalsG))))))])) + +## (def: lux_procs +## Bundle +## (|> /.empty +## ## (/.install "syntax char case!" lux::syntax_char_case!) +## (/.install "is" (binary _.eq/2)) +## ## (/.install "try" (unary //runtime.lux//try)) +## )) + +## ## (def: (capped operation parameter subject) +## ## (-> (-> Expression Expression Expression) +## ## (-> Expression Expression Expression)) +## ## (//runtime.i64//64 (operation parameter subject))) + +## (def: i64_procs +## Bundle +## (<| (/.prefix "i64") +## (|> /.empty +## (/.install "and" (binary _.logand/2)) +## (/.install "or" (binary _.logior/2)) +## (/.install "xor" (binary _.logxor/2)) +## (/.install "left-shift" (binary _.ash/2)) +## (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) +## (/.install "=" (binary _.=/2)) +## (/.install "<" (binary _.</2)) +## (/.install "+" (binary _.+/2)) +## (/.install "-" (binary _.-/2)) +## (/.install "*" (binary _.*/2)) +## (/.install "/" (binary _.floor/2)) +## (/.install "%" (binary _.rem/2)) +## ## (/.install "f64" (unary (_.//2 (_.float +1.0)))) +## (/.install "char" (unary (|>> _.code-char/1 _.string/1))) +## ))) + +## (def: f64_procs +## Bundle +## (<| (/.prefix "f64") +## (|> /.empty +## ## (/.install "=" (binary (product.uncurry _.=/2))) +## ## (/.install "<" (binary (product.uncurry _.</2))) +## ## (/.install "+" (binary (product.uncurry _.+/2))) +## ## (/.install "-" (binary (product.uncurry _.-/2))) +## ## (/.install "*" (binary (product.uncurry _.*/2))) +## ## (/.install "/" (binary (product.uncurry _.//2))) +## ## (/.install "%" (binary (product.uncurry _.rem/2))) +## ## (/.install "i64" (unary _.truncate/1)) +## (/.install "encode" (unary _.write-to-string/1)) +## ## (/.install "decode" (unary //runtime.f64//decode)) +## ))) + +## (def: (text//index [offset sub text]) +## (Trinary (Expression Any)) +## (//runtime.text//index offset sub text)) + +## (def: (text//clip [offset length text]) +## (Trinary (Expression Any)) +## (//runtime.text//clip offset length text)) + +## (def: (text//char [index text]) +## (Binary (Expression Any)) +## (_.char-code/1 (_.char/2 [text index]))) + +## (def: text_procs +## Bundle +## (<| (/.prefix "text") +## (|> /.empty +## (/.install "=" (binary _.string=/2)) +## ## (/.install "<" (binary (product.uncurry _.string<?/2))) +## (/.install "concat" (binary (function (_ [left right]) +## (_.concatenate/3 [(_.symbol "string") left right])))) +## (/.install "index" (trinary ..text//index)) +## (/.install "size" (unary _.length/1)) +## (/.install "char" (binary ..text//char)) +## (/.install "clip" (trinary ..text//clip)) +## ))) + +## (def: (io//log! message) +## (Unary (Expression Any)) +## (_.progn (list (_.write-line/1 message) +## //runtime.unit))) + +## (def: io_procs +## Bundle +## (<| (/.prefix "io") +## (|> /.empty +## (/.install "log" (unary ..io//log!)) +## (/.install "error" (unary _.error/1)) +## ))) + +(def: #export bundle + Bundle + (<| (/.prefix "lux") + (|> /.empty + ## (dictionary.merge 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/r/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux new file mode 100644 index 000000000..2d9148dda --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux @@ -0,0 +1,39 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + [collection + ["." dictionary] + ["." list]] + [text + ["%" format (#+ format)]]] + [target + ["_" r (#+ Var Expression)]]] + ["." // #_ + ["#." common (#+ custom)] + ["//#" /// #_ + ["/" bundle] + ["/#" // #_ + ["." extension] + [generation + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["." reference] + ["//" r #_ + ["#." runtime (#+ Operation Phase Handler Bundle + with_vars)]]] + ["/#" // #_ + ["." generation] + ["//#" /// #_ + ["#." phase]]]]]]) + +(def: #export bundle + Bundle + (<| (/.prefix "r") + (|> /.empty + ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r.lux new file mode 100644 index 000000000..b4b3e6423 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r.lux @@ -0,0 +1,58 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]] + [target + ["_" r]]] + ["." / #_ + [runtime (#+ Phase)] + ["#." primitive] + ["#." structure] + ["#." reference] + ["#." case] + ["#." loop] + ["#." function] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + ["#." extension] + ["/#" // #_ + [analysis (#+)] + ["#." synthesis] + ["//#" /// #_ + ["#." phase ("#\." monad)] + [reference (#+) + [variable (#+)]]]]]]]) + +(def: #export (generate archive synthesis) + Phase + (case synthesis + (^template [<tag> <generator>] + [(^ (<tag> value)) + (//////phase\wrap (<generator> value))]) + ([////synthesis.bit /primitive.bit] + [////synthesis.i64 /primitive.i64] + [////synthesis.f64 /primitive.f64] + [////synthesis.text /primitive.text]) + + (#////synthesis.Reference value) + (//reference.reference /reference.system archive value) + + (^template [<tag> <generator>] + [(^ (<tag> value)) + (<generator> generate archive value)]) + ([////synthesis.variant /structure.variant] + [////synthesis.tuple /structure.tuple] + [////synthesis.branch/let /case.let] + [////synthesis.branch/if /case.if] + [////synthesis.branch/get /case.get] + [////synthesis.function/apply /function.apply] + + [////synthesis.branch/case /case.case] + [////synthesis.loop/scope /loop.scope] + [////synthesis.loop/recur /loop.recur] + [////synthesis.function/abstraction /function.function]) + + (#////synthesis.Extension extension) + (///extension.apply archive generate extension) + )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/case.lux new file mode 100644 index 000000000..fe4e4a7c2 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/case.lux @@ -0,0 +1,239 @@ +(.module: + [lux (#- case let if) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)] + ["." set]]] + [macro + ["." template]] + [math + [number + ["i" int]]] + [target + ["_" r (#+ Expression SVar)]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." reference] + ["#." primitive] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + ["#." synthesis #_ + ["#/." case]] + ["/#" // #_ + ["#." synthesis (#+ Member Synthesis Path)] + ["#." generation] + ["//#" /// #_ + [reference + ["#." variable (#+ Register)]] + ["#." phase ("#\." monad)] + [meta + [archive (#+ Archive)]]]]]]]) + +(def: #export register + (-> Register SVar) + (|>> (///reference.local //reference.system) :assume)) + +(def: #export capture + (-> Register SVar) + (|>> (///reference.foreign //reference.system) :assume)) + +(def: #export (let expression archive [valueS register bodyS]) + (Generator [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (expression archive bodyS)] + (wrap (_.block + ($_ _.then + (_.set! (..register register) valueO) + bodyO))))) + +(def: #export (if expression archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testO (expression archive testS) + thenO (expression archive thenS) + elseO (expression archive elseS)] + (wrap (_.if testO thenO elseO)))) + +(def: #export (get expression archive [pathP valueS]) + (Generator [(List Member) Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS)] + (wrap (list\fold (function (_ side source) + (.let [method (.case side + (^template [<side> <accessor>] + [(<side> lefts) + (<accessor> (_.int (.int lefts)))]) + ([#.Left //runtime.tuple::left] + [#.Right //runtime.tuple::right]))] + (method source))) + valueO + (list.reverse pathP))))) + +(def: $savepoint (_.var "lux_pm_cursor_savepoint")) +(def: $cursor (_.var "lux_pm_cursor")) +(def: $temp (_.var "lux_pm_temp")) +(def: $alt_error (_.var "alt_error")) + +(def: top + _.length) + +(def: next + (|>> _.length (_.+ (_.int +1)))) + +(def: (push! value var) + (-> Expression SVar Expression) + (_.set_nth! (next var) value var)) + +(def: (pop! var) + (-> SVar Expression) + (_.set_nth! (top var) _.null var)) + +(def: (push_cursor! value) + (-> Expression Expression) + (push! value $cursor)) + +(def: save_cursor! + Expression + (push! (_.slice (_.float +1.0) (_.length $cursor) $cursor) + $savepoint)) + +(def: restore_cursor! + Expression + (_.set! $cursor (_.nth (top $savepoint) $savepoint))) + +(def: peek + Expression + (|> $cursor (_.nth (top $cursor)))) + +(def: pop_cursor! + Expression + (pop! $cursor)) + +(def: error + (_.string (template.with_locals [error] + (template.text [error])))) + +(def: fail! + (_.stop ..error)) + +(def: (catch handler) + (-> Expression Expression) + (_.function (list $alt_error) + (_.if (|> $alt_error (_.= ..error)) + handler + (_.stop $alt_error)))) + +(def: (pattern_matching' expression archive) + (Generator Path) + (function (recur pathP) + (.case pathP + (#/////synthesis.Then bodyS) + (expression archive bodyS) + + #/////synthesis.Pop + (///////phase\wrap ..pop_cursor!) + + (#/////synthesis.Bind register) + (///////phase\wrap (_.set! (..register register) ..peek)) + + (#/////synthesis.Bit_Fork when thenP elseP) + (do {! ///////phase.monad} + [then! (recur thenP) + else! (.case elseP + (#.Some elseP) + (recur elseP) + + #.None + (wrap ..fail!))] + (wrap (.if when + (_.if ..peek + then! + else!) + (_.if ..peek + else! + then!)))) + + (^template [<tag> <format> <=>] + [(<tag> cons) + (do {! ///////phase.monad} + [clauses (monad.map ! (function (_ [match then]) + (do ! + [then! (recur then)] + (wrap [(<=> (|> match <format>) + ..peek) + then!]))) + (#.Cons cons))] + (wrap (list\fold (function (_ [when then] else) + (_.if when then else)) + ..fail! + clauses)))]) + ([#/////synthesis.I64_Fork //primitive.i64 //runtime.i64::=] + [#/////synthesis.F64_Fork //primitive.f64 _.=] + [#/////synthesis.Text_Fork //primitive.text _.=]) + + (^template [<pm> <flag> <prep>] + [(^ (<pm> idx)) + (///////phase\wrap ($_ _.then + (_.set! $temp (|> idx <prep> .int _.int (//runtime.sum::get ..peek (//runtime.flag <flag>)))) + (_.if (_.= _.null $temp) + ..fail! + (..push_cursor! $temp))))]) + ([/////synthesis.side/left false (<|)] + [/////synthesis.side/right true inc]) + + (^ (/////synthesis.member/left 0)) + (///////phase\wrap (_.nth (_.int +1) ..peek)) + + (^template [<pm> <getter>] + [(^ (<pm> lefts)) + (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push_cursor!))]) + ([/////synthesis.member/left //runtime.tuple::left] + [/////synthesis.member/right //runtime.tuple::right]) + + (^ (/////synthesis.path/seq leftP rightP)) + (do ///////phase.monad + [leftO (recur leftP) + rightO (recur rightP)] + (wrap ($_ _.then + leftO + rightO))) + + (^ (/////synthesis.path/alt leftP rightP)) + (do {! ///////phase.monad} + [leftO (recur leftP) + rightO (recur rightP)] + (wrap (_.try ($_ _.then + ..save_cursor! + leftO) + #.None + (#.Some (..catch ($_ _.then + ..restore_cursor! + rightO))) + #.None))) + ))) + +(def: (pattern_matching expression archive pathP) + (Generator Path) + (do ///////phase.monad + [pattern_matching! (pattern_matching' expression archive pathP)] + (wrap (_.try pattern_matching! + #.None + (#.Some (..catch (_.stop (_.string "Invalid expression for pattern-matching.")))) + #.None)))) + +(def: #export (case expression archive [valueS pathP]) + (Generator [Synthesis Path]) + (do {! ///////phase.monad} + [valueO (expression archive valueS)] + (<| (\ ! map (|>> ($_ _.then + (_.set! $cursor (_.list (list valueO))) + (_.set! $savepoint (_.list (list)))) + _.block)) + (pattern_matching expression archive pathP)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/function.lux new file mode 100644 index 000000000..c89ffaf0a --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/function.lux @@ -0,0 +1,116 @@ +(.module: + [lux (#- function) + [abstract + ["." monad (#+ do)]] + [control + pipe] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [target + ["_" r (#+ Expression SVar)]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." reference] + ["#." case] + ["/#" // #_ + ["#." reference] + ["//#" /// #_ + [analysis (#+ Variant Tuple Abstraction Application Analysis)] + [synthesis (#+ Synthesis)] + ["#." generation (#+ Context)] + ["//#" /// #_ + [arity (#+ Arity)] + ["#." phase ("#\." monad)] + [reference + [variable (#+ Register Variable)]] + [meta + [archive + ["." artifact]]]]]]]) + +(def: #export (apply expression archive [functionS argsS+]) + (Generator (Application Synthesis)) + (do {! ///////phase.monad} + [functionO (expression archive functionS) + argsO+ (monad.map ! (expression archive) argsS+)] + (wrap (_.apply argsO+ functionO)))) + +(def: (with_closure function_id $function inits function_definition) + (-> artifact.ID SVar (List Expression) Expression (Operation Expression)) + (case inits + #.Nil + (do ///////phase.monad + [_ (/////generation.execute! function_definition) + _ (/////generation.save! (%.nat function_id) + function_definition)] + (wrap $function)) + + _ + (do ///////phase.monad + [#let [closure_definition (_.set! $function + (_.function (|> inits + list.size + list.indices + (list\map //case.capture)) + ($_ _.then + function_definition + $function)))] + _ (/////generation.execute! closure_definition) + _ (/////generation.save! (%.nat function_id) closure_definition)] + (wrap (_.apply inits $function))))) + +(def: $curried (_.var "curried")) +(def: $missing (_.var "missing")) + +(def: (input_declaration register) + (-> Register Expression) + (_.set! (|> register inc //case.register) + (|> $curried (_.nth (|> register inc .int _.int))))) + +(def: #export (function expression archive [environment arity bodyS]) + (Generator (Abstraction Synthesis)) + (do {! ///////phase.monad} + [[[function_module function_artifact] bodyO] (/////generation.with_new_context archive + (do ! + [$self (\ ! map (|>> ///reference.artifact _.var) + (/////generation.context archive))] + (/////generation.with_anchor $self + (expression archive bodyS)))) + closureO+ (monad.map ! (expression archive) environment) + #let [arityO (|> arity .int _.int) + $num_args (_.var "num_args") + $self (_.var (///reference.artifact [function_module function_artifact])) + apply_poly (.function (_ args func) + (_.apply (list func args) (_.var "do.call")))]] + (with_closure function_artifact $self closureO+ + (_.set! $self (_.function (list _.var_args) + ($_ _.then + (_.set! $curried (_.list (list _.var_args))) + (_.set! $num_args (_.length $curried)) + (_.cond (list [(|> $num_args (_.= arityO)) + ($_ _.then + (_.set! (//case.register 0) $self) + (|> arity + list.indices + (list\map input_declaration) + (list\fold _.then bodyO)))] + [(|> $num_args (_.> arityO)) + (let [arity_args (_.slice (_.int +1) arityO $curried) + output_func_args (_.slice (|> arityO (_.+ (_.int +1))) + $num_args + $curried)] + (|> $self + (apply_poly arity_args) + (apply_poly output_func_args)))]) + ## (|> $num_args (_.< arityO)) + (let [$missing (_.var "missing")] + (_.function (list _.var_args) + ($_ _.then + (_.set! $missing (_.list (list _.var_args))) + (|> $self + (apply_poly (_.apply (list $curried $missing) + (_.var "append")))))))))))) + )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/loop.lux new file mode 100644 index 000000000..c8f8bd1d5 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/loop.lux @@ -0,0 +1,64 @@ +(.module: + [lux (#- Scope) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)] + ["." set (#+ Set)]]] + [math + [number + ["n" nat]]] + [target + ["_" r]]] + ["." // #_ + [runtime (#+ Operation Phase Generator)] + ["#." case] + ["/#" // #_ + ["#." reference] + ["/#" // #_ + [synthesis + ["." case]] + ["/#" // #_ + ["."synthesis (#+ Scope Synthesis)] + ["#." generation] + ["//#" /// #_ + ["#." phase] + [meta + [archive (#+ Archive)]] + [reference + [variable (#+ Register)]]]]]]]) + +(def: #export (scope expression archive [offset initsS+ bodyS]) + (Generator (Scope Synthesis)) + (case initsS+ + ## function/false/non-independent loop + #.Nil + (expression archive bodyS) + + ## true loop + _ + (do {! ///////phase.monad} + [$scope (\ ! map _.var (/////generation.gensym "loop_scope")) + initsO+ (monad.map ! (expression archive) initsS+) + bodyO (/////generation.with_anchor $scope + (expression archive bodyS))] + (wrap (_.block + ($_ _.then + (_.set! $scope + (_.function (|> initsS+ + list.size + list.indices + (list\map (|>> (n.+ offset) //case.register))) + bodyO)) + (_.apply initsO+ $scope))))))) + +(def: #export (recur expression archive argsS+) + (Generator (List Synthesis)) + (do {! ///////phase.monad} + [$scope /////generation.anchor + argsO+ (monad.map ! (expression archive) argsS+)] + (wrap (_.apply argsO+ $scope)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux new file mode 100644 index 000000000..efbd569f4 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux @@ -0,0 +1,17 @@ +(.module: + [lux (#- i64) + [target + ["_" r (#+ Expression)]]] + ["." // #_ + ["#." runtime]]) + +(template [<name> <type> <code>] + [(def: #export <name> + (-> <type> Expression) + <code>)] + + [bit Bit _.bool] + [i64 (I64 Any) (|>> .int //runtime.i64)] + [f64 Frac _.float] + [text Text _.string] + ) diff --git a/lux-r/source/luxc/lang/translation/r/procedure/common.jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux index 85ccd90dc..85ccd90dc 100644 --- a/lux-r/source/luxc/lang/translation/r/procedure/common.jvm.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux diff --git a/lux-r/source/luxc/lang/translation/r/procedure/host.jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux index 3bd33955f..3bd33955f 100644 --- a/lux-r/source/luxc/lang/translation/r/procedure/host.jvm.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/reference.lux new file mode 100644 index 000000000..c3f2e8289 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/reference.lux @@ -0,0 +1,12 @@ +(.module: + [lux #* + [target + ["_" r (#+ Expression)]]] + [/// + [reference (#+ System)]]) + +(structure: #export system + (System Expression) + + (def: constant _.var) + (def: variable _.var)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux new file mode 100644 index 000000000..1b7119378 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux @@ -0,0 +1,848 @@ +(.module: + [lux (#- Location inc i64) + ["." meta] + [abstract + ["." monad (#+ do)]] + [control + ["." function] + ["<>" parser + ["<.>" code]]] + [data + ["." product] + ["." text ("#\." hash) + ["%" format (#+ format)] + [encoding + ["." utf8]]] + [collection + ["." list ("#\." functor)] + ["." row]]] + ["." macro + [syntax (#+ syntax:)] + ["." code]] + [math + [number (#+ hex) + ["n" nat] + ["i" int ("#\." interval)] + ["." i64]]] + ["@" target + ["_" r (#+ SVar Expression)]]] + ["." /// #_ + ["#." reference] + ["//#" /// #_ + [analysis (#+ Variant)] + ["#." synthesis (#+ Synthesis)] + ["#." generation] + ["//#" /// + ["#." phase] + [reference + [variable (#+ Register)]] + [meta + [archive (#+ Output Archive) + ["." artifact (#+ Registry)]]]]]]) + +(def: module_id + 0) + +(template [<name> <base>] + [(type: #export <name> + (<base> _.SVar _.Expression _.Expression))] + + [Operation /////generation.Operation] + [Phase /////generation.Phase] + [Handler /////generation.Handler] + [Bundle /////generation.Bundle] + ) + +(type: #export (Generator i) + (-> Phase Archive i (Operation Expression))) + +(def: #export unit + Expression + (_.string /////synthesis.unit)) + +(def: full_32 (hex "FFFFFFFF")) +(def: half_32 (hex "7FFFFFFF")) +(def: post_32 (hex "100000000")) + +(def: (cap_32 input) + (-> Nat Int) + (cond (n.> full_32 input) + (|> input (i64.and full_32) cap_32) + + (n.> half_32 input) + (|> post_32 (n.- input) .int (i.* -1)) + + ## else + (.int input))) + +(def: high_32 + (-> Nat Nat) + (i64.right_shift 32)) + +(def: low_32 + (-> Nat Nat) + (|>> (i64.and (hex "FFFFFFFF")))) + +(def: #export i64_high_field "luxIH") +(def: #export i64_low_field "luxIL") + +(def: #export (i64 value) + (-> Int Expression) + (let [value (.nat value) + high (|> value ..high_32 ..cap_32) + low (|> value ..low_32 ..cap_32)] + (_.named_list (list [..i64_high_field (_.int high)] + [..i64_low_field (_.int low)])))) + +(def: #export variant_tag_field "luxVT") +(def: #export variant_flag_field "luxVF") +(def: #export variant_value_field "luxVV") + +(def: #export (flag value) + (-> Bit Expression) + (if value + (_.string "") + _.null)) + +(def: (variant' tag last? value) + (-> Expression Expression Expression Expression) + (_.named_list (list [..variant_tag_field tag] + [..variant_flag_field last?] + [..variant_value_field value]))) + +(def: #export (variant tag last? value) + (-> Nat Bit Expression Expression) + (variant' (_.int (.int tag)) + (flag last?) + value)) + +(def: #export none + Expression + (variant 0 #0 ..unit)) + +(def: #export some + (-> Expression Expression) + (variant 1 #1)) + +(def: #export left + (-> Expression Expression) + (variant 0 #0)) + +(def: #export right + (-> Expression Expression) + (variant 1 #1)) + +(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} + body) + (do {! meta.monad} + [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] + (wrap (list (` (let [(~+ (|> vars + (list.zip/2 ids) + (list\map (function (_ [id var]) + (list (code.local_identifier var) + (` (_.var (~ (code.text (format "v" (%.nat id))))))))) + list.concat))] + (~ body))))))) + +(syntax: (runtime: {declaration (<>.or <code>.local_identifier + (<code>.form (<>.and <code>.local_identifier + (<>.some <code>.local_identifier))))} + code) + (do meta.monad + [runtime_id meta.count] + (macro.with_gensyms [g!_] + (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id])) + runtime_name (` (_.var (~ (code.text (%.code runtime)))))] + (case declaration + (#.Left name) + (let [g!name (code.local_identifier name)] + (wrap (list (` (def: #export (~ g!name) + _.SVar + (~ runtime_name))) + + (` (def: (~ (code.local_identifier (format "@" name))) + _.Expression + (_.set! (~ runtime_name) (~ code))))))) + + (#.Right [name inputs]) + (let [g!name (code.local_identifier name) + inputsC (list\map code.local_identifier inputs) + inputs_typesC (list\map (function.constant (` _.Expression)) + inputs)] + (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) + (-> (~+ inputs_typesC) _.Expression) + (_.apply (list (~+ inputsC)) (~ runtime_name)))) + + (` (def: (~ (code.local_identifier (format "@" name))) + _.Expression + (..with_vars [(~+ inputsC)] + (_.set! (~ runtime_name) + (_.function (list (~+ inputsC)) + (~ code)))))))))))))) + +(def: high_shift (_.bit_shl (_.int +32))) + +(runtime: f2^32 (|> (_.int +2) (_.** (_.int +32)))) +(runtime: f2^63 (|> (_.int +2) (_.** (_.int +63)))) + +(def: (as_double value) + (-> Expression Expression) + (_.apply (list value) (_.var "as.double"))) + +(def: (as_integer value) + (-> Expression Expression) + (_.apply (list value) (_.var "as.integer"))) + +(runtime: (i64::unsigned_low input) + (with_vars [low] + ($_ _.then + (_.set! low (|> input (_.nth (_.string ..i64_low_field)))) + (_.if (|> low (_.>= (_.int +0))) + low + (|> low (_.+ f2^32)))))) + +(runtime: (i64::to_float input) + (let [high (|> input + (_.nth (_.string ..i64_high_field)) + high_shift) + low (|> input + i64::unsigned_low)] + (|> high (_.+ low) as_double))) + +(runtime: (i64::new high low) + (_.named_list (list [..i64_high_field (as_integer high)] + [..i64_low_field (as_integer low)]))) + +(template [<name> <value>] + [(runtime: <name> + (..i64 <value>))] + + [i64::zero +0] + [i64::one +1] + [i64::min i\bottom] + [i64::max i\top] + ) + +(def: #export i64_high (_.nth (_.string ..i64_high_field))) +(def: #export i64_low (_.nth (_.string ..i64_low_field))) + +(runtime: (i64::not input) + (i64::new (|> input i64_high _.bit_not) + (|> input i64_low _.bit_not))) + +(runtime: (i64::+ param subject) + (with_vars [sH sL pH pL + x00 x16 x32 x48] + ($_ _.then + (_.set! sH (|> subject i64_high)) + (_.set! sL (|> subject i64_low)) + (_.set! pH (|> param i64_high)) + (_.set! pL (|> param i64_low)) + (let [bits16 (_.manual "0xFFFF") + move_top_16 (_.bit_shl (_.int +16)) + top_16 (_.bit_ushr (_.int +16)) + bottom_16 (_.bit_and bits16) + split_16 (function (_ source) + [(|> source top_16) + (|> source bottom_16)]) + split_int (function (_ high low) + [(split_16 high) + (split_16 low)]) + + [[s48 s32] [s16 s00]] (split_int sH sL) + [[p48 p32] [p16 p00]] (split_int pH pL) + new_half (function (_ top bottom) + (|> top bottom_16 move_top_16 + (_.bit_or (bottom_16 bottom))))] + ($_ _.then + (_.set! x00 (|> s00 (_.+ p00))) + (_.set! x16 (|> x00 top_16 (_.+ s16) (_.+ p16))) + (_.set! x32 (|> x16 top_16 (_.+ s32) (_.+ p32))) + (_.set! x48 (|> x32 top_16 (_.+ s48) (_.+ p48))) + (i64::new (new_half x48 x32) + (new_half x16 x00))))))) + +(runtime: (i64::= reference sample) + (let [n/a? (function (_ value) + (_.apply (list value) (_.var "is.na"))) + isTRUE? (function (_ value) + (_.apply (list value) (_.var "isTRUE"))) + comparison (: (-> (-> Expression Expression) Expression) + (function (_ field) + (|> (|> (field sample) (_.= (field reference))) + (_.or (|> (n/a? (field sample)) + (_.and (n/a? (field reference))))))))] + (|> (comparison i64_high) + (_.and (comparison i64_low)) + isTRUE?))) + +(runtime: (i64::negate input) + (_.if (|> input (i64::= i64::min)) + i64::min + (|> input i64::not (i64::+ i64::one)))) + +(runtime: i64::-one + (i64::negate i64::one)) + +(runtime: (i64::- param subject) + (i64::+ (i64::negate param) subject)) + +(runtime: (i64::< reference sample) + (with_vars [r_? s_?] + ($_ _.then + (_.set! s_? (|> sample i64_high (_.< (_.int +0)))) + (_.set! r_? (|> reference i64_high (_.< (_.int +0)))) + (|> (|> s_? (_.and (_.not r_?))) + (_.or (|> (_.not s_?) (_.and r_?) _.not)) + (_.or (|> sample + (i64::- reference) + i64_high + (_.< (_.int +0)))))))) + +(runtime: (i64::from_float input) + (_.cond (list [(_.apply (list input) (_.var "is.nan")) + i64::zero] + [(|> input (_.<= (_.negate f2^63))) + i64::min] + [(|> input (_.+ (_.float +1.0)) (_.>= f2^63)) + i64::max] + [(|> input (_.< (_.float +0.0))) + (|> input _.negate i64::from_float i64::negate)]) + (i64::new (|> input (_./ f2^32)) + (|> input (_.%% f2^32))))) + +(runtime: (i64::* param subject) + (with_vars [sH sL pH pL + x00 x16 x32 x48] + ($_ _.then + (_.set! sH (|> subject i64_high)) + (_.set! pH (|> param i64_high)) + (let [negative_subject? (|> sH (_.< (_.int +0))) + negative_param? (|> pH (_.< (_.int +0)))] + (_.cond (list [negative_subject? + (_.if negative_param? + (i64::* (i64::negate param) + (i64::negate subject)) + (i64::negate (i64::* param + (i64::negate subject))))] + + [negative_param? + (i64::negate (i64::* (i64::negate param) + subject))]) + ($_ _.then + (_.set! sL (|> subject i64_low)) + (_.set! pL (|> param i64_low)) + (let [bits16 (_.manual "0xFFFF") + move_top_16 (_.bit_shl (_.int +16)) + top_16 (_.bit_ushr (_.int +16)) + bottom_16 (_.bit_and bits16) + split_16 (function (_ source) + [(|> source top_16) + (|> source bottom_16)]) + split_int (function (_ high low) + [(split_16 high) + (split_16 low)]) + new_half (function (_ top bottom) + (|> top bottom_16 move_top_16 + (_.bit_or (bottom_16 bottom)))) + x16_top (|> x16 top_16) + x32_top (|> x32 top_16)] + (with_vars [s48 s32 s16 s00 + p48 p32 p16 p00] + (let [[[_s48 _s32] [_s16 _s00]] (split_int sH sL) + [[_p48 _p32] [_p16 _p00]] (split_int pH pL) + set_subject_chunks! ($_ _.then (_.set! s48 _s48) (_.set! s32 _s32) (_.set! s16 _s16) (_.set! s00 _s00)) + set_param_chunks! ($_ _.then (_.set! p48 _p48) (_.set! p32 _p32) (_.set! p16 _p16) (_.set! p00 _p00))] + ($_ _.then + set_subject_chunks! + set_param_chunks! + (_.set! x00 (|> s00 (_.* p00))) + (_.set! x16 (|> x00 top_16 (_.+ (|> s16 (_.* p00))))) + (_.set! x32 x16_top) + (_.set! x16 (|> x16 bottom_16 (_.+ (|> s00 (_.* p16))))) + (_.set! x32 (|> x32 (_.+ x16_top) (_.+ (|> s32 (_.* p00))))) + (_.set! x48 x32_top) + (_.set! x32 (|> x32 bottom_16 (_.+ (|> s16 (_.* p16))))) + (_.set! x48 (|> x48 (_.+ x32_top))) + (_.set! x32 (|> x32 bottom_16 (_.+ (|> s00 (_.* p32))))) + (_.set! x48 (|> x48 (_.+ x32_top) + (_.+ (|> s48 (_.* p00))) + (_.+ (|> s32 (_.* p16))) + (_.+ (|> s16 (_.* p32))) + (_.+ (|> s00 (_.* p48))))) + (i64::new (new_half x48 x32) + (new_half x16 x00))))) + ))))))) + +(def: (limit_shift! shift) + (-> SVar Expression) + (_.set! shift (|> shift (_.bit_and (_.int +63))))) + +(def: (no_shift_clause shift input) + (-> SVar SVar [Expression Expression]) + [(|> shift (_.= (_.int +0))) + input]) + +(runtime: (i64::left_shift shift input) + ($_ _.then + (limit_shift! shift) + (_.cond (list (no_shift_clause shift input) + [(|> shift (_.< (_.int +32))) + (let [mid (|> (i64_low input) (_.bit_ushr (|> (_.int +32) (_.- shift)))) + high (|> (i64_high input) + (_.bit_shl shift) + (_.bit_or mid)) + low (|> (i64_low input) + (_.bit_shl shift))] + (i64::new high low))]) + (let [high (|> (i64_high input) + (_.bit_shl (|> shift (_.- (_.int +32)))))] + (i64::new high (_.int +0)))))) + +(runtime: (i64::arithmetic_right_shift_32 shift input) + (let [top_bit (|> input (_.bit_and (_.int (hex "+80000000"))))] + (|> input + (_.bit_ushr shift) + (_.bit_or top_bit)))) + +(runtime: (i64::arithmetic_right_shift shift input) + ($_ _.then + (limit_shift! shift) + (_.cond (list (no_shift_clause shift input) + [(|> shift (_.< (_.int +32))) + (let [mid (|> (i64_high input) (_.bit_shl (|> (_.int +32) (_.- shift)))) + high (|> (i64_high input) + (i64::arithmetic_right_shift_32 shift)) + low (|> (i64_low input) + (_.bit_ushr shift) + (_.bit_or mid))] + (i64::new high low))]) + (let [low (|> (i64_high input) + (i64::arithmetic_right_shift_32 (|> shift (_.- (_.int +32))))) + high (_.if (|> (i64_high input) (_.>= (_.int +0))) + (_.int +0) + (_.int -1))] + (i64::new high low))))) + +(runtime: (i64::/ param subject) + (let [negative? (|>> (i64::< i64::zero)) + valid_division_check [(|> param (i64::= i64::zero)) + (_.stop (_.string "Cannot divide by zero!"))] + short_circuit_check [(|> subject (i64::= i64::zero)) + i64::zero]] + (_.cond (list valid_division_check + short_circuit_check + + [(|> subject (i64::= i64::min)) + (_.cond (list [(|> (|> param (i64::= i64::one)) + (_.or (|> param (i64::= i64::-one)))) + i64::min] + [(|> param (i64::= i64::min)) + i64::one]) + (with_vars [approximation] + ($_ _.then + (_.set! approximation + (|> subject + (i64::arithmetic_right_shift (_.int +1)) + (i64::/ param) + (i64::left_shift (_.int +1)))) + (_.if (|> approximation (i64::= i64::zero)) + (_.if (negative? param) + i64::one + i64::-one) + (let [remainder (i64::- (i64::* param approximation) + subject)] + (|> remainder + (i64::/ param) + (i64::+ approximation)))))))] + [(|> param (i64::= i64::min)) + i64::zero] + + [(negative? subject) + (_.if (negative? param) + (|> (i64::negate subject) + (i64::/ (i64::negate param))) + (|> (i64::negate subject) + (i64::/ param) + i64::negate))] + + [(negative? param) + (|> param + i64::negate + (i64::/ subject) + i64::negate)]) + (with_vars [result remainder approximate approximate_result log2 approximate_remainder] + ($_ _.then + (_.set! result i64::zero) + (_.set! remainder subject) + (_.while (|> (|> remainder (i64::< param)) + (_.or (|> remainder (i64::= param)))) + (let [calc_rough_estimate (_.apply (list (|> (i64::to_float remainder) (_./ (i64::to_float param)))) + (_.var "floor")) + calc_approximate_result (i64::from_float approximate) + calc_approximate_remainder (|> approximate_result (i64::* param)) + delta (_.if (|> (_.float +48.0) (_.<= log2)) + (_.float +1.0) + (_.** (|> log2 (_.- (_.float +48.0))) + (_.float +2.0)))] + ($_ _.then + (_.set! approximate (_.apply (list (_.float +1.0) calc_rough_estimate) + (_.var "max"))) + (_.set! log2 (let [log (function (_ input) + (_.apply (list input) (_.var "log")))] + (_.apply (list (|> (log (_.int +2)) + (_./ (log approximate)))) + (_.var "ceil")))) + (_.set! approximate_result calc_approximate_result) + (_.set! approximate_remainder calc_approximate_remainder) + (_.while (|> (negative? approximate_remainder) + (_.or (|> approximate_remainder (i64::< remainder)))) + ($_ _.then + (_.set! approximate (|> delta (_.- approximate))) + (_.set! approximate_result calc_approximate_result) + (_.set! approximate_remainder calc_approximate_remainder))) + (_.set! result (|> (_.if (|> approximate_result (i64::= i64::zero)) + i64::one + approximate_result) + (i64::+ result))) + (_.set! remainder (|> remainder (i64::- approximate_remainder)))))) + result)) + ))) + +(runtime: (i64::% param subject) + (let [flat (|> subject (i64::/ param) (i64::* param))] + (|> subject (i64::- flat)))) + +(runtime: (lux::try op) + (with_vars [error value] + (_.try ($_ _.then + (_.set! value (_.apply (list ..unit) op)) + (..right value)) + #.None + (#.Some (_.function (list error) + (..left (_.nth (_.string "message") + error)))) + #.None))) + +(runtime: (lux::program_args program_args) + (with_vars [inputs value] + ($_ _.then + (_.set! inputs ..none) + (<| (_.for_in value program_args) + (_.set! inputs (..some (_.list (list value inputs))))) + inputs))) + +(def: runtime::lux + Expression + ($_ _.then + @lux::try + @lux::program_args + )) + +(def: current_time_float + Expression + (let [raw_time (_.apply (list) (_.var "Sys.time"))] + (_.apply (list raw_time) (_.var "as.numeric")))) + +(runtime: (io::current_time! _) + (|> current_time_float + (_.* (_.float +1,000.0)) + i64::from_float)) + +(def: runtime::io + Expression + ($_ _.then + @io::current_time! + )) + +(def: minimum_index_length + (-> SVar Expression) + (|>> (_.+ (_.int +1)))) + +(def: (product_element product index) + (-> Expression Expression Expression) + (|> product (_.nth (|> index (_.+ (_.int +1)))))) + +(def: (product_tail product) + (-> SVar Expression) + (|> product (_.nth (_.length product)))) + +(def: (updated_index min_length product) + (-> Expression Expression Expression) + (|> min_length (_.- (_.length product)))) + +(runtime: (tuple::left index product) + (let [$index_min_length (_.var "index_min_length")] + ($_ _.then + (_.set! $index_min_length (minimum_index_length index)) + (_.if (|> (_.length product) (_.> $index_min_length)) + ## No need for recursion + (product_element product index) + ## Needs recursion + (tuple::left (updated_index $index_min_length product) + (product_tail product)))))) + +(runtime: (tuple::right index product) + (let [$index_min_length (_.var "index_min_length")] + ($_ _.then + (_.set! $index_min_length (minimum_index_length index)) + (_.cond (list [## Last element. + (|> (_.length product) (_.= $index_min_length)) + (product_element product index)] + [## Needs recursion + (|> (_.length product) (_.< $index_min_length)) + (tuple::right (updated_index $index_min_length product) + (product_tail product))]) + ## Must slice + (|> product (_.slice_from index)))))) + +(runtime: (sum::get sum wants_last? wanted_tag) + (let [no_match _.null + sum_tag (|> sum (_.nth (_.string ..variant_tag_field))) + sum_flag (|> sum (_.nth (_.string ..variant_flag_field))) + sum_value (|> sum (_.nth (_.string ..variant_value_field))) + is_last? (|> sum_flag (_.= (_.string ""))) + test_recursion (_.if is_last? + ## Must recurse. + (|> wanted_tag + (_.- sum_tag) + (sum::get sum_value wants_last?)) + no_match)] + (_.cond (list [(_.= sum_tag wanted_tag) + (_.if (_.= wants_last? sum_flag) + sum_value + test_recursion)] + + [(|> wanted_tag (_.> sum_tag)) + test_recursion] + + [(|> (|> wants_last? (_.= (_.string ""))) + (_.and (|> wanted_tag (_.< sum_tag)))) + (variant' (|> sum_tag (_.- wanted_tag)) sum_flag sum_value)]) + + no_match))) + +(def: runtime::adt + Expression + ($_ _.then + @tuple::left + @tuple::right + @sum::get + )) + +(template [<name> <op>] + [(runtime: (<name> mask input) + (i64::new (<op> (i64_high mask) + (i64_high input)) + (<op> (i64_low mask) + (i64_low input))))] + + [i64::and _.bit_and] + [i64::or _.bit_or] + [i64::xor _.bit_xor] + ) + +(runtime: (i64::right_shift shift input) + ($_ _.then + (limit_shift! shift) + (_.cond (list (no_shift_clause shift input) + [(|> shift (_.< (_.int +32))) + (with_vars [$mid] + (let [mid (|> (i64_high input) (_.bit_shl (|> (_.int +32) (_.- shift)))) + high (|> (i64_high input) (_.bit_ushr shift)) + low (|> (i64_low input) + (_.bit_ushr shift) + (_.bit_or (_.if (_.apply (list $mid) (_.var "is.na")) + (_.int +0) + $mid)))] + ($_ _.then + (_.set! $mid mid) + (i64::new high low))))] + [(|> shift (_.= (_.int +32))) + (let [high (i64_high input)] + (i64::new (_.int +0) high))]) + (let [low (|> (i64_high input) (_.bit_ushr (|> shift (_.- (_.int +32)))))] + (i64::new (_.int +0) low))))) + +(def: runtime::i64 + Expression + ($_ _.then + @i64::zero + @i64::one + @i64::min + @i64::max + @i64::= + @i64::< + @i64::+ + @i64::- + @i64::negate + @i64::-one + @i64::unsigned_low + @i64::to_float + @i64::* + @i64::/ + @i64::% + + @i64::and + @i64::or + @i64::xor + @i64::not + @i64::left_shift + @i64::arithmetic_right_shift_32 + @i64::arithmetic_right_shift + @i64::right_shift + )) + +(runtime: (frac::decode input) + (with_vars [output] + ($_ _.then + (_.set! output (_.apply (list input) (_.var "as.numeric"))) + (_.if (|> output (_.= _.n/a)) + ..none + (..some output))))) + +(def: runtime::frac + Expression + ($_ _.then + @frac::decode + )) + +(def: inc + (-> Expression Expression) + (|>> (_.+ (_.int +1)))) + +(template [<name> <top_cmp>] + [(def: (<name> top value) + (-> Expression Expression Expression) + (|> (|> value (_.>= (_.int +0))) + (_.and (|> value (<top_cmp> top)))))] + + [within? _.<] + [up_to? _.<=] + ) + +(def: (text_clip start end text) + (-> Expression Expression Expression Expression) + (_.apply (list text start end) + (_.var "substr"))) + +(def: (text_length text) + (-> Expression Expression) + (_.apply (list text) (_.var "nchar"))) + +(runtime: (text::index subject param start) + (with_vars [idx startF subjectL] + ($_ _.then + (_.set! startF (i64::to_float start)) + (_.set! subjectL (text_length subject)) + (_.if (|> startF (within? subjectL)) + ($_ _.then + (_.set! idx (|> (_.apply_kw (list param (_.if (|> startF (_.= (_.int +0))) + subject + (text_clip (inc startF) + (inc subjectL) + subject))) + (list ["fixed" (_.bool #1)]) + (_.var "regexpr")) + (_.nth (_.int +1)))) + (_.if (|> idx (_.= (_.int -1))) + ..none + (..some (i64::from_float (|> idx (_.+ startF)))))) + ..none)))) + +(runtime: (text::clip text from to) + (with_vars [length] + ($_ _.then + (_.set! length (_.length text)) + (_.if ($_ _.and + (|> to (within? length)) + (|> from (up_to? to))) + (..some (text_clip (inc from) (inc to) text)) + ..none)))) + +(def: (char_at idx text) + (-> Expression Expression Expression) + (_.apply (list (text_clip idx idx text)) + (_.var "utf8ToInt"))) + +(runtime: (text::char text idx) + (_.if (|> idx (within? (_.length text))) + ($_ _.then + (_.set! idx (inc idx)) + (..some (i64::from_float (char_at idx text)))) + ..none)) + +(def: runtime::text + Expression + ($_ _.then + @text::index + @text::clip + @text::char + )) + +(def: (check_index_out_of_bounds array idx body) + (-> Expression Expression Expression Expression) + (_.if (|> idx (_.<= (_.length array))) + body + (_.stop (_.string "Array index out of bounds!")))) + +(runtime: (array::new size) + (with_vars [output] + ($_ _.then + (_.set! output (_.list (list))) + (_.set_nth! (|> size (_.+ (_.int +1))) + _.null + output) + output))) + +(runtime: (array::get array idx) + (with_vars [temp] + (<| (check_index_out_of_bounds array idx) + ($_ _.then + (_.set! temp (|> array (_.nth (_.+ (_.int +1) idx)))) + (_.if (|> temp (_.= _.null)) + ..none + (..some temp)))))) + +(runtime: (array::put array idx value) + (<| (check_index_out_of_bounds array idx) + ($_ _.then + (_.set_nth! (_.+ (_.int +1) idx) value array) + array))) + +(def: runtime::array + Expression + ($_ _.then + @array::new + @array::get + @array::put + )) + +(def: runtime + Expression + ($_ _.then + runtime::lux + @f2^32 + @f2^63 + @i64::new + @i64::from_float + runtime::i64 + runtime::adt + runtime::frac + runtime::text + runtime::array + runtime::io + )) + +(def: #export generate + (Operation [Registry Output]) + (do ///////phase.monad + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! (%.nat ..module_id) ..runtime)] + (wrap [(|> artifact.empty + artifact.resource + product.right) + (row.row [(%.nat ..module_id) + (|> ..runtime + _.code + (\ utf8.codec encode))])]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/structure.lux new file mode 100644 index 000000000..5f4703836 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/structure.lux @@ -0,0 +1,39 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [data + [collection + ["." list]]] + [target + ["_" r (#+ Expression)]]] + ["." // #_ + ["#." runtime (#+ Operation Phase Generator)] + ["#." primitive] + ["///#" //// #_ + [analysis (#+ Variant Tuple)] + ["#." synthesis (#+ Synthesis)] + ["//#" /// #_ + ["#." phase ("#\." monad)]]]]) + +(def: #export (tuple expression archive elemsS+) + (Generator (Tuple Synthesis)) + (case elemsS+ + #.Nil + (///////phase\wrap (//primitive.text /////synthesis.unit)) + + (#.Cons singletonS #.Nil) + (expression archive singletonS) + + _ + (|> elemsS+ + (monad.map ///////phase.monad (expression archive)) + (///////phase\map _.list)))) + +(def: #export (variant expression archive [lefts right? valueS]) + (Generator (Variant Synthesis)) + (let [tag (if right? + (inc lefts) + lefts)] + (///////phase\map (|>> (//runtime.variant tag right?)) + (expression archive valueS)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux index be476cf74..1a36df4e0 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux @@ -2,8 +2,6 @@ [lux #* [abstract [monad (#+ do)]] - [control - ["." exception (#+ exception:)]] [target ["_" scheme]]] ["." / #_ diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux index 380352c5b..65c674ded 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux @@ -89,8 +89,7 @@ output_func_args (//runtime.slice arityO (|> @num_args (_.-/2 arityO)) @curried)] - (_.begin (list ## (_.display/1 (_.string (format "!!! PRE [slice]" text.new_line))) - (|> @self + (_.begin (list (|> @self (apply_poly arity_args) (apply_poly output_func_args)))))) ## (|> @num_args (_.</2 arityO)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux index 633b0da5a..d4b964910 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux @@ -13,7 +13,7 @@ [number ["n" nat]]] [target - ["_" scheme (#+ Computation Var)]]] + ["_" scheme]]] ["." // #_ [runtime (#+ Operation Phase Generator)] ["#." case] diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux index 612cb3153..7f55df9a9 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux @@ -11,7 +11,8 @@ ["." product] ["." text ("#\." hash) ["%" format (#+ format)] - ["." encoding]] + [encoding + ["." utf8]]] [collection ["." list ("#\." functor)] ["." row]]] @@ -365,4 +366,4 @@ (row.row [(%.nat ..module_id) (|> ..runtime _.code - (\ encoding.utf8 encode))])]))) + (\ utf8.codec encode))])]))) diff --git a/stdlib/source/lux/tool/compiler/meta/io/context.lux b/stdlib/source/lux/tool/compiler/meta/io/context.lux index 6c44c026a..3bb388f5e 100644 --- a/stdlib/source/lux/tool/compiler/meta/io/context.lux +++ b/stdlib/source/lux/tool/compiler/meta/io/context.lux @@ -15,7 +15,8 @@ [binary (#+ Binary)] ["." text ("#\." hash) ["%" format (#+ format)] - ["." encoding]] + [encoding + ["." utf8]]] [collection ["." dictionary (#+ Dictionary)]]] [world @@ -127,7 +128,7 @@ (Promise (Try Input))) (do (try.with promise.monad) [[path binary] (..find_any_source_file system import contexts partial_host_extension module)] - (case (\ encoding.utf8 decode binary) + (case (\ utf8.codec decode binary) (#try.Success code) (wrap {#////.module module #////.file path diff --git a/stdlib/source/lux/tool/compiler/meta/packager/script.lux b/stdlib/source/lux/tool/compiler/meta/packager/script.lux index e8685ce2b..c23688a9e 100644 --- a/stdlib/source/lux/tool/compiler/meta/packager/script.lux +++ b/stdlib/source/lux/tool/compiler/meta/packager/script.lux @@ -12,7 +12,8 @@ ["." product] [text ["%" format (#+ format)] - ["." encoding]] + [encoding + ["." utf8]]] [collection ["." row] ["." list ("#\." functor)]]] @@ -49,7 +50,7 @@ (monad.fold try.monad (function (_ content so_far) (|> content - (\ encoding.utf8 decode) + (\ utf8.codec decode) (\ try.monad map (function (_ content) (sequence so_far @@ -75,4 +76,4 @@ (list\map (function (_ [module [module_id [descriptor document output]]]) [module_id output])) (monad.fold ! (..write_module sequence) header) - (\ ! map (|>> scope to_code (\ encoding.utf8 encode))))))) + (\ ! map (|>> scope to_code (\ utf8.codec encode))))))) |