blob: 5e509935df10d58281d1875f30d9b8352292c55d (
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
|
(.module:
[lux #*
[control
[monad (#+ do Monad)]
[functor]
["p" parser]]
[data
["." text
format]
[collection [list ("list/" Monad<List> Monoid<List>)]]
[product]]
["." macro
[code]
[syntax (#+ syntax: Syntax)
[common]]
[poly (#+ poly:)]]
[language [type]]
])
(poly: #export Functor<?>
(do @
[#let [type-funcC (code.local-symbol "____________type-funcC")
funcC (code.local-symbol "____________funcC")
inputC (code.local-symbol "____________inputC")]
*env* poly.env
inputT poly.peek
[polyC varsC non-functorT] (poly.local (list inputT)
(poly.polymorphic poly.any))
#let [num-vars (list.size varsC)]
#let [@Functor (: (-> Type Code)
(function (_ unwrappedT)
(if (n/= +1 num-vars)
(` ((~! functor.Functor) (~ (poly.to-code *env* unwrappedT))))
(let [paramsC (|> num-vars dec list.indices (list/map (|>> %n code.local-symbol)))]
(` (All [(~+ paramsC)]
((~! functor.Functor) ((~ (poly.to-code *env* unwrappedT)) (~+ paramsC)))))))))
Arg<?> (: (-> Code (poly.Poly Code))
(function (Arg<?> valueC)
($_ p.either
## Type-var
(do p.Monad<Parser>
[#let [varI (|> num-vars (n/* +2) dec)]
_ (poly.var varI)]
(wrap (` ((~ funcC) (~ valueC)))))
## Variants
(do @
[_ (wrap [])
membersC (poly.variant (p.many (Arg<?> valueC)))]
(wrap (` (case (~ valueC)
(~+ (list/join (list/map (function (_ [tag memberC])
(list (` ((~ (code.nat tag)) (~ valueC)))
(` ((~ (code.nat tag)) (~ memberC)))))
(list.enumerate membersC))))))))
## Tuples
(do p.Monad<Parser>
[pairsCC (: (poly.Poly (List [Code Code]))
(poly.tuple (loop [idx +0
pairsCC (: (List [Code Code])
(list))]
(p.either (let [slotC (|> idx %n (format "____________slot") code.local-symbol)]
(do @
[_ (wrap [])
memberC (Arg<?> slotC)]
(recur (inc idx)
(list/compose pairsCC (list [slotC memberC])))))
(wrap pairsCC)))))]
(wrap (` (case (~ valueC)
[(~+ (list/map product.left pairsCC))]
[(~+ (list/map product.right pairsCC))]))))
## Functions
(do @
[_ (wrap [])
#let [g! (code.local-symbol "____________")
outL (code.local-symbol "____________outL")]
[inT+ outC] (poly.function (p.many poly.any)
(Arg<?> outL))
#let [inC+ (|> (list.size inT+) dec
(list.n/range +0)
(list/map (|>> %n (format "____________inC") code.local-symbol)))]]
(wrap (` (function ((~ g!) (~+ inC+))
(let [(~ outL) ((~ valueC) (~+ inC+))]
(~ outC))))))
## Recursion
(do p.Monad<Parser>
[_ poly.recursive-call]
(wrap (` ((~' map) (~ funcC) (~ valueC)))))
## Parameters
(do p.Monad<Parser>
[_ poly.any]
(wrap valueC))
)))]
[_ _ outputC] (: (poly.Poly [Code (List Code) Code])
(p.either (poly.polymorphic
(Arg<?> inputC))
(p.fail (format "Cannot create Functor for: " (%type inputT)))))]
(wrap (` (: (~ (@Functor inputT))
(structure (def: ((~' map) (~ funcC) (~ inputC))
(~ outputC))))))))
|
