(.module:
  [lux (#- Type)
   [abstract
    ["." monad (#+ do)]]
   [control
    ["<>" parser
     ["<s>" synthesis (#+ Parser)]]
    ["ex" exception (#+ exception:)]]
   [data
    ["." product]
    ["." error]
    [number
     ["f" frac]]
    [collection
     ["." list ("#@." monad)]
     ["." dictionary]]]
   [target
    [jvm
     ["_t" type (#+ Type Method)]]]
   [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)
      (#error.Success input')
      (handler extension-name phase input')

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

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

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

(def: lux-intI Inst (|>> _.I2L (_.wrap #_t.Long)))
(def: jvm-intI Inst (|>> (_.unwrap #_t.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))

## 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 #_t.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-class)
       (_.INVOKESTATIC ///.runtime-class "try"
                       (_t.method (list ///.$Function) (#.Some $Object-Array) (list))
                       #0)))

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

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

(template [<name> <op>]
  [(def: (<name> [shiftI inputI])
     (Binary Inst)
     (|>> inputI (_.unwrap #_t.Long)
          shiftI jvm-intI
          <op>
          (_.wrap #_t.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>)))]

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

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

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

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

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

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

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

  [frac::i64 (_.unwrap #_t.Double) (<| (_.wrap #_t.Long) _.D2L)]
  [frac::encode (_.unwrap #_t.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)]
  )

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

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

(def: (text::clip [startI endI subjectI])
  (Trinary Inst)
  (|>> subjectI ..check-stringI
       startI jvm-intI
       endI 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 [startI partI textI])
  (Trinary Inst)
  (<| _.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))))

(def: string-method Method (_t.method (list $String) #.None (list)))
(def: (io::log messageI)
  (Unary Inst)
  (|>> (_.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 Inst)
  (|>> (_.NEW "java.lang.Error")
       _.DUP
       messageI
       ..check-stringI
       (_.INVOKESPECIAL "java.lang.Error" "<init>" string-method #0)
       _.ATHROW))

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

(def: (io::current-time _)
  (Nullary Inst)
  (|>> (_.INVOKESTATIC "java.lang.System" "currentTimeMillis" (_t.method (list) (#.Some _t.long) (list)) #0)
       (_.wrap #_t.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 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 "i64" (unary frac::i64))
          (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::f64)
          (dictionary.merge bundle::text)
          (dictionary.merge bundle::io))))