module Parsing where

import Data.Char

infixr 5 +++

-- Simple example of monadic parsing combinators

-- Essentially a cut down version of Hutton's monadic parser code
-- http://www.cs.nott.ac.uk/~gmh/Parsing.lhs

data Parser a = P (String -> Maybe (a,String))

parse :: Parser a -> String -> Maybe (a,String)
parse (P p) s = p s

-- Basic parsers

failure :: Parser a
failure = P $ \s -> Nothing

-- Choice operator 
-- Try to parse with the first parser. If it fails try the second.
(+++) :: Parser a -> Parser a -> Parser a
p +++ q = P $ \s ->  case parse p s of 
                        Nothing         -> parse q s 
                        (Just (v,rest)) -> Just (v,rest)  

-- Parse a single character
item :: Parser Char
item = P $ \s -> case s of 
                   ""     -> Nothing
                   (c:cs) -> Just (c,cs)
          

-- Parser as a monad.  return gives its result without consuming any
-- of the input string.  sequencing (p >>= f) parses the string with p
-- and passes the result value to f to give a second parser which is
-- then applied to the output string to give the result.

instance Monad Parser where
  return v = P $ \s -> Just (v,s)

  p >>= f  = P $ \s -> case parse p s of 
                        Just (a,rest) -> parse (f a) rest
                        Nothing       -> Nothing

-- Derived parsers --------------------------

sat :: (Char -> Bool) -> Parser Char
sat p = do 
          x <- item
          if p x then return x else failure

number :: Parser Char
number =  sat isDigit

char  :: Char -> Parser Char
char x =  sat (== x)

zeroOrMore, oneOrMore :: Parser a -> Parser [a]
zeroOrMore p = oneOrMore p +++ return []

oneOrMore p = do v <- p 
                 vs <- zeroOrMore p
                 return(v:vs)                

          
nat :: Parser Int
nat =  do xs <- oneOrMore (sat isDigit)
          return (read xs)

int :: Parser Int
int =  nat +++ 
       do char '-'
          n <- nat
          return (-n)


chain :: Parser a -> Char -> (a ->  a -> a) -> Parser a

chain p c f = do v <- p
                 vs <- zeroOrMore (char c >> p)
                 return (foldr1 f (v:vs))

{- -- recursive style alternative: 
chain p c f = do a <- p
                 do char c
                    rest <- chain p c f
                    return $ f a rest 
                   +++ return a
 -}