blob: a9f4a574493b17cd4be273d2bdc20845970cc0a2 (
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
|
(.module:
[library
[lux #*
["." meta]
["." type]
[abstract
["." monad (#+ do)]]
[control
["<>" parser
["<.>" type (#+ Env)]
["<.>" code]]]
[data
["." product]
["." maybe]
["." text]
[collection
["." list ("#\." fold functor)]
["." dictionary]]]
[macro (#+ with_gensyms)
["." code]
[syntax (#+ syntax:)
["|.|" export]]]
[math
[number
["n" nat]]]]])
(syntax: #export (poly: {export |export|.parser}
{name <code>.local_identifier}
body)
(with_gensyms [g!_ g!type g!output]
(let [g!name (code.identifier ["" name])]
(wrap (.list (` ((~! syntax:) (~+ (|export|.format export)) ((~ g!name) {(~ g!type) (~! <code>.identifier)})
((~! do) (~! meta.monad)
[(~ g!type) ((~! meta.find_type_def) (~ g!type))]
(case (: (.Either .Text .Code)
((~! <type>.run) ((~! <>.rec)
(function ((~ g!_) (~ g!name))
(~ body)))
(~ g!type)))
(#.Left (~ g!output))
((~! meta.failure) (~ g!output))
(#.Right (~ g!output))
((~' wrap) (.list (~ g!output))))))))))))
(def: (common_poly_name? poly_func)
(-> Text Bit)
(text.contains? "?" poly_func))
(def: (derivation_name poly args)
(-> Text (List Text) (Maybe Text))
(if (common_poly_name? poly)
(#.Some (list\fold (text.replace_once "?") poly args))
#.None))
(syntax: #export (derived: {export |export|.parser}
{?name (<>.maybe <code>.local_identifier)}
{[poly_func poly_args] (<code>.form (<>.and <code>.identifier (<>.many <code>.identifier)))}
{?custom_impl (<>.maybe <code>.any)})
(do {! meta.monad}
[poly_args (monad.map ! meta.normal poly_args)
name (case ?name
(#.Some name)
(wrap name)
(^multi #.None
{(derivation_name (product.right poly_func) (list\map product.right poly_args))
(#.Some derived_name)})
(wrap derived_name)
_
(<>.failure "derived: was given no explicit name, and cannot generate one from given information."))
#let [impl (case ?custom_impl
(#.Some custom_impl)
custom_impl
#.None
(` ((~ (code.identifier poly_func)) (~+ (list\map code.identifier poly_args)))))]]
(wrap (.list (` (def: (~+ (|export|.format export))
(~ (code.identifier ["" name]))
{#.implementation? #1}
(~ impl)))))))
(def: #export (to_code env type)
(-> Env Type Code)
(`` (case type
(#.Primitive name params)
(` (#.Primitive (~ (code.text name))
(list (~+ (list\map (to_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 (to_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 (to_code env))
(undefined)))
(^template [<tag>]
[(<tag> left right)
(` (<tag> (~ (to_code env left))
(~ (to_code env right))))])
([#.Function] [#.Apply])
(^template [<macro> <tag> <flattener>]
[(<tag> left right)
(` (<macro> (~+ (list\map (to_code env) (<flattener> type)))))])
([| #.Sum type.flat_variant]
[& #.Product type.flat_tuple])
(#.Named name sub_type)
(code.identifier name)
(^template [<tag>]
[(<tag> scope body)
(` (<tag> (list (~+ (list\map (to_code env) scope)))
(~ (to_code env body))))])
([#.UnivQ] [#.ExQ])
)))
|
