syb-0.7.3: tests/Ext1.hs

{-# LANGUAGE CPP        #-}
{-# LANGUAGE MagicHash  #-}
{-# LANGUAGE RankNTypes #-}

module Ext1 (tests) where

{-

This example records some experiments with polymorphic datatypes.

-}

import Test.Tasty.HUnit

import Data.Generics
import GHC.Exts (unsafeCoerce#)
import GHC.Base hiding (foldr)

-- Unsafe coerce
unsafeCoerce :: a -> b
unsafeCoerce = unsafeCoerce#

-- Extension of a query with a para. poly. list case
extListQ' :: Data d
          => (d -> q)
          -> (forall d. [d] -> q)
          -> d -> q
extListQ' def ext d =
  if isList d
    then ext (unsafeCoerce d)
    else def d


-- Test extListQ'
foo1 :: Data d => d -> Int
foo1 = const 0 `extListQ'` length

t1 :: Int
t1 = foo1 True -- should count as 0

t2 :: Int
t2 = foo1 [True,True] -- should count as 2


-- Infeasible extension of a query with a data-polymorphic list case
extListQ'' :: Data d
           => (d -> q)
           -> (forall d. Data d => [d] -> q)
           -> d -> q
extListQ'' def ext d =
  if isList d
    then undefined -- hard to avoid an ambiguous type
    else def d


-- Test extListQ from Data.Generics.Aliases
foo2 :: Data a => a -> Int
foo2 = const 0 `ext1Q` list
 where
  list :: Data a => [a] -> Int
  list l = foldr (+) 0 $ map glength l

t3 :: Int
t3 = foo2 (True,True) -- should count as 0

t4 :: Int
t4 = foo2 [(True,True),(True,True)] -- should count as 2+2=4


-- Customisation for lists without type cast
foo3 :: Data a => a -> Int
foo3 x = if isList x
          then foldr (+) 0 $ gmapListQ glength x
          else 0

t5 :: Int
t5 = foo3 (True,True) -- should count as 0

t6 :: Int
t6 = foo3 [(True,True),(True,True)] -- should count as 2+2=4


-- Test for list datatype
isList :: Data a => a -> Bool
isList x = typeRepTyCon (typeOf x) ==
           typeRepTyCon (typeOf (undefined::[()]))


-- Test for nil
isNil :: Data a => a -> Bool
isNil x = toConstr x == toConstr ([]::[()])


-- Test for cons
isCons :: Data a => a -> Bool
isCons x = toConstr x == toConstr (():[])


-- gmapQ for polymorphic lists
gmapListQ :: forall a q. Data a => (forall a. Data a => a -> q) -> a -> [q]
gmapListQ f x =
  if not $ isList x
    then error "gmapListQ"
    else if isNil x
           then []
           else if isCons x
                  then ( gmapQi 0 f x : gmapQi 1 (gmapListQ f) x )
                  else error "gmapListQ"

-- Main function for testing
tests :: Assertion
tests = ( t1
        , ( t2
        , ( t3
        , ( t4
        , ( t5
        , ( t6
        )))))) @=? output

output :: (Int, (Int, (Int, (Int, (Int, Int)))))
output = (0,(2,(0,(4,(0,4)))))