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

(.module:
  [lux #*
   [control
    monad
    ["p" parser ("parser/." Monad<Parser>)]]
   [data
    ["." product]
    ["e" error]
    ["." maybe]
    ["." number ("int/." Codec<Text,Int>)]
    ["." text
     ["l" lexer]
     format]
    [collection
     ["." list ("list/." Fold<List> Monad<List>)]]]
   ["." macro (#+ with-gensyms)
    ["." code]
    ["s" syntax (#+ syntax:)]]])

## [Utils]
(def: regex-char^
  (l.Lexer Text)
  (l.none-of "\\.|&()[]{}"))

(def: escaped-char^
  (l.Lexer Text)
  (do p.Monad<Parser>
    [? (l.this? "\\")]
    (if ?
      l.any
      regex-char^)))

(def: (refine^ refinement^ base^)
  (All [a] (-> (l.Lexer a) (l.Lexer Text) (l.Lexer Text)))
  (do p.Monad<Parser>
    [output base^
     _ (l.local output refinement^)]
    (wrap output)))

(def: word^
  (l.Lexer Text)
  (p.either l.alpha-num
            (l.one-of "_")))

(def: (copy reference)
  (-> Text (l.Lexer Text))
  (p.after (l.this reference) (parser/wrap reference)))

(def: (join-text^ part^)
  (-> (l.Lexer (List Text)) (l.Lexer Text))
  (do p.Monad<Parser>
    [parts part^]
    (wrap (text.join-with "" parts))))

(def: name-char^
  (l.Lexer Text)
  (l.none-of "[]{}()s\"#.<>"))

(def: name-part^
  (l.Lexer Text)
  (do p.Monad<Parser>
    [head (refine^ (l.not l.decimal)
                   name-char^)
     tail (l.some name-char^)]
    (wrap (format head tail))))

(def: (name^ current-module)
  (-> Text (l.Lexer Name))
  ($_ p.either
      (p.seq (parser/wrap current-module) (p.after (l.this "..") name-part^))
      (p.seq name-part^ (p.after (l.this ".") name-part^))
      (p.seq (parser/wrap "lux") (p.after (l.this ".") name-part^))
      (p.seq (parser/wrap "") name-part^)))

(def: (re-var^ current-module)
  (-> Text (l.Lexer Code))
  (do p.Monad<Parser>
    [name (l.enclosed ["\\@<" ">"] (name^ current-module))]
    (wrap (` (: (l.Lexer Text) (~ (code.identifier name)))))))

(def: re-range^
  (l.Lexer Code)
  (do p.Monad<Parser>
    [from (|> regex-char^ (:: @ map (|>> (text.nth +0) maybe.assume)))
     _ (l.this "-")
     to (|> regex-char^ (:: @ map (|>> (text.nth +0) maybe.assume)))]
    (wrap (` (l.range (~ (code.nat from)) (~ (code.nat to)))))))

(def: re-char^
  (l.Lexer Code)
  (do p.Monad<Parser>
    [char escaped-char^]
    (wrap (` ((~! ..copy) (~ (code.text char)))))))

(def: re-options^
  (l.Lexer Code)
  (do p.Monad<Parser>
    [options (l.many escaped-char^)]
    (wrap (` (l.one-of (~ (code.text options)))))))

(def: re-user-class^'
  (l.Lexer Code)
  (do p.Monad<Parser>
    [negate? (p.maybe (l.this "^"))
     parts (p.many ($_ p.either
                       re-range^
                       re-options^))]
    (wrap (case negate?
            (#.Some _) (` (l.not ($_ p.either (~+ parts))))
            #.None     (` ($_ p.either (~+ parts)))))))

(def: re-user-class^
  (l.Lexer Code)
  (do p.Monad<Parser>
    [_ (wrap [])
     init re-user-class^'
     rest (p.some (p.after (l.this "&&") (l.enclosed ["[" "]"] re-user-class^')))]
    (wrap (list/fold (function (_ refinement base)
                       (` ((~! refine^) (~ refinement) (~ base))))
                     init
                     rest))))

(def: blank^
  (l.Lexer Text)
  (l.one-of " \t"))

(def: ascii^
  (l.Lexer Text)
  (l.range (char "\u0000") (char "\u007F")))

(def: control^
  (l.Lexer Text)
  (p.either (l.range (char "\u0000") (char "\u001F"))
            (l.one-of "\u007F")))

(def: punct^
  (l.Lexer Text)
  (l.one-of "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~"))

(def: graph^
  (l.Lexer Text)
  (p.either punct^ l.alpha-num))

(def: print^
  (l.Lexer Text)
  (p.either graph^
            (l.one-of "\u0020")))

(def: re-system-class^
  (l.Lexer Code)
  (do p.Monad<Parser>
    []
    ($_ p.either
        (p.after (l.this ".") (wrap (` l.any)))
        (p.after (l.this "\\d") (wrap (` l.decimal)))
        (p.after (l.this "\\D") (wrap (` (l.not l.decimal))))
        (p.after (l.this "\\s") (wrap (` l.space)))
        (p.after (l.this "\\S") (wrap (` (l.not l.space))))
        (p.after (l.this "\\w") (wrap (` (~! word^))))
        (p.after (l.this "\\W") (wrap (` (l.not (~! word^)))))

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

(def: re-class^
  (l.Lexer Code)
  (p.either re-system-class^
            (l.enclosed ["[" "]"] re-user-class^)))

(def: number^
  (l.Lexer Nat)
  (|> (l.many l.decimal)
      (p.codec number.Codec<Text,Int>)
      (parser/map .nat)))

(def: re-back-reference^
  (l.Lexer Code)
  (p.either (do p.Monad<Parser>
              [_ (l.this "\\")
               id number^]
              (wrap (` ((~! ..copy) (~ (code.identifier ["" (int/encode (.int id))]))))))
            (do p.Monad<Parser>
              [_ (l.this "\\k<")
               captured-name name-part^
               _ (l.this ">")]
              (wrap (` ((~! ..copy) (~ (code.identifier ["" captured-name]))))))))

(def: (re-simple^ current-module)
  (-> Text (l.Lexer Code))
  ($_ p.either
      re-class^
      (re-var^ current-module)
      re-back-reference^
      re-char^
      ))

(def: (re-simple-quantified^ current-module)
  (-> Text (l.Lexer Code))
  (do p.Monad<Parser>
    [base (re-simple^ current-module)
     quantifier (l.one-of "?*+")]
    (case quantifier
      "?"
      (wrap (` (p.default "" (~ base))))
      
      "*"
      (wrap (` ((~! join-text^) (p.some (~ base)))))
      
      ## "+"
      _
      (wrap (` ((~! join-text^) (p.many (~ base)))))
      )))

(def: (re-counted-quantified^ current-module)
  (-> Text (l.Lexer Code))
  (do p.Monad<Parser>
    [base (re-simple^ current-module)]
    (l.enclosed ["{" "}"]
                ($_ p.either
                    (do @
                      [[from to] (p.seq number^ (p.after (l.this ",") number^))]
                      (wrap (` ((~! join-text^) (p.between (~ (code.nat from))
                                                           (~ (code.nat to))
                                                           (~ base))))))
                    (do @
                      [limit (p.after (l.this ",") number^)]
                      (wrap (` ((~! join-text^) (p.at-most (~ (code.nat limit)) (~ base))))))
                    (do @
                      [limit (p.before (l.this ",") number^)]
                      (wrap (` ((~! join-text^) (p.at-least (~ (code.nat limit)) (~ base))))))
                    (do @
                      [limit number^]
                      (wrap (` ((~! join-text^) (p.exactly (~ (code.nat limit)) (~ base))))))))))

(def: (re-quantified^ current-module)
  (-> Text (l.Lexer Code))
  (p.either (re-simple-quantified^ current-module)
            (re-counted-quantified^ current-module)))

(def: (re-complex^ current-module)
  (-> Text (l.Lexer Code))
  ($_ p.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 (l.Lexer [Re-Group Code]))
      Text
      (l.Lexer [Nat Code]))
  (do p.Monad<Parser>
    [parts (p.many (p.alt (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])
                                             [Int (List Code) (List (List Code))]
                                             [Int (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) (:: (~! text.Monoid<Text>) (~' compose) (~ g!total) (~ g!temp))]))
                                                     steps)]
                                             
                                             (#.Right [(#Capturing [?name num-captures]) scoped])
                                             (let [[idx! name!] (case ?name
                                                                  (#.Some _name)
                                                                  [idx (code.identifier ["" _name])]

                                                                  #.None
                                                                  [(inc idx) (code.identifier ["" (int/encode idx)])])
                                                   access (if (n/> +0 num-captures)
                                                            (` ((~! product.left) (~ name!)))
                                                            name!)]
                                               [idx!
                                                (list& name! names)
                                                (list& (list name! scoped
                                                             (' #let) (` [(~ g!total) (:: (~! text.Monoid<Text>) (~' compose) (~ g!total) (~ access))]))
                                                       steps)])
                                             )))
                                      [0
                                       (: (List Code) (list))
                                       (: (List (List Code)) (list))]
                                      parts)]]
    (wrap [(if capturing?
             (list.size names)
             +0)
           (` (do p.Monad<Parser>
                [(~ (' #let)) [(~ g!total) ""]
                 (~+ (|> steps list.reverse list/join))]
                ((~ (' wrap)) [(~ g!total) (~+ (list.reverse names))])))])
    ))

(def: (unflatten^ lexer)
  (-> (l.Lexer Text) (l.Lexer [Text Any]))
  (p.seq lexer (:: p.Monad<Parser> wrap [])))

(def: (|||^ left right)
  (All [l r] (-> (l.Lexer [Text l]) (l.Lexer [Text r]) (l.Lexer [Text (| l r)])))
  (function (_ input)
    (case (left input)
      (#e.Success [input' [lt lv]])
      (#e.Success [input' [lt (+0 lv)]])

      (#e.Error _)
      (case (right input)
        (#e.Success [input' [rt rv]])
        (#e.Success [input' [rt (+1 rv)]])

        (#e.Error error)
        (#e.Error error)))))

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

      (#e.Error _)
      (case (right input)
        (#e.Success [input' [rt rv]])
        (#e.Success [input' rt])

        (#e.Error error)
        (#e.Error 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 (l.Lexer [Re-Group Code]))
      Text
      (l.Lexer [Nat Code]))
  (do p.Monad<Parser>
    [#let [sub^ (re-sequential^ capturing? re-scoped^ current-module)]
     head sub^
     tail (p.some (p.after (l.this "|") sub^))
     #let [g!op (code.identifier ["" " alt "])]]
    (if (list.empty? tail)
      (wrap head)
      (wrap [(list/fold n/max (product.left head) (list/map product.left tail))
             (` (let [(~ g!op) (~ (if capturing?
                                    (` (~! |||^))
                                    (` (~! |||_^))))]
                  ($_ (~ g!op)
                      (~ (prep-alternative head))
                      (~+ (list/map prep-alternative tail)))))]))))

(def: (re-scoped^ current-module)
  (-> Text (l.Lexer [Re-Group Code]))
  ($_ p.either
      (do p.Monad<Parser>
        [_ (l.this "(?:")
         [_ scoped] (re-alternative^ #0 re-scoped^ current-module)
         _ (l.this ")")]
        (wrap [#Non-Capturing scoped]))
      (do p.Monad<Parser>
        [complex (re-complex^ current-module)]
        (wrap [#Non-Capturing complex]))
      (do p.Monad<Parser>
        [_ (l.this "(?<")
         captured-name name-part^
         _ (l.this ">")
         [num-captures pattern] (re-alternative^ #1 re-scoped^ current-module)
         _ (l.this ")")]
        (wrap [(#Capturing [(#.Some captured-name) num-captures]) pattern]))
      (do p.Monad<Parser>
        [_ (l.this "(")
         [num-captures pattern] (re-alternative^ #1 re-scoped^ current-module)
         _ (l.this ")")]
        (wrap [(#Capturing [#.None num-captures]) pattern]))))

(def: (regex^ current-module)
  (-> Text (l.Lexer Code))
  (:: p.Monad<Parser> map product.right (re-alternative^ #1 re-scoped^ current-module)))

## [Syntax]
(syntax: #export (regex {pattern s.text})
  {#.doc (doc "Create lexers using regular-expression syntax."
              "For example:"
              
              "Literals"
              (regex "a")
              
              "Wildcards"
              (regex ".")
              
              "Escaping"
              (regex "\\.")
              
              "Character classes"
              (regex "\\d")
              (regex "\\p{Lower}")
              (regex "[abc]")
              (regex "[a-z]")
              (regex "[a-zA-Z]")
              (regex "[a-z&&[def]]")
              
              "Negation"
              (regex "[^abc]")
              (regex "[^a-z]")
              (regex "[^a-zA-Z]")
              (regex "[a-z&&[^bc]]")
              (regex "[a-z&&[^m-p]]")
              
              "Combinations"
              (regex "aa")
              (regex "a?")
              (regex "a*")
              (regex "a+")
              
              "Specific amounts"
              (regex "a{2}")
              
              "At least"
              (regex "a{1,}")
              
              "At most"
              (regex "a{,1}")
              
              "Between"
              (regex "a{1,2}")
              
              "Groups"
              (regex "a(.)c")
              (regex "a(b+)c")
              (regex "(\\d{3})-(\\d{3})-(\\d{4})")
              (regex "(\\d{3})-(?:\\d{3})-(\\d{4})")
              (regex "(?<code>\\d{3})-\\k<code>-(\\d{4})")
              (regex "(?<code>\\d{3})-\\k<code>-(\\d{4})-\\0")
              (regex "(\\d{3})-((\\d{3})-(\\d{4}))")
              
              "Alternation"
              (regex "a|b")
              (regex "a(.)(.)|b(.)(.)")
              )}
  (do @
    [current-module macro.current-module-name]
    (case (|> (regex^ current-module)
              (p.before l.end)
              (l.run pattern))
      (#e.Error error)
      (macro.fail (format "Error while parsing regular-expression:\n"
                          error))

      (#e.Success regex)
      (wrap (list regex))
      )))

(syntax: #export (^regex {[pattern bindings] (s.form (p.seq s.text (p.maybe s.any)))}
                         body
                         {branches (p.many s.any)})
  {#.doc (doc "Allows you to test text against regular expressions."
              (case some-text
                (^regex "(\\d{3})-(\\d{3})-(\\d{4})"
                        [_ country-code area-code place-code])
                do-some-thing-when-number

                (^regex "\\w+")
                do-some-thing-when-word

                _
                do-something-else))}
  (with-gensyms [g!temp]
    (wrap (list& (` (^multi (~ g!temp)
                            [((~! l.run) (~ g!temp) (regex (~ (code.text pattern))))
                             (#e.Success (~ (maybe.default g!temp bindings)))]))
                 body
                 branches))))