path: root/stdlib/source/library/lux/meta/target/jvm/reflection.lux

(.require
 [library
  [lux (.except parameter type)
   ["[0]" ffi (.only import)]
   [abstract
    ["[0]" monad (.only do)]]
   [control
    ["[0]" try (.only Try) (.use "[1]#[0]" functor)]
    ["[0]" exception (.only Exception)]]
   [data
    ["[0]" text (.use "[1]#[0]" equivalence)
     ["%" \\format (.only format)]
     ["<t>" \\parser]]
    [collection
     ["[0]" list (.use "[1]#[0]" mix functor)]
     ["[0]" array]
     ["[0]" dictionary]]]
   [math
    [number
     ["n" nat]]]
   [meta
    ["[0]" type]
    [macro
     ["^" pattern]]]]]
 ["[0]" //
  [encoding
   ["[1][0]" name (.only External)]]
  ["/" type (.only)
   [category (.only Void Value Return Method Primitive Object Class Array Parameter)]
   ["[1][0]" lux (.only Mapping)]
   ["[1][0]" descriptor]
   ["[1][0]" reflection]
   ["[1][0]" parser]]])

(import java/lang/String
  "[1]::[0]")

(import java/lang/Object
  "[1]::[0]"
  (toString [] java/lang/String)
  (getClass [] (java/lang/Class java/lang/Object)))

(import java/lang/reflect/Type
  "[1]::[0]"
  (getTypeName [] java/lang/String))

(import java/lang/reflect/GenericArrayType
  "[1]::[0]"
  (getGenericComponentType [] java/lang/reflect/Type))

(import java/lang/reflect/ParameterizedType
  "[1]::[0]"
  (getRawType [] java/lang/reflect/Type)
  (getActualTypeArguments [] [java/lang/reflect/Type]))

(import (java/lang/reflect/TypeVariable d)
  "[1]::[0]"
  (getName [] java/lang/String)
  (getBounds [] [java/lang/reflect/Type]))

(import (java/lang/reflect/WildcardType d)
  "[1]::[0]"
  (getLowerBounds [] [java/lang/reflect/Type])
  (getUpperBounds [] [java/lang/reflect/Type]))

(import java/lang/reflect/Modifier
  "[1]::[0]"
  ("static" isStatic [int] boolean)
  ("static" isFinal [int] boolean)
  ("static" isInterface [int] boolean)
  ("static" isAbstract [int] boolean))

(import java/lang/annotation/Annotation
  "[1]::[0]")

(import java/lang/Deprecated
  "[1]::[0]")

(import java/lang/reflect/Field
  "[1]::[0]"
  (getDeclaringClass [] (java/lang/Class java/lang/Object))
  (getModifiers [] int)
  (getGenericType [] java/lang/reflect/Type)
  (getDeclaredAnnotations [] [java/lang/annotation/Annotation]))

(import java/lang/ClassLoader
  "[1]::[0]")

(import (java/lang/Class c)
  "[1]::[0]"
  ("static" forName [java/lang/String boolean java/lang/ClassLoader] "try" (java/lang/Class java/lang/Object))
  (getName [] java/lang/String)
  (isAssignableFrom [(java/lang/Class java/lang/Object)] boolean)
  (getTypeParameters [] [(java/lang/reflect/TypeVariable (java/lang/Class c))])
  (getDeclaredField [java/lang/String] "try" java/lang/reflect/Field)
  (isArray [] boolean)
  (getComponentType [] (java/lang/Class java/lang/Object)))

(exception.def .public (unknown_class class)
  (Exception External)
  (exception.report
   (list ["Class" (%.text class)])))

(with_template [<name>]
  [(exception.def .public (<name> jvm_type)
     (Exception java/lang/reflect/Type)
     (exception.report
      (list ["Type" (java/lang/reflect/Type::getTypeName jvm_type)]
            ["Class" (|> jvm_type java/lang/Object::getClass java/lang/Object::toString)])))]

  [not_a_class]
  [cannot_convert_to_a_lux_type]
  )

