Instances.hs

-- | Tests for instances (like @Read@ \/ @Show@)

module TestSuite.Instances where

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

import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Tasty

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 TestSuite.Tools
import TestSuite.Misc

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

testgroup_Instances :: TestTree
testgroup_Instances = testGroup "Instances"
  [ testgroup_Instances_Misc
  , testgroup_Instances_ReadShow
  , testgroup_Instances_Attrib 
  ]

testgroup_Instances_Misc :: TestTree
testgroup_Instances_Misc = testGroup "Misc"
  [ testProperty "forget"                prop_forget
  , testProperty "toFixT . fromFixT"     prop_fromToFixT 
  , testProperty "fromFixT . toFixT"     prop_toFromFixT
  , testProperty "toAttr . fromAttr"     prop_fromToAttr
  , testProperty "fromAttr . toAttr"     prop_toFromAttr
  ]

testgroup_Instances_ReadShow :: TestTree
testgroup_Instances_ReadShow = testGroup "Read / Show"
  [ testProperty "Mu/Label"              prop_ReadShowMuLabel
  , testProperty "Mu/Int"                prop_ReadShowMuInt
  , testProperty "Mu/String"             prop_ReadShowMuString
  , testProperty "Attr/Label/Int"        prop_ReadShowAttrLabelInt
  , testProperty "Attr/String/Label"     prop_ReadShowAttrStringLabel
  ]

testgroup_Instances_Attrib :: TestTree
testgroup_Instances_Attrib = testGroup "derived vs. Attrib"
  [ testProperty "fmap"                  prop_AttribFMap
  , testProperty "foldr"                 prop_AttribFoldr
  , testProperty "foldl"                 prop_AttribFoldl
  , testProperty "mapAccumL"             prop_AttribMapAccumL
  , testProperty "mapAccumR"             prop_AttribMapAccumR
  ]

--------------------------------------------------------------------------------
-- * 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
-}
  
--------------------------------------------------------------------------------