import Data.Char
import Data.Maybe
import Test.QuickCheck
import Test.QuickCheck.Gen

-------------------------------------------------------------------------
-- simple examples

prop_Reverse (Fixed xs) =
  reverse xs == (xs :: [Int])




















prop_UnwordsWords (Fixed s) =
  unwords (words s) == s














-------------------------------------------------------------------------
-- the expression datatype

data Expr
  = Num Int
  | Add Expr Expr
  | Mul Expr Expr
 deriving ( Eq )
 
-------------------------------------------------------------------------
-- parsing numbers

type Parser a = String -> Maybe (a,String)

number :: Parser Int
number (c:s) | isDigit c = Just (digits 0 (c:s))
number ('-':s)           = fmap negate' (number s)
number _                 = Nothing

negate' :: (Int,String) -> (Int,String)
negate' (n,s) = (-n,s)

digits :: Int -> String -> (Int,String)
digits n (c:s) | isDigit c = digits (10*n + digitToInt c) s
digits n s                 = (n,s)

num :: Parser Expr
num s =
  case number s of
    Just (n,s') -> Just (Num n, s')
    Nothing     -> Nothing

-------------------------------------------------------------------------
-- expr and term

{-
* an expression is a '+'-chain of terms
* a term is a '*'-chain of factors
-}

expr, term :: Parser Expr
expr = chain term   '+' Add
term = chain factor '*' Mul

{-
chain p op f s1 parsers a "chain" of things.
The things are parsed by the parser p.
The things are separated by the symbol op.
The things are combined by the function f.
For example,
  12+23+1+172
is a chain of numbers, separated by the symbol '+'.
-}

chain :: Parser a -> Char -> (a -> a -> a) -> Parser a
chain p op f s1 =
  case p s1 of
     Just (a,s2) -> case s2 of
                      c:s3 | c == op -> case chain p op f s3 of
                                          Just (b,s4) -> Just (f a b, s4)
                                          Nothing     -> Just (a,s2)
                      _              -> Just (a,s2)
     Nothing     -> Nothing

-------------------------------------------------------------------------
-- factor

factor :: Parser Expr
factor ('(':s) =
   case expr s of
      Just (a, ')':s1) -> Just (a, s1)
      _                -> Nothing
factor s = num s

-------------------------------------------------------------------------
-- reading expressions

readExpr :: String -> Maybe Expr
readExpr s =
  case expr s of
    Just (a,"") -> Just a
    _           -> Nothing

-------------------------------------------------------------------------
-- testing the parser

showExpr :: Expr -> String
showExpr (Num n)   = show n
showExpr (Add a b) = showExpr a ++ "+" ++ showExpr b
showExpr (Mul a b) = showFactor a ++ "*" ++ showFactor b

showFactor :: Expr -> String
showFactor (Add a b) = "(" ++ showExpr (Add a b) ++ ")"
showFactor e         = showExpr e

instance Show Expr where
  show = showExpr

-----------------------------------------------------------------------

instance Arbitrary Expr where
  arbitrary = sized arbExpr

  shrink (Num n)   = [ Num n' | n' <- shrink n ]
  shrink (Add a b) = [ a, b ]
                  ++ [ Add a' b | a' <- shrink a ]
                  ++ [ Add a b' | b' <- shrink b ]
  shrink (Mul a b) = [ a, b ]
                  ++ [ Mul a' b | a' <- shrink a ]
                  ++ [ Mul a b' | b' <- shrink b ]

arbExpr :: Int -> Gen Expr
arbExpr s =
  frequency [ (1, do n <- arbitrary
                     return (Num n))
            , (s, do a <- arbExpr s'
                     b <- arbExpr s'
                     return (Add a b))
            , (s, do a <- arbExpr s'
                     b <- arbExpr s'
                     return (Mul a b))
            ]
 where
  s' = s `div` 2

-----------------------------------------------------------------------

-- this property fails (even after fixing number) -- do you see why?
prop_ShowRead a =
  readExpr (show a) == Just a

-----------------------------------------------------------------------

prop_ShowReadEval a =
  fmap eval (readExpr (show a)) == Just (eval a)

eval :: Expr -> Int
eval (Num n)   = n
eval (Add a b) = eval a + eval b
eval (Mul a b) = eval a * eval b

-----------------------------------------------------------------------

prop_ShowReadAssoc a =
  readExpr (show a) == Just (assoc a)

assoc :: Expr -> Expr
assoc (Add (Add a b) c) = assoc (Add a (Add b c))
assoc (Add a b)         = Add (assoc a) (assoc b)
assoc (Mul (Mul a b) c) = assoc (Mul a (Mul b c))
assoc (Mul a b)         = Mul (assoc a) (assoc b)
assoc a                 = a
  
-----------------------------------------------------------------------