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

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

      (#try.Failure error)
      (phase.throw extension.invalid-syntax [extension-name %synthesis input]))))

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

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

(def: lux-intI Inst (|>> _.I2L (_.wrap descriptor.long)))
(def: jvm-intI Inst (|>> (_.unwrap descriptor.long) _.L2I))
(def: check-stringI Inst (_.CHECKCAST $String))

(def: (predicateI tester)
  (-> (-> Label Inst)
      Inst)
  (let [$Boolean (descriptor.class "java.lang.Boolean")]
    (<| _.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 [input else conditionals])
               (<| _.with-label (function (_ @end))
                   _.with-label (function (_ @else))
                   (do phase.monad
                     [inputG (phase input)
                      elseG (phase else)
                      conditionalsG+ (: (Operation (List [(List [Int Label])
                                                          Inst]))
                                        (monad.map @ (function (_ [chars branch])
                                                       (do @
                                                         [branchG (phase 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 descriptor.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.$Runtime "try"
                       (descriptor.method [(list ///.$Function) ///.$Variant])
                       #0)))

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

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

(template [<name> <op>]
  [(def: (<name> [shiftI inputI])
     (Binary Inst)
     (|>> inputI (_.unwrap descriptor.long)
          shiftI jvm-intI
          <op>
          (_.wrap descriptor.long)))]

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

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

  [f64::smallest (_.double (Double::MIN_VALUE))            descriptor.double]
  [f64::min      (_.double (f.* -1.0 (Double::MAX_VALUE))) descriptor.double]
  [f64::max      (_.double (Double::MAX_VALUE))            descriptor.double]
  )

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

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

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

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

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

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

  [f64::i64 (_.unwrap descriptor.double) (<| (_.wrap descriptor.long) _.D2L)]
  [f64::encode (_.unwrap descriptor.double)
   (_.INVOKESTATIC (descriptor.class "java.lang.Double") "toString" (descriptor.method [(list descriptor.double) $String]) #0)]
  [f64::decode ..check-stringI
   (_.INVOKESTATIC runtime.$Runtime "decode_frac" (descriptor.method [(list $String) ///.$Variant]) #0)]
  )

(def: (text::size inputI)
  (Unary Inst)
  (|>> inputI
       ..check-stringI
       (_.INVOKEVIRTUAL $String "length" (descriptor.method [(list) descriptor.int]) #0)
       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" (descriptor.method [(list $Object) descriptor.boolean]) #0)
   (_.wrap descriptor.boolean)]
  [text::< ..check-stringI ..check-stringI
   (_.INVOKEVIRTUAL $String "compareTo" (descriptor.method [(list $String) descriptor.int]) #0)
   (predicateI _.IFLT)]
  [text::char ..check-stringI jvm-intI
   (_.INVOKEVIRTUAL $String "charAt" (descriptor.method [(list descriptor.int) descriptor.char]) #0)
   lux-intI]
  )

(def: (text::concat [leftI rightI])
  (Binary Inst)
  (|>> leftI ..check-stringI
       rightI ..check-stringI
       (_.INVOKEVIRTUAL $String "concat" (descriptor.method [(list $String) $String]) #0)))

(def: (text::clip [startI endI subjectI])
  (Trinary Inst)
  (|>> subjectI ..check-stringI
       startI jvm-intI
       endI jvm-intI
       (_.INVOKEVIRTUAL $String "substring" (descriptor.method [(list descriptor.int descriptor.int) $String]) #0)))

(def: index-method (descriptor.method [(list $String descriptor.int) descriptor.int]))
(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 #0)
           _.DUP
           (_.int -1)
           (_.IF_ICMPEQ @not-found)
           lux-intI
           runtime.someI
           (_.GOTO @end)
           (_.label @not-found)
           _.POP
           runtime.noneI
           (_.label @end))))

(def: string-method (descriptor.method [(list $String) descriptor.void]))
(def: (io::log messageI)
  (Unary Inst)
  (let [$PrintStream (descriptor.class "java.io.PrintStream")]
    (|>> (_.GETSTATIC $System "out" $PrintStream)
         messageI
         ..check-stringI
         (_.INVOKEVIRTUAL $PrintStream "println" string-method #0)
         unitI)))

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

(def: (io::exit codeI)
  (Unary Inst)
  (|>> codeI jvm-intI
       (_.INVOKESTATIC $System "exit" (descriptor.method [(list descriptor.int) descriptor.void]) #0)
       _.NULL))

(def: (io::current-time _)
  (Nullary Inst)
  (|>> (_.INVOKESTATIC $System "currentTimeMillis" (descriptor.method [(list) descriptor.long]) #0)
       (_.wrap descriptor.long)))

(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 "logical-right-shift" (binary i64::logical-right-shift))
          (bundle.install "arithmetic-right-shift" (binary i64::arithmetic-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))
          (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::f64)
          (dictionary.merge bundle::text)
          (dictionary.merge bundle::io))))