path: root/lux-cl/source/program.lux

(.using
 [lux (.except)
  [program (.only program:)]
  ["[0]" ffi]
  ["[0]" debug]
  [abstract
   ["[0]" monad (.only do)]]
  [control
   ["[0]" pipe]
   ["[0]" maybe]
   ["[0]" try (.only Try)]
   ["[0]" exception (.only exception:)]
   ["[0]" io (.only IO io)]
   [concurrency
    ["[0]" promise (.only Promise)]]]
  [data
   ["[0]" text (.open: "[1]#[0]" hash)
    ["%" format (.only format)]
    ["[0]" encoding]]
   [collection
    ["[0]" array (.only Array)]]]
  [macro
   ["[0]" template]]
  [math
   [number (.only hex)
    ["n" nat]
    ["[0]" i64]]]
  ["[0]" world
   ["[0]" file]
   ["[1]/[0]" program]]
  ["@" target
   ["_" common_lisp]]
  [tool
   [compiler
    [phase (.only Operation Phase)]
    [reference
     [variable (.only Register)]]
    [language
     [lux
      [program (.only Program)]
      [generation (.only Context Host)]
      ["[0]" synthesis]
      [analysis
       [macro (.only Expander)]]
      [phase
       ["[0]" extension (.only Extender Handler)
        ["[1]/[0]" bundle]
        ["[0]" analysis
         ["[1]" common_lisp]]
        ["[0]" generation
         ["[1]" common_lisp]]]
       [generation
        ["[0]" reference]
        ["[0]" common_lisp
         ["[0]" runtime]]]]]]
    [default
     ["[0]" platform (.only Platform)]]
    [meta
     ["[0]" packager
      ["[1]" script]]]]]]
 [program
  ["/" compositor
   ["[1][0]" cli]
   ["[1][0]" static]]])

(ffi.import java/lang/String
  "[1]::[0]")

(ffi.import (java/lang/Class a)
  "[1]::[0]"
  ("static" forName [java/lang/String] "try" (java/lang/Class java/lang/Object)))

(ffi.import java/lang/Object
  "[1]::[0]"
  (toString [] java/lang/String)
  (getClass [] (java/lang/Class java/lang/Object)))

(ffi.import java/lang/Long
  "[1]::[0]"
  (intValue [] java/lang/Integer))

(ffi.import java/lang/Integer
  "[1]::[0]"
  (longValue [] long))

(ffi.import java/lang/Number
  "[1]::[0]"
  (intValue [] java/lang/Integer)
  (longValue [] long)
  (doubleValue [] double))

(ffi.import org/armedbear/lisp/LispObject
  "[1]::[0]"
  (length [] int)
  (NTH [int] org/armedbear/lisp/LispObject)
  (SVREF [int] org/armedbear/lisp/LispObject)
  (elt [int] org/armedbear/lisp/LispObject)
  (execute [org/armedbear/lisp/LispObject org/armedbear/lisp/LispObject] "try" org/armedbear/lisp/LispObject))

... The org/armedbear/lisp/Interpreter must be imported before the
... other ones, because there is an order dependency in their static initialization.
(ffi.import org/armedbear/lisp/Interpreter
  "[1]::[0]"
  ("static" getInstance [] org/armedbear/lisp/Interpreter)
  ("static" createInstance [] "?" org/armedbear/lisp/Interpreter)
  (eval [java/lang/String] "try" org/armedbear/lisp/LispObject))

(ffi.import org/armedbear/lisp/Symbol
  "[1]::[0]"
  ("static" T org/armedbear/lisp/Symbol))

(ffi.import org/armedbear/lisp/DoubleFloat
  "[1]::[0]"
  (new [double])
  (doubleValue [] double))

(ffi.import org/armedbear/lisp/SimpleString
  "[1]::[0]"
  (new [java/lang/String])
  (getStringValue [] java/lang/String))

(ffi.import org/armedbear/lisp/LispInteger
  "[1]::[0]")

(ffi.import org/armedbear/lisp/Bignum
  "[1]::[0]"
  (longValue [] long)
  ("static" getInstance [long] org/armedbear/lisp/LispInteger))

