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

(.module:
  [lux #*
   ["." debug]
   ["." host (#+ import: interface: do-to object)]
   [abstract
    [monad (#+ do)]]
   [control
    ["." exception (#+ exception:)]
    ["." io (#+ IO io)]
    [parser
     [cli (#+ program:)]]]
   [data
    ["." maybe]
    ["." error (#+ Error)]
    [number
     ["." i64]]
    ["." text ("#@." hash)
     format]
    [collection
     ["." array (#+ Array)]]]
   [macro
    ["." template]]
   [world
    ["." file]]
   [target
    ["_" scheme]]
   [tool
    [compiler
     ["." name]
     ["." synthesis]
     [phase
      [macro (#+ Expander)]
      ["." generation
       ["." scheme
        ["." runtime]
        ["." extension]]]]
     [default
      ["." platform (#+ Platform)]]]]]
  [program
   ["/" compositor
    ["/." cli]]])

(import: #long java/lang/Boolean)
(import: #long java/lang/String)

(import: #long (java/lang/Class a))

(import: #long java/lang/Object
  (toString [] java/lang/String)
  (getClass [] (java/lang/Class java/lang/Object)))

(import: #long java/lang/Long
  (intValue [] java/lang/Integer))

(import: #long java/lang/Integer
  (longValue [] java/lang/Long))

(import: #long gnu/math/IntNum
  (new #manual [int])
  (longValue [] long))

(import: #long gnu/math/DFloNum
  (doubleValue [] double))

(import: #long gnu/lists/FString
  (toString [] String))

(import: #long gnu/lists/Pair
  (getCar [] java/lang/Object)
  (getCdr [] java/lang/Object))

(import: #long (gnu/lists/FVector E)
  (getBufferLength [] int)
  (getRaw [int] E))

(import: #long gnu/expr/ModuleMethod
  (apply2 [java/lang/Object java/lang/Object] #try java/lang/Object))

(import: #long gnu/mapping/Environment)

(import: #long gnu/expr/Language
  (eval [java/lang/String] #try java/lang/Object))

(import: #long kawa/standard/Scheme
  (#static getR7rsInstance [] kawa/standard/Scheme))

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

               #.None
               false)
             
             #.None
             false)))
    
    #.None
    false))

(template [<name>]
  [(interface: <name>
     (getValue [] java/lang/Object))

   (`` (import: #long (~~ (template.identifier ["program/" <name>]))
         (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)
  (object [] gnu/lists/Pair [program/VariantValue]
    []
    ## Methods
    (program/VariantValue
     (getValue self) java/lang/Object
     (:coerce java/lang/Object value))
    (gnu/lists/Pair
     (getCar self) java/lang/Object
     (if cdr?
       (case (array.read 1 value)
         (#.Some flag-is-set)
         (:coerce java/lang/Object "")
         
         #.None
         (host.null))
       (|> value
           (array.read 0)
           maybe.assume
           (:coerce java/lang/Integer)
           gnu/math/IntNum::new)))
    (gnu/lists/Pair
     (getCdr self) java/lang/Object
     (if cdr?
       (|> value
           (array.read 2)
           maybe.assume
           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)
  (object [] gnu/lists/SimpleVector [program/TupleValue]
    []
    ## Methods
    (program/TupleValue
     (getValue self) java/lang/Object
     (:coerce java/lang/Object value))
    (gnu/lists/SimpleVector
     (getBufferLength self) int
     (host.long-to-int (array.size value)))
    (gnu/lists/SimpleVector
     (getRaw self {idx int}) java/lang/Object
     (|> value
         (array.read (|> idx java/lang/Integer::longValue (:coerce Nat)))
         maybe.assume
         lux-value))
    (gnu/lists/SimpleVector
     (getBuffer self) java/lang/Object
     (error! "tuple-value getBuffer"))
    (gnu/lists/SimpleVector
     (setBuffer self {_ java/lang/Object}) void
     (error! "tuple-value setBuffer"))
    (gnu/lists/SimpleVector
     (clearBuffer self {_ int} {_ int}) void
     (error! "tuple-value clearBuffer"))
    (gnu/lists/SimpleVector
     (copyBuffer self {_ int}) void
     (error! "tuple-value copyBuffer"))
    (gnu/lists/SimpleVector
     (newInstance self {_ int}) gnu/lists/SimpleVector
     (error! "tuple-value newInstance"))
    ))

(exception: (unknown-kind-of-host-object {object java/lang/Object})
  (exception.report
   ["Class" (java/lang/Object::toString (java/lang/Object::getClass object))]
   ["Object" (java/lang/Object::toString object)]))

(exception: (cannot-apply-a-non-function {object java/lang/Object})
  (exception.report
   ["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)
  (<| (case (host.check [java/lang/Object] value)
        (#.Some value)
        ## TODO: Get rid of the coercions below.
        (if (variant? value)
          (variant-value lux-value false (:coerce (Array java/lang/Object) value))
          (tuple-value lux-value (:coerce (Array java/lang/Object) value)))
        #.None)
      value))

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

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

(def: (read-variant read host-object)
  (-> (Reader java/lang/Object) (Reader gnu/lists/Pair))
  (do error.monad
    [tag (read (gnu/lists/Pair::getCar host-object))
     #let [host-object (:coerce gnu/lists/Pair (gnu/lists/Pair::getCdr host-object))
           flag (case (host.check java/lang/String (gnu/lists/Pair::getCar host-object))
                  (#.Some _)
                  true
                  
                  #.None
                  false)]
     value (read (gnu/lists/Pair::getCdr host-object))]
    (wrap (..variant (:coerce 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 [idx 0
           output (: (Array Any)
                     (array.new size))]
      (if (n/< size idx)
        (case (read (gnu/lists/FVector::getRaw (.int idx) host-object))
          (#error.Failure error)
          (#error.Failure error)

          (#error.Success lux-value)
          (recur (inc idx) (array.write idx (: Any lux-value) output)))
        (#error.Success output)))))

(def: (read host-object)
  (Reader java/lang/Object)
  (`` (<| (~~ (template [<class>]
                [(case (host.check <class> host-object)
                   (#.Some host-object)
                   (#error.Success host-object)
                   #.None)]

                [java/lang/Boolean] [java/lang/String] [gnu/expr/ModuleMethod]
                ))
          (~~ (template [<class> <method>]
                [(case (host.check <class> host-object)
                   (#.Some host-object)
                   (#error.Success (<method> host-object))
                   #.None)]

                [gnu/math/IntNum gnu/math/IntNum::longValue]
                [gnu/math/DFloNum gnu/math/DFloNum::doubleValue]
                [gnu/lists/FString gnu/lists/FString::toString]
                [program/VariantValue program/VariantValue::getValue]
                [program/TupleValue program/TupleValue::getValue]
                ))
          (case (host.check gnu/lists/Pair host-object)
            (#.Some host-object)
            (read-variant read host-object)
            #.None)
          (case (host.check gnu/lists/FVector host-object)
            (#.Some host-object)
            (read-tuple read (:coerce (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/expr/ModuleMethod))
  (|>> (:coerce java/lang/Object) (host.check gnu/expr/ModuleMethod)))

(def: (expander macro inputs lux)
  Expander
  (case (ensure-macro macro)
    (#.Some macro)
    (case (gnu/expr/ModuleMethod::apply2 (lux-value (:coerce java/lang/Object inputs))
                                         (lux-value (:coerce java/lang/Object lux))
                                         macro)
      (#error.Success output)
      (|> output
          ..read
          (:coerce (Error (Error [Lux (List Code)]))))

      (#error.Failure error)
      (#error.Failure error))

    #.None
    (exception.throw ..cannot-apply-a-non-function (:coerce java/lang/Object macro)))
  )

(def: separator "$")

(type: Host
  (generation.Host _.Expression _.Expression))

(def: host
  (IO Host)
  (io (let [interpreter (kawa/standard/Scheme::getR7rsInstance)
            evaluate! (function (evaluate! alias input)
                        (do error.monad
                          [output (gnu/expr/Language::eval (_.code input) interpreter)]
                          (read output)))]
        (: Host
           (structure
            (def: evaluate! evaluate!)
            (def: (execute! alias input)
              (gnu/expr/Language::eval (_.code input) interpreter))
            (def: (define! [module name] input)
              (let [global (format (text.replace-all .module-separator ..separator module)
                                   ..separator (name.normalize name)
                                   "___" (%n (text@hash name)))
                    @global (_.var global)]
                (do error.monad
                  [#let [definition (_.define-constant @global input)]
                   _ (gnu/expr/Language::eval (_.code definition) interpreter)
                   value (evaluate! global @global)]
                  (wrap [global value definition])))))))))

(def: platform
  (IO (Platform IO _.Var _.Expression _.Expression))
  (do io.monad
    [host ..host]
    (wrap {#platform.&monad io.monad
           #platform.&file-system file.system
           #platform.host host
           #platform.phase scheme.generate
           #platform.runtime runtime.generate})))

(def: (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))

(program: [{service /cli.service}]
  (/.compiler ..expander
              ..platform
              extension.bundle
              ..program
              service))