{-
This module is to be used for demonstration purposes only. For real applications you may consider the
uu-parsinglib package available from HackageDB
-}

module TooSimpleParseLib where
import Data.Functor
import Control.Applicative -- includes Alternative
import Data.Char

infixl  2 `opt`

-- | The type Parser

newtype Parser symbol result  = P {runParser :: [symbol] -> [(result, [symbol])]}

-- Parsers are instances of common classes
 
instance Functor (Parser s) where
  fmap f p = P $ \s -> [(f a, ss') | (a, ss') <- runParser p s]

instance Applicative (Parser s) where
  p <*> q = P $ \ss -> [ (b2a b, ss'') | (b2a,  ss')   <- runParser p ss
                                       , (b,    ss'')  <- runParser q ss'
                       ]
  pure a  = P $ \ss -> [(a, ss)]

instance Alternative (Parser s) where
  p <|> q  = P $ \ xs  ->  runParser p xs ++ runParser q xs
  empty    = P $ const []

pSym  ::  Eq s  =>  s -> Parser s s
pSym a  = P $ \ xs ->  case xs of
                       (x:xs') | x == a  ->  [(x, xs')]
                       _                 ->  []
 
pSatisfy  ::  (s -> Bool) -> Parser s s
pSatisfy p  = P $ \ xs ->  case xs of
                           (x:xs') | p x     -> [(x, xs')]
                           _                 -> []

pToken  ::  Eq s => [s] -> Parser s [s]
pToken k  = P $ \xs  -> let n = length k 
                        in if  k == take n xs  then  [(k,drop n xs)]
                                               else  []

-- Applications of elementary parsers

pDigit  :: Parser Char Char
pDigit  =  pSatisfy (\x -> ord '0' <= ord x && ord x <= ord '9')

pDigAsInt  :: Parser Char Int
pDigAsInt  =  (\c -> ord c - ord '0')  <$> pDigit

-- Some common

opt     :: Parser s a -> a -> Parser s a
opt p d  =  p <|> pure d

pPack        :: Parser s a -> Parser s b -> Parser s c -> Parser s b
pPack p r q  =  p *> r <* q 

pListSep      :: Parser s a -> Parser s b -> Parser s [a]
pListSep p s  =  (:) <$> p <*> many ( s *> p)

-- Auxiliary functions

determ  ::  Parser s b -> Parser s b
determ p = P $ \ xs -> let r = runParser p xs
                       in if  null r  then  [] else [head r]


-- Applications of EBNF combinators

pNatural  :: Parser Char Int
pNatural  =  foldl (\a b -> a*10 + b) 0 <$> some pDigAsInt

pInteger  ::  Parser Char Int
pInteger  =  ((negate <$ (pSym '-')) `opt` id ) <*>  pNatural 

pIdentifier :: Parser Char String
pIdentifier = (:) <$> pSatisfy isAlpha <*> many (pSatisfy isAlphaNum)

pParens p  =  pPack  (pSym '(') p (pSym ')')

pCommaList    :: Parser Char a -> Parser Char [a]
pCommaList p  =  pListSep p (pSym ',')

pSequence         :: [Parser s a] -> Parser s [a]
pSequence []      =  pure []
pSequence (p:ps)  =  (:) <$> p <*> pSequence ps


choice  :: [Parser s a] -> Parser s a
choice  =  foldr (<|>) empty