(def .public (load class_loader name)
  (-> java/lang/ClassLoader External (Try (java/lang/Class java/lang/Object)))
  (when (java/lang/Class::forName name false class_loader)
    {try.#Failure _}
    (exception.except ..unknown_class [name])

    success
    success))

(def .public (sub? class_loader super sub)
  (-> java/lang/ClassLoader External External (Try Bit))
  (do try.monad
    [super (..load class_loader super)
     sub (..load class_loader sub)]
    (in (java/lang/Class::isAssignableFrom sub super))))

(def (class' parameter reflection)
  (-> (-> java/lang/reflect/Type (Try (/.Type Parameter)))
      java/lang/reflect/Type
      (Try (/.Type Class)))
  (<| (when (ffi.as java/lang/Class reflection)
        {.#Some class}
        (let [class_name (|> class
                             (as (java/lang/Class java/lang/Object))
                             java/lang/Class::getName)]
          (`` (if (or (,, (with_template [<reflection>]
                            [(text#= (/reflection.reflection <reflection>)
                                     class_name)]

                            [/reflection.boolean]
                            [/reflection.byte]
                            [/reflection.short]
                            [/reflection.int]
                            [/reflection.long]
                            [/reflection.float]
                            [/reflection.double]
                            [/reflection.char]))
                      (text.starts_with? /descriptor.array_prefix class_name))
                (exception.except ..not_a_class [reflection])
                {try.#Success (/.class class_name (list))})))
        _)
      (when (ffi.as java/lang/reflect/ParameterizedType reflection)
        {.#Some reflection}
        (let [raw (java/lang/reflect/ParameterizedType::getRawType reflection)]
          (when (ffi.as java/lang/Class raw)
            {.#Some raw'}
            (let [! try.monad]
              (|> reflection
                  java/lang/reflect/ParameterizedType::getActualTypeArguments
                  (array.list {.#None})
                  (monad.each ! parameter)
                  (of ! each (/.class (|> raw'
                                          (as (java/lang/Class java/lang/Object))
                                          java/lang/Class::getName)))
                  (exception.with ..cannot_convert_to_a_lux_type [reflection])))

            _
            (exception.except ..not_a_class [reflection])))
        _)
      ... else
      (exception.except ..cannot_convert_to_a_lux_type [reflection])))

(def .public (parameter type reflection)
  (-> (-> java/lang/reflect/Type (Try (/.Type Value)))
      (-> java/lang/reflect/Type (Try (/.Type Parameter))))
  (<| (when (ffi.as java/lang/reflect/TypeVariable reflection)
        {.#Some reflection}
        {try.#Success (/.var (java/lang/reflect/TypeVariable::getName reflection))}
        _)
      (when (ffi.as java/lang/reflect/WildcardType reflection)
        {.#Some reflection}
        ... TODO: Instead of having single lower/upper bounds, should
        ... allow for multiple ones.
        (when [(array.item 0 (java/lang/reflect/WildcardType::getLowerBounds reflection))
               (array.item 0 (java/lang/reflect/WildcardType::getUpperBounds reflection))]
          (^.with_template [<pattern> <kind>]
            [<pattern>
             (when (ffi.as java/lang/reflect/GenericArrayType bound)
               {.#Some it}
               ... TODO: Array bounds should not be "erased" as they
               ... are right now.
               {try.#Success /.wildcard}

               _
               (of try.monad each <kind> (parameter type bound)))])
          ([[_ {.#Some bound}] /.upper]
           [[{.#Some bound} _] /.lower])
          
          _
          {try.#Success /.wildcard})
        _)
      (when (ffi.as java/lang/reflect/GenericArrayType reflection)
        {.#Some reflection}
        (|> reflection
            java/lang/reflect/GenericArrayType::getGenericComponentType
            type
            (of try.monad each /.array))
        _)
      (when (ffi.as java/lang/Class reflection)
        {.#Some class}
        (if (java/lang/Class::isArray class)
          (|> class
              java/lang/Class::getComponentType
              type
              (try#each /.array))
          (..class' (parameter type) reflection))
        _)
      (..class' (parameter type) reflection)))

(def .public (type reflection)
  (-> java/lang/reflect/Type (Try (/.Type Value)))
  (<| (when (ffi.as java/lang/Class reflection)
        {.#Some reflection}
        (let [class_name (|> reflection
                             (as (java/lang/Class java/lang/Object))
                             java/lang/Class::getName)]
          (`` (cond (,, (with_template [<reflection> <type>]
                          [(text#= (/reflection.reflection <reflection>)
                                   class_name)
                           {try.#Success <type>}]

                          [/reflection.boolean /.boolean]
                          [/reflection.byte /.byte]
                          [/reflection.short /.short]
                          [/reflection.int /.int]
                          [/reflection.long /.long]
                          [/reflection.float /.float]
                          [/reflection.double /.double]
                          [/reflection.char /.char]))
                    (if (text.starts_with? /descriptor.array_prefix class_name)
                      (<t>.result /parser.value (|> class_name //name.internal //name.read))
                      {try.#Success (/.class class_name (list))}))))
        _)
      ... else
      (..parameter type reflection)))

(def .public class
  (-> java/lang/reflect/Type
      (Try (/.Type Class)))
  (..class' (..parameter ..type)))

(def .public (return reflection)
  (-> java/lang/reflect/Type (Try (/.Type Return)))
  (with_expansions [<else> (these (..type reflection))]
    (when (ffi.as java/lang/Class reflection)
      {.#Some class}
      (let [class_name (|> reflection
                           (as (java/lang/Class java/lang/Object))
                           java/lang/Class::getName)]
        (if (text#= (/reflection.reflection /reflection.void)
                    class_name)
          {try.#Success /.void}
          <else>))

      {.#None}
      <else>)))

(exception.def .public (cannot_correspond [class type])
  (Exception [(java/lang/Class java/lang/Object) Type])
  (exception.report
   (list ["Class" (java/lang/Object::toString class)]
         ["Type" (%.type type)])))

(exception.def .public (type_parameter_mismatch [expected actual class type])
  (Exception [Nat Nat (java/lang/Class java/lang/Object) Type])
  (exception.report
   (list ["Expected" (%.nat expected)]
         ["Actual" (%.nat actual)]
         ["Class" (java/lang/Object::toString class)]
         ["Type" (%.type type)])))

(exception.def .public (non_jvm_type type)
  (Exception Type)
  (exception.report
   (list ["Type" (%.type type)])))

(def .public (correspond class type)
  (-> (java/lang/Class java/lang/Object) Type (Try Mapping))
  (when type
    {.#Nominal array.nominal (list :member:)}
    (if (java/lang/Class::isArray class)
      (correspond (java/lang/Class::getComponentType class)
                  :member:)
      (exception.except ..cannot_correspond [class type]))
    
    {.#Nominal name params}
    (let [class_name (java/lang/Class::getName class)
          class_params (array.list {.#None} (java/lang/Class::getTypeParameters class))
          num_class_params (list.size class_params)
          num_type_params (list.size params)]
      (if (text#= class_name name)
        (if (n.= num_class_params num_type_params)
          (|> params
              (list.zipped_2 (list#each (|>> java/lang/reflect/TypeVariable::getName)
                                        class_params))
              (list#mix (function (_ [name paramT] mapping)
                          (dictionary.has name paramT mapping))
                        /lux.fresh)
              {try.#Success})
          (exception.except ..type_parameter_mismatch [num_class_params num_type_params class type]))
        (exception.except ..cannot_correspond [class type])))

    {.#Named name anonymousT}
    (correspond class anonymousT)

    {.#Apply inputT abstractionT}
    (when (type.applied (list inputT) abstractionT)
      {.#Some outputT}
      (correspond class outputT)

      {.#None}
      (exception.except ..non_jvm_type [type]))

    _
    (exception.except ..non_jvm_type [type])))

(exception.def .public (mistaken_field_owner [field owner target])
  (Exception [java/lang/reflect/Field (java/lang/Class java/lang/Object) (java/lang/Class java/lang/Object)])
  (exception.report
   (list ["Field" (java/lang/Object::toString field)]
         ["Owner" (java/lang/Object::toString owner)]
         ["Target" (java/lang/Object::toString target)])))

(with_template [<name>]
  [(exception.def .public (<name> [field class])
     (Exception [Text (java/lang/Class java/lang/Object)])
     (exception.report
      (list ["Field" (%.text field)]
            ["Class" (java/lang/Object::toString class)])))]

  [unknown_field]
  [not_a_static_field]
  [not_a_virtual_field]
  )

(def .public (field field target)
  (-> Text (java/lang/Class java/lang/Object) (Try java/lang/reflect/Field))
  (when (java/lang/Class::getDeclaredField field target)
    {try.#Success field}
    (let [owner (java/lang/reflect/Field::getDeclaringClass field)]
      (if (same? owner target)
        {try.#Success field}
        (exception.except ..mistaken_field_owner [field owner target])))

    {try.#Failure _}
    (exception.except ..unknown_field [field target])))

(def .public deprecated?
  (-> (array.Array java/lang/annotation/Annotation) Bit)
  (|>> (array.list {.#None})
       (list.all (|>> (ffi.as java/lang/Deprecated)))
       list.empty?
       not))

(with_template [<name> <exception> <then?> <else?>]
  [(def .public (<name> field class)
     (-> Text (java/lang/Class java/lang/Object) (Try [Bit Bit (/.Type Value)]))
     (do [! try.monad]
       [fieldJ (..field field class)
        .let [modifiers (java/lang/reflect/Field::getModifiers fieldJ)]]
       (when (java/lang/reflect/Modifier::isStatic modifiers)
         <then?> (|> fieldJ
                     java/lang/reflect/Field::getGenericType
                     ..type
                     (of ! each (|>> [(java/lang/reflect/Modifier::isFinal modifiers)
                                      (..deprecated? (java/lang/reflect/Field::getDeclaredAnnotations fieldJ))])))
         <else?> (exception.except <exception> [field class]))))]

  [static_field ..not_a_static_field #1 #0]
  [virtual_field ..not_a_virtual_field #0 #1]
  )