- WIP: - Initial PHP back-end implementation.

1 files changed, 214 insertions, 0 deletions

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)))