module Example where

import Control.Monad(liftM, liftM2)
import Data.Char(isDigit)
import Test.QuickCheck(Arbitrary(arbitrary), Gen,
                       sized, elements, frequency, 
                       quickCheck, sample)
import Parsers(P, symbol, pfail, (+++), parse)

-- | 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.
pExpr :: P Char Expr
pExpr = 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 <- pExpr
  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

type Size = Int
-- Generating arbitrary expressions.
instance Arbitrary Expr where
  arbitrary = sized arb
    where
      digit :: Gen Int
      digit = elements [0..9]
      arb :: Size -> Gen Expr
      arb 0 = liftM Lit digit
      arb n = frequency $
        [ (1, arb 0) ] ++
        [ (4, liftM2 Plus arb2 arb2) | n > 0 ]
        where
          arb2 :: Gen Expr
          arb2 = arb (n `div` 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] == parseAll (show e)
  where
    -- Throw away incomplete parses
    parseAll :: String -> [Expr]
    parseAll s = [ x | (x, "") <- parse pExpr s ]
--    parseAll s = [ x | (x, _) <- parse pExpr s ]
-- Bad:   

run_tests = quickCheck prop_parse

main = run_tests