##   Copyright (c) Eduardo Julian. All rights reserved.
##   The use and distribution terms for this software are covered by the
##   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
##   which can be found in the file epl-v10.html at the root of this distribution.
##   By using this software in any fashion, you are agreeing to be bound by
##   the terms of this license.
##   You must not remove this notice, or any other, from this software.

(;import lux
         (lux (control (monoid #as m)
                       (functor #as F)
                       (monad #as M #refer (#only do)))
              (data (list #as l #refer #all #open ("" List/Functor))
                    (text #as text)
                    (number (int #open ("i" Int/Eq))))
              (meta lux
                    macro
                    syntax)))

## [Utils]
## Parsers
(def finally^
  (Parser Syntax)
  (form^ (do Parser/Monad
           [_ (symbol?^ ["" "finally"])
            expr id^]
           (M;wrap expr))))

(def catch^
  (Parser (, Text Ident Syntax))
  (form^ (do Parser/Monad
           [_ (symbol?^ ["" "catch"])
            ex-class local-symbol^
            ex symbol^
            expr id^]
           (M;wrap [ex-class ex expr]))))

(def method-decl^
  (Parser (, (List Text) Text (List Text) Text))
  (form^ (do Parser/Monad
           [modifiers (*^ local-tag^)
            name local-symbol^
            inputs (tuple^ (*^ local-symbol^))
            output local-symbol^]
           (M;wrap [modifiers name inputs output]))))

(def field-decl^
  (Parser (, (List Text) Text Text))
  (form^ (do Parser/Monad
           [modifiers (*^ local-tag^)
            name local-symbol^
            class local-symbol^]
           (M;wrap [modifiers name class]))))

(def arg-decl^
  (Parser (, Text Text))
  (form^ (do Parser/Monad
           [arg-name local-symbol^
            arg-class local-symbol^]
           (M;wrap [arg-name arg-class]))))

(def method-def^
  (Parser (, (List Text) Text (List (, Text Text)) Text Syntax))
  (form^ (do Parser/Monad
           [modifiers (*^ local-tag^)
            name local-symbol^
            inputs (tuple^ (*^ arg-decl^))
            output local-symbol^
            body id^]
           (M;wrap [modifiers name inputs output body]))))

(def method-call^
  (Parser (, Text (List Text) (List Syntax)))
  (form^ (do Parser/Monad
           [method local-symbol^
            arity-classes (tuple^ (*^ local-symbol^))
            arity-args (tuple^ (*^ id^))
            _ (: (Parser (,))
                 (if (i= (size arity-classes)
                         (size arity-args))
                   (M;wrap [])
                   (lambda [_] #;None)))]
           (M;wrap [method arity-classes arity-args])
           )))

## [Syntax]
(defsyntax #export (throw ex)
  (emit (list (` (_jvm_throw (~ ex))))))

(defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)])
  (emit (list (` (_jvm_try (~ body)
                           (~@ (:: List/Monoid (m;++ (map (: (-> (, Text Ident Syntax) Syntax)
                                                             (lambda [catch]
                                                               (let [[class ex body] catch]
                                                                 (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body))))))
                                                          catches)
                                                     (case finally
                                                       #;None
                                                       (list)

                                                       (#;Some finally)
                                                       (list (` (_jvm_finally (~ finally)))))))))))))

(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)])
  (let [members' (map (: (-> (, (List Text) Text (List Text) Text) Syntax)
                         (lambda [member]
                           (let [[modifiers name inputs output] member]
                             (` ((~ (text$ name)) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))])))))
                      members)]
    (emit (list (` (_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))]
                     (~@ members')))))))

(defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))]
                     [fields (*^ field-decl^)]
                     [methods (*^ method-def^)])
  (do Lux/Monad
    [current-module get-module-name
     #let [fields' (map (: (-> (, (List Text) Text Text) Syntax)
                           (lambda [field]
                             (let [[modifiers name class] field]
                               (` ((~ (text$ name))
                                   (~ (text$ class))
                                   [(~@ (map text$ modifiers))])))))
                        fields)
           methods' (map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax)
                            (lambda [methods]
                              (let [[modifiers name inputs output body] methods]
                                (` ((~ (text$ name))
                                    [(~@ (map (: (-> (, Text Text) Syntax)
                                                 (lambda [in]
                                                   (let [[left right] in]
                                                     (form$ (list (symbol$ ["" left])
                                                                  (text$ right))))))
                                              inputs))]
                                    (~ (text$ output))
                                    [(~@ (map text$ modifiers))]
                                    (~ body))))))
                         methods)]]
    (emit (list (` (_jvm_class (~ (text$ name)) (~ (text$ super))
                     [(~@ (map text$ interfaces))]
                     [(~@ fields')]
                     [(~@ methods')]))))))

(defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))])
  (emit (list (` (_jvm_new (~ (text$ class))
                           [(~@ (map text$ arg-classes))]
                           [(~@ args)])))))

(defsyntax #export (instance? [class local-symbol^] obj)
  (emit (list (` (_jvm_instanceof (~ (text$ class)) (~ obj))))))

(defsyntax #export (locking lock body)
  (do Lux/Monad
    [g!lock (gensym "")
     g!body (gensym "")]
    (emit (list (` (;let [(~ g!lock) (~ lock)
                          _ (_jvm_monitorenter (~ g!lock))
                          (~ g!body) (~ body)
                          _ (_jvm_monitorexit (~ g!lock))]
                         (~ g!body)))))
    ))

(defsyntax #export (null? obj)
  (emit (list (` (_jvm_null? (~ obj))))))

(defsyntax #export (program [args symbol^] body)
  (emit (list (` (_jvm_program (~ (symbol$ args))
                   (~ body))))))

(defsyntax #export (.? [field local-symbol^] obj)
  (case obj
    (#;Meta [_ (#;SymbolS obj-name)])
    (do Lux/Monad
      [obj-type (find-var-type obj-name)]
      (case obj-type
        (#;DataT class)
        (emit (list (` (_jvm_getfield (~ (text$ class)) (~ (text$ field))))))

        _
        (fail "Can only get field from object.")))

    _
    (do Lux/Monad
      [g!obj (gensym "")]
      (emit (list (` (;let [(~ g!obj) (~ obj)]
                           (.? (~ (text$ field)) (~ g!obj)))))))))

(defsyntax #export (.= [field local-symbol^] value obj)
  (case obj
    (#;Meta [_ (#;SymbolS obj-name)])
    (do Lux/Monad
      [obj-type (find-var-type obj-name)]
      (case obj-type
        (#;DataT class)
        (emit (list (` (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ value)))))

        _
        (fail "Can only set field of object.")))

    _
    (do Lux/Monad
      [g!obj (gensym "")]
      (emit (list (` (;let [(~ g!obj) (~ obj)]
                           (.= (~ (text$ field)) (~ value) (~ g!obj)))))))))

(defsyntax #export (.! [call method-call^] obj)
  (let [[m-name ?m-classes m-args] call]
    (case obj
      (#;Meta [_ (#;SymbolS obj-name)])
      (do Lux/Monad
        [obj-type (find-var-type obj-name)]
        (case obj-type
          (#;DataT class)
          (emit (list (` (_jvm_invokevirtual (~ (text$ class)) (~ (text$ m-name)) [(~@ (map text$ ?m-classes))]
                                             (~ obj) [(~@ m-args)]))))

          _
          (fail "Can only call method on object.")))

      _
      (do Lux/Monad
        [g!obj (gensym "")]
        (emit (list (` (;let [(~ g!obj) (~ obj)]
                             (.! ((~ (symbol$ ["" m-name]))
                                  [(~@ (map (lambda [c] (symbol$ ["" c])) ?m-classes))]
                                  [(~@ m-args)])
                                 (~ g!obj))))))))))

(defsyntax #export (..? [field local-symbol^] [class local-symbol^])
  (emit (list (` (_jvm_getstatic (~ (text$ class)) (~ (text$ field)))))))

(defsyntax #export (..= [field local-symbol^] value [class local-symbol^])
  (emit (list (` (_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value))))))

(defsyntax #export (..! [call method-call^] [class local-symbol^])
  (let [[m-name m-classes m-args] call]
    (emit (list (` (_jvm_invokestatic (~ (text$ class)) (~ (text$ m-name))
                                      [(~@ (map text$ m-classes))]
                                      [(~@ m-args)]))))))

(defsyntax #export (->maybe expr)
  (do Lux/Monad
    [g!val (gensym "")]
    (emit (list (` (;let [(~ g!val) (~ expr)]
                         (;if (null? (~ g!val))
                              #;None
                              (#;Some (~ g!val)))))))))

(defsyntax #export (try$ expr)
  (emit (list (` (try (#;Right (~ expr))
                   (~ (' (catch java.lang.Exception e
                           (#;Left (.! (getMessage [] []) e))))))))))