syb-0.2: tests/Ext1.hs

{-# OPTIONS -fglasgow-exts #-}

module Ext1 (tests) where

{-

This example records some experiments with polymorphic datatypes.

-}

import Test.HUnit

import Data.Generics
import GHC.Base


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


-- Handy type constructors
newtype ID x = ID { unID :: x }
newtype CONST c a = CONST { unCONST :: c }


-- 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 = foo1 True -- should count as 0
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 = foo2 (True,True) -- should count as 0
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 = foo3 (True,True) -- should count as 0
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"


-- Build nil
mkNil :: Data a => a
mkNil = fromConstr $ toConstr ([]::[()])


-- Build cons
mkCons :: Data a => a
mkCons = fromConstr $ toConstr ((undefined:undefined)::[()])


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

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