path: root/lux-scheme/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/.

(.require
 [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 (.use "[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]
   [time
    ["[0]" instant]]]
  ["@" target
   ["_" scheme]]
  [meta
   [compiler
    [phase (.only Operation Phase)]
    [reference
     [variable (.only Register)]]
    [language
     [lux
      [program (.only Program)]
      [translation (.only Context Host)]
      ["[0]" synthesis]
      [analysis
       [macro (.only Expander)]]
      [phase
       ["[0]" extension (.only Extender Handler)
        ["[1]/[0]" bundle]
        ["[0]" analysis
         ["[1]" scheme]]
        ["[0]" translation
         ["[1]" scheme]]]
       [translation
        ["[0]" reference]
        ["[0]" scheme
         ["[0]" runtime]]]]]]
    [default
     ["[0]" platform (.only Platform)]]
    [meta
     ["[0]" packager
      ["[1]" scheme]]]]]]
 [program
  ["/" compositor
   ["[1][0]" cli]
   ["[1][0]" static]]])

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

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

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

(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 [] java/lang/Long))

(ffi.import gnu/math/IntNum
  "[1]::[0]"
  (new "manual" [int])
  (longValue [] long))

(ffi.import gnu/math/DFloNum
  "[1]::[0]"
  (doubleValue [] double))

(ffi.import gnu/lists/FString
  "[1]::[0]"
  (toString [] String))

(ffi.import gnu/lists/IString
  "[1]::[0]"
  (toString [] String))

(ffi.import gnu/lists/Pair
  "[1]::[0]"
  (getCar [] java/lang/Object)
  (getCdr [] java/lang/Object))

(ffi.import gnu/lists/EmptyList
  "[1]::[0]"
  ("static" emptyList gnu/lists/EmptyList))

(ffi.import (gnu/lists/FVector E)
  "[1]::[0]"
  (getBufferLength [] int)
  (getRaw [int] E))

(ffi.import gnu/lists/U8Vector
  "[1]::[0]")

(ffi.import gnu/mapping/Procedure
  "[1]::[0]"
  (apply2 [java/lang/Object java/lang/Object] "try" java/lang/Object)
  (applyN [[java/lang/Object]] "try" java/lang/Object))

(ffi.import gnu/mapping/Environment
  "[1]::[0]")

(ffi.import gnu/expr/Language
  "[1]::[0]"
  (eval [java/lang/String] "try" java/lang/Object))

(ffi.import kawa/standard/Scheme
  "[1]::[0]"
  ("static" getR7rsInstance [] kawa/standard/Scheme))

