{-# LANGUAGE DeriveGeneric #-}
{- Tests.hs has a number of different custom data types. All of them implement 'Out' and 'Arbitrary'.
Properties are provided for each that specify that the output given by 'pretty' and that given
by 'show' should be identical except for the whitespace
The different data types follow the same pattern of implementation and functions, so most of the
functions are only commented for the first data type -}
import Text.PrettyPrint.GenericPretty
import Test.QuickCheck
import Control.Monad
import Data.Maybe
import Text.Printf
-- used to make pretty printed and show output identical for comparing purposes
removeSpaces :: String -> String
removeSpaces [] = []
removeSpaces (x:xs)
| x `elem` " \n" = removeSpaces xs
| otherwise = x : removeSpaces xs
-- checks the output of a specific value
checkOutput :: (Out a, Show a) => a -> Bool
checkOutput a = removeSpaces (pretty a) == removeSpaces (show a)
-- Finite State Machine Type
data FSM q = FSMCons ([q], Alphabet, q, [q], [Transition q]) deriving (Show, Generic)
type Alphabet = String
type Transition q = (q, Char, q)
-- implement 'Out' so we can pretty print
instance (Out a) => Out (FSM a) where
docPrec = genOut
--implementation needed for quickCheck generation of random values
instance Arbitrary a => Arbitrary (FSM a) where
arbitrary = liftM FSMCons arbitrary
-- check wether 'Maybe Int' FSM's are outputed the same via pretty and show (modulo the whitespace)
checkFSM :: FSM (Maybe Int) -> FSM (Maybe Int) -> Bool
checkFSM _ a = removeSpaces (pretty a) == removeSpaces (show a)
-- example of an FSM, you can check the output of this manually with 'checkOutput'
f :: FSM Int
f = FSMCons([0,1,2,3,4],
"ab",
0,
[4],
[(0,'a',1), (0,'b',1), (0,'a',2), (0,'b',2),
(1,'b',4), (2,'a',3), (2,'b',3), (3,'b',4),
(4,'a',4), (4,'b',4)])
-- Binary Tree data type
data BinaryTree a = EmptyBTree | BNode a (BinaryTree a) (BinaryTree a) deriving (Show, Generic)
instance (Out a) => Out (BinaryTree a) where
docPrec = genOut
instance (Arbitrary a) => Arbitrary (BinaryTree a) where
arbitrary = sized arbitTree
where
arbitTree 0 = return EmptyBTree
arbitTree n
| n>0 = oneof [return EmptyBTree, liftM3 BNode arbitrary subTree subTree]
| otherwise = error "tree size should never be < 0"
where
subTree = arbitTree (n `div` 2)
checkBinaryTree :: BinaryTree Char -> BinaryTree Char -> Bool
checkBinaryTree _ a = removeSpaces (pretty a) == removeSpaces (show a)
-- functions for the construction of BinaryTrees
singleton :: a -> BinaryTree a
singleton x = BNode x EmptyBTree EmptyBTree
treeInsert :: (Ord a) => a -> BinaryTree a -> BinaryTree a
treeInsert x EmptyBTree = singleton x
treeInsert x (BNode a left right)
| x == a = BNode x left right
| x < a = BNode a (treeInsert x left) right
| x > a = BNode a left (treeInsert x right)
nums :: [Int]
nums = [55555,99999,22222,77777,88888,11111,33333,44444,66666]
-- mkBTree takes a list and creates a BinaryTree docPrec of it
mkBTree :: (Ord a) => [a] -> BinaryTree a
mkBTree = foldr treeInsert EmptyBTree
-- example BinaryTree
bt :: BinaryTree Int
bt = mkBTree nums
-- Tree using record syntax
data RecordTree a = RNode {val :: a, children :: [RecordTree a]} deriving (Show, Generic)
instance (Out a) => Out (RecordTree a) where
docPrec = genOut
instance (Arbitrary a) => Arbitrary (RecordTree a) where
arbitrary = sized arbitTree
where
arbitTree 0 = liftM2 RNode arbitrary (return [])
arbitTree n
| n>0 = liftM2 RNode arbitrary childList
| otherwise = error "tree size should never be < 0"
where
childList = resize (floor.sqrt.fromIntegral $ n) (listOf (arbitTree (n`div` 2)) )
checkRecordTree :: RecordTree String -> RecordTree String -> Bool
checkRecordTree _ a = removeSpaces (pretty a) == removeSpaces (show a)
rt :: RecordTree Int
rt = RNode (-656565) [RNode 33344 [], RNode 98789 [RNode (-766444) [], RNode 454545 [], RNode 59996 []]]
infixr 5 :*:
infixr 3 :+:
-- tree using infix notation
data InfixTree a = ILeaf a a | (InfixTree a) :*: (InfixTree a) | (InfixTree a) :+: (InfixTree a)
deriving (Show, Generic)
instance (Out a) => Out (InfixTree a) where
docPrec = genOut
instance (Arbitrary a) => Arbitrary (InfixTree a) where
arbitrary = sized arbitTree
where
arbitTree 0 = liftM2 ILeaf arbitrary arbitrary
arbitTree n
| n>0 = oneof [ liftM2 (:*:) subTree subTree, liftM2 (:+:) subTree subTree]
| otherwise = error "tree size should never be < 0"
where
subTree = arbitTree (n `div` 2)
nt :: InfixTree Int
nt = ILeaf 5454544 55 :*: (ILeaf 5375738 44 :+: ((ILeaf 699879 55 :*: ILeaf 2332323 66 :+: ILeaf 676765 77)
:*: ILeaf 99999 88) ) :+: ILeaf 555 666
checkInfixTree :: InfixTree (Either Int Char) -> InfixTree (Either Int Char) -> Bool
checkInfixTree _ a = removeSpaces (pretty a) == removeSpaces (show a)
infixr 5 :^:
-- infix and record tree, also uses a second user defined type in it's definition, 'Wrap'
data InfixRecordTree a = IRLeaf (Wrap a) | (:^:) {left :: InfixRecordTree a, right :: InfixRecordTree a}
deriving (Show, Generic)
instance (Out a) => Out (InfixRecordTree a) where
docPrec = genOut
instance (Arbitrary a) => Arbitrary (InfixRecordTree a) where
arbitrary = sized arbitTree
where
arbitTree 0 = liftM IRLeaf arbitrary
arbitTree n
| n>0 = liftM2 (:^:) subTree subTree
| otherwise = error "tree size should never be < 0"
where
subTree = arbitTree (n `div` 2)
irt :: InfixRecordTree Int
irt = IRLeaf (Wrap 5454544) :^: (IRLeaf (Wrap (-5375738)) :^: ((IRLeaf (Wrap 699879) :^:
(IRLeaf (Wrap (-2332323)) :^: IRLeaf (Wrap 676765))) :^: IRLeaf (Wrap 99999)))
checkInfixRecordTree :: InfixRecordTree Int -> InfixRecordTree Int -> Bool
checkInfixRecordTree _ a = removeSpaces (pretty a) == removeSpaces (show a)
-- just a very simple user defined type that is used in IRTree
data Wrap a = Wrap a deriving (Show, Generic)
instance Out a => Out (Wrap a) where
docPrec = genOut
instance Arbitrary a => Arbitrary (Wrap a) where
arbitrary = liftM Wrap arbitrary
allTests = [ ("FSM (Maybe Int)", quickCheck checkFSM),
("BinaryTree (Char)", quickCheck checkBinaryTree),
("RecordTree (String)", quickCheck checkRecordTree),
("InfixTree (Either Int Char)", quickCheck checkInfixTree),
("InfixRecordTree (Int)", quickCheck checkInfixRecordTree)]
main = mapM_ (\(s,r) -> printf "%-30s: " s >> r) allTests