aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/library/lux/macro/syntax.lux
blob: 9a2e566f05df8506758401502bddfbfbb867ab56 (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
(.using
 [library
  [lux "*"
   ["[0]" macro {"+" with_symbols}]
   ["[0]" meta]
   [abstract
    ["[0]" monad {"+" do}]]
   [control
    ["[0]" maybe]
    ["[0]" try]
    ["<>" parser
     ["</>" code {"+" Parser}]]]
   [data
    ["[0]" text ("[1]#[0]" monoid)]
    [collection
     ["[0]" list]]]
   [math
    [number
     ["[0]" nat]
     ["[0]" int]
     ["[0]" rev]
     ["[0]" frac]]]]]
 [//
  ["[0]" code]]
 ["[0]" / "_"
  ["[1][0]" export]])

(def: (self_documenting binding parser)
  (All (_ a) (-> Code (Parser a) (Parser a)))
  (function (_ tokens)
    (case (parser tokens)
      {try.#Success [tokens output]}
      {try.#Success [tokens output]}
      
      {try.#Failure error}
      {try.#Failure (all text#composite
                         "Failed to parse: " (code.format binding) text.new_line
                         error)})))

(def: (un_paired pairs)
  (All (_ a) (-> (List [a a]) (List a)))
  (case pairs
    {.#End}                 {.#End}
    {.#Item [[x y] pairs']} (partial_list x y (un_paired pairs'))))

(def: syntax
  (Parser [Code [Text (List Code)] Code])
  (/export.parser
   (all <>.and
        (</>.form (all <>.and
                       </>.local
                       (</>.tuple (<>.some </>.any))))
        </>.any)))

(macro: .public (syntax: tokens)
  (case (</>.result ..syntax tokens)
    {try.#Success [export_policy [name args] body]}
    (with_symbols [g!tokens g!body g!error]
      (do [! meta.monad]
        [vars+parsers (case (list.pairs args)
                        {.#Some args}
                        (monad.each !
                                    (is (-> [Code Code] (Meta [Code Code]))
                                        (function (_ [var parser])
                                          (with_expansions [<default> (in [var
                                                                           (` ((~! ..self_documenting) (' (~ var))
                                                                               (~ parser)))])]
                                            (case var
                                              [_ {.#Symbol ["" _]}]
                                              <default>

                                              [_ {.#Symbol _}]
                                              (in [var parser])

                                              _
                                              <default>))))
                                    args)

                        _
                        (meta.failure "Syntax pattern expects pairs of bindings and code-parsers."))
         this_module meta.current_module_name
         .let [g!state (code.symbol ["" "*lux*"])
               error_msg (code.text (macro.wrong_syntax_error [this_module name]))]]
        (in (list (` (.macro: (~ export_policy) ((~ (code.symbol ["" name])) (~ g!tokens) (~ g!state))
                       (.case ((~! </>.result)
                               (is ((~! </>.Parser) (Meta (List Code)))
                                   ((~! do) (~! <>.monad)
                                    [(~+ (..un_paired vars+parsers))]
                                    ((~' in) (~ body))))
                               (~ g!tokens))
                         {try.#Success (~ g!body)}
                         ((~ g!body) (~ g!state))

                         {try.#Failure (~ g!error)}
                         {try.#Failure ((~! text.interposed) (~! text.new_line) (list (~ error_msg) (~ g!error)))})))))))
    
    {try.#Failure error}
    (meta.failure (macro.wrong_syntax_error (symbol ..syntax:)))))