diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/translation/scheme')
11 files changed, 0 insertions, 1447 deletions
diff --git a/new-luxc/source/luxc/lang/translation/scheme/case.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/case.jvm.lux deleted file mode 100644 index 91ad5140d..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/case.jvm.lux +++ /dev/null @@ -1,179 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data [number] - [text] - text/format - (coll [list "list/" Functor<List> Fold<List>] - (set ["set" unordered #+ Set]))) - [macro #+ "meta/" Monad<Meta>] - (macro [code])) - (luxc [lang] - (lang [".L" variable #+ Register Variable] - ["ls" synthesis #+ Synthesis Path] - (host ["_" scheme #+ Expression SVar @@]))) - [//] - (// [".T" runtime] - [".T" primitive] - [".T" reference])) - -(def: #export (translate-let translate register valueS bodyS) - (-> (-> Synthesis (Meta Expression)) Register Synthesis Synthesis - (Meta Expression)) - (do macro.Monad<Meta> - [valueO (translate valueS) - bodyO (translate bodyS) - #let [$register (referenceT.variable register)]] - (wrap (_.let (list [$register valueO]) - bodyO)))) - -(def: #export (translate-record-get translate valueS pathP) - (-> (-> Synthesis (Meta Expression)) Synthesis (List [Nat Bool]) - (Meta Expression)) - (do macro.Monad<Meta> - [valueO (translate valueS)] - (wrap (list/fold (function (_ [idx tail?] source) - (let [method (if tail? - runtimeT.product//right - runtimeT.product//left)] - (method source (_.int (:! Int idx))))) - valueO - pathP)))) - -(def: #export (translate-if testO thenO elseO) - (-> Expression Expression Expression Expression) - (_.if testO thenO elseO)) - -(def: $savepoint (_.var "lux_pm_cursor_savepoint")) -(def: $cursor (_.var "lux_pm_cursor")) - -(def: top _.length) -(def: (push! value var) - (-> Expression SVar Expression) - (_.set! var (_.cons value (@@ var)))) -(def: (pop! var) - (-> SVar Expression) - (_.set! var (@@ var))) - -(def: (push-cursor! value) - (-> Expression Expression) - (push! value $cursor)) - -(def: save-cursor! - Expression - (push! (@@ $cursor) $savepoint)) - -(def: restore-cursor! - Expression - (_.set! $cursor (_.car (@@ $savepoint)))) - -(def: cursor-top - Expression - (_.car (@@ $cursor))) - -(def: pop-cursor! - Expression - (pop! $cursor)) - -(def: pm-error (_.string "PM-ERROR")) - -(def: fail-pm! (_.raise pm-error)) - -(def: $temp (_.var "lux_pm_temp")) - -(exception: #export (Unrecognized-Path {message Text}) - message) - -(def: $alt_error (_.var "alt_error")) - -(def: (pm-catch handler) - (-> Expression Expression) - (_.lambda (_.poly (list $alt_error)) - (_.if (|> (@@ $alt_error) (_.eqv? pm-error)) - handler - (_.raise (@@ $alt_error))))) - -(def: (translate-pattern-matching' translate pathP) - (-> (-> Synthesis (Meta Expression)) Path (Meta Expression)) - (case pathP - (^code ("lux case exec" (~ bodyS))) - (do macro.Monad<Meta> - [bodyO (translate bodyS)] - (wrap bodyO)) - - (^code ("lux case pop")) - (meta/wrap pop-cursor!) - - (^code ("lux case bind" (~ [_ (#.Nat register)]))) - (meta/wrap (_.define (referenceT.variable register) (list) cursor-top)) - - (^template [<tag> <format> <=>] - [_ (<tag> value)] - (meta/wrap (_.when (|> value <format> (<=> cursor-top) _.not) - fail-pm!))) - ([#.Bool _.bool _.eqv?] - [#.Nat (<| _.int (:! Int)) _.=] - [#.Int _.int _.=] - [#.Deg (<| _.int (:! Int)) _.=] - [#.Frac _.float _.=] - [#.Text _.string _.eqv?]) - - (^template [<pm> <getter>] - (^code (<pm> (~ [_ (#.Nat idx)]))) - (meta/wrap (push-cursor! (<getter> cursor-top (_.int (:! Int idx)))))) - (["lux case tuple left" runtimeT.product//left] - ["lux case tuple right" runtimeT.product//right]) - - (^template [<pm> <flag>] - (^code (<pm> (~ [_ (#.Nat idx)]))) - (meta/wrap (_.begin (list (_.set! $temp (runtimeT.sum//get cursor-top (_.int (:! Int idx)) <flag>)) - (_.if (_.null? (@@ $temp)) - fail-pm! - (push-cursor! (@@ $temp))))))) - (["lux case variant left" _.nil] - ["lux case variant right" (_.string "")]) - - (^code ("lux case seq" (~ leftP) (~ rightP))) - (do macro.Monad<Meta> - [leftO (translate-pattern-matching' translate leftP) - rightO (translate-pattern-matching' translate rightP)] - (wrap (_.begin (list leftO - rightO)))) - - (^code ("lux case alt" (~ leftP) (~ rightP))) - (do macro.Monad<Meta> - [leftO (translate-pattern-matching' translate leftP) - rightO (translate-pattern-matching' translate rightP)] - (wrap (_.with-exception-handler - (pm-catch (_.begin (list restore-cursor! - rightO))) - (_.lambda (_.poly (list)) - (_.begin (list save-cursor! - leftO)))))) - - _ - (lang.throw Unrecognized-Path (%code pathP)) - )) - -(def: (translate-pattern-matching translate pathP) - (-> (-> Synthesis (Meta Expression)) Path (Meta Expression)) - (do macro.Monad<Meta> - [pattern-matching! (translate-pattern-matching' translate pathP)] - (wrap (_.with-exception-handler - (pm-catch (_.raise (_.string "Invalid expression for pattern-matching."))) - (_.lambda (_.poly (list)) - pattern-matching!))))) - -(def: (initialize-pattern-matching! stack-init) - (-> Expression Expression) - (_.begin (list (_.set! $cursor (_.list (list stack-init))) - (_.set! $savepoint (_.list (list)))))) - -(def: #export (translate-case translate valueS pathP) - (-> (-> Synthesis (Meta Expression)) Synthesis Path (Meta Expression)) - (do macro.Monad<Meta> - [valueO (translate valueS) - pattern-matching! (translate-pattern-matching translate pathP)] - (wrap (_.begin (list (initialize-pattern-matching! valueO) - pattern-matching!))))) diff --git a/new-luxc/source/luxc/lang/translation/scheme/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/expression.jvm.lux deleted file mode 100644 index d906ae825..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/expression.jvm.lux +++ /dev/null @@ -1,87 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - ["p" parser]) - (data ["e" error] - text/format) - [macro] - (macro ["s" syntax])) - (luxc ["&" lang] - (lang [".L" variable #+ Variable Register] - [".L" extension] - ["ls" synthesis] - (host ["_" scheme #+ Expression]))) - [//] - (// [".T" runtime] - [".T" primitive] - [".T" structure] - [".T" reference] - [".T" function] - [".T" case] - [".T" procedure])) - -(do-template [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [Invalid-Function-Syntax] - [Unrecognized-Synthesis] - ) - -(def: #export (translate synthesis) - (-> ls.Synthesis (Meta Expression)) - (case synthesis - (^code []) - (:: macro.Monad<Meta> wrap runtimeT.unit) - - (^template [<tag> <generator>] - [_ (<tag> value)] - (<generator> value)) - ([#.Bool primitiveT.translate-bool] - [#.Nat primitiveT.translate-nat] - [#.Int primitiveT.translate-int] - [#.Deg primitiveT.translate-deg] - [#.Frac primitiveT.translate-frac] - [#.Text primitiveT.translate-text]) - - (^code ((~ [_ (#.Nat tag)]) (~ [_ (#.Bool last?)]) (~ valueS))) - (structureT.translate-variant translate tag last? valueS) - - (^code [(~ singleton)]) - (translate singleton) - - (^code [(~+ members)]) - (structureT.translate-tuple translate members) - - (^ [_ (#.Form (list [_ (#.Int var)]))]) - (referenceT.translate-variable var) - - [_ (#.Symbol definition)] - (referenceT.translate-definition definition) - - (^code ("lux call" (~ functionS) (~+ argsS))) - (functionT.translate-apply translate functionS argsS) - - (^code ("lux function" (~ [_ (#.Nat arity)]) [(~+ environment)] (~ bodyS))) - (case (s.run environment (p.some s.int)) - (#e.Success environment) - (functionT.translate-function translate environment arity bodyS) - - _ - (&.throw Invalid-Function-Syntax (%code synthesis))) - - (^code ("lux let" (~ [_ (#.Nat register)]) (~ inputS) (~ exprS))) - (caseT.translate-let translate register inputS exprS) - - (^code ("lux case" (~ inputS) (~ pathPS))) - (caseT.translate-case translate inputS pathPS) - - (^code ((~ [_ (#.Text procedure)]) (~+ argsS))) - (procedureT.translate-procedure translate procedure argsS) - ## (do macro.Monad<Meta> - ## [translation (extensionL.find-translation procedure)] - ## (translation argsS)) - - _ - (&.throw Unrecognized-Synthesis (%code synthesis)))) diff --git a/new-luxc/source/luxc/lang/translation/scheme/function.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/function.jvm.lux deleted file mode 100644 index 87821f2a0..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/function.jvm.lux +++ /dev/null @@ -1,87 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - pipe) - (data [product] - [text] - text/format - (coll [list "list/" Functor<List> Fold<List>])) - [macro]) - (luxc ["&" lang] - (lang ["ls" synthesis] - [".L" variable #+ Variable] - (host ["_" scheme #+ Expression @@]))) - [//] - (// [".T" reference] - [".T" runtime])) - -(def: #export (translate-apply translate functionS argsS+) - (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis (List ls.Synthesis) (Meta Expression)) - (do macro.Monad<Meta> - [functionO (translate functionS) - argsO+ (monad.map @ translate argsS+)] - (wrap (_.apply functionO argsO+)))) - -(def: $curried (_.var "curried")) -(def: $missing (_.var "missing")) - -(def: input-declaration - (|>> inc referenceT.variable)) - -(def: (with-closure function-name inits function-definition) - (-> Text (List Expression) Expression (Meta Expression)) - (let [$closure (_.var (format function-name "___CLOSURE"))] - (do macro.Monad<Meta> - [] - (case inits - #.Nil - (wrap function-definition) - - _ - (wrap (_.letrec (list [$closure - (_.lambda (|> (list.enumerate inits) - (list/map (|>> product.left referenceT.closure)) - _.poly) - function-definition)]) - (_.apply (@@ $closure) inits))))))) - -(def: #export (translate-function translate env arity bodyS) - (-> (-> ls.Synthesis (Meta Expression)) - (List Variable) ls.Arity ls.Synthesis - (Meta Expression)) - (do macro.Monad<Meta> - [[function-name bodyO] (//.with-sub-context - (do @ - [function-name //.context] - (//.with-anchor [function-name +1] - (translate bodyS)))) - closureO+ (monad.map @ referenceT.translate-variable env) - #let [arityO (|> arity .int _.int) - $num_args (_.var "num_args") - $function (_.var function-name) - apply-poly (function (_ args func) - (_.apply (_.global "apply") (list func args)))]] - (with-closure function-name closureO+ - (_.letrec (list [$function (_.lambda $curried - (_.let (list [$num_args (_.length (@@ $curried))]) - (<| (_.if (|> (@@ $num_args) (_.= arityO)) - (_.let (list [(referenceT.variable +0) (@@ $function)]) - (_.let-values (list [(|> (list.n/range +0 (dec arity)) - (list/map input-declaration) - _.poly) - (_.apply (_.global "apply") (list (_.global "values") (@@ $curried)))]) - bodyO))) - (_.if (|> (@@ $num_args) (_.> arityO)) - (let [arity-args (runtimeT.list-slice (_.int 0) arityO (@@ $curried)) - output-func-args (runtimeT.list-slice arityO - (|> (@@ $num_args) (_.- arityO)) - (@@ $curried))] - (|> (@@ $function) - (apply-poly arity-args) - (apply-poly output-func-args)))) - ## (|> (@@ $num_args) (_.< arityO)) - (_.lambda $missing - (|> (@@ $function) - (apply-poly (_.append (@@ $curried) (@@ $missing))))))))]) - (@@ $function))) - )) diff --git a/new-luxc/source/luxc/lang/translation/scheme/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/loop.jvm.lux deleted file mode 100644 index c64973d8f..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/loop.jvm.lux +++ /dev/null @@ -1,37 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data [text] - text/format - (coll [list "list/" Functor<List>])) - [macro]) - (luxc [lang] - (lang ["ls" synthesis] - (host [r #+ Expression @@]))) - [//] - (// [".T" reference])) - -(def: #export (translate-loop translate offset initsS+ bodyS) - (-> (-> ls.Synthesis (Meta Expression)) Nat (List ls.Synthesis) ls.Synthesis - (Meta Expression)) - (do macro.Monad<Meta> - [loop-name (|> (macro.gensym "loop") - (:: @ map (|>> %code lang.normalize-name))) - initsO+ (monad.map @ translate initsS+) - bodyO (//.with-anchor [loop-name offset] - (translate bodyS)) - #let [$loop-name (r.var loop-name) - @loop-name (@@ $loop-name)] - _ (//.save (r.set! $loop-name - (r.function (|> (list.n/range +0 (dec (list.size initsS+))) - (list/map (|>> (n/+ offset) referenceT.variable))) - bodyO)))] - (wrap (r.apply initsO+ @loop-name)))) - -(def: #export (translate-recur translate argsS+) - (-> (-> ls.Synthesis (Meta Expression)) (List ls.Synthesis) - (Meta Expression)) - (do macro.Monad<Meta> - [[loop-name offset] //.anchor - argsO+ (monad.map @ translate argsS+)] - (wrap (r.apply argsO+ (r.global loop-name))))) diff --git a/new-luxc/source/luxc/lang/translation/scheme/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/primitive.jvm.lux deleted file mode 100644 index c7043eeb7..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/primitive.jvm.lux +++ /dev/null @@ -1,30 +0,0 @@ -(.module: - lux - (lux [macro "meta/" Monad<Meta>]) - (luxc (lang (host [scheme #+ Expression]))) - [//] - (// [".T" runtime])) - -(def: #export translate-bool - (-> Bool (Meta Expression)) - (|>> scheme.bool meta/wrap)) - -(def: #export translate-int - (-> Int (Meta Expression)) - (|>> scheme.int meta/wrap)) - -(def: #export translate-nat - (-> Nat (Meta Expression)) - (|>> (:! Int) scheme.int meta/wrap)) - -(def: #export translate-deg - (-> Deg (Meta Expression)) - (|>> (:! Int) scheme.int meta/wrap)) - -(def: #export translate-frac - (-> Frac (Meta Expression)) - (|>> scheme.float meta/wrap)) - -(def: #export translate-text - (-> Text (Meta Expression)) - (|>> scheme.string meta/wrap)) diff --git a/new-luxc/source/luxc/lang/translation/scheme/procedure.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/procedure.jvm.lux deleted file mode 100644 index 8247baa0c..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/procedure.jvm.lux +++ /dev/null @@ -1,29 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data [maybe] - text/format - (coll (dictionary ["dict" unordered #+ Dict])))) - (luxc ["&" lang] - (lang ["ls" synthesis] - (host ["_" scheme #+ Expression]))) - [//] - (/ ["/." common] - ["/." host])) - -(exception: #export (Unknown-Procedure {message Text}) - message) - -(def: procedures - /common.Bundle - (|> /common.procedures - (dict.merge /host.procedures))) - -(def: #export (translate-procedure translate name args) - (-> (-> ls.Synthesis (Meta Expression)) Text (List ls.Synthesis) - (Meta Expression)) - (<| (maybe.default (&.throw Unknown-Procedure (%t name))) - (do maybe.Monad<Maybe> - [proc (dict.get name procedures)] - (wrap (proc translate args))))) diff --git a/new-luxc/source/luxc/lang/translation/scheme/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/procedure/common.jvm.lux deleted file mode 100644 index a7e9f0814..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/procedure/common.jvm.lux +++ /dev/null @@ -1,461 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - ["p" parser]) - (data ["e" error] - [text] - text/format - [number #+ hex] - (coll [list "list/" Functor<List>] - (dictionary ["dict" unordered #+ Dict]))) - [macro #+ with-gensyms] - (macro [code] - ["s" syntax #+ syntax:]) - [host]) - (luxc ["&" lang] - (lang ["la" analysis] - ["ls" synthesis] - (host ["_" scheme #+ Expression]))) - [///] - (/// [".T" runtime] - [".T" case] - [".T" function] - [".T" loop])) - -## [Types] -(type: #export Translator - (-> ls.Synthesis (Meta Expression))) - -(type: #export Proc - (-> Translator (List ls.Synthesis) (Meta Expression))) - -(type: #export Bundle - (Dict Text Proc)) - -(syntax: (Vector {size s.nat} elemT) - (wrap (list (` [(~+ (list.repeat size elemT))])))) - -(type: #export Nullary (-> (Vector +0 Expression) Expression)) -(type: #export Unary (-> (Vector +1 Expression) Expression)) -(type: #export Binary (-> (Vector +2 Expression) Expression)) -(type: #export Trinary (-> (Vector +3 Expression) Expression)) -(type: #export Variadic (-> (List Expression) Expression)) - -## [Utils] -(def: #export (install name unnamed) - (-> Text (-> Text Proc) - (-> Bundle Bundle)) - (dict.put name (unnamed name))) - -(def: #export (prefix prefix bundle) - (-> Text Bundle Bundle) - (|> bundle - dict.entries - (list/map (function (_ [key val]) [(format prefix " " key) val])) - (dict.from-list text.Hash<Text>))) - -(def: (wrong-arity proc expected actual) - (-> Text Nat Nat Text) - (format "Wrong number of arguments for " (%t proc) "\n" - "Expected: " (|> expected .int %i) "\n" - " Actual: " (|> actual .int %i))) - -(syntax: (arity: {name s.local-symbol} {arity s.nat}) - (with-gensyms [g!_ g!proc g!name g!translate g!inputs] - (do @ - [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] - (wrap (list (` (def: #export ((~ (code.local-symbol name)) (~ g!proc)) - (-> (-> (..Vector (~ (code.nat arity)) Expression) Expression) - (-> Text ..Proc)) - (function ((~ g!_) (~ g!name)) - (function ((~ g!_) (~ g!translate) (~ g!inputs)) - (case (~ g!inputs) - (^ (list (~+ g!input+))) - (do macro.Monad<Meta> - [(~+ (|> g!input+ - (list/map (function (_ g!input) - (list g!input (` ((~ g!translate) (~ g!input)))))) - list.concat))] - ((~' wrap) ((~ g!proc) [(~+ g!input+)]))) - - (~' _) - (macro.fail (wrong-arity (~ g!name) +1 (list.size (~ g!inputs)))))))))))))) - -(arity: nullary +0) -(arity: unary +1) -(arity: binary +2) -(arity: trinary +3) - -(def: #export (variadic proc) - (-> Variadic (-> Text Proc)) - (function (_ proc-name) - (function (_ translate inputsS) - (do macro.Monad<Meta> - [inputsI (monad.map @ translate inputsS)] - (wrap (proc inputsI)))))) - -## [Procedures] -## [[Lux]] -(def: (lux//is [leftO rightO]) - Binary - (_.eq? leftO rightO)) - -(def: (lux//if [testO thenO elseO]) - Trinary - (caseT.translate-if testO thenO elseO)) - -(def: (lux//try riskyO) - Unary - (runtimeT.lux//try riskyO)) - -(def: (lux//noop valueO) - Unary - valueO) - -(exception: #export (Wrong-Syntax {message Text}) - message) - -(def: #export (wrong-syntax procedure args) - (-> Text (List ls.Synthesis) Text) - (format "Procedure: " procedure "\n" - "Arguments: " (%code (code.tuple args)))) - -(def: lux//loop - (-> Text Proc) - (function (_ proc-name) - (function (_ translate inputsS) - (case (s.run inputsS ($_ p.seq s.nat (s.tuple (p.many s.any)) s.any)) - (#e.Success [offset initsS+ bodyS]) - (loopT.translate-loop translate offset initsS+ bodyS) - - (#e.Error error) - (&.throw Wrong-Syntax (wrong-syntax proc-name inputsS))) - ))) - -(def: lux//recur - (-> Text Proc) - (function (_ proc-name) - (function (_ translate inputsS) - (loopT.translate-recur translate inputsS)))) - -(def: lux-procs - Bundle - (|> (dict.new text.Hash<Text>) - (install "noop" (unary lux//noop)) - (install "is" (binary lux//is)) - (install "try" (unary lux//try)) - (install "if" (trinary lux//if)) - (install "loop" lux//loop) - (install "recur" lux//recur) - )) - -## [[Bits]] -(do-template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (<op> paramO subjectO))] - - [bit//and _.bit-and] - [bit//or _.bit-or] - [bit//xor _.bit-xor] - ) - -(def: (bit//left-shift [subjectO paramO]) - Binary - (_.arithmetic-shift (_.remainder (_.int 64) paramO) subjectO)) - -(def: (bit//arithmetic-right-shift [subjectO paramO]) - Binary - (_.arithmetic-shift (|> paramO (_.remainder (_.int 64)) (_.* (_.int -1))) - subjectO)) - -(def: (bit//logical-right-shift [subjectO paramO]) - Binary - (runtimeT.bit//logical-right-shift (_.remainder (_.int 64) paramO) subjectO)) - -(def: bit-procs - Bundle - (<| (prefix "bit") - (|> (dict.new text.Hash<Text>) - (install "and" (binary bit//and)) - (install "or" (binary bit//or)) - (install "xor" (binary bit//xor)) - (install "left-shift" (binary bit//left-shift)) - (install "logical-right-shift" (binary bit//logical-right-shift)) - (install "arithmetic-right-shift" (binary bit//arithmetic-right-shift)) - ))) - -## [[Arrays]] -(def: (array//new size0) - Unary - ((_.apply2 (_.global "make-vector")) size0 _.nil)) - -(def: (array//get [arrayO idxO]) - Binary - (runtimeT.array//get arrayO idxO)) - -(def: (array//put [arrayO idxO elemO]) - Trinary - (runtimeT.array//put arrayO idxO elemO)) - -(def: (array//remove [arrayO idxO]) - Binary - (runtimeT.array//put arrayO idxO _.nil)) - -(def: array-procs - Bundle - (<| (prefix "array") - (|> (dict.new text.Hash<Text>) - (install "new" (unary array//new)) - (install "get" (binary array//get)) - (install "put" (trinary array//put)) - (install "remove" (binary array//remove)) - (install "size" (unary (_.apply1 (_.global "vector-length")))) - ))) - -## [[Numbers]] -(host.import java/lang/Double - (#static MIN_VALUE Double) - (#static MAX_VALUE Double)) - -(do-template [<name> <const> <encode>] - [(def: (<name> _) - Nullary - (<encode> <const>))] - - [frac//smallest Double::MIN_VALUE _.float] - [frac//min (f/* -1.0 Double::MAX_VALUE) _.float] - [frac//max Double::MAX_VALUE _.float] - ) - -(do-template [<name> <expression>] - [(def: (<name> _) - Nullary - (_.int <expression>))] - - [int//min ("lux int min")] - [int//max ("lux int max")] - ) - -(do-template [<name> <frac>] - [(def: (<name> _) - Nullary - (_.float <frac>))] - - [frac//not-a-number number.not-a-number] - [frac//positive-infinity number.positive-infinity] - [frac//negative-infinity number.negative-infinity] - ) - -(do-template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (|> subjectO (<op> paramO)))] - - [int//add _.+] - [int//sub _.-] - [int//mul _.*] - [int//div _.quotient] - [int//rem _.remainder] - ) - -(do-template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (<op> paramO subjectO))] - - [frac//add _.+] - [frac//sub _.-] - [frac//mul _.*] - [frac//div _./] - [frac//rem _.mod] - [frac//= _.=] - [frac//< _.<] - - [text//= _.string=?] - [text//< _.string<?] - ) - -(do-template [<name> <cmp>] - [(def: (<name> [subjectO paramO]) - Binary - (<cmp> paramO subjectO))] - - [int//= _.=] - [int//< _.<] - ) - -(def: int//char (|>> (_.apply1 (_.global "integer->char")) - (_.apply1 (_.global "string")))) - -(def: int-procs - Bundle - (<| (prefix "int") - (|> (dict.new text.Hash<Text>) - (install "+" (binary int//add)) - (install "-" (binary int//sub)) - (install "*" (binary int//mul)) - (install "/" (binary int//div)) - (install "%" (binary int//rem)) - (install "=" (binary int//=)) - (install "<" (binary int//<)) - (install "min" (nullary int//min)) - (install "max" (nullary int//max)) - (install "to-frac" (unary (|>> (_./ (_.float 1.0))))) - (install "char" (unary int//char))))) - -(def: frac-procs - Bundle - (<| (prefix "frac") - (|> (dict.new text.Hash<Text>) - (install "+" (binary frac//add)) - (install "-" (binary frac//sub)) - (install "*" (binary frac//mul)) - (install "/" (binary frac//div)) - (install "%" (binary frac//rem)) - (install "=" (binary frac//=)) - (install "<" (binary frac//<)) - (install "smallest" (nullary frac//smallest)) - (install "min" (nullary frac//min)) - (install "max" (nullary frac//max)) - (install "not-a-number" (nullary frac//not-a-number)) - (install "positive-infinity" (nullary frac//positive-infinity)) - (install "negative-infinity" (nullary frac//negative-infinity)) - (install "to-int" (unary (_.apply1 (_.global "exact")))) - (install "encode" (unary (_.apply1 (_.global "number->string")))) - (install "decode" (unary runtimeT.frac//decode))))) - -## [[Text]] -(def: (text//concat [subjectO paramO]) - Binary - (_.apply (_.global "string-append") (list subjectO paramO))) - -(def: text-procs - Bundle - (<| (prefix "text") - (|> (dict.new text.Hash<Text>) - (install "=" (binary text//=)) - (install "<" (binary text//<)) - (install "concat" (binary text//concat)) - ## (install "index" (trinary text//index)) - (install "size" (unary (_.apply1 (_.global "string-length")))) - (install "hash" (unary (_.apply1 (_.global "string-hash")))) - ## (install "replace-once" (trinary text//replace-once)) - ## (install "replace-all" (trinary text//replace-all)) - ## (install "char" (binary text//char)) - ## (install "clip" (trinary text//clip)) - ))) - -## [[Math]] -(def: (math//pow [subject param]) - Binary - ((_.apply2 (_.global "expt")) subject param)) - -(def: math-func - (-> Text (-> Expression Expression)) - (|>> _.global _.apply1)) - -(def: math-procs - Bundle - (<| (prefix "math") - (|> (dict.new text.Hash<Text>) - (install "cos" (unary (math-func "cos"))) - (install "sin" (unary (math-func "sin"))) - (install "tan" (unary (math-func "tan"))) - (install "acos" (unary (math-func "acos"))) - (install "asin" (unary (math-func "asin"))) - (install "atan" (unary (math-func "atan"))) - (install "exp" (unary (math-func "exp"))) - (install "log" (unary (math-func "log"))) - (install "ceil" (unary (math-func "ceiling"))) - (install "floor" (unary (math-func "floor"))) - (install "pow" (binary math//pow)) - ))) - -## [[IO]] -(def: (io//log input) - Unary - (_.begin (list (_.apply (_.global "display") (list input)) - (_.apply (_.global "newline") (list))))) - -(def: (void code) - (-> Expression Expression) - (_.begin (list code runtimeT.unit))) - -(def: io-procs - Bundle - (<| (prefix "io") - (|> (dict.new text.Hash<Text>) - (install "log" (unary (|>> io//log ..void))) - (install "error" (unary _.raise)) - (install "exit" (unary (_.apply1 (_.global "exit")))) - (install "current-time" (nullary (function (_ _) (runtimeT.io//current-time runtimeT.unit))))))) - -## [[Atoms]] -(def: atom//new - Unary - (|>> (list) _.vector)) - -(def: (atom//read atom) - Unary - (_.vector-ref atom (_.int 0))) - -(def: (atom//compare-and-swap [atomO oldO newO]) - Trinary - (runtimeT.atom//compare-and-swap atomO oldO newO)) - -(def: atom-procs - Bundle - (<| (prefix "atom") - (|> (dict.new text.Hash<Text>) - (install "new" (unary atom//new)) - (install "read" (unary atom//read)) - (install "compare-and-swap" (trinary atom//compare-and-swap))))) - -## [[Box]] -(def: (box//write [valueO boxO]) - Binary - (runtimeT.box//write valueO boxO)) - -(def: box-procs - Bundle - (<| (prefix "box") - (|> (dict.new text.Hash<Text>) - (install "new" (unary atom//new)) - (install "read" (unary atom//read)) - (install "write" (binary box//write))))) - -## [[Processes]] -(def: (process//parallelism-level []) - Nullary - (_.int 1)) - -(def: (process//schedule [milli-secondsO procedureO]) - Binary - (runtimeT.process//schedule milli-secondsO procedureO)) - -(def: process-procs - Bundle - (<| (prefix "process") - (|> (dict.new text.Hash<Text>) - (install "parallelism-level" (nullary process//parallelism-level)) - (install "schedule" (binary process//schedule)) - ))) - -## [Bundles] -(def: #export procedures - Bundle - (<| (prefix "lux") - (|> lux-procs - (dict.merge bit-procs) - (dict.merge int-procs) - (dict.merge frac-procs) - (dict.merge text-procs) - (dict.merge array-procs) - (dict.merge math-procs) - (dict.merge io-procs) - (dict.merge atom-procs) - (dict.merge box-procs) - (dict.merge process-procs) - ))) diff --git a/new-luxc/source/luxc/lang/translation/scheme/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/procedure/host.jvm.lux deleted file mode 100644 index af82491b6..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/procedure/host.jvm.lux +++ /dev/null @@ -1,89 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data [text] - text/format - (coll [list "list/" Functor<List>] - (dictionary ["dict" unordered #+ Dict]))) - [macro "macro/" Monad<Meta>]) - (luxc ["&" lang] - (lang ["la" analysis] - ["ls" synthesis] - (host [ruby #+ Ruby Expression Statement]))) - [///] - (/// [".T" runtime]) - (// ["@" common])) - -## (do-template [<name> <lua>] -## [(def: (<name> _) @.Nullary <lua>)] - -## [lua//nil "nil"] -## [lua//table "{}"] -## ) - -## (def: (lua//global proc translate inputs) -## (-> Text @.Proc) -## (case inputs -## (^ (list [_ (#.Text name)])) -## (do macro.Monad<Meta> -## [] -## (wrap name)) - -## _ -## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -## (def: (lua//call proc translate inputs) -## (-> Text @.Proc) -## (case inputs -## (^ (list& functionS argsS+)) -## (do macro.Monad<Meta> -## [functionO (translate functionS) -## argsO+ (monad.map @ translate argsS+)] -## (wrap (lua.apply functionO argsO+))) - -## _ -## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -## (def: lua-procs -## @.Bundle -## (|> (dict.new text.Hash<Text>) -## (@.install "nil" (@.nullary lua//nil)) -## (@.install "table" (@.nullary lua//table)) -## (@.install "global" lua//global) -## (@.install "call" lua//call))) - -## (def: (table//call proc translate inputs) -## (-> Text @.Proc) -## (case inputs -## (^ (list& tableS [_ (#.Text field)] argsS+)) -## (do macro.Monad<Meta> -## [tableO (translate tableS) -## argsO+ (monad.map @ translate argsS+)] -## (wrap (lua.method field tableO argsO+))) - -## _ -## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -## (def: (table//get [fieldO tableO]) -## @.Binary -## (runtimeT.lua//get tableO fieldO)) - -## (def: (table//set [fieldO valueO tableO]) -## @.Trinary -## (runtimeT.lua//set tableO fieldO valueO)) - -## (def: table-procs -## @.Bundle -## (<| (@.prefix "table") -## (|> (dict.new text.Hash<Text>) -## (@.install "call" table//call) -## (@.install "get" (@.binary table//get)) -## (@.install "set" (@.trinary table//set))))) - -(def: #export procedures - @.Bundle - (<| (@.prefix "lua") - (dict.new text.Hash<Text>) - ## (|> lua-procs - ## (dict.merge table-procs)) - )) diff --git a/new-luxc/source/luxc/lang/translation/scheme/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/reference.jvm.lux deleted file mode 100644 index 1552f52af..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/reference.jvm.lux +++ /dev/null @@ -1,42 +0,0 @@ -(.module: - lux - (lux [macro] - (data [text] - text/format)) - (luxc ["&" lang] - (lang [".L" variable #+ Variable Register] - (host ["_" scheme #+ Expression SVar @@]))) - [//] - (// [".T" runtime])) - -(do-template [<register> <translation> <prefix>] - [(def: #export (<register> register) - (-> Register SVar) - (_.var (format <prefix> (%i (.int register))))) - - (def: #export (<translation> register) - (-> Register (Meta Expression)) - (:: macro.Monad<Meta> wrap (@@ (<register> register))))] - - [closure translate-captured "c"] - [variable translate-local "v"]) - -(def: #export (local var) - (-> Variable SVar) - (if (variableL.captured? var) - (closure (variableL.captured-register var)) - (variable (.nat var)))) - -(def: #export (translate-variable var) - (-> Variable (Meta Expression)) - (if (variableL.captured? var) - (translate-captured (variableL.captured-register var)) - (translate-local (.nat var)))) - -(def: #export global - (-> Ident SVar) - (|>> //.definition-name _.var)) - -(def: #export (translate-definition name) - (-> Ident (Meta Expression)) - (:: macro.Monad<Meta> wrap (@@ (global name)))) diff --git a/new-luxc/source/luxc/lang/translation/scheme/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/runtime.jvm.lux deleted file mode 100644 index c3f149eeb..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/runtime.jvm.lux +++ /dev/null @@ -1,375 +0,0 @@ -(.module: - lux - (lux (control ["p" parser "p/" Monad<Parser>] - [monad #+ do]) - (data [bit] - [number #+ hex] - text/format - (coll [list "list/" Monad<List>])) - [macro] - (macro [code] - ["s" syntax #+ syntax:]) - [io #+ Process]) - [//] - (luxc [lang] - (lang (host ["_" scheme #+ SVar Expression @@])))) - -(def: prefix Text "LuxRuntime") - -(def: #export unit Expression (_.string //.unit)) - -(def: (flag value) - (-> Bool Expression) - (if value - (_.string "") - _.nil)) - -(def: (variant' tag last? value) - (-> Expression Expression Expression Expression) - (<| (_.cons (_.symbol //.variant-tag)) - (_.cons tag) - (_.cons last?) - value)) - -(def: #export (variant tag last? value) - (-> Nat Bool Expression Expression) - (variant' (_.int (:! Int tag)) (flag last?) value)) - -(def: #export none - Expression - (variant +0 false unit)) - -(def: #export some - (-> Expression Expression) - (variant +1 true)) - -(def: #export left - (-> Expression Expression) - (variant +0 false)) - -(def: #export right - (-> Expression Expression) - (variant +1 true)) - -(type: Runtime Expression) - -(def: declaration - (s.Syntax [Text (List Text)]) - (p.either (p.seq s.local-symbol (p/wrap (list))) - (s.form (p.seq s.local-symbol (p.some s.local-symbol))))) - -(syntax: (runtime: {[name args] declaration} - definition) - (let [implementation (code.local-symbol (format "@@" name)) - runtime (format prefix "__" (lang.normalize-name name)) - $runtime (` (_.var (~ (code.text runtime)))) - @runtime (` (@@ (~ $runtime))) - argsC+ (list/map code.local-symbol args) - argsLC+ (list/map (|>> lang.normalize-name (format "LRV__") code.text (~) (_.var) (`)) - args) - declaration (` ((~ (code.local-symbol name)) - (~+ argsC+))) - type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression))) - _.Expression))] - (wrap (list (` (def: (~' #export) (~ declaration) - (~ type) - (~ (case argsC+ - #.Nil - @runtime - - _ - (` (_.apply (~ @runtime) (list (~+ argsC+)))))))) - (` (def: (~ implementation) - _.Expression - (~ (case argsC+ - #.Nil - (` (_.define (~ $runtime) (~ definition))) - - _ - (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) - (list/map (function (_ [left right]) - (list left right))) - list/join))] - (_.define (~ $runtime) (list (~+ argsLC+)) - (~ definition)))))))))))) - -(runtime: (list-slice offset length list) - (<| (_.if (_.null? (@@ list)) - (@@ list)) - (_.if (|> (@@ offset) (_.> (_.int 0))) - (list-slice (|> (@@ offset) (_.- (_.int 1))) - (@@ length) - (_.cdr (@@ list)))) - (_.if (|> (@@ length) (_.> (_.int 0))) - (_.cons (_.car (@@ list)) - (list-slice (@@ offset) - (|> (@@ length) (_.- (_.int 1))) - (_.cdr (@@ list))))) - _.nil)) - -(syntax: #export (with-vars {vars (s.tuple (p.many s.local-symbol))} - body) - (wrap (list (` (let [(~+ (|> vars - (list/map (function (_ var) - (list (code.local-symbol var) - (` (_.var (~ (code.text (format "LRV__" (lang.normalize-name var))))))))) - list/join))] - (~ body)))))) - -(def: as-integer - (-> Expression Expression) - (_.apply1 (_.global "exact"))) - -(runtime: (lux//try op) - (with-vars [error] - (_.with-exception-handler - (_.lambda (_.poly (list error)) - (..left (@@ error))) - (_.lambda (_.poly (list)) - (..right (_.apply (@@ op) (list ..unit))))))) - -(runtime: (lux//program-args program-args) - (with-vars [loop input output] - (_.letrec (list [loop (_.lambda (_.poly (list input output)) - (_.if (_.eqv? _.nil (@@ input)) - (@@ output) - (_.apply (@@ loop) - (list (_.cdr (@@ input)) - (..some (_.vector (list (_.car (@@ input)) (@@ output))))))))]) - (_.apply (@@ loop) (list (_.apply (_.global "reverse") (list (@@ program-args))) - ..none))))) - -(def: runtime//lux - Runtime - (_.begin (list @@lux//try - @@lux//program-args))) - -(def: minimum-index-length - (-> Expression Expression) - (|>> (_.+ (_.int 1)))) - -(def: product-element - (-> Expression Expression Expression) - _.vector-ref) - -(def: (product-tail product) - (-> Expression Expression) - (_.vector-ref product (|> (_.length product) (_.- (_.int 1))))) - -(def: (updated-index min-length product) - (-> Expression Expression Expression) - (|> min-length (_.- (_.length product)))) - -(runtime: (product//left product index) - (let [$index_min_length (_.var "index_min_length")] - (_.begin - (list (_.define $index_min_length (list) - (minimum-index-length (@@ index))) - (_.if (|> (_.length (@@ product)) (_.> (@@ $index_min_length))) - ## No need for recursion - (product-element (@@ product) (@@ index)) - ## Needs recursion - (product//left (product-tail (@@ product)) - (updated-index (@@ $index_min_length) (@@ product)))))))) - -(runtime: (product//right product index) - (let [$index_min_length (_.var "index_min_length") - $product_length (_.var "product_length") - $slice (_.var "slice")] - (_.begin - (list - (_.define $index_min_length (list) (minimum-index-length (@@ index))) - (_.define $product_length (list) (_.length (@@ product))) - (<| (_.if ## Last element. - (|> (@@ $product_length) (_.= (@@ $index_min_length))) - (product-element (@@ product) (@@ index))) - (_.if ## Needs recursion - (|> (@@ $product_length) (_.< (@@ $index_min_length))) - (product//right (product-tail (@@ product)) - (updated-index (@@ $index_min_length) (@@ product)))) - ## Must slice - (_.begin - (list (_.define $slice (list) - (_.make-vector (|> (@@ $product_length) - (_.- (@@ index))))) - (_.vector-copy! (@@ $slice) (_.int 0) - (@@ product) (@@ index) (@@ $product_length)) - (@@ $slice)))))))) - -(runtime: (sum//get sum wanted_tag wants_last) - (with-vars [variant-tag sum-tag sum-flag sum-value] - (let [no-match _.nil - is-last? (|> (@@ sum-flag) (_.eqv? (_.string ""))) - test-recursion (_.if is-last? - ## Must recurse. - (sum//get (@@ sum-value) - (|> (@@ wanted_tag) (_.- (@@ sum-tag))) - (@@ wants_last)) - no-match)] - (<| (_.let-values (list [(_.poly (list variant-tag sum-tag sum-flag sum-value)) - (_.apply (_.global "apply") (list (_.global "values") (@@ sum)))])) - (_.if (|> (@@ wanted_tag) (_.= (@@ sum-tag))) - (_.if (|> (@@ sum-flag) (_.eqv? (@@ wants_last))) - (@@ sum-value) - test-recursion)) - (_.if (|> (@@ wanted_tag) (_.> (@@ sum-tag))) - test-recursion) - (_.if (_.and (list (|> (@@ wants_last) (_.eqv? (_.string ""))) - (|> (@@ wanted_tag) (_.< (@@ sum-tag))))) - (variant' (|> (@@ sum-tag) (_.- (@@ wanted_tag))) (@@ sum-flag) (@@ sum-value))) - no-match)))) - -(def: runtime//adt - Runtime - (_.begin (list @@product//left - @@product//right - @@sum//get))) - -(runtime: (bit//logical-right-shift shift input) - (_.if (_.= (_.int 0) (@@ shift)) - (@@ input) - (|> (@@ input) - (_.arithmetic-shift (_.* (_.int -1) (@@ shift))) - (_.bit-and (_.int (hex "7FFFFFFFFFFFFFFF")))))) - -(def: runtime//bit - Runtime - (_.begin (list @@bit//logical-right-shift))) - -(runtime: (frac//decode input) - (with-vars [output] - (_.let (list [output ((_.apply1 (_.global "string->number")) (@@ input))]) - (_.if (_.and (list (_.not (_.= (@@ output) (@@ output))) - (_.not (_.eqv? (_.string "+nan.0") (@@ input))))) - ..none - (..some (@@ output)))))) - -(def: runtime//frac - Runtime - (_.begin - (list @@frac//decode))) - -## (def: runtime//text -## Runtime -## (_.begin (list @@text//index -## @@text//clip -## @@text//char))) - -(def: (check-index-out-of-bounds array idx body) - (-> Expression Expression Expression Expression) - (_.if (|> idx (_.<= (_.length array))) - body - (_.raise (_.string "Array index out of bounds!")))) - -(runtime: (array//get array idx) - (with-vars [temp] - (<| (check-index-out-of-bounds (@@ array) (@@ idx)) - (_.let (list [temp (_.vector-ref (@@ array) (@@ idx))]) - (_.if (|> (@@ temp) (_.eqv? _.nil)) - ..none - (..some (@@ temp))))))) - -(runtime: (array//put array idx value) - (<| (check-index-out-of-bounds (@@ array) (@@ idx)) - (_.begin - (list (_.vector-set! (@@ array) (@@ idx) (@@ value)) - (@@ array))))) - -(def: runtime//array - Runtime - (_.begin - (list @@array//get - @@array//put))) - -(runtime: (atom//compare-and-swap atom old new) - (with-vars [temp] - (_.let (list [temp (_.vector-ref (@@ atom) (_.int 0))]) - (_.if (_.eq? (@@ old) (@@ temp)) - (_.begin - (list (_.vector-set! (@@ atom) (_.int 0) (@@ new)) - (_.bool true))) - (_.bool false))))) - -(def: runtime//atom - Runtime - @@atom//compare-and-swap) - -(runtime: (box//write value box) - (_.begin - (list - (_.vector-set! (@@ box) (_.int 0) (@@ value)) - ..unit))) - -(def: runtime//box - Runtime - (_.begin (list @@box//write))) - -(runtime: (io//current-time _) - (|> (_.apply (_.global "current-second") (list)) - (_.* (_.int 1_000)) - as-integer)) - -(def: runtime//io - (_.begin (list @@io//current-time))) - -(def: process//incoming - SVar - (_.var (lang.normalize-name "process//incoming"))) - -(runtime: (process//loop _) - (_.when (_.not (_.null? (@@ process//incoming))) - (with-vars [queue process] - (_.let (list [queue (@@ process//incoming)]) - (_.begin (list (_.set! process//incoming (_.list (list))) - (_.apply (_.global "map") - (list (_.lambda (_.poly (list process)) - (_.apply (@@ process) (list ..unit))) - (@@ queue))) - (process//loop ..unit))))))) - -(runtime: (process//schedule milli-seconds procedure) - (let [process//future (function (_ process) - (_.set! process//incoming (_.cons process (@@ process//incoming))))] - (_.begin - (list - (_.if (_.= (_.int 0) (@@ milli-seconds)) - (process//future (@@ procedure)) - (with-vars [start process now _ignored] - (_.let (list [start (io//current-time ..unit)]) - (_.letrec (list [process (_.lambda _ignored - (_.let (list [now (io//current-time ..unit)]) - (_.if (|> (@@ now) (_.- (@@ start)) (_.>= (@@ milli-seconds))) - (_.apply (@@ procedure) (list ..unit)) - (process//future (@@ process)))))]) - (process//future (@@ process)))))) - ..unit)))) - -(def: runtime//process - Runtime - (_.begin (list (_.define process//incoming (list) (_.list (list))) - @@process//loop - @@process//schedule))) - -(def: runtime - Runtime - (_.begin (list @@list-slice - runtime//lux - runtime//bit - runtime//adt - runtime//frac - ## runtime//text - runtime//array - runtime//atom - runtime//box - runtime//io - runtime//process - ))) - -(def: #export artifact Text (format prefix //.file-extension)) - -(def: #export translate - (Meta (Process Any)) - (do macro.Monad<Meta> - [_ //.init-module-buffer - _ (//.save runtime)] - (//.save-module! artifact))) diff --git a/new-luxc/source/luxc/lang/translation/scheme/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/structure.jvm.lux deleted file mode 100644 index 01ddcbf6f..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/structure.jvm.lux +++ /dev/null @@ -1,31 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data [text] - text/format) - [macro]) - (luxc ["&" lang] - (lang [synthesis #+ Synthesis] - (host [scheme #+ Expression]))) - [//] - (// [".T" runtime])) - -(def: #export (translate-tuple translate elemsS+) - (-> (-> Synthesis (Meta Expression)) (List Synthesis) (Meta Expression)) - (case elemsS+ - #.Nil - (:: macro.Monad<Meta> wrap runtimeT.unit) - - (#.Cons singletonS #.Nil) - (translate singletonS) - - _ - (do macro.Monad<Meta> - [elemsT+ (monad.map @ translate elemsS+)] - (wrap (scheme.vector elemsT+))))) - -(def: #export (translate-variant translate tag tail? valueS) - (-> (-> Synthesis (Meta Expression)) Nat Bool Synthesis (Meta Expression)) - (do macro.Monad<Meta> - [valueT (translate valueS)] - (wrap (runtimeT.variant tag tail? valueT)))) |