path: root/stdlib/source/lux/target/jvm/type.lux

(.module:
  [lux (#- Type int char)
   [abstract
    [equivalence (#+ Equivalence)]]
   [control
    ["." function]
    ["<>" parser
     ["<t>" text (#+ Parser)]]]
   [data
    ["." product]
    ["." maybe ("#@." functor)]
    ["." text ("#@." equivalence)
     ["%" format (#+ format)]]
    [collection
     ["." list ("#@." functor)]]]]
  ["." // #_
   [encoding
    ["#." name]]])

(template [<descriptor> <definition>]
  [(def: #export <definition> <descriptor>)]

  ["V" void-descriptor]
  ["Z" boolean-descriptor]
  ["B" byte-descriptor]
  ["S" short-descriptor]
  ["I" int-descriptor]
  ["J" long-descriptor]
  ["F" float-descriptor]
  ["D" double-descriptor]
  ["C" char-descriptor]
  )

(def: #export array-prefix "[")
(def: object-prefix "L")
(def: var-prefix "T")
(def: wildcard-signature "*")
(def: lower-prefix "-")
(def: upper-prefix "+")
(def: object-suffix ";")
(def: #export object-class "java.lang.Object")

(def: valid-var-characters/head
  (format "abcdefghijklmnopqrstuvwxyz"
          "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
          "_"))

(def: valid-var-characters/tail
  (format valid-var-characters/head
          "0123456789"))

(def: valid-class-characters/head
  (format valid-var-characters/head //name.internal-separator))

(def: valid-class-characters/tail
  (format valid-var-characters/tail //name.internal-separator))

(type: #export Bound
  #Lower
  #Upper)

## TODO: Replace with polytypism.
(structure: #export bound-equivalence
  (Equivalence Bound)
  (def: (= parameter subject)
    (case [parameter subject]
      (^template [<tag>]
        [<tag> <tag>]
        true)
      ([#Lower]
       [#Upper])

      _
      false)))

(type: #export Primitive
  #Boolean
  #Byte
  #Short
  #Int
  #Long
  #Float
  #Double
  #Char)

## TODO: Replace with polytypism.
(structure: #export primitive-equivalence
  (Equivalence Primitive)
  (def: (= parameter subject)
    (case [parameter subject]
      (^template [<tag>]
        [<tag> <tag>]
        true)
      ([#Boolean]
       [#Byte]
       [#Short]
       [#Int]
       [#Long]
       [#Float]
       [#Double]
       [#Char])

      _
      false)))

(type: #export Var Text)

(with-expansions [<Class> (as-is [Text (List Generic)])]
  (type: #export #rec Generic
    (#Var Var)
    (#Wildcard (Maybe [Bound Generic]))
    (#Class <Class>))

  (type: #export Class
    <Class>)
  )

(structure: #export generic-equivalence
  (Equivalence Generic)
  (def: (= parameter subject)
    (case [parameter subject]
      [(#Var parameter) (#Var subject)]
      (text@= parameter subject)

      [(#Wildcard parameter) (#Wildcard subject)]
      (:: (maybe.equivalence (product.equivalence bound-equivalence =))
          = parameter subject)

      [(#Class [nameP paramsP]) (#Class [nameS paramsS])]
      (and (text@= nameP nameS)
           (:: (list.equivalence =) = paramsP paramsS))

      _
      false)))

(type: #export Parameter
  [Text Class (List Class)])

(type: #export #rec Type
  (#Primitive Primitive)
  (#Generic Generic)
  (#Array Type))

(structure: #export type-equivalence
  (Equivalence Type)
  (def: (= parameter subject)
    (case [parameter subject]
      [(#Primitive parameter) (#Primitive subject)]
      (:: ..primitive-equivalence = parameter subject)

      [(#Generic parameter) (#Generic subject)]
      (:: ..generic-equivalence = parameter subject)

      [(#Array parameter) (#Array subject)]
      (= parameter subject)

      _
      false)))

(type: #export Argument
  [Text Type])

(type: #export Return
  (Maybe Type))

(def: #export return-equivalence
  (Equivalence Return)
  (maybe.equivalence ..type-equivalence))

(type: #export Method
  {#args (List Type)
   #return Return
   #exceptions (List Generic)})

(structure: #export method-equivalence
  (Equivalence Method)
  (def: (= [argsP returnP exceptionsP] [argsS returnS exceptionsS])
    (and (:: (list.equivalence ..type-equivalence) = argsP argsS)
         (:: ..return-equivalence = returnP returnS)
         (:: (list.equivalence ..generic-equivalence) = exceptionsP exceptionsS))))

(type: #export (Typed a)
  [Type a])

(template [<name> <primitive>]
  [(def: #export <name> Type (#Primitive <primitive>))]

  [boolean #Boolean]
  [byte    #Byte]
  [short   #Short]
  [int     #Int]
  [long    #Long]
  [float   #Float]
  [double  #Double]
  [char    #Char]
  )

(template: #export (class name params)
  (#..Generic (#..Class name params)))

(template: #export (var name)
  (#..Generic (#..Var name)))

(template: #export (wildcard bound)
  (#..Generic (#..Wildcard bound)))

(def: #export (array depth elemT)
  (-> Nat Type Type)
  (case depth
    0 elemT
    _ (#Array (array (dec depth) elemT))))

(def: #export (signature type)
  (-> Type Text)
  (case type
    (#Primitive prim)
    (case prim
      #Boolean ..boolean-descriptor
      #Byte    ..byte-descriptor
      #Short   ..short-descriptor
      #Int     ..int-descriptor
      #Long    ..long-descriptor
      #Float   ..float-descriptor
      #Double  ..double-descriptor
      #Char    ..char-descriptor)

    (#Array sub)
    (format ..array-prefix (signature sub))

    (#Generic generic)
    (case generic
      (#Class class params)
      (let [=params (if (list.empty? params)
                      ""
                      (format "<"
                              (|> params
                                  (list@map (|>> #Generic signature))
                                  (text.join-with ""))
                              ">"))]
        (format ..object-prefix (|> class //name.internal //name.read) =params ..object-suffix))

      (#Var name)
      (format ..var-prefix name ..object-suffix)

      (#Wildcard #.None)
      ..wildcard-signature

      (^template [<tag> <prefix>]
        (#Wildcard (#.Some [<tag> bound]))
        (format <prefix> (signature (#Generic bound))))
      ([#Lower ..lower-prefix]
       [#Upper ..upper-prefix]))
    ))

(template [<name> <head> <tail> <adapter>]
  [(def: <name>
     (Parser Text)
     (:: <>.functor map <adapter>
         (<t>.slice (<t>.and! (<t>.one-of! <head>)
                              (<t>.some! (<t>.one-of! <tail>))))))]

  [parse-class-name valid-class-characters/head valid-class-characters/tail (|>> //name.internal //name.external)]
  [parse-var-name valid-var-characters/head valid-var-characters/tail function.identity]
  )

(def: parse-var
  (Parser Var)
  (|> ..parse-var-name
      (<>.after (<t>.this ..var-prefix))
      (<>.before (<t>.this ..object-suffix))))

(def: parse-bound
  (Parser Bound)
  ($_ <>.or
      (<t>.this ..lower-prefix)
      (<t>.this ..upper-prefix)))

(def: parse-generic
  (Parser Generic)
  (<>.rec
   (function (_ recur)
     ($_ <>.or
         ..parse-var
         ($_ <>.or
             (<t>.this ..wildcard-signature)
             (<>.and ..parse-bound recur)
             )
         (|> (<>.and ..parse-class-name
                     (|> (<>.some recur)
                         (<>.after (<t>.this "<"))
                         (<>.before (<t>.this ">"))
                         (<>.default (list))))
             (<>.after (<t>.this ..object-prefix))
             (<>.before (<t>.this ..object-suffix)))
         ))))

(def: #export parse-signature
  (Parser Type)
  (<>.rec
   (function (_ recur)
     ($_ <>.or
         ($_ <>.or
             (<t>.this ..boolean-descriptor)
             (<t>.this ..byte-descriptor)
             (<t>.this ..short-descriptor)
             (<t>.this ..int-descriptor)
             (<t>.this ..long-descriptor)
             (<t>.this ..float-descriptor)
             (<t>.this ..double-descriptor)
             (<t>.this ..char-descriptor)
             )
         ..parse-generic
         (<>.after (<t>.this ..array-prefix)
                   recur)
         ))))

(def: #export (method args return exceptions)
  (-> (List Type) (Maybe Type) (List Generic) Method)
  {#args args #return return #exceptions exceptions})

(def: #export (method-signature method)
  (-> Method Text)
  (format (|> (get@ #args method)
              (list@map signature)
              (text.join-with "")
              (text.enclose ["(" ")"]))
          (case (get@ #return method)
            #.None
            ..void-descriptor

            (#.Some return)
            (signature return))
          (|> (get@ #exceptions method)
              (list@map (|>> #Generic signature (format "^")))
              (text.join-with ""))))