path: root/lux-c++/source/program.lux

... This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
... If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/.

... https://github.com/wlav/cppyy
(.require
 [library
  [lux (.except)
   [program (.only program)]
   ["[0]" ffi (.only import)]
   [abstract
    [monad (.only do)]]
   [control
    ["[0]" maybe (.use "[1]#[0]" monad)]
    ["[0]" try (.only Try)]
    ["[0]" exception (.only Exception)]
    ["[0]" io (.only IO io)]
    [concurrency
     ["[0]" async (.only Async)]
     ["[0]" atom]]]
   [data
    ["[0]" product]
    ["[0]" text (.only)
     ["%" \\format (.only format)]
     [encoding
      ["[0]" utf8]]]
    [collection
     ["[0]" array
      ["[1]" \\unsafe (.only Array)]]]]
   [math
    [number
     ["n" nat]
     ["i" int]
     ["[0]" i64]]]
   ["[0]" world
    ["[0]" file]
    ["[0]" environment]]
   [meta
    ["[0]" static]
    [macro
     ["^" pattern]
     ["[0]" template]]
    [compiler
     [target
      ["_" c++ (.only)
       [":" type]]]
     [reference
      [variable (.only Register)]]
     [language
      [lux
       [program (.only Program)]
       [translation (.only Host)]
       [analysis
        [macro (.only Expander)]]
       ["[0]" phase (.only Operation Phase)
        ["[0]" extension (.only Extender Handler)
         ... ["[0]" analysis
         ...  ["[1]" js]]
         ... ["[0]" translation
         ...  ["[1]" js]]
         ]
        [translation
         ["[0]" reference]
         ["/" c++ (.only)
          ["[1][0]" runtime]
          ["[1][0]" primitive]
          ["[1][0]" reference]]]]]]
     [default
      ["[0]" platform (.only Platform)]]
     [meta
      ["[0]" cli]
      ["[0]" context]
      [archive (.only Archive)
       ["[0]" unit]
       ["[0]" module]]
      ["[0]" packager
       ["[1]" script]]]]]]]
 [program
  ["[0]" compositor]])

(type Globals
  Any)

(import cppyy
  "[1]::[0]"
  ("static" cppdef [Text] "io" Bit)
  ("static" gbl Globals))

(ffi.import (getattr [Any Text] Any))

(ffi.import (tuple [(Array Any)] Any))

(ffi.import (str [Any] Text))

(def nested
  (-> Text
      Text)
  (let [\n\t (%.format text.\n text.\t)]
    (|>> (text.replaced text.\n \n\t)
         (%.format text.\t))))

(def module
  module.ID
  (-- 0))

(type Runtime
  Any)

(type Value
  Any)

(def (runtime globals)
  (-> Any
      Runtime)
  (getattr globals /runtime.namespace))

(with_template [<short> <type>]
  [(def (<short> @ it)
     (-> Runtime Any
         <type>)
     (let [on (as (-> Any
                      <type>)
                  (getattr @ (template.symbol [/runtime._] [<short>])))]
       (on it)))]

  [object_tag Nat]
  [lux_bit Bit]
  [lux_i64 Int]
  [lux_text Text]

  [variant_lefts Nat]
  [variant_right? Bit]
  [variant_choice Value]

  [tuple::arity Nat]
  )

