\documentclass{article}

\usepackage{verbatim}
\newenvironment{code}{\small\verbatim}{\endverbatim\normalsize}

\topmargin 0pt
\setlength{\voffset}{-29mm}
\setlength{\oddsidemargin}{0mm}
\setlength{\evensidemargin}{-5.5mm}
\setlength{\textwidth}{162mm}
\setlength{\textheight}{255mm}

%%% latex src/Parsing.lhs; dvips -t letter -Ppdf -z Parsing.dvi

\begin{document}
%
\section*{Parsing}

\begin{code}
module Parsing where

import qualified Char

infixl 3 <|>, <||>
infixl 4 <*>

type Parser s a = [s] -> [(a,[s])]

pSucceed :: a -> Parser s a
pFail    ::      Parser s a

pSucceed a input = [(a,input)]
pFail      input = []


pSym  :: Eq s => s -> Parser s s
pSym s (s':rest) = if s == s' then [(s,rest)] else []
pSym s [] = []

pSat	:: (s -> Bool) -> Parser s s
pSat p (s:rest) = if p s then [(s,rest)] else []
pSat p [] = []


(<|>), (<||>) :: Eq s => Parser s a        -> Parser s a -> Parser s a
(<*>) :: Eq s => Parser s (b -> a) -> Parser s b -> Parser s a

(p <|> q) input  = p input ++ q input
(p <||> q) input  = case p input of [] -> q input; r -> r

(p <*> q) input = [ (pv qv, rest)
                  | (pv   , qinput) <- p input
                  , (qv   , rest  ) <- q qinput
                  ]

infixl 4 <$>, <$, <*, *>, <**>, <??>, <?>
infixl 2 `opt`
infixl 4 <$$>

opt    :: Eq s => Parser s a  -> a                -> Parser s a
(<$  ) :: Eq s => a           -> Parser s b       -> Parser s a
(<*  ) :: Eq s => Parser s a  -> Parser s b       -> Parser s a
(  *>) :: Eq s => Parser s a  -> Parser s b       -> Parser s b
(<$$>) :: Eq s => Parser s b  ->          (b->a)  -> Parser s a
(<**>) :: Eq s => Parser s b  -> Parser s (b->a)  -> Parser s a
(<??>) :: Eq s => Parser s b  -> Parser s (b->b)  -> Parser s b

p `opt` v = p <|> pSucceed v
f <$> p   = pSucceed f      <*> p
f <$  p   = const f        <$> p
p <*  q   = (\ x _ -> x)   <$> p <*> q
p *>  q   = (\ _ x -> x)   <$> p <*> q
p <**> q  = (\ x f -> f x) <$> p <*> q
p <$$> f  = p              <**> pSucceed f
p <??> q  =                    p <**> (q `opt` id)


(<?>) :: Parser s a -> (a -> Maybe b) -> Parser s b 
p <?> f = \ s -> let presult = p s
                 in  do (a, r) <- presult
                        case f a of
                           Just b -> [(b, r)]
                           Nothing -> []

pFoldr         alg@(op,e)     p = pfm
   where pfm = (op <$> p <*> pfm)   `opt` e

pFoldr1        op             p = pfm
   where pfm = (op <$> p <*> pfm)   <|> p

pFoldrSep      alg@(op,e) sep p =
   (op <$> p <*> pFoldr alg (sep *> p)) `opt` e

pFoldr1Sep     op         sep p = (op <$> p <*> pFoldr1 op (sep *> p))
pFoldrPrefixed alg@(op,e) c   p = pFoldr alg (c *> p)
pFoldr1Prefixed op        c   p = pFoldr1 op (c *> p)

pList           p = pFoldr    ((:), [])   p
pListSep      s p = pFoldrSep ((:), []) s p
pListPrefixed c p = pFoldrPrefixed ((:),[]) c p

pSome p           = (:) <$> p <*> pList p
pSomeSep      s p = (:) <$> p <*> pListPrefixed s p
pSomePrefixed c p = let pp = c *> p in pSome pp
pChainr op x =  r where r = x <**> (flip <$> op <*> r `opt` id)
pChainl op x =  f <$> x <*> pList (flip <$> op <*> x)
               where
                 f x [] = x
                 f x (func:rest) = f (func x) rest

pPacked l r x   =   l *>  x <*   r

pAnyOf :: Eq s => [s] -> Parser s s
pAnyOf = foldr (<|>) pFail . map pSym


pWhile p = q
 where q = (pSat p <$$> (:) <*> q) <||> pSucceed []

pFoldrX         alg@(op,e)     p = pfm
   where pfm = (op <$> p <*> pfm)   <||> pSucceed e

pFoldrXSep      alg@(op,e) sep p =
   (op <$> p <*> pFoldrX alg (sep *> p)) <||> pSucceed e


pListX           p = pFoldrX  ((:), [])   p

pListXSep  sep   p = pFoldrXSep  ((:), []) sep p

spaces :: Parser Char String
spaces = pWhile Char.isSpace

spacedSym x = spaces <* pSym x *> spaces
comma = spacedSym ','

commaList p = pListXSep comma p

pTriple :: Parser Char a -> Parser Char b -> Parser Char c -> Parser Char (a,b,c)
pTriple p1 p2 p3 =
  pSym '(' *> spaces *>
  (
  (\ x1 x2 x3 -> (x1,x2,x3)) <$>
  p1 <* comma <*>
  p2 <* comma <*>
  p3 <* spaces <* pSym ')'
  )
\end{code}

\section*{Tree Parsing}


Binary tree data type:

\begin{code}
data Tree = Leaf Char | Bin Tree Tree  deriving Show
\end{code}

\noindent
Tree parser using the elementary parsing combinators:

\begin{code}
pTree1 =         pSucceed Leaf
             <*> pDigit1
         <|>     pSucceed (\ _ left right _ -> Bin left right)
             <*> pSym '(' <*> pTree1 <*> pTree1 <*> pSym ')'

pDigit1 = foldr (<|>) pFail (map pSym "0123456789")
\end{code}

\noindent
Tree parser using the extended parsing combinators:

\begin{code}
pTree2 =         Leaf <$> pDigit2
         <|>     pParens (Bin <$> pTree2 <*> pTree2)

pDigit2 = pAnyOf "0123456789"

pOParen = pSym '('
pCParen = pSym ')'
pParens = pPacked pOParen pCParen
\end{code}

\end{document}