path: root/stdlib/source/library/lux/control/parser.lux

(.module:
  [library
   [lux (#- or and not)
    [abstract
     [functor (#+ Functor)]
     [apply (#+ Apply)]
     [monad (#+ Monad do)]
     [codec (#+ Codec)]]
    [control
     ["." try (#+ Try)]]
    [data
     ["." product]
     [collection
      ["." list ("#\." functor monoid)]]]
    [math
     [number
      ["n" nat]]]]])

(type: .public (Parser s a)
  {#.doc "A generic parser."}
  (-> s (Try [s a])))

(implementation: .public functor
  (All [s] (Functor (Parser s)))
  
  (def: (map f ma)
    (function (_ input)
      (case (ma input)
        (#try.Failure msg)
        (#try.Failure msg)

        (#try.Success [input' a])
        (#try.Success [input' (f a)])))))

(implementation: .public apply
  (All [s] (Apply (Parser s)))
  
  (def: &functor ..functor)

  (def: (apply ff fa)
    (function (_ input)
      (case (ff input)
        (#try.Success [input' f])
        (case (fa input')
          (#try.Success [input'' a])
          (#try.Success [input'' (f a)])

          (#try.Failure msg)
          (#try.Failure msg))

        (#try.Failure msg)
        (#try.Failure msg)))))

(implementation: .public monad
  (All [s] (Monad (Parser s)))
  
  (def: &functor ..functor)

  (def: (in x)
    (function (_ input)
      (#try.Success [input x])))

  (def: (join mma)
    (function (_ input)
      (case (mma input)
        (#try.Failure msg)
        (#try.Failure msg)

        (#try.Success [input' ma])
        (ma input')))))

(def: .public (assertion message test)
  {#.doc "Fails with the given message if the test is #0."}
  (All [s] (-> Text Bit (Parser s Any)))
  (function (_ input)
    (if test
      (#try.Success [input []])
      (#try.Failure message))))

(def: .public (maybe parser)
  {#.doc "Optionality combinator."}
  (All [s a]
    (-> (Parser s a) (Parser s (Maybe a))))
  (function (_ input)
    (case (parser input)
      (#try.Failure _)
      (#try.Success [input #.None])
      
      (#try.Success [input' x])
      (#try.Success [input' (#.Some x)]))))

(def: .public (run parser input)
  {#.doc (doc "Executes the parser on the input."
              "Does not verify that all of the input has been consumed by the parser."
              "Returns both the parser's output, and a value that represents the remaining input.")}
  (All [s a]
    (-> (Parser s a) s (Try [s a])))
  (parser input))

(def: .public (and first second)
  {#.doc "Sequencing combinator."}
  (All [s a b]
    (-> (Parser s a) (Parser s b) (Parser s [a b])))
  (do {! ..monad}
    [head first]
    (\ ! map (|>> [head]) second)))

(def: .public (or left right)
  {#.doc "Heterogeneous alternative combinator."}
  (All [s a b]
    (-> (Parser s a) (Parser s b) (Parser s (Or a b))))
  (function (_ tokens)
    (case (left tokens)
      (#try.Success [tokens' output])
      (#try.Success [tokens' (0 #0 output)])
      
      (#try.Failure _)
      (case (right tokens)
        (#try.Success [tokens' output])
        (#try.Success [tokens' (0 #1 output)])
        
        (#try.Failure error)
        (#try.Failure error)))))

(def: .public (either this that)
  {#.doc "Homogeneous alternative combinator."}
  (All [s a]
    (-> (Parser s a) (Parser s a) (Parser s a)))
  (function (_ tokens)
    (case (this tokens)
      (#try.Failure _)
      (that tokens)
      
      output
      output)))

(def: .public (some parser)
  {#.doc "0-or-more combinator."}
  (All [s a]
    (-> (Parser s a) (Parser s (List a))))
  (function (_ input)
    (case (parser input)
      (#try.Failure _)
      (#try.Success [input (list)])

      (#try.Success [input' head])
      (..run (\ ..monad map (|>> (list& head))
                (some parser))
             input'))))

(def: .public (many parser)
  {#.doc "1-or-more combinator."}
  (All [s a]
    (-> (Parser s a) (Parser s (List a))))
  (|> (..some parser)
      (..and parser)
      (\ ..monad map (|>> #.Item))))

(def: .public (exactly amount parser)
  {#.doc "Parse exactly N times."}
  (All [s a] (-> Nat (Parser s a) (Parser s (List a))))
  (case amount
    0 (\ ..monad in (list))
    _ (do {! ..monad}
        [x parser]
        (|> parser
            (exactly (dec amount))
            (\ ! map (|>> (#.Item x)))))))

(def: .public (at_least amount parser)
  {#.doc "Parse at least N times."}
  (All [s a] (-> Nat (Parser s a) (Parser s (List a))))
  (do {! ..monad}
    [minimum (..exactly amount parser)]
    (\ ! map (list\compose minimum) (..some parser))))

(def: .public (at_most amount parser)
  {#.doc "Parse at most N times."}
  (All [s a] (-> Nat (Parser s a) (Parser s (List a))))
  (case amount
    0 (\ ..monad in (list))
    _ (function (_ input)
        (case (parser input)
          (#try.Failure msg)
          (#try.Success [input (list)])

          (#try.Success [input' x])
          (..run (\ ..monad map (|>> (#.Item x))
                    (at_most (dec amount) parser))
                 input')))))

(def: .public (between minimum additional parser)
  (All [s a] (-> Nat Nat (Parser s a) (Parser s (List a))))
  (do {! ..monad}
    [minimum (..exactly minimum parser)]
    (case additional
      0 (in minimum)
      _ (\ ! map (list\compose minimum)
           (..at_most additional parser)))))

(def: .public (separated_by separator parser)
  {#.doc "Parses instances of 'parser' that are separated by instances of 'separator'."}
  (All [s a b] (-> (Parser s b) (Parser s a) (Parser s (List a))))
  (do {! ..monad}
    [?x (..maybe parser)]
    (case ?x
      #.None
      (in #.End)
      
      (#.Some x)
      (|> parser
          (..and separator)
          ..some
          (\ ! map (|>> (list\map product.right) (#.Item x)))))))

(def: .public (not parser)
  {#.doc (doc "Only succeeds when the underlying parser fails.")}
  (All [s a] (-> (Parser s a) (Parser s Any)))
  (function (_ input)
    (case (parser input)
      (#try.Failure msg)
      (#try.Success [input []])
      
      _
      (#try.Failure "Expected to fail; yet succeeded."))))

(def: .public (failure message)
  {#.doc (doc "Always fail with this 'message'.")}
  (All [s a] (-> Text (Parser s a)))
  (function (_ input)
    (#try.Failure message)))

(def: .public (lift operation)
  {#.doc (doc "Lift a potentially failed computation into a parser.")}
  (All [s a] (-> (Try a) (Parser s a)))
  (function (_ input)
    (case operation
      (#try.Success output)
      (#try.Success [input output])
      
      (#try.Failure error)
      (#try.Failure error))))

(def: .public (else value parser)
  {#.doc "If the given parser fails, returns the default value."}
  (All [s a] (-> a (Parser s a) (Parser s a)))
  (function (_ input)
    (case (parser input)
      (#try.Failure error)
      (#try.Success [input value])

      (#try.Success [input' output])
      (#try.Success [input' output]))))

(def: .public remaining
  {#.doc (doc "Yield the remaining input (without consuming it).")}
  (All [s] (Parser s s))
  (function (_ inputs)
    (#try.Success [inputs inputs])))

(def: .public (rec parser)
  {#.doc "Combinator for recursive parsers."}
  (All [s a] (-> (-> (Parser s a) (Parser s a)) (Parser s a)))
  (function (_ inputs)
    (..run (parser (rec parser)) inputs)))

(def: .public (after param subject)
  {#.doc (doc "Run the parser after another one (whose output is ignored).")}
  (All [s _ a] (-> (Parser s _) (Parser s a) (Parser s a)))
  (do ..monad
    [_ param]
    subject))

(def: .public (before param subject)
  {#.doc (doc "Run the parser before another one (whose output is ignored).")}
  (All [s _ a] (-> (Parser s _) (Parser s a) (Parser s a)))
  (do ..monad
    [output subject
     _ param]
    (in output)))

(def: .public (only test parser)
  {#.doc (doc "Only succeed when the parser's output passes a test.")}
  (All [s a] (-> (-> a Bit) (Parser s a) (Parser s a)))
  (do ..monad
    [output parser
     _ (..assertion "Constraint failed." (test output))]
    (in output)))

(def: .public (parses? parser)
  {#.doc (doc "Ignore a parser's output and just verify that it succeeds.")}
  (All [s a] (-> (Parser s a) (Parser s Bit)))
  (function (_ input)
    (case (parser input)
      (#try.Failure error)
      (#try.Success [input false])

      (#try.Success [input' _])
      (#try.Success [input' true]))))

(def: .public (parses parser)
  {#.doc (doc "Ignore a parser's output and just execute it.")}
  (All [s a] (-> (Parser s a) (Parser s Any)))
  (function (_ input)
    (case (parser input)
      (#try.Failure error)
      (#try.Failure error)

      (#try.Success [input' _])
      (#try.Success [input' []]))))

(def: .public (speculative parser)
  {#.doc (doc "Executes a parser, without actually consuming the input."
              "That way, the same input can be consumed again by another parser.")}
  (All [s a] (-> (Parser s a) (Parser s a)))
  (function (_ input)
    (case (parser input)
      (#try.Success [input' output])
      (#try.Success [input output])

      output
      output)))

(def: .public (codec codec parser)
  {#.doc (doc "Decode the output of a parser using a codec.")}
  (All [s a z] (-> (Codec a z) (Parser s a) (Parser s z)))
  (function (_ input)
    (case (parser input)
      (#try.Failure error)
      (#try.Failure error)

      (#try.Success [input' to_decode])
      (case (\ codec decode to_decode)
        (#try.Failure error)
        (#try.Failure error)
        
        (#try.Success value)
        (#try.Success [input' value])))))