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)
  (-> s (Try [s a])))

(implementation: .public functor
  (All (_ s) (Functor (Parser s)))
  
  (def: (each 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: (on fa ff)
    (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: (conjoint mma)
    (function (_ input)
      (case (mma input)
        (#try.Failure msg)
        (#try.Failure msg)

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

(def: .public (assertion message test)
  (All (_ s) (-> Text Bit (Parser s Any)))
  (function (_ input)
    (if test
      (#try.Success [input []])
      (#try.Failure message))))

(def: .public (maybe parser)
  (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 (result parser input)
  (All (_ s a)
    (-> (Parser s a) s (Try [s a])))
  (parser input))

(def: .public (and first second)
  (All (_ s a b)
    (-> (Parser s a) (Parser s b) (Parser s [a b])))
  (do [! ..monad]
    [head first]
    (\ ! each (|>> [head]) second)))

(def: .public (or left right)
  (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)
  (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)
  (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])
      (..result (\ ..monad each (|>> (list& head))
                   (some parser))
                input'))))

(def: .public (many parser)
  (All (_ s a)
    (-> (Parser s a) (Parser s (List a))))
  (|> (..some parser)
      (..and parser)
      (\ ..monad each (|>> #.Item))))

(def: .public (exactly amount parser)
  (All (_ s a) (-> Nat (Parser s a) (Parser s (List a))))
  (case amount
    0 (\ ..monad in (list))
    _ (do [! ..monad]
        [x parser]
        (|> parser
            (exactly (-- amount))
            (\ ! each (|>> (#.Item x)))))))

(def: .public (at_least amount parser)
  (All (_ s a) (-> Nat (Parser s a) (Parser s (List a))))
  (do [! ..monad]
    [minimum (..exactly amount parser)]
    (\ ! each (list\composite minimum) (..some parser))))

(def: .public (at_most amount parser)
  (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])
          (..result (\ ..monad each (|>> (#.Item x))
                       (at_most (-- 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)
      _ (\ ! each (list\composite minimum)
           (..at_most additional parser)))))

(def: .public (separated_by separator parser)
  (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
          (\ ! each (|>> (list\each product.right) (#.Item x)))))))

(def: .public (not parser)
  (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)
  (All (_ s a) (-> Text (Parser s a)))
  (function (_ input)
    (#try.Failure message)))

(def: .public (lifted 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: .public (else value parser)
  (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
  (All (_ s) (Parser s s))
  (function (_ inputs)
    (#try.Success [inputs inputs])))

(def: .public (rec parser)
  (All (_ s a) (-> (-> (Parser s a) (Parser s a)) (Parser s a)))
  (function (_ inputs)
    (..result (parser (rec parser)) inputs)))

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

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

(def: .public (only test parser)
  (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)
  (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)
  (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)
  (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)
  (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 decoded to_decode)
        (#try.Failure error)
        (#try.Failure error)
        
        (#try.Success value)
        (#try.Success [input' value])))))