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

(.module:
  [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: #export (Parser s a)
  {#.doc "A generic parser."}
  (-> s (Try [s a])))

(implementation: #export 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: #export 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: #export monad
  (All [s] (Monad (Parser s)))
  
  (def: &functor ..functor)

  (def: (wrap 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: #export (assert 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: #export (maybe p)
  {#.doc "Optionality combinator."}
  (All [s a]
    (-> (Parser s a) (Parser s (Maybe a))))
  (function (_ input)
    (case (p input)
      (#try.Failure _)
      (#try.Success [input #.None])
      
      (#try.Success [input' x])
      (#try.Success [input' (#.Some x)]))))

(def: #export (run p input)
  (All [s a]
    (-> (Parser s a) s (Try [s a])))
  (p input))

(def: #export (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: #export (many parser)
  {#.doc "1-or-more combinator."}
  (All [s a]
    (-> (Parser s a) (Parser s (List a))))
  (do {! ..monad}
    [head parser]
    (\ ! map (|>> (list& head))
       (some parser))))

(def: #export (and p1 p2)
  {#.doc "Sequencing combinator."}
  (All [s a b]
    (-> (Parser s a) (Parser s b) (Parser s [a b])))
  (do ..monad
    [x1 p1
     x2 p2]
    (wrap [x1 x2])))

(def: #export (or p1 p2)
  {#.doc "Heterogeneous alternative combinator."}
  (All [s a b]
    (-> (Parser s a) (Parser s b) (Parser s (| a b))))
  (function (_ tokens)
    (case (p1 tokens)
      (#try.Success [tokens' x1])
      (#try.Success [tokens' (0 #0 x1)])
      
      (#try.Failure _)
      (run (do ..monad
             [x2 p2]
             (wrap (0 #1 x2)))
           tokens)
      )))

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

(def: #export (exactly n p)
  {#.doc "Parse exactly N times."}
  (All [s a] (-> Nat (Parser s a) (Parser s (List a))))
  (if (n.> 0 n)
    (do ..monad
      [x p
       xs (exactly (dec n) p)]
      (wrap (#.Cons x xs)))
    (\ ..monad wrap (list))))

(def: #export (at_least n p)
  {#.doc "Parse at least N times."}
  (All [s a] (-> Nat (Parser s a) (Parser s (List a))))
  (do ..monad
    [min (exactly n p)
     extra (some p)]
    (wrap (list\compose min extra))))

(def: #export (at_most n p)
  {#.doc "Parse at most N times."}
  (All [s a] (-> Nat (Parser s a) (Parser s (List a))))
  (if (n.> 0 n)
    (function (_ input)
      (case (p input)
        (#try.Failure msg)
        (#try.Success [input (list)])

        (#try.Success [input' x])
        (run (do ..monad
               [xs (at_most (dec n) p)]
               (wrap (#.Cons x xs)))
             input')
        ))
    (\ ..monad wrap (list))))

(def: #export (between from to p)
  {#.doc "Parse between N and M times."}
  (All [s a] (-> Nat Nat (Parser s a) (Parser s (List a))))
  (do ..monad
    [min_xs (exactly from p)
     max_xs (at_most (n.- from to) p)]
    (wrap (\ list.monad join (list min_xs max_xs)))))

(def: #export (sep_by sep p)
  {#.doc "Parsers instances of 'p' that are separated by instances of 'sep'."}
  (All [s a b] (-> (Parser s b) (Parser s a) (Parser s (List a))))
  (do {! ..monad}
    [?x (maybe p)]
    (case ?x
      #.None
      (wrap #.Nil)
      
      (#.Some x)
      (do !
        [xs' (some (..and sep p))]
        (wrap (#.Cons x (list\map product.right xs'))))
      )))

(def: #export (not p)
  (All [s a] (-> (Parser s a) (Parser s Any)))
  (function (_ input)
    (case (p input)
      (#try.Failure msg)
      (#try.Success [input []])
      
      _
      (#try.Failure "Expected to fail; yet succeeded."))))

(def: #export (fail message)
  (All [s a] (-> Text (Parser s a)))
  (function (_ input)
    (#try.Failure message)))

(def: #export (lift operation)
  (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: #export (default 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: #export remaining
  (All [s] (Parser s s))
  (function (_ inputs)
    (#try.Success [inputs inputs])))

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

(def: #export (after param subject)
  (All [s _ a] (-> (Parser s _) (Parser s a) (Parser s a)))
  (do ..monad
    [_ param]
    subject))

(def: #export (before param subject)
  (All [s _ a] (-> (Parser s _) (Parser s a) (Parser s a)))
  (do ..monad
    [output subject
     _ param]
    (wrap output)))

(def: #export (filter test parser)
  (All [s a] (-> (-> a Bit) (Parser s a) (Parser s a)))
  (do ..monad
    [output parser
     _ (..assert "Constraint failed." (test output))]
    (wrap output)))

(def: #export (parses? parser)
  (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: #export (parses parser)
  (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: #export (speculative 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: #export (codec codec parser)
  (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])))))