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 #+ Monad<Lux> with-gensyms]
       (macro [code]
              [syntax #+ syntax: Syntax]
              (syntax [common])
              [poly #+ poly:])
       [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))))))))