packages feed

syb 0.3 → 0.3.1

raw patch · 38 files changed

+1208/−1206 lines, 38 files

Files

src/Data/Generics/Instances.hs view
@@ -1,4 +1,6 @@ {-# OPTIONS_GHC -cpp                  #-}+{-# LANGUAGE DeriveDataTypeable       #-}+{-# LANGUAGE StandaloneDeriving       #-}  ----------------------------------------------------------------------------- -- |
syb.cabal view
@@ -1,5 +1,5 @@ name:                 syb-version:              0.3+version:              0.3.1 license:              BSD3 license-file:         LICENSE author:               Ralf Lammel, Simon Peyton Jones
− tests/Datatype.hs 
@@ -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\")))))"
− tests/Encode.hs 
@@ -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) }
− tests/Ext.hs 
@@ -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)
− tests/FoldTree.hs 
@@ -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])"
− tests/GShow2.hs 
@@ -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))) ([])) ([]))))"
− tests/GetC.hs 
@@ -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
− tests/Gread.hs 
@@ -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],"")]])
− tests/Gread2.hs 
@@ -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 }
− tests/HList.hs 
@@ -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\"")))
− tests/HOPat.hs 
@@ -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)))))
− tests/Labels.hs 
@@ -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"])
− tests/Newtype.hs 
@@ -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"
− tests/Perm.hs 
@@ -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))))
− tests/Polymatch.hs 
@@ -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")
− tests/Twin.hs 
@@ -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)
− tests/Typecase1.hs 
@@ -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")
− tests/Typecase2.hs 
@@ -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)")-
− tests/Where.hs 
@@ -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)))))))"
+ tests/datatype.hs view
@@ -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\")))))"
+ tests/encode.hs view
@@ -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) }
+ tests/ext.hs view
@@ -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)
+ tests/foldTree.hs view
@@ -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])"
+ tests/getC.hs view
@@ -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
+ tests/gread.hs view
@@ -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],"")]])
+ tests/gread2.hs view
@@ -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 }
+ tests/gshow2.hs view
@@ -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))) ([])) ([]))))"
+ tests/hlist.hs view
@@ -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\"")))
+ tests/hopat.hs view
@@ -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)))))
+ tests/labels.hs view
@@ -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"])
+ tests/newtype.hs view
@@ -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"
+ tests/perm.hs view
@@ -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))))
+ tests/polymatch.hs view
@@ -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")
+ tests/twin.hs view
@@ -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)
+ tests/typecase1.hs view
@@ -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")
+ tests/typecase2.hs view
@@ -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)")+
+ tests/where.hs view
@@ -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)))))))"