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

(.module:
  [lux "*"
   [program {"+" [program:]}]
   ["[0]" ffi]
   ["[0]" debug]
   [abstract
    ["[0]" monad {"+" [do]}]]
   [control
    [pipe {"+" [exec> case> new>]}]
    ["[0]" maybe]
    ["[0]" try {"+" [Try]}]
    ["[0]" exception {"+" [exception:]}]
    ["[0]" io {"+" [IO io]}]
    [concurrency
     ["[0]" promise {"+" [Promise]}]]]
   [data
    ["[0]" text ("[1]\[0]" hash)
     ["%" format {"+" [format]}]
     ["[0]" encoding]]
    [collection
     ["[0]" array {"+" [Array]}]]]
   [macro
    ["[0]" template]]
   [math
    [number {"+" [hex]}
     ["n" nat]
     ["[0]" i64]]]
   [time
    ["[0]" instant]]
   ["[0]" world "_"
    ["[0]" file]
    ["[1]/[0]" program]]
   ["@" target
    ["_" scheme]]
   [tool
    [compiler
     [phase {"+" [Operation Phase]}]
     [reference
      [variable {"+" [Register]}]]
     [language
      [lux
       [program {"+" [Program]}]
       [generation {"+" [Context Host]}]
       ["[0]" synthesis]
       [analysis
        [macro {"+" [Expander]}]]
       [phase
        ["[0]" extension {"+" [Extender Handler]}
         ["[1]/[0]" bundle]
         ["[0]" analysis "_"
          ["[1]" scheme]]
         ["[0]" generation "_"
          ["[1]" scheme]]]
        [generation
         ["[0]" reference]
         ["[0]" scheme
          ["[0]" runtime]]]]]]
     [default
      ["[0]" platform {"+" [Platform]}]]
     [meta
      ["[0]" packager "_"
       ["[1]" scheme]]]]]]
  [program
   ["/" compositor
    ["[1][0]" cli]
    ["[1][0]" static]]])

(ffi.import: java/lang/Boolean)
(ffi.import: java/lang/String)

(ffi.import: (java/lang/Class a))

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

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

(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)
  (case (ffi.check [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))
           (case (array.read! 0 array)
             {#.Some tag}
             (case (ffi.check java/lang/Integer tag)
               {#.Some _}
               true

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

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

   (`` (ffi.import: (~~ (template.identifier ["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?
       (case (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: (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 (ffi.check [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))
   (: 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 (case (ffi.check 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 [idx 0
           output (: (Array Any)
                     (array.new size))]
      (if (n.< size idx)
        (case (read (gnu/lists/FVector::getRaw (.int idx) host_object))
          {#try.Failure error}
          {#try.Failure error}

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

(def: (read host_object)
  (Reader java/lang/Object)
  (`` (<| (~~ (template [<class>]
                [(case (ffi.check <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]
                ))
          (~~ (template [<class> <processing>]
                [(case (ffi.check <class> host_object)
                   {#.Some host_object}
                   {#try.Success (<| <processing> host_object)}
                   #.None)]

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

                [gnu/lists/EmptyList (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]
                ))
          (case (ffi.check gnu/lists/Pair host_object)
            {#.Some host_object}
            (read_variant read host_object)
            #.None)
          (case (ffi.check 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.check gnu/mapping/Procedure)))

(def: (expander macro inputs lux)
  Expander
  (case (..ensure_macro macro)
    {#.Some macro}
    (case (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! (: (-> (_.Code Any) (Try Any))
                    (function (_ input)
                      (do try.monad
                        [output (gnu/expr/Language::eval (_.code input) interpreter)]
                        (read output))))]
        (: (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 (\ 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.generate
           #platform.runtime runtime.generate
           #platform.write (|>> _.code (\ 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 name 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
        (:expected handler))])

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

(`` (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)
                                 generation.bundle
                                 extension/bundle.empty
                                 ..program
                                 [_.Var _.Expression _.Expression]
                                 ..extender
                                 service
                                 [(packager.package now)
                                  (format (/cli.target service)
                                          (\ file.default separator)
                                          "program.tar")])]
                  (..declare_success! []))
            (io.io []))))))