diff --git a/src/Data/Generics/Instances.hs b/src/Data/Generics/Instances.hs --- a/src/Data/Generics/Instances.hs +++ b/src/Data/Generics/Instances.hs @@ -1,4 +1,6 @@ {-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- -- | diff --git a/syb.cabal b/syb.cabal --- a/syb.cabal +++ b/syb.cabal @@ -1,5 +1,5 @@ name: syb -version: 0.3 +version: 0.3.1 license: BSD3 license-file: LICENSE author: Ralf Lammel, Simon Peyton Jones diff --git a/tests/Datatype.hs b/tests/Datatype.hs deleted file mode 100644 --- a/tests/Datatype.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - --- These are simple tests to observe (data)type representations. -module Datatype (tests) where - -import Test.HUnit - -import Data.Tree -import Data.Generics - --- A simple polymorphic datatype -data Data a => - MyDataType a = MyDataType a - deriving (Typeable, Data) - - --- Some terms and corresponding type representations -myTerm = undefined :: MyDataType Int -myTypeRep = typeOf myTerm -- type representation in Typeable -myTyCon = typeRepTyCon myTypeRep -- type constructor via Typeable -myDataType = dataTypeOf myTerm -- datatype representation in Data -myString1 = tyConString myTyCon -- type constructor via Typeable -myString2 = dataTypeName myDataType -- type constructor via Data - --- Main function for testing -tests = show ( myTypeRep - , ( myDataType - , ( tyconModule myString1 - , ( tyconUQname myString1 - , ( tyconModule myString2 - , ( tyconUQname myString2 - )))))) - ~=? output - -output = "(Datatype.MyDataType Int,(DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]},(\"Datatype\",(\"MyDataType\",(\"Datatype\",\"MyDataType\")))))" diff --git a/tests/Encode.hs b/tests/Encode.hs deleted file mode 100644 --- a/tests/Encode.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - --- A bit more test code for the 2nd boilerplate paper. --- These are downscaled versions of library functionality or real test cases. --- We just wanted to typecheck the fragments as shown in the paper. - -module Encode () where - -import Data.Generics - -data Bit = Zero | One - ------------------------------------------------------------------------------- --- Sec. 3.2 - -data2bits :: Data a => a -> [Bit] -data2bits t = encodeCon (dataTypeOf t) (toConstr t) - ++ concat (gmapQ data2bits t) - --- The encoder for constructors -encodeCon :: DataType -> Constr -> [Bit] -encodeCon ty con = natToBin (max-1) (idx-1) - where - max = maxConstrIndex ty - idx = constrIndex con - - -natToBin :: Int -> Int -> [Bit] -natToBin = undefined - ------------------------------------------------------------------------------- --- Sec. 3.3 - -data State -- Abstract -initState :: State -encodeCon' :: DataType -> Constr - -> State -> (State, [Bit]) - -initState = undefined -encodeCon' = undefined - -data2bits' :: Data a => a -> [Bit] -data2bits' t = snd (show_bin t initState) - -show_bin :: Data a => a -> State -> (State, [Bit]) -show_bin t st = (st2, con_bits ++ args_bits) - where - (st1, con_bits) = encodeCon' (dataTypeOf t) - (toConstr t) st - (st2, args_bits) = foldr do_arg (st1,[]) - enc_args - - enc_args :: [State -> (State,[Bit])] - enc_args = gmapQ show_bin t - - do_arg fn (st,bits) = (st', bits' ++ bits) - where - (st', bits') = fn st - - ------------------------------------------------------------------------------- --- Sec. 3.3 cont'd - -data EncM a -- The encoder monad -instance Monad EncM - where - return = undefined - c >>= f = undefined - -runEnc :: EncM () -> [Bit] -emitCon :: DataType -> Constr -> EncM () - -runEnc = undefined -emitCon = undefined - -data2bits'' :: Data a => a -> [Bit] -data2bits'' t = runEnc (emit t) - -emit :: Data a => a -> EncM () -emit t = do { emitCon (dataTypeOf t) (toConstr t) - ; sequence_ (gmapQ emit t) } diff --git a/tests/Ext.hs b/tests/Ext.hs deleted file mode 100644 --- a/tests/Ext.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - -module Ext () where - --- There were typos in these definitions in the ICFP 2004 paper. - -import Data.Generics - -extQ fn spec_fn arg - = case gcast (Q spec_fn) of - Just (Q spec_fn') -> spec_fn' arg - Nothing -> fn arg - -newtype Q r a = Q (a -> r) - -extT fn spec_fn arg - = case gcast (T spec_fn) of - Just (T spec_fn') -> spec_fn' arg - Nothing -> fn arg - -newtype T a = T (a -> a) - -extM :: (Typeable a, Typeable b) - => (a -> m a) -> (b -> m b) -> (a -> m a) -extM fn spec_fn - = case gcast (M spec_fn) of - Just (M spec_fn') -> spec_fn' - Nothing -> fn - -newtype M m a = M (a -> m a) diff --git a/tests/FoldTree.hs b/tests/FoldTree.hs deleted file mode 100644 --- a/tests/FoldTree.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{- - -A very, very simple example: "extract all Ints from a tree of Ints". -The text book approach is to write a generalised fold for that. One -can also turn the Tree datatype into functorial style and then write a -Functor instance for the functorial datatype including a definition of -fmap. (The original Tree datatype can be related to the functorial -version by the usual injection and projection.) - -You can scrap all such boilerplate by using a traversal scheme based -on gmap combinators as illustrated below. To get it a little more -interesting, we use a datatype Tree with not just a case for leafs and -fork trees, but we also add a case for trees with a weight. - -For completeness' sake, we mention that the fmap/generalised fold -approach differs from the gmap approach in some details. Most notably, -the gmap approach does not generally facilitate the identification of -term components that relate to the type parameter of a parameterised -datatype. The consequence of this is illustrated below as well. -Sec. 6.3 in "Scrap Your Boilerplate ..." discusses such `type -distinctions' as well. - --} - -module FoldTree (tests) where - -import Test.HUnit - --- Enable "ScrapYourBoilerplate" -import Data.Generics - - --- A parameterised datatype for binary trees with data at the leafs -data (Data a, Data w) => - Tree a w = Leaf a - | Fork (Tree a w) (Tree a w) - | WithWeight (Tree a w) w - deriving (Typeable, Data) - - --- A typical tree -mytree :: Tree Int Int -mytree = Fork (WithWeight (Leaf 42) 1) - (WithWeight (Fork (Leaf 88) (Leaf 37)) 2) - --- A less typical tree, used for testing everythingBut -mytree' :: Tree Int Int -mytree' = Fork (Leaf 42) - (WithWeight (Fork (Leaf 88) (Leaf 37)) 2) - - --- Print everything like an Int in mytree --- In fact, we show two attempts: --- 1. print really just everything like an Int --- 2. print everything wrapped with Leaf --- So (1.) confuses leafs and weights whereas (2.) does not. --- Additionally we test everythingBut, stopping when we see a WithWeight node -tests = show ( listify (\(_::Int) -> True) mytree - , everything (++) ([] `mkQ` fromLeaf) mytree - , everythingBut (++) - (([],False) `mkQ` (\x -> (fromLeaf x, stop x))) mytree' - ) ~=? output - where - fromLeaf :: Tree Int Int -> [Int] - fromLeaf (Leaf x) = [x] - fromLeaf _ = [] - stop :: (Data a, Data b) => Tree a b -> Bool - stop (WithWeight _ _) = True - stop _ = False - -output = "([42,1,88,37,2],[42,88,37],[42])" diff --git a/tests/GShow2.hs b/tests/GShow2.hs deleted file mode 100644 --- a/tests/GShow2.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - -module GShow2 (tests) where - -{- - -This test exercices GENERIC show for the infamous company datatypes. The -output of the program should be some representation of the infamous -"genCom" company. - --} - -import Test.HUnit - -import Data.Generics -import CompanyDatatypes - -tests = gshow genCom ~=? output - -{- - -Here is another exercise: -The following function gshow' is a completely generic variation on gshow. -It would print strings as follows: - -*Main> gshow' "abc" -"((:) ('a') ((:) ('b') ((:) ('c') ([]))))" - -The original gshow does a better job because it is customised for strings: - -*Main> gshow "foo" -"\"foo\"" - -In fact, this is what Haskell's normal show would also do: - -*Main> show "foo" -"\"foo\"" - --} - -gshow' :: Data a => a -> String -gshow' t = "(" - ++ showConstr (toConstr t) - ++ concat (gmapQ ((++) " " . gshow') t) - ++ ")" - -output = "(C ((:) (D \"Research\" (E (P \"Laemmel\" \"Amsterdam\") (S (8000.0))) ((:) (PU (E (P \"Joost\" \"Amsterdam\") (S (1000.0)))) ((:) (PU (E (P \"Marlow\" \"Cambridge\") (S (2000.0)))) ([])))) ((:) (D \"Strategy\" (E (P \"Blair\" \"London\") (S (100000.0))) ([])) ([]))))" diff --git a/tests/GetC.hs b/tests/GetC.hs deleted file mode 100644 --- a/tests/GetC.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} -{-# LANGUAGE OverlappingInstances, UndecidableInstances #-} - -module GetC (tests) where - -import Test.HUnit - -{- - -Ralf Laemmel, 5 November 2004 - -Joe Stoy suggested the idiom to test for the outermost constructor. - -Given is a term t -and a constructor f (say the empty constructor application). - -isC f t returns True if the outermost constructor of t is f. -isC f t returns False otherwise. -Modulo type checking, i.e., the data type of f and t must be the same. -If not, we want to see a type error, of course. - --} - -import Data.Typeable -- to cast t's subterms, which will be reused for f. -import Data.Generics -- to access t's subterms and constructors. - - --- Some silly data types -data T1 = T1a Int String | T1b String Int deriving (Typeable, Data) -data T2 = T2a Int Int | T2b String String deriving (Typeable, Data) -data T3 = T3! Int deriving (Typeable, Data) - - --- Test cases -tests = show [ isC T1a (T1a 1 "foo") -- typechecks, returns True - , isC T1a (T1b "foo" 1) -- typechecks, returns False - , isC T3 (T3 42)] -- works for strict data too - ~=? output --- err = show $ isC T2b (T1b "foo" 1) -- must not typecheck - -output = show [True,False,True] - --- --- We look at a datum a. --- We look at a constructor function f. --- The class GetT checks that f constructs data of type a. --- The class GetC computes maybe the constructor ... --- ... if the subterms of the datum at hand fit for f. --- Finally we compare the constructors. --- - -isC :: (Data a, GetT f a, GetC f) => f -> a -> Bool -isC f t = maybe False ((==) (toConstr t)) con - where - kids = gmapQ ExTypeable t -- homogenify subterms in list for reuse - con = getC f kids -- compute constructor from constructor application - - --- --- We prepare for a list of kids using existential envelopes. --- We could also just operate on TypeReps for non-strict datatypes. --- - -data ExTypeable = forall a. Typeable a => ExTypeable a -unExTypeable (ExTypeable a) = cast a - - --- --- Compute the result type of a function type. --- Beware: the TypeUnify constraint causes headache. --- We can't have GetT t t because the FD will be violated then. --- We can't omit the FD because unresolvable overlapping will hold then. --- - -class GetT f t | f -> t -- FD is optional -instance GetT g t => GetT (x -> g) t -instance TypeUnify t t' => GetT t t' - - --- --- Obtain the constructor if term can be completed --- - -class GetC f - where - getC :: f -> [ExTypeable] -> Maybe Constr - -instance (Typeable x, GetC g) => GetC (x -> g) - where - getC _ [] = Nothing - getC (f::x->g) (h:t) - = - do - (x::x) <- unExTypeable h - getC (f x) t - -instance Data t => GetC t - where - getC y [] = Just $ toConstr y - getC _ (_:_) = Nothing - - --- --- Type unification; we could try this: --- class TypeUnify a b | a -> b, b -> a --- instance TypeUnify a a --- --- However, if the instance is placed in the present module, --- then type improvement would inline this instance. Sigh!!! --- --- So we need type unification with type improvement blocker --- The following solution works with GHC for ages. --- Other solutions; see the HList paper. --- - -class TypeUnify a b | a -> b, b -> a -class TypeUnify' x a b | x a -> b, x b -> a -class TypeUnify'' x a b | x a -> b, x b -> a -instance TypeUnify' () a b => TypeUnify a b -instance TypeUnify'' x a b => TypeUnify' x a b -instance TypeUnify'' () a a diff --git a/tests/Gread.hs b/tests/Gread.hs deleted file mode 100644 --- a/tests/Gread.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - -module GRead (tests) where - -{- - -The following examples achieve branch coverage for the various -productions in the definition of gread. Also, negative test cases are -provided; see str2 and str3. Also, the potential of heading or -trailing spaces as well incomplete parsing of the input is exercised; -see str5. - --} - -import Test.HUnit - -import Data.Generics - -str1 = "(True)" -- reads fine as a Bool -str2 = "(Treu)" -- invalid constructor -str3 = "True" -- lacks parentheses -str4 = "(1)" -- could be an Int -str5 = "( 2 ) ..." -- could be an Int with some trailing left-over -str6 = "([])" -- test empty list -str7 = "((:)" ++ " " ++ str4 ++ " " ++ str6 ++ ")" - -tests = show ( ( [ gread str1, - gread str2, - gread str3 - ] - , [ gread str4, - gread str5 - ] - , [ gread str6, - gread str7 - ] - ) - :: ( [[(Bool, String)]] - , [[(Int, String)]] - , [[([Int], String)]] - ) - ) ~=? output - -output = show - ([[(True,"")],[],[]],[[(1,"")],[(2,"...")]],[[([],"")],[([1],"")]]) diff --git a/tests/Gread2.hs b/tests/Gread2.hs deleted file mode 100644 --- a/tests/Gread2.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - -module GRead2 () where - -{- - -For the discussion in the 2nd boilerplate paper, -we favour some simplified generic read, which is checked to compile. -For the full/real story see Data.Generics.Text. - --} - -import Data.Generics - -gread :: Data a => String -> Maybe a -gread input = runDec input readM - --- The decoder monad -newtype DecM a = D (String -> Maybe (String, a)) - -instance Monad DecM where - return a = D (\s -> Just (s,a)) - (D m) >>= k = D (\s -> - case m s of - Nothing -> Nothing - Just (s1,a) -> let D n = k a - in n s1) - -runDec :: String -> DecM a -> Maybe a -runDec input (D m) = do (_,x) <- m input - return x - -parseConstr :: DataType -> DecM Constr -parseConstr ty = D (\s -> - match s (dataTypeConstrs ty)) - where - match :: String -> [Constr] - -> Maybe (String, Constr) - match _ [] = Nothing - match input (con:cons) - | take n input == showConstr con - = Just (drop n input, con) - | otherwise - = match input cons - where - n = length (showConstr con) - - -readM :: forall a. Data a => DecM a -readM = read - where - read :: DecM a - read = do { let val = argOf read - ; let ty = dataTypeOf val - ; constr <- parseConstr ty - ; let con::a = fromConstr constr - ; gmapM (\_ -> readM) con } - -argOf :: c a -> a -argOf = undefined - -yareadM :: forall a. Data a => DecM a -yareadM = do { let ty = dataTypeOf (undefined::a) - ; constr <- parseConstr ty - ; let con::a = fromConstr constr - ; gmapM (\_ -> yareadM) con } diff --git a/tests/HList.hs b/tests/HList.hs deleted file mode 100644 --- a/tests/HList.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - -module HList (tests) where - -{- - -This module illustrates heterogeneously typed lists. - --} - -import Test.HUnit - -import Data.Typeable - - --- Heterogeneously typed lists -type HList = [DontKnow] - -data DontKnow = forall a. Typeable a => DontKnow a - --- The empty list -initHList :: HList -initHList = [] - --- Add an entry -addHList :: Typeable a => a -> HList -> HList -addHList a l = (DontKnow a:l) - --- Test for an empty list -nullHList :: HList -> Bool -nullHList = null - --- Retrieve head by type case -headHList :: Typeable a => HList -> Maybe a -headHList [] = Nothing -headHList (DontKnow a:_) = cast a - --- Retrieve tail by type case -tailHList :: HList -> HList -tailHList = tail - --- Access per index; starts at 1 -nth1HList :: Typeable a => Int -> HList -> Maybe a -nth1HList i l = case (l !! (i-1)) of (DontKnow a) -> cast a - - ----------------------------------------------------------------------------- - --- A demo list -mylist = addHList (1::Int) $ - addHList (True::Bool) $ - addHList ("42"::String) $ - initHList - --- Main function for testing -tests = ( show (nth1HList 1 mylist :: Maybe Int) -- shows Just 1 - , ( show (nth1HList 1 mylist :: Maybe Bool) -- shows Nothing - , ( show (nth1HList 2 mylist :: Maybe Bool) -- shows Just True - , ( show (nth1HList 3 mylist :: Maybe String) -- shows Just "42" - )))) ~=? output - -output = ("Just 1",("Nothing",("Just True","Just \"42\""))) diff --git a/tests/HOPat.hs b/tests/HOPat.hs deleted file mode 100644 --- a/tests/HOPat.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - -module HOPat (tests) where - -{- - -This module is in reply to an email by C. Barry Jay -received on March 15, and handled within hours. CBJ -raises the very interesting issue of higher-order patterns. -It turns out that some form of it is readily covered in -our setting. - --} - -import Test.HUnit - -import Data.Generics - - --- Sample datatypes -data T1 = T1a Int | T1b Float - deriving (Show, Eq, Typeable, Data) -data T2 = T2a T1 T2 | T2b - deriving (Show, Eq, Typeable, Data) - --- Eliminate a constructor if feasible -elim' :: (Data y, Data x) => Constr -> y -> Maybe x -elim' c y = if toConstr y == c - then unwrap y - else Nothing - - --- Unwrap a term; Return its single component -unwrap :: (Data y, Data x) => y -> Maybe x -unwrap y = case gmapQ (Nothing `mkQ` Just) y of - [Just x] -> Just x - _ -> Nothing - - --- Eliminate a constructor if feasible; 2nd try -elim :: forall x y. (Data y, Data x) => (x -> y) -> y -> Maybe x -elim c y = elim' (toConstr (c (undefined::x))) y - - --- Visit a data structure -visitor :: (Data x, Data y, Data z) - => (x -> y) -> (x -> x) -> z -> z -visitor c f = everywhere (mkT g) - where - g y = case elim c y of - Just x -> c (f x) - Nothing -> y - - --- Main function for testing -tests = ( ( elim' (toConstr t1a) t1a) :: Maybe Int - , ( (elim' (toConstr t1a) t1b) :: Maybe Int - , ( (elim T1a t1a) :: Maybe Int - , ( (elim T1a t1b) :: Maybe Int - , ( (visitor T1a ((+) 46) t2) :: T2 - ))))) ~=? output - where - t1a = T1a 42 - t1b = T1b 3.14 - t2 = T2a t1a (T2a t1a T2b) - -output = (Just 42,(Nothing,(Just 42,(Nothing,T2a (T1a 88) (T2a (T1a 88) T2b))))) diff --git a/tests/Labels.hs b/tests/Labels.hs deleted file mode 100644 --- a/tests/Labels.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - -module Labels (tests) where - --- This module tests availability of field labels. - -import Test.HUnit - -import Data.Generics - --- A datatype without labels -data NoLabels = NoLabels Int Float - deriving (Typeable, Data) - --- A datatype with labels -data YesLabels = YesLabels { myint :: Int - , myfloat :: Float - } - deriving (Typeable, Data) - --- Test terms -noLabels = NoLabels 42 3.14 -yesLabels = YesLabels 42 3.14 - --- Main function for testing -tests = ( constrFields $ toConstr noLabels - , constrFields $ toConstr yesLabels - ) ~=? output - -output = ([],["myint","myfloat"]) diff --git a/tests/Newtype.hs b/tests/Newtype.hs deleted file mode 100644 --- a/tests/Newtype.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - -module Newtype (tests) where - --- The type of a newtype should treat the newtype as opaque - -import Test.HUnit - -import Data.Generics - -newtype T = MkT Int deriving( Typeable ) - -tests = show (typeOf (undefined :: T)) ~=? output - -output = "Newtype.T" diff --git a/tests/Perm.hs b/tests/Perm.hs deleted file mode 100644 --- a/tests/Perm.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - -module Perm (tests) where - -{- - -This module illustrates permutation phrases. -Disclaimer: this is a perhaps naive, certainly undebugged example. - --} - -import Test.HUnit - -import Control.Monad -import Data.Generics - ---------------------------------------------------------------------------- --- We want to read terms of type T3 regardless of the order T1 and T2. ---------------------------------------------------------------------------- - -data T1 = T1 deriving (Show, Eq, Typeable, Data) -data T2 = T2 deriving (Show, Eq, Typeable, Data) -data T3 = T3 T1 T2 deriving (Show, Eq, Typeable, Data) - - ---------------------------------------------------------------------------- --- A silly monad that we use to read lists of constructor strings. ---------------------------------------------------------------------------- - --- Type constructor -newtype ReadT a = ReadT { unReadT :: [String] -> Maybe ([String],a) } - - - --- Run a computation -runReadT x y = case unReadT x y of - Just ([],y) -> Just y - _ -> Nothing - --- Read one string -readT :: ReadT String -readT = ReadT (\x -> if null x - then Nothing - else Just (tail x, head x) - ) - --- ReadT is a monad! -instance Monad ReadT where - return x = ReadT (\y -> Just (y,x)) - c >>= f = ReadT (\x -> case unReadT c x of - Nothing -> Nothing - Just (x', a) -> unReadT (f a) x' - ) - --- ReadT also accommodates mzero and mplus! -instance MonadPlus ReadT where - mzero = ReadT (const Nothing) - f `mplus` g = ReadT (\x -> case unReadT f x of - Nothing -> unReadT g x - y -> y - ) - - ---------------------------------------------------------------------------- --- A helper type to appeal to predicative type system. ---------------------------------------------------------------------------- - -newtype GenM = GenM { unGenM :: forall a. Data a => a -> ReadT a } - - ---------------------------------------------------------------------------- --- The function that reads and copes with all permutations. ---------------------------------------------------------------------------- - -buildT :: forall a. Data a => ReadT a -buildT = result - - where - result = do str <- readT - con <- string2constr str - ske <- return $ fromConstr con - fs <- return $ gmapQ buildT' ske - perm [] fs ske - - -- Determine type of data to be constructed - myType = myTypeOf result - where - myTypeOf :: forall a. ReadT a -> a - myTypeOf = undefined - - -- Turn string into constructor - string2constr str = maybe mzero - return - (readConstr (dataTypeOf myType) str) - - -- Specialise buildT per kid type - buildT' :: forall a. Data a => a -> GenM - buildT' (_::a) = GenM (const mzero `extM` const (buildT::ReadT a)) - - -- The permutation exploration function - perm :: forall a. Data a => [GenM] -> [GenM] -> a -> ReadT a - perm [] [] a = return a - perm fs [] a = perm [] fs a - perm fs (f:fs') a = ( - do a' <- gmapMo (unGenM f) a - perm fs fs' a' - ) - `mplus` - ( - do guard (not (null fs')) - perm (f:fs) fs' a - ) - - ---------------------------------------------------------------------------- --- The main function for testing ---------------------------------------------------------------------------- - -tests = - ( runReadT buildT ["T1"] :: Maybe T1 -- should parse fine - , ( runReadT buildT ["T2"] :: Maybe T2 -- should parse fine - , ( runReadT buildT ["T3","T1","T2"] :: Maybe T3 -- should parse fine - , ( runReadT buildT ["T3","T2","T1"] :: Maybe T3 -- should parse fine - , ( runReadT buildT ["T3","T2","T2"] :: Maybe T3 -- should fail - ))))) ~=? output - -output = (Just T1,(Just T2,(Just (T3 T1 T2),(Just (T3 T1 T2),Nothing)))) diff --git a/tests/Polymatch.hs b/tests/Polymatch.hs deleted file mode 100644 --- a/tests/Polymatch.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - -module Polymatch () where - - -import Data.Typeable -import Data.Generics - - --- Representation of kids -kids x = gmapQ Kid x -- get all kids -type Kids = [Kid] -data Kid = forall k. Typeable k => Kid k - - --- Build term from a list of kids and the constructor -fromConstrL :: Data a => Kids -> Constr -> Maybe a -fromConstrL l = unIDL . gunfold k z - where - z c = IDL (Just c) l - k (IDL Nothing _) = IDL Nothing undefined - k (IDL (Just f) (Kid x:l)) = IDL f' l - where - f' = case cast x of - (Just x') -> Just (f x') - _ -> Nothing - - --- Helper datatype -data IDL x = IDL (Maybe x) Kids -unIDL (IDL mx _) = mx - - --- Two sample datatypes -data A = A String deriving (Read, Show, Eq, Data, Typeable) -data B = B String deriving (Read, Show, Eq, Data, Typeable) - - --- Mediate between two "left-equal" Either types -f :: (Data a, Data b, Show a, Read b) - => (a->b) -> Either String a -> Either String b - -f g (Right a) = Right $ g a -- conversion really needed --- f g (Left s) = Left s -- unappreciated conversion --- f g s = s -- doesn't typecheck --- f g s = deep_rebuild s -- too expensive -f g s = just (shallow_rebuild s) -- perhaps this is Ok? - - --- Get rid of maybies -just = maybe (error "tried, but failed.") id - - --- Just mentioned for completeness' sake -deep_rebuild :: (Show a, Read b) => a -> b -deep_rebuild = read . show - - --- For the record: it's possible. -shallow_rebuild :: (Data a, Data b) => a -> Maybe b -shallow_rebuild a = b - where - b = fromConstrL (kids a) constr - constr = indexConstr (dataTypeOf b) (constrIndex (toConstr a)) - - --- Test cases -a2b (A s) = B s -- silly conversion -t1 = f a2b (Left "x") -- prints Left "x" -t2 = f a2b (Right (A "y")) -- prints Right (B "y") diff --git a/tests/Twin.hs b/tests/Twin.hs deleted file mode 100644 --- a/tests/Twin.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - -module Twin (tests) where - -{- - -For the discussion in the 2nd boilerplate paper, -we favour some simplified development of twin traversal. -So the full general, stepwise story is in Data.Generics.Twin, -but the short version from the paper is turned into a test -case below. - -See the paper for an explanation. - --} - -import Test.HUnit - -import Data.Generics hiding (GQ,gzipWithQ,geq) - -geq' :: GenericQ (GenericQ Bool) -geq' x y = toConstr x == toConstr y - && and (gzipWithQ geq' x y) - -geq :: Data a => a -> a -> Bool -geq = geq' - -newtype GQ r = GQ (GenericQ r) - -gzipWithQ :: GenericQ (GenericQ r) - -> GenericQ (GenericQ [r]) -gzipWithQ f t1 t2 - = gApplyQ (gmapQ (\x -> GQ (f x)) t1) t2 - -gApplyQ :: Data a => [GQ r] -> a -> [r] -gApplyQ qs t = reverse (snd (gfoldlQ k z t)) - where - k :: ([GQ r], [r]) -> GenericQ ([GQ r], [r]) - k (GQ q : qs, rs) child = (qs, q child : rs) - z = (qs, []) - -newtype R r x = R { unR :: r } - -gfoldlQ :: (r -> GenericQ r) - -> r - -> GenericQ r - -gfoldlQ k z t = unR (gfoldl k' z' t) - where - z' _ = R z - k' (R r) c = R (k r c) - ------------------------------------------------------------------------------ - --- A dependently polymorphic geq -geq'' :: Data a => a -> a -> Bool -geq'' x y = toConstr x == toConstr y - && and (gzipWithQ' geq'' x y) - --- A helper type for existentially quantified queries -data XQ r = forall a. Data a => XQ (a -> r) - --- A dependently polymorphic gzipWithQ -gzipWithQ' :: (forall a. Data a => a -> a -> r) - -> (forall a. Data a => a -> a -> [r]) -gzipWithQ' f t1 t2 - = gApplyQ' (gmapQ (\x -> XQ (f x)) t1) t2 - --- Apply existentially quantified queries --- Insist on equal types! --- -gApplyQ' :: Data a => [XQ r] -> a -> [r] -gApplyQ' qs t = reverse (snd (gfoldlQ k z t)) - where - z = (qs, []) - k :: ([XQ r], [r]) -> GenericQ ([XQ r], [r]) - k (XQ q : qs, rs) child = (qs, q' child : rs) - where - q' = error "Twin mismatch" `extQ` q - - ------------------------------------------------------------------------------ - -tests = ( geq [True,True] [True,True] - , geq [True,True] [True,False] - , geq'' [True,True] [True,True] - , geq'' [True,True] [True,False] - ) ~=? output - -output = (True,False,True,False) diff --git a/tests/Typecase1.hs b/tests/Typecase1.hs deleted file mode 100644 --- a/tests/Typecase1.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - -module Typecase1 (tests) where - -{- - -This test demonstrates type case as it lives in Data.Typeable. -We define a function f that converts typeables into strings in some way. -Note: we only need Data.Typeable. Say: Dynamics are NOT involved. - --} - -import Test.HUnit - -import Data.Typeable -import Data.Maybe - --- Some datatype. -data MyTypeable = MyCons String deriving (Show, Typeable) - --- --- Some function that performs type case. --- -f :: (Show a, Typeable a) => a -> String -f a = (maybe (maybe (maybe others - mytys (cast a) ) - float (cast a) ) - int (cast a) ) - - where - - -- do something with ints - int :: Int -> String - int a = "got an int, incremented: " ++ show (a + 1) - - -- do something with floats - float :: Float -> String - float a = "got a float, multiplied by .42: " ++ show (a * 0.42) - - -- do something with my typeables - mytys :: MyTypeable -> String - mytys a = "got a term: " ++ show a - - -- do something with all other typeables - others = "got something else: " ++ show a - - --- --- Test the type case --- -tests = ( f (41::Int) - , f (88::Float) - , f (MyCons "42") - , f True) ~=? output - -output = ( "got an int, incremented: 42" - , "got a float, multiplied by .42: 36.96" - , "got a term: MyCons \"42\"" - , "got something else: True") diff --git a/tests/Typecase2.hs b/tests/Typecase2.hs deleted file mode 100644 --- a/tests/Typecase2.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - -module Typecase2 (tests) where - -{- - -This test provides a variation on typecase1.hs. -This time, we use generic show as defined for all instances of Data. -Thereby, we get rid of the Show constraint in our functions. -So we only keep a single constraint: the one for class Data. - --} - -import Test.HUnit - -import Data.Generics -import Data.Maybe - --- Some datatype. -data MyData = MyCons String deriving (Typeable, Data) - --- --- Some function that performs type case. --- -f :: Data a => a -> String -f a = (maybe (maybe (maybe others - mytys (cast a) ) - float (cast a) ) - int (cast a) ) - - where - - -- do something with ints - int :: Int -> String - int a = "got an int, incremented: " ++ show (a + 1) - - -- do something with floats - float :: Float -> String - float a = "got a float, multiplied by .42: " ++ show (a * 0.42) - - -- do something with my data - mytys :: MyData -> String - mytys a = "got my data: " ++ gshow a - - -- do something with all other data - others = "got something else: " ++ gshow a - - --- --- Test the type case --- -tests = ( f (41::Int) - , f (88::Float) - , f (MyCons "42") - , f True) ~=? output - -output = ( "got an int, incremented: 42" - , "got a float, multiplied by .42: 36.96" - , "got my data: (MyCons \"42\")" - , "got something else: (True)") - diff --git a/tests/Where.hs b/tests/Where.hs deleted file mode 100644 --- a/tests/Where.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - -module Where (tests) where - -{- - -This example illustrates some differences between certain traversal -schemes. To this end, we use a simple system of datatypes, and the -running example shall be to replace "T1a 42" by "T1a 88". It is our -intention to illustrate a few dimensions of designing traversals. - -1. We can decide on whether we prefer "rewrite steps" (i.e., -monomorphic functions on data) that succeed either for all input -patterns or only if the encounter a term pattern to be replaced. In -the first case, the catch-all equation of such a function describes -identity (see "stepid" below). In the second case, the catch-call -equation describes failure using the Maybe type constructor (see -"stepfail" below). As an intermediate assessment, the failure approach -is more general because it allows one to observe if a rewrite step was -meaningful or not. Often the identity approach is more convenient and -sufficient. - -2. We can now also decide on whether we want monadic or simple -traversals; recall monadic generic functions GenericM from -Data.Generics. The monad can serve for success/failure, state, -environment and others. One can now subdivide monadic traversal -schemes with respect to the question whether they simply support -monadic style of whether they even interact with the relevant -monad. The scheme "everywereM" from the library belongs to the first -category while "somewhere" belongs to the second category as it uses -the operation "mplus" of a monad with addition. So while "everywhereM" -makes very well sense without a monad --- as demonstrated by -"everywhere", the scheme "somewhere" is immediately monadic. - -3. We can now also decide on whether we want rewrite steps to succeed -for all possible subterms, at least for one subterm, exactly for one -subterm, and others. The various traversal schemes make different -assumptions in this respect. - -a) everywhere - - By its type, succeeds and requires non-failing rewrite steps. - However, we do not get any feedback on whether terms were actually - rewritten. (Say, we might have performed accidentally the identity - function on all nodes.) - -b) everywhereM - - Attempts to reach all nodes where all the sub-traversals are performed - in monadic bind-sequence. Failure of the traversal for a given subterm - implies failure of the entire traversal. Hence, the argument of - "everywhereM" should be designed in a way that it tends to succeed - except for the purpose of propagating a proper error in the sense of - violating a pre-/post-condition. For example, "mkM stepfail" should - not be passed to "everywhereM" as it will fail for all but one term - pattern; see "recovered" for a way to massage "stepfail" accordingly. - -c) somewhere - - Descends into term in a top-down manner, and stops in a given - branch when the argument succeeds for the subterm at hand. To this - end, it takes an argument that is perfectly intended to fail for - certain term patterns. Thanks to the employment of gmapF, the - traversal scheme recovers from failure when mapping over the immediate - subterms while insisting success for at least one subterm (say, branch). - This scheme is appropriate if you want to make sure that a given - rewrite step was actually used in a traversal. So failure of the - traversal would mean that the argument failed for all subterms. - -Contributed by Ralf Laemmel, ralf@cwi.nl - --} - -import Test.HUnit - -import Data.Generics -import Control.Monad - - --- Two mutually recursive datatypes -data T1 = T1a Int | T1b T2 deriving (Typeable, Data) -data T2 = T2 T1 deriving (Typeable, Data) - - --- A rewrite step with identity as catch-all case -stepid (T1a 42) = T1a 88 -stepid x = x - - --- The same rewrite step but now with failure as catch-all case -stepfail (T1a 42) = Just (T1a 88) -stepfail _ = Nothing - - --- We can let recover potentially failing generic functions from failure; --- this is illustrated for a generic made from stepfail via mkM. -recovered x = mkM stepfail x `mplus` Just x - - --- A test term that comprehends a redex -term42 = T1b (T2 (T1a 42)) - - --- A test term that does not comprehend a redex -term37 = T1b (T2 (T1a 37)) - - --- A number of traversals -result1 = everywhere (mkT stepid) term42 -- rewrites term accordingly -result2 = everywhere (mkT stepid) term37 -- preserves term without notice -result3 = everywhereM (mkM stepfail) term42 -- fails in a harsh manner -result4 = everywhereM (mkM stepfail) term37 -- fails rather early -result5 = everywhereM recovered term37 -- preserves term without notice -result6 = somewhere (mkMp stepfail) term42 -- rewrites term accordingly -result7 = somewhere (mkMp stepfail) term37 -- fails to notice lack of redex - -tests = gshow ( result1, - ( result2, - ( result3, - ( result4, - ( result5, - ( result6, - ( result7 ))))))) ~=? output - -output = "((,) (T1b (T2 (T1a (88)))) ((,) (T1b (T2 (T1a (37)))) ((,) (Nothing) ((,) (Nothing) ((,) (Just (T1b (T2 (T1a (37))))) ((,) (Just (T1b (T2 (T1a (88))))) (Nothing)))))))" diff --git a/tests/datatype.hs b/tests/datatype.hs new file mode 100644 --- /dev/null +++ b/tests/datatype.hs @@ -0,0 +1,35 @@ +{-# OPTIONS -fglasgow-exts #-} + +-- These are simple tests to observe (data)type representations. +module Datatype (tests) where + +import Test.HUnit + +import Data.Tree +import Data.Generics + +-- A simple polymorphic datatype +data Data a => + MyDataType a = MyDataType a + deriving (Typeable, Data) + + +-- Some terms and corresponding type representations +myTerm = undefined :: MyDataType Int +myTypeRep = typeOf myTerm -- type representation in Typeable +myTyCon = typeRepTyCon myTypeRep -- type constructor via Typeable +myDataType = dataTypeOf myTerm -- datatype representation in Data +myString1 = tyConString myTyCon -- type constructor via Typeable +myString2 = dataTypeName myDataType -- type constructor via Data + +-- Main function for testing +tests = show ( myTypeRep + , ( myDataType + , ( tyconModule myString1 + , ( tyconUQname myString1 + , ( tyconModule myString2 + , ( tyconUQname myString2 + )))))) + ~=? output + +output = "(Datatype.MyDataType Int,(DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]},(\"Datatype\",(\"MyDataType\",(\"Datatype\",\"MyDataType\")))))" diff --git a/tests/encode.hs b/tests/encode.hs new file mode 100644 --- /dev/null +++ b/tests/encode.hs @@ -0,0 +1,81 @@ +{-# OPTIONS -fglasgow-exts #-} + +-- A bit more test code for the 2nd boilerplate paper. +-- These are downscaled versions of library functionality or real test cases. +-- We just wanted to typecheck the fragments as shown in the paper. + +module Encode () where + +import Data.Generics + +data Bit = Zero | One + +------------------------------------------------------------------------------ +-- Sec. 3.2 + +data2bits :: Data a => a -> [Bit] +data2bits t = encodeCon (dataTypeOf t) (toConstr t) + ++ concat (gmapQ data2bits t) + +-- The encoder for constructors +encodeCon :: DataType -> Constr -> [Bit] +encodeCon ty con = natToBin (max-1) (idx-1) + where + max = maxConstrIndex ty + idx = constrIndex con + + +natToBin :: Int -> Int -> [Bit] +natToBin = undefined + +------------------------------------------------------------------------------ +-- Sec. 3.3 + +data State -- Abstract +initState :: State +encodeCon' :: DataType -> Constr + -> State -> (State, [Bit]) + +initState = undefined +encodeCon' = undefined + +data2bits' :: Data a => a -> [Bit] +data2bits' t = snd (show_bin t initState) + +show_bin :: Data a => a -> State -> (State, [Bit]) +show_bin t st = (st2, con_bits ++ args_bits) + where + (st1, con_bits) = encodeCon' (dataTypeOf t) + (toConstr t) st + (st2, args_bits) = foldr do_arg (st1,[]) + enc_args + + enc_args :: [State -> (State,[Bit])] + enc_args = gmapQ show_bin t + + do_arg fn (st,bits) = (st', bits' ++ bits) + where + (st', bits') = fn st + + +------------------------------------------------------------------------------ +-- Sec. 3.3 cont'd + +data EncM a -- The encoder monad +instance Monad EncM + where + return = undefined + c >>= f = undefined + +runEnc :: EncM () -> [Bit] +emitCon :: DataType -> Constr -> EncM () + +runEnc = undefined +emitCon = undefined + +data2bits'' :: Data a => a -> [Bit] +data2bits'' t = runEnc (emit t) + +emit :: Data a => a -> EncM () +emit t = do { emitCon (dataTypeOf t) (toConstr t) + ; sequence_ (gmapQ emit t) } diff --git a/tests/ext.hs b/tests/ext.hs new file mode 100644 --- /dev/null +++ b/tests/ext.hs @@ -0,0 +1,30 @@ +{-# OPTIONS -fglasgow-exts #-} + +module Ext () where + +-- There were typos in these definitions in the ICFP 2004 paper. + +import Data.Generics + +extQ fn spec_fn arg + = case gcast (Q spec_fn) of + Just (Q spec_fn') -> spec_fn' arg + Nothing -> fn arg + +newtype Q r a = Q (a -> r) + +extT fn spec_fn arg + = case gcast (T spec_fn) of + Just (T spec_fn') -> spec_fn' arg + Nothing -> fn arg + +newtype T a = T (a -> a) + +extM :: (Typeable a, Typeable b) + => (a -> m a) -> (b -> m b) -> (a -> m a) +extM fn spec_fn + = case gcast (M spec_fn) of + Just (M spec_fn') -> spec_fn' + Nothing -> fn + +newtype M m a = M (a -> m a) diff --git a/tests/foldTree.hs b/tests/foldTree.hs new file mode 100644 --- /dev/null +++ b/tests/foldTree.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- + +A very, very simple example: "extract all Ints from a tree of Ints". +The text book approach is to write a generalised fold for that. One +can also turn the Tree datatype into functorial style and then write a +Functor instance for the functorial datatype including a definition of +fmap. (The original Tree datatype can be related to the functorial +version by the usual injection and projection.) + +You can scrap all such boilerplate by using a traversal scheme based +on gmap combinators as illustrated below. To get it a little more +interesting, we use a datatype Tree with not just a case for leafs and +fork trees, but we also add a case for trees with a weight. + +For completeness' sake, we mention that the fmap/generalised fold +approach differs from the gmap approach in some details. Most notably, +the gmap approach does not generally facilitate the identification of +term components that relate to the type parameter of a parameterised +datatype. The consequence of this is illustrated below as well. +Sec. 6.3 in "Scrap Your Boilerplate ..." discusses such `type +distinctions' as well. + +-} + +module FoldTree (tests) where + +import Test.HUnit + +-- Enable "ScrapYourBoilerplate" +import Data.Generics + + +-- A parameterised datatype for binary trees with data at the leafs +data (Data a, Data w) => + Tree a w = Leaf a + | Fork (Tree a w) (Tree a w) + | WithWeight (Tree a w) w + deriving (Typeable, Data) + + +-- A typical tree +mytree :: Tree Int Int +mytree = Fork (WithWeight (Leaf 42) 1) + (WithWeight (Fork (Leaf 88) (Leaf 37)) 2) + +-- A less typical tree, used for testing everythingBut +mytree' :: Tree Int Int +mytree' = Fork (Leaf 42) + (WithWeight (Fork (Leaf 88) (Leaf 37)) 2) + + +-- Print everything like an Int in mytree +-- In fact, we show two attempts: +-- 1. print really just everything like an Int +-- 2. print everything wrapped with Leaf +-- So (1.) confuses leafs and weights whereas (2.) does not. +-- Additionally we test everythingBut, stopping when we see a WithWeight node +tests = show ( listify (\(_::Int) -> True) mytree + , everything (++) ([] `mkQ` fromLeaf) mytree + , everythingBut (++) + (([],False) `mkQ` (\x -> (fromLeaf x, stop x))) mytree' + ) ~=? output + where + fromLeaf :: Tree Int Int -> [Int] + fromLeaf (Leaf x) = [x] + fromLeaf _ = [] + stop :: (Data a, Data b) => Tree a b -> Bool + stop (WithWeight _ _) = True + stop _ = False + +output = "([42,1,88,37,2],[42,88,37],[42])" diff --git a/tests/getC.hs b/tests/getC.hs new file mode 100644 --- /dev/null +++ b/tests/getC.hs @@ -0,0 +1,121 @@ +{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE OverlappingInstances, UndecidableInstances #-} + +module GetC (tests) where + +import Test.HUnit + +{- + +Ralf Laemmel, 5 November 2004 + +Joe Stoy suggested the idiom to test for the outermost constructor. + +Given is a term t +and a constructor f (say the empty constructor application). + +isC f t returns True if the outermost constructor of t is f. +isC f t returns False otherwise. +Modulo type checking, i.e., the data type of f and t must be the same. +If not, we want to see a type error, of course. + +-} + +import Data.Typeable -- to cast t's subterms, which will be reused for f. +import Data.Generics -- to access t's subterms and constructors. + + +-- Some silly data types +data T1 = T1a Int String | T1b String Int deriving (Typeable, Data) +data T2 = T2a Int Int | T2b String String deriving (Typeable, Data) +data T3 = T3! Int deriving (Typeable, Data) + + +-- Test cases +tests = show [ isC T1a (T1a 1 "foo") -- typechecks, returns True + , isC T1a (T1b "foo" 1) -- typechecks, returns False + , isC T3 (T3 42)] -- works for strict data too + ~=? output +-- err = show $ isC T2b (T1b "foo" 1) -- must not typecheck + +output = show [True,False,True] + +-- +-- We look at a datum a. +-- We look at a constructor function f. +-- The class GetT checks that f constructs data of type a. +-- The class GetC computes maybe the constructor ... +-- ... if the subterms of the datum at hand fit for f. +-- Finally we compare the constructors. +-- + +isC :: (Data a, GetT f a, GetC f) => f -> a -> Bool +isC f t = maybe False ((==) (toConstr t)) con + where + kids = gmapQ ExTypeable t -- homogenify subterms in list for reuse + con = getC f kids -- compute constructor from constructor application + + +-- +-- We prepare for a list of kids using existential envelopes. +-- We could also just operate on TypeReps for non-strict datatypes. +-- + +data ExTypeable = forall a. Typeable a => ExTypeable a +unExTypeable (ExTypeable a) = cast a + + +-- +-- Compute the result type of a function type. +-- Beware: the TypeUnify constraint causes headache. +-- We can't have GetT t t because the FD will be violated then. +-- We can't omit the FD because unresolvable overlapping will hold then. +-- + +class GetT f t | f -> t -- FD is optional +instance GetT g t => GetT (x -> g) t +instance TypeUnify t t' => GetT t t' + + +-- +-- Obtain the constructor if term can be completed +-- + +class GetC f + where + getC :: f -> [ExTypeable] -> Maybe Constr + +instance (Typeable x, GetC g) => GetC (x -> g) + where + getC _ [] = Nothing + getC (f::x->g) (h:t) + = + do + (x::x) <- unExTypeable h + getC (f x) t + +instance Data t => GetC t + where + getC y [] = Just $ toConstr y + getC _ (_:_) = Nothing + + +-- +-- Type unification; we could try this: +-- class TypeUnify a b | a -> b, b -> a +-- instance TypeUnify a a +-- +-- However, if the instance is placed in the present module, +-- then type improvement would inline this instance. Sigh!!! +-- +-- So we need type unification with type improvement blocker +-- The following solution works with GHC for ages. +-- Other solutions; see the HList paper. +-- + +class TypeUnify a b | a -> b, b -> a +class TypeUnify' x a b | x a -> b, x b -> a +class TypeUnify'' x a b | x a -> b, x b -> a +instance TypeUnify' () a b => TypeUnify a b +instance TypeUnify'' x a b => TypeUnify' x a b +instance TypeUnify'' () a a diff --git a/tests/gread.hs b/tests/gread.hs new file mode 100644 --- /dev/null +++ b/tests/gread.hs @@ -0,0 +1,45 @@ +{-# OPTIONS -fglasgow-exts #-} + +module GRead (tests) where + +{- + +The following examples achieve branch coverage for the various +productions in the definition of gread. Also, negative test cases are +provided; see str2 and str3. Also, the potential of heading or +trailing spaces as well incomplete parsing of the input is exercised; +see str5. + +-} + +import Test.HUnit + +import Data.Generics + +str1 = "(True)" -- reads fine as a Bool +str2 = "(Treu)" -- invalid constructor +str3 = "True" -- lacks parentheses +str4 = "(1)" -- could be an Int +str5 = "( 2 ) ..." -- could be an Int with some trailing left-over +str6 = "([])" -- test empty list +str7 = "((:)" ++ " " ++ str4 ++ " " ++ str6 ++ ")" + +tests = show ( ( [ gread str1, + gread str2, + gread str3 + ] + , [ gread str4, + gread str5 + ] + , [ gread str6, + gread str7 + ] + ) + :: ( [[(Bool, String)]] + , [[(Int, String)]] + , [[([Int], String)]] + ) + ) ~=? output + +output = show + ([[(True,"")],[],[]],[[(1,"")],[(2,"...")]],[[([],"")],[([1],"")]]) diff --git a/tests/gread2.hs b/tests/gread2.hs new file mode 100644 --- /dev/null +++ b/tests/gread2.hs @@ -0,0 +1,66 @@ +{-# OPTIONS -fglasgow-exts #-} + +module GRead2 () where + +{- + +For the discussion in the 2nd boilerplate paper, +we favour some simplified generic read, which is checked to compile. +For the full/real story see Data.Generics.Text. + +-} + +import Data.Generics + +gread :: Data a => String -> Maybe a +gread input = runDec input readM + +-- The decoder monad +newtype DecM a = D (String -> Maybe (String, a)) + +instance Monad DecM where + return a = D (\s -> Just (s,a)) + (D m) >>= k = D (\s -> + case m s of + Nothing -> Nothing + Just (s1,a) -> let D n = k a + in n s1) + +runDec :: String -> DecM a -> Maybe a +runDec input (D m) = do (_,x) <- m input + return x + +parseConstr :: DataType -> DecM Constr +parseConstr ty = D (\s -> + match s (dataTypeConstrs ty)) + where + match :: String -> [Constr] + -> Maybe (String, Constr) + match _ [] = Nothing + match input (con:cons) + | take n input == showConstr con + = Just (drop n input, con) + | otherwise + = match input cons + where + n = length (showConstr con) + + +readM :: forall a. Data a => DecM a +readM = read + where + read :: DecM a + read = do { let val = argOf read + ; let ty = dataTypeOf val + ; constr <- parseConstr ty + ; let con::a = fromConstr constr + ; gmapM (\_ -> readM) con } + +argOf :: c a -> a +argOf = undefined + +yareadM :: forall a. Data a => DecM a +yareadM = do { let ty = dataTypeOf (undefined::a) + ; constr <- parseConstr ty + ; let con::a = fromConstr constr + ; gmapM (\_ -> yareadM) con } diff --git a/tests/gshow2.hs b/tests/gshow2.hs new file mode 100644 --- /dev/null +++ b/tests/gshow2.hs @@ -0,0 +1,47 @@ +{-# OPTIONS -fglasgow-exts #-} + +module GShow2 (tests) where + +{- + +This test exercices GENERIC show for the infamous company datatypes. The +output of the program should be some representation of the infamous +"genCom" company. + +-} + +import Test.HUnit + +import Data.Generics +import CompanyDatatypes + +tests = gshow genCom ~=? output + +{- + +Here is another exercise: +The following function gshow' is a completely generic variation on gshow. +It would print strings as follows: + +*Main> gshow' "abc" +"((:) ('a') ((:) ('b') ((:) ('c') ([]))))" + +The original gshow does a better job because it is customised for strings: + +*Main> gshow "foo" +"\"foo\"" + +In fact, this is what Haskell's normal show would also do: + +*Main> show "foo" +"\"foo\"" + +-} + +gshow' :: Data a => a -> String +gshow' t = "(" + ++ showConstr (toConstr t) + ++ concat (gmapQ ((++) " " . gshow') t) + ++ ")" + +output = "(C ((:) (D \"Research\" (E (P \"Laemmel\" \"Amsterdam\") (S (8000.0))) ((:) (PU (E (P \"Joost\" \"Amsterdam\") (S (1000.0)))) ((:) (PU (E (P \"Marlow\" \"Cambridge\") (S (2000.0)))) ([])))) ((:) (D \"Strategy\" (E (P \"Blair\" \"London\") (S (100000.0))) ([])) ([]))))" diff --git a/tests/hlist.hs b/tests/hlist.hs new file mode 100644 --- /dev/null +++ b/tests/hlist.hs @@ -0,0 +1,62 @@ +{-# OPTIONS -fglasgow-exts #-} + +module HList (tests) where + +{- + +This module illustrates heterogeneously typed lists. + +-} + +import Test.HUnit + +import Data.Typeable + + +-- Heterogeneously typed lists +type HList = [DontKnow] + +data DontKnow = forall a. Typeable a => DontKnow a + +-- The empty list +initHList :: HList +initHList = [] + +-- Add an entry +addHList :: Typeable a => a -> HList -> HList +addHList a l = (DontKnow a:l) + +-- Test for an empty list +nullHList :: HList -> Bool +nullHList = null + +-- Retrieve head by type case +headHList :: Typeable a => HList -> Maybe a +headHList [] = Nothing +headHList (DontKnow a:_) = cast a + +-- Retrieve tail by type case +tailHList :: HList -> HList +tailHList = tail + +-- Access per index; starts at 1 +nth1HList :: Typeable a => Int -> HList -> Maybe a +nth1HList i l = case (l !! (i-1)) of (DontKnow a) -> cast a + + +---------------------------------------------------------------------------- + +-- A demo list +mylist = addHList (1::Int) $ + addHList (True::Bool) $ + addHList ("42"::String) $ + initHList + +-- Main function for testing +tests = ( show (nth1HList 1 mylist :: Maybe Int) -- shows Just 1 + , ( show (nth1HList 1 mylist :: Maybe Bool) -- shows Nothing + , ( show (nth1HList 2 mylist :: Maybe Bool) -- shows Just True + , ( show (nth1HList 3 mylist :: Maybe String) -- shows Just "42" + )))) ~=? output + +output = ("Just 1",("Nothing",("Just True","Just \"42\""))) diff --git a/tests/hopat.hs b/tests/hopat.hs new file mode 100644 --- /dev/null +++ b/tests/hopat.hs @@ -0,0 +1,67 @@ +{-# OPTIONS -fglasgow-exts #-} + +module HOPat (tests) where + +{- + +This module is in reply to an email by C. Barry Jay +received on March 15, and handled within hours. CBJ +raises the very interesting issue of higher-order patterns. +It turns out that some form of it is readily covered in +our setting. + +-} + +import Test.HUnit + +import Data.Generics + + +-- Sample datatypes +data T1 = T1a Int | T1b Float + deriving (Show, Eq, Typeable, Data) +data T2 = T2a T1 T2 | T2b + deriving (Show, Eq, Typeable, Data) + +-- Eliminate a constructor if feasible +elim' :: (Data y, Data x) => Constr -> y -> Maybe x +elim' c y = if toConstr y == c + then unwrap y + else Nothing + + +-- Unwrap a term; Return its single component +unwrap :: (Data y, Data x) => y -> Maybe x +unwrap y = case gmapQ (Nothing `mkQ` Just) y of + [Just x] -> Just x + _ -> Nothing + + +-- Eliminate a constructor if feasible; 2nd try +elim :: forall x y. (Data y, Data x) => (x -> y) -> y -> Maybe x +elim c y = elim' (toConstr (c (undefined::x))) y + + +-- Visit a data structure +visitor :: (Data x, Data y, Data z) + => (x -> y) -> (x -> x) -> z -> z +visitor c f = everywhere (mkT g) + where + g y = case elim c y of + Just x -> c (f x) + Nothing -> y + + +-- Main function for testing +tests = ( ( elim' (toConstr t1a) t1a) :: Maybe Int + , ( (elim' (toConstr t1a) t1b) :: Maybe Int + , ( (elim T1a t1a) :: Maybe Int + , ( (elim T1a t1b) :: Maybe Int + , ( (visitor T1a ((+) 46) t2) :: T2 + ))))) ~=? output + where + t1a = T1a 42 + t1b = T1b 3.14 + t2 = T2a t1a (T2a t1a T2b) + +output = (Just 42,(Nothing,(Just 42,(Nothing,T2a (T1a 88) (T2a (T1a 88) T2b))))) diff --git a/tests/labels.hs b/tests/labels.hs new file mode 100644 --- /dev/null +++ b/tests/labels.hs @@ -0,0 +1,30 @@ +{-# OPTIONS -fglasgow-exts #-} + +module Labels (tests) where + +-- This module tests availability of field labels. + +import Test.HUnit + +import Data.Generics + +-- A datatype without labels +data NoLabels = NoLabels Int Float + deriving (Typeable, Data) + +-- A datatype with labels +data YesLabels = YesLabels { myint :: Int + , myfloat :: Float + } + deriving (Typeable, Data) + +-- Test terms +noLabels = NoLabels 42 3.14 +yesLabels = YesLabels 42 3.14 + +-- Main function for testing +tests = ( constrFields $ toConstr noLabels + , constrFields $ toConstr yesLabels + ) ~=? output + +output = ([],["myint","myfloat"]) diff --git a/tests/newtype.hs b/tests/newtype.hs new file mode 100644 --- /dev/null +++ b/tests/newtype.hs @@ -0,0 +1,15 @@ +{-# OPTIONS -fglasgow-exts #-} + +module Newtype (tests) where + +-- The type of a newtype should treat the newtype as opaque + +import Test.HUnit + +import Data.Generics + +newtype T = MkT Int deriving( Typeable ) + +tests = show (typeOf (undefined :: T)) ~=? output + +output = "Newtype.T" diff --git a/tests/perm.hs b/tests/perm.hs new file mode 100644 --- /dev/null +++ b/tests/perm.hs @@ -0,0 +1,127 @@ +{-# OPTIONS -fglasgow-exts #-} + +module Perm (tests) where + +{- + +This module illustrates permutation phrases. +Disclaimer: this is a perhaps naive, certainly undebugged example. + +-} + +import Test.HUnit + +import Control.Monad +import Data.Generics + +--------------------------------------------------------------------------- +-- We want to read terms of type T3 regardless of the order T1 and T2. +--------------------------------------------------------------------------- + +data T1 = T1 deriving (Show, Eq, Typeable, Data) +data T2 = T2 deriving (Show, Eq, Typeable, Data) +data T3 = T3 T1 T2 deriving (Show, Eq, Typeable, Data) + + +--------------------------------------------------------------------------- +-- A silly monad that we use to read lists of constructor strings. +--------------------------------------------------------------------------- + +-- Type constructor +newtype ReadT a = ReadT { unReadT :: [String] -> Maybe ([String],a) } + + + +-- Run a computation +runReadT x y = case unReadT x y of + Just ([],y) -> Just y + _ -> Nothing + +-- Read one string +readT :: ReadT String +readT = ReadT (\x -> if null x + then Nothing + else Just (tail x, head x) + ) + +-- ReadT is a monad! +instance Monad ReadT where + return x = ReadT (\y -> Just (y,x)) + c >>= f = ReadT (\x -> case unReadT c x of + Nothing -> Nothing + Just (x', a) -> unReadT (f a) x' + ) + +-- ReadT also accommodates mzero and mplus! +instance MonadPlus ReadT where + mzero = ReadT (const Nothing) + f `mplus` g = ReadT (\x -> case unReadT f x of + Nothing -> unReadT g x + y -> y + ) + + +--------------------------------------------------------------------------- +-- A helper type to appeal to predicative type system. +--------------------------------------------------------------------------- + +newtype GenM = GenM { unGenM :: forall a. Data a => a -> ReadT a } + + +--------------------------------------------------------------------------- +-- The function that reads and copes with all permutations. +--------------------------------------------------------------------------- + +buildT :: forall a. Data a => ReadT a +buildT = result + + where + result = do str <- readT + con <- string2constr str + ske <- return $ fromConstr con + fs <- return $ gmapQ buildT' ske + perm [] fs ske + + -- Determine type of data to be constructed + myType = myTypeOf result + where + myTypeOf :: forall a. ReadT a -> a + myTypeOf = undefined + + -- Turn string into constructor + string2constr str = maybe mzero + return + (readConstr (dataTypeOf myType) str) + + -- Specialise buildT per kid type + buildT' :: forall a. Data a => a -> GenM + buildT' (_::a) = GenM (const mzero `extM` const (buildT::ReadT a)) + + -- The permutation exploration function + perm :: forall a. Data a => [GenM] -> [GenM] -> a -> ReadT a + perm [] [] a = return a + perm fs [] a = perm [] fs a + perm fs (f:fs') a = ( + do a' <- gmapMo (unGenM f) a + perm fs fs' a' + ) + `mplus` + ( + do guard (not (null fs')) + perm (f:fs) fs' a + ) + + +--------------------------------------------------------------------------- +-- The main function for testing +--------------------------------------------------------------------------- + +tests = + ( runReadT buildT ["T1"] :: Maybe T1 -- should parse fine + , ( runReadT buildT ["T2"] :: Maybe T2 -- should parse fine + , ( runReadT buildT ["T3","T1","T2"] :: Maybe T3 -- should parse fine + , ( runReadT buildT ["T3","T2","T1"] :: Maybe T3 -- should parse fine + , ( runReadT buildT ["T3","T2","T2"] :: Maybe T3 -- should fail + ))))) ~=? output + +output = (Just T1,(Just T2,(Just (T3 T1 T2),(Just (T3 T1 T2),Nothing)))) diff --git a/tests/polymatch.hs b/tests/polymatch.hs new file mode 100644 --- /dev/null +++ b/tests/polymatch.hs @@ -0,0 +1,70 @@ +{-# OPTIONS -fglasgow-exts #-} + +module Polymatch () where + + +import Data.Typeable +import Data.Generics + + +-- Representation of kids +kids x = gmapQ Kid x -- get all kids +type Kids = [Kid] +data Kid = forall k. Typeable k => Kid k + + +-- Build term from a list of kids and the constructor +fromConstrL :: Data a => Kids -> Constr -> Maybe a +fromConstrL l = unIDL . gunfold k z + where + z c = IDL (Just c) l + k (IDL Nothing _) = IDL Nothing undefined + k (IDL (Just f) (Kid x:l)) = IDL f' l + where + f' = case cast x of + (Just x') -> Just (f x') + _ -> Nothing + + +-- Helper datatype +data IDL x = IDL (Maybe x) Kids +unIDL (IDL mx _) = mx + + +-- Two sample datatypes +data A = A String deriving (Read, Show, Eq, Data, Typeable) +data B = B String deriving (Read, Show, Eq, Data, Typeable) + + +-- Mediate between two "left-equal" Either types +f :: (Data a, Data b, Show a, Read b) + => (a->b) -> Either String a -> Either String b + +f g (Right a) = Right $ g a -- conversion really needed +-- f g (Left s) = Left s -- unappreciated conversion +-- f g s = s -- doesn't typecheck +-- f g s = deep_rebuild s -- too expensive +f g s = just (shallow_rebuild s) -- perhaps this is Ok? + + +-- Get rid of maybies +just = maybe (error "tried, but failed.") id + + +-- Just mentioned for completeness' sake +deep_rebuild :: (Show a, Read b) => a -> b +deep_rebuild = read . show + + +-- For the record: it's possible. +shallow_rebuild :: (Data a, Data b) => a -> Maybe b +shallow_rebuild a = b + where + b = fromConstrL (kids a) constr + constr = indexConstr (dataTypeOf b) (constrIndex (toConstr a)) + + +-- Test cases +a2b (A s) = B s -- silly conversion +t1 = f a2b (Left "x") -- prints Left "x" +t2 = f a2b (Right (A "y")) -- prints Right (B "y") diff --git a/tests/twin.hs b/tests/twin.hs new file mode 100644 --- /dev/null +++ b/tests/twin.hs @@ -0,0 +1,90 @@ +{-# OPTIONS -fglasgow-exts #-} + +module Twin (tests) where + +{- + +For the discussion in the 2nd boilerplate paper, +we favour some simplified development of twin traversal. +So the full general, stepwise story is in Data.Generics.Twin, +but the short version from the paper is turned into a test +case below. + +See the paper for an explanation. + +-} + +import Test.HUnit + +import Data.Generics hiding (GQ,gzipWithQ,geq) + +geq' :: GenericQ (GenericQ Bool) +geq' x y = toConstr x == toConstr y + && and (gzipWithQ geq' x y) + +geq :: Data a => a -> a -> Bool +geq = geq' + +newtype GQ r = GQ (GenericQ r) + +gzipWithQ :: GenericQ (GenericQ r) + -> GenericQ (GenericQ [r]) +gzipWithQ f t1 t2 + = gApplyQ (gmapQ (\x -> GQ (f x)) t1) t2 + +gApplyQ :: Data a => [GQ r] -> a -> [r] +gApplyQ qs t = reverse (snd (gfoldlQ k z t)) + where + k :: ([GQ r], [r]) -> GenericQ ([GQ r], [r]) + k (GQ q : qs, rs) child = (qs, q child : rs) + z = (qs, []) + +newtype R r x = R { unR :: r } + +gfoldlQ :: (r -> GenericQ r) + -> r + -> GenericQ r + +gfoldlQ k z t = unR (gfoldl k' z' t) + where + z' _ = R z + k' (R r) c = R (k r c) + +----------------------------------------------------------------------------- + +-- A dependently polymorphic geq +geq'' :: Data a => a -> a -> Bool +geq'' x y = toConstr x == toConstr y + && and (gzipWithQ' geq'' x y) + +-- A helper type for existentially quantified queries +data XQ r = forall a. Data a => XQ (a -> r) + +-- A dependently polymorphic gzipWithQ +gzipWithQ' :: (forall a. Data a => a -> a -> r) + -> (forall a. Data a => a -> a -> [r]) +gzipWithQ' f t1 t2 + = gApplyQ' (gmapQ (\x -> XQ (f x)) t1) t2 + +-- Apply existentially quantified queries +-- Insist on equal types! +-- +gApplyQ' :: Data a => [XQ r] -> a -> [r] +gApplyQ' qs t = reverse (snd (gfoldlQ k z t)) + where + z = (qs, []) + k :: ([XQ r], [r]) -> GenericQ ([XQ r], [r]) + k (XQ q : qs, rs) child = (qs, q' child : rs) + where + q' = error "Twin mismatch" `extQ` q + + +----------------------------------------------------------------------------- + +tests = ( geq [True,True] [True,True] + , geq [True,True] [True,False] + , geq'' [True,True] [True,True] + , geq'' [True,True] [True,False] + ) ~=? output + +output = (True,False,True,False) diff --git a/tests/typecase1.hs b/tests/typecase1.hs new file mode 100644 --- /dev/null +++ b/tests/typecase1.hs @@ -0,0 +1,59 @@ +{-# OPTIONS -fglasgow-exts #-} + +module Typecase1 (tests) where + +{- + +This test demonstrates type case as it lives in Data.Typeable. +We define a function f that converts typeables into strings in some way. +Note: we only need Data.Typeable. Say: Dynamics are NOT involved. + +-} + +import Test.HUnit + +import Data.Typeable +import Data.Maybe + +-- Some datatype. +data MyTypeable = MyCons String deriving (Show, Typeable) + +-- +-- Some function that performs type case. +-- +f :: (Show a, Typeable a) => a -> String +f a = (maybe (maybe (maybe others + mytys (cast a) ) + float (cast a) ) + int (cast a) ) + + where + + -- do something with ints + int :: Int -> String + int a = "got an int, incremented: " ++ show (a + 1) + + -- do something with floats + float :: Float -> String + float a = "got a float, multiplied by .42: " ++ show (a * 0.42) + + -- do something with my typeables + mytys :: MyTypeable -> String + mytys a = "got a term: " ++ show a + + -- do something with all other typeables + others = "got something else: " ++ show a + + +-- +-- Test the type case +-- +tests = ( f (41::Int) + , f (88::Float) + , f (MyCons "42") + , f True) ~=? output + +output = ( "got an int, incremented: 42" + , "got a float, multiplied by .42: 36.96" + , "got a term: MyCons \"42\"" + , "got something else: True") diff --git a/tests/typecase2.hs b/tests/typecase2.hs new file mode 100644 --- /dev/null +++ b/tests/typecase2.hs @@ -0,0 +1,61 @@ +{-# OPTIONS -fglasgow-exts #-} + +module Typecase2 (tests) where + +{- + +This test provides a variation on typecase1.hs. +This time, we use generic show as defined for all instances of Data. +Thereby, we get rid of the Show constraint in our functions. +So we only keep a single constraint: the one for class Data. + +-} + +import Test.HUnit + +import Data.Generics +import Data.Maybe + +-- Some datatype. +data MyData = MyCons String deriving (Typeable, Data) + +-- +-- Some function that performs type case. +-- +f :: Data a => a -> String +f a = (maybe (maybe (maybe others + mytys (cast a) ) + float (cast a) ) + int (cast a) ) + + where + + -- do something with ints + int :: Int -> String + int a = "got an int, incremented: " ++ show (a + 1) + + -- do something with floats + float :: Float -> String + float a = "got a float, multiplied by .42: " ++ show (a * 0.42) + + -- do something with my data + mytys :: MyData -> String + mytys a = "got my data: " ++ gshow a + + -- do something with all other data + others = "got something else: " ++ gshow a + + +-- +-- Test the type case +-- +tests = ( f (41::Int) + , f (88::Float) + , f (MyCons "42") + , f True) ~=? output + +output = ( "got an int, incremented: 42" + , "got a float, multiplied by .42: 36.96" + , "got my data: (MyCons \"42\")" + , "got something else: (True)") + diff --git a/tests/where.hs b/tests/where.hs new file mode 100644 --- /dev/null +++ b/tests/where.hs @@ -0,0 +1,125 @@ +{-# OPTIONS -fglasgow-exts #-} + +module Where (tests) where + +{- + +This example illustrates some differences between certain traversal +schemes. To this end, we use a simple system of datatypes, and the +running example shall be to replace "T1a 42" by "T1a 88". It is our +intention to illustrate a few dimensions of designing traversals. + +1. We can decide on whether we prefer "rewrite steps" (i.e., +monomorphic functions on data) that succeed either for all input +patterns or only if the encounter a term pattern to be replaced. In +the first case, the catch-all equation of such a function describes +identity (see "stepid" below). In the second case, the catch-call +equation describes failure using the Maybe type constructor (see +"stepfail" below). As an intermediate assessment, the failure approach +is more general because it allows one to observe if a rewrite step was +meaningful or not. Often the identity approach is more convenient and +sufficient. + +2. We can now also decide on whether we want monadic or simple +traversals; recall monadic generic functions GenericM from +Data.Generics. The monad can serve for success/failure, state, +environment and others. One can now subdivide monadic traversal +schemes with respect to the question whether they simply support +monadic style of whether they even interact with the relevant +monad. The scheme "everywereM" from the library belongs to the first +category while "somewhere" belongs to the second category as it uses +the operation "mplus" of a monad with addition. So while "everywhereM" +makes very well sense without a monad --- as demonstrated by +"everywhere", the scheme "somewhere" is immediately monadic. + +3. We can now also decide on whether we want rewrite steps to succeed +for all possible subterms, at least for one subterm, exactly for one +subterm, and others. The various traversal schemes make different +assumptions in this respect. + +a) everywhere + + By its type, succeeds and requires non-failing rewrite steps. + However, we do not get any feedback on whether terms were actually + rewritten. (Say, we might have performed accidentally the identity + function on all nodes.) + +b) everywhereM + + Attempts to reach all nodes where all the sub-traversals are performed + in monadic bind-sequence. Failure of the traversal for a given subterm + implies failure of the entire traversal. Hence, the argument of + "everywhereM" should be designed in a way that it tends to succeed + except for the purpose of propagating a proper error in the sense of + violating a pre-/post-condition. For example, "mkM stepfail" should + not be passed to "everywhereM" as it will fail for all but one term + pattern; see "recovered" for a way to massage "stepfail" accordingly. + +c) somewhere + + Descends into term in a top-down manner, and stops in a given + branch when the argument succeeds for the subterm at hand. To this + end, it takes an argument that is perfectly intended to fail for + certain term patterns. Thanks to the employment of gmapF, the + traversal scheme recovers from failure when mapping over the immediate + subterms while insisting success for at least one subterm (say, branch). + This scheme is appropriate if you want to make sure that a given + rewrite step was actually used in a traversal. So failure of the + traversal would mean that the argument failed for all subterms. + +Contributed by Ralf Laemmel, ralf@cwi.nl + +-} + +import Test.HUnit + +import Data.Generics +import Control.Monad + + +-- Two mutually recursive datatypes +data T1 = T1a Int | T1b T2 deriving (Typeable, Data) +data T2 = T2 T1 deriving (Typeable, Data) + + +-- A rewrite step with identity as catch-all case +stepid (T1a 42) = T1a 88 +stepid x = x + + +-- The same rewrite step but now with failure as catch-all case +stepfail (T1a 42) = Just (T1a 88) +stepfail _ = Nothing + + +-- We can let recover potentially failing generic functions from failure; +-- this is illustrated for a generic made from stepfail via mkM. +recovered x = mkM stepfail x `mplus` Just x + + +-- A test term that comprehends a redex +term42 = T1b (T2 (T1a 42)) + + +-- A test term that does not comprehend a redex +term37 = T1b (T2 (T1a 37)) + + +-- A number of traversals +result1 = everywhere (mkT stepid) term42 -- rewrites term accordingly +result2 = everywhere (mkT stepid) term37 -- preserves term without notice +result3 = everywhereM (mkM stepfail) term42 -- fails in a harsh manner +result4 = everywhereM (mkM stepfail) term37 -- fails rather early +result5 = everywhereM recovered term37 -- preserves term without notice +result6 = somewhere (mkMp stepfail) term42 -- rewrites term accordingly +result7 = somewhere (mkMp stepfail) term37 -- fails to notice lack of redex + +tests = gshow ( result1, + ( result2, + ( result3, + ( result4, + ( result5, + ( result6, + ( result7 ))))))) ~=? output + +output = "((,) (T1b (T2 (T1a (88)))) ((,) (T1b (T2 (T1a (37)))) ((,) (Nothing) ((,) (Nothing) ((,) (Just (T1b (T2 (T1a (37))))) ((,) (Just (T1b (T2 (T1a (88))))) (Nothing)))))))"