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

(.module:
  [library
   [lux #*
    ["." meta]
    [abstract
     monad]
    [control
     ["." maybe]
     ["." try]
     ["." exception (#+ exception:)]
     ["<>" parser ("#\." monad)
      ["<.>" text (#+ Parser)]
      ["<.>" code]]]
    [data
     ["." product]
     [collection
      ["." list ("#\." fold monad)]]]
    [macro (#+ with_identifiers)
     [syntax (#+ syntax:)]
     ["." code]]
    [math
     [number (#+ hex)
      ["n" nat ("#\." decimal)]]]]]
  ["." //
   ["%" format (#+ 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: join_text^
  (-> (Parser (List Text)) (Parser Text))
  (\ <>.monad map //.together))

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

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

(def: (name^ current_module)
  (-> Text (Parser Name))
  ($_ <>.either
      (<>.and (<>\in current_module) (<>.after (<text>.this "..") name_part^))
      (<>.and name_part^ (<>.after (<text>.this ".") name_part^))
      (<>.and (<>\in .prelude_module) (<>.after (<text>.this ".") name_part^))
      (<>.and (<>\in "") name_part^)))

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

(def: re_range^
  (Parser Code)
  (do {! <>.monad}
    [from (|> regex_char^ (\ ! map (|>> (//.char 0) maybe.trusted)))
     _ (<text>.this "-")
     to (|> regex_char^ (\ ! map (|>> (//.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 ($_ <>.either
                        re_range^
                        re_options^))]
    (in (case negate?
          (#.Some _) (` ((~! <text>.not) ($_ ((~! <>.either)) (~+ parts))))
          #.None     (` ($_ ((~! <>.either)) (~+ parts)))))))

(def: re_user_class^
  (Parser Code)
  (do <>.monad
    [_ (in [])
     init re_user_class^'
     rest (<>.some (<>.after (<text>.this "&&") (<text>.enclosed ["[" "]"] re_user_class^')))]
    (in (list\fold (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
    []
    ($_ <>.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.identifier ["" (n\encode id)]))))))
             (do <>.monad
               [_ (<text>.this "\k<")
                captured_name name_part^
                _ (<text>.this ">")]
               (in (` ((~! ..copy) (~ (code.identifier ["" captured_name]))))))))

(def: (re_simple^ current_module)
  (-> Text (Parser Code))
  ($_ <>.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 (` ((~! join_text^) ((~! <>.some) (~ base)))))
      
      ... "+"
      _
      (in (` ((~! join_text^) ((~! <>.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 ["{" "}"])
        ($_ <>.either
            (do !
              [[from to] (<>.and number^ (<>.after (<text>.this ",") number^))
               _ (<>.assertion (exception.error ..incorrect_quantification [from to])
                               (n.<= to from))]
              (in (` ((~! join_text^) ((~! <>.between)
                                       (~ (code.nat from))
                                       (~ (code.nat (n.- from to)))
                                       (~ base))))))
            (do !
              [limit (<>.after (<text>.this ",") number^)]
              (in (` ((~! join_text^) ((~! <>.at_most) (~ (code.nat limit)) (~ base))))))
            (do !
              [limit (<>.before (<text>.this ",") number^)]
              (in (` ((~! join_text^) ((~! <>.at_least) (~ (code.nat limit)) (~ base))))))
            (do !
              [limit number^]
              (in (` ((~! join_text^) ((~! <>.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))
  ($_ <>.either
      (re_quantified^ current_module)
      (re_simple^ current_module)))

(type: Re_Group
  #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.identifier ["" "0total"])
           g!temp (code.identifier ["" "0temp"])
           [_ names steps] (list\fold (: (-> (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
                                              (list& (list g!temp complex
                                                           (` .let) (` [(~ g!total) (\ (~! //.monoid) (~' compose) (~ g!total) (~ g!temp))]))
                                                     steps)]
                                             
                                             (#.Right [(#Capturing [?name num_captures]) scoped])
                                             (let [[idx! name!] (case ?name
                                                                  (#.Some _name)
                                                                  [idx (code.identifier ["" _name])]

                                                                  #.None
                                                                  [(++ idx) (code.identifier ["" (n\encode idx)])])
                                                   access (if (n.> 0 num_captures)
                                                            (` ((~! product.left) (~ name!)))
                                                            name!)]
                                               [idx!
                                                (list& name! names)
                                                (list& (list name! scoped
                                                             (` .let) (` [(~ g!total) (\ (~! //.monoid) (~' compose) (~ g!total) (~ access))]))
                                                       steps)])
                                             )))
                                      [0
                                       (: (List Code) (list))
                                       (: (List (List Code)) (list))]
                                      parts)]]
    (in [(if capturing?
           (list.size names)
           0)
         (` ((~! do) (~! <>.monad)
             [.let [(~ g!total) ""]
              (~+ (|> steps list.reversed list\join))]
             ((~ (' 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\fold n.max (product.left head) (list\map product.left tail))
           (` ($_ ((~ (if capturing?
                        (` (~! |||^))
                        (` (~! |||_^)))))
                  (~ (prep_alternative head))
                  (~+ (list\map prep_alternative tail))))]))))

(def: (re_scoped^ current_module)
  (-> Text (Parser [Re_Group Code]))
  ($_ <>.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_name name_part^
         _ (<text>.this ">")
         [num_captures pattern] (re_alternative^ #1 re_scoped^ current_module)
         _ (<text>.this ")")]
        (in [(#Capturing [(#.Some captured_name) 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 map 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 (^regex [[pattern bindings] (<code>.form (<>.and <code>.text (<>.maybe <code>.any)))
                          body <code>.any
                          branches (<>.many <code>.any)])
  (with_identifiers [g!temp]
    (in (list& (` (^multi (~ g!temp)
                          {((~! <text>.result) (..regex (~ (code.text pattern))) (~ g!temp))
                           (#try.Success (~ (maybe.else g!temp bindings)))}))
               body
               branches))))