stdlib/source/lux/macro/poly/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

(.module:
  lux
  (lux (control [monad #+ do Monad]
                [functor]
                ["p" parser])
       (data [text]
             text/format
             (coll [list "L/" Monad<List> Monoid<List>])
             [product])
       [macro]
       (macro [code]
              [syntax #+ syntax: Syntax]
              (syntax [common])
              [poly #+ poly:])
       (lang [type])
       ))

(poly: #export Functor<?>
  (do @
    [#let [type-funcC (code.local-symbol "\u0000type-funcC")
           funcC (code.local-symbol "\u0000funcC")
           inputC (code.local-symbol "\u0000inputC")]
     *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-ast *env* unwrappedT))))
                           (let [paramsC (|> num-vars n/dec list.indices (L/map (|>> %n code.local-symbol)))]
                             (` (All [(~+ paramsC)]
                                  (functor.Functor ((~ (poly.to-ast *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) n/dec)]
                              _ (poly.var varI)]
                             (wrap (` ((~ funcC) (~ valueC)))))
                           ## Variants
                           (do @
                             [_ (wrap [])
                              membersC (poly.variant (p.many (Arg<?> valueC)))]
                             (wrap (` (case (~ valueC)
                                        (~+ (L/join (L/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 "\u0000slot") code.local-symbol)]
                                                                   (do @
                                                                     [_ (wrap [])
                                                                      memberC (Arg<?> slotC)]
                                                                     (recur (n/inc idx)
                                                                            (L/compose pairsCC (list [slotC memberC])))))
                                                                 (wrap pairsCC)))))]
                             (wrap (` (case (~ valueC)
                                        [(~+ (L/map product.left pairsCC))]
                                        [(~+ (L/map product.right pairsCC))]))))
                           ## Functions
                           (do @
                             [_ (wrap [])
                              #let [outL (code.local-symbol "\u0000outL")]
                              [inT+ outC] (poly.function (p.many poly.any)
                                            (Arg<?> outL))
                              #let [inC+ (|> (list.size inT+) n/dec
                                             (list.n/range +0)
                                             (L/map (|>> %n (format "\u0000inC") code.local-symbol)))]]
                             (wrap (` (function [(~+ inC+)]
                                        (let [(~ outL) ((~ valueC) (~+ inC+))]
                                          (~ outC))))))
                           ## Recursion
                           (do p.Monad<Parser>
                             [_ poly.recursive-call]
                             (wrap (` ((~' map) (~ funcC) (~ valueC)))))
                           ## Bound type-variables
                           (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))
                (struct (def: ((~' map) (~ funcC) (~ inputC))
                          (~ outputC))))))))