aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/generator/statement.jvm.lux
blob: 830935dda8ea540c7cdbc428c206927f6bc54da6 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
(;module:
  lux
  (lux (control monad
                ["ex" exception #+ exception:])
       (concurrency ["T" task])
       (data ["e" error]
             [maybe]
             [text "text/" Monoid<Text>]
             text/format
             (coll [list "list/" Functor<List> Fold<List>]))
       [meta]
       [host])
  (luxc ["&" base]
        ["&;" scope]
        ["&;" module]
        ["&;" io]
        (generator ["&;" expr]
                   ["&;" eval]
                   ["&;" common]
                   (host ["$" jvm]
                         (jvm ["$t" type]
                              ["$d" def]
                              ["$i" inst])))))

(exception: #export Invalid-Definition-Value)

(host;import java.lang.Object
  (toString [] String))

(host;import java.lang.reflect.Field
  (get [#? Object] #try #? Object))

(host;import (java.lang.Class c)
  (getField [String] #try Field))

(def: #export (generate-def def-name valueT valueI metaI metaV)
  (-> Text Type $;Inst $;Inst Code (Meta Unit))
  (do meta;Monad<Meta>
    [current-module meta;current-module-name
     #let [def-ident [current-module def-name]
           normal-name (&;normalize-name def-name)
           bytecode-name (format current-module "/" normal-name)
           class-name (format current-module "." normal-name)
           bytecode ($d;class #$;V1.6
                              #$;Public $;finalC
                              bytecode-name
                              (list) ["java.lang.Object" (list)]
                              (list)
                              (|>. ($d;field #$;Public ($;++F $;finalF $;staticF) &common;value-field &common;$Object)
                                   ($d;method #$;Public $;staticM "<clinit>" ($t;method (list) #;None (list))
                                              (|>. valueI
                                                   ($i;PUTSTATIC bytecode-name &common;value-field &common;$Object)
                                                   $i;RETURN))))]
     _ (&common;store-class class-name bytecode)
     class (&common;load-class class-name)
     valueV (: (Meta Top)
               (case (do e;Monad<Error>
                       [field (Class.getField [&common;value-field] class)]
                       (Field.get [#;None] field))
                 (#e;Success #;None)
                 (&;throw Invalid-Definition-Value (format current-module ";" def-name))
                 
                 (#e;Success (#;Some valueV))
                 (wrap valueV)
                 
                 (#e;Error error)
                 (&;fail error)))
     _ (&module;define [current-module def-name] [valueT metaV valueV])
     _ (if (meta;type? metaV)
         (case (meta;declared-tags metaV)
           #;Nil
           (wrap [])

           tags
           (&module;declare-tags tags (meta;export? metaV) (:! Type valueV)))
         (wrap []))
     #let [_ (log! (format "DEF " current-module ";" def-name))]]
    (&common;record-artifact bytecode-name bytecode)))

(def: #export (generate-program program-args programI)
  (-> Text $;Inst (Meta Unit))
  (do meta;Monad<Meta>
    []
    (&;fail "'lux program' is unimplemented.")))