path: root/stdlib/source/library/lux/meta/macro/pattern.lux

(.require
 [library
  [lux (.except or let with_template |>
                ` , ,*
                UnQuote unquote unquote_macro
                Spliced_UnQuote spliced_unquote spliced_unquote_macro)
   [abstract
    ["[0]" monad (.only do)]]
   [control
    ["[0]" maybe]
    ["[0]" try]]
   [data
    [collection
     ["[0]" list (.use "[1]#[0]" monoid monad mix)]]]]]
 ["[0]" // (.only with_symbols)
  [vocabulary (.only vocabulary)]
  ["/[1]" // (.use "[1]#[0]" monad)]])

(def locally
  (macro (_ tokens lux)
    (.let [[prelude _] (symbol ._)]
      (when tokens
        (list [@ {.#Symbol ["" name]}])
        {.#Right [lux (list (.` (.in_module# (., [@ {.#Text prelude}])
                                             (., [@ {.#Symbol [prelude name]}]))))]}

        _
        {.#Left ""}))))

(.with_template [<name>]
  [(def <name> (..locally <name>))]

  [function#composite]

  [Replacement_Environment]
  [realized_template]
  [replacement_environment]

  [symbol_short]
  [tuple_list]

  [text$]
  [type_definition]
  [record_slots]
  [text#composite]
  [type#encoded]
  [module_alias]
  [symbol$]
  [tuple$]
  [zipped_2]

  [type_code]
  [expected_type]

  [wrong_syntax_error]
  [local$]

  [untemplated_list]
  [bit$]
  [nat$]
  [int$]
  [rev$]
  [frac$]

  [one_expansion]
  )

(def .public or
  (pattern
   (macro (_ tokens)
     (when tokens
       (list.partial [_ {.#Form patterns}] body branches)
       (when patterns
         {.#End}
         (///.failure (..wrong_syntax_error (symbol ..or)))

         _
         (.let [pairs (.|> patterns
                           (list#each (function (_ pattern) (list pattern body)))
                           list#conjoint)]
           (///#in (list#composite pairs branches))))
       _
       (///.failure (..wrong_syntax_error (symbol ..or)))))))

(def .public with_template
  (pattern
   (macro (_ tokens)
     (when tokens
       (list.partial [_ {.#Form (list [_ {.#Tuple bindings}]
                                      [_ {.#Tuple templates}])}]
                     [_ {.#Form data}]
                     branches)
       (when (is (Maybe (List Code))
                 (do maybe.monad
                   [bindings' (monad.each maybe.monad symbol_short bindings)
                    data' (monad.each maybe.monad tuple_list data)]
                   (.let [num_bindings (list.size bindings')]
                     (if (list.every? (|>> (.i64_=# num_bindings))
                                      (list#each list.size data'))
                       (.let [apply (is (-> Replacement_Environment (List Code))
                                        (function (_ env) (list#each (realized_template env) templates)))]
                         (.|> data'
                              (list#each (function#composite apply (replacement_environment bindings')))
                              list#conjoint
                              in))
                       {.#None}))))
         {.#Some output}
         (///#in (list#composite output branches))
         
         {.#None}
         (///.failure (..wrong_syntax_error (symbol ..with_template))))
       
       _
       (///.failure (..wrong_syntax_error (symbol ..with_template)))))))

(type Level
  [Code Code])

(def (level it)
  (-> Code (Meta Level))
  (///#in (when it
            [_ {.#Tuple (list expr binding)}]
            [expr binding]

            _
            [it (.` #1)])))

(type Multi
  [Code (List Level)])

(def (multiP levels)
  (-> (List Code) (Meta Multi))
  (when levels
    {.#End}
    (///.failure "Multi-level patterns cannot be empty.")

    {.#Item init extras}
    (do ///.monad
      [extras' (monad.each ///.monad ..level extras)]
      (in [init extras']))))

(def (multiG g!_ [[init_pattern levels] body])
  (-> Code [Multi Code] (List Code))
  (.let [inner_pattern_body (list#mix (function (_ [calculation pattern] success)
                                        (.let [bind? (when pattern
                                                       [_ {.#Symbol _}]
                                                       true

                                                       _
                                                       false)]
                                          (.` (when (., calculation)
                                                (., pattern)
                                                (., success)

                                                (.,* (if bind?
                                                       (list)
                                                       (list g!_ (.` {.#None}))))))))
                                      (.` {.#Some (., body)})
                                      (list.reversed levels))]
    (list init_pattern inner_pattern_body)))

(def .public multi
  (pattern
   (macro (_ tokens)
     (when tokens
       (list.partial [_meta {.#Form levels}] body next_branches)
       (with_symbols [g!temp]
         (do ///.monad
           [mlc (multiP levels)
            .let [initial_bind? (when mlc
                                  [[_ {.#Symbol _}] _]
                                  true

                                  _
                                  false)]
            expected ..expected_type]
           (in (list g!temp
                     (.` (.when (.is# {.#Apply (., (type_code expected)) Maybe}
                                      (.when (., g!temp)
                                        (.,* (multiG g!temp [mlc body]))

                                        (.,* (if initial_bind?
                                               (list)
                                               (list g!temp (.` {.#None}))))))
                           {.#Some (., g!temp)}
                           (., g!temp)

                           {.#None}
                           (.when (., g!temp)
                             (.,* next_branches))))))))
       
       _
       (///.failure (..wrong_syntax_error (symbol ..multi)))))))

(def .public let
  (pattern
   (macro (_ tokens)
     (when tokens
       (list.partial [_meta {.#Form (list [_ {.#Symbol ["" name]}] pattern)}] body branches)
       (.let [g!whole (local$ name)]
         (///#in (list.partial g!whole
                               (.` (when (., g!whole) (., pattern) (., body)))
                               branches)))
       
       _
       (///.failure (..wrong_syntax_error (symbol ..let)))))))

(def .public |>
  (pattern
   (macro (_ tokens)
     (when tokens
       (list.partial [_meta {.#Form (list [_ {.#Symbol ["" name]}] [_ {.#Tuple steps}])}] body branches)
       (.let [g!name (local$ name)]
         (///#in (list.partial g!name
                               (.` (.let [(., g!name) (.|> (., g!name) (.,* steps))]
                                     (., body)))
                               branches)))
       
       _
       (///.failure (..wrong_syntax_error (symbol ..|>)))))))

(def (name$ [module name])
  (-> Symbol Code)
  (.` [(., (text$ module)) (., (text$ name))]))

(def (untemplated_partial_list last inits)
  (-> Code (List Code) Code)
  (when inits
    {.#End}
    last

    {.#Item [init inits']}
    (.` {.#Item (., init) (., (untemplated_partial_list last inits'))})))

(vocabulary
 [.public Spliced_UnQuote]
 [.public spliced_unquote]
 [.public spliced_unquote_macro]
 [.private named_spliced_unquote])

(def (untemplated_composite <tag> g!meta untemplated_pattern elems)
  (-> Code Code (-> Code (Meta Code))
      (-> (List Code) (Meta Code)))
  (with_expansions [<default> (do ///.monad
                                [=elems (monad.each ///.monad untemplated_pattern elems)]
                                (in (.` [(., g!meta) {(., <tag>) (., (untemplated_list =elems))}])))]
    (when (list.reversed elems)
      {.#Item [_ {.#Form {.#Item [_ {.#Symbol global}] parameters}}]
              inits}
      (do ///.monad
        [micro (///.try (..named_spliced_unquote global))]
        (when micro
          {try.#Success micro}
          (do ///.monad
            [output (..one_expansion ((//.function micro) parameters))
             =inits (monad.each ///.monad untemplated_pattern (list.reversed inits))]
            (in (.` [(., g!meta) {(., <tag>) (., (untemplated_partial_list output =inits))}])))
          
          {try.#Failure error}
          <default>))

      _
      <default>)))

(def .public ,*
  (..spliced_unquote
   (macro (_ tokens)
     ({{.#Item it {.#End}}
       (at ///.monad in (list it))

       _
       (///.failure (..wrong_syntax_error (symbol ..,*)))}
      tokens))))

(vocabulary
 [.public UnQuote]
 [.public unquote]
 [.public unquote_macro]
 [.private named_unquote])

(def (untemplated_pattern pattern)
  (-> Code (Meta Code))
  (with_symbols [g!meta]
    (when pattern
      (..with_template [<tag> <gen>]
        [[_ {<tag> value}]
         (///#in (.` [(., g!meta) {<tag> (., (<gen> value))}]))])
      ([.#Bit    bit$]
       [.#Nat    nat$]
       [.#Int    int$]
       [.#Rev    rev$]
       [.#Frac   frac$]
       [.#Text   text$]
       [.#Symbol name$])

      [@composite {.#Form {.#Item [@global {.#Symbol global}] parameters}}]
      (do [! ///.monad]
        [micro (///.try (..named_unquote global))]
        (when micro
          {try.#Success micro}
          (do !
            [[_ output] (..one_expansion ((//.function micro) parameters))]
            (in [@composite output]))
          
          {try.#Failure error}
          (untemplated_composite (.` .#Form) g!meta untemplated_pattern (list.partial [@global {.#Symbol global}] parameters))))

      (..with_template [<tag>]
        [[_ {<tag> it}]
         (untemplated_composite (.` <tag>) g!meta untemplated_pattern it)])
      ([.#Form]
       [.#Variant]
       [.#Tuple])
      )))

(def .public `
  (pattern
   (macro (_ tokens)
     (when tokens
       (list.partial [_meta {.#Form (list template)}] body branches)
       (do ///.monad
         [pattern (untemplated_pattern template)]
         (in (list.partial pattern body branches)))

       (list template)
       (do ///.monad
         [pattern (untemplated_pattern template)]
         (in (list pattern)))

       _
       (///.failure (..wrong_syntax_error (symbol ..`)))))))

(def .public ,
  UnQuote
  (..unquote
   (macro (_ tokens)
     ({{.#Item it {.#End}}
       (at ///.monad in (list it))

       _
       (///.failure (..wrong_syntax_error (symbol ..,)))}
      tokens))))