(def (lux_variant lefts right? choice)
  (-> Nat Bit Value
      Any)
  (|> (array.empty 3)
      (array.has! 0 lefts)
      (array.has! 1 (if right?
                      []
                      (.python_object_none#)))
      (array.has! 2 choice)
      ..tuple))

(def (tuple::member @ member it)
  (-> Runtime Nat Any
      Value)
  (let [on (as (-> Nat Any
                   Value)
               (getattr @ /runtime.tuple::member))]
    (on member it)))

(def (lux_tuple @ lux_value input)
  (-> Runtime (-> Runtime Any Value) Any
      Any)
  (let [arity (tuple::arity @ input)]
    (loop (next [member 0
                 output (array.empty arity)])
      (if (n.< arity member)
        (next (++ member)
              (array.has! member (lux_value @ (tuple::member @ member input))
                          output))
        output))))

(def (lux_value @ it)
  (-> Runtime Value
      Any)
  (when (object_tag @ it)
    /runtime.bit_tag
    (lux_bit @ it)
    
    /runtime.i64_tag
    (lux_i64 @ it)
    
    ... /runtime.f64_tag

    /runtime.text_tag
    (..str (lux_text @ it))

    /runtime.variant_tag
    (lux_variant (variant_lefts @ it)
                 (variant_right? @ it)
                 (lux_value @ (variant_choice @ it)))
    
    /runtime.tuple_tag
    (lux_tuple @ lux_value it)
    
    /runtime.function_tag
    it

    tag
    (panic! (when tag
              2 "F64"
              _ "???"))))

(def host
  (IO (Host /runtime.Value /runtime.Declaration))
  (io (let [id (atom.atom 0)
            \n\t (%.format text.\n text.\t)
            evaluate! (is (-> [(Maybe unit.ID) /runtime.Value] (Try Any))
                          (function (evaluate! [_ input])
                            (let [[id _] (io.run! (atom.update! ++ id))
                                  global (reference.artifact [..module id])
                                  definition (_.constant (_.local global) /runtime.value_type input)]
                              (exec
                                (.log!# "[evaluate!]")
                                (.log!# (..nested (_.code definition)))
                                (if (io.run! (cppyy::cppdef (_.code definition)))
                                  {try.#Success (let [globals (io.run! (cppyy::gbl))]
                                                  (lux_value (..runtime globals)
                                                             (getattr globals global)))}
                                  {try.#Failure "Cannot evaluate!"})))))
            execute! (is (-> /runtime.Declaration
                             (Try Any))
                         (function (execute! input)
                           (exec
                             (.log!# "[execute!]")
                             (.log!# (..nested (_.code input)))
                             (if (io.run! (cppyy::cppdef (_.code input)))
                               {try.#Success []}
                               {try.#Failure "Cannot execute!"}))))]
        (is (Host /runtime.Value /runtime.Declaration)
            (implementation
             (def evaluate evaluate!)
             (def execute execute!)
             (def (define context custom [@def input])
               (let [global (maybe.else (reference.artifact context)
                                        custom)
                     @global (_.local global)]
                 (do try.monad
                   [.let [definition (_.constant @global /runtime.value_type input)]
                    _ (execute! definition)
                    .let [globals (io.run! (cppyy::gbl))
                          value (lux_value (..runtime globals)
                                           (getattr globals global))]]
                   (in [global value definition]))))

             (def (ingest context content)
               (|> content
                   (of utf8.codec decoded)
                   try.trusted
                   (as /runtime.Declaration)))

             (def (re_learn context custom content)
               (execute! content))
             
             (def (re_load context custom content)
               (do try.monad
                 [_ (execute! content)]
                 (evaluate! [{.#None} (_.local (reference.artifact context))]))))))))

(def phase_wrapper
  phase.Wrapper
  (|>>))

(def .public platform
  (IO [/runtime.Host
       (Platform /runtime.Anchor /runtime.Value /runtime.Declaration)])
  (do io.monad
    [host ..host]
    (in [host
         [platform.#file_system (file.async file.default)
          platform.#host host

          platform.#phase /.translation
          platform.#runtime /runtime.translation

          platform.#phase_wrapper ..phase_wrapper
          platform.#write (|>> _.code (of utf8.codec encoded))]])))

(def (extender _)
  Extender
  (undefined))

(def (expander macro inputs lux)
  Expander
  (undefined))

(def (c++_program name it)
  (Program /runtime.Value /runtime.Declaration)
  (undefined))

(def (declare_success! _)
  (-> Any
      (Async Any))
  (async.future (of environment.default exit +0)))

(def _
  (program [service cli.service]
    (let [context (context.c++ (cli.target service))]
      (exec
        (do async.monad
          [[host platform] (async.future ..platform)
           _ (compositor.compiler (|>> (as platform.Custom))
                                  context
                                  ..expander
                                  extension.empty
                                  (io.io platform)
                                  extension.empty
                                  extension.empty
                                  ..c++_program
                                  /reference.constant
                                  ..extender
                                  service
                                  [(packager.package (is /runtime.Declaration (_.manual ""))
                                                     _.code
                                                     _.also
                                                     (_.namespace "lux_program"))
                                   "program.cpp"])]
          (..declare_success! []))
        (io.io [])))))