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

(.module:
  [lux #*
   [control
    ["." monad (#+ do)]
    ["p" parser]
    ["ex" exception (#+ exception:)]]
   [data
    ["." text
     format]
    [collection
     ["." list ("#/." functor)]
     ["." dictionary]]]
   ["." macro (#+ with-gensyms)
    ["." code]
    ["s" syntax (#+ syntax:)]]
   [tool
    [compiler
     ["." synthesis (#+ Synthesis)]
     ["." phase
      ["." extension
       ["." bundle]]]]]
   [host (#+ import:)]]
  [luxc
   [lang
    [host
     ["$" jvm (#+ Label Inst Method Handler Bundle)
      ["_t" type]
      ["_" inst]]]]]
  ["." ///
   ["." runtime]])

(import: java/lang/Double
  (#static MIN_VALUE Double)
  (#static MAX_VALUE Double))

## [Types]
(syntax: (Vector {size s.nat} elemT)
  (wrap (list (` [(~+ (list.repeat size elemT))]))))

(type: #export Nullary (-> (Vector 0 Inst) Inst))
(type: #export Unary   (-> (Vector 1 Inst) Inst))
(type: #export Binary  (-> (Vector 2 Inst) Inst))
(type: #export Trinary (-> (Vector 3 Inst) Inst))
(type: #export Variadic (-> (List Inst) Inst))

## [Utils]
(def: $Object-Array $.Type (_t.array 1 ///.$Object))
(def: $String $.Type (_t.class "java.lang.String" (list)))
(def: $CharSequence $.Type (_t.class "java.lang.CharSequence" (list)))

(syntax: (arity: {name s.local-identifier} {arity s.nat})
  (with-gensyms [g!_ g!extension g!extension-name g!phase g!inputs]
    (do @
      [g!inputC+ (monad.seq @ (list.repeat arity (macro.gensym "input")))
       #let [arityC (code.nat arity)]]
      (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension))
                       (-> (-> (..Vector (~ arityC) Inst) Inst) ..Handler)
                       (function ((~ g!_) (~ g!extension-name) (~ g!phase) (~ g!inputs))
                         (case (~ g!inputs)
                           (^ (list (~+ g!inputC+)))
                           (do phase.monad
                             [(~+ (|> g!inputC+
                                      (list/map (function (_ g!input)
                                                  (list g!input (` ((~ g!phase) (~ g!input))))))
                                      list.concat))]
                             ((~' wrap) ((~ g!extension) [(~+ g!inputC+)])))

                           (~ g!_)
                           (phase.fail (ex.construct extension.incorrect-arity
                                                     [(~ g!extension-name) (~ arityC) (list.size (~ g!inputs))])))))))))))

(arity: nullary 0)
(arity: unary 1)
(arity: binary 2)
(arity: trinary 3)

(def: #export (variadic extension)
  (-> Variadic Handler)
  (function (_ extension-name phase inputsS)
    (do phase.monad
      [inputsH (monad.map @ phase inputsS)]
      (wrap (extension inputsH)))))

## [Instructions]
(def: lux-intI Inst (|>> _.I2L (_.wrap #$.Long)))
(def: jvm-intI Inst (|>> (_.unwrap #$.Long) _.L2I))
(def: check-stringI Inst (_.CHECKCAST "java.lang.String"))

(def: (predicateI tester)
  (-> (-> Label Inst)
      Inst)
  (<| _.with-label (function (_ @then))
      _.with-label (function (_ @end))
      (|>> (tester @then)
           (_.GETSTATIC "java.lang.Boolean" "FALSE" (_t.class "java.lang.Boolean" (list)))
           (_.GOTO @end)
           (_.label @then)
           (_.GETSTATIC "java.lang.Boolean" "TRUE" (_t.class "java.lang.Boolean" (list)))
           (_.label @end)
           )))

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

## Extensions
### Lux
(def: (lux::is [leftI rightI])
  Binary
  (|>> leftI
       rightI
       (predicateI _.IF_ACMPEQ)))

(def: (lux::try riskyI)
  Unary
  (|>> riskyI
       (_.CHECKCAST ///.function-class)
       (_.INVOKESTATIC ///.runtime-class "try"
                       (_t.method (list ///.$Function) (#.Some $Object-Array) (list))
                       #0)))

### Bits
(do-template [<name> <op>]
  [(def: (<name> [maskI inputI])
     Binary
     (|>> inputI (_.unwrap #$.Long)
          maskI (_.unwrap #$.Long)
          <op> (_.wrap #$.Long)))]

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

(do-template [<name> <op>]
  [(def: (<name> [shiftI inputI])
     Binary
     (|>> inputI (_.unwrap #$.Long)
          shiftI jvm-intI
          <op>
          (_.wrap #$.Long)))]

  [bit::left-shift             _.LSHL]
  [bit::arithmetic-right-shift _.LSHR]
  [bit::logical-right-shift    _.LUSHR]
  )

### Numbers
(do-template [<name> <const> <type>]
  [(def: (<name> _)
     Nullary
     (|>> <const> (_.wrap <type>)))]

  [frac::smallest (_.double (Double::MIN_VALUE))            #$.Double]
  [frac::min      (_.double (f/* -1.0 (Double::MAX_VALUE))) #$.Double]
  [frac::max      (_.double (Double::MAX_VALUE))            #$.Double]
  )

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

  [i64::+  #$.Long   _.LADD]
  [i64::-  #$.Long   _.LSUB]
  [int::*  #$.Long   _.LMUL]
  [int::/  #$.Long   _.LDIV]
  [int::%  #$.Long   _.LREM]
  
  [frac::+ #$.Double _.DADD]
  [frac::- #$.Double _.DSUB]
  [frac::* #$.Double _.DMUL]
  [frac::/ #$.Double _.DDIV]
  [frac::% #$.Double _.DREM]
  )

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

  [i64::= int::< (_.unwrap #$.Long)   _.LCMP]
  [frac::= frac::< (_.unwrap #$.Double) _.DCMPG]
  )

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

  [int::frac (_.unwrap #$.Long) (<| (_.wrap #$.Double) _.L2D)]
  [int::char (_.unwrap #$.Long)
   ((|>> _.L2I _.I2C (_.INVOKESTATIC "java.lang.Character" "toString" (_t.method (list _t.char) (#.Some $String) (list)) #0)))]

  [frac::int (_.unwrap #$.Double) (<| (_.wrap #$.Long) _.D2L)]
  [frac::encode (_.unwrap #$.Double)
   (_.INVOKESTATIC "java.lang.Double" "toString" (_t.method (list _t.double) (#.Some $String) (list)) #0)]
  [frac::decode ..check-stringI
   (_.INVOKESTATIC ///.runtime-class "decode_frac" (_t.method (list $String) (#.Some $Object-Array) (list)) #0)]
  )

### Text
(def: (text::size inputI)
  Unary
  (|>> inputI
       ..check-stringI
       (_.INVOKEVIRTUAL "java.lang.String" "length" (_t.method (list) (#.Some _t.int) (list)) #0)
       lux-intI))

(do-template [<name> <pre-subject> <pre-param> <op> <post>]
  [(def: (<name> [subjectI paramI])
     Binary
     (|>> subjectI <pre-subject>
          paramI <pre-param>
          <op> <post>))]

  [text::= (<|) (<|)
   (_.INVOKEVIRTUAL "java.lang.Object" "equals" (_t.method (list ///.$Object) (#.Some _t.boolean) (list)) #0)
   (_.wrap #$.Boolean)]
  [text::< ..check-stringI ..check-stringI
   (_.INVOKEVIRTUAL "java.lang.String" "compareTo" (_t.method (list $String) (#.Some _t.int) (list)) #0)
   (predicateI _.IFLT)]
  [text::concat ..check-stringI ..check-stringI
   (_.INVOKEVIRTUAL "java.lang.String" "concat" (_t.method (list $String) (#.Some $String) (list)) #0)
   (<|)]
  [text::char ..check-stringI jvm-intI
   (_.INVOKEVIRTUAL "java.lang.String" "charAt" (_t.method (list _t.int) (#.Some _t.char) (list)) #0)
   lux-intI]
  )

(do-template [<name> <pre-subject> <pre-param> <pre-extra> <op>]
  [(def: (<name> [subjectI paramI extraI])
     Trinary
     (|>> subjectI <pre-subject>
          paramI <pre-param>
          extraI <pre-extra>
          <op>))]

  [text::clip ..check-stringI jvm-intI jvm-intI
   (_.INVOKEVIRTUAL "java.lang.String" "substring" (_t.method (list _t.int _t.int) (#.Some $String) (list)) #0)]
  )

(def: index-method Method (_t.method (list $String _t.int) (#.Some _t.int) (list)))
(def: (text::index [textI partI startI])
  Trinary
  (<| _.with-label (function (_ @not-found))
      _.with-label (function (_ @end))
      (|>> textI ..check-stringI
           partI ..check-stringI
           startI jvm-intI
           (_.INVOKEVIRTUAL "java.lang.String" "indexOf" index-method #0)
           _.DUP
           (_.int -1)
           (_.IF_ICMPEQ @not-found)
           lux-intI
           runtime.someI
           (_.GOTO @end)
           (_.label @not-found)
           _.POP
           runtime.noneI
           (_.label @end))))

### I/O
(def: string-method Method (_t.method (list $String) #.None (list)))
(def: (io::log messageI)
  Unary
  (|>> (_.GETSTATIC "java.lang.System" "out" (_t.class "java.io.PrintStream" (list)))
       messageI
       ..check-stringI
       (_.INVOKEVIRTUAL "java.io.PrintStream" "println" string-method #0)
       unitI))

(def: (io::error messageI)
  Unary
  (|>> (_.NEW "java.lang.Error")
       _.DUP
       messageI
       ..check-stringI
       (_.INVOKESPECIAL "java.lang.Error" "<init>" string-method #0)
       _.ATHROW))

(def: (io::exit codeI)
  Unary
  (|>> codeI jvm-intI
       (_.INVOKESTATIC "java.lang.System" "exit" (_t.method (list _t.int) #.None (list)) #0)
       _.NULL))

(def: (io::current-time _)
  Nullary
  (|>> (_.INVOKESTATIC "java.lang.System" "currentTimeMillis" (_t.method (list) (#.Some _t.long) (list)) #0)
       (_.wrap #$.Long)))

## Bundles
(def: bundle::lux
  Bundle
  (|> (: Bundle bundle.empty)
      (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 bit::and))
          (bundle.install "or" (binary bit::or))
          (bundle.install "xor" (binary bit::xor))
          (bundle.install "left-shift" (binary bit::left-shift))
          (bundle.install "logical-right-shift" (binary bit::logical-right-shift))
          (bundle.install "arithmetic-right-shift" (binary bit::arithmetic-right-shift))
          (bundle.install "+" (binary i64::+))
          (bundle.install "-" (binary i64::-))
          (bundle.install "=" (binary i64::=)))))

(def: bundle::int
  Bundle
  (<| (bundle.prefix "int")
      (|> (: Bundle bundle.empty)
          (bundle.install "*" (binary int::*))
          (bundle.install "/" (binary int::/))
          (bundle.install "%" (binary int::%))
          (bundle.install "<" (binary int::<))
          (bundle.install "frac" (unary int::frac))
          (bundle.install "char" (unary int::char)))))

(def: bundle::frac
  Bundle
  (<| (bundle.prefix "frac")
      (|> (: Bundle bundle.empty)
          (bundle.install "+" (binary frac::+))
          (bundle.install "-" (binary frac::-))
          (bundle.install "*" (binary frac::*))
          (bundle.install "/" (binary frac::/))
          (bundle.install "%" (binary frac::%))
          (bundle.install "=" (binary frac::=))
          (bundle.install "<" (binary frac::<))
          (bundle.install "smallest" (nullary frac::smallest))
          (bundle.install "min" (nullary frac::min))
          (bundle.install "max" (nullary frac::max))
          (bundle.install "int" (unary frac::int))
          (bundle.install "encode" (unary frac::encode))
          (bundle.install "decode" (unary frac::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))
          (bundle.install "exit" (unary io::exit))
          (bundle.install "current-time" (nullary io::current-time)))))

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