stdlib/source/polytypic/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 (.except)
   [abstract
    [monad (.only Monad do)]]
   [control
    ["p" parser (.only)
     ["<[0]>" type]
     ["s" code (.only Parser)]]]
   [data
    ["[0]" product]
    ["[0]" text (.only)
     ["%" \\format (.only format)]]
    [collection
     ["[0]" list (.open: "[1]#[0]" monad monoid)]]]
   [macro
    ["[0]" code]]
   [math
    [number
     ["n" nat]]]
   ["[0]" type (.only)
    ["[0]" poly (.only polytypic)]]]]
 [\\library
  ["[0]" /]])

(def: .public functor
  (polytypic 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)))))))))