path: root/source/lux/host/jvm.lux

##  Copyright (c) Eduardo Julian. All rights reserved.
##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
##  If a copy of the MPL was not distributed with this file,
##  You can obtain one at http://mozilla.org/MPL/2.0/.

(;import lux
         (lux (control (monoid #as m)
                       (functor #as F)
                       (monad #as M #refer (#only do seq%))
                       (enum #as E))
              (data (list #refer #all #open ("" List/Functor List/Fold))
                    (number/int #refer #all #open ("i:" Int/Ord Int/Number))
                    maybe
                    tuple
                    (text #open ("text:" Text/Monoid)))
              (meta lux
                    ast
                    syntax)))

(open List/Monad "list:")

## [Types]
(defsyntax #export (Array [dimensions (?^ nat^)] type)
  (emit (@list (foldL (lambda [inner _] (` (#;DataT "#Array" (@list (~ inner)))))
                      type
                      (repeat (? 1 dimensions) [])))))

## [Utils]
## Types
(deftype StackFrame (^ java.lang.StackTraceElement))
(deftype StackTrace (Array StackFrame))

(deftype Modifier Text)
(deftype JvmType Text)

(deftype AnnotationParam
  (, Text AST))

(deftype Annotation
  (& #ann-name Text
     #ann-params (List AnnotationParam)))

(deftype MemberDecl
  (& #member-name      Text
     #member-modifiers (List Modifier)
     #member-anns      (List Annotation)))

(deftype FieldDecl
  JvmType)

(deftype MethodDecl
  (& #method-inputs (List JvmType)
     #method-output JvmType
     #method-exs    (List JvmType)))

(deftype ArgDecl
  (& #arg-name Text
     #arg-type JvmType))

(deftype MethodDef
  (& #method-vars (List ArgDecl)
     #return-type JvmType
     #return-body AST
     #throws-exs  (List JvmType)))

(deftype ExpectedInput
  (& #opt-input? Bool
     #input-type JvmType))

(deftype ExpectedOutput
  (& #ex-output? Bool
     #opt-output? Bool
     #output-type JvmType))

## Functions
(def (prepare-args args)
  (-> (List ExpectedInput) (Lux (, (List AST) (List AST) (List AST) (List Text))))
  (do Lux/Monad
    [vars (seq% Lux/Monad (repeat (size args) (gensym "")))
     #let [pairings (map (: (-> (, (, Bool Text) AST) (, AST (List AST)))
                            (lambda [[[opt? arg-class] var]]
                              (if opt?
                                [(` (Maybe (^ (~ (symbol$ ["" arg-class])))))
                                 (@list var (` (: (^ (~ (symbol$ ["" arg-class])))
                                                  (case (~ var)
                                                    (#;Some (~ var)) (~ var)
                                                    #;None           ;_jvm_null))))]
                                [(` (^ (~ (symbol$ ["" arg-class]))))
                                 (@list)])))
                         (zip2 args vars))
           var-types (map first pairings)
           var-rebinds (map second pairings)
           arg-classes (map second args)]]
    (wrap [vars var-types (list:join var-rebinds) arg-classes])))

## Parsers
(def annotation-params^
  (Parser (List AnnotationParam))
  (record^ (*^ (tuple^ (&^ local-tag^ id^)))))

(def annotation^
  (Parser Annotation)
  (form^ (&^ local-symbol^
             annotation-params^)))

(def annotations^'
  (Parser (List Annotation))
  (do Parser/Monad
    [_ (tag!^ ["" "ann"])]
    (tuple^ (*^ annotation^))))

(def annotations^
  (Parser (List Annotation))
  (do Parser/Monad
    [anns?? (?^ annotations^')]
    (wrap (? (@list) anns??))))

(def member-decl^
  (Parser MemberDecl)
  (do Parser/Monad
    [modifiers (*^ local-tag^)
     name local-symbol^
     anns annotations^]
    (wrap [name modifiers anns])))

(def throws-decl'^
  (Parser (List JvmType))
  (do Parser/Monad
    [_ (tag!^ ["" "throws"])]
    (tuple^ (*^ local-symbol^))))

(def throws-decl^
  (Parser (List JvmType))
  (do Parser/Monad
    [exs? (?^ throws-decl'^)]
    (wrap (? (@list) exs?))))

(def method-decl'^
  (Parser MethodDecl)
  (do Parser/Monad
    [inputs (tuple^ (*^ local-symbol^))
     outputs local-symbol^
     exs throws-decl^]
    (wrap [inputs outputs exs])))

(def method-decl^
  (Parser (, MemberDecl MethodDecl))
  (form^ (&^ member-decl^
             method-decl'^)))

(def field-decl^
  (Parser (, MemberDecl FieldDecl))
  (form^ (&^ member-decl^
             local-symbol^)))

(def arg-decl^
  (Parser ArgDecl)
  (form^ (&^ local-symbol^ local-symbol^)))

(def method-def'^
  (Parser MethodDef)
  (do Parser/Monad
    [inputs (tuple^ (*^ arg-decl^))
     output local-symbol^
     exs throws-decl^
     body id^]
    (wrap [inputs output body exs])))

(def method-def^
  (Parser (, MemberDecl MethodDef))
  (form^ (&^ member-decl^
             method-def'^)))

(def exp-input^
  (Parser ExpectedInput)
  (&^ (tag?^ ["" "?"])
      local-symbol^))

(def exp-output^
  (Parser ExpectedOutput)
  (do Parser/Monad
    [ex? (tag?^ ["" "!"])
     opt? (tag?^ ["" "?"])
     return local-symbol^]
    (wrap [ex? opt? return])))

## Generators
(def (gen-annotation-param [name value])
  (-> AnnotationParam (, AST AST))
  [(text$ name) value])

(def (gen-annotation [name params])
  (-> Annotation AST)
  (` ((~ (text$ name))
      (~ (record$ (map gen-annotation-param params))))))

(def (gen-method-decl [[name modifiers anns] [inputs output exs]])
  (-> (, MemberDecl MethodDecl) AST)
  (` ((~ (text$ name))
      [(~@ (map text$ modifiers))]
      [(~@ (map gen-annotation anns))]
      [(~@ (map text$ exs))]
      [(~@ (map text$ inputs))]
      (~ (text$ output)))))

(def (gen-field-decl [[name modifiers anns] class])
  (-> (, MemberDecl FieldDecl) AST)
  (` ((~ (text$ name))
      [(~@ (map text$ modifiers))]
      [(~@ (map gen-annotation anns))]
      (~ (text$ class))
      )))

(def (gen-arg-decl [name type])
  (-> ArgDecl AST)
  (form$ (@list (symbol$ ["" name]) (text$ type))))

(def (gen-method-def [[name modifiers anns] [inputs output body exs]])
  (-> (, MemberDecl MethodDef) AST)
  (` ((~ (text$ name))
      [(~@ (map text$ modifiers))]
      [(~@ (map gen-annotation anns))]
      [(~@ (map text$ exs))]
      [(~@ (map gen-arg-decl inputs))]
      (~ (text$ output))
      (~ body))))

(def (gen-expected-output [ex? opt? output] body)
  (-> ExpectedOutput AST (, AST AST))
  (let [type (` (^ (~ (symbol$ ["" output]))))
        [body type] (if opt?
                      [(` (;;??? (~ body)))
                       (` (Maybe (~ type)))]
                      [body type])
        [body type] (if ex?
                      [(` (;;try (~ body)))
                       (` (Either Text (~ type)))]
                      [body type])]
    [body type]))

## [Functions]
(def (stack-trace->text trace)
  (-> StackTrace Text)
  (let [size (_jvm_arraylength trace)
        idxs (E;range Int/Enum 0 (i:+ -1 size))]
    (|> idxs
        (map (: (-> Int Text)
                (lambda [idx]
                  (_jvm_invokevirtual "java.lang.Object" "toString" [] (_jvm_aaload "java.lang.StackTraceElement" trace idx) []))))
        (interpose "\n")
        (foldL text:++ "")
        )))

(def (get-stack-trace t)
  (-> (^ java.lang.Throwable) StackTrace)
  (_jvm_invokevirtual "java.lang.Throwable" "getStackTrace" [] t []))

(def #export (throwable->text t)
  ($ text:++
    (_jvm_invokevirtual "java.lang.Object" "toString" [] t [])
    "\n"
    (|> t get-stack-trace stack-trace->text)))

## [Syntax]
(defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))]
                     [annotations annotations^]
                     [fields (*^ field-decl^)]
                     [methods (*^ method-def^)])
  (emit (@list (` (;_jvm_class (~ (text$ name)) (~ (text$ super))
                               [(~@ (map text$ interfaces))]
                               [(~@ (map gen-annotation annotations))]
                               [(~@ (map gen-field-decl fields))]
                               [(~@ (map gen-method-def methods))])))))

(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))]
                     [annotations annotations^]
                     [members (*^ method-decl^)])
  (emit (@list (` (;_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))]
                                   [(~@ (map gen-annotation annotations))]
                                   (~@ (map gen-method-decl members)))))))

(defsyntax #export (object [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))]
                           [methods (*^ method-def^)])
  (emit (@list (` (;_jvm_anon-class (~ (text$ super))
                                    [(~@ (map text$ interfaces))]
                                    [(~@ (map gen-method-def methods))])))))

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

(defsyntax #export (??? expr)
  (do Lux/Monad
    [g!temp (gensym "")]
    (wrap (@list (` (let [(~ g!temp) (~ expr)]
                      (if (;_jvm_null? (~ g!temp))
                        #;None
                        (#;Some (~ g!temp)))))))))

(defsyntax #export (try expr)
  (emit (@list (` (;_jvm_try (#;Right (~ expr))
                             (~ (' (_jvm_catch "java.lang.Exception" e
                                               (#;Left (throwable->text e))))))))))

(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 "")
     g!_ (gensym "")]
    (emit (@list (` (let [(~ g!lock) (~ lock)
                          (~ g!_) (;_jvm_monitorenter (~ g!lock))
                          (~ g!body) (~ body)
                          (~ g!_) (;_jvm_monitorexit (~ g!lock))]
                      (~ g!body)))))
    ))

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

(defsyntax #export (new$ [class local-symbol^] [args (tuple^ (*^ exp-input^))] [ex? (tag?^ ["" "!"])])
  (do Lux/Monad
    [[vars var-types var-rebinds arg-classes] (prepare-args args)
     #let [new-expr (` (;_jvm_new (~ (text$ class)) [(~@ (map text$ arg-classes))] [(~@ vars)]))
           new-expr (if ex?
                      (` (try (~ new-expr)))
                      new-expr)]]
    (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class]))))
                       (lambda [[(~@ vars)]]
                         (let [(~@ var-rebinds)]
                           (~ new-expr)))))))))

(do-template [<name> <op>]
  [(defsyntax #export (<name> [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ exp-input^))]
                              [expected-output exp-output^])
     (do Lux/Monad
       [[vars var-types var-rebinds arg-classes] (prepare-args args)
        g!self (gensym "self")
        #let [[body return-type] (gen-expected-output expected-output
                                                      (` (<op> (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] (~ g!self) [(~@ vars)])))]]
       (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class]))) (~ return-type))
                          (lambda [[(~@ vars)] (~ g!self)]
                            (let [(~@ var-rebinds)]
                              (~ body)))))))
       ))]

  [invoke-virtual$   ;_jvm_invokevirtual]
  [invoke-interface$ ;_jvm_invokeinterface]
  )

(defsyntax #export (invoke-static$ [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ exp-input^))]
                                   [expected-output exp-output^])
  (do Lux/Monad
    [[vars var-types var-rebinds arg-classes] (prepare-args args)
     #let [[body return-type] (gen-expected-output expected-output
                                                   (` (;_jvm_invokestatic (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] [(~@ vars)])))]]
    (wrap (@list (` (: (-> (, (~@ var-types)) (~ return-type))
                       (lambda [[(~@ vars)]]
                         (let [(~@ var-rebinds)]
                           (~ body)))))))
    ))