(def (variant? value)
  (-> Any Bit)
  (when (ffi.as [java/lang/Object] (as java/lang/Object value))
    {.#Some array}
    ... TODO: Get rid of this coercion ASAP.
    (let [array (as (Array java/lang/Object) array)]
      (and (n.= 3 (array.size array))
           (when (array.read! 0 array)
             {.#Some tag}
             (when (ffi.as java/lang/Integer tag)
               {.#Some _}
               true

               {.#None}
               false)
             
             {.#None}
             false)))
    
    {.#None}
    false))

(with_template [<name>]
  [(ffi.interface <name>
     (getValue [] java/lang/Object))

   (`` (ffi.import (,, (template.symbol ["program/" <name>]))
         "[1]::[0]"
         (getValue [] java/lang/Object)))]

  [VariantValue]
  [TupleValue]
  )

(def (variant_value lux_value cdr? value)
  (-> (-> java/lang/Object java/lang/Object) Bit (Array java/lang/Object) gnu/lists/Pair)
  (ffi.object [] gnu/lists/Pair [program/VariantValue]
    []
    ... Methods
    (program/VariantValue
     [] (getValue self []) java/lang/Object
     (as java/lang/Object value))
    (gnu/lists/Pair
     [] (getCar self []) java/lang/Object
     (if cdr?
       (when (array.read! 1 value)
         {.#Some flag_is_set}
         true
         
         {.#None}
         false)
       (|> value
           (array.read! 0)
           maybe.trusted
           (as java/lang/Integer)
           gnu/math/IntNum::new)))
    (gnu/lists/Pair
     [] (getCdr self []) java/lang/Object
     (if cdr?
       (|> value
           (array.read! 2)
           maybe.trusted
           lux_value)
       (variant_value lux_value true value)))))

(def (tuple_value lux_value value)
  (-> (-> java/lang/Object java/lang/Object) (Array java/lang/Object) gnu/lists/FVector)
  (ffi.object [] gnu/lists/SimpleVector [program/TupleValue gnu/lists/GVector]
    []
    ... Methods
    (program/TupleValue
     [] (getValue self []) java/lang/Object
     (as java/lang/Object value))
    (gnu/lists/SimpleVector
     [] (getBufferLength self []) int
     (ffi.long_to_int (array.size value)))
    (gnu/lists/SimpleVector
     [] (getRaw self [idx int]) java/lang/Object
     (|> value
         (array.read! (|> idx java/lang/Integer::longValue (as Nat)))
         maybe.trusted
         lux_value))
    (gnu/lists/SimpleVector
     [] (getBuffer self []) java/lang/Object
     (undefined))
    (gnu/lists/SimpleVector
     [] (setBuffer self [_ java/lang/Object]) void
     (undefined))
    (gnu/lists/SimpleVector
     [] (clearBuffer self [_ int _ int]) void
     (undefined))
    (gnu/lists/SimpleVector
     [] (copyBuffer self [_ int]) void
     (undefined))
    (gnu/lists/SimpleVector
     [] (newInstance self [_ int]) gnu/lists/SimpleVector
     (undefined))
    ))

(exception.def (unknown_kind_of_host_object object)
  (Exception java/lang/Object)
  (exception.report
   (list ["Class" (java/lang/Object::toString (java/lang/Object::getClass object))]
         ["Object" (java/lang/Object::toString object)])))

(exception.def (cannot_apply_a_non_function object)
  (Exception java/lang/Object)
  (exception.report
   (list ["Class" (java/lang/Object::toString (java/lang/Object::getClass object))]
         ["Object" (java/lang/Object::toString object)])))

(def (lux_value value)
  (-> java/lang/Object java/lang/Object)
  (<| (when (ffi.as [java/lang/Object] value)
        {.#Some value}
        ... TODO: Get rid of the coercions below.
        (if (variant? value)
          (variant_value lux_value false (as (Array java/lang/Object) value))
          (tuple_value lux_value (as (Array java/lang/Object) value)))

        {.#None})
      value))

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

(def (variant tag flag value)
  (-> Nat Bit Any Any)
  [(java/lang/Long::intValue (as java/lang/Long tag))
   (is Any
       (if flag
         synthesis.unit
         (ffi.null)))
   value])

(def (read_variant read host_object)
  (-> (Reader java/lang/Object) (Reader gnu/lists/Pair))
  (do try.monad
    [tag (read (gnu/lists/Pair::getCar host_object))
     #let [host_object (as gnu/lists/Pair (gnu/lists/Pair::getCdr host_object))
           flag (when (ffi.as java/lang/Boolean (gnu/lists/Pair::getCar host_object))
                  {.#Some flag}
                  (as Bit flag)
                  
                  {.#None}
                  (undefined))]
     value (read (gnu/lists/Pair::getCdr host_object))]
    (wrap (..variant (as Nat tag) flag value))))

(def (read_tuple read host_object)
  (-> (Reader java/lang/Object) (Reader (gnu/lists/FVector java/lang/Object)))
  (let [size (.nat (gnu/lists/FVector::getBufferLength host_object))]
    (loop (again [idx 0
                  output (is (Array Any)
                             (array.new size))])
      (if (n.< size idx)
        (when (read (gnu/lists/FVector::getRaw (.int idx) host_object))
          {try.#Failure error}
          {try.#Failure error}

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

(def (read host_object)
  (Reader java/lang/Object)
  (`` (<| (,, (with_template [<class>]
                [(when (ffi.as <class> host_object)
                   {.#Some host_object}
                   {try.#Success host_object}

                   {.#None})]

                [java/lang/Boolean] [java/lang/Long] [java/lang/Double] [java/lang/String]
                [gnu/mapping/Procedure] [gnu/lists/U8Vector]
                ))
          (,, (with_template [<class> <processing>]
                [(when (ffi.as <class> host_object)
                   {.#Some host_object}
                   {try.#Success (<| <processing> host_object)}

                   {.#None})]

                [java/lang/Integer java/lang/Integer::longValue]

                [gnu/lists/EmptyList (pipe.new [] [])]
                [gnu/math/IntNum gnu/math/IntNum::longValue]
                [gnu/math/DFloNum gnu/math/DFloNum::doubleValue]
                [gnu/lists/FString gnu/lists/FString::toString]
                [gnu/lists/IString gnu/lists/IString::toString]
                
                [program/VariantValue program/VariantValue::getValue]
                [program/TupleValue program/TupleValue::getValue]
                ))
          (when (ffi.as gnu/lists/Pair host_object)
            {.#Some host_object}
            (read_variant read host_object)

            {.#None})
          (when (ffi.as gnu/lists/FVector host_object)
            {.#Some host_object}
            (read_tuple read (as (gnu/lists/FVector java/lang/Object) host_object))

            {.#None})
          ... else
          (exception.throw ..unknown_kind_of_host_object host_object))))

(def ensure_macro
  (-> Macro (Maybe gnu/mapping/Procedure))
  (|>> (as java/lang/Object) (ffi.as gnu/mapping/Procedure)))

(def (expander macro inputs lux)
  Expander
  (when (..ensure_macro macro)
    {.#Some macro}
    (when (gnu/mapping/Procedure::apply2 (lux_value (as java/lang/Object inputs))
                                         (lux_value (as java/lang/Object lux))
                                         macro)
      {try.#Success output}
      (|> output
          ..read
          (as (Try (Try [Lux (List Code)]))))

      {try.#Failure error}
      {try.#Failure error})

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

(def host
  (IO (Host _.Expression _.Expression))
  (io (let [interpreter (kawa/standard/Scheme::getR7rsInstance)
            run! (is (-> (_.Code Any) (Try Any))
                     (function (_ input)
                       (do try.monad
                         [output (gnu/expr/Language::eval (_.code input) interpreter)]
                         (read output))))]
        (is (Host _.Expression _.Expression)
            (structure
             (def (evaluate! context code)
               (run! code))
             
             (def (execute! input)
               (gnu/expr/Language::eval (_.code input) interpreter))
             
             (def (define! context input)
               (let [global (reference.artifact context)
                     @global (_.var global)]
                 (do try.monad
                   [#let [definition (_.define_constant @global input)]
                    _ (gnu/expr/Language::eval (_.code definition) interpreter)
                    value (run! @global)]
                   (wrap [global value definition]))))

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

             (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 _.Var _.Expression _.Expression))
  (do io.monad
    [host ..host]
    (wrap [platform.#file_system (file.async file.default)
           platform.#host host
           platform.#phase scheme.translate
           platform.#runtime runtime.translate
           platform.#write (|>> _.code (of encoding.utf8 encoded))])))

(def (program context program)
  (Program _.Expression _.Expression)
  (_.apply/2 program
             ... TODO: Figure out how to always get the command-line
             ... arguments.
             ... It appears that it differs between Scheme implementations.
             (runtime.lux//program_args _.nil)
             _.nil))

(for @.old
     (def extender
       Extender
       ... TODO: Stop relying on coercions ASAP.
       (<| (as Extender)
           (function (@self handler))
           (as Handler)
           (function (@self phase))
           (as Phase)
           (function (@self archive parameters))
           (as Operation)
           (function (@self state))
           (as Try)
           try.trusted
           (as Try)
           (do try.monad
             [handler (try.from_maybe (..ensure_macro (as Macro handler)))
              output (gnu/mapping/Procedure::applyN (array.from_list (list (lux_value (as java/lang/Object name))
                                                                           (lux_value (as java/lang/Object phase))
                                                                           (lux_value (as java/lang/Object archive))
                                                                           (lux_value (as java/lang/Object parameters))
                                                                           (lux_value (as java/lang/Object state))))
                                                    handler)]
             (..read output))))

     @.scheme
     (def (extender handler)
       Extender
       (as_expected handler)))

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

(`` (def _
      (program [service /cli.service]
        (let [extension ".scm"]
          (do io.monad
            [platform ..platform
             now instant.now]
            (exec (do promise.monad
                    [_ (/.compiler [/static.#host @.scheme
                                    /static.#host_module_extension extension
                                    /static.#target (/cli.target service)
                                    /static.#artifact_extension extension]
                                   ..expander
                                   analysis.bundle
                                   (io.io platform)
                                   translation.bundle
                                   extension/bundle.empty
                                   ..program
                                   [_.Var _.Expression _.Expression]
                                   ..extender
                                   service
                                   [(packager.package now)
                                    "program.tar"])]
                    (..declare_success! []))
              (io.io [])))))))