blob: 99bb28c0ee0addeac4f551fb1dad2c31dc0fd670 (
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
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
(.module:
[library
[lux #*
["." macro (#+ with_gensyms)]
["." meta]
[abstract
["." monad (#+ do)]]
[control
["." try]
["<>" parser
["</>" code (#+ Parser)]]]
[data
["." maybe]
["." text ("#\." monoid)]
[collection
["." list ("#\." functor)]]]
[math
[number
["." nat]
["." int]
["." rev]
["." frac]]]]]
[//
["." code]])
(def: (self_documenting binding parser)
(All [a] (-> Code (Parser a) (Parser a)))
(function (_ tokens)
(case (parser tokens)
(#try.Success [tokens output])
(#try.Success [tokens output])
(#try.Failure error)
(#try.Failure ($_ text\compose
"Failed to parse: " (code.format binding) text.new_line
error)))))
(def: (un_paired pairs)
(All [a] (-> (List [a a]) (List a)))
(case pairs
#.End #.End
(#.Item [[x y] pairs']) (list& x y (un_paired pairs'))))
(macro: #export (syntax: tokens)
{#.doc (doc "A more advanced way to define macros than 'macro:'."
"The inputs to the macro can be parsed in complex ways through the use of syntax parsers."
"The macro body is also (implicitly) run in the Meta monad, to save some typing."
"Also, the compiler state can be accessed through the *compiler* binding."
(syntax: #export (object {.let [imports (class_imports *compiler*)]}
{.let [class_vars (list)]}
{super (opt (super_class_decl^ imports class_vars))}
{interfaces (tuple (some (super_class_decl^ imports class_vars)))}
{constructor_args (constructor_args^ imports class_vars)}
{methods (some (overriden_method_def^ imports))})
(let [def_code ($_ text\compose "anon-class:"
(spaced (list (super_class_decl$ (maybe.else object_super_class super))
(with_brackets (spaced (list\map super_class_decl$ interfaces)))
(with_brackets (spaced (list\map constructor_arg$ constructor_args)))
(with_brackets (spaced (list\map (method_def$ id) methods))))))]
(in (list (` ((~ (code.text def_code)))))))))}
(let [[exported? tokens] (: [Bit (List Code)]
(case tokens
(^ (list& [_ (#.Tag ["" "export"])] tokens'))
[#1 tokens']
_
[#0 tokens]))
?parts (: (Maybe [Text (List Code) Code Code])
(case tokens
(^ (list [_ (#.Form (list& [_ (#.Identifier ["" name])] args))]
body))
(#.Some name args (` {}) body)
(^ (list [_ (#.Form (list& [_ (#.Identifier ["" name])] args))]
meta_data
body))
(#.Some name args meta_data body)
_
#.None))]
(case ?parts
(#.Some [name args meta body])
(with_gensyms [g!tokens g!body g!error]
(do {! meta.monad}
[vars+parsers (monad.map !
(: (-> Code (Meta [Code Code]))
(function (_ arg)
(case arg
(^ [_ (#.Record (list [var parser]))])
(with_expansions [<default> (in [var
(` ((~! ..self_documenting) (' (~ var))
(~ parser)))])]
(case var
[_ (#.Identifier ["" _])]
<default>
[_ (#.Identifier _)]
(in [var parser])
_
<default>))
[_ (#.Identifier var_name)]
(in [arg
(` ((~! ..self_documenting) (' (~ arg))
(~! </>.any)))])
_
(meta.failure "Syntax pattern expects records or identifiers."))))
args)
this_module meta.current_module_name
.let [g!state (code.identifier ["" "*compiler*"])
error_msg (code.text (macro.wrong_syntax_error [this_module name]))
export_ast (: (List Code)
(if exported?
(list (' #export))
(list)))]]
(in (list (` (macro: (~+ export_ast) ((~ (code.identifier ["" name])) (~ g!tokens) (~ g!state))
(~ meta)
({(#.Right (~ g!body))
((~ g!body) (~ g!state))
(#.Left (~ g!error))
(#.Left ((~! text.join_with) (~! text.new_line) (list (~ error_msg) (~ g!error))))}
((~! </>.run)
(: ((~! </>.Parser) (Meta (List Code)))
((~! do) (~! <>.monad)
[(~+ (..un_paired vars+parsers))]
((~' in) (~ body))))
(~ g!tokens)))))))))
_
(meta.failure (macro.wrong_syntax_error (name_of ..syntax:))))))
|
