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

(.module:
  [lux (#- or and not)
   [control
    [monad (#+ do Monad)]
    ["p" parser]]
   [data
    ["." text ("text/." Monoid<Text>)]
    ["." product]
    ["." maybe]
    ["e" error]
    [collection
     ["." list ("list/." Fold<List>)]]]
   [macro
    ["." code]]])

(type: Offset Nat)

(def: start-offset Offset 0)

(type: #export Lexer
  (p.Parser [Offset Text]))

(type: #export Slice
  {#basis Offset
   #distance Offset})

(def: (remaining offset tape)
  (-> Offset Text Text)
  (|> tape (text.split offset) maybe.assume product.right))

(def: cannot-lex-error Text "Cannot lex from empty text.")

(def: (unconsumed-input-error offset tape)
  (-> Offset Text Text)
  ($_ text/compose "Unconsumed input: " (remaining offset tape)))

(def: #export (run input lexer)
  (All [a] (-> Text (Lexer a) (e.Error a)))
  (case (lexer [start-offset input])
    (#e.Error msg)
    (#e.Error msg)
    
    (#e.Success [[end-offset _] output])
    (if (n/= end-offset (text.size input))
      (#e.Success output)
      (#e.Error (unconsumed-input-error end-offset input)))
    ))

(def: #export offset
  (Lexer Offset)
  (function (_ (^@ input [offset tape]))
    (#e.Success [input offset])))

(def: (with-slices lexer)
  (-> (Lexer (List Slice)) (Lexer Slice))
  (do p.Monad<Parser>
    [offset ..offset
     slices lexer]
    (wrap (list/fold (function (_ [slice::basis slice::distance]
                                  [total::basis total::distance])
                       [total::basis (n/+ slice::distance total::distance)])
                     {#basis offset
                      #distance 0}
                     slices))))

(def: #export any
  {#.doc "Just returns the next character without applying any logic."}
  (Lexer Text)
  (function (_ [offset tape])
    (case (text.nth offset tape)
      (#.Some output)
      (#e.Success [[(inc offset) tape] (text.from-code output)])

      _
      (#e.Error cannot-lex-error))))

(def: #export any!
  {#.doc "Just returns the next character without applying any logic."}
  (Lexer Slice)
  (function (_ [offset tape])
    (#e.Success [[(inc offset) tape]
                 {#basis offset
                  #distance 1}])))

(do-template [<name> <type> <any>]
  [(def: #export (<name> p)
     {#.doc "Produce a character if the lexer fails."}
     (All [a] (-> (Lexer a) (Lexer <type>)))
     (function (_ input)
       (case (p input)
         (#e.Error msg)
         (<any> input)
         
         _
         (#e.Error "Expected to fail; yet succeeded."))))]

  [not  Text  ..any]
  [not! Slice ..any!]
  )

(def: #export (this reference)
  {#.doc "Lex a text if it matches the given sample."}
  (-> Text (Lexer Any))
  (function (_ [offset tape])
    (case (text.index-of' reference offset tape)
      (#.Some where)
      (if (n/= offset where)
        (#e.Success [[(n/+ (text.size reference) offset) tape] []])
        (#e.Error ($_ text/compose "Could not match: " (text.encode reference) " @ " (maybe.assume (text.clip' offset tape)))))

      _
      (#e.Error ($_ text/compose "Could not match: " (text.encode reference))))))

(def: #export (this? reference)
  {#.doc "Lex a text if it matches the given sample."}
  (-> Text (Lexer Bit))
  (function (_ (^@ input [offset tape]))
    (case (text.index-of' reference offset tape)
      (^multi (#.Some where) (n/= offset where))
      (#e.Success [[(n/+ (text.size reference) offset) tape] #1])

      _
      (#e.Success [input #0]))))

(def: #export end
  {#.doc "Ensure the lexer's input is empty."}
  (Lexer Any)
  (function (_ (^@ input [offset tape]))
    (if (n/= offset (text.size tape))
      (#e.Success [input []])
      (#e.Error (unconsumed-input-error offset tape)))))

(def: #export end?
  {#.doc "Ask if the lexer's input is empty."}
  (Lexer Bit)
  (function (_ (^@ input [offset tape]))
    (#e.Success [input (n/= offset (text.size tape))])))

(def: #export peek
  {#.doc "Lex the next character (without consuming it from the input)."}
  (Lexer Text)
  (function (_ (^@ input [offset tape]))
    (case (text.nth offset tape)
      (#.Some output)
      (#e.Success [input (text.from-code output)])

      _
      (#e.Error cannot-lex-error))))

(def: #export get-input
  {#.doc "Get all of the remaining input (without consuming it)."}
  (Lexer Text)
  (function (_ (^@ input [offset tape]))
    (#e.Success [input (remaining offset tape)])))

(def: #export (range bottom top)
  {#.doc "Only lex characters within a range."}
  (-> Nat Nat (Lexer Text))
  (do p.Monad<Parser>
    [char any
     #let [char' (maybe.assume (text.nth 0 char))]
     _ (p.assert ($_ text/compose "Character is not within range: " (text.from-code bottom) "-" (text.from-code top))
                 (.and (n/>= bottom char')
                       (n/<= top char')))]
    (wrap char)))

(do-template [<name> <bottom> <top> <desc>]
  [(def: #export <name>
     {#.doc (code.text ($_ text/compose "Only lex " <desc> " characters."))}
     (Lexer Text)
     (range (char <bottom>) (char <top>)))]

  [upper   "A" "Z" "uppercase"]
  [lower   "a" "z" "lowercase"]
  [decimal "0" "9" "decimal"]
  [octal   "0" "7" "octal"]
  )

(def: #export alpha
  {#.doc "Only lex alphabetic characters."}
  (Lexer Text)
  (p.either lower upper))

(def: #export alpha-num
  {#.doc "Only lex alphanumeric characters."}
  (Lexer Text)
  (p.either alpha decimal))

(def: #export hexadecimal
  {#.doc "Only lex hexadecimal digits."}
  (Lexer Text)
  ($_ p.either
      decimal
      (range (char "a") (char "f"))
      (range (char "A") (char "F"))))

(do-template [<name> <description-modifier> <modifier>]
  [(def: #export (<name> options)
     {#.doc (code.text ($_ text/compose "Only lex characters that are" <description-modifier> " part of a piece of text."))}
     (-> Text (Lexer Text))
     (function (_ [offset tape])
       (case (text.nth offset tape)
         (#.Some output)
         (let [output (text.from-code output)]
           (if (<modifier> (text.contains? output options))
             (#e.Success [[(inc offset) tape] output])
             (#e.Error ($_ text/compose "Character (" output
                           ") is should " <description-modifier>
                           "be one of: " options))))

         _
         (#e.Error cannot-lex-error))))]

  [one-of  ""     |>]
  [none-of " not" .not]
  )

(do-template [<name> <description-modifier> <modifier>]
  [(def: #export (<name> options)
     {#.doc (code.text ($_ text/compose "Only lex characters that are" <description-modifier> " part of a piece of text."))}
     (-> Text (Lexer Slice))
     (function (_ [offset tape])
       (case (text.nth offset tape)
         (#.Some output)
         (let [output (text.from-code output)]
           (if (<modifier> (text.contains? output options))
             (#e.Success [[(inc offset) tape]
                          {#basis offset
                           #distance 1}])
             (#e.Error ($_ text/compose "Character (" output
                           ") is should " <description-modifier>
                           "be one of: " options))))

         _
         (#e.Error cannot-lex-error))))]

  [one-of!  ""     |>]
  [none-of! " not" .not]
  )

(def: #export (satisfies p)
  {#.doc "Only lex characters that satisfy a predicate."}
  (-> (-> Nat Bit) (Lexer Text))
  (function (_ [offset tape])
    (case (text.nth offset tape)
      (#.Some output)
      (if (p output)
        (#e.Success [[(inc offset) tape] (text.from-code output)])
        (#e.Error ($_ text/compose "Character does not satisfy predicate: " (text.from-code output))))

      _
      (#e.Error cannot-lex-error))))

(def: #export space
  {#.doc "Only lex white-space."}
  (Lexer Text)
  (satisfies text.space?))

(def: #export (and left right)
  (-> (Lexer Text) (Lexer Text) (Lexer Text))
  (do p.Monad<Parser>
    [=left left
     =right right]
    (wrap ($_ text/compose =left =right))))

(def: #export (and! left right)
  (-> (Lexer Slice) (Lexer Slice) (Lexer Slice))
  (do p.Monad<Parser>
    [[left::basis left::distance] left
     [right::basis right::distance] right]
    (wrap [left::basis (n/+ right::distance right::distance)])))

(do-template [<name> <base> <doc-modifier>]
  [(def: #export (<name> lexer)
     {#.doc (code.text ($_ text/compose "Lex " <doc-modifier> " characters as a single continuous text."))}
     (-> (Lexer Text) (Lexer Text))
     (|> lexer <base> (:: p.Monad<Parser> map text.concat)))]

  [some p.some "some"]
  [many p.many "many"]
  )

(do-template [<name> <base> <doc-modifier>]
  [(def: #export (<name> lexer)
     {#.doc (code.text ($_ text/compose "Lex " <doc-modifier> " characters as a single continuous text."))}
     (-> (Lexer Slice) (Lexer Slice))
     (with-slices (<base> lexer)))]

  [some! p.some "some"]
  [many! p.many "many"]
  )

(do-template [<name> <base> <doc-modifier>]
  [(def: #export (<name> amount lexer)
     {#.doc (code.text ($_ text/compose "Lex " <doc-modifier> " N characters."))}
     (-> Nat (Lexer Text) (Lexer Text))
     (|> lexer (<base> amount) (:: p.Monad<Parser> map text.concat)))]

  [exactly  p.exactly  "exactly"]
  [at-most  p.at-most  "at most"]
  [at-least p.at-least "at least"]
  )

(do-template [<name> <base> <doc-modifier>]
  [(def: #export (<name> amount lexer)
     {#.doc (code.text ($_ text/compose "Lex " <doc-modifier> " N characters."))}
     (-> Nat (Lexer Slice) (Lexer Slice))
     (with-slices (<base> amount lexer)))]

  [exactly!  p.exactly  "exactly"]
  [at-most!  p.at-most  "at most"]
  [at-least! p.at-least "at least"]
  )

(def: #export (between from to lexer)
  {#.doc "Lex between N and M characters."}
  (-> Nat Nat (Lexer Text) (Lexer Text))
  (|> lexer (p.between from to) (:: p.Monad<Parser> map text.concat)))

(def: #export (between! from to lexer)
  {#.doc "Lex between N and M characters."}
  (-> Nat Nat (Lexer Slice) (Lexer Slice))
  (with-slices (p.between from to lexer)))

(def: #export (enclosed [start end] lexer)
  (All [a] (-> [Text Text] (Lexer a) (Lexer a)))
  (|> lexer
      (p.before (this end))
      (p.after (this start))))

(def: #export (local local-input lexer)
  {#.doc "Run a lexer with the given input, instead of the real one."}
  (All [a] (-> Text (Lexer a) (Lexer a)))
  (function (_ real-input)
    (case (run local-input lexer)
      (#e.Error error)
      (#e.Error error)

      (#e.Success value)
      (#e.Success [real-input value]))))

(def: #export (slice lexer)
  (-> (Lexer Slice) (Lexer Text))
  (do p.Monad<Parser>
    [[basis distance] lexer]
    (function (_ (^@ input [offset tape]))
      (case (text.clip basis (n/+ basis distance) tape)
        (#.Some output)
        (#e.Success [input output])

        #.None
        (#e.Error "Cannot slice.")))))