(ffi.import org/armedbear/lisp/Fixnum
  "[1]::[0]"
  (longValue [] long)
  ("static" getInstance [int] org/armedbear/lisp/Fixnum))

(ffi.import org/armedbear/lisp/Nil
  "[1]::[0]"
  ("static" NIL org/armedbear/lisp/Symbol))

(ffi.import org/armedbear/lisp/SimpleVector
  "[1]::[0]")

(ffi.import org/armedbear/lisp/Cons
  "[1]::[0]")

(ffi.import org/armedbear/lisp/Closure
  "[1]::[0]")

(ffi.interface: LuxADT
  (getValue [] java/lang/Object))

(ffi.import program/LuxADT
  "[1]::[0]"
  (getValue [] java/lang/Object))

(with_template [<name>]
  [(exception: (<name> [object java/lang/Object])
     (exception.report
      "Class" (java/lang/Object::toString (java/lang/Object::getClass object))
      "Object" (java/lang/Object::toString object)))]

  [unknown_kind_of_object]
  [cannot_apply_a_non_function]
  )

(def: host_bit
  (-> Bit org/armedbear/lisp/LispObject)
  (|>> (pipe.case #0 (org/armedbear/lisp/Nil::NIL)
         #1 (org/armedbear/lisp/Symbol::T))))

(def: (host_value value)
  (-> Any org/armedbear/lisp/LispObject)
  (let [to_sub (is (-> Any org/armedbear/lisp/LispObject)
                   (function (_ sub_value)
                     (let [sub_value (as java/lang/Object sub_value)]
                       (`` (<| (~~ (with_template [<type> <then>]
                                     [(case (ffi.is <type> sub_value)
                                        {.#Some sub_value}
                                        (`` (|> sub_value (~~ (template.splice <then>))))

                                        {.#None})]

                                     [[java/lang/Object] [host_value]]
                                     [java/lang/Boolean [..host_bit]]
                                     [java/lang/Integer [java/lang/Integer::longValue org/armedbear/lisp/Fixnum::getInstance]]
                                     [java/lang/Long [org/armedbear/lisp/Bignum::getInstance]]
                                     [java/lang/Double [org/armedbear/lisp/DoubleFloat::new]]
                                     [java/lang/String [org/armedbear/lisp/SimpleString::new]]
                                     ))
                               ... else
                               (as org/armedbear/lisp/LispObject sub_value))))))]
    (`` (ffi.object [] org/armedbear/lisp/LispObject [program/LuxADT]
          []
          ... Methods
          (program/LuxADT
           [] (getValue self []) java/lang/Object
           (as java/lang/Object value))

          (org/armedbear/lisp/LispObject
           [] (length self [])
           int
           (|> value
               (as (Array java/lang/Object))
               array.size
               (as java/lang/Long)
               java/lang/Number::intValue))

          (~~ (with_template [<name>]
                [(org/armedbear/lisp/LispObject
                  [] (<name> self [idx int])
                  org/armedbear/lisp/LispObject
                  (case (array.read! (|> idx java/lang/Integer::longValue (as Nat))
                                     (as (Array java/lang/Object) value))
                    {.#Some sub}
                    (to_sub sub)

                    {.#None}
                    (org/armedbear/lisp/Nil::NIL)))]

                [NTH] [SVREF] [elt]
                ))
          ))))

(type: (Reader a)
  (-> a (Try Any)))

(def: (read_variant read host_object)
  (-> (Reader org/armedbear/lisp/LispObject) (Reader org/armedbear/lisp/Cons))
  (do try.monad
    [tag (read (org/armedbear/lisp/LispObject::NTH +0 host_object))
     value (read (org/armedbear/lisp/LispObject::NTH +2 host_object))]
    (wrap [(java/lang/Long::intValue (as java/lang/Long tag))
           (case (ffi.is org/armedbear/lisp/Nil (org/armedbear/lisp/LispObject::NTH +1 host_object))
             {.#Some _}
             (is Any (ffi.null))

             _
             (is Any synthesis.unit))
           value])))

(def: (read_tuple read host_object)
  (-> (Reader org/armedbear/lisp/LispObject) (Reader org/armedbear/lisp/SimpleVector))
  (let [size (.nat (org/armedbear/lisp/LispObject::length host_object))]
    (loop (again [idx 0
                  output (as (Array Any) (array.new size))])
      (if (n.< size idx)
        ... TODO: Start using "SVREF" instead of "elt" ASAP
        (case (read (org/armedbear/lisp/LispObject::elt (.int idx) host_object))
          {try.#Failure error}
          {try.#Failure error}

          {try.#Success member}
          (again (++ idx) (array.write! idx (as Any member) output)))
        {try.#Success output}))))

(def: (read host_object)
  (Reader org/armedbear/lisp/LispObject)
  (`` (<| (~~ (with_template [<class> <post_processing>]
                [(case (ffi.is <class> host_object)
                   {.#Some host_object}
                   (`` (|> host_object (~~ (template.splice <post_processing>))))

                   {.#None})]

                [org/armedbear/lisp/Bignum [org/armedbear/lisp/Bignum::longValue {try.#Success}]]
                [org/armedbear/lisp/Fixnum [org/armedbear/lisp/Fixnum::longValue {try.#Success}]]
                [org/armedbear/lisp/DoubleFloat [org/armedbear/lisp/DoubleFloat::doubleValue {try.#Success}]]
                [org/armedbear/lisp/SimpleString [org/armedbear/lisp/SimpleString::getStringValue {try.#Success}]]
                [org/armedbear/lisp/Cons [(read_variant read)]]
                [org/armedbear/lisp/SimpleVector [(read_tuple read)]]
                [org/armedbear/lisp/Nil [(pipe.new {try.#Success false} [])]]
                [org/armedbear/lisp/Closure [{try.#Success}]]
                [program/LuxADT [program/LuxADT::getValue {try.#Success}]]))
          (case (ffi.is org/armedbear/lisp/Symbol host_object)
            {.#Some host_object}
            (if (same? (org/armedbear/lisp/Symbol::T) host_object)
              {try.#Success true}
              (exception.throw ..unknown_kind_of_object (as java/lang/Object host_object)))

            {.#None})
          ... else
          (exception.throw ..unknown_kind_of_object (as java/lang/Object host_object))
          )))

(def: ensure_macro
  (-> Macro (Maybe org/armedbear/lisp/Closure))
  (|>> (as java/lang/Object) (ffi.is org/armedbear/lisp/Closure)))

(def: (call_macro inputs lux macro)
  (-> (List Code) Lux org/armedbear/lisp/Closure (Try (Try [Lux (List Code)])))
  (do try.monad
    [raw_output (org/armedbear/lisp/LispObject::execute (..host_value inputs) (..host_value lux) macro)]
    (as (Try (Try [Lux (List Code)]))
        (..read raw_output))))

(def: (expander macro inputs lux)
  Expander
  (case (ensure_macro macro)
    {.#Some macro}
    (call_macro inputs lux macro)

    {.#None}
    (exception.throw ..cannot_apply_a_non_function (as java/lang/Object macro))))

(def: host
  (IO (Host (_.Expression Any) (_.Expression Any)))
  (io (let [_ (org/armedbear/lisp/Interpreter::createInstance)
            interpreter (org/armedbear/lisp/Interpreter::getInstance)
            run! (is (-> (_.Code Any) (Try Any))
                     (function (_ code)
                       (do try.monad
                         [host_value (org/armedbear/lisp/Interpreter::eval (_.code code) interpreter)]
                         (read host_value))))]
        (is (Host (_.Expression Any) (_.Expression Any))
            (structure
             (def: (evaluate! context code)
               (run! code))
             
             (def: (execute! input)
               (org/armedbear/lisp/Interpreter::eval (_.code input) interpreter))
             
             (def: (define! context input)
               (let [global (reference.artifact context)
                     @global (_.var global)]
                 (do try.monad
                   [#let [definition (_.defparameter @global input)]
                    _ (org/armedbear/lisp/Interpreter::eval (_.code definition) interpreter)
                    value (run! @global)]
                   (wrap [global value definition]))))

             (def: (ingest context content)
               (|> content (at encoding.utf8 decoded) try.trusted (as (_.Expression Any))))

             (def: (re_learn context content)
               (run! content))
             
             (def: (re_load context content)
               (do try.monad
                 [_ (run! content)]
                 (run! (_.var (reference.artifact context)))))
             )))))

(def: platform
  (IO (Platform [_.Tag Register] (_.Expression Any) (_.Expression Any)))
  (do io.monad
    [host ..host]
    (wrap [platform.#file_system (file.async file.default)
           platform.#host host
           platform.#phase common_lisp.generate
           platform.#runtime runtime.generate
           platform.#write (|>> _.code (at encoding.utf8 encoded))])))

(def: get_ecl_cli_inputs
  (let [@idx (_.var "i")]
    (_.call/* (_.var "loop")
              (list (_.var "for") @idx
                    (_.var "from") (_.int +0)
                    (_.var "below") (_.call/* (_.var "si:argc") (list))
                    (_.var "collect") (_.call/* (_.var "si:argv") (list @idx))))))

(def: (program context program)
  (Program (_.Expression Any) (_.Expression Any))
  (let [raw_inputs (_.progn (list (_.conditional+ (list "clisp") (_.var "ext:*args*"))
                                  (_.conditional+ (list "sbcl") (_.var "sb-ext:*posix-argv*"))
                                  (_.conditional+ (list "clozure") (_.call/* (_.var "ccl::command-line-arguments") (list)))
                                  (_.conditional+ (list "gcl") (_.var "si:*command-args*"))
                                  (_.conditional+ (list "ecl") ..get_ecl_cli_inputs)
                                  (_.conditional+ (list "cmu") (_.var "extensions:*command-line-strings*"))
                                  (_.conditional+ (list "allegro") (_.call/* (_.var "sys:command-line-arguments") (list)))
                                  (_.conditional+ (list "lispworks") (_.var "sys:*line-arguments-list*"))
                                  (_.list/* (list))))]
    (_.call/2 [(runtime.lux//program_args raw_inputs) _.nil] program)))

(for @.old
     (def: extender
       Extender
       ... TODO: Stop relying on coercions ASAP.
       (<| (as Extender)
           (function (@self handler))
           (as Handler)
           (function (@self name phase))
           (as Phase)
           (function (@self archive parameters))
           (as Operation)
           (function (@self state))
           (as Try)
           try.trusted
           (as Try)
           (exec
             ("lux io log" "TODO: Extender")
             {try.#Failure "TODO: Extender"})))

     @.common_lisp
     (def: (extender handler)
       Extender
       (as_expected handler)))

(def: (declare_success! _)
  (-> Any (Promise Any))
  (promise.future (at world/program.default exit +0)))

(def: (then pre post)
  (-> (_.Expression Any) (_.Expression Any) (_.Expression Any))
  (_.manual (format (_.code pre)
                    text.new_line
                    (_.code post))))

(def: (scope body)
  (-> (_.Expression Any) (_.Expression Any))
  (let [@program (_.var "lux_program")]
    (all ..then
         (_.defun @program (_.args (list)) body)
         (_.call/* @program (list))
         )))

(`` (program: [service /cli.service]
      (let [extension ".cl"]
        (do io.monad
          [platform ..platform]
          (exec (do promise.monad
                  [_ (/.compiler [/static.#host @.common_lisp
                                  /static.#host_module_extension extension
                                  /static.#target (/cli.target service)
                                  /static.#artifact_extension extension]
                                 ..expander
                                 analysis.bundle
                                 (io.io platform)
                                 generation.bundle
                                 extension/bundle.empty
                                 ..program
                                 [(& _.Tag Register) (type (_.Expression Any)) (type (_.Expression Any))]
                                 ..extender
                                 service
                                 [(packager.package (_.manual "")
                                                    _.code
                                                    ..then
                                                    ..scope)
                                  (format (/cli.target service)
                                          (at file.default separator)
                                          "program"
                                          extension)])]
                  (..declare_success! []))
            (io.io []))))))