diff options
Diffstat (limited to 'new-luxc/source/luxc/lang')
11 files changed, 1450 insertions, 29 deletions
diff --git a/new-luxc/source/luxc/lang/host/php.lux b/new-luxc/source/luxc/lang/host/php.lux new file mode 100644 index 000000000..1fb1ca1e0 --- /dev/null +++ b/new-luxc/source/luxc/lang/host/php.lux @@ -0,0 +1,314 @@ +(.module: + [lux #- not or and function] + (lux (control pipe) + (data [text] + text/format + [number] + (coll [list "list/" Functor<List> Fold<List>])) + (type abstract))) + +(def: nest + (-> Text Text) + (|>> (format "\n") + (text.replace-all "\n" "\n "))) + +(def: (block content) + (-> Text Text) + (format "{" (nest content) "\n" "}")) + +(abstract: #export Global {} Unit) +(abstract: #export Var {} Unit) +(abstract: #export Computation {} Unit) + +(abstract: #export (Expression' k) + {} + + Text + + (type: #export Expression (Ex [k] (Expression' k))) + (type: #export GExpression (Expression' Global)) + (type: #export VExpression (Expression' Var)) + (type: #export CExpression (Expression' Computation)) + + (def: (self-contained content) + (-> Text CExpression) + (@abstraction (format "(" content ")"))) + + (def: #export expression (-> Expression Text) (|>> @representation)) + + (def: arguments + (-> (List Expression) Text) + (|>> (list/map ..expression) (text.join-with ", "))) + + (def: #export code (-> Text CExpression) (|>> @abstraction)) + + (def: #export var + (-> Text VExpression) + (|>> (format "$") @abstraction)) + + (def: #export global + (-> Text GExpression) + (|>> @abstraction)) + + (def: #export null + CExpression + (@abstraction "NULL")) + + (def: #export bool + (-> Bool CExpression) + (|>> %b @abstraction)) + + (def: #export int + (-> Int CExpression) + (|>> %i @abstraction)) + + (def: #export float + (-> Frac CExpression) + (|>> (cond> [(f/= number.positive-infinity)] + [(new> "INF" self-contained)] + + [(f/= number.negative-infinity)] + [(new> "-INF" self-contained)] + + [(f/= number.not-a-number)] + [(new> "NAN" self-contained)] + + ## else + [%f @abstraction]))) + + (def: #export string + (-> Text CExpression) + (|>> %t @abstraction)) + + (def: #export (apply args func) + (-> (List Expression) Expression CExpression) + (self-contained + (format (@representation func) "(" (..arguments args) ")"))) + + (do-template [<name> <function>] + [(def: #export <name> + CExpression + (..apply (list) (..global <function>)))] + + [func-num-args/0 "func_num_args"] + [func-get-args/0 "func_get_args"] + ) + + (do-template [<name> <function>] + [(def: #export (<name> values) + (-> (List Expression) CExpression) + (..apply values (..global <function>)))] + + [array/* "array"] + ) + + (do-template [<name> <function>] + [(def: #export (<name> required optionals) + (-> Expression (List Expression) CExpression) + (..apply (list& required optionals) (..global <function>)))] + + [array-merge/+ "array_merge"] + ) + + (def: #export (array/** kvs) + (-> (List [Expression Expression]) CExpression) + (self-contained + (format "array(" + (|> kvs + (list/map (.function (_ [key value]) + (format (@representation key) " => " (@representation value)))) + (text.join-with ", ")) + ")"))) + + (do-template [<name> <function>] + [(def: #export (<name> input0) + (-> Expression CExpression) + (..apply (list input0) (..global <function>)))] + + [count/1 "count"]) + + (do-template [<name> <function>] + [(def: #export (<name> input0 input1) + (-> Expression Expression CExpression) + (..apply (list input0 input1) (..global <function>)))] + + [call-user-func-array/2 "call_user_func_array"] + [array-slice/2 "array_slice"]) + + (do-template [<name> <function>] + [(def: #export (<name> input0 input1 input2) + (-> Expression Expression Expression CExpression) + (..apply (list input0 input1 input2) (..global <function>)))] + + [array-slice/3 "array_slice"]) + + ## (def: (composite-literal left-delimiter right-delimiter entry-serializer) + ## (All [a] (-> Text Text (-> a Text) + ## (-> (List a) CExpression))) + ## (function (_ entries) + ## (@abstraction (format "(" left-delimiter + ## (|> entries (list/map entry-serializer) (text.join-with ",")) + ## right-delimiter ")")))) + + ## (def: #export (slice from to list) + ## (-> CExpression CExpression CExpression CExpression) + ## (@abstraction (format "(" (@representation list) + ## "[" (@representation from) ":" (@representation to) "]" + ## ")"))) + + ## (def: #export (slice-from from list) + ## (-> CExpression CExpression CExpression) + ## (@abstraction (format "(" (@representation list) + ## "[" (@representation from) ":]" + ## ")"))) + + ## (def: #export (field name object) + ## (-> Text CExpression CExpression) + ## (@abstraction (format "(" (@representation object) "." name ")"))) + + ## (def: #export (send args method object) + ## (-> (List CExpression) Text CExpression CExpression) + ## (|> object (field method) (apply args))) + + (def: #export (nth idx array) + (-> Expression Expression CExpression) + (self-contained + (format (@representation array) "[" (@representation idx) "]"))) + + (def: #export (? test then else) + (-> Expression Expression Expression CExpression) + (self-contained + (format (@representation test) " ? " + (@representation then) " : " + (@representation else)))) + + (do-template [<name> <op>] + [(def: #export (<name> param subject) + (-> Expression Expression CExpression) + (@abstraction (format "(" (@representation subject) + " " <op> " " + (@representation param) ")")))] + + ## [is "is"] + [= "=="] + [< "<"] + [<= "<="] + [> ">"] + [>= ">="] + [+ "+"] + [- "-"] + [* "*"] + [/ "/"] + [% "%"] + [** "**"] + ## [bit-or "|"] + ## [bit-and "&"] + ## [bit-xor "^"] + ## [bit-shl "<<"] + ## [bit-shr ">>"] + ) + + ## (do-template [<name> <op>] + ## [(def: #export (<name> param subject) + ## (-> CExpression CExpression CExpression) + ## (@abstraction (format "(" (@representation param) + ## " " <op> " " + ## (@representation subject) ")")))] + + ## [or "or"] + ## [and "and"] + ## ) + + ## (def: #export (not subject) + ## (-> CExpression CExpression) + ## (@abstraction (format "(not " (@representation subject) ")"))) + ) + +(abstract: #export Statement + {} + + Text + + (def: #export statement (-> Statement Text) (|>> @representation)) + + (def: #export (set! var value) + (-> VExpression Expression Statement) + (@abstraction + (format (..expression var) " = " (..expression value) ";"))) + + ## (def: #export (set-nth! idx value array) + ## (-> CExpression CExpression CExpression Statement) + ## (@abstraction (format (expression array) "[" (expression idx) "] = " (expression value)))) + + (def: #export (if! test then! else!) + (-> Expression Statement Statement Statement) + (@abstraction + (format "if (" (..expression test) ")" + (block (@representation then!)) + " else " + (block (@representation else!))))) + + (def: #export (when! test then!) + (-> Expression Statement Statement) + (@abstraction + (format "if (" (..expression test) ") " + (block (@representation then!))))) + + (def: #export (then! post! pre!) + (-> Statement Statement Statement) + (@abstraction + (format (@representation pre!) + "\n" + (@representation post!)))) + + ## (def: #export (while! test body!) + ## (-> CExpression Statement Statement) + ## (@abstraction + ## (format "while " (expression test) ":" + ## (nest body!)))) + + ## (def: #export (for-in! variable inputs body!) + ## (-> SVariable CExpression Statement Statement) + ## (@abstraction + ## (format "for " (..name variable) " in " (expression inputs) ":" + ## (nest body!)))) + + ## (type: #export Except + ## {#classes (List Text) + ## #exception SVariable + ## #handler Statement}) + + ## (def: #export (try! body! excepts) + ## (-> Statement (List Except) Statement) + ## (@abstraction + ## (format "try:" + ## (nest body!) + ## (|> excepts + ## (list/map (function (_ [classes exception catch!]) + ## (format "\n" "except (" (text.join-with "," classes) + ## ") as " (..name exception) ":" + ## (nest catch!)))) + ## (text.join-with ""))))) + + (do-template [<name> <keyword>] + [(def: #export (<name> message) + (-> Expression Statement) + (@abstraction + (format <keyword> " " (..expression message) ";")))] + + ## [raise! "raise"] + [return! "return"] + [echo! "echo"] + ) + + (def: #export (function! name args body) + (-> GExpression (List VExpression) Statement Statement) + (@abstraction + (format "function " (..expression name) "(" (..arguments args) ") " + (block (@representation body))))) + ) + +(def: #export (function arguments body) + (-> (List VExpression) Statement CExpression) + (self-contained + (format "function " "(" (..arguments arguments) ") " (block (..statement body))))) diff --git a/new-luxc/source/luxc/lang/translation/lua/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/lua/eval.jvm.lux index 8be5667e9..cc267e7d5 100644 --- a/new-luxc/source/luxc/lang/translation/lua/eval.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/lua/eval.jvm.lux @@ -75,35 +75,35 @@ (def: (lux-object host-object) (-> Object (Error Top)) - (`` (cond (host.null? host-object) - (ex.throw Null-Has-No-Lux-Representation "") - - (or (host.instance? java/lang/Boolean host-object) - (host.instance? java/lang/Long host-object) - (host.instance? java/lang/Double host-object) - (host.instance? java/lang/String host-object)) - (ex.return host-object) - - (host.instance? ByteString host-object) - (ex.return (ByteString::decode [] (:! ByteString host-object))) - - (host.instance? DefaultTable host-object) - (let [host-object (:! DefaultTable host-object)] - (case (variant lux-object host-object) - (#.Some value) - (ex.return value) - - #.None - (case (array lux-object host-object) - (#.Some value) - (ex.return value) - - #.None - (ex.throw Unknown-Kind-Of-Host-Object (format "SECOND " (Object::toString [] (:! Object host-object))))))) - - ## else - (ex.throw Unknown-Kind-Of-Host-Object (format "FIRST " (Object::toString [] (:! Object host-object)))) - ))) + (cond (host.null? host-object) + (ex.throw Null-Has-No-Lux-Representation "") + + (or (host.instance? java/lang/Boolean host-object) + (host.instance? java/lang/Long host-object) + (host.instance? java/lang/Double host-object) + (host.instance? java/lang/String host-object)) + (ex.return host-object) + + (host.instance? ByteString host-object) + (ex.return (ByteString::decode [] (:! ByteString host-object))) + + (host.instance? DefaultTable host-object) + (let [host-object (:! DefaultTable host-object)] + (case (variant lux-object host-object) + (#.Some value) + (ex.return value) + + #.None + (case (array lux-object host-object) + (#.Some value) + (ex.return value) + + #.None + (ex.throw Unknown-Kind-Of-Host-Object (format "SECOND " (Object::toString [] (:! Object host-object))))))) + + ## else + (ex.throw Unknown-Kind-Of-Host-Object (format "FIRST " (Object::toString [] (:! Object host-object)))) + )) (def: #export (eval code) (-> Expression (Meta Top)) diff --git a/new-luxc/source/luxc/lang/translation/php.lux b/new-luxc/source/luxc/lang/translation/php.lux new file mode 100644 index 000000000..4cfcaaa0f --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php.lux @@ -0,0 +1,214 @@ +(.module: + lux + (lux (control ["ex" exception #+ exception:] + pipe + [monad #+ do]) + (data [bit] + [maybe] + ["e" error #+ Error] + [text "text/" Eq<Text>] + text/format + (coll [array])) + [macro] + [io #+ IO Process io] + [host #+ class: interface: object] + (world [file #+ File])) + (luxc [lang] + (lang [".L" variable #+ Register] + ["ls" synthesis #+ Synthesis] + (host ["_" php #+ Expression Statement])) + [".C" io])) + +(do-template [<name>] + [(exception: #export (<name> {message Text}) + message)] + + [No-Active-Module-Buffer] + [Cannot-Execute] + + [No-Anchor] + ) + +(host.import java/lang/Object) + +(host.import java/lang/String + (getBytes [String] #try (Array byte))) + +(host.import java/lang/CharSequence) + +(host.import java/lang/Appendable + (append [CharSequence] Appendable)) + +(host.import java/lang/StringBuilder + (new []) + (toString [] String)) + +(host.import javax/script/ScriptEngine + (eval [String] #try Object)) + +(host.import javax/script/ScriptEngineManager + (new []) + (getEngineByName [String] ScriptEngine)) + +(type: #export Anchor [Text Register]) + +(type: #export Host + {#context [Text Nat] + #anchor (Maybe Anchor) + #loader (-> Statement (Error Unit)) + #interpreter (-> Expression (Error Object)) + #module-buffer (Maybe StringBuilder) + #program-buffer StringBuilder}) + +(def: #export init + (IO Host) + (io (let [interpreter (|> (ScriptEngineManager::new []) + (ScriptEngineManager::getEngineByName ["jphp"]))] + {#context ["" +0] + #anchor #.None + #loader (function (_ code) + (do e.Monad<Error> + [_ (ScriptEngine::eval [(format "<?php " (_.statement code))] interpreter)] + (wrap []))) + #interpreter (function (_ code) + (ScriptEngine::eval [(format "<?php " (_.statement (_.return! code)))] interpreter)) + #module-buffer #.None + #program-buffer (StringBuilder::new [])}))) + +(def: #export extension Text ".php") +(def: #export module-name Text (format "module" extension)) + +(def: #export init-module-buffer + (Meta Unit) + (function (_ compiler) + (#e.Success [(update@ #.host + (|>> (:! Host) + (set@ #module-buffer (#.Some (StringBuilder::new []))) + (:! Void)) + compiler) + []]))) + +(def: #export (with-sub-context expr) + (All [a] (-> (Meta a) (Meta [Text a]))) + (function (_ compiler) + (let [old (:! Host (get@ #.host compiler)) + [old-name old-sub] (get@ #context old) + new-name (format old-name "___" (%i (nat-to-int old-sub)))] + (case (expr (set@ #.host + (:! Void (set@ #context [new-name +0] old)) + compiler)) + (#e.Success [compiler' output]) + (#e.Success [(update@ #.host + (|>> (:! Host) + (set@ #context [old-name (n/inc old-sub)]) + (:! Void)) + compiler') + [new-name output]]) + + (#e.Error error) + (#e.Error error))))) + +(def: #export context + (Meta Text) + (function (_ compiler) + (#e.Success [compiler + (|> (get@ #.host compiler) + (:! Host) + (get@ #context) + (let> [name sub] + name))]))) + +(def: #export (with-anchor anchor expr) + (All [a] (-> Anchor (Meta a) (Meta a))) + (function (_ compiler) + (let [old (:! Host (get@ #.host compiler))] + (case (expr (set@ #.host + (:! Void (set@ #anchor (#.Some anchor) old)) + compiler)) + (#e.Success [compiler' output]) + (#e.Success [(update@ #.host + (|>> (:! Host) + (set@ #anchor (get@ #anchor old)) + (:! Void)) + compiler') + output]) + + (#e.Error error) + (#e.Error error))))) + +(def: #export anchor + (Meta Anchor) + (function (_ compiler) + (case (|> compiler (get@ #.host) (:! Host) (get@ #anchor)) + (#.Some anchor) + (#e.Success [compiler anchor]) + + #.None + ((lang.throw No-Anchor "") compiler)))) + +(def: #export module-buffer + (Meta StringBuilder) + (function (_ compiler) + (case (|> compiler (get@ #.host) (:! Host) (get@ #module-buffer)) + #.None + ((lang.throw No-Active-Module-Buffer "") compiler) + + (#.Some module-buffer) + (#e.Success [compiler module-buffer])))) + +(def: #export program-buffer + (Meta StringBuilder) + (function (_ compiler) + (#e.Success [compiler (|> compiler (get@ #.host) (:! Host) (get@ #program-buffer))]))) + +(do-template [<name> <field> <inputT> <outputT>] + [(def: (<name> code) + (-> <inputT> (Meta <outputT>)) + (function (_ compiler) + (let [runner (|> compiler (get@ #.host) (:! Host) (get@ <field>))] + (case (runner code) + (#e.Error error) + (exec (log! (:! Text code)) + ((lang.throw Cannot-Execute error) compiler)) + + (#e.Success output) + (#e.Success [compiler output])))))] + + [load! #loader Statement Unit] + [interpret #interpreter Expression Object] + ) + +(def: #export variant-tag-field "_lux_tag") +(def: #export variant-flag-field "_lux_flag") +(def: #export variant-value-field "_lux_value") + +(def: #export unit Text "") + +(def: #export (definition-name [module name]) + (-> Ident Text) + (lang.normalize-name (format module "$" name))) + +(def: #export (save code) + (-> Statement (Meta Unit)) + (do macro.Monad<Meta> + [module-buffer module-buffer + #let [_ (Appendable::append [(:! CharSequence (_.statement code))] + module-buffer)]] + (load! code))) + +(def: #export (save-module! target) + (-> File (Meta (Process Unit))) + (do macro.Monad<Meta> + [module macro.current-module-name + module-buffer module-buffer + program-buffer program-buffer + #let [module-code (StringBuilder::toString [] module-buffer) + _ (Appendable::append [(:! CharSequence (format module-code "\n"))] + program-buffer)]] + (wrap (ioC.write target + (format (lang.normalize-name module) "/" ..module-name) + (|> module-code + (String::getBytes ["UTF-8"]) + e.assume))))) + +(type: #export Translator (-> Synthesis (Meta Expression))) diff --git a/new-luxc/source/luxc/lang/translation/php/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/php/eval.jvm.lux new file mode 100644 index 000000000..ba9220f57 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php/eval.jvm.lux @@ -0,0 +1,147 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [bit] + [maybe] + ["e" error #+ Error] + text/format + (coll [array])) + [host]) + (luxc [lang] + (lang (host ["_" php #+ Expression Statement]))) + [//]) + +(do-template [<name>] + [(exception: #export (<name> {message Text}) + message)] + + [Not-A-Variant] + [Null-Has-No-Lux-Representation] + [Cannot-Evaluate] + ) + +(host.import java/lang/Object + (toString [] String) + (getClass [] (Class Object))) + +(host.import java/lang/Long + (intValue [] Integer)) + +(exception: #export (Unknown-Kind-Of-Host-Object {host-object Object}) + (let [object-class (:! Text (Object::toString [] (Object::getClass [] (:! Object host-object)))) + text-representation (:! Text (Object::toString [] (:! Object host-object)))] + (format object-class " --- " text-representation))) + +(host.import php/runtime/Memory) + +(host.import php/runtime/memory/NullMemory) + +(host.import php/runtime/memory/FalseMemory) +(host.import php/runtime/memory/TrueMemory) + +(host.import php/runtime/memory/LongMemory + (new [long]) + (toLong [] long)) + +(host.import php/runtime/memory/DoubleMemory + (toDouble [] double)) + +(host.import php/runtime/memory/StringMemory + (new [String]) + (toString [] String)) + +(host.import php/runtime/memory/ReferenceMemory + (getValue [] Memory)) + +(host.import php/runtime/memory/ArrayMemory + (size [] int) + (isMap [] boolean) + (get [Memory] Memory)) + +(def: (tuple lux-object host-object) + (-> (-> Object (Error Top)) ArrayMemory (Error Top)) + (let [size (ArrayMemory::size [] host-object)] + (loop [idx 0 + output (: (Array Top) (array.new (:! Nat size)))] + (if (i/< size idx) + (let [value (|> host-object + (ArrayMemory::get [(LongMemory::new [idx])]) + (:! ReferenceMemory) (ReferenceMemory::getValue []))] + (if (host.instance? php/runtime/memory/NullMemory value) + (recur (i/inc idx) + (array.write (:! Nat idx) (host.null) output)) + (do e.Monad<Error> + [lux-value (lux-object value)] + (recur (i/inc idx) + (array.write (:! Nat idx) lux-value output))))) + (ex.return output))))) + +(def: (variant lux-object host-object) + (-> (-> Object (Error Top)) ArrayMemory (Error Top)) + (do e.Monad<Error> + [variant-tag (lux-object (ArrayMemory::get [(StringMemory::new [//.variant-tag-field])] host-object)) + variant-value (lux-object (ArrayMemory::get [(StringMemory::new [//.variant-value-field])] host-object))] + (wrap (: Top + [(Long::intValue [] (:! Long variant-tag)) + (: Top + (if (|> host-object + (ArrayMemory::get [(StringMemory::new [//.variant-flag-field])]) + (:! ReferenceMemory) + (ReferenceMemory::getValue []) + (host.instance? php/runtime/memory/NullMemory)) + (host.null) + "")) + variant-value])))) + +(def: (lux-object host-object) + (-> Object (Error Top)) + (cond (host.instance? php/runtime/memory/FalseMemory host-object) + (ex.return false) + + (host.instance? php/runtime/memory/TrueMemory host-object) + (ex.return true) + + (host.instance? php/runtime/memory/LongMemory host-object) + (ex.return (LongMemory::toLong [] (:! LongMemory host-object))) + + (host.instance? php/runtime/memory/DoubleMemory host-object) + (ex.return (DoubleMemory::toDouble [] (:! DoubleMemory host-object))) + + (host.instance? php/runtime/memory/StringMemory host-object) + (ex.return (StringMemory::toString [] (:! StringMemory host-object))) + + (host.instance? php/runtime/memory/ReferenceMemory host-object) + (lux-object (ReferenceMemory::getValue [] (:! ReferenceMemory host-object))) + + (host.instance? php/runtime/memory/ArrayMemory host-object) + (if (ArrayMemory::isMap [] (:! ArrayMemory host-object)) + (variant lux-object (:! ArrayMemory host-object)) + (tuple lux-object (:! ArrayMemory host-object))) + + ## else + (ex.throw Unknown-Kind-Of-Host-Object host-object))) + +(def: #export (eval code) + (-> Expression (Meta Top)) + (function (_ compiler) + (let [interpreter (|> compiler (get@ #.host) (:! //.Host) (get@ #//.interpreter))] + (case (interpreter code) + (#e.Error error) + (exec (log! (format "eval #e.Error\n" + "<< " (_.expression code) "\n" + error)) + ((lang.throw Cannot-Evaluate error) compiler)) + + (#e.Success output) + (case (lux-object output) + (#e.Success parsed-output) + (exec ## (log! (format "eval #e.Success\n" + ## "<< " (_.expression code))) + (#e.Success [compiler parsed-output])) + + (#e.Error error) + (exec (log! (format "eval #e.Error\n" + "<< " (_.expression code) "\n" + error)) + ((lang.throw Cannot-Evaluate error) compiler))))))) diff --git a/new-luxc/source/luxc/lang/translation/php/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/php/expression.jvm.lux new file mode 100644 index 000000000..abcc22187 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php/expression.jvm.lux @@ -0,0 +1,82 @@ +(.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 #+ Synthesis] + (host ["_" php #+ Expression Statement]))) + [//] + (// [".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) + //.Translator + (case synthesis + (^template [<tag> <generator>] + [_ (<tag> value)] + (|> value <generator>)) + ([#.Bool primitiveT.translate-bool] + [#.Nat (<| primitiveT.translate-int (:! Int))] + [#.Int primitiveT.translate-int] + [#.Deg (<| primitiveT.translate-int (:! Int))] + [#.Frac primitiveT.translate-frac] + [#.Text primitiveT.translate-text]) + + (^code ((~ [_ (#.Nat tag)]) (~ [_ (#.Bool last?)]) (~ valueS))) + (structureT.translate-variant translate tag last? valueS) + + (^code [(~+ members)]) + (structureT.translate-tuple translate members) + + (^ [_ (#.Form (list [_ (#.Int var)]))]) + (referenceT.translate-variable var) + + [_ (#.Symbol 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/php/function.jvm.lux b/new-luxc/source/luxc/lang/translation/php/function.jvm.lux new file mode 100644 index 000000000..7d0baa4d5 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php/function.jvm.lux @@ -0,0 +1,81 @@ +(.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 #+ Synthesis Arity] + [".L" variable #+ Register Variable] + (host ["_" php #+ Expression GExpression CExpression Statement]))) + [//] + (// [".T" reference])) + +(def: #export (translate-apply translate functionS argsS+) + (-> //.Translator Synthesis (List Synthesis) (Meta CExpression)) + (do macro.Monad<Meta> + [functionO (translate functionS) + argsO+ (monad.map @ translate argsS+)] + (wrap (_.apply argsO+ functionO)))) + +(def: @curried (_.var "curried")) + +(def: (input-declaration! register) + (-> Register Statement) + (_.set! (referenceT.variable (n/inc register)) + (_.nth (|> register nat-to-int _.int) + @curried))) + +(def: (with-closure @function inits function-definition!) + (-> GExpression (List Expression) Statement (Meta Expression)) + (case inits + #.Nil + (do macro.Monad<Meta> + [_ (//.save function-definition!)] + (wrap @function)) + + _ + (do macro.Monad<Meta> + [] + (wrap (_.apply inits + (_.function (|> (list.enumerate inits) + (list/map (|>> product.left referenceT.closure))) + (|> function-definition! + (_.then! (_.return! @function))))))))) + +(def: #export (translate-function translate env arity bodyS) + (-> //.Translator (List Variable) Arity 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 [@function (_.global function-name) + self-init! (_.set! (referenceT.variable +0) @function) + args-inits! (|> (list.n/range +0 (n/dec arity)) + (list/map input-declaration!) + (list/fold _.then! self-init!)) + arityO (|> arity nat-to-int _.int) + @num_args (_.var "num_args")]] + (with-closure @function closureO+ + (_.function! @function (list) + (|> (_.set! @num_args _.func-num-args/0) + (_.then! (_.set! @curried _.func-get-args/0)) + (_.then! (_.if! (|> @num_args (_.= arityO)) + (|> args-inits! + (_.then! (_.return! bodyO))) + (_.if! (|> @num_args (_.> arityO)) + (let [arity-args (_.array-slice/3 @curried (_.int 0) arityO) + output-func-args (_.array-slice/2 @curried arityO)] + (_.return! (_.call-user-func-array/2 (_.call-user-func-array/2 @function arity-args) + output-func-args))) + (let [@missing (_.var "missing")] + (_.return! (_.function (list) + (|> (_.set! @missing _.func-get-args/0) + (_.then! (_.return! (_.call-user-func-array/2 @function + (_.array-merge/+ @curried (list @missing))))))))))))))))) diff --git a/new-luxc/source/luxc/lang/translation/php/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/php/primitive.jvm.lux new file mode 100644 index 000000000..61570143b --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php/primitive.jvm.lux @@ -0,0 +1,20 @@ +(.module: + lux + (lux [macro "meta/" Monad<Meta>]) + (luxc (lang (host ["_" php #+ CExpression])))) + +(def: #export translate-bool + (-> Bool (Meta CExpression)) + (|>> _.bool meta/wrap)) + +(def: #export translate-int + (-> Int (Meta CExpression)) + (|>> _.int meta/wrap)) + +(def: #export translate-frac + (-> Frac (Meta CExpression)) + (|>> _.float meta/wrap)) + +(def: #export translate-text + (-> Text (Meta CExpression)) + (|>> _.string meta/wrap)) diff --git a/new-luxc/source/luxc/lang/translation/php/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/php/reference.jvm.lux new file mode 100644 index 000000000..280710afc --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php/reference.jvm.lux @@ -0,0 +1,37 @@ +(.module: + lux + (lux [macro] + (data [text] + text/format)) + (luxc ["&" lang] + (lang [".L" variable #+ Variable Register] + (host ["_" php #+ VExpression]))) + [//] + (// [".T" runtime])) + +(do-template [<register> <prefix>] + [(def: #export <register> + (-> Register VExpression) + (|>> (:! Int) %i (format <prefix>) _.var))] + + [closure "c"] + [variable "v"]) + +(def: #export (local var) + (-> Variable VExpression) + (if (variableL.captured? var) + (closure (variableL.captured-register var)) + (variable (:! Nat var)))) + +(def: #export global + (-> Ident VExpression) + (|>> //.definition-name _.var)) + +(do-template [<name> <input> <converter>] + [(def: #export <name> + (-> <input> (Meta VExpression)) + (|>> <converter> (:: macro.Monad<Meta> wrap)))] + + [translate-variable Variable local] + [translate-definition Ident global] + ) diff --git a/new-luxc/source/luxc/lang/translation/php/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/php/runtime.jvm.lux new file mode 100644 index 000000000..d2f5cd2a2 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php/runtime.jvm.lux @@ -0,0 +1,447 @@ +(.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 ["_" php #+ Expression CExpression Statement])))) + +(def: prefix Text "LuxRuntime") + +(def: #export unit CExpression (_.string //.unit)) + +(def: (flag value) + (-> Bool CExpression) + (if value + (_.string "") + _.null)) + +(def: (variant' tag last? value) + (-> Expression Expression Expression CExpression) + (_.array/** (list [(_.string //.variant-tag-field) tag] + [(_.string //.variant-flag-field) last?] + [(_.string //.variant-value-field) value]))) + +(def: #export (variant tag last? value) + (-> Nat Bool Expression CExpression) + (variant' (_.int (nat-to-int tag)) + (flag last?) + value)) + +(def: #export none + CExpression + (variant +0 false unit)) + +(def: #export some + (-> Expression CExpression) + (variant +1 true)) + +(def: #export left + (-> Expression CExpression) + (variant +0 false)) + +(def: #export right + (-> Expression CExpression) + (variant +1 true)) + +(type: Runtime Statement) + +## (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 code.text (~) (_.var) (`)) +## args) +## declaration (` ((~ (code.local-symbol name)) +## (~+ argsC+))) +## type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression))) +## _.CExpression))] +## (wrap (list (` (def: (~' #export) (~ declaration) +## (~ type) +## (_.apply (list (~+ argsC+)) (~ @runtime)))) +## (` (def: (~ implementation) +## _.Statement +## (~ (case argsC+ +## #.Nil +## (` (_.set! (list (~ $runtime)) (~ definition))) + +## _ +## (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) +## (list/map (function (_ [left right]) +## (list left (` (@@ (~ right)))))) +## list/join))] +## (_.def! (~ $runtime) +## (list (~+ argsLC+)) +## (~ definition)))))))))))) + +## (syntax: (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 (lang.normalize-name var)))))))) +## list/join))] +## (~ body)))))) + +## (runtime: (lux//try op) +## (let [$error (_.var "error") +## $value (_.var "value")] +## (_.try! ($_ _.then! +## (_.set! (list $value) (_.apply (list unit) op)) +## (_.return! (right (@@ $value)))) +## (list [(list "Exception") $error +## (_.return! (left (_.apply (list (@@ $error)) (_.global "str"))))])))) + +## (runtime: (lux//program-args program-args) +## (let [$inputs (_.var "inputs") +## $value (_.var "value")] +## ($_ _.then! +## (_.set! (list $inputs) none) +## (<| (_.for-in! $value program-args) +## (_.set! (list $inputs) +## (some (_.tuple (list (@@ $value) (@@ $inputs)))))) +## (_.return! (@@ $inputs))))) + +## (def: runtime//lux +## Runtime +## ($_ _.then! +## @@lux//try +## @@lux//program-args)) + +## (runtime: (io//log! message) +## ($_ _.then! +## (_.print! message) +## (_.return! ..unit))) + +## (def: (exception message) +## (-> Expression CExpression) +## (_.apply (list message) (_.global "Exception"))) + +## (runtime: (io//throw! message) +## ($_ _.then! +## (_.raise! (exception message)) +## (_.return! ..unit))) + +## (runtime: (io//exit! code) +## ($_ _.then! +## (_.import! "sys") +## (_.do! (|> (_.global "sys") (_.send (list code) "exit"))) +## (_.return! ..unit))) + +## (runtime: (io//current-time! _) +## ($_ _.then! +## (_.import! "time") +## (_.return! (let [time (|> (_.global "time") +## (_.send (list) "time") +## (_.* (_.int 1_000)))] +## (_.apply (list time) (_.global "int")))))) + +## (def: runtime//io +## Runtime +## ($_ _.then! +## @@io//log! +## @@io//throw! +## @@io//exit! +## @@io//current-time!)) + +## (runtime: (product//left product index) +## (let [$index_min_length (_.var "index_min_length")] +## ($_ _.then! +## (_.set! (list $index_min_length) (_.+ (_.int 1) index)) +## (_.if! (_.> (@@ $index_min_length) (_.length product)) +## ## No need for recursion +## (_.return! (_.nth index product)) +## ## Needs recursion +## (_.return! (product//left (_.nth (_.- (_.int 1) +## (_.length product)) +## product) +## (_.- (_.length product) +## (@@ $index_min_length)))))))) + +## (runtime: (product//right product index) +## (let [$index_min_length (_.var "index_min_length")] +## ($_ _.then! +## (_.set! (list $index_min_length) (_.+ (_.int 1) index)) +## (_.cond! (list [(_.= (@@ $index_min_length) (_.length product)) +## ## Last element. +## (_.return! (_.nth index product))] +## [(_.< (@@ $index_min_length) (_.length product)) +## ## Needs recursion +## (_.return! (product//right (_.nth (_.- (_.int 1) +## (_.length product)) +## product) +## (_.- (_.length product) +## (@@ $index_min_length))))]) +## ## Must slice +## (_.return! (_.slice-from index product)))))) + +## (runtime: (sum//get sum wantedTag wantsLast) +## (let [no-match! (_.return! _.none) +## sum-tag (_.nth (_.string //.variant-tag-field) sum) +## sum-flag (_.nth (_.string //.variant-flag-field) sum) +## sum-value (_.nth (_.string //.variant-value-field) sum) +## is-last? (_.= (_.string "") sum-flag) +## test-recursion! (_.if! is-last? +## ## Must recurse. +## (_.return! (sum//get sum-value (_.- sum-tag wantedTag) wantsLast)) +## 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 +## Runtime +## ($_ _.then! +## @@product//left +## @@product//right +## @@sum//get)) + +## (def: full-32-bits (_.code "0xFFFFFFFF")) + +## (runtime: (bit//32 input) +## (with-vars [capped] +## (_.cond! (list [(|> input (_.> full-32-bits)) +## (_.return! (|> input (_.bit-and full-32-bits) bit//32))] +## [(|> input (_.> (_.code "0x7FFFFFFF"))) +## ($_ _.then! +## (_.set! (list capped) +## (_.apply (list (|> (_.code "0x100000000") +## (_.- input))) +## (_.global "int"))) +## (_.if! (|> (@@ capped) (_.<= (_.int 2147483647))) +## (_.return! (|> (@@ capped) (_.* (_.int -1)))) +## (_.return! (_.int -2147483648))))]) +## (_.return! input)))) + +## (def: full-64-bits (_.code "0xFFFFFFFFFFFFFFFF")) + +## (runtime: (bit//64 input) +## (with-vars [capped] +## (_.cond! (list [(|> input (_.> full-64-bits)) +## (_.return! (|> input (_.bit-and full-64-bits) bit//64))] +## [(|> input (_.> (_.code "0x7FFFFFFFFFFFFFFF"))) +## ($_ _.then! +## (_.set! (list capped) +## (_.apply (list (|> (_.code "0x10000000000000000") +## (_.- input))) +## (_.global "int"))) +## (_.if! (|> (@@ capped) (_.<= (_.code "9223372036854775807L"))) +## (_.return! (|> (@@ capped) (_.* (_.int -1)))) +## (_.return! (_.code "-9223372036854775808L"))))]) +## (_.return! input)))) + +## (runtime: (bit//shift-right param subject) +## (let [mask (|> (_.int 1) +## (_.bit-shl (_.- param (_.int 64))) +## (_.- (_.int 1)))] +## (_.return! (|> subject +## (_.bit-shr param) +## (_.bit-and mask))))) + +## (def: runtime//bit +## Runtime +## ($_ _.then! +## @@bit//32 +## @@bit//64 +## @@bit//shift-right)) + +## (runtime: (text//index subject param start) +## (with-vars [idx] +## ($_ _.then! +## (_.set! (list idx) (_.send (list param start) "find" subject)) +## (_.if! (_.= (_.int -1) (@@ idx)) +## (_.return! ..none) +## (_.return! (..some (@@ idx))))))) + +## (def: inc (|>> (_.+ (_.int 1)))) + +## (do-template [<name> <top-cmp>] +## [(def: (<name> top value) +## (-> Expression Expression Expression) +## (_.and (|> value (_.>= (_.int 0))) +## (|> value (<top-cmp> top))))] + +## [within? _.<] +## [up-to? _.<=] +## ) + +## (runtime: (text//clip @text @from @to) +## (with-vars [length] +## ($_ _.then! +## (_.set! (list length) (_.length @text)) +## (_.if! ($_ _.and +## (|> @to (within? (@@ length))) +## (|> @from (up-to? @to))) +## (_.return! (..some (|> @text (_.slice @from (inc @to))))) +## (_.return! ..none))))) + +## (runtime: (text//char text idx) +## (_.if! (|> idx (within? (_.length text))) +## (_.return! (..some (_.apply (list (|> text (_.slice idx (inc idx)))) +## (_.global "ord")))) +## (_.return! ..none))) + +## (def: runtime//text +## Runtime +## ($_ _.then! +## @@text//index +## @@text//clip +## @@text//char)) + +## (def: (check-index-out-of-bounds array idx body!) +## (-> Expression Expression Statement Statement) +## (_.if! (|> idx (_.<= (_.length array))) +## body! +## (_.raise! (exception (_.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)))))))) + +## (runtime: (array//put array idx value) +## (<| (check-index-out-of-bounds array idx) +## ($_ _.then! +## (_.set-nth! idx value array) +## (_.return! array)))) + +## (def: runtime//array +## Runtime +## ($_ _.then! +## @@array//get +## @@array//put)) + +## (def: #export atom//field Text "_lux_atom") + +## (runtime: (atom//compare-and-swap atom old new) +## (let [atom//field (_.string atom//field)] +## (_.if! (_.= old (_.nth atom//field atom)) +## ($_ _.then! +## (_.set-nth! atom//field new atom) +## (_.return! (_.bool true))) +## (_.return! (_.bool false))))) + +## (def: runtime//atom +## Runtime +## ($_ _.then! +## @@atom//compare-and-swap)) + +## (runtime: (box//write value box) +## ($_ _.then! +## (_.set-nth! (_.int 0) value box) +## (_.return! ..unit))) + +## (def: runtime//box +## Runtime +## ($_ _.then! +## @@box//write)) + +## (runtime: (process//future procedure) +## ($_ _.then! +## (_.import! "threading") +## (let [params (_.dict (list [(_.string "target") procedure]))] +## (_.do! (|> (_.global "threading") +## (_.send-keyword (list) params "Thread") +## (_.send (list) "start")))) +## (_.return! ..unit))) + +## (runtime: (process//schedule milli-seconds procedure) +## ($_ _.then! +## (_.import! "threading") +## (let [seconds (|> milli-seconds (_./ (_.float 1_000.0)))] +## (_.do! (|> (_.global "threading") +## (_.send (list seconds procedure) "Timer") +## (_.send (list) "start")))) +## (_.return! ..unit))) + +## (def: runtime//process +## Runtime +## ($_ _.then! +## @@process//future +## @@process//schedule)) + +## (do-template [<name> <method>] +## [(runtime: (<name> input) +## ($_ _.then! +## (_.import! "math") +## (_.return! (|> (_.global "math") (_.send (list input) <method>)))))] + +## [math//cos "cos"] +## [math//sin "sin"] +## [math//tan "tan"] +## [math//acos "acos"] +## [math//asin "asin"] +## [math//atan "atan"] +## [math//exp "exp"] +## [math//log "log"] +## [math//ceil "ceil"] +## [math//floor "floor"] +## ) + +## (def: runtime//math +## Runtime +## ($_ _.then! +## @@math//cos +## @@math//sin +## @@math//tan +## @@math//acos +## @@math//asin +## @@math//atan +## @@math//exp +## @@math//log +## @@math//ceil +## @@math//floor)) + +(def: runtime + Runtime + (_.echo! (_.string "Hello, world!")) + ## ($_ _.then! + ## runtime//lux + ## runtime//adt + ## runtime//bit + ## runtime//text + ## runtime//array + ## runtime//atom + ## runtime//box + ## runtime//io + ## runtime//process + ## runtime//math + ## ) + ) + +(def: #export artifact Text (format prefix //.extension)) + +(def: #export translate + (Meta (Process Unit)) + (do macro.Monad<Meta> + [_ //.init-module-buffer + _ (//.save runtime)] + (//.save-module! artifact))) diff --git a/new-luxc/source/luxc/lang/translation/php/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/php/statement.jvm.lux new file mode 100644 index 000000000..592e579cf --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php/statement.jvm.lux @@ -0,0 +1,48 @@ +(.module: + lux + (lux (control [monad #+ do]) + [macro] + (data text/format)) + (luxc (lang [".L" module] + (host ["_" php #+ Expression Statement]))) + [//] + (// [".T" runtime] + [".T" reference] + [".T" eval])) + +(def: #export (translate-def name expressionT expressionO metaV) + (-> Text Type Expression Code (Meta Unit)) + (do macro.Monad<Meta> + [current-module macro.current-module-name + #let [def-ident [current-module name]]] + (case (macro.get-symbol-ann (ident-for #.alias) metaV) + (#.Some real-def) + (do @ + [[realT realA realV] (macro.find-def real-def) + _ (moduleL.define def-ident [realT metaV realV])] + (wrap [])) + + _ + (do @ + [#let [def-name (referenceT.global def-ident)] + _ (//.save (_.set! def-name expressionO)) + expressionV (evalT.eval def-name) + _ (moduleL.define def-ident [expressionT metaV expressionV]) + _ (if (macro.type? metaV) + (case (macro.declared-tags metaV) + #.Nil + (wrap []) + + tags + (moduleL.declare-tags tags (macro.export? metaV) (:! Type expressionV))) + (wrap [])) + #let [_ (log! (format "DEF " (%ident def-ident)))]] + (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/php/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/php/structure.jvm.lux new file mode 100644 index 000000000..6e44f3973 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/php/structure.jvm.lux @@ -0,0 +1,31 @@ +(.module: + lux + (lux (control [monad #+ do]) + (data [text] + text/format) + [macro]) + (luxc ["&" lang] + (lang [synthesis #+ Synthesis] + (host ["_" php #+ Expression CExpression]))) + [//] + (// [".T" runtime])) + +(def: #export (translate-tuple translate elemsS+) + (-> //.Translator (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 (_.array/* elemsT+))))) + +(def: #export (translate-variant translate tag tail? valueS) + (-> //.Translator Nat Bool Synthesis (Meta CExpression)) + (do macro.Monad<Meta> + [valueT (translate valueS)] + (wrap (runtimeT.variant tag tail? valueT)))) |