module Example where

import Control.Monad
import Data.Char
import Test.QuickCheck
import Parsers

-- | Parse a symbol satisfying a given predicate.
sat :: (s -> Bool) -> P s s
sat p = do
  x <- symbol
  if p x then return x
         else pfail

-- | Parse a particular symbol.
this :: Eq s => s -> P s s
this x = sat (x ==)

-- | Parse a left associative operator carefully avoiding left recursion.
--   chainLeft Op T ::= E
--     where E ::= E Op T | T
chainLeft :: P s (a -> a -> a) -> P s a -> P s a
chainLeft op term = do
    e <- term
    chain e
  where
    chain e = return e +++ do
      o  <- op
      e' <- term
      chain (e `o` e')

-- | Parse a digit as a number.
digitP :: P Char Int
digitP = do
    c <- sat isDigit
    return (charToInt c)
  where
    charToInt c = fromEnum c - fromEnum '0'

-- | A simple expression type.
data Expr = Lit Int | Plus Expr Expr
  deriving Eq

-- | A parser for expressions.
exprP :: P Char Expr
exprP = chainLeft plusP termP
  where
    -- Parse the plus sign. Returns the 'Plus' function.
    plusP :: P Char (Expr -> Expr -> Expr)
    plusP = this '+' >> return Plus

termP :: P Char Expr
termP = liftM Lit digitP +++ do
  this '('
  e <- exprP
  this ')'
  return e

-- Tests

instance Show Expr where
  showsPrec p (Lit n)      = shows n
  showsPrec p (Plus e1 e2) = showParen (p > 0) $
    showsPrec 0 e1 . showString "+" . showsPrec 1 e2

-- Generating arbitrary expressions.
instance Arbitrary Expr where
  arbitrary = sized arb
    where
      digit = elements [0..9]
      arb 0 = liftM Lit digit
      arb n = frequency $
        [ (1, arb 0) ] ++
        [ (4, liftM2 Plus arb2 arb2) | n > 0 ]
        where
          arb2 = arb (div n 2)

-- | We test that showing and then parsing is the identity and that
--   the parse is unambiguous.
prop_parse :: Expr -> Bool
prop_parse e = [e] == parse' (show e)
  where
    -- Throw away incomplete parses
    parse' s = [ x | (x, "") <- parse exprP s ]

run_tests = quickCheck prop_parse