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