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.")))
|
