diff options
31 files changed, 1483 insertions, 1538 deletions
diff --git a/new-luxc/source/luxc/lang/host/ruby.lux b/new-luxc/source/luxc/lang/host/ruby.lux deleted file mode 100644 index 61c0f8bb5..000000000 --- a/new-luxc/source/luxc/lang/host/ruby.lux +++ /dev/null @@ -1,223 +0,0 @@ -(.module: - [lux #- not or and] - (lux - (control - pipe) - (data [text] - text/format - (coll [list "list/" Functor<List> Fold<List>])))) - -(type: #export Ruby Text) - -(type: #export Expression Ruby) - -(type: #export Statement Ruby) - -(def: #export nil - Expression - "nil") - -(def: #export bool - (-> Bit Expression) - (|>> (case> #0 "false" - #1 "true"))) - -(def: #export int - (-> Int Expression) - %i) - -(def: #export float - (-> Frac Expression) - %f) - -(def: #export (string value) - (-> Text Expression) - (%t value)) - -(def: #export splat - (-> Expression Expression) - (|>> (format "*"))) - -(def: #export (array-range from to array) - (-> Expression Expression Expression Expression) - (format "(" array "[" from ".." to "])")) - -(def: #export (array elements) - (-> (List Expression) Expression) - (format "([" (text.join-with "," elements) "])")) - -(def: #export (dictionary kvs) - (-> (List [Expression Expression]) Expression) - (format "({" - (|> kvs - (list/map (.function (_ [k v]) - (format k " => " v))) - (text.join-with ", ")) - "})")) - -(def: #export (apply func args) - (-> Expression (List Expression) Expression) - (format "(" func "(" (text.join-with "," args) ")" ")")) - -(def: #export (send method args object) - (-> Text (List Expression) Expression Expression) - (apply (format object "." method) args)) - -(def: #export call - (-> (List Expression) Expression Expression) - (send "call")) - -(def: #export (nth idx array) - (-> Expression Expression Expression) - (format "(" array "[" idx "])")) - -(def: #export (set-nth! idx value array) - (-> Expression Expression Expression Statement) - (format array "[" idx "] = " value ";")) - -(def: #export (field name object) - (-> Text Expression Expression) - (format "(" object "." name ")")) - -(def: #export (length array) - (-> Expression Expression) - (format "(" array ".length)")) - -(def: #export (set! vars value) - (-> (List Text) Expression Statement) - (format (text.join-with ", " vars) " = " value ";")) - -(def: #export (global var) - (-> Text Expression) - (format "$" var)) - -(def: #export (global! var value) - (-> Text Expression Statement) - (set! (list (global var)) value)) - -(def: #export (? test then! else!) - (-> Expression Expression Expression Expression) - (format "(" test " ? " then! " : " else! ")")) - -(def: #export (if! test then! else!) - (-> Expression Statement Statement Statement) - (format "if " test - "\n" then! - "\n" "else" - "\n" else! - "\n" "end;")) - -(def: #export (when! test then!) - (-> Expression Statement Statement) - (format "if " test - "\n" then! - "\n" "end;")) - -(def: #export (cond! clauses else!) - (-> (List [Expression Statement]) Statement Statement) - (list/fold (.function (_ [test then!] next!) - (if! test then! next!)) - else! - (list.reverse clauses))) - -(def: #export (block! statements) - (-> (List Statement) Statement) - (text.join-with " " statements)) - -(def: #export (statement expression) - (-> Expression Statement) - (format expression ";")) - -(def: #export (while! test body) - (-> Expression Statement Statement) - (format "while " test - "\n" body - "\n" "end;")) - -(def: #export (for-in! var array body) - (-> Text Expression Statement Statement) - (format "for " var " in " array "do" "\n" - body "\n" - "end;" "\n")) - -(def: #export (begin! body rescues) - (-> Statement (List [(List Text) Text Statement]) Statement) - (format "begin" - "\n" body "\n" - (|> rescues - (list/map (function (_ [ex-classes ex-value ex-handler]) - (format "rescue " (text.join-with ", " ex-classes) - (case ex-value - "" "" - _ (format " => " ex-value)) - "\n" - ex-handler))) - (text.join-with "\n")) - "\n" "end;")) - -(def: #export (raise message) - (-> Expression Expression) - (format "raise " message ";")) - -(def: #export (return! value) - (-> Expression Statement) - (format "return " value ";")) - -(def: #export (function! name args body) - (-> Text (List Text) Statement Statement) - (format "def " name "(" (text.join-with "," args) ")\n" - body - "\n" "end;")) - -(def: #export (lambda name args body) - (-> (Maybe Text) (List Text) Statement Expression) - (let [proc (format "lambda {" (format "|" (text.join-with ", " args) "|") " " body "}")] - (case name - #.None - (format "(" proc ")") - - (#.Some name) - (format "(" name " = " proc ")")))) - -(template [<name> <op>] - [(def: #export (<name> param subject) - (-> Expression Expression Expression) - (format "(" subject " " <op> " " param ")"))] - - [= "=="] - [< "<"] - [<= "<="] - [> ">"] - [>= ">="] - [+ "+"] - [- "-"] - [* "*"] - [/ "/"] - [% "%"] - [pow "**"] - ) - -(template [<name> <op>] - [(def: #export (<name> param subject) - (-> Expression Expression Expression) - (format "(" param " " <op> " " subject ")"))] - - [or "||"] - [and "&&"] - [bit-or "|"] - [bit-and "&"] - [bit-xor "^"] - ) - -(template [<name> <op>] - [(def: #export (<name> param subject) - (-> Expression Expression Expression) - (format "(" subject " " <op> " " param ")"))] - - [bit-shl "<<"] - [bit-shr ">>"] - ) - -(def: #export (not subject) - (-> Expression Expression) - (format "(!" subject ")")) diff --git a/new-luxc/source/luxc/lang/translation/ruby/case.jvm.lux b/new-luxc/source/luxc/lang/translation/ruby/case.jvm.lux deleted file mode 100644 index d83a5cd0a..000000000 --- a/new-luxc/source/luxc/lang/translation/ruby/case.jvm.lux +++ /dev/null @@ -1,173 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - (data text/format - (coll [list "list/" Fold<List>])) - [macro #+ "meta/" Monad<Meta>]) - (luxc [lang] - (lang ["ls" synthesis] - (host [ruby #+ Ruby Expression Statement]))) - [//] - (// [".T" runtime] - [".T" primitive] - [".T" reference])) - -(def: (expression-block body) - (-> Statement Expression) - (ruby.call (list) - (ruby.lambda #.None (list) - body))) - -(def: #export (translate-let translate register valueS bodyS) - (-> (-> ls.Synthesis (Meta Expression)) Nat ls.Synthesis ls.Synthesis - (Meta Expression)) - (do macro.Monad<Meta> - [valueO (translate valueS) - bodyO (translate bodyS)] - (wrap (expression-block - (ruby.block! (list (ruby.set! (list (referenceT.variable register)) valueO) - (ruby.return! bodyO))))))) - -(def: #export (translate-record-get translate valueS path) - (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis (List [Nat Bit]) - (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 (ruby.int (:coerce Int idx))))) - valueO - path)))) - -(def: #export (translate-if testO thenO elseO) - (-> Expression Expression Expression Expression) - (expression-block - (ruby.if! testO - (ruby.return! thenO) - (ruby.return! elseO)))) - -(def: savepoint - Expression - "pm_cursor_savepoint") - -(def: cursor - Expression - "pm_cursor") - -(def: (push-cursor! value) - (-> Expression Statement) - (ruby.statement (ruby.send "push" (list value) cursor))) - -(def: save-cursor! - Statement - (ruby.statement - (ruby.send "push" - (list (ruby.array-range (ruby.int 0) (ruby.int -1) cursor)) - savepoint))) - -(def: restore-cursor! - Statement - (ruby.set! (list cursor) (ruby.send "pop" (list) savepoint))) - -(def: cursor-top - Expression - (ruby.nth (ruby.- (ruby.int 1) - (ruby.length cursor)) - cursor)) - -(def: pop-cursor! - Statement - (ruby.statement (ruby.send "pop" (list) cursor))) - -(def: pm-error - Expression - (ruby.string "PM-ERROR")) - -(exception: #export (Unrecognized-Path {message Text}) - message) - -(def: (translate-pattern-matching' translate path) - (-> (-> ls.Synthesis (Meta Expression)) Code (Meta Expression)) - (case path - (^code ("lux case exec" (~ bodyS))) - (do macro.Monad<Meta> - [bodyO (translate bodyS)] - (wrap (ruby.return! bodyO))) - - (^code ("lux case pop")) - (meta/wrap pop-cursor!) - - (^code ("lux case bind" (~ [_ (#.Nat register)]))) - (meta/wrap (ruby.set! (list (referenceT.variable register)) cursor-top)) - - (^template [<tag> <format>] - [_ (<tag> value)] - (meta/wrap (ruby.when! (ruby.not (ruby.= (|> value <format>) cursor-top)) - (ruby.raise pm-error)))) - ([#.Int ruby.int] - [#.Bit ruby.bool] - [#.Frac ruby.float] - [#.Text ruby.string]) - - (^template [<pm> <getter>] - (^code (<pm> (~ [_ (#.Nat idx)]))) - (meta/wrap (push-cursor! (<getter> cursor-top (ruby.int (:coerce 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 (ruby.block! (list (ruby.set! (list "temp") (runtimeT.sum//get cursor-top (ruby.int (:coerce Int idx)) <flag>)) - (ruby.if! (ruby.= ruby.nil "temp") - (ruby.raise pm-error) - (push-cursor! "temp")))))) - (["lux case variant left" ruby.nil] - ["lux case variant right" (ruby.string "")]) - - (^code ("lux case seq" (~ leftP) (~ rightP))) - (do macro.Monad<Meta> - [leftO (translate-pattern-matching' translate leftP) - rightO (translate-pattern-matching' translate rightP)] - (wrap (ruby.block! (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 (ruby.begin! (ruby.block! (list save-cursor! - leftO)) - (list [(list) "alt_error" (ruby.if! (ruby.= pm-error (ruby.field "message" "alt_error")) - (ruby.block! (list restore-cursor! - rightO)) - (ruby.raise "alt_error"))])))) - - _ - (lang.throw Unrecognized-Path (%code path)) - )) - -(def: (translate-pattern-matching translate path) - (-> (-> ls.Synthesis (Meta Expression)) Code (Meta Expression)) - (do macro.Monad<Meta> - [pattern-matching (translate-pattern-matching' translate path)] - (wrap (ruby.begin! pattern-matching - (list [(list) "alt_error" - (ruby.if! (ruby.= pm-error (ruby.field "message" "alt_error")) - (ruby.raise (ruby.string "Invalid expression for pattern-matching.")) - (ruby.raise "alt_error"))]))))) - -(def: (initialize-pattern-matching stack-init) - (-> Expression Statement) - (ruby.block! (list (ruby.set! (list cursor) (ruby.array (list stack-init))) - (ruby.set! (list savepoint) (ruby.array (list)))))) - -(def: #export (translate-case translate valueS path) - (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis Code (Meta Expression)) - (do macro.Monad<Meta> - [valueO (translate valueS) - pattern-matching (translate-pattern-matching translate path)] - (wrap (expression-block - (ruby.block! (list (initialize-pattern-matching valueO) - pattern-matching)))))) diff --git a/new-luxc/source/luxc/lang/translation/ruby/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/ruby/expression.jvm.lux deleted file mode 100644 index 3016836b9..000000000 --- a/new-luxc/source/luxc/lang/translation/ruby/expression.jvm.lux +++ /dev/null @@ -1,85 +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 [ruby #+ Ruby Expression Statement]))) - [//] - (// [".T" runtime] - [".T" primitive] - [".T" structure] - [".T" function] - [".T" reference] - [".T" case] - [".T" procedure])) - -(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) - - (^code [(~ singleton)]) - (translate singleton) - - (^template [<tag> <generator>] - [_ (<tag> value)] - (<generator> value)) - ([#.Bit primitiveT.translate-bit] - [#.Int primitiveT.translate-int] - [#.Frac primitiveT.translate-frac] - [#.Text primitiveT.translate-text]) - - (^code ((~ [_ (#.Nat tag)]) (~ [_ (#.Bit last?)]) (~ valueS))) - (structureT.translate-variant translate tag last? valueS) - - (^code [(~+ members)]) - (structureT.translate-tuple translate members) - - (^ [_ (#.Form (list [_ (#.Int var)]))]) - (referenceT.translate-variable var) - - [_ (#.Identifier definition)] - (referenceT.translate-definition definition) - - (^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 ("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 call" (~ functionS) (~+ argsS))) - (functionT.translate-apply translate functionS argsS) - - (^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/ruby/function.jvm.lux b/new-luxc/source/luxc/lang/translation/ruby/function.jvm.lux deleted file mode 100644 index 64c2bba2e..000000000 --- a/new-luxc/source/luxc/lang/translation/ruby/function.jvm.lux +++ /dev/null @@ -1,79 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data [product] - [text] - text/format - (coll [list "list/" Functor<List>])) - [macro]) - (luxc ["&" lang] - (lang ["ls" synthesis] - [".L" variable #+ Variable Register] - (host [ruby #+ Ruby Expression Statement]))) - [//] - (// [".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 (ruby.call argsO+ functionO)))) - -(def: (input-declaration registers) - (-> (List Register) Statement) - (ruby.set! (list.concat (list (list/map (|>> inc referenceT.variable) registers) - (list "_"))) - "curried")) - -(def: (with-closure inits function-definition) - (-> (List Expression) Statement Expression) - (case inits - #.Nil - function-definition - - _ - (ruby.call inits - (ruby.lambda #.None - (|> (list.enumerate inits) - (list/map (|>> product.left referenceT.closure))) - (ruby.return! function-definition))))) - -(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 [args-initsO+ (input-declaration (list.n/range +0 (dec arity))) - selfO (ruby.set! (list (referenceT.variable +0)) function-name) - arityO (|> arity .int %i) - limitO (|> arity dec .int %i)]] - (wrap (with-closure closureO+ - (ruby.lambda (#.Some function-name) - (list (ruby.splat "curried")) - (ruby.block! (list (ruby.set! (list "num_args") (ruby.length "curried")) - (ruby.if! (ruby.= arityO "num_args") - (ruby.block! (list selfO - args-initsO+ - (ruby.while! (ruby.bool #1) - (ruby.return! bodyO)))) - (ruby.return! (let [recur (function (_ args) (ruby.call (list args) function-name))] - (ruby.? (ruby.> arityO "num_args") - (let [slice (function (_ from to) - (ruby.array-range from to "curried")) - arity-args (ruby.splat (slice (ruby.int 0) limitO)) - output-func-args (ruby.splat (slice arityO "num_args"))] - (ruby.call (list output-func-args) - (recur arity-args))) - (ruby.lambda #.None - (list (ruby.splat "extra")) - (recur (ruby.splat (|> (ruby.array (list)) - (ruby.send "concat" (list "curried")) - (ruby.send "concat" (list "extra"))))))))))))))))) diff --git a/new-luxc/source/luxc/lang/translation/ruby/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/ruby/loop.jvm.lux deleted file mode 100644 index 3c2124565..000000000 --- a/new-luxc/source/luxc/lang/translation/ruby/loop.jvm.lux +++ /dev/null @@ -1,35 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data [text] - text/format - (coll [list "list/" Functor<List>])) - [macro]) - (luxc [lang] - (lang ["ls" synthesis] - (host [ruby #+ Ruby Expression Statement]))) - [//] - (// [".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 (:: @ map (|>> %code lang.normalize-name) - (macro.gensym "loop")) - initsO+ (monad.map @ translate initsS+) - bodyO (//.with-anchor [loop-name offset] - (translate bodyS)) - #let [registersO+ (|> (list.n/range +0 (dec (list.size initsS+))) - (list/map (|>> (n/+ offset) referenceT.variable)))] - _ (//.save (ruby.function! loop-name registersO+ - (ruby.return! bodyO)))] - (wrap (ruby.apply loop-name initsO+)))) - -(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 (ruby.apply loop-name argsO+)))) diff --git a/new-luxc/source/luxc/lang/translation/ruby/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/ruby/primitive.jvm.lux deleted file mode 100644 index cc5e5752e..000000000 --- a/new-luxc/source/luxc/lang/translation/ruby/primitive.jvm.lux +++ /dev/null @@ -1,34 +0,0 @@ -(.module: - lux - (lux (control pipe) - (data [number] - text/format) - [macro "meta/" Monad<Meta>]) - (luxc (lang (host [ruby #+ Ruby Expression Statement])))) - -(def: #export translate-bit - (-> Bit (Meta Expression)) - (|>> ruby.bool meta/wrap)) - -(def: #export translate-int - (-> Int (Meta Expression)) - (|>> ruby.int meta/wrap)) - -(def: #export translate-frac - (-> Frac (Meta Expression)) - (|>> (cond> [(f/= number.positive-infinity)] - [(new> "(1.0/0.0)")] - - [(f/= number.negative-infinity)] - [(new> "(-1.0/0.0)")] - - [(f/= number.not-a-number)] - [(new> "(0.0/0.0)")] - - ## else - [%f]) - meta/wrap)) - -(def: #export translate-text - (-> Text (Meta Expression)) - (|>> %t meta/wrap)) diff --git a/new-luxc/source/luxc/lang/translation/ruby/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/ruby/procedure/common.jvm.lux deleted file mode 100644 index c60938d79..000000000 --- a/new-luxc/source/luxc/lang/translation/ruby/procedure/common.jvm.lux +++ /dev/null @@ -1,372 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - ["p" parser]) - (data ["e" error] - [text] - text/format - (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 [ruby #+ Ruby Expression Statement]))) - [///] - (/// [".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-identifier} {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-identifier 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 - (ruby.= leftO rightO)) - -(def: (lux//if [testO thenO elseO]) - Trinary - (caseT.translate-if testO thenO elseO)) - -(def: (lux//try riskyO) - Unary - (runtimeT.lux//try riskyO)) - -(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 "is" (binary lux//is)) - (install "try" (unary lux//try)) - (install "if" (trinary lux//if)) - (install "loop" lux//loop) - (install "recur" lux//recur) - )) - -## [[Bits]] -(template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (<op> paramO subjectO))] - - [bit//and ruby.bit-and] - [bit//or ruby.bit-or] - [bit//xor ruby.bit-xor] - ) - -(def: (bit//left-shift [subjectO paramO]) - Binary - (ruby.bit-and "0xFFFFFFFFFFFFFFFF" - (ruby.bit-shl paramO subjectO))) - -(template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (<op> paramO subjectO))] - - [bit//arithmetic-right-shift ruby.bit-shr] - [bit//logical-right-shift runtimeT.bit//logical-right-shift] - ) - -(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)) - ))) - -## [[Numbers]] -(host.import: java/lang/Double - (#static MIN_VALUE Double) - (#static MAX_VALUE Double)) - -(template [<name> <const> <encode>] - [(def: (<name> _) - Nullary - (<encode> <const>))] - - [frac//smallest Double::MIN_VALUE ruby.float] - [frac//min (f/* -1.0 Double::MAX_VALUE) ruby.float] - [frac//max Double::MAX_VALUE ruby.float] - ) - -(template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (ruby.bit-and "0xFFFFFFFFFFFFFFFF" - (<op> paramO subjectO)))] - - [int//add ruby.+] - [int//sub ruby.-] - [int//mul ruby.*] - ) - -(template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (<op> paramO subjectO))] - - [int//div ruby./] - [int//rem ruby.%] - ) - -(template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (<op> paramO subjectO))] - - [frac//add ruby.+] - [frac//sub ruby.-] - [frac//mul ruby.*] - [frac//div ruby./] - [frac//rem ruby.%] - [frac//= ruby.=] - [frac//< ruby.<] - - [text//= ruby.=] - [text//< ruby.<] - ) - -(template [<name> <cmp>] - [(def: (<name> [subjectO paramO]) - Binary - (<cmp> paramO subjectO))] - - [int//= ruby.=] - [int//< ruby.<] - ) - -(def: frac//encode - Unary - (ruby.send "to_s" (list))) - -(def: (frac//decode inputO) - Unary - (ruby.call (list) - (ruby.lambda #.None (list) - (ruby.block! (list (ruby.set! (list "input") inputO) - (ruby.set! (list "temp") (ruby.send "to_f" (list) "input")) - (ruby.if! (ruby.or (ruby.not (ruby.= (ruby.float 0.0) "temp")) - (ruby.or (ruby.= (ruby.string "0") "input") - (ruby.= (ruby.string "0.0") "input"))) - (ruby.return! (runtimeT.some "temp")) - (ruby.return! runtimeT.none))))))) - -(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 "to-frac" (unary (ruby./ (ruby.float 1.0)))) - (install "char" (unary (ruby.send "chr" (list))))))) - -(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 "to-int" (unary (ruby.send "floor" (list)))) - (install "encode" (unary frac//encode)) - (install "decode" (unary frac//decode))))) - -## [[Text]] -(template [<name> <op>] - [(def: <name> - Unary - (ruby.send <op> (list)))] - - [text//size "length"] - ) - -(def: (text//concat [subjectO paramO]) - Binary - (|> subjectO (ruby.+ paramO))) - -(def: (text//char [subjectO paramO]) - Binary - (runtimeT.text//char subjectO paramO)) - -(def: (text//clip [subjectO paramO extraO]) - Trinary - (runtimeT.text//clip subjectO paramO extraO)) - -(def: (text//index [textO partO startO]) - Trinary - (runtimeT.text//index textO partO startO)) - -(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 text//size)) - (install "char" (binary text//char)) - (install "clip" (trinary text//clip)) - ))) - -## [[IO]] -(def: (io//log messageO) - Unary - (ruby.or (ruby.apply "puts" (list (ruby.+ (ruby.string "\n") messageO))) - runtimeT.unit)) - -(def: io//error - Unary - ruby.raise) - -(def: io//exit - Unary - (|>> (list) (ruby.apply "exit"))) - -(def: (io//current-time []) - Nullary - (|> "Time" - (ruby.send "now" (list)) - (ruby.send "to_f" (list)) - (ruby.* (ruby.float 1000.0)) - (ruby.send "to_i" (list)))) - -(def: io-procs - Bundle - (<| (prefix "io") - (|> (dict.new text.Hash<Text>) - (install "log" (unary io//log)) - (install "error" (unary io//error)) - (install "exit" (unary io//exit)) - (install "current-time" (nullary io//current-time))))) - -## [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 io-procs) - ))) diff --git a/new-luxc/source/luxc/lang/translation/ruby/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/ruby/procedure/host.jvm.lux deleted file mode 100644 index 2793b40e8..000000000 --- a/new-luxc/source/luxc/lang/translation/ruby/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])) - -## (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/ruby/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/ruby/reference.jvm.lux deleted file mode 100644 index 80e78951b..000000000 --- a/new-luxc/source/luxc/lang/translation/ruby/reference.jvm.lux +++ /dev/null @@ -1,36 +0,0 @@ -(.module: - lux - (lux [macro] - (data [text] - text/format)) - (luxc ["&" lang] - (lang [".L" variable #+ Variable Register] - (host [ruby #+ Ruby Expression Statement]))) - [//] - (// [".T" runtime])) - -(template [<register> <translation> <prefix>] - [(def: #export (<register> register) - (-> Register Expression) - (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 (translate-variable var) - (-> Variable (Meta Expression)) - (if (variableL.captured? var) - (translate-captured (variableL.captured-register var)) - (translate-local (.nat var)))) - -(def: #export global - (-> Name Expression) - //.definition-name) - -(def: #export (translate-definition name) - (-> Name (Meta Expression)) - (:: macro.Monad<Meta> wrap (ruby.global (global name)))) diff --git a/new-luxc/source/luxc/lang/translation/ruby/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/ruby/runtime.jvm.lux deleted file mode 100644 index 02de3dc7b..000000000 --- a/new-luxc/source/luxc/lang/translation/ruby/runtime.jvm.lux +++ /dev/null @@ -1,250 +0,0 @@ -(.module: - lux - (lux (control ["p" parser "p/" Monad<Parser>] - [monad #+ do]) - (data text/format - (coll [list "list/" Monad<List>])) - [macro] - (macro [code] - ["s" syntax #+ syntax:]) - [io #+ Process]) - [//] - (luxc [lang] - (lang (host [ruby #+ Ruby Expression Statement])))) - -(def: prefix Text "LuxRuntime") - -(def: #export unit Expression (%t //.unit)) - -(def: (flag value) - (-> Bit Ruby) - (if value - (ruby.string "") - ruby.nil)) - -(def: (variant' tag last? value) - (-> Expression Expression Expression Expression) - (ruby.dictionary (list [(ruby.string //.variant-tag-field) tag] - [(ruby.string //.variant-flag-field) last?] - [(ruby.string //.variant-value-field) value]))) - -(def: #export (variant tag last? value) - (-> Nat Bit Expression Expression) - (variant' (%i (.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)) - -(type: Runtime Ruby) - -(def: declaration - (s.Syntax [Text (List Text)]) - (p.either (p.seq s.local-identifier (p/wrap (list))) - (s.form (p.seq s.local-identifier (p.some s.local-identifier))))) - -(syntax: (runtime: {[name args] declaration} - definition) - (let [implementation (code.local-identifier (format "@@" name)) - runtime (code.text (format "__" prefix "__" (lang.normalize-name name))) - argsC+ (list/map code.local-identifier args) - argsLC+ (list/map (|>> lang.normalize-name code.text) args) - declaration (` ((~ (code.local-identifier name)) - (~+ argsC+))) - type (` (-> (~+ (list.repeat (list.size argsC+) (` ruby.Ruby))) - ruby.Ruby))] - (wrap (list (` (def: #export (~ declaration) - (~ type) - (ruby.apply (~ runtime) (list (~+ argsC+))))) - (` (def: (~ implementation) - Ruby - (~ (case argsC+ - #.Nil - (` (ruby.set! (list (~ runtime)) (~ definition))) - - _ - (` (let [(~' @) (~ runtime) - (~+ (|> (list.zip2 argsC+ argsLC+) - (list/map (function (_ [left right]) (list left right))) - list/join))] - (ruby.function! (~ runtime) - (list (~+ argsLC+)) - (~ definition)))))))))))) - -(runtime: (lux//try op) - (ruby.begin! (ruby.block! (list (ruby.set! (list "value") (ruby.call (list unit) op)) - (ruby.return! (right "value")))) - (list [(list) "error" - (ruby.return! (left (ruby.field "message" "error")))]))) - -(runtime: (lux//program-args program-args) - (ruby.block! (list (ruby.set! (list "inputs") none) - (ruby.for-in! "value" program-args - (ruby.set! (list "inputs") (some (ruby.array (list "value" "inputs"))))) - (ruby.return! "inputs")))) - -(def: runtime//lux - Runtime - (format @@lux//try "\n" - @@lux//program-args "\n")) - -(runtime: (product//left product index) - (ruby.block! (list (ruby.set! (list "index_min_length") (ruby.+ (ruby.int 1) index)) - (ruby.if! (ruby.> "index_min_length" (ruby.length product)) - ## No need for recursion - (ruby.return! (ruby.nth index product)) - ## Needs recursion - (ruby.return! (product//left (ruby.nth (ruby.- (ruby.int 1) - (ruby.length product)) - product) - (ruby.- (ruby.length product) - "index_min_length"))))))) - -(runtime: (product//right product index) - (ruby.block! (list (ruby.set! (list "index_min_length") (ruby.+ (ruby.int 1) index)) - (ruby.cond! (list [(ruby.= "index_min_length" (ruby.length product)) - ## Last element. - (ruby.return! (ruby.nth index product))] - [(ruby.< "index_min_length" (ruby.length product)) - ## Needs recursion - (ruby.return! (product//right (ruby.nth (ruby.- (ruby.int 1) - (ruby.length product)) - product) - (ruby.- (ruby.length product) - "index_min_length")))]) - ## Must slice - (ruby.return! (ruby.array-range index (ruby.length product) product)))))) - -(runtime: (sum//get sum wantedTag wantsLast) - (let [no-match! (ruby.return! ruby.nil) - sum-tag (ruby.nth (ruby.string //.variant-tag-field) sum) - sum-flag (ruby.nth (ruby.string //.variant-flag-field) sum) - sum-value (ruby.nth (ruby.string //.variant-value-field) sum) - is-last? (ruby.= (ruby.string "") sum-flag) - test-recursion! (ruby.if! is-last? - ## Must recurse. - (ruby.return! (sum//get sum-value (ruby.- sum-tag wantedTag) wantsLast)) - no-match!)] - (ruby.cond! (list [(ruby.= sum-tag wantedTag) - (ruby.if! (ruby.= wantsLast sum-flag) - (ruby.return! sum-value) - test-recursion!)] - - [(ruby.> sum-tag wantedTag) - test-recursion!] - - [(ruby.and (ruby.< sum-tag wantedTag) - (ruby.= (ruby.string "") wantsLast)) - (ruby.return! (variant' (ruby.- wantedTag sum-tag) sum-flag sum-value))]) - - no-match!))) - -(def: runtime//adt - Runtime - (format @@product//left "\n" - @@product//right "\n" - @@sum//get "\n")) - -(runtime: (bit//logical-right-shift param subject) - (let [mask (|> (ruby.int 1) - (ruby.bit-shl (ruby.- param (ruby.int 64))) - (ruby.- (ruby.int 1)))] - (ruby.return! (|> subject - (ruby.bit-shr param) - (ruby.bit-and mask))))) - -(def: runtime//bit - Runtime - @@bit//logical-right-shift) - -(runtime: (text//index subject param start) - (ruby.block! (list (ruby.set! (list "idx") (ruby.send "index" (list param start) subject)) - (ruby.if! (ruby.= ruby.nil "idx") - (ruby.return! none) - (ruby.return! (some "idx")))))) - -(runtime: (text//clip text from to) - (ruby.if! ($_ ruby.and - (ruby.>= (ruby.int 0) from) - (ruby.< (ruby.send "length" (list) text) from) - (ruby.>= (ruby.int 0) to) - (ruby.< (ruby.send "length" (list) text) to) - (ruby.<= to from)) - (ruby.return! (some (ruby.array-range from to text))) - (ruby.return! none))) - -(runtime: (text//char text idx) - (ruby.if! (ruby.and (ruby.>= (ruby.int 0) idx) - (ruby.< (ruby.send "length" (list) text) idx)) - (ruby.return! (some (ruby.send "ord" (list) - (ruby.array-range idx idx text)))) - (ruby.return! none))) - -(def: runtime//text - Runtime - (format @@text//index - @@text//clip - @@text//char)) - -(def: (check-index-out-of-bounds array idx body!) - (-> Expression Expression Statement Statement) - (ruby.if! (ruby.<= (ruby.length array) - idx) - body! - (ruby.raise (ruby.string "Array index out of bounds!")))) - -(runtime: (array//get array idx) - (<| (check-index-out-of-bounds array idx) - (ruby.block! (list (ruby.set! (list "temp") (ruby.nth idx array)) - (ruby.if! (ruby.= ruby.nil "temp") - (ruby.return! none) - (ruby.return! (some "temp"))))))) - -(runtime: (array//put array idx value) - (<| (check-index-out-of-bounds array idx) - (ruby.block! (list (ruby.set-nth! idx value array) - (ruby.return! array))))) - -(def: runtime//array - Runtime - (format @@array//get - @@array//put)) - -(runtime: (box//write value box) - (ruby.block! (list (ruby.set-nth! (ruby.int 0) value box) - (ruby.return! ..unit)))) - -(def: runtime//box - Runtime - (format @@box//write)) - -(def: runtime - Runtime - (format runtime//lux "\n" - runtime//adt "\n" - runtime//bit "\n" - runtime//text "\n" - runtime//array "\n" - runtime//box "\n" - )) - -(def: #export artifact Text (format prefix ".rb")) - -(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/ruby/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/ruby/statement.jvm.lux deleted file mode 100644 index a9fbc7152..000000000 --- a/new-luxc/source/luxc/lang/translation/ruby/statement.jvm.lux +++ /dev/null @@ -1,48 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - [macro] - (data text/format)) - (luxc (lang [".L" module] - (host [ruby #+ Ruby Expression Statement]))) - [//] - (// [".T" runtime] - [".T" reference] - [".T" eval])) - -(def: #export (translate-def name expressionT expressionO metaV) - (-> Text Type Expression Code (Meta Any)) - (do macro.Monad<Meta> - [current-module macro.current-module-name - #let [def-name [current-module name]]] - (case (macro.get-identifier-ann (name-of #.alias) metaV) - (#.Some real-def) - (do @ - [[realT realA realV] (macro.find-def real-def) - _ (moduleL.define def-name [realT metaV realV])] - (wrap [])) - - _ - (do @ - [#let [def-name (referenceT.global def-name)] - _ (//.save (ruby.global! def-name expressionO)) - expressionV (evalT.eval (ruby.global def-name)) - _ (moduleL.define def-name [expressionT metaV expressionV]) - _ (if (macro.type? metaV) - (case (macro.declared-tags metaV) - #.Nil - (wrap []) - - tags - (moduleL.declare-tags tags (macro.export? metaV) (:coerce Type expressionV))) - (wrap [])) - #let [_ (log! (format "DEF " (%name def-name)))]] - (wrap [])) - ))) - -(def: #export (translate-program programO) - (-> Expression (Meta Statement)) - (macro.fail "translate-program NOT IMPLEMENTED YET") - ## (hostT.save (format "var " (referenceT.variable +0) " = " runtimeT.lux//program-args "();" - ## "(" programO ")(null);")) - ) diff --git a/new-luxc/source/luxc/lang/translation/ruby/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/ruby/structure.jvm.lux deleted file mode 100644 index 2a1f81d37..000000000 --- a/new-luxc/source/luxc/lang/translation/ruby/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 [ruby #+ Ruby Expression Statement]))) - [//] - (// [".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 (ruby.array elemsT+))))) - -(def: #export (translate-variant translate tag tail? valueS) - (-> (-> Synthesis (Meta Expression)) Nat Bit Synthesis (Meta Expression)) - (do macro.Monad<Meta> - [valueT (translate valueS)] - (wrap (runtimeT.variant tag tail? valueT)))) diff --git a/stdlib/source/lux/host/python.lux b/stdlib/source/lux/host/python.lux index ce9a2e504..d2fe7f9c7 100644 --- a/stdlib/source/lux/host/python.lux +++ b/stdlib/source/lux/host/python.lux @@ -1,7 +1,7 @@ (.module: [lux (#- Code not or and list if cond int comment) [control - pipe] + [pipe (#+ new> case> cond>)]] [data [number ["." frac]] @@ -60,13 +60,15 @@ [Label Code] ) - (abstract: #export Single {} Any) - (abstract: #export Poly {} Any) - (abstract: #export Keyword {} Any) + (template [<var> <brand>] + [(abstract: #export <brand> {} Any) - (type: #export SVar (Var Single)) - (type: #export PVar (Var Poly)) - (type: #export KVar (Var Keyword)) + (type: #export <var> (Var <brand>))] + + [SVar Single] + [PVar Poly] + [KVar Keyword] + ) (def: #export var (-> Text SVar) diff --git a/stdlib/source/lux/host/ruby.lux b/stdlib/source/lux/host/ruby.lux new file mode 100644 index 000000000..6bf113ed0 --- /dev/null +++ b/stdlib/source/lux/host/ruby.lux @@ -0,0 +1,392 @@ +(.module: + [lux (#- Code static int if cond function or and not comment) + [control + [pipe (#+ case> cond> new>)]] + [data + [number + ["." frac]] + ["." text + format] + [collection + ["." list ("#@." functor fold)]]] + [macro + ["." template] + ["." code] + ["s" syntax (#+ syntax:)]] + [type + abstract]]) + +(def: input-separator ", ") +(def: statement-suffix ";") + +(def: nest + (-> Text Text) + (|>> (format text.new-line) + (text.replace-all text.new-line (format text.new-line text.tab)))) + +(abstract: #export (Code brand) + {} + + Text + + (def: #export manual + (-> Text Code) + (|>> :abstraction)) + + (def: #export code + (-> (Code Any) Text) + (|>> :representation)) + + (template [<type> <super>] + [(with-expansions [<brand> (template.identifier [<type> "'"])] + (`` (abstract: #export (<brand> brand) {} Any)) + (`` (type: #export (<type> brand) + (<super> (<brand> brand)))))] + + [Expression Code] + [Computation Expression] + [Location Computation] + [Var Location] + [Statement Code] + ) + + (template [<type> <super>] + [(with-expansions [<brand> (template.identifier [<type> "'"])] + (`` (abstract: #export <brand> {} Any)) + (`` (type: #export <type> (<super> <brand>))))] + + [Literal Computation] + [Access Location] + [Loop Statement] + [Label Code] + ) + + (template [<var> <brand> <prefix> <constructor>] + [(abstract: #export <brand> {} Any) + + (type: #export <var> (Var <brand>)) + + (def: #export <constructor> + (-> Text <var>) + (|>> (format <prefix>) :abstraction))] + + [GVar Global "$" global] + [IVar Instance "@" instance] + [SVar Static "@@" static] + ) + + (abstract: #export (Local brand) {} Any) + (type: #export LVar (Var (Local Any))) + + (def: #export local + (-> Text LVar) + (|>> :abstraction)) + + (template [<var> <brand> <prefix> <modifier> <unpacker>] + [(abstract: #export <brand> {} Any) + + (type: #export <var> (Var (Local <brand>))) + + (template [<name> <input> <output>] + [(def: #export <name> + (-> <input> <output>) + (|>> :representation (format <prefix>) :abstraction))] + + [<modifier> LVar <var>] + [<unpacker> (Expression Any) (Computation Any)] + )] + + [LVar* Poly "*" variadic splat] + [LVar** PolyKV "**" variadic-kv double-splat] + ) + + (template [<ruby-name> <lux-name>] + [(def: #export <lux-name> (..global <ruby-name>))] + + ["@" latest-error] + ["_" last-string-read] + ["." last-line-number-read] + ["&" last-string-matched] + ["~" last-regexp-match] + ["=" case-insensitivity-flag] + ["/" input-record-separator] + ["\" output-record-separator] + ["0" script-name] + ["*" command-line-arguments] + ["$" process-id] + ["?" exit-status] + ) + + (def: #export nil + Literal + (:abstraction "nil")) + + (def: #export bool + (-> Bit Literal) + (|>> (case> #0 "false" + #1 "true") + :abstraction)) + + (def: sanitize + (-> Text Text) + (`` (|>> (~~ (template [<find> <replace>] + [(text.replace-all <find> <replace>)] + + ["\" "\\"] + [text.tab "\t"] + [text.vertical-tab "\v"] + [text.null "\0"] + [text.back-space "\b"] + [text.form-feed "\f"] + [text.new-line "\n"] + [text.carriage-return "\r"] + [text.double-quote (format "\" text.double-quote)] + )) + ))) + + (template [<format> <name> <type> <prep>] + [(def: #export <name> + (-> <type> Literal) + (|>> <prep> <format> :abstraction))] + + [%i int Int (<|)] + [%t string Text ..sanitize] + ) + + (def: #export float + (-> Frac Literal) + (|>> (cond> [(f/= frac.positive-infinity)] + [(new> "(+1.0/0.0)" [])] + + [(f/= frac.negative-infinity)] + [(new> "(-1.0/0.0)" [])] + + [(f/= frac.not-a-number)] + [(new> "(+0.0/-0.0)" [])] + + ## else + [%f]) + :abstraction)) + + (def: #export (array-range from to array) + (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any)) + (|> (format (:representation from) ".." (:representation to)) + (text.enclose ["[" "]"]) + (format (:representation array)) + :abstraction)) + + (def: #export array + (-> (List (Expression Any)) Literal) + (|>> (list@map (|>> :representation)) + (text.join-with ..input-separator) + (text.enclose ["[" "]"]) + :abstraction)) + + (def: #export hash + (-> (List [(Expression Any) (Expression Any)]) Literal) + (|>> (list@map (.function (_ [k v]) + (format (:representation k) " => " (:representation v)))) + (text.join-with ..input-separator) + (text.enclose ["{" "}"]) + :abstraction)) + + (def: #export (apply/* args func) + (-> (List (Expression Any)) (Expression Any) (Computation Any)) + (|> args + (list@map (|>> :representation)) + (text.join-with ..input-separator) + (text.enclose ["(" ")"]) + (format (:representation func)) + :abstraction)) + + (def: #export (the field object) + (-> Text (Expression Any) Access) + (:abstraction (format (:representation object) "." field))) + + (def: #export (nth idx array) + (-> (Expression Any) (Expression Any) Access) + (|> (:representation idx) + (text.enclose ["[" "]"]) + (format (:representation array)) + :abstraction)) + + (def: #export (? test then else) + (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any)) + (|> (format (:representation test) " ? " + (:representation then) " : " + (:representation else)) + (text.enclose ["(" ")"]) + :abstraction)) + + (def: #export statement + (-> (Expression Any) (Statement Any)) + (|>> :representation + (text.suffix ..statement-suffix) + :abstraction)) + + (def: #export (then pre! post!) + (-> (Statement Any) (Statement Any) (Statement Any)) + (:abstraction + (format (:representation pre!) + text.new-line + (:representation post!)))) + + (def: #export (set vars value) + (-> (List (Location Any)) (Expression Any) (Statement Any)) + (:abstraction + (format (|> vars + (list@map (|>> :representation)) + (text.join-with ..input-separator)) + " = " (:representation value) ..statement-suffix))) + + (def: (block content) + (-> Text Text) + (format content + text.new-line "end" ..statement-suffix)) + + (def: #export (if test then! else!) + (-> (Expression Any) (Statement Any) (Statement Any) (Statement Any)) + (<| :abstraction + ..block + (format "if " (:representation test) + text.new-line (..nest (:representation then!)) + text.new-line "else" + text.new-line (..nest (:representation else!))))) + + (template [<name> <block>] + [(def: #export (<name> test then!) + (-> (Expression Any) (Statement Any) (Statement Any)) + (<| :abstraction + ..block + (format <block> " " (:representation test) + text.new-line (..nest (:representation then!)))))] + + [when "if"] + [while "while"] + ) + + (def: #export (for-in var array iteration!) + (-> LVar (Expression Any) (Statement Any) (Statement Any)) + (<| :abstraction + ..block + (format "for " (:representation var) + " in " (:representation array) + " do " + text.new-line (..nest (:representation iteration!))))) + + (type: #export Rescue + {#classes (List Text) + #exception LVar + #rescue (Statement Any)}) + + (def: #export (begin body! rescues) + (-> (Statement Any) (List Rescue) (Statement Any)) + (<| :abstraction + ..block + (format "begin" + text.new-line (:representation body!) + (|> rescues + (list@map (.function (_ [classes exception rescue]) + (format text.new-line "rescue " (text.join-with ..input-separator classes) + " => " (:representation exception) + text.new-line (..nest (:representation rescue))))) + (text.join-with text.new-line))))) + + (def: #export (return value) + (-> (Expression Any) (Statement Any)) + (:abstraction (format "return " (:representation value) ..statement-suffix))) + + (def: #export (raise message) + (-> (Expression Any) (Computation Any)) + (:abstraction (format "raise " (:representation message)))) + + (template [<name> <keyword>] + [(def: #export <name> + (Statement Any) + (|> <keyword> + (text.suffix ..statement-suffix) + :abstraction))] + + [next "next"] + [redo "redo"] + [break "break"] + ) + + (def: #export (function name args body!) + (-> LVar (List (Var Any)) (Statement Any) (Statement Any)) + (<| :abstraction + ..block + (format "def " (:representation name) + (|> args + (list@map (|>> :representation)) + (text.join-with ..input-separator) + (text.enclose ["(" ")"])) + text.new-line (:representation body!)))) + + (def: #export (lambda name args body!) + (-> (Maybe LVar) (List (Var Any)) (Statement Any) Literal) + (let [proc (|> (format (|> args + (list@map (|>> :representation)) + (text.join-with ..input-separator) + (text.enclose' "|")) + " " + (:representation body!)) + (text.enclose ["{" "}"]) + (format "lambda "))] + (|> (case name + #.None + proc + + (#.Some name) + (format (:representation name) " = " proc)) + (text.enclose ["(" ")"]) + :abstraction))) + + (template [<op> <name>] + [(def: #export (<name> parameter subject) + (-> (Expression Any) (Expression Any) (Computation Any)) + (:abstraction (format "(" (:representation subject) " " <op> " " (:representation parameter) ")")))] + + ["==" =] + [ "<" <] + ["<=" <=] + [ ">" >] + [">=" >=] + + [ "+" +] + [ "-" -] + [ "*" *] + [ "/" /] + [ "%" %] + ["**" pow] + + ["||" or] + ["&&" and] + [ "|" bit-or] + [ "&" bit-and] + [ "^" bit-xor] + + ["<<" bit-shl] + [">>" bit-shr] + ) + + (def: #export (not subject) + (-> (Expression Any) (Computation Any)) + (:abstraction (format "(!" (:representation subject) ")"))) + + (def: #export (comment commentary on) + (All [brand] (-> Text (Code brand) (Code brand))) + (:abstraction (format "# " (..sanitize commentary) text.new-line + (:representation on)))) + ) + +(def: #export (do method args object) + (-> Text (List (Expression Any)) (Expression Any) (Computation Any)) + (|> object (..the method) (..apply/* args))) + +(def: #export (cond clauses else!) + (-> (List [(Expression Any) (Statement Any)]) (Statement Any) (Statement Any)) + (list@fold (.function (_ [test then!] next!) + (..if test then! next!)) + else! + (list.reverse clauses))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/case.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/case.lux index dca429854..74b1128c2 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/js/case.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/case.lux @@ -113,10 +113,11 @@ (-> Bit Nat Statement) ($_ _.then (_.set @temp (|> idx <prep> .int _.i32 (//runtime.sum//get ..peek-cursor <flag>))) - (_.if (_.= _.null @temp) - fail-pm! - (.if simple? - (_.statement _.null) + (.if simple? + (_.when (_.= _.null @temp) + fail-pm!) + (_.if (_.= _.null @temp) + fail-pm! (push-cursor! @temp)))))] [left-choice _.null (<|)] diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/runtime.lux index 9102dd30d..f492479d4 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/js/runtime.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/runtime.lux @@ -693,29 +693,22 @@ )) (runtime: (array//read idx array) - (let [fail! (_.return ..none)] - (_.if (_.< (..length array) idx) - (with-vars [temp] - ($_ _.then - (_.define temp (_.at idx array)) - (_.if (_.= _.undefined temp) - fail! - (_.return (..some temp))))) - fail!))) + (with-vars [temp] + ($_ _.then + (_.define temp (_.at idx array)) + (_.if (_.= _.undefined temp) + (_.return ..none) + (_.return (..some temp)))))) (runtime: (array//write idx value array) - (_.if (_.< (..length array) idx) - ($_ _.then - (_.set (_.at idx array) value) - (_.return (..some array))) - (_.return ..none))) + ($_ _.then + (_.set (_.at idx array) value) + (_.return array))) (runtime: (array//delete idx array) - (_.if (_.< (..length array) idx) - ($_ _.then - (_.delete (_.at idx array)) - (_.return (..some array))) - (_.return ..none))) + ($_ _.then + (_.delete (_.at idx array)) + (_.return array))) (def: runtime//array Statement diff --git a/stdlib/source/lux/tool/compiler/phase/generation/python/case.lux b/stdlib/source/lux/tool/compiler/phase/generation/python/case.lux index 923f3d1d3..3aa95d673 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/python/case.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/python/case.lux @@ -67,32 +67,32 @@ elseO (generate elseS)] (wrap (_.? testO thenO elseO)))) -(def: @savepoint (_.var "lux_pm_cursor_savepoint")) +(def: @savepoint (_.var "lux_pm_savepoint")) (def: @cursor (_.var "lux_pm_cursor")) (def: @temp (_.var "lux_pm_temp")) -(def: (push-cursor! value) +(def: (push! value) (-> (Expression Any) (Statement Any)) (_.statement (|> @cursor (_.do "append" (list value))))) -(def: peek-and-pop-cursor +(def: peek-and-pop (Expression Any) (|> @cursor (_.do "pop" (list)))) -(def: pop-cursor! +(def: pop! (Statement Any) - (_.statement ..peek-and-pop-cursor)) + (_.statement ..peek-and-pop)) -(def: peek-cursor +(def: peek (Expression Any) (_.nth (_.int -1) @cursor)) -(def: save-cursor! +(def: save! (Statement Any) (.let [cursor (_.slice-from (_.int +0) @cursor)] (_.statement (|> @savepoint (_.do "append" (list cursor)))))) -(def: restore-cursor! +(def: restore! (Statement Any) (_.set (list @cursor) (|> @savepoint (_.do "pop" (list))))) @@ -100,7 +100,7 @@ (exception: #export unrecognized-path) -(def: (multi-pop-cursor! pops) +(def: (multi-pop! pops) (-> Nat (Statement Any)) (_.delete (_.slice-from (_.int (i/* -1 (.int pops))) @cursor))) @@ -108,12 +108,14 @@ [(def: (<name> simple? idx) (-> Bit Nat (Statement Any)) ($_ _.then - (_.set (list @temp) (|> idx <prep> .int _.int (//runtime.sum//get ..peek-cursor <flag>))) - (_.if (_.= _.none @temp) - fail-pm! - (.if simple? - _.pass - (push-cursor! @temp)))))] + (_.set (list @temp) (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>))) + (.if simple? + (_.when (_.= _.none @temp) + fail-pm!) + (_.if (_.= _.none @temp) + fail-pm! + (..push! @temp)) + )))] [left-choice _.none (<|)] [right-choice (_.string "") inc] @@ -124,10 +126,10 @@ ($_ _.then (_.while (_.bool true) ($_ _.then - ..save-cursor! + ..save! pre!)) ($_ _.then - ..restore-cursor! + ..restore! post!))) (def: (pattern-matching' generate pathP) @@ -137,14 +139,14 @@ (:: ////.monad map _.return (generate bodyS)) #/////synthesis.Pop - (////@wrap pop-cursor!) + (////@wrap ..pop!) (#/////synthesis.Bind register) - (////@wrap (_.set (list (..register register)) ..peek-cursor)) + (////@wrap (_.set (list (..register register)) ..peek)) (^template [<tag> <format>] (^ (<tag> value)) - (////@wrap (_.when (|> value <format> (_.= ..peek-cursor) _.not) + (////@wrap (_.when (|> value <format> (_.= ..peek) _.not) fail-pm!))) ([/////synthesis.path/bit //primitive.bit] [/////synthesis.path/i64 //primitive.i64] @@ -163,11 +165,11 @@ [/////synthesis.side/right /////synthesis.simple-right-side ..right-choice]) (^ (/////synthesis.member/left 0)) - (////@wrap (|> ..peek-cursor (_.nth (_.int +0)) push-cursor!)) + (////@wrap (|> ..peek (_.nth (_.int +0)) ..push!)) (^template [<pm> <getter>] (^ (<pm> lefts)) - (////@wrap (|> ..peek-cursor (<getter> (_.int (.int lefts))) push-cursor!))) + (////@wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))) ([/////synthesis.member/left //runtime.tuple//left] [/////synthesis.member/right //runtime.tuple//right]) @@ -175,7 +177,7 @@ (do ////.monad [then! (pattern-matching' generate thenP)] (////@wrap ($_ _.then - (_.set (list (..register register)) ..peek-and-pop-cursor) + (_.set (list (..register register)) ..peek-and-pop) then!))) (^ (/////synthesis.!multi-pop nextP)) @@ -183,7 +185,7 @@ (do ////.monad [next! (pattern-matching' generate nextP')] (////@wrap ($_ _.then - (multi-pop-cursor! (n/+ 2 extra-pops)) + (..multi-pop! (n/+ 2 extra-pops)) next!)))) (^template [<tag> <combinator>] diff --git a/stdlib/source/lux/tool/compiler/phase/generation/python/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/python/runtime.lux index f5a734346..0b84f4741 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/python/runtime.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/python/runtime.lux @@ -293,15 +293,10 @@ (def: inc (|>> (_.+ (_.int +1)))) -(template [<name> <top-cmp>] - [(def: (<name> top value) - (-> (Expression Any) (Expression Any) (Computation Any)) - (_.and (|> value (_.>= (_.int +0))) - (|> value (<top-cmp> top))))] - - [within? _.<] - [up-to? _.<=] - ) +(def: (within? top value) + (-> (Expression Any) (Expression Any) (Computation Any)) + (_.and (|> value (_.>= (_.int +0))) + (|> value (_.< top)))) (runtime: (text//clip @text @from @to) (_.return (|> @text (_.slice @from (inc @to))))) @@ -318,26 +313,18 @@ @text//clip @text//char)) -(def: (check-index-out-of-bounds array idx body!) - (-> (Expression Any) (Expression Any) (Statement Any) (Statement Any)) - (_.if (|> idx (_.<= (_.len/1 array))) - body! - (_.raise (_.Exception/1 (_.string "Array index out of bounds!"))))) - (runtime: (array//get array idx) (with-vars [temp] - (<| (check-index-out-of-bounds array idx) - ($_ _.then - (_.set (list temp) (_.nth idx array)) - (_.if (_.= _.none temp) - (_.return ..none) - (_.return (..some temp))))))) + ($_ _.then + (_.set (list temp) (_.nth idx array)) + (_.if (_.= _.none temp) + (_.return ..none) + (_.return (..some temp)))))) (runtime: (array//put array idx value) - (<| (check-index-out-of-bounds array idx) - ($_ _.then - (_.set (list (_.nth idx array)) value) - (_.return array)))) + ($_ _.then + (_.set (list (_.nth idx array)) value) + (_.return array))) (def: runtime//array (Statement Any) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/python/structure.lux b/stdlib/source/lux/tool/compiler/phase/generation/python/structure.lux index 93a83883d..bcae96966 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/python/structure.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/python/structure.lux @@ -22,9 +22,9 @@ (generate singletonS) _ - (do ////.monad - [elemsT+ (monad.map @ generate elemsS+)] - (wrap (_.list elemsT+))))) + (|> elemsS+ + (monad.map ////.monad generate) + (:: ////.monad map _.list)))) (def: #export (variant generate [lefts right? valueS]) (-> Phase (Variant Synthesis) (Operation (Expression Any))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/ruby.lux b/stdlib/source/lux/tool/compiler/phase/generation/ruby.lux new file mode 100644 index 000000000..155d3e13c --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/ruby.lux @@ -0,0 +1,60 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]]] + [/ + [runtime (#+ Phase)] + ["." primitive] + ["." structure] + ["." reference ("#@." system)] + ["." case] + ["." function] + ["." loop] + ["." /// + ["." extension] + [// + ["." synthesis]]]]) + +(def: #export (generate synthesis) + Phase + (case synthesis + (^template [<tag> <generator>] + (^ (<tag> value)) + (:: ///.monad wrap (<generator> value))) + ([synthesis.bit primitive.bit] + [synthesis.i64 primitive.i64] + [synthesis.f64 primitive.f64] + [synthesis.text primitive.text]) + + (^ (synthesis.variant variantS)) + (structure.variant generate variantS) + + (^ (synthesis.tuple members)) + (structure.tuple generate members) + + (#synthesis.Reference value) + (reference@reference value) + + (^ (synthesis.branch/case case)) + (case.case generate case) + + (^ (synthesis.branch/let let)) + (case.let generate let) + + (^ (synthesis.branch/if if)) + (case.if generate if) + + (^ (synthesis.loop/scope scope)) + (loop.scope generate scope) + + (^ (synthesis.loop/recur updates)) + (loop.recur generate updates) + + (^ (synthesis.function/abstraction abstraction)) + (function.function generate abstraction) + + (^ (synthesis.function/apply application)) + (function.apply generate application) + + (#synthesis.Extension extension) + (extension.apply generate extension))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/ruby/case.lux b/stdlib/source/lux/tool/compiler/phase/generation/ruby/case.lux new file mode 100644 index 000000000..7bc52c318 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/ruby/case.lux @@ -0,0 +1,224 @@ +(.module: + [lux (#- case let if) + [abstract + [monad (#+ do)]] + [control + ["ex" exception (#+ exception:)]] + [data + ["." text + format] + [collection + ["." list ("#@." functor fold)] + ["." set]]] + [host + ["_" ruby (#+ Expression LVar Statement)]]] + ["." // #_ + ["#." runtime (#+ Operation Phase)] + ["#." reference] + ["#." primitive] + ["#/" // + ["#." reference] + ["#/" // ("#@." monad) + [synthesis + ["." case]] + ["#/" // #_ + ["." reference (#+ Register)] + ["#." synthesis (#+ Synthesis Path)]]]]]) + +(def: #export register + (///reference.local _.local)) + +(def: #export capture + (///reference.foreign _.local)) + +(def: #export (let generate [valueS register bodyS]) + (-> Phase [Synthesis Register Synthesis] + (Operation (Expression Any))) + (do ////.monad + [valueO (generate valueS) + bodyO (generate bodyS)] + ## TODO: Find some way to do 'let' without paying the price of the closure. + (wrap (|> bodyO + _.return + (_.lambda #.None (list (..register register))) + (_.apply/* (list valueO)))))) + +(def: #export (record-get generate valueS pathP) + (-> Phase Synthesis (List (Either Nat Nat)) + (Operation (Expression Any))) + (do ////.monad + [valueO (generate 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 + pathP)))) + +(def: #export (if generate [testS thenS elseS]) + (-> Phase [Synthesis Synthesis Synthesis] + (Operation (Expression Any))) + (do ////.monad + [testO (generate testS) + thenO (generate thenS) + elseO (generate elseS)] + (wrap (_.? testO thenO elseO)))) + +(def: @savepoint (_.local "lux_pm_savepoint")) +(def: @cursor (_.local "lux_pm_cursor")) +(def: @temp (_.local "lux_pm_temp")) + +(def: (push! value) + (-> (Expression Any) (Statement Any)) + (_.statement (|> @cursor (_.do "push" (list value))))) + +(def: peek-and-pop + (Expression Any) + (|> @cursor (_.do "pop" (list)))) + +(def: pop! + (Statement Any) + (_.statement ..peek-and-pop)) + +(def: peek + (Expression Any) + (_.nth (_.int -1) @cursor)) + +(def: save! + (Statement Any) + (.let [cursor (_.array-range (_.int +0) (_.int -1) @cursor)] + (_.statement (|> @savepoint (_.do "push" (list cursor)))))) + +(def: restore! + (Statement Any) + (_.set (list @cursor) (|> @savepoint (_.do "pop" (list))))) + +(def: fail-pm! _.break) + +(exception: #export unrecognized-path) + +(def: (multi-pop! pops) + (-> Nat (Statement Any)) + (_.statement (_.do "slice!" (list (_.int (i/* -1 (.int pops))) + (_.int (.int pops))) + @cursor))) + +(template [<name> <flag> <prep>] + [(def: (<name> simple? idx) + (-> Bit Nat (Statement Any)) + ($_ _.then + (_.set (list @temp) (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>))) + (.if simple? + (_.when (_.= _.nil @temp) + fail-pm!) + (_.if (_.= _.nil @temp) + fail-pm! + (..push! @temp)))))] + + [left-choice _.nil (<|)] + [right-choice (_.string "") inc] + ) + +(def: (alternation pre! post!) + (-> (Statement Any) (Statement Any) (Statement Any)) + ($_ _.then + (_.while (_.bool true) + ($_ _.then + ..save! + pre!)) + ($_ _.then + ..restore! + post!))) + +(def: (pattern-matching' generate pathP) + (-> Phase Path (Operation (Statement Any))) + (.case pathP + (^ (/////synthesis.path/then bodyS)) + (:: ////.monad map _.return (generate bodyS)) + + #/////synthesis.Pop + (////@wrap ..pop!) + + (#/////synthesis.Bind register) + (////@wrap (_.set (list (..register register)) ..peek)) + + (^template [<tag> <format>] + (^ (<tag> value)) + (////@wrap (_.when (|> value <format> (_.= ..peek) _.not) + fail-pm!))) + ([/////synthesis.path/bit //primitive.bit] + [/////synthesis.path/i64 //primitive.i64] + [/////synthesis.path/f64 //primitive.f64] + [/////synthesis.path/text //primitive.text]) + + (^template [<complex> <simple> <choice>] + (^ (<complex> idx)) + (////@wrap (<choice> false idx)) + + (^ (<simple> idx nextP)) + (|> nextP + (pattern-matching' generate) + (:: ////.monad map (_.then (<choice> true idx))))) + ([/////synthesis.side/left /////synthesis.simple-left-side ..left-choice] + [/////synthesis.side/right /////synthesis.simple-right-side ..right-choice]) + + (^ (/////synthesis.member/left 0)) + (////@wrap (|> ..peek (_.nth (_.int +0)) ..push!)) + + (^template [<pm> <getter>] + (^ (<pm> lefts)) + (////@wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))) + ([/////synthesis.member/left //runtime.tuple//left] + [/////synthesis.member/right //runtime.tuple//right]) + + (^ (/////synthesis.!bind-top register thenP)) + (do ////.monad + [then! (pattern-matching' generate thenP)] + (////@wrap ($_ _.then + (_.set (list (..register register)) ..peek-and-pop) + then!))) + + (^ (/////synthesis.!multi-pop nextP)) + (.let [[extra-pops nextP'] (case.count-pops nextP)] + (do ////.monad + [next! (pattern-matching' generate nextP')] + (////@wrap ($_ _.then + (..multi-pop! (n/+ 2 extra-pops)) + next!)))) + + (^template [<tag> <combinator>] + (^ (<tag> preP postP)) + (do ////.monad + [pre! (pattern-matching' generate preP) + post! (pattern-matching' generate postP)] + (wrap (<combinator> pre! post!)))) + ([/////synthesis.path/seq _.then] + [/////synthesis.path/alt ..alternation]) + + _ + (////.throw unrecognized-path []))) + +(def: (pattern-matching generate pathP) + (-> Phase Path (Operation (Statement Any))) + (do ////.monad + [pattern-matching! (pattern-matching' generate pathP)] + (wrap ($_ _.then + (_.while (_.bool true) + pattern-matching!) + (_.statement (_.raise (_.string case.pattern-matching-error))))))) + +(def: #export (case generate [valueS pathP]) + (-> Phase [Synthesis Path] (Operation (Expression Any))) + (do ////.monad + [initG (generate valueS) + pattern-matching! (pattern-matching generate pathP)] + (wrap (|> ($_ _.then + (_.set (list @cursor) (_.array (list initG))) + (_.set (list @savepoint) (_.array (list))) + pattern-matching!) + (_.lambda #.None (list)) + (_.do "call" (list)))))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/ruby/extension.lux b/stdlib/source/lux/tool/compiler/phase/generation/ruby/extension.lux new file mode 100644 index 000000000..a40b4953f --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/ruby/extension.lux @@ -0,0 +1,15 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + [// + [runtime (#+ Bundle)]] + [/ + ["." common] + ["." host]]) + +(def: #export bundle + Bundle + (|> common.bundle + (dictionary.merge host.bundle))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/ruby/extension/common.lux b/stdlib/source/lux/tool/compiler/phase/generation/ruby/extension/common.lux new file mode 100644 index 000000000..eda6782b3 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/ruby/extension/common.lux @@ -0,0 +1,159 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function]] + [data + ["." product] + ["." text] + [collection + ["." dictionary]]] + [host (#+ import:) + ["_" ruby (#+ Expression)]]] + ["." /// #_ + ["#." runtime (#+ Operation Phase Handler Bundle)] + ["#." primitive] + [// + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + [// + [extension + ["." bundle]]]]]) + +(def: lux-procs + Bundle + (|> bundle.empty + (bundle.install "is" (binary (product.uncurry _.=))) + (bundle.install "try" (unary ///runtime.lux//try)))) + +(def: keep-i64 + (All [input] + (-> (-> input (Expression Any)) + (-> input (Expression Any)))) + (function.compose (_.bit-and (_.manual "0xFFFFFFFFFFFFFFFF")))) + +(def: i64-procs + Bundle + (<| (bundle.prefix "i64") + (|> bundle.empty + (bundle.install "and" (binary (product.uncurry _.bit-and))) + (bundle.install "or" (binary (product.uncurry _.bit-or))) + (bundle.install "xor" (binary (product.uncurry _.bit-xor))) + (bundle.install "left-shift" (binary (..keep-i64 (product.uncurry _.bit-shl)))) + (bundle.install "logical-right-shift" (binary (product.uncurry ///runtime.i64//logic-right-shift))) + (bundle.install "arithmetic-right-shift" (binary (product.uncurry _.bit-shr))) + (bundle.install "=" (binary (product.uncurry _.=))) + (bundle.install "+" (binary (..keep-i64 (product.uncurry _.+)))) + (bundle.install "-" (binary (..keep-i64 (product.uncurry _.-)))) + ))) + +(import: #long java/lang/Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double)) + +(template [<name> <const>] + [(def: (<name> _) + (Nullary (Expression Any)) + (_.float <const>))] + + [frac//smallest (java/lang/Double::MIN_VALUE)] + [frac//min (f/* -1.0 (java/lang/Double::MAX_VALUE))] + [frac//max (java/lang/Double::MAX_VALUE)] + ) + +(def: int-procs + Bundle + (<| (bundle.prefix "int") + (|> bundle.empty + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "*" (binary (..keep-i64 (product.uncurry _.*)))) + (bundle.install "/" (binary (product.uncurry _./))) + (bundle.install "%" (binary (product.uncurry _.%))) + (bundle.install "frac" (unary (_./ (_.float +1.0)))) + (bundle.install "char" (unary (_.do "chr" (list))))))) + +(def: frac-procs + Bundle + (<| (bundle.prefix "frac") + (|> bundle.empty + (bundle.install "+" (binary (product.uncurry _.+))) + (bundle.install "-" (binary (product.uncurry _.-))) + (bundle.install "*" (binary (product.uncurry _.*))) + (bundle.install "/" (binary (product.uncurry _./))) + (bundle.install "%" (binary (product.uncurry _.%))) + (bundle.install "=" (binary (product.uncurry _.=))) + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "smallest" (nullary frac//smallest)) + (bundle.install "min" (nullary frac//min)) + (bundle.install "max" (nullary frac//max)) + (bundle.install "int" (unary (_.do "floor" (list)))) + (bundle.install "encode" (unary (_.do "to_s" (list)))) + (bundle.install "decode" (unary ///runtime.f64//decode))))) + +(def: (text//char [subjectO paramO]) + (Binary (Expression Any)) + (///runtime.text//char subjectO paramO)) + +(def: (text//clip [paramO extraO subjectO]) + (Trinary (Expression Any)) + (///runtime.text//clip subjectO paramO extraO)) + +(def: (text//index [startO partO textO]) + (Trinary (Expression Any)) + (///runtime.text//index textO partO startO)) + +(def: text-procs + Bundle + (<| (bundle.prefix "text") + (|> bundle.empty + (bundle.install "=" (binary (product.uncurry _.=))) + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "concat" (binary (product.uncurry _.+))) + (bundle.install "index" (trinary text//index)) + (bundle.install "size" (unary (_.the "length"))) + (bundle.install "char" (binary (product.uncurry ///runtime.text//char))) + (bundle.install "clip" (trinary text//clip)) + ))) + +(def: (io//log! messageG) + (Unary (Expression Any)) + (_.or (_.apply/* (list (|> messageG (_.+ (_.string text.new-line)))) + (_.local "puts")) + ///runtime.unit)) + +(def: io//error! + (Unary (Expression Any)) + _.raise) + +(def: (io//exit! code) + (Unary (Expression Any)) + (_.apply/* (list code) (_.local "exit"))) + +(def: (io//current-time! _) + (Nullary (Expression Any)) + (|> (_.local "Time") + (_.do "now" (list)) + (_.do "to_f" (list)) + (_.* (_.float +1000.0)) + (_.do "to_i" (list)))) + +(def: io-procs + Bundle + (<| (bundle.prefix "io") + (|> bundle.empty + (bundle.install "log" (unary ..io//log!)) + (bundle.install "error" (unary ..io//error!)) + (bundle.install "exit" (unary ..io//exit!)) + (bundle.install "current-time" (nullary ..io//current-time!))))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "lux") + (|> lux-procs + (dictionary.merge ..i64-procs) + (dictionary.merge ..int-procs) + (dictionary.merge ..frac-procs) + (dictionary.merge ..text-procs) + (dictionary.merge ..io-procs) + ))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/ruby/extension/host.lux b/stdlib/source/lux/tool/compiler/phase/generation/ruby/extension/host.lux new file mode 100644 index 000000000..c8b6dcb27 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/ruby/extension/host.lux @@ -0,0 +1,25 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [data + ["." product] + [collection + ["." dictionary]]] + [host + ["_" ruby (#+ Expression)]]] + ["." /// #_ + ["#." runtime (#+ Handler Bundle)] + ["#/" // #_ + ["#." extension (#+ Nullary Unary Binary Trinary Variadic + nullary unary binary trinary variadic)] + ["#/" // + ["#." extension + ["." bundle]] + ["#/" // #_ + ["#." synthesis]]]]]) + +(def: #export bundle + Bundle + (<| (bundle.prefix "ruby") + bundle.empty)) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/ruby/function.lux b/stdlib/source/lux/tool/compiler/phase/generation/ruby/function.lux new file mode 100644 index 000000000..486b68592 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/ruby/function.lux @@ -0,0 +1,100 @@ +(.module: + [lux (#- function) + [abstract + ["." monad (#+ do)]] + [control + pipe] + [data + ["." product] + [text + format] + [collection + ["." list ("#@." functor fold)]]] + [host + ["_" ruby (#+ Expression Statement)]]] + ["." // #_ + [runtime (#+ Operation Phase)] + ["#." reference] + ["#." case] + ["#/" // + ["#." reference] + ["#/" // + ["." // #_ + [reference (#+ Register Variable)] + [analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)] + [synthesis (#+ Synthesis)]]]]]) + +(def: #export (apply generate [functionS argsS+]) + (-> Phase (Application Synthesis) (Operation (Expression Any))) + (do ////.monad + [functionO (generate functionS) + argsO+ (monad.map @ generate argsS+)] + (wrap (_.apply/* argsO+ functionO)))) + +(def: #export capture + (///reference.foreign _.local)) + +(def: (with-closure inits function-definition) + (-> (List (Expression Any)) (Expression Any) (Expression Any)) + (case inits + #.Nil + function-definition + + _ + (|> function-definition + _.return + (_.lambda #.None + (|> (list.enumerate inits) + (list@map (|>> product.left ..capture)))) + (_.do "call" inits)))) + +(def: input + (|>> inc //case.register)) + +(def: #export (function generate [environment arity bodyS]) + (-> Phase (Abstraction Synthesis) (Operation (Expression Any))) + (do ////.monad + [[function-name bodyO] (///.with-context + (do @ + [function-name ///.context] + (///.with-anchor (_.local function-name) + (generate bodyS)))) + closureO+ (: (Operation (List (Expression Any))) + (monad.map @ (:: //reference.system variable) environment)) + #let [@curried (_.local "curried") + arityO (|> arity .int _.int) + limitO (|> arity dec .int _.int) + @num-args (_.local "num_args") + @self (_.local function-name) + initialize-self! (_.set (list (//case.register 0)) @self) + initialize! (list@fold (.function (_ post pre!) + ($_ _.then + pre! + (_.set (list (..input post)) (_.nth (|> post .int _.int) @curried)))) + initialize-self! + (list.indices arity))]] + (wrap (with-closure closureO+ + (_.lambda (#.Some @self) (list (_.variadic @curried)) + ($_ _.then + (_.set (list @num-args) (_.the "length" @curried)) + (_.cond (list [(|> @num-args (_.= arityO)) + ($_ _.then + initialize! + (_.return bodyO))] + [(|> @num-args (_.> arityO)) + (let [slice (.function (_ from to) + (_.array-range from to @curried)) + arity-args (_.splat (slice (_.int +0) limitO)) + output-func-args (_.splat (slice arityO @num-args))] + (_.return (|> @self + (_.do "call" (list arity-args)) + (_.do "call" (list output-func-args)))))]) + ## (|> @num-args (_.< arityO)) + (let [@missing (_.local "missing")] + (_.return (_.lambda #.None (list (_.variadic @missing)) + (_.return (|> @self + (_.do "call" (list (_.splat (|> (_.array (list)) + (_.do "concat" (list @curried)) + (_.do "concat" (list @missing)))))))))))) + )))) + )) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/ruby/loop.lux b/stdlib/source/lux/tool/compiler/phase/generation/ruby/loop.lux new file mode 100644 index 000000000..91eb3eeb2 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/ruby/loop.lux @@ -0,0 +1,40 @@ +(.module: + [lux (#- Scope) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + [text + format] + [collection + ["." list ("#@." functor)]]] + [host + ["_" ruby (#+ Expression)]]] + ["." // #_ + [runtime (#+ Operation Phase)] + ["#." case] + ["#/" // + ["#/" // + [// + [synthesis (#+ Scope Synthesis)]]]]]) + +(def: #export (scope generate [start initsS+ bodyS]) + (-> Phase (Scope Synthesis) (Operation (Expression Any))) + (do ////.monad + [@loop (:: @ map (|>> %n (format "loop") _.local) ///.next) + initsO+ (monad.map @ generate initsS+) + bodyO (///.with-anchor @loop + (generate bodyS))] + (wrap (|> (_.return bodyO) + (_.lambda (#.Some @loop) + (|> initsS+ + list.enumerate + (list@map (|>> product.left (n/+ start) //case.register)))) + (_.apply/* initsO+))))) + +(def: #export (recur generate argsS+) + (-> Phase (List Synthesis) (Operation (Expression Any))) + (do ////.monad + [@scope ///.anchor + argsO+ (monad.map @ generate argsS+)] + (wrap (_.apply/* argsO+ @scope)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/ruby/primitive.lux b/stdlib/source/lux/tool/compiler/phase/generation/ruby/primitive.lux new file mode 100644 index 000000000..4ec058ffe --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/ruby/primitive.lux @@ -0,0 +1,27 @@ +(.module: + [lux (#- i64) + [control + [pipe (#+ cond> new>)]] + [data + [number + ["." frac]]] + [host + ["_" ruby (#+ Expression)]]] + ["." // #_ + ["#." runtime]]) + +(def: #export bit + (-> Bit (Expression Any)) + _.bool) + +(def: #export i64 + (-> (I64 Any) (Expression Any)) + (|>> .int _.int)) + +(def: #export f64 + (-> Frac (Expression Any)) + _.float) + +(def: #export text + (-> Text (Expression Any)) + _.string) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/ruby/reference.lux b/stdlib/source/lux/tool/compiler/phase/generation/ruby/reference.lux new file mode 100644 index 000000000..6ff021863 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/ruby/reference.lux @@ -0,0 +1,11 @@ +(.module: + [lux #* + [host + ["_" ruby (#+ Expression)]]] + [// + [// + ["." reference]]]) + +(def: #export system + (reference.system (: (-> Text (Expression Any)) _.local) + (: (-> Text (Expression Any)) _.local))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/ruby/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/ruby/runtime.lux new file mode 100644 index 000000000..b3dcbd8ee --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/ruby/runtime.lux @@ -0,0 +1,320 @@ +(.module: + [lux (#- inc) + [abstract + [monad (#+ do)]] + [control + ["." function] + ["p" parser]] + [data + [number (#+ hex) + ["." i64]] + ["." text + format] + [collection + ["." list ("#@." functor)]]] + ["." macro + ["." code] + ["s" syntax (#+ syntax:)]] + [host + ["_" ruby (#+ Expression LVar Computation Literal Statement)]]] + ["." /// + ["//." // + [// + ["/////." name] + ["." synthesis]]]] + ) + +(template [<name> <base>] + [(type: #export <name> + (<base> LVar (Expression Any) (Statement Any)))] + + [Operation ///.Operation] + [Phase ///.Phase] + [Handler ///.Handler] + [Bundle ///.Bundle] + ) + +(def: prefix Text "LuxRuntime") + +(def: #export unit (_.string synthesis.unit)) + +(def: (flag value) + (-> Bit Literal) + (if value + (_.string "") + _.nil)) + +(def: #export variant-tag-field "_lux_tag") +(def: #export variant-flag-field "_lux_flag") +(def: #export variant-value-field "_lux_value") + +(def: (variant' tag last? value) + (-> (Expression Any) (Expression Any) (Expression Any) Literal) + (_.hash (list [(_.string ..variant-tag-field) tag] + [(_.string ..variant-flag-field) last?] + [(_.string ..variant-value-field) value]))) + +(def: #export (variant tag last? value) + (-> Nat Bit (Expression Any) Literal) + (variant' (_.int (.int tag)) (..flag last?) value)) + +(def: #export none + Literal + (variant 0 #0 unit)) + +(def: #export some + (-> (Expression Any) Literal) + (variant 1 #1)) + +(def: #export left + (-> (Expression Any) Literal) + (variant 0 #0)) + +(def: #export right + (-> (Expression Any) Literal) + (variant 1 #1)) + +(def: runtime-name + (-> Text LVar) + (|>> /////name.normalize + (format ..prefix "_") + _.local)) + +(def: (feature name definition) + (-> LVar (-> LVar (Statement Any)) (Statement Any)) + (definition name)) + +(syntax: #export (with-vars {vars (s.tuple (p.some s.local-identifier))} + body) + (wrap (list (` (let [(~+ (|> vars + (list@map (function (_ var) + (list (code.local-identifier var) + (` (_.local (~ (code.text (/////name.normalize var)))))))) + list.concat))] + (~ body)))))) + +(syntax: (runtime: {declaration (p.or s.local-identifier + (s.form (p.and s.local-identifier + (p.some s.local-identifier))))} + code) + (case declaration + (#.Left name) + (macro.with-gensyms [g!_] + (let [nameC (code.local-identifier name) + code-nameC (code.local-identifier (format "@" name)) + runtime-nameC (` (runtime-name (~ (code.text name))))] + (wrap (list (` (def: #export (~ nameC) LVar (~ runtime-nameC))) + (` (def: (~ code-nameC) + (Statement Any) + (..feature (~ runtime-nameC) + (function ((~ g!_) (~ nameC)) + (~ code))))))))) + + (#.Right [name inputs]) + (macro.with-gensyms [g!_] + (let [nameC (code.local-identifier name) + code-nameC (code.local-identifier (format "@" name)) + runtime-nameC (` (runtime-name (~ (code.text name)))) + inputsC (list@map code.local-identifier inputs) + inputs-typesC (list@map (function.constant (` (_.Expression Any))) + inputs)] + (wrap (list (` (def: #export ((~ nameC) (~+ inputsC)) + (-> (~+ inputs-typesC) (Computation Any)) + (_.apply/* (list (~+ inputsC)) (~ runtime-nameC)))) + (` (def: (~ code-nameC) + (Statement Any) + (..feature (~ runtime-nameC) + (function ((~ g!_) (~ g!_)) + (..with-vars [(~+ inputsC)] + (_.function (~ g!_) (list (~+ inputsC)) + (~ code))))))))))))) + +(def: tuple-size + (_.the "length")) + +(def: last-index + (|>> ..tuple-size (_.- (_.int +1)))) + +(runtime: (tuple//left lefts tuple) + (with-vars [last-index-right] + ($_ _.then + (_.set (list last-index-right) (..last-index tuple)) + (_.if (_.> lefts last-index-right) + ## No need for recursion + (_.return (_.nth lefts tuple)) + ## Needs recursion + (_.return (tuple//left (_.- last-index-right lefts) + (_.nth last-index-right tuple))))))) + +(runtime: (tuple//right lefts tuple) + (with-vars [last-index-right right-index] + ($_ _.then + (_.set (list last-index-right) (..last-index tuple)) + (_.set (list right-index) (_.+ (_.int +1) lefts)) + (_.cond (list [(_.= right-index last-index-right) + (_.return (_.nth right-index tuple))] + [(_.> right-index last-index-right) + ## Needs recursion. + (_.return (tuple//right (_.- last-index-right lefts) + (_.nth last-index-right tuple)))]) + (_.return (_.array-range right-index (..tuple-size tuple) tuple))) + ))) + +(runtime: (sum//get sum wantsLast wantedTag) + (let [no-match! (_.return _.nil) + sum-tag (_.nth (_.int +0) sum) + sum-flag (_.nth (_.int +1) sum) + sum-value (_.nth (_.int +2) sum) + is-last? (_.= (_.string "") sum-flag) + test-recursion! (_.if is-last? + ## Must recurse. + (_.return (sum//get sum-value wantsLast (_.- sum-tag wantedTag))) + no-match!)] + (_.cond (list [(_.= sum-tag wantedTag) + (_.if (_.= wantsLast sum-flag) + (_.return sum-value) + test-recursion!)] + + [(_.> sum-tag wantedTag) + test-recursion!] + + [(_.and (_.< sum-tag wantedTag) + (_.= (_.string "") wantsLast)) + (_.return (variant' (_.- wantedTag sum-tag) sum-flag sum-value))]) + + no-match!))) + +(def: runtime//adt + (Statement Any) + ($_ _.then + @tuple//left + @tuple//right + @sum//get)) + +(runtime: (lux//try risky) + (with-vars [error value] + (_.begin ($_ _.then + (_.set (list value) (_.do "call" (list ..unit) risky)) + (_.return (..right value))) + (list [(list) error + (_.return (..left (_.the "message" error)))])))) + +(runtime: (lux//program-args raw) + (with-vars [tail head] + ($_ _.then + (_.set (list tail) ..none) + (<| (_.for-in head raw) + (_.set (list tail) (..some (_.array (list head tail))))) + (_.return tail)))) + +(def: runtime//lux + (Statement Any) + ($_ _.then + @lux//try + @lux//program-args)) + +(runtime: (i64//logic-right-shift param subject) + (let [mask (|> (_.int +1) + (_.bit-shl (_.- param (_.int +64))) + (_.- (_.int +1)))] + (_.return (|> subject + (_.bit-shr param) + (_.bit-and mask))))) + +(def: runtime//i64 + (Statement Any) + @i64//logic-right-shift) + +(runtime: (f64//decode inputG) + (with-vars [@input @temp] + ($_ _.then + (_.set (list @input) inputG) + (_.set (list @temp) (_.do "to_f" (list) @input)) + (_.if ($_ _.or + (_.not (_.= (_.float +0.0) @temp)) + (_.= (_.string "0") @input) + (_.= (_.string ".0") @input) + (_.= (_.string "0.0") @input)) + (_.return (..some @temp)) + (_.return ..none))))) + +(def: runtime//f64 + (Statement Any) + @f64//decode) + +(runtime: (text//index subject param start) + (with-vars [idx] + ($_ _.then + (_.set (list idx) (|> subject (_.do "index" (list param start)))) + (_.if (_.= _.nil idx) + (_.return ..none) + (_.return (..some idx)))))) + +(def: (within? top value) + (-> (Expression Any) (Expression Any) (Computation Any)) + (_.and (|> value (_.>= (_.int +0))) + (|> value (_.< top)))) + +(runtime: (text//clip @text @from @to) + (_.return (|> @text (_.array-range @from @to)))) + +(runtime: (text//char idx text) + (_.if (|> idx (within? (_.the "length" text))) + (_.return (..some (|> text (_.array-range idx idx) (_.do "ord" (list))))) + (_.return ..none))) + +(def: runtime//text + (Statement Any) + ($_ _.then + @text//index + @text//clip + @text//char)) + +(runtime: (array//get array idx) + (with-vars [temp] + ($_ _.then + (_.set (list temp) (_.nth idx array)) + (_.if (_.= _.nil temp) + (_.return ..none) + (_.return (..some temp)))))) + +(runtime: (array//put array idx value) + ($_ _.then + (_.set (list (_.nth idx array)) value) + (_.return array))) + +(def: runtime//array + (Statement Any) + ($_ _.then + @array//get + @array//put)) + +(runtime: (box//write value box) + ($_ _.then + (_.set (list (_.nth (_.int +0) box)) value) + (_.return ..unit))) + +(def: runtime//box + (Statement Any) + @box//write) + +(def: runtime + (Statement Any) + ($_ _.then + runtime//adt + runtime//lux + runtime//i64 + runtime//f64 + runtime//text + runtime//array + runtime//box + )) + +(def: #export artifact ..prefix) + +(def: #export generate + (Operation Any) + (///.with-buffer + (do ////.monad + [_ (///.save! ["" ..prefix] ..runtime)] + (///.save-buffer! ..artifact)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/ruby/structure.lux b/stdlib/source/lux/tool/compiler/phase/generation/ruby/structure.lux new file mode 100644 index 000000000..b3d3046c8 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/ruby/structure.lux @@ -0,0 +1,36 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [host + ["_" ruby (#+ Expression)]]] + ["." // #_ + ["#." runtime (#+ Operation Phase)] + ["#." primitive] + ["#//" /// + ["#/" // #_ + [analysis (#+ Variant Tuple)] + ["#." synthesis (#+ Synthesis)]]]]) + +(def: #export (tuple generate elemsS+) + (-> Phase (Tuple Synthesis) (Operation (Expression Any))) + (case elemsS+ + #.Nil + (:: ////.monad wrap (//primitive.text /////synthesis.unit)) + + (#.Cons singletonS #.Nil) + (generate singletonS) + + _ + (|> elemsS+ + (monad.map ////.monad generate) + (:: ////.monad map _.array)))) + +(def: #export (variant generate [lefts right? valueS]) + (-> Phase (Variant Synthesis) (Operation (Expression Any))) + (:: ////.monad map + (//runtime.variant (if right? + (inc lefts) + lefts) + right?) + (generate valueS))) diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index 42f4c9f81..f73319739 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -3,8 +3,8 @@ [structure (#+)] [reference (#+)] [case (#+)] - [loop (#+)] [function (#+)] + [loop (#+)] [extension (#+) [common (#+)] [host (#+)]])] @@ -38,6 +38,7 @@ [host [js (#+)] [python (#+)] + [ruby (#+)] [scheme (#+)]] [tool [compiler @@ -47,6 +48,8 @@ <host-modules>] [python (#+) <host-modules>] + [ruby (#+) + <host-modules>] [scheme (#+) <host-modules>]]]]] ## [control @@ -375,4 +378,7 @@ (<| io _.run! (_.times 100) + ## (_.seed 16966479879996440699) + ## (_.seed 16140950815046933697) + ## (_.seed 8804587020128699091) ..test)) |