stdlib/source/poly/lux/abstract/functor.lux


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

(.using
 [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 "____________")
           type_funcC (code.local "____________type_funcC")
           funcC (code.local "____________funcC")
           inputC (code.local "____________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 (is (-> 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)))]
                              (` (All ((~ g!_) (~+ paramsC))
                                   ((~! /.Functor) ((~ (poly.code *env* unwrappedT)) (~+ paramsC)))))))))
           Arg<?> (is (-> Code (<type>.Parser Code))
                      (function (Arg<?> valueC)
                        (all p.either
                             ... Type-var
                             (do p.monad
                               [.let [varI (|> num_vars (n.* 2) --)]
                                _ (<type>.this_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 (is (<type>.Parser (List [Code Code]))
                                            (<type>.tuple (loop (again [idx 0
                                                                        pairsCC (is (List [Code Code])
                                                                                    (list))])
                                                            (p.either (let [slotC (|> idx %.nat (format "____________slot") code.local)]
                                                                        (do !
                                                                          [_ (in [])
                                                                           memberC (Arg<?> slotC)]
                                                                          (again (++ 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 "____________")
                                      outL (code.local "____________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)))]]
                               (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] (is (<type>.Parser [Code (List Code) Code])
                       (p.either (<type>.polymorphic
                                  (Arg<?> inputC))
                                 (p.failure (format "Cannot create Functor for: " (%.type inputT)))))]
    (in (` (is (~ (@Functor inputT))
               (implementation
                (def: ((~' each) (~ funcC) (~ inputC))
                  (~ outputC))))))))