Instances.hs


{-# LANGUAGE 
      CPP, 
      DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving,
      FlexibleInstances
  #-}
module Data.Generics.Fixplate.Test.Instances where

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

import Control.Applicative
import Control.Monad hiding (mapM, mapM_, forM, forM_)
import Data.List (sort)
import Data.Foldable
import Data.Traversable
import Prelude hiding (foldl,foldr,mapM,mapM_,concat,concatMap)

import Data.Generics.Fixplate.Base
import Data.Generics.Fixplate.Misc
import Data.Generics.Fixplate.Test.Tools

import Test.QuickCheck

--------------------------------------------------------------------------------
-- * Misc

prop_forget :: Attr (TreeF Label) Int -> Bool
prop_forget tree =
  fromFixT (forget tree) == fmap fst (fromAttr tree)
  
prop_fromToFixT :: FixT Label -> Bool  
prop_fromToFixT tree =
  toFixT (fromFixT tree) == tree

prop_toFromFixT :: Tree Label -> Bool  
prop_toFromFixT tree =
  fromFixT (toFixT tree) == tree

prop_fromToAttr :: Attr (TreeF Label) Int -> Bool  
prop_fromToAttr tree =
  toAttr (fromAttr tree) == tree

prop_toFromAttr :: Tree (Label,Int) -> Bool  
prop_toFromAttr tree =
  fromAttr (toAttr tree) == tree
  
runtests_InstancesMisc = do
  quickCheck prop_forget
  quickCheck prop_fromToFixT 
  quickCheck prop_toFromFixT
  quickCheck prop_fromToAttr
  quickCheck prop_toFromAttr
  
--------------------------------------------------------------------------------
-- * Read/Show.

prop_ReadShowMuLabel   :: Mu (TreeF Label ) -> Bool
prop_ReadShowMuInt     :: Mu (TreeF Int   ) -> Bool
prop_ReadShowMuString  :: Mu (TreeF String) -> Bool

prop_ReadShowMuLabel  t = read (show t) == t 
prop_ReadShowMuInt    t = read (show t) == t 
prop_ReadShowMuString t = read (show t) == t 

prop_ReadShowAttrLabelInt    :: Attr (TreeF Label ) Int   -> Bool
prop_ReadShowAttrStringLabel :: Attr (TreeF String) Label -> Bool

prop_ReadShowAttrLabelInt    t = read (show t) == t 
prop_ReadShowAttrStringLabel t = read (show t) == t 

runtests_ReadShow = do
  quickCheck prop_ReadShowMuLabel
  quickCheck prop_ReadShowMuInt
  quickCheck prop_ReadShowMuString
  quickCheck prop_ReadShowAttrLabelInt
  quickCheck prop_ReadShowAttrStringLabel
  
--------------------------------------------------------------------------------
-- * Attrib wrapper.

prop_AttribFMap :: Attr (TreeF Label) Int -> Bool
prop_AttribFMap tree = 
  unAttrib (fmap f (Attrib tree)) == toAttr (fmap (id<#>f) (fromAttr tree)) 
    where f n = show n ++ "_"

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

prop_AttribFoldr :: Attr (TreeF Label) Int -> Bool
prop_AttribFoldr tree = 
  foldr (:) [] (Attrib tree) == map snd (foldr (:) [] (fromAttr tree))

prop_AttribFoldl :: Attr (TreeF Label) Int -> Bool
prop_AttribFoldl tree = 
  foldl (flip (:)) [] (Attrib tree) == map snd (foldl (flip (:)) [] (fromAttr tree))

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

prop_AttribMapAccumL :: Attr (TreeF Label) Integer -> Bool
prop_AttribMapAccumL tree = 
  (id<#>unAttrib) (mapAccumL f1 666 (Attrib tree)) == (id<#>toAttr) (mapAccumL f2 666 (fromAttr tree)) where 
    f1 :: Integer -> Integer -> (Integer,String)
    f1 old input = (new, show residue) where 
      new     = old*3 - input
      residue = old*2 + input*7
    f2 :: Integer -> (Label,Integer) -> (Integer,(Label,String))
    f2 old (x,input) = let (new,res) = f1 old input in (new,(x,res))

prop_AttribMapAccumR :: Attr (TreeF Label) Integer -> Bool
prop_AttribMapAccumR tree = 
  (id<#>unAttrib) (mapAccumR f1 666 (Attrib tree)) == (id<#>toAttr) (mapAccumR f2 666 (fromAttr tree)) where 
    f1 :: Integer -> Integer -> (Integer,String)
    f1 old input = (new, show residue) where 
      new     = old*3 - input
      residue = old*2 + input*7
    f2 :: Integer -> (Label,Integer) -> (Integer,(Label,String))
    f2 old (x,input) = let (new,res) = f1 old input in (new,(x,res))

-- | We compare GHC-derived Functor, Foldable and Traversable instances (for Tree)
-- with our implementation (for Attrib).
runtests_Attrib = do
  quickCheck prop_AttribFMap
  quickCheck prop_AttribFoldr
  quickCheck prop_AttribFoldl
  quickCheck prop_AttribMapAccumL
  quickCheck prop_AttribMapAccumR
  
--------------------------------------------------------------------------------