blob: 7c79dd3d7e0525ce269ee261e2d6e2cfc4b38e8d (
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
|
(.module:
[library
[lux #*
["." meta]
["." type]
[abstract
["." monad (#+ do)]]
[control
["." maybe]
["<>" parser ("#\." monad)
["<.>" type (#+ Env)]
["<.>" code (#+ Parser)]]]
[data
["." product]
["." text]
[collection
["." list ("#\." fold functor)]
["." dictionary]]]
[macro (#+ with_identifiers)
["." code]
[syntax (#+ syntax:)]]
[math
[number
["n" nat]]]]])
(def: polyP
(Parser [Code Text Code])
(let [private ($_ <>.and
<code>.local_identifier
<code>.any)]
(<>.either (<>.and <code>.any private)
(<>.and (<>\in (` .private)) private))))
(syntax: .public (poly: {[export_policy name body] ..polyP})
(with_identifiers [g!_ g!type g!output]
(let [g!name (code.identifier ["" name])]
(in (.list (` ((~! syntax:) (~ export_policy) ((~ g!name) {(~ g!type) (~! <code>.identifier)})
((~! do) (~! meta.monad)
[(~ g!type) ((~! meta.type_definition) (~ g!type))]
(case (: (.Either .Text .Code)
((~! <type>.result) ((~! <>.rec)
(function ((~ g!_) (~ g!name))
(~ body)))
(~ g!type)))
(#.Left (~ g!output))
((~! meta.failure) (~ g!output))
(#.Right (~ g!output))
((~' in) (.list (~ g!output))))))))))))
(def: derivedP
(Parser [Code Text [Name (List Name)] (Maybe Code)])
(let [private ($_ <>.and
<code>.local_identifier
(<code>.form (<>.and <code>.identifier (<>.many <code>.identifier)))
(<>.maybe <code>.any))]
(<>.either (<>.and <code>.any private)
(<>.and (<>\in (` .private)) private))))
(syntax: .public (derived: {[export_policy name [poly_func poly_args] ?custom_impl]
..derivedP})
(do {! meta.monad}
[poly_args (monad.map ! meta.normal poly_args)
.let [impl (case ?custom_impl
(#.Some custom_impl)
custom_impl
#.None
(` ((~ (code.identifier poly_func)) (~+ (list\map code.identifier poly_args)))))]]
(in (.list (` (def: (~ export_policy) (~ (code.identifier ["" name]))
{#.implementation? #1}
(~ impl)))))))
(def: .public (code env type)
(-> Env Type Code)
(`` (case type
(#.Primitive name params)
(` (#.Primitive (~ (code.text name))
(.list (~+ (list\map (code env) params)))))
(^template [<tag>]
[(<tag> idx)
(` (<tag> (~ (code.nat idx))))])
([#.Var] [#.Ex])
(#.Parameter idx)
(let [idx (<type>.adjusted_idx env idx)]
(if (n.= 0 idx)
(|> (dictionary.get idx env) maybe.assume product.left (code env))
(` (.$ (~ (code.nat (dec idx)))))))
(#.Apply (#.Named [(~~ (static .prelude_module)) "Nothing"] _) (#.Parameter idx))
(let [idx (<type>.adjusted_idx env idx)]
(if (n.= 0 idx)
(|> (dictionary.get idx env) maybe.assume product.left (code env))
(undefined)))
(^template [<tag>]
[(<tag> left right)
(` (<tag> (~ (code env left))
(~ (code env right))))])
([#.Function] [#.Apply])
(^template [<macro> <tag> <flattener>]
[(<tag> left right)
(` (<macro> (~+ (list\map (code env) (<flattener> type)))))])
([.Variant #.Sum type.flat_variant]
[.Tuple #.Product type.flat_tuple])
(#.Named name sub_type)
(code.identifier name)
(^template [<tag>]
[(<tag> scope body)
(` (<tag> (.list (~+ (list\map (code env) scope)))
(~ (code env body))))])
([#.UnivQ] [#.ExQ])
)))
|
