path: root/stdlib/source/library/lux/ffi.lux

(.require
 [library
  [lux (.except Symbol Alias Global global function type_of undefined)
   ["[0]" meta]
   [abstract
    ["[0]" monad (.only do)]]
   [control
    ["<>" parser (.use "[1]#[0]" monad)]
    ["[0]" io]
    ["[0]" maybe (.use "[1]#[0]" functor)]
    ["[0]" try]]
   [data
    ["[0]" product]
    ["[0]" text (.use "[1]#[0]" equivalence)
     ["%" \\format]]
    [collection
     ["[0]" list (.use "[1]#[0]" monad mix)]]]
   ["[0]" macro (.only with_symbols)
    [syntax (.only syntax)]
    ["[0]" template]]
   [meta
    [type
     [primitive (.except)]]
    ["[0]" code (.only)
     ["<[1]>" \\parser (.only Parser)]]]
   ["@" target (.only)
    ["[0]" js]]]])

(with_expansions [<constant> (for @.js "js constant"
                                  @.python "python constant"
                                  @.lua "lua constant"
                                  @.ruby "ruby constant")
                  <apply> (for @.js "js apply"
                               @.python "python apply"
                               @.lua "lua apply"
                               @.ruby "ruby apply")
                  <new> (for @.js "js object new"
                             @.python "python apply"
                             (these))
                  <do> (for @.js "js object do"
                            @.python "python object do"
                            @.lua "lua object do"
                            @.ruby "ruby object do")
                  <get> (for @.js "js object get"
                             @.python "python object get"
                             @.lua "lua object get"
                             @.ruby "ruby object get"
                             (these))
                  <import> (for @.python "python import"
                                @.lua "lua import"
                                @.ruby "ruby import"
                                (these))
                  <function> (for @.js "js function"
                                  @.python "python function"
                                  @.lua "lua function"
                                  (these))]
  (primitive .public (Object brand) Any)

  (with_expansions [<un_common> (for @.js (these [Symbol]
                                                 [Null]
                                                 [Undefined])
                                     @.python (these [None]
                                                     [Dict])
                                     @.lua (these [Nil]
                                                  [Table])
                                     @.ruby (these [Nil]))
                    <un_common> <un_common>]
    (with_template [<name>]
      [(with_expansions [<brand> (template.symbol [<name> "'"])]
         (primitive <brand>
           Any
           
           (type .public <name>
             (Object <brand>))))]

      [Function]
      <un_common>
      ))

  (with_expansions [<un_common> (for @.js (these [Number  Frac])
                                     @.python (these [Integer Int]
                                                     [Float   Frac])
                                     @.lua (these [Integer Int]
                                                  [Float   Frac])
                                     @.ruby (these [Integer Int]
                                                   [Float   Frac]))
                    <un_common> <un_common>]
    (with_template [<name> <type>]
      [(type .public <name>
         <type>)]

      [Boolean Bit]
      [String  Text]
      <un_common>
      ))

  (type Alias
    (Maybe Text))

  (def alias
    (Parser Alias)
    (<>.maybe (<>.after (<code>.this (' "as")) <code>.local)))

  (type Optional
    (Record
     [#optional? Bit
      #mandatory Code]))

  (def optional
    (Parser Optional)
    (let [token "?"]
      (<| (<>.and (<>.parses? (<code>.this_text token)))
          (<>.after (<>.not (<code>.this_text token)))
          <code>.any)))

  (type (Named a)
    (Record
     [#name Text
      #alias Alias
      #anonymous a]))

  (with_template [<case> <name>]
    [(def <case>
       (All (_ a) (-> (Parser a) (Parser (Named a))))
       (|>> (all <>.and
                 <name>
                 ..alias
                 )))]

    [named <code>.local]
    [anonymous (<>#in "")]
    )

  (type Output
    Optional)

  (def output
    (Parser Output)
    ..optional)

  (type Global
    (Named Output))

  (def variables
    (Parser (List Text))
    (<>.else (list) (<code>.tuple (<>.some <code>.local))))

  (def (generalized $ it)
    (All (_ a)
      (-> (-> (List Text) a a)
          (-> (Parser a) (Parser a))))
    (do <>.monad
      [variables ..variables
       it it]
      (in ($ variables it))))

  (type Input
    (Record
     [#variables (List Text)
      #parameters (List Optional)
      #io? Bit
      #try? Bit]))

  (def input
    (Parser Input)
    (all <>.and
         (<>#in (list))
         (<code>.tuple (<>.some ..optional))
         (<>.parses? (<code>.this_text "io"))
         (<>.parses? (<code>.this_text "try"))))

  (type Constructor
    (Named Input))

  (def constructor
    (Parser Constructor)
    (<| <code>.form
        (..generalized (has [#anonymous #variables]))
        (<>.after (<code>.this (' new)))
        (..anonymous ..input)))

  (type (Member a)
    (Record
     [#static? Bit
      #member a]))

  (def static!
    (Parser Any)
    (<code>.this_text "static"))

  (def (member it)
    (All (_ a)
      (-> (Parser a)
          (Parser (Member a))))
    (do [! <>.monad]
      [static? (<>.parses? ..static!)]
      (at ! each
          (|>> [#static? static?
                #member])
          it)))

  (type Field
    (Member (Named Output)))

  (def field
    (Parser Field)
    (<| <code>.form
        ..member
        ..named
        ..output))

  (type Procedure
    (Record
     [#input Input
      #output Optional]))

  (def procedure
    (Parser (Named Procedure))
    (<| (..generalized (has [#anonymous #input #variables]))
        ..named
        (all <>.and
             ..input
             ..optional
             )))

  (type Method
    (Member (Named Procedure)))

  (def method
    (Parser Method)
    (<| <code>.form
        ..member
        ..procedure))

  (`` (`` (type Sub
            (Variant
             (,, (for @.lua (,, (these))
                      @.ruby (,, (these))
                      {#Constructor Constructor}))
             {#Field Field}
             {#Method Method}))))

  (`` (`` (def sub
            (Parser Sub)
            (all <>.or
                 (,, (for @.lua (,, (these))
                          @.ruby (,, (these))
                          ..constructor))
                 ..field
                 ..method
                 ))))

  (def parameters
    (-> (List Optional) (List Optional))
    (|>> list.enumeration
         (list#each (.function (_ [idx [optional? type]])
                      [#optional? optional?
                       #mandatory (|> idx %.nat code.local)]))))

  (def (output_type it)
    (-> Optional Code)
    (if (the #optional? it)
      (` (.Maybe (, (the #mandatory it))))
      (the #mandatory it)))

  (`` (with_template [<lux_it> <host_it>
                      <lux_?> <host_?>]
        [(def .public (<lux_it> _)
           (-> Any Nothing)
           (as_expected (<host_it>)))

         (def .public <lux_?>
           (-> Any Bit)
           (|>> <host_?>))

         (template.with_locals [g!it]
           (these (def g!it' (' g!it))
                  (def (host_optional it)
                    (-> Optional Code)
                    (.if (.the #optional? it)
                      (` (.case (, (the #mandatory it))
                           {.#Some (, g!it')}
                           (, g!it')

                           {.#None}
                           (<host_it>)))
                      (the #mandatory it)))

                  (def (lux_optional it output)
                    (-> Optional Code Code)
                    (` (.let [(, g!it') (, output)]
                         (, (if (the #optional? it)
                              (` (.if (<host_?> (, g!it'))
                                   {.#None}
                                   {.#Some (, g!it')}))
                              (` (.if (.not (<host_?> (, g!it')))
                                   (, g!it')
                                   (.panic! "Invalid output."))))))))))]

        (,, (for @.js [null "js object null"
                       null? "js object null?"]
                 @.python [none "python object none"
                           none? "python object none?"]
                 @.lua [nil "lua object nil"
                        nil? "lua object nil?"]
                 @.ruby [nil "ruby object nil"
                         nil? "ruby object nil?"]))
        ))

  (type Declaration
    [Text (List Text)])

  (type Namespace
    Text)

  (type Class
    (Record
     [#declaration Declaration
      #class_alias Alias
      #namespace Namespace
      #members (List Sub)]))

  (def class
    (Parser Class)
    (all <>.and
         (<>.either (<>.and <code>.local
                            (<>#in (list)))
                    (<code>.form (<>.and <code>.local
                                         (<>.some <code>.local))))
         ..alias
         <code>.text
         (<>.some ..sub)))

  (type Import
    (Variant
     {#Class Class}
     {#Procedure (Named Procedure)}
     {#Global Global}))

  (def importP
    (Parser Import)
    (all <>.or
         ..class
         (<code>.form ..procedure)
         (<code>.form (..named ..output))))

  (def (input_type input :it:)
    (-> Input Code Code)
    (let [:it: (if (the #try? input)
                 (` (.Either .Text (, :it:)))
                 :it:)]
      (if (the #io? input)
        (` ((,! io.IO) (, :it:)))
        :it:)))

  (def (input_term input term)
    (-> Input Code Code)
    (let [term (if (the #try? input)
                 (` (.try (, term)))
                 term)]
      (if (the #io? input)
        (` ((,! io.io) (, term)))
        term)))

  (def (procedure_definition import! source it)
    (-> (List Code) Code (Named Procedure) Code)
    (let [g!it (|> (the #alias it)
                   (maybe.else (the #name it))
                   code.local)
          g!variables (list#each code.local (the [#anonymous #input #variables] it))
          input (the [#anonymous #input] it)
          :parameters: (the #parameters input)
          g!parameters (..parameters :parameters:)
          :output: (the [#anonymous #output] it)
          :input:/* (case :parameters:
                      {.#End}
                      (list (` []))
                      
                      parameters
                      (list#each ..output_type :parameters:))]
      (` (.def ((, g!it) (,* (case g!parameters
                               {.#End} (list g!it)
                               _ (list#each (the #mandatory) g!parameters))))
           (.All ((, g!it) (,* g!variables))
             (-> (,* :input:/*)
                 (, (|> :output:
                        ..output_type
                        (..input_type input)))))
           (.exec
             (,* import!)
             (.as_expected
              (, (<| (..input_term input)
                     (..lux_optional :output:)
                     (` (<apply> (.as_expected (, source))
                                 [(,* (list#each ..host_optional g!parameters))]))))))))))

  (def (namespaced namespace class alias member)
    (-> Namespace Text Alias Text Text)
    (|> namespace
        (text.replaced "[1]" (maybe.else class alias))
        (text.replaced "[0]" member)))

  (def class_separator ".")

  (def host_path
    (text.replaced .module_separator ..class_separator))

  (for @.js (these)
       (def (imported class)
         (-> Text Code)
         (case (text.all_split_by .module_separator class)
           {.#Item head tail}
           (list#mix (.function (_ sub super)
                       (` (<get> (, (code.text sub))
                                 (.as (..Object .Any)
                                      (, super)))))
                     (` (<import> (, (code.text head))))
                     tail)
           
           {.#End}
           (` (<import> (, (code.text class)))))))

  (def (global_definition import! it)
    (-> (List Code) Global Code)
    (let [g!name (|> (the #alias it)
                     (maybe.else (the #name it))
                     code.local)
          :output: (the #anonymous it)]
      (` (.def (, g!name)
           (, (..output_type :output:))
           (.exec
             (,* import!)
             (.as_expected
              (, (<| (lux_optional :output:)
                     (` (<constant> (, (code.text (..host_path (the #name it))))))))))))))
  
  (for @.lua (these)
       @.ruby (these)
       (def (constructor_definition [class_name class_parameters] alias namespace it)
         (-> Declaration Alias Namespace Constructor Code)
         (let [g!it (|> it
                        (the #alias)
                        (maybe.else "new")
                        (..namespaced namespace class_name alias)
                        code.local)
               input (the #anonymous it)
               g!input_variables (list#each code.local (the #variables input))
               :parameters: (the #parameters input)
               g!parameters (..parameters :parameters:)
               g!class_variables (list#each code.local class_parameters)
               g!class (` ((, (code.local (maybe.else class_name alias))) (,* g!class_variables)))
               :output: [#optional? false #mandatory g!class]]
           (` (.def ((, g!it) (,* (case g!parameters
                                    {.#End} (list g!it)
                                    _ (list#each (the #mandatory) g!parameters))))
                (.All ((, g!it) (,* g!class_variables) (,* g!input_variables))
                  (.-> (,* (list#each ..output_type :parameters:))
                       (, (|> :output:
                              ..output_type
                              (..input_type input)))))
                (.as_expected
                 (, (<| (..input_term input)
                        (..lux_optional :output:)
                        (` (<new> (, (for @.js (` (<constant> (, (code.text (..host_path class_name)))))
                                          @.python (` (.as ..Function
                                                           (, (..imported class_name))))))
                                  [(,* (list#each ..host_optional g!parameters))]))))))))))

  (def (static_field_definition import! [class_name class_parameters] alias namespace it)
    (-> (List Code) Declaration Alias Namespace (Named Output) Code)
    (let [field (the #name it)
          g!it (|> (the #alias it)
                   (maybe.else field)
                   (..namespaced namespace class_name alias)
                   code.local)
          :field: (the #anonymous it)]
      (` (def (, g!it)
           ((,! syntax) ((, g!it) [])
            (.at (,! meta.monad) (,' in)
                 (.list (`' (.exec
                              (,* import!)
                              (.as (, (..output_type :field:))
                                   (, (<| (lux_optional :field:)
                                          (for @.js (` (<constant> (, (code.text (%.format (..host_path class_name) "." field)))))
                                               @.ruby (` (<constant> (, (code.text (%.format (..host_path class_name) "::" field)))))
                                               (` (<get> (, (code.text field))
                                                         (, (..imported class_name)))))))))))))))))

  (def (virtual_field_definition [class_name class_parameters] alias namespace it)
    (-> Declaration Alias Namespace (Named Output) Code)
    (let [name (the #name it)
          g!it (|> (the #alias it)
                   (maybe.else name)
                   (..namespaced namespace class_name alias)
                   code.local)
          path (%.format (..host_path class_name) "." name)
          :field: (the #anonymous it)
          g!variables (list#each code.local class_parameters)
          g!class (` ((, (code.local (maybe.else class_name alias))) (,* g!variables)))]
      (` (.def ((, g!it) (, g!it))
           (.All ((, g!it) (,* g!variables))
             (.-> (, g!class)
                  (, (..output_type :field:))))
           (.as_expected
            (, (<| (lux_optional :field:)
                   (` (<get> (, (code.text name)) (, g!it))))))))))

  (def (field_definition import! class alias namespace it)
    (-> (List Code) Declaration Alias Namespace Field Code)
    (if (the #static? it)
      (..static_field_definition import! class alias namespace (the #member it))
      (..virtual_field_definition class alias namespace (the #member it))))

  (def (static_method_definition import! [class_name class_parameters] alias namespace it)
    (-> (List Code) Declaration Alias Namespace (Named Procedure) Code)
    (let [method (the #name it)
          name (|> (the #alias it)
                   (maybe.else (the #name it))
                   (..namespaced namespace class_name alias))]
      (|> it
          (has #alias {.#Some name})
          (..procedure_definition import!
                                  (for @.js (` (<constant> (, (code.text (%.format (..host_path class_name) "." method)))))
                                       @.ruby (` (<constant> (, (code.text (%.format (..host_path class_name) "::" method)))))
                                       (` (<get> (, (code.text method))
                                                 (.as (..Object .Any)
                                                      (, (..imported class_name))))))))))

  (def (virtual_method_definition [class_name class_parameters] alias namespace it)
    (-> Declaration Alias Namespace (Named Procedure) Code)
    (let [method (the #name it)
          g!it (|> (the #alias it)
                   (maybe.else method)
                   (..namespaced namespace class_name alias)
                   code.local)
          procedure (the #anonymous it)
          input (the #input procedure)
          g!input_variables (list#each code.local (the #variables input))
          :parameters: (the #parameters input)
          g!parameters (..parameters :parameters:)
          g!class_variables (list#each code.local class_parameters)
          g!class (` ((, (code.local (maybe.else class_name alias))) (,* g!class_variables)))
          :output: (the #output procedure)]
      (` (.def ((, g!it) (,* (list#each (the #mandatory) g!parameters)) (, g!it))
           (.All ((, g!it) (,* g!class_variables) (,* g!input_variables))
             (.-> (,* (list#each ..output_type :parameters:))
                  (, g!class)
                  (, (|> :output:
                         ..output_type
                         (..input_type input)))))
           (.as_expected
            (, (<| (..input_term input)
                   (..lux_optional :output:)
                   (` (<do> (, (code.text method))
                            (, g!it)
                            [(,* (list#each ..host_optional g!parameters))])))))))))

  (def (method_definition import! class alias namespace it)
    (-> (List Code) Declaration Alias Namespace Method Code)
    (if (the #static? it)
      (static_method_definition import! class alias namespace (the #member it))
      (virtual_method_definition class alias namespace (the #member it))))

  (def .public import
    (syntax (_ [host_module (<>.maybe <code>.text)
                it ..importP])
      (let [host_module_import! (is (List Code)
                                    (case host_module
                                      {.#Some host_module}
                                      (list (` (<import> (, (code.text host_module)))))

                                      {.#None}
                                      (list)))]
        (case it
          {#Global it}
          (in (list (..global_definition host_module_import! it)))

          {#Procedure it}
          (in (list (..procedure_definition host_module_import!
                                            (` (<constant> (, (code.text (..host_path (the #name it))))))
                                            it)))

          {#Class it}
          (let [class (the #declaration it)
                alias (the #class_alias it)
                [class_name class_parameters] class
                namespace (the #namespace it)
                g!class_variables (list#each code.local class_parameters)
                declaration (` ((, (code.local (maybe.else class_name alias)))
                                (,* g!class_variables)))]
            (in (list.partial (` (.type (, declaration)
                                   (..Object (.Primitive (, (code.text (..host_path class_name)))
                                                         [(,* g!class_variables)]))))
                              (list#each (.function (_ member)
                                           (`` (`` (case member
                                                     (,, (for @.lua (,, (these))
                                                              @.ruby (,, (these))
                                                              (,, (these {#Constructor it}
                                                                         (..constructor_definition class alias namespace it)))))
                                                     
                                                     {#Field it}
                                                     (..field_definition host_module_import! class alias namespace it)
                                                     
                                                     {#Method it}
                                                     (..method_definition host_module_import! class alias namespace it)))))
                                         (the #members it)))))
          ))))

  (for @.ruby (these)
       (def .public function
         (syntax (_ [[self inputs] (<code>.form
                                    (all <>.and
                                         <code>.local
                                         (<code>.tuple (<>.some (<>.and <code>.any <code>.any)))))
                     type <code>.any
                     term <code>.any])
           (in (list (` (.<| (.as ..Function)
                             (<function> (, (code.nat (list.size inputs))))
                             (.as (.-> [(,* (list.repeated (list.size inputs) (` .Any)))]
                                       .Any))
                             (.is (.-> [(,* (list#each product.right inputs))]
                                       (, type)))
                             (.function ((, (code.local self)) [(,* (list#each product.left inputs))])
                               (, term)))))))))

  (for @.js (these (def .public type_of
                     (template (type_of object)
                       [("js type-of" object)]))

                   (def .public global
                     (syntax (_ [type <code>.any
                                 [head tail] (<code>.tuple (<>.and <code>.local (<>.some <code>.local)))])
                       (with_symbols [g!_]
                         (let [global (` ("js constant" (, (code.text head))))]
                           (case tail
                             {.#End}
                             (in (list (` (is (.Maybe (, type))
                                              (case (..type_of (, global))
                                                "undefined"
                                                {.#None}

                                                (, g!_)
                                                {.#Some (as (, type) (, global))})))))
                             
                             {.#Item [next tail]}
                             (let [separator "."]
                               (in (list (` (is (.Maybe (, type))
                                                (case (..type_of (, global))
                                                  "undefined"
                                                  {.#None}

                                                  (, g!_)
                                                  (..global (, type) [(, (code.local (%.format head "." next)))
                                                                      (,* (list#each code.local tail))]))))))))))))

                   (def !defined?
                     (template (_ <global>)
                       [(.case (..global Any <global>)
                          {.#None}
                          .false

                          {.#Some _}
                          .true)]))

                   (with_template [<name> <global>]
                     [(def .public <name>
                        Bit
                        (!defined? <global>))]

                     [on_browser? [window]]
                     [on_nashorn? [java lang Object]]
                     )

                   (def .public on_node_js?
                     Bit
                     (|> (..global (Object Any) [process])
                         (maybe#each (|>> []
                                          ("js apply" ("js constant" "Object.prototype.toString.call"))
                                          (as Text)
                                          (text#= "[object process]")))
                         (maybe.else false)))

                   ... These extensions must be defined this way because importing any of the modules
                   ... normally used when writing extensions would introduce a circular dependency
                   ... because the Archive type depends on Binary, and that module depends on this ffi module.
                   (def extension_name
                     (syntax (_ [])
                       (do meta.monad
                         [module meta.current_module_name
                          unique_id meta.seed]
                         (in (list (code.text (%.format module " " (%.nat unique_id))))))))

                   (with_expansions [<undefined> (..extension_name)
                                     <undefined?> (..extension_name)
                                     <object> (..extension_name)]
                     (these (def extension_analysis
                              (template (_ <name> <parameter>)
                                [{5 #1 [<name> <parameter>]}]))

                            (def text_analysis
                              (template (_ <it>)
                                [{0 #0 {5 #1 <it>}}]))

                            (def analysis
                              (template (_ <name> <bindings> <parser> <inputs> <body>)
                                [("lux def analysis" <name>
                                  (.function (_ name phase archive inputs)
                                    (.function (_ state)
                                      (let [<bindings> [name phase archive state]]
                                        (case (<code>.result <parser> inputs)
                                          {try.#Failure error}
                                          {try.#Failure (%.format "Invalid inputs for extension: " (%.text name)
                                                                  text.\n error)}

                                          {try.#Success <inputs>}
                                          <body>)))))]))

                            (def generation
                              (template (_ <name> <bindings> <inputs> <body>)
                                [("lux def generation" <name>
                                  (.function (_ name phase archive inputs)
                                    (.function (_ state)
                                      (let [<bindings> [name phase archive state]]
                                        (case inputs
                                          (pattern <inputs>)
                                          <body>

                                          _
                                          {try.#Failure (%.format "Invalid inputs for extension: " (%.text name))})))))]))

                            (analysis <undefined>
                              [name phase archive state]
                              <code>.end
                              _
                              {try.#Success [state (extension_analysis name (list))]})

                            (generation <undefined>
                              [name phase archive state]
                              (list)
                              {try.#Success [state js.undefined]})

                            (def .public undefined
                              (template (undefined)
                                [(.is ..Undefined (<undefined>))]))

                            (analysis <undefined?>
                              [name phase archive state]
                              <code>.any
                              it
                              (do try.monad
                                [[state it] (phase archive (` (.is .Any (, it))) state)]
                                (in [state (extension_analysis name (list it))])))

                            (generation <undefined?>
                              [name phase archive state]
                              (list it)
                              (do try.monad
                                [[state it] (phase archive it state)]
                                (in [state (js.= js.undefined it)])))

                            (def .public undefined?
                              (template (undefined? <it>)
                                [(.as .Bit (.is .Any (<undefined?> <it>)))]))

                            (analysis <object>
                              [name phase archive state]
                              (<>.some (<>.and <code>.text <code>.any))
                              it
                              (do [! try.monad]
                                [[state output] (monad.mix ! (.function (_ [key value] [state output])
                                                               (do !
                                                                 [[state value] (phase archive (` (.is .Any (, value))) state)]
                                                                 (in [state (list.partial value (text_analysis key) output)])))
                                                           [state (list)]
                                                           it)]
                                (in [state (extension_analysis name (list.reversed output))])))

                            (def text_synthesis
                              (template (_ <it>)
                                [{0 #0 {2 #1 <it>}}]))

                            (def (pairs it)
                              (All (_ a) (-> (List a) (List [a a])))
                              (case it
                                (pattern (list.partial left right tail))
                                (list.partial [left right] (pairs tail))
                                
                                (pattern (list))
                                (list)

                                _
                                (.undefined)))

                            (generation <object>
                              [name phase archive state]
                              (list.partial head_key head_value tail)
                              (do [! try.monad]
                                [[state output] (monad.mix !
                                                           (.function (_ [key value] [state output])
                                                             (case key
                                                               (pattern (text_synthesis key))
                                                               (do try.monad
                                                                 [[state value] (phase archive value state)]
                                                                 (in [state (list.partial [key value] output)]))
                                                               
                                                               _
                                                               (.undefined)))
                                                           [state (list)]
                                                           (pairs (list.partial head_key head_value tail)))]
                                (in [state (js.object (list.reversed output))])))

                            (def .public object
                              (syntax (_ [it (<>.some <code>.any)])
                                (in (list (` (.as (..Object .Any)
                                                  (<object> (,* it))))))))
                            )))
       (these))
  )