syb-0.4.1: tests/Ext2.hs

{-# LANGUAGE DeriveDataTypeable #-}

module Ext2 (tests) where

-- Tests for ext2 and friends

import Test.HUnit
import Data.Generics


-- A type of lists
data List a = Nil | Cons a (List a) deriving (Data, Typeable, Show, Eq)

-- Example lists
l1, l2 :: List Int
l1 = Cons 1 (Cons 2 Nil)
l2 = Cons 0 l1

-- A type of pairs
data Pair a b = Pair1 a b | Pair2 a b deriving (Data, Typeable, Show, Eq)

-- Example pairs
p1, p2 :: Pair Int Char
p1 = Pair1 2 'p'
p2 = Pair2 3 'q'

-- Structures containing the above
s1 :: [Pair Int Char]
s1 = [p1, p2]

s2 :: (Pair Int Char, List Int)
s2 = (p2, l2)


-- Auxiliary functions
unifyPair :: Pair a b -> Pair a b -> Bool
unifyPair (Pair1 _ _) (Pair1 _ _) = True
unifyPair (Pair2 _ _) (Pair2 _ _) = True
unifyPair _           _           = False

flipPair :: Pair a b -> Pair a b
flipPair (Pair1 a b) = Pair2 a b
flipPair (Pair2 a b) = Pair1 a b

-- Tests
t1 = everywhere (id `ext2T` flipPair) (s1,s2)
t2 = let f :: (Data a) => a -> Maybe a
         f = (const Nothing) `ext2M` (Just . flipPair)
     in (f p1, f l1)
t3 = everything (+) ( const 0
             `ext1Q` (const 1  :: List a   -> Int)
             `ext2Q` (const 10 :: Pair a b -> Int))
               $ s2
t4 = unifyPair (t4' :: Pair Int Char) t4' where
  t4' :: Data a => a
  t4' = undefined `ext1B` Nil `ext2B` (Pair1 undefined undefined)


-- Main function for testing
tests = (t1, t2, t3, t4) ~=? output

output = ((map flipPair s1, (flipPair p2, l2))
         ,(Just (flipPair p1),Nothing)
         ,14
         ,True)