Attributes.hs

-- | Tests for attributes

module TestSuite.Attributes where

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

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

import Control.Applicative
import Control.Monad hiding ( mapM , mapM_ , forM , forM_ )
import Data.List ( sort , intercalate )
import Data.Char ( ord )
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.Attributes
import Data.Generics.Fixplate.Morphisms
import Data.Generics.Fixplate.Traversals

import TestSuite.Tools
import TestSuite.Misc

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

testgroup_Attributes :: TestTree
testgroup_Attributes = testGroup "Attributes"
  [ testProperty "synthAccumL"            prop_synthAccumL
  , testProperty "synthAccumR"            prop_synthAccumR
  , testProperty "synthetise"             prop_synthetise
  , testProperty "synthCata"              prop_synthCata
  , testProperty "synthPara"              prop_synthPara
  , testProperty "synthPara'"             prop_synthPara'
  , testProperty "scanCata"               prop_scanCata 
  , testProperty "mapAccumCata"           prop_mapAccumCata
  , testProperty "zygo"                   prop_zygo
  , testProperty "zygo_"                  prop_zygo_
  ]

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

{-
runtests_Attributes :: IO ()
runtests_Attributes = do
  quickCheck prop_synthAccumL
  quickCheck prop_synthAccumR
  quickCheck prop_synthetise
  quickCheck prop_synthCata
  quickCheck prop_synthPara
  quickCheck prop_synthPara'
  quickCheck prop_scanCata 
  quickCheck prop_mapAccumCata
  quickCheck prop_zygo
  quickCheck prop_zygo_
-}

prop_synthAccumL :: FixT Label -> Bool
prop_synthAccumL tree = 
  toList (Attrib (synthAccumL_ (\i _ -> (i+1,i)) 1 tree)) == [1..length (universe tree)]

prop_synthAccumR :: FixT Label -> Bool
prop_synthAccumR tree = 
  toList (Attrib (synthAccumR_ (\i _ -> (i+1,i)) 1 tree)) == reverse [1..length (universe tree)]

prop_synthetise :: FixT Label -> Bool
prop_synthetise tree = 
  map attribute (universe $ synthetise (\(TreeF (Label l) xs) -> l ++ concat xs) tree)
  ==
  map fold (universe tree)
  where
    fold = foldLeft (\s (Fix (TreeF (Label l) _)) -> s++l) []

prop_synthCata :: FixT Label -> Bool
prop_synthCata tree = attribute (synthCata f tree) == cata f tree where 
  f :: TreeF Label String -> String
  f (TreeF (Label label) xs) = label++"(" ++ intercalate "," xs ++ ")"

prop_synthPara' :: FixT Label -> Bool
prop_synthPara' tree = attribute (synthPara' h tree) == para' h tree where 
  h :: FixT Label -> TreeF Label String -> String
  h tree@(Fix (TreeF label ts)) ys = unLabel label++"_"++show siz++"(" ++ intercalate "," (zipWith c (toList ys) sizs) ++ ")" where
    siz = cata f tree
    sizs = map (cata f) ts
    f t = (1::Int) + Data.Foldable.sum t
    c str j = str ++ "<" ++ show j ++ ">"

prop_synthPara :: FixT Label -> Bool
prop_synthPara tree = attribute (synthPara g tree) == para g tree where 
  g :: TreeF Label (FixT Label , String) -> String
  g (TreeF (Label label) xs) = label++"(" ++ intercalate "," (map u xs) ++ ")" where
    u (tree,a) = show siz ++ "_" ++ a where
      siz = cata (\t -> (1::Int) + Data.Foldable.sum t) tree

scanCataNaive :: Functor f => (a -> f b -> b) -> Attr f a -> Attr f b
scanCataNaive f = annZipWith (flip const) . synthCata (\(Ann a x) -> f a x)

prop_scanCata :: Attr (TreeF Label) String -> Bool
prop_scanCata tree = scanCata f tree == scanCataNaive f tree where
  f :: (String -> TreeF Label Integer -> Integer) -- -> Attr (TreeF Label) String -> Attr (TreeF Label) Integer
  f str t = Prelude.product (toList t) + sumchar str
  sumchar :: String -> Integer
  sumchar = fromIntegral . Prelude.sum . map ord 
--   tree = synthetise (\(TreeF (Label l) xs) -> map toUpper l ++ concat xs) tree) tree0

mapAccumCataNaive :: Functor f => (f acc -> b -> (acc,c)) -> Attr f b -> (acc, Attr f c)
mapAccumCataNaive f = second (annZipWith (flip const)) . synthAccumCata (\(Ann b t) -> f t b)

prop_mapAccumCata :: Attr (TreeF Label) String -> Bool
prop_mapAccumCata tree = mapAccumCata f tree == mapAccumCataNaive f tree where
  f :: (TreeF Label Integer -> String -> (Integer,String)) -- -> Attr (TreeF Label) String -> Attr (TreeF Label) Integer
  f t str = ( k - fromIntegral (length str) + sumchar str , "<" ++ show k ++ "," ++ str ++ ">") where 
    ls = toList t
    k  = Prelude.product ls
  sumchar :: String -> Integer
  sumchar = fromIntegral . Prelude.sum . map ord 
  -- tree = synthetise (\(TreeF (Label l) xs) -> map toLower l ++ concat xs) tree) tree0

--------------------------------------------------------------------------------
-- Morphism tests which are here to avoid circular imports

zygoNaive_ :: Functor f => (f b -> b) -> (f (b,a) -> a) -> Mu f -> a
zygoNaive_ g h = para (h . fmap (first attribute) . unAnn) . synthCata g 

zygoNaive :: Functor f => (f b -> b) -> (f (b,a) -> a) -> Mu f -> (b,a)
zygoNaive g h tree = (attribute tmp, para h1 tmp) where 
  tmp = synthCata g tree
  h1 = h . fmap (first attribute) . unAnn

prop_zygo :: FixT Label -> Bool
prop_zygo tree = zygo g h tree == zygoNaive g h tree where
  g :: TreeF Label Integer -> Integer
  g (TreeF (Label label) child) = Prelude.product child + sumchar label

  h :: TreeF Label (Integer,String) -> String
  h (TreeF (Label label) child) = "[" ++ label ++ "]<" ++ intercalate "," (map f child) ++ ">"

  f (k,s) = show k ++ "_" ++ s

  sumchar = fromIntegral . Prelude.sum . map ord 

prop_zygo_ :: FixT Label -> Bool
prop_zygo_ tree = zygo_ g h tree == zygoNaive_ g h tree where
  g :: TreeF Label Integer -> Integer
  g (TreeF (Label label) child) = Prelude.product child + prodchar label

  h :: TreeF Label (Integer,String) -> String
  h (TreeF (Label label) child) = "<" ++ intercalate "," (map f child) ++ ">" ++ "[" ++ label ++ "]"

  f (k,s) = s ++ "_" ++ show k

  prodchar = fromIntegral . Prelude.product . map ord 
  
--------------------------------------------------------------------------------