path: root/stdlib/source/library/lux/data/text/regex.lux

(.using
 [library
  [lux (.except pattern)
   ["[0]" meta]
   [abstract
    [monad (.only do)]]
   [control
    ["[0]" maybe]
    ["[0]" try]
    ["[0]" exception (.only exception:)]
    ["<>" parser ("[1]#[0]" monad)
     ["<[0]>" text (.only Parser)]
     ["<[0]>" code]]]
   [data
    ["[0]" product]
    [collection
     ["[0]" list ("[1]#[0]" mix monad)]]]
   [macro (.only with_symbols)
    [syntax (.only syntax:)]
    ["^" pattern]
    ["[0]" code]]
   [math
    [number (.only hex)
     ["n" nat ("[1]#[0]" decimal)]]]]]
 ["[0]" // (.only)
  ["%" format (.only format)]])

(def: regex_char^
  (Parser Text)
  (<text>.none_of "\.|&()[]{}"))

(def: escaped_char^
  (Parser Text)
  (do <>.monad
    [? (<>.parses? (<text>.this "\"))]
    (if ?
      <text>.any
      regex_char^)))

(def: (refine^ refinement^ base^)
  (All (_ a) (-> (Parser a) (Parser Text) (Parser Text)))
  (do <>.monad
    [output base^
     _ (<text>.local output refinement^)]
    (in output)))

(def: word^
  (Parser Text)
  (<>.either <text>.alpha_num
             (<text>.one_of "_")))

(def: (copy reference)
  (-> Text (Parser Text))
  (<>.after (<text>.this reference) (<>#in reference)))

(def: together^
  (-> (Parser (List Text)) (Parser Text))
  (# <>.monad each //.together))

(def: symbol_char^
  (Parser Text)
  (<text>.none_of (format "[]{}()s.<>" //.double_quote)))

(def: symbol_part^
  (Parser Text)
  (do <>.monad
    [head (refine^ (<text>.not <text>.decimal)
                   symbol_char^)
     tail (<text>.some symbol_char^)]
    (in (format head tail))))

(def: (symbol^ current_module)
  (-> Text (Parser Symbol))
  (all <>.either
       (<>.and (<>#in current_module) (<>.after (<text>.this "..") symbol_part^))
       (<>.and symbol_part^ (<>.after (<text>.this ".") symbol_part^))
       (<>.and (<>#in .prelude_module) (<>.after (<text>.this ".") symbol_part^))
       (<>.and (<>#in "") symbol_part^)))

(def: (re_var^ current_module)
  (-> Text (Parser Code))
  (do <>.monad
    [symbol (<text>.enclosed ["\@<" ">"] (symbol^ current_module))]
    (in (` (is ((~! <text>.Parser) Text) (~ (code.symbol symbol)))))))

(def: re_range^
  (Parser Code)
  (do [! <>.monad]
    [from (|> regex_char^ (# ! each (|>> (//.char 0) maybe.trusted)))
     _ (<text>.this "-")
     to (|> regex_char^ (# ! each (|>> (//.char 0) maybe.trusted)))]
    (in (` ((~! <text>.range) (~ (code.nat from)) (~ (code.nat to)))))))

(def: re_char^
  (Parser Code)
  (do <>.monad
    [char escaped_char^]
    (in (` ((~! ..copy) (~ (code.text char)))))))

(def: re_options^
  (Parser Code)
  (do <>.monad
    [options (<text>.many escaped_char^)]
    (in (` ((~! <text>.one_of) (~ (code.text options)))))))

(def: re_user_class^'
  (Parser Code)
  (do <>.monad
    [negate? (<>.maybe (<text>.this "^"))
     parts (<>.many (all <>.either
                         re_range^
                         re_options^))]
    (in (case negate?
          {.#Some _} (` ((~! <text>.not) (all ((~! <>.either)) (~+ parts))))
          {.#None}   (` (all ((~! <>.either)) (~+ parts)))))))

(def: re_user_class^
  (Parser Code)
  (do <>.monad
    [init ..re_user_class^'
     rest (<>.some (<>.after (<text>.this "&&")
                             (<text>.enclosed ["[" "]"]
                                              ..re_user_class^')))]
    (in (list#mix (function (_ refinement base)
                    (` ((~! refine^) (~ refinement) (~ base))))
                  init
                  rest))))

(def: blank^
  (Parser Text)
  (<text>.one_of (format " " //.tab)))

(def: ascii^
  (Parser Text)
  (<text>.range (hex "0") (hex "7F")))

(def: control^
  (Parser Text)
  (<>.either (<text>.range (hex "0") (hex "1F"))
             (<text>.one_of (//.of_char (hex "7F")))))

(def: punct^
  (Parser Text)
  (<text>.one_of (format "!#$%&'()*+,-./:;<=>?@[\]^_`{|}~"
                         //.double_quote)))

(def: graph^
  (Parser Text)
  (<>.either punct^ <text>.alpha_num))

(def: print^
  (Parser Text)
  (<>.either graph^
             (<text>.one_of (//.of_char (hex "20")))))

(def: re_system_class^
  (Parser Code)
  (do <>.monad
    []
    (all <>.either
         (<>.after (<text>.this ".") (in (` (~! <text>.any))))
         (<>.after (<text>.this "\d") (in (` (~! <text>.decimal))))
         (<>.after (<text>.this "\D") (in (` ((~! <text>.not) (~! <text>.decimal)))))
         (<>.after (<text>.this "\s") (in (` (~! <text>.space))))
         (<>.after (<text>.this "\S") (in (` ((~! <text>.not) (~! <text>.space)))))
         (<>.after (<text>.this "\w") (in (` (~! word^))))
         (<>.after (<text>.this "\W") (in (` ((~! <text>.not) (~! word^)))))

         (<>.after (<text>.this "\p{Lower}") (in (` (~! <text>.lower))))
         (<>.after (<text>.this "\p{Upper}") (in (` (~! <text>.upper))))
         (<>.after (<text>.this "\p{Alpha}") (in (` (~! <text>.alpha))))
         (<>.after (<text>.this "\p{Digit}") (in (` (~! <text>.decimal))))
         (<>.after (<text>.this "\p{Alnum}") (in (` (~! <text>.alpha_num))))
         (<>.after (<text>.this "\p{Space}") (in (` (~! <text>.space))))
         (<>.after (<text>.this "\p{HexDigit}") (in (` (~! <text>.hexadecimal))))
         (<>.after (<text>.this "\p{OctDigit}") (in (` (~! <text>.octal))))
         (<>.after (<text>.this "\p{Blank}") (in (` (~! blank^))))
         (<>.after (<text>.this "\p{ASCII}") (in (` (~! ascii^))))
         (<>.after (<text>.this "\p{Contrl}") (in (` (~! control^))))
         (<>.after (<text>.this "\p{Punct}") (in (` (~! punct^))))
         (<>.after (<text>.this "\p{Graph}") (in (` (~! graph^))))
         (<>.after (<text>.this "\p{Print}") (in (` (~! print^))))
         )))

(def: re_class^
  (Parser Code)
  (<>.either re_system_class^
             (<text>.enclosed ["[" "]"] re_user_class^)))

(def: number^
  (Parser Nat)
  (|> (<text>.many <text>.decimal)
      (<>.codec n.decimal)))

(def: re_back_reference^
  (Parser Code)
  (<>.either (do <>.monad
               [_ (<text>.this "\")
                id number^]
               (in (` ((~! ..copy) (~ (code.symbol ["" (n#encoded id)]))))))
             (do <>.monad
               [_ (<text>.this "\k<")
                captured_symbol symbol_part^
                _ (<text>.this ">")]
               (in (` ((~! ..copy) (~ (code.symbol ["" captured_symbol]))))))))

(def: (re_simple^ current_module)
  (-> Text (Parser Code))
  (all <>.either
       re_class^
       (re_var^ current_module)
       re_back_reference^
       re_char^
       ))

(def: (re_simple_quantified^ current_module)
  (-> Text (Parser Code))
  (do <>.monad
    [base (re_simple^ current_module)
     quantifier (<text>.one_of "?*+")]
    (case quantifier
      "?"
      (in (` ((~! <>.else) "" (~ base))))
      
      "*"
      (in (` ((~! together^) ((~! <>.some) (~ base)))))
      
      ... "+"
      _
      (in (` ((~! together^) ((~! <>.many) (~ base)))))
      )))

(exception: .public (incorrect_quantification [from Nat
                                               to Nat])
  (exception.report
   "Input" (format (%.nat from) "," (%.nat to))
   "Should be" (format (%.nat to) "," (%.nat from))))

(def: (re_counted_quantified^ current_module)
  (-> Text (Parser Code))
  (do [! <>.monad]
    [base (re_simple^ current_module)]
    (<| (<text>.enclosed ["{" "}"])
        (all <>.either
             (do !
               [[from to] (<>.and number^ (<>.after (<text>.this ",") number^))
                _ (<>.assertion (exception.error ..incorrect_quantification [from to])
                                (n.<= to from))]
               (in (` ((~! together^) ((~! <>.between)
                                       (~ (code.nat from))
                                       (~ (code.nat (n.- from to)))
                                       (~ base))))))
             (do !
               [limit (<>.after (<text>.this ",") number^)]
               (in (` ((~! together^) ((~! <>.at_most) (~ (code.nat limit)) (~ base))))))
             (do !
               [limit (<>.before (<text>.this ",") number^)]
               (in (` ((~! together^) ((~! <>.at_least) (~ (code.nat limit)) (~ base))))))
             (do !
               [limit number^]
               (in (` ((~! together^) ((~! <>.exactly) (~ (code.nat limit)) (~ base))))))))))

(def: (re_quantified^ current_module)
  (-> Text (Parser Code))
  (<>.either (re_simple_quantified^ current_module)
             (re_counted_quantified^ current_module)))

(def: (re_complex^ current_module)
  (-> Text (Parser Code))
  (all <>.either
       (re_quantified^ current_module)
       (re_simple^ current_module)))

(type: Re_Group
  (Variant
   {#Non_Capturing}
   {#Capturing [(Maybe Text) Nat]}))

(def: (re_sequential^ capturing? re_scoped^ current_module)
  (-> Bit
      (-> Text (Parser [Re_Group Code]))
      Text
      (Parser [Nat Code]))
  (do <>.monad
    [parts (<>.many (<>.or (re_complex^ current_module)
                           (re_scoped^ current_module)))
     .let [g!total (code.symbol ["" "0total"])
           g!temp (code.symbol ["" "0temp"])
           [_ names steps] (list#mix (is (-> (Either Code [Re_Group Code])
                                             [Nat (List Code) (List (List Code))]
                                             [Nat (List Code) (List (List Code))])
                                         (function (_ part [idx names steps])
                                           (case part
                                             (^.or {.#Left complex}
                                                   {.#Right [{#Non_Capturing} complex]})
                                             [idx
                                              names
                                              (partial_list (list g!temp complex
                                                                  (` .let) (` [(~ g!total) (# (~! //.monoid) (~' composite) (~ g!total) (~ g!temp))]))
                                                            steps)]
                                             
                                             {.#Right [{#Capturing [?name num_captures]} scoped]}
                                             (let [[idx! name!] (case ?name
                                                                  {.#Some _name}
                                                                  [idx (code.symbol ["" _name])]

                                                                  {.#None}
                                                                  [(++ idx) (code.symbol ["" (n#encoded idx)])])
                                                   access (if (n.> 0 num_captures)
                                                            (` ((~! product.left) (~ name!)))
                                                            name!)]
                                               [idx!
                                                (partial_list name! names)
                                                (partial_list (list name! scoped
                                                                    (` .let) (` [(~ g!total) (# (~! //.monoid) (~' composite) (~ g!total) (~ access))]))
                                                              steps)])
                                             )))
                                     [0
                                      (is (List Code) (list))
                                      (is (List (List Code)) (list))]
                                     parts)]]
    (in [(if capturing?
           (list.size names)
           0)
         (` ((~! do) (~! <>.monad)
             [.let [(~ g!total) ""]
              (~+ (|> steps list.reversed list#conjoint))]
             ((~ (' in)) [(~ g!total) (~+ (list.reversed names))])))])
    ))

(def: (unflatten^ lexer)
  (-> (Parser Text) (Parser [Text Any]))
  (<>.and lexer (# <>.monad in [])))

(def: (|||^ left right)
  (All (_ l r) (-> (Parser [Text l]) (Parser [Text r]) (Parser [Text (Or l r)])))
  (function (_ input)
    (case (left input)
      {try.#Success [input' [lt lv]]}
      {try.#Success [input' [lt {0 #0 lv}]]}

      {try.#Failure _}
      (case (right input)
        {try.#Success [input' [rt rv]]}
        {try.#Success [input' [rt {0 #1 rv}]]}

        {try.#Failure error}
        {try.#Failure error}))))

(def: (|||_^ left right)
  (All (_ l r) (-> (Parser [Text l]) (Parser [Text r]) (Parser Text)))
  (function (_ input)
    (case (left input)
      {try.#Success [input' [lt lv]]}
      {try.#Success [input' lt]}

      {try.#Failure _}
      (case (right input)
        {try.#Success [input' [rt rv]]}
        {try.#Success [input' rt]}

        {try.#Failure error}
        {try.#Failure error}))))

(def: (prep_alternative [num_captures alt])
  (-> [Nat Code] Code)
  (if (n.> 0 num_captures)
    alt
    (` ((~! unflatten^) (~ alt)))))

(def: (re_alternative^ capturing? re_scoped^ current_module)
  (-> Bit
      (-> Text (Parser [Re_Group Code]))
      Text
      (Parser [Nat Code]))
  (do <>.monad
    [.let [sub^ (re_sequential^ capturing? re_scoped^ current_module)]
     head sub^
     tail (<>.some (<>.after (<text>.this "|") sub^))]
    (if (list.empty? tail)
      (in head)
      (in [(list#mix n.max (product.left head) (list#each product.left tail))
           (` (all ((~ (if capturing?
                         (` (~! |||^))
                         (` (~! |||_^)))))
                   (~ (prep_alternative head))
                   (~+ (list#each prep_alternative tail))))]))))

(def: (re_scoped^ current_module)
  (-> Text (Parser [Re_Group Code]))
  (all <>.either
       (do <>.monad
         [_ (<text>.this "(?:")
          [_ scoped] (re_alternative^ #0 re_scoped^ current_module)
          _ (<text>.this ")")]
         (in [{#Non_Capturing} scoped]))
       (do <>.monad
         [complex (re_complex^ current_module)]
         (in [{#Non_Capturing} complex]))
       (do <>.monad
         [_ (<text>.this "(?<")
          captured_symbol symbol_part^
          _ (<text>.this ">")
          [num_captures pattern] (re_alternative^ #1 re_scoped^ current_module)
          _ (<text>.this ")")]
         (in [{#Capturing [{.#Some captured_symbol} num_captures]} pattern]))
       (do <>.monad
         [_ (<text>.this "(")
          [num_captures pattern] (re_alternative^ #1 re_scoped^ current_module)
          _ (<text>.this ")")]
         (in [{#Capturing [{.#None} num_captures]} pattern]))))

(def: (regex^ current_module)
  (-> Text (Parser Code))
  (# <>.monad each product.right (re_alternative^ #1 re_scoped^ current_module)))

(syntax: .public (regex [pattern <code>.text])
  (do meta.monad
    [current_module meta.current_module_name]
    (case (<text>.result (regex^ current_module)
                         pattern)
      {try.#Failure error}
      (meta.failure (format "Error while parsing regular-expression:" //.new_line
                            error))

      {try.#Success regex}
      (in (list regex)))))

(syntax: .public (pattern [[pattern bindings] (<code>.form (<>.and <code>.text (<>.maybe <code>.any)))
                           body <code>.any
                           branches (<>.many <code>.any)])
  (with_symbols [g!temp]
    (in (partial_list (` (^.multi (~ g!temp)
                                  [((~! <text>.result) (..regex (~ (code.text pattern))) (~ g!temp))
                                   {try.#Success (~ (maybe.else g!temp bindings))}]))
                      body
                      branches))))