path: root/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux

(.module:
  [lux (#- Type)
   [ffi (#+ import:)]
   [abstract
    ["." monad (#+ do)]]
   [control
    ["." try]
    ["<>" parser
     ["<s>" synthesis (#+ Parser)]]]
   [data
    ["." product]
    [collection
     ["." list ("#@." monad)]
     ["." dictionary]]]
   [math
    [number
     ["f" frac]]]
   [target
    [jvm
     ["." type]]]
   [tool
    [compiler
     ["." phase]
     [meta
      [archive (#+ Archive)]]
     [language
      [lux
       ["." synthesis (#+ Synthesis %synthesis)]
       [phase
        [generation
         [extension (#+ Nullary Unary Binary Trinary Variadic
                        nullary unary binary trinary variadic)]]
        ["." extension
         ["." bundle]]]]]]]]
  [luxc
   [lang
    [host
     ["$" jvm (#+ Label Inst Def Handler Bundle Operation Phase)
      ["_" inst]]]]]
  ["." ///
   ["." runtime]])

(def: #export (custom [parser handler])
  (All [s]
    (-> [(Parser s)
         (-> Text Phase Archive s (Operation Inst))]
        Handler))
  (function (_ extension_name phase archive input)
    (case (<s>.run parser input)
      (#try.Success input')
      (handler extension_name phase archive input')

      (#try.Failure error)
      (phase.throw extension.invalid_syntax [extension_name %synthesis input]))))

(import: java/lang/Double
  ["#::."
   (#static MIN_VALUE java/lang/Double)
   (#static MAX_VALUE java/lang/Double)])

(def: $String (type.class "java.lang.String" (list)))
(def: $CharSequence (type.class "java.lang.CharSequence" (list)))
(def: $System (type.class "java.lang.System" (list)))
(def: $Object (type.class "java.lang.Object" (list)))

(def: lux_intI Inst (|>> _.I2L (_.wrap type.long)))
(def: jvm_intI Inst (|>> (_.unwrap type.long) _.L2I))
(def: check_stringI Inst (_.CHECKCAST $String))

(def: (predicateI tester)
  (-> (-> Label Inst)
      Inst)
  (let [$Boolean (type.class "java.lang.Boolean" (list))]
    (<| _.with_label (function (_ @then))
        _.with_label (function (_ @end))
        (|>> (tester @then)
             (_.GETSTATIC $Boolean "FALSE" $Boolean)
             (_.GOTO @end)
             (_.label @then)
             (_.GETSTATIC $Boolean "TRUE" $Boolean)
             (_.label @end)
             ))))

(def: unitI Inst (_.string synthesis.unit))

## TODO: Get rid of this ASAP
(def: lux::syntax_char_case!
  (..custom [($_ <>.and
                 <s>.any
                 <s>.any
                 (<>.some (<s>.tuple ($_ <>.and
                                         (<s>.tuple (<>.many <s>.i64))
                                         <s>.any))))
             (function (_ extension_name phase archive [input else conditionals])
               (<| _.with_label (function (_ @end))
                   _.with_label (function (_ @else))
                   (do {@ phase.monad}
                     [inputG (phase archive input)
                      elseG (phase archive else)
                      conditionalsG+ (: (Operation (List [(List [Int Label])
                                                          Inst]))
                                        (monad.map @ (function (_ [chars branch])
                                                       (do @
                                                         [branchG (phase archive branch)]
                                                         (wrap (<| _.with_label (function (_ @branch))
                                                                   [(list@map (function (_ char)
                                                                                [(.int char) @branch])
                                                                              chars)
                                                                    (|>> (_.label @branch)
                                                                         branchG
                                                                         (_.GOTO @end))]))))
                                                   conditionals))
                      #let [table (|> conditionalsG+
                                      (list@map product.left)
                                      list@join)
                            conditionalsG (|> conditionalsG+
                                              (list@map product.right)
                                              _.fuse)]]
                     (wrap (|>> inputG (_.unwrap type.long) _.L2I
                                (_.LOOKUPSWITCH @else table)
                                conditionalsG
                                (_.label @else)
                                elseG
                                (_.label @end)
                                )))))]))

(def: (lux::is [referenceI sampleI])
  (Binary Inst)
  (|>> referenceI
       sampleI
       (predicateI _.IF_ACMPEQ)))

(def: (lux::try riskyI)
  (Unary Inst)
  (|>> riskyI
       (_.CHECKCAST ///.$Function)
       (_.INVOKESTATIC ///.$Runtime "try" runtime.try)))

(template [<name> <op>]
  [(def: (<name> [maskI inputI])
     (Binary Inst)
     (|>> inputI (_.unwrap type.long)
          maskI (_.unwrap type.long)
          <op> (_.wrap type.long)))]

  [i64::and _.LAND]
  [i64::or  _.LOR]
  [i64::xor _.LXOR]
  )

(template [<name> <op>]
  [(def: (<name> [shiftI inputI])
     (Binary Inst)
     (|>> inputI (_.unwrap type.long)
          shiftI jvm_intI
          <op>
          (_.wrap type.long)))]

  [i64::left_shift  _.LSHL]
  [i64::right_shift _.LUSHR]
  )

(template [<name> <const> <type>]
  [(def: (<name> _)
     (Nullary Inst)
     (|>> <const> (_.wrap <type>)))]

  [f64::smallest (_.double (java/lang/Double::MIN_VALUE))            type.double]
  [f64::min      (_.double (f.* -1.0 (java/lang/Double::MAX_VALUE))) type.double]
  [f64::max      (_.double (java/lang/Double::MAX_VALUE))            type.double]
  )

(template [<name> <type> <op>]
  [(def: (<name> [paramI subjectI])
     (Binary Inst)
     (|>> subjectI (_.unwrap <type>)
          paramI (_.unwrap <type>)
          <op>
          (_.wrap <type>)))]

  [i64::+ type.long   _.LADD]
  [i64::- type.long   _.LSUB]
  [i64::* type.long   _.LMUL]
  [i64::/ type.long   _.LDIV]
  [i64::% type.long   _.LREM]
  
  [f64::+ type.double _.DADD]
  [f64::- type.double _.DSUB]
  [f64::* type.double _.DMUL]
  [f64::/ type.double _.DDIV]
  [f64::% type.double _.DREM]
  )

(template [<eq> <lt> <type> <cmp>]
  [(template [<name> <reference>]
     [(def: (<name> [paramI subjectI])
        (Binary Inst)
        (|>> subjectI (_.unwrap <type>)
             paramI (_.unwrap <type>)
             <cmp>
             (_.int <reference>)
             (predicateI _.IF_ICMPEQ)))]
     
     [<eq> +0]
     [<lt> -1])]

  [i64::= i64::< type.long   _.LCMP]
  [f64::= f64::< type.double _.DCMPG]
  )

(template [<name> <prepare> <transform>]
  [(def: (<name> inputI)
     (Unary Inst)
     (|>> inputI <prepare> <transform>))]

  [i64::f64 (_.unwrap type.long) (<| (_.wrap type.double) _.L2D)]
  [i64::char (_.unwrap type.long)
   ((|>> _.L2I _.I2C (_.INVOKESTATIC (type.class "java.lang.Character" (list)) "toString" (type.method [(list type.char) $String (list)]))))]

  [f64::i64 (_.unwrap type.double) (<| (_.wrap type.long) _.D2L)]
  [f64::encode (_.unwrap type.double)
   (_.INVOKESTATIC (type.class "java.lang.Double" (list)) "toString" (type.method [(list type.double) $String (list)]))]
  [f64::decode ..check_stringI
   (_.INVOKESTATIC ///.$Runtime "decode_frac" (type.method [(list $String) ///.$Variant (list)]))]
  )

(def: (text::size inputI)
  (Unary Inst)
  (|>> inputI
       ..check_stringI
       (_.INVOKEVIRTUAL $String "length" (type.method [(list) type.int (list)]))
       lux_intI))

(template [<name> <pre_subject> <pre_param> <op> <post>]
  [(def: (<name> [paramI subjectI])
     (Binary Inst)
     (|>> subjectI <pre_subject>
          paramI <pre_param>
          <op> <post>))]

  [text::= (<|) (<|)
   (_.INVOKEVIRTUAL $Object "equals" (type.method [(list $Object) type.boolean (list)]))
   (_.wrap type.boolean)]
  [text::< ..check_stringI ..check_stringI
   (_.INVOKEVIRTUAL $String "compareTo" (type.method [(list $String) type.int (list)]))
   (predicateI _.IFLT)]
  [text::char ..check_stringI jvm_intI
   (_.INVOKEVIRTUAL $String "charAt" (type.method [(list type.int) type.char (list)]))
   lux_intI]
  )

(def: (text::concat [leftI rightI])
  (Binary Inst)
  (|>> leftI ..check_stringI
       rightI ..check_stringI
       (_.INVOKEVIRTUAL $String "concat" (type.method [(list $String) $String (list)]))))

(def: (text::clip [offsetI lengthI subjectI])
  (Trinary Inst)
  (|>> subjectI ..check_stringI
       offsetI jvm_intI
       _.DUP
       lengthI jvm_intI
       _.IADD
       (_.INVOKEVIRTUAL $String "substring" (type.method [(list type.int type.int) $String (list)]))))

(def: index_method (type.method [(list $String type.int) type.int (list)]))
(def: (text::index [startI partI textI])
  (Trinary Inst)
  (<| _.with_label (function (_ @not_found))
      _.with_label (function (_ @end))
      (|>> textI ..check_stringI
           partI ..check_stringI
           startI jvm_intI
           (_.INVOKEVIRTUAL $String "indexOf" index_method)
           _.DUP
           (_.int -1)
           (_.IF_ICMPEQ @not_found)
           lux_intI
           runtime.someI
           (_.GOTO @end)
           (_.label @not_found)
           _.POP
           runtime.noneI
           (_.label @end))))

(def: string_method (type.method [(list $String) type.void (list)]))
(def: (io::log messageI)
  (Unary Inst)
  (let [$PrintStream (type.class "java.io.PrintStream" (list))]
    (|>> (_.GETSTATIC $System "out" $PrintStream)
         messageI
         ..check_stringI
         (_.INVOKEVIRTUAL $PrintStream "println" string_method)
         unitI)))

(def: (io::error messageI)
  (Unary Inst)
  (let [$Error (type.class "java.lang.Error" (list))]
    (|>> (_.NEW $Error)
         _.DUP
         messageI
         ..check_stringI
         (_.INVOKESPECIAL $Error "<init>" string_method)
         _.ATHROW)))

(def: bundle::lux
  Bundle
  (|> (: Bundle bundle.empty)
      (bundle.install "syntax char case!" lux::syntax_char_case!)
      (bundle.install "is" (binary lux::is))
      (bundle.install "try" (unary lux::try))))

(def: bundle::i64
  Bundle
  (<| (bundle.prefix "i64")
      (|> (: Bundle bundle.empty)
          (bundle.install "and" (binary i64::and))
          (bundle.install "or" (binary i64::or))
          (bundle.install "xor" (binary i64::xor))
          (bundle.install "left-shift" (binary i64::left_shift))
          (bundle.install "right-shift" (binary i64::right_shift))
          (bundle.install "=" (binary i64::=))
          (bundle.install "<" (binary i64::<))
          (bundle.install "+" (binary i64::+))
          (bundle.install "-" (binary i64::-))
          (bundle.install "*" (binary i64::*))
          (bundle.install "/" (binary i64::/))
          (bundle.install "%" (binary i64::%))
          (bundle.install "f64" (unary i64::f64))
          (bundle.install "char" (unary i64::char)))))

(def: bundle::f64
  Bundle
  (<| (bundle.prefix "f64")
      (|> (: Bundle bundle.empty)
          (bundle.install "+" (binary f64::+))
          (bundle.install "-" (binary f64::-))
          (bundle.install "*" (binary f64::*))
          (bundle.install "/" (binary f64::/))
          (bundle.install "%" (binary f64::%))
          (bundle.install "=" (binary f64::=))
          (bundle.install "<" (binary f64::<))
          (bundle.install "smallest" (nullary f64::smallest))
          (bundle.install "min" (nullary f64::min))
          (bundle.install "max" (nullary f64::max))
          (bundle.install "i64" (unary f64::i64))
          (bundle.install "encode" (unary f64::encode))
          (bundle.install "decode" (unary f64::decode)))))

(def: bundle::text
  Bundle
  (<| (bundle.prefix "text")
      (|> (: Bundle bundle.empty)
          (bundle.install "=" (binary text::=))
          (bundle.install "<" (binary text::<))
          (bundle.install "concat" (binary text::concat))
          (bundle.install "index" (trinary text::index))
          (bundle.install "size" (unary text::size))
          (bundle.install "char" (binary text::char))
          (bundle.install "clip" (trinary text::clip)))))

(def: bundle::io
  Bundle
  (<| (bundle.prefix "io")
      (|> (: Bundle bundle.empty)
          (bundle.install "log" (unary io::log))
          (bundle.install "error" (unary io::error)))))

(def: #export bundle
  Bundle
  (<| (bundle.prefix "lux")
      (|> bundle::lux
          (dictionary.merge bundle::i64)
          (dictionary.merge bundle::f64)
          (dictionary.merge bundle::text)
          (dictionary.merge bundle::io))))