blob: b4c5e44a364b7bbf4313cea005ceb2a8b07066b1 (
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
|
(.module:
[library
[lux "*"
[abstract
[monad {"+" Monad do}]]
[control
["p" parser
["<[0]>" type]
["s" code {"+" Parser}]]]
[data
["[0]" product]
["[0]" text
["%" format {"+" format}]]
[collection
["[0]" list ("[1]#[0]" monad monoid)]]]
[macro
[syntax {"+" syntax:}]
["[0]" code]]
[math
[number
["n" nat]]]
["[0]" type
["[0]" poly {"+" poly:}]]]]
[\\library
["[0]" /]])
(poly: .public functor
(do [! p.monad]
[.let [g!_ (code.local_symbol "____________")
type_funcC (code.local_symbol "____________type_funcC")
funcC (code.local_symbol "____________funcC")
inputC (code.local_symbol "____________inputC")]
*env* <type>.env
inputT <type>.next
[polyC varsC non_functorT] (<type>.local (list inputT)
(<type>.polymorphic <type>.any))
.let [num_vars (list.size varsC)]
.let [@Functor (: (-> Type Code)
(function (_ unwrappedT)
(if (n.= 1 num_vars)
(` ((~! /.Functor) (~ (poly.code *env* unwrappedT))))
(let [paramsC (|> num_vars -- list.indices (list#each (|>> %.nat code.local_symbol)))]
(` (All ((~ g!_) (~+ paramsC))
((~! /.Functor) ((~ (poly.code *env* unwrappedT)) (~+ paramsC)))))))))
Arg<?> (: (-> Code (<type>.Parser Code))
(function (Arg<?> valueC)
($_ p.either
... Type-var
(do p.monad
[.let [varI (|> num_vars (n.* 2) --)]
_ (<type>.parameter! varI)]
(in (` ((~ funcC) (~ valueC)))))
... Variants
(do !
[_ (in [])
membersC (<type>.variant (p.many (Arg<?> valueC)))
.let [last (-- (list.size membersC))]]
(in (` (case (~ valueC)
(~+ (list#conjoint (list#each (function (_ [tag memberC])
(if (n.= last tag)
(list (` {(~ (code.nat (-- tag))) #1 (~ valueC)})
(` {(~ (code.nat (-- tag))) #1 (~ memberC)}))
(list (` {(~ (code.nat tag)) #0 (~ valueC)})
(` {(~ (code.nat tag)) #0 (~ memberC)}))))
(list.enumeration membersC))))))))
... Tuples
(do p.monad
[pairsCC (: (<type>.Parser (List [Code Code]))
(<type>.tuple (loop [idx 0
pairsCC (: (List [Code Code])
(list))]
(p.either (let [slotC (|> idx %.nat (format "____________slot") code.local_symbol)]
(do !
[_ (in [])
memberC (Arg<?> slotC)]
(recur (++ idx)
(list#composite pairsCC (list [slotC memberC])))))
(in pairsCC)))))]
(in (` (case (~ valueC)
[(~+ (list#each product.left pairsCC))]
[(~+ (list#each product.right pairsCC))]))))
... Functions
(do !
[_ (in [])
.let [g! (code.local_symbol "____________")
outL (code.local_symbol "____________outL")]
[inT+ outC] (<type>.function (p.many <type>.any)
(Arg<?> outL))
.let [inC+ (|> (list.size inT+)
list.indices
(list#each (|>> %.nat (format "____________inC") code.local_symbol)))]]
(in (` (function ((~ g!) (~+ inC+))
(let [(~ outL) ((~ valueC) (~+ inC+))]
(~ outC))))))
... Recursion
(do p.monad
[_ <type>.recursive_call]
(in (` ((~' each) (~ funcC) (~ valueC)))))
... Parameters
(do p.monad
[_ <type>.any]
(in valueC))
)))]
[_ _ outputC] (: (<type>.Parser [Code (List Code) Code])
(p.either (<type>.polymorphic
(Arg<?> inputC))
(p.failure (format "Cannot create Functor for: " (%.type inputT)))))]
(in (` (: (~ (@Functor inputT))
(implementation
(def: ((~' each) (~ funcC) (~ inputC))
(~ outputC))))))))
|