packages feed

syb 0.3.3 → 0.3.4

raw patch · 75 files changed

+4565/−4574 lines, 75 filessetup-changed

Files

LICENSE view
@@ -1,83 +1,83 @@-This library (libraries/syb) is derived from code from several-sources: --  * Code from the GHC project which is largely (c) The University of-    Glasgow, and distributable under a BSD-style license (see below),--  * Code from the Haskell 98 Report which is (c) Simon Peyton Jones-    and freely redistributable (but see the full license for-    restrictions).--  * Code from the Haskell Foreign Function Interface specification,-    which is (c) Manuel M. T. Chakravarty and freely redistributable-    (but see the full license for restrictions).--The full text of these licenses is reproduced below.  All of the-licenses are BSD-style or compatible.---------------------------------------------------------------------------------The Glasgow Haskell Compiler License--Copyright 2004, The University Court of the University of Glasgow. -All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--- Redistributions of source code must retain the above copyright notice,-this list of conditions and the following disclaimer.- -- Redistributions in binary form must reproduce the above copyright notice,-this list of conditions and the following disclaimer in the documentation-and/or other materials provided with the distribution.- -- Neither name of the University nor the names of its contributors may be-used to endorse or promote products derived from this software without-specific prior written permission. --THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF-GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,-INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND-FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE-UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR-SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER-CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT-LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY-OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH-DAMAGE.---------------------------------------------------------------------------------Code derived from the document "Report on the Programming Language-Haskell 98", is distributed under the following license:--  Copyright (c) 2002 Simon Peyton Jones--  The authors intend this Report to belong to the entire Haskell-  community, and so we grant permission to copy and distribute it for-  any purpose, provided that it is reproduced in its entirety,-  including this Notice.  Modified versions of this Report may also be-  copied and distributed for any purpose, provided that the modified-  version is clearly presented as such, and that it does not claim to-  be a definition of the Haskell 98 Language.---------------------------------------------------------------------------------Code derived from the document "The Haskell 98 Foreign Function-Interface, An Addendum to the Haskell 98 Report" is distributed under-the following license:--  Copyright (c) 2002 Manuel M. T. Chakravarty--  The authors intend this Report to belong to the entire Haskell-  community, and so we grant permission to copy and distribute it for-  any purpose, provided that it is reproduced in its entirety,-  including this Notice.  Modified versions of this Report may also be-  copied and distributed for any purpose, provided that the modified-  version is clearly presented as such, and that it does not claim to-  be a definition of the Haskell 98 Foreign Function Interface.-------------------------------------------------------------------------------+This library (libraries/syb) is derived from code from several
+sources: 
+
+  * Code from the GHC project which is largely (c) The University of
+    Glasgow, and distributable under a BSD-style license (see below),
+
+  * Code from the Haskell 98 Report which is (c) Simon Peyton Jones
+    and freely redistributable (but see the full license for
+    restrictions).
+
+  * Code from the Haskell Foreign Function Interface specification,
+    which is (c) Manuel M. T. Chakravarty and freely redistributable
+    (but see the full license for restrictions).
+
+The full text of these licenses is reproduced below.  All of the
+licenses are BSD-style or compatible.
+
+-----------------------------------------------------------------------------
+
+The Glasgow Haskell Compiler License
+
+Copyright 2004, The University Court of the University of Glasgow. 
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+- Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+ 
+- Redistributions in binary form must reproduce the above copyright notice,
+this list of conditions and the following disclaimer in the documentation
+and/or other materials provided with the distribution.
+ 
+- Neither name of the University nor the names of its contributors may be
+used to endorse or promote products derived from this software without
+specific prior written permission. 
+
+THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGE.
+
+-----------------------------------------------------------------------------
+
+Code derived from the document "Report on the Programming Language
+Haskell 98", is distributed under the following license:
+
+  Copyright (c) 2002 Simon Peyton Jones
+
+  The authors intend this Report to belong to the entire Haskell
+  community, and so we grant permission to copy and distribute it for
+  any purpose, provided that it is reproduced in its entirety,
+  including this Notice.  Modified versions of this Report may also be
+  copied and distributed for any purpose, provided that the modified
+  version is clearly presented as such, and that it does not claim to
+  be a definition of the Haskell 98 Language.
+
+-----------------------------------------------------------------------------
+
+Code derived from the document "The Haskell 98 Foreign Function
+Interface, An Addendum to the Haskell 98 Report" is distributed under
+the following license:
+
+  Copyright (c) 2002 Manuel M. T. Chakravarty
+
+  The authors intend this Report to belong to the entire Haskell
+  community, and so we grant permission to copy and distribute it for
+  any purpose, provided that it is reproduced in its entirety,
+  including this Notice.  Modified versions of this Report may also be
+  copied and distributed for any purpose, provided that the modified
+  version is clearly presented as such, and that it does not claim to
+  be a definition of the Haskell 98 Foreign Function Interface.
+
+-----------------------------------------------------------------------------
README view
@@ -1,43 +1,43 @@-syb: Scrap Your Boilerplate!-================================================================================--Scrap Your Boilerplate (SYB) is a library for generic programming in Haskell. It -is supported since the GHC >= 6.0 implementation of Haskell. Using this -approach, you can write generic functions such as traversal schemes (e.g., -everywhere and everything), as well as generic read, generic show and generic -equality (i.e., gread, gshow, and geq). This approach is based on just a few -primitives for type-safe cast and processing constructor applications. --It was originally developed by Ralf Lämmel and Simon Peyton Jones. Since then, -many people have contributed with research relating to SYB or its applications. --More information is available on the webpage: -http://www.cs.uu.nl/wiki/GenericProgramming/SYB---Features-----------* Easy generic programming with combinators-* GHC can derive Data and Typeable instances for your datatypes-* Comes with many useful generic functions---Requirements---------------* GHC 6.10.1 or later-* Cabal 1.6 or later---Bugs & Support-----------------Please report issues or request features at the bug tracker:--  http://code.google.com/p/scrapyourboilerplate/issues/list--For discussion about the library with the authors, maintainers, and other-interested persons use the mailing list:--  http://www.haskell.org/mailman/listinfo/generics+syb: Scrap Your Boilerplate!
+================================================================================
+
+Scrap Your Boilerplate (SYB) is a library for generic programming in Haskell. It 
+is supported since the GHC >= 6.0 implementation of Haskell. Using this 
+approach, you can write generic functions such as traversal schemes (e.g., 
+everywhere and everything), as well as generic read, generic show and generic 
+equality (i.e., gread, gshow, and geq). This approach is based on just a few 
+primitives for type-safe cast and processing constructor applications. 
+
+It was originally developed by Ralf Lämmel and Simon Peyton Jones. Since then,
+many people have contributed with research relating to SYB or its applications. 
+
+More information is available on the webpage: 
+http://www.cs.uu.nl/wiki/GenericProgramming/SYB
+
+
+Features
+--------
+
+* Easy generic programming with combinators
+* GHC can derive Data and Typeable instances for your datatypes
+* Comes with many useful generic functions
+
+
+Requirements
+------------
+
+* GHC 6.10.1 or later
+* Cabal 1.6 or later
+
+
+Bugs & Support
+--------------
+
+Please report issues or request features at the bug tracker:
+
+  http://code.google.com/p/scrapyourboilerplate/issues/list
+
+For discussion about the library with the authors, maintainers, and other
+interested persons use the mailing list:
+
+  http://www.haskell.org/mailman/listinfo/generics
Setup.hs view
@@ -1,15 +1,15 @@-module Main (main) where--import Distribution.Simple ( defaultMainWithHooks, simpleUserHooks-                           , UserHooks(runTests))-import System.Cmd (system)--main :: IO ()-main = defaultMainWithHooks hooks-  where hooks = simpleUserHooks { runTests = runTests' }---- Runs the testsuite-runTests' _ _ _ _ = system cmd >> return ()-  where testdir = "tests"-        testcmd = "runhaskell ./Main.hs"-        cmd = "cd " ++ testdir ++ " && " ++ testcmd+module Main (main) where
+
+import Distribution.Simple ( defaultMainWithHooks, simpleUserHooks
+                           , UserHooks(runTests))
+import System.Cmd (system)
+
+main :: IO ()
+main = defaultMainWithHooks hooks
+  where hooks = simpleUserHooks { runTests = runTests' }
+
+-- Runs the testsuite
+runTests' _ _ _ _ = system cmd >> return ()
+  where testdir = "tests"
+        testcmd = "runhaskell ./Main.hs"
+        cmd = "cd " ++ testdir ++ " && " ++ testcmd
src/Data/Generics.hs view
@@ -1,43 +1,40 @@-{-# OPTIONS_GHC -cpp                  #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics--- Copyright   :  (c) The University of Glasgow, CWI 2001--2004--- License     :  BSD-style (see the LICENSE file)--- --- Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable (uses Data.Generics.Basics)------ \"Scrap your boilerplate\" --- Generic programming in Haskell --- See <http://www.cs.vu.nl/boilerplate/>. To scrap your boilerplate it--- is sufficient to import the present module, which simply re-exports all--- themes of the Data.Generics library.------ For more information, please visit the new--- SYB wiki: <http://www.cs.uu.nl/wiki/bin/view/GenericProgramming/SYB>.-----------------------------------------------------------------------------------module Data.Generics (--  -- * All Data.Generics modules-  module Data.Data,               -- primitives and instances of the Data class-  module Data.Generics.Aliases,   -- aliases for type case, generic types-  module Data.Generics.Schemes,   -- traversal schemes (everywhere etc.)-  module Data.Generics.Text,      -- generic read and show-  module Data.Generics.Twins,     -- twin traversal, e.g., generic eq-  module Data.Generics.Builders,  -- term builders-- ) where----------------------------------------------------------------------------------import Data.Data-import Data.Generics.Instances ()-import Data.Generics.Aliases-import Data.Generics.Schemes-import Data.Generics.Text-import Data.Generics.Twins-import Data.Generics.Builders+{-# OPTIONS_GHC -cpp                  #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Generics
+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004
+-- License     :  BSD-style (see the LICENSE file)
+-- 
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (uses Data.Generics.Basics)
+--
+-- \"Scrap your boilerplate\" --- Generic programming in Haskell 
+-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. To scrap your
+-- boilerplate it is sufficient to import the present module, which simply
+-- re-exports all themes of the Data.Generics library.
+--
+-----------------------------------------------------------------------------
+
+module Data.Generics (
+
+  -- * All Data.Generics modules
+  module Data.Data,               -- primitives and instances of the Data class
+  module Data.Generics.Aliases,   -- aliases for type case, generic types
+  module Data.Generics.Schemes,   -- traversal schemes (everywhere etc.)
+  module Data.Generics.Text,      -- generic read and show
+  module Data.Generics.Twins,     -- twin traversal, e.g., generic eq
+  module Data.Generics.Builders,  -- term builders
+
+ ) where
+
+------------------------------------------------------------------------------
+
+import Data.Data
+import Data.Generics.Instances ()
+import Data.Generics.Aliases
+import Data.Generics.Schemes
+import Data.Generics.Text
+import Data.Generics.Twins
+import Data.Generics.Builders
src/Data/Generics/Aliases.hs view
@@ -1,436 +1,436 @@-{-# OPTIONS_GHC -cpp                  #-}-{-# LANGUAGE Rank2Types               #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Aliases--- Copyright   :  (c) The University of Glasgow, CWI 2001--2004--- License     :  BSD-style (see the LICENSE file)--- --- Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable (local universal quantification)------ \"Scrap your boilerplate\" --- Generic programming in Haskell --- See <http://www.cs.vu.nl/boilerplate/>. The present module provides--- a number of declarations for typical generic function types,--- corresponding type case, and others.-----------------------------------------------------------------------------------module Data.Generics.Aliases (--        -- * Combinators to \"make\" generic functions via cast-        mkT, mkQ, mkM, mkMp, mkR,-        ext0, extT, extQ, extM, extMp, extB, extR,--        -- * Type synonyms for generic function types-        GenericT,-        GenericQ,-        GenericM,-        GenericB,-        GenericR,-        Generic,-        Generic'(..),-        GenericT'(..),-        GenericQ'(..),-        GenericM'(..),--        -- * Ingredients of generic functions-        orElse,--        -- * Function combinators on generic functions-        recoverMp,-        recoverQ,-        choiceMp,-        choiceQ,--        -- * Type extension for unary type constructors-        ext1,-        ext1T,-        ext1M,-        ext1Q,-        ext1R,-        ext1B,--        -- * Type extension for binary type constructors-        ext2T,-        ext2M,-        ext2Q,-        ext2R,-        ext2B--  ) where--#ifdef __HADDOCK__-import Prelude-#endif-import Control.Monad-import Data.Data--------------------------------------------------------------------------------------      Combinators to "make" generic functions---      We use type-safe cast in a number of ways to make generic functions.-------------------------------------------------------------------------------------- | Make a generic transformation;---   start from a type-specific case;---   preserve the term otherwise----mkT :: ( Typeable a-       , Typeable b-       )-    => (b -> b)-    -> a-    -> a-mkT = extT id----- | Make a generic query;---   start from a type-specific case;---   return a constant otherwise----mkQ :: ( Typeable a-       , Typeable b-       )-    => r-    -> (b -> r)-    -> a-    -> r-(r `mkQ` br) a = case cast a of-                        Just b  -> br b-                        Nothing -> r----- | Make a generic monadic transformation;---   start from a type-specific case;---   resort to return otherwise----mkM :: ( Monad m-       , Typeable a-       , Typeable b-       )-    => (b -> m b)-    -> a-    -> m a-mkM = extM return---{---For the remaining definitions, we stick to a more concise style, i.e.,-we fold maybes with "maybe" instead of case ... of ..., and we also-use a point-free style whenever possible.---}----- | Make a generic monadic transformation for MonadPlus;---   use \"const mzero\" (i.e., failure) instead of return as default.----mkMp :: ( MonadPlus m-        , Typeable a-        , Typeable b-        )-     => (b -> m b)-     -> a-     -> m a-mkMp = extM (const mzero)----- | Make a generic builder;---   start from a type-specific ase;---   resort to no build (i.e., mzero) otherwise----mkR :: ( MonadPlus m-       , Typeable a-       , Typeable b-       )-    => m b -> m a-mkR f = mzero `extR` f----- | Flexible type extension-ext0 :: (Typeable a, Typeable b) => c a -> c b -> c a-ext0 def ext = maybe def id (gcast ext)----- | Extend a generic transformation by a type-specific case-extT :: ( Typeable a-        , Typeable b-        )-     => (a -> a)-     -> (b -> b)-     -> a-     -> a-extT def ext = unT ((T def) `ext0` (T ext))----- | Extend a generic query by a type-specific case-extQ :: ( Typeable a-        , Typeable b-        )-     => (a -> q)-     -> (b -> q)-     -> a-     -> q-extQ f g a = maybe (f a) g (cast a)----- | Extend a generic monadic transformation by a type-specific case-extM :: ( Monad m-        , Typeable a-        , Typeable b-        )-     => (a -> m a) -> (b -> m b) -> a -> m a-extM def ext = unM ((M def) `ext0` (M ext))----- | Extend a generic MonadPlus transformation by a type-specific case-extMp :: ( MonadPlus m-         , Typeable a-         , Typeable b-         )-      => (a -> m a) -> (b -> m b) -> a -> m a-extMp = extM----- | Extend a generic builder-extB :: ( Typeable a-        , Typeable b-        )-     => a -> b -> a-extB a = maybe a id . cast----- | Extend a generic reader-extR :: ( Monad m-        , Typeable a-        , Typeable b-        )-     => m a -> m b -> m a-extR def ext = unR ((R def) `ext0` (R ext))----------------------------------------------------------------------------------------      Type synonyms for generic function types--------------------------------------------------------------------------------------- | Generic transformations,---   i.e., take an \"a\" and return an \"a\"----type GenericT = forall a. Data a => a -> a----- | Generic queries of type \"r\",---   i.e., take any \"a\" and return an \"r\"----type GenericQ r = forall a. Data a => a -> r----- | Generic monadic transformations,---   i.e., take an \"a\" and compute an \"a\"----type GenericM m = forall a. Data a => a -> m a----- | Generic builders---   i.e., produce an \"a\".----type GenericB = forall a. Data a => a----- | Generic readers, say monadic builders,---   i.e., produce an \"a\" with the help of a monad \"m\".----type GenericR m = forall a. Data a => m a----- | The general scheme underlying generic functions---   assumed by gfoldl; there are isomorphisms such as---   GenericT = Generic T.----type Generic c = forall a. Data a => a -> c a----- | Wrapped generic functions;---   recall: [Generic c] would be legal but [Generic' c] not.----data Generic' c = Generic' { unGeneric' :: Generic c }----- | Other first-class polymorphic wrappers-newtype GenericT'   = GT { unGT :: forall a. Data a => a -> a }-newtype GenericQ' r = GQ { unGQ :: GenericQ r }-newtype GenericM' m = GM { unGM :: forall a. Data a => a -> m a }----- | Left-biased choice on maybes-orElse :: Maybe a -> Maybe a -> Maybe a-x `orElse` y = case x of-                 Just _  -> x-                 Nothing -> y---{---The following variations take "orElse" to the function-level. Furthermore, we generalise from "Maybe" to any-"MonadPlus". This makes sense for monadic transformations and-queries. We say that the resulting combinators modell choice. We also-provide a prime example of choice, that is, recovery from failure. In-the case of transformations, we recover via return whereas for-queries a given constant is returned.---}---- | Choice for monadic transformations-choiceMp :: MonadPlus m => GenericM m -> GenericM m -> GenericM m-choiceMp f g x = f x `mplus` g x----- | Choice for monadic queries-choiceQ :: MonadPlus m => GenericQ (m r) -> GenericQ (m r) -> GenericQ (m r)-choiceQ f g x = f x `mplus` g x----- | Recover from the failure of monadic transformation by identity-recoverMp :: MonadPlus m => GenericM m -> GenericM m-recoverMp f = f `choiceMp` return----- | Recover from the failure of monadic query by a constant-recoverQ :: MonadPlus m => r -> GenericQ (m r) -> GenericQ (m r)-recoverQ r f = f `choiceQ` const (return r)-------------------------------------------------------------------------------------      Type extension for unary type constructors----------------------------------------------------------------------------------- | Flexible type extension-ext1 :: (Data a, Typeable1 t)-     => c a-     -> (forall d. Data d => c (t d))-     -> c a-ext1 def ext = maybe def id (dataCast1 ext)----- | Type extension of transformations for unary type constructors-ext1T :: (Data d, Typeable1 t)-      => (forall e. Data e => e -> e)-      -> (forall f. Data f => t f -> t f)-      -> d -> d-ext1T def ext = unT ((T def) `ext1` (T ext))----- | Type extension of monadic transformations for type constructors-ext1M :: (Monad m, Data d, Typeable1 t)-      => (forall e. Data e => e -> m e)-      -> (forall f. Data f => t f -> m (t f))-      -> d -> m d-ext1M def ext = unM ((M def) `ext1` (M ext))----- | Type extension of queries for type constructors-ext1Q :: (Data d, Typeable1 t)-      => (d -> q)-      -> (forall e. Data e => t e -> q)-      -> d -> q-ext1Q def ext = unQ ((Q def) `ext1` (Q ext))----- | Type extension of readers for type constructors-ext1R :: (Monad m, Data d, Typeable1 t)-      => m d-      -> (forall e. Data e => m (t e))-      -> m d-ext1R def ext = unR ((R def) `ext1` (R ext))----- | Type extension of builders for type constructors-ext1B :: (Data a, Typeable1 t)-      => a-      -> (forall b. Data b => (t b))-      -> a-ext1B def ext = unB ((B def) `ext1` (B ext))-----------------------------------------------------------------------------------      Type extension for binary type constructors----------------------------------------------------------------------------------- | Flexible type extension-ext2 :: (Data a, Typeable2 t)-     => c a-     -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))-     -> c a-ext2 def ext = maybe def id (dataCast2 ext)----- | Type extension of transformations for unary type constructors-ext2T :: (Data d, Typeable2 t)-      => (forall e. Data e => e -> e)-      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> t d1 d2)-      -> d -> d-ext2T def ext = unT ((T def) `ext2` (T ext))----- | Type extension of monadic transformations for type constructors-ext2M :: (Monad m, Data d, Typeable2 t)-      => (forall e. Data e => e -> m e)-      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> m (t d1 d2))-      -> d -> m d-ext2M def ext = unM ((M def) `ext2` (M ext))----- | Type extension of queries for type constructors-ext2Q :: (Data d, Typeable2 t)-      => (d -> q)-      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)-      -> d -> q-ext2Q def ext = unQ ((Q def) `ext2` (Q ext))----- | Type extension of readers for type constructors-ext2R :: (Monad m, Data d, Typeable2 t)-      => m d-      -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2))-      -> m d-ext2R def ext = unR ((R def) `ext2` (R ext))----- | Type extension of builders for type constructors-ext2B :: (Data a, Typeable2 t)-      => a-      -> (forall d1 d2. (Data d1, Data d2) => (t d1 d2))-      -> a-ext2B def ext = unB ((B def) `ext2` (B ext))--------------------------------------------------------------------------------------      Type constructors for type-level lambdas--------------------------------------------------------------------------------------- | The type constructor for transformations-newtype T x = T { unT :: x -> x }---- | The type constructor for transformations-newtype M m x = M { unM :: x -> m x }---- | The type constructor for queries-newtype Q q x = Q { unQ :: x -> q }---- | The type constructor for readers-newtype R m x = R { unR :: m x }---- | The type constructor for builders-newtype B x = B {unB :: x}+{-# OPTIONS_GHC -cpp                  #-}
+{-# LANGUAGE Rank2Types               #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Generics.Aliases
+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004
+-- License     :  BSD-style (see the LICENSE file)
+-- 
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (local universal quantification)
+--
+-- \"Scrap your boilerplate\" --- Generic programming in Haskell 
+-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>.
+-- The present module provides a number of declarations for typical generic
+-- function types, corresponding type case, and others.
+--
+-----------------------------------------------------------------------------
+
+module Data.Generics.Aliases (
+
+        -- * Combinators to \"make\" generic functions via cast
+        mkT, mkQ, mkM, mkMp, mkR,
+        ext0, extT, extQ, extM, extMp, extB, extR,
+
+        -- * Type synonyms for generic function types
+        GenericT,
+        GenericQ,
+        GenericM,
+        GenericB,
+        GenericR,
+        Generic,
+        Generic'(..),
+        GenericT'(..),
+        GenericQ'(..),
+        GenericM'(..),
+
+        -- * Ingredients of generic functions
+        orElse,
+
+        -- * Function combinators on generic functions
+        recoverMp,
+        recoverQ,
+        choiceMp,
+        choiceQ,
+
+        -- * Type extension for unary type constructors
+        ext1,
+        ext1T,
+        ext1M,
+        ext1Q,
+        ext1R,
+        ext1B,
+
+        -- * Type extension for binary type constructors
+        ext2T,
+        ext2M,
+        ext2Q,
+        ext2R,
+        ext2B
+
+  ) where
+
+#ifdef __HADDOCK__
+import Prelude
+#endif
+import Control.Monad
+import Data.Data
+
+------------------------------------------------------------------------------
+--
+--      Combinators to "make" generic functions
+--      We use type-safe cast in a number of ways to make generic functions.
+--
+------------------------------------------------------------------------------
+
+-- | Make a generic transformation;
+--   start from a type-specific case;
+--   preserve the term otherwise
+--
+mkT :: ( Typeable a
+       , Typeable b
+       )
+    => (b -> b)
+    -> a
+    -> a
+mkT = extT id
+
+
+-- | Make a generic query;
+--   start from a type-specific case;
+--   return a constant otherwise
+--
+mkQ :: ( Typeable a
+       , Typeable b
+       )
+    => r
+    -> (b -> r)
+    -> a
+    -> r
+(r `mkQ` br) a = case cast a of
+                        Just b  -> br b
+                        Nothing -> r
+
+
+-- | Make a generic monadic transformation;
+--   start from a type-specific case;
+--   resort to return otherwise
+--
+mkM :: ( Monad m
+       , Typeable a
+       , Typeable b
+       )
+    => (b -> m b)
+    -> a
+    -> m a
+mkM = extM return
+
+
+{-
+
+For the remaining definitions, we stick to a more concise style, i.e.,
+we fold maybes with "maybe" instead of case ... of ..., and we also
+use a point-free style whenever possible.
+
+-}
+
+
+-- | Make a generic monadic transformation for MonadPlus;
+--   use \"const mzero\" (i.e., failure) instead of return as default.
+--
+mkMp :: ( MonadPlus m
+        , Typeable a
+        , Typeable b
+        )
+     => (b -> m b)
+     -> a
+     -> m a
+mkMp = extM (const mzero)
+
+
+-- | Make a generic builder;
+--   start from a type-specific ase;
+--   resort to no build (i.e., mzero) otherwise
+--
+mkR :: ( MonadPlus m
+       , Typeable a
+       , Typeable b
+       )
+    => m b -> m a
+mkR f = mzero `extR` f
+
+
+-- | Flexible type extension
+ext0 :: (Typeable a, Typeable b) => c a -> c b -> c a
+ext0 def ext = maybe def id (gcast ext)
+
+
+-- | Extend a generic transformation by a type-specific case
+extT :: ( Typeable a
+        , Typeable b
+        )
+     => (a -> a)
+     -> (b -> b)
+     -> a
+     -> a
+extT def ext = unT ((T def) `ext0` (T ext))
+
+
+-- | Extend a generic query by a type-specific case
+extQ :: ( Typeable a
+        , Typeable b
+        )
+     => (a -> q)
+     -> (b -> q)
+     -> a
+     -> q
+extQ f g a = maybe (f a) g (cast a)
+
+
+-- | Extend a generic monadic transformation by a type-specific case
+extM :: ( Monad m
+        , Typeable a
+        , Typeable b
+        )
+     => (a -> m a) -> (b -> m b) -> a -> m a
+extM def ext = unM ((M def) `ext0` (M ext))
+
+
+-- | Extend a generic MonadPlus transformation by a type-specific case
+extMp :: ( MonadPlus m
+         , Typeable a
+         , Typeable b
+         )
+      => (a -> m a) -> (b -> m b) -> a -> m a
+extMp = extM
+
+
+-- | Extend a generic builder
+extB :: ( Typeable a
+        , Typeable b
+        )
+     => a -> b -> a
+extB a = maybe a id . cast
+
+
+-- | Extend a generic reader
+extR :: ( Monad m
+        , Typeable a
+        , Typeable b
+        )
+     => m a -> m b -> m a
+extR def ext = unR ((R def) `ext0` (R ext))
+
+
+
+------------------------------------------------------------------------------
+--
+--      Type synonyms for generic function types
+--
+------------------------------------------------------------------------------
+
+
+-- | Generic transformations,
+--   i.e., take an \"a\" and return an \"a\"
+--
+type GenericT = forall a. Data a => a -> a
+
+
+-- | Generic queries of type \"r\",
+--   i.e., take any \"a\" and return an \"r\"
+--
+type GenericQ r = forall a. Data a => a -> r
+
+
+-- | Generic monadic transformations,
+--   i.e., take an \"a\" and compute an \"a\"
+--
+type GenericM m = forall a. Data a => a -> m a
+
+
+-- | Generic builders
+--   i.e., produce an \"a\".
+--
+type GenericB = forall a. Data a => a
+
+
+-- | Generic readers, say monadic builders,
+--   i.e., produce an \"a\" with the help of a monad \"m\".
+--
+type GenericR m = forall a. Data a => m a
+
+
+-- | The general scheme underlying generic functions
+--   assumed by gfoldl; there are isomorphisms such as
+--   GenericT = Generic T.
+--
+type Generic c = forall a. Data a => a -> c a
+
+
+-- | Wrapped generic functions;
+--   recall: [Generic c] would be legal but [Generic' c] not.
+--
+data Generic' c = Generic' { unGeneric' :: Generic c }
+
+
+-- | Other first-class polymorphic wrappers
+newtype GenericT'   = GT { unGT :: forall a. Data a => a -> a }
+newtype GenericQ' r = GQ { unGQ :: GenericQ r }
+newtype GenericM' m = GM { unGM :: forall a. Data a => a -> m a }
+
+
+-- | Left-biased choice on maybes
+orElse :: Maybe a -> Maybe a -> Maybe a
+x `orElse` y = case x of
+                 Just _  -> x
+                 Nothing -> y
+
+
+{-
+
+The following variations take "orElse" to the function
+level. Furthermore, we generalise from "Maybe" to any
+"MonadPlus". This makes sense for monadic transformations and
+queries. We say that the resulting combinators modell choice. We also
+provide a prime example of choice, that is, recovery from failure. In
+the case of transformations, we recover via return whereas for
+queries a given constant is returned.
+
+-}
+
+-- | Choice for monadic transformations
+choiceMp :: MonadPlus m => GenericM m -> GenericM m -> GenericM m
+choiceMp f g x = f x `mplus` g x
+
+
+-- | Choice for monadic queries
+choiceQ :: MonadPlus m => GenericQ (m r) -> GenericQ (m r) -> GenericQ (m r)
+choiceQ f g x = f x `mplus` g x
+
+
+-- | Recover from the failure of monadic transformation by identity
+recoverMp :: MonadPlus m => GenericM m -> GenericM m
+recoverMp f = f `choiceMp` return
+
+
+-- | Recover from the failure of monadic query by a constant
+recoverQ :: MonadPlus m => r -> GenericQ (m r) -> GenericQ (m r)
+recoverQ r f = f `choiceQ` const (return r)
+
+
+
+------------------------------------------------------------------------------
+--      Type extension for unary type constructors
+------------------------------------------------------------------------------
+
+-- | Flexible type extension
+ext1 :: (Data a, Typeable1 t)
+     => c a
+     -> (forall d. Data d => c (t d))
+     -> c a
+ext1 def ext = maybe def id (dataCast1 ext)
+
+
+-- | Type extension of transformations for unary type constructors
+ext1T :: (Data d, Typeable1 t)
+      => (forall e. Data e => e -> e)
+      -> (forall f. Data f => t f -> t f)
+      -> d -> d
+ext1T def ext = unT ((T def) `ext1` (T ext))
+
+
+-- | Type extension of monadic transformations for type constructors
+ext1M :: (Monad m, Data d, Typeable1 t)
+      => (forall e. Data e => e -> m e)
+      -> (forall f. Data f => t f -> m (t f))
+      -> d -> m d
+ext1M def ext = unM ((M def) `ext1` (M ext))
+
+
+-- | Type extension of queries for type constructors
+ext1Q :: (Data d, Typeable1 t)
+      => (d -> q)
+      -> (forall e. Data e => t e -> q)
+      -> d -> q
+ext1Q def ext = unQ ((Q def) `ext1` (Q ext))
+
+
+-- | Type extension of readers for type constructors
+ext1R :: (Monad m, Data d, Typeable1 t)
+      => m d
+      -> (forall e. Data e => m (t e))
+      -> m d
+ext1R def ext = unR ((R def) `ext1` (R ext))
+
+
+-- | Type extension of builders for type constructors
+ext1B :: (Data a, Typeable1 t)
+      => a
+      -> (forall b. Data b => (t b))
+      -> a
+ext1B def ext = unB ((B def) `ext1` (B ext))
+
+------------------------------------------------------------------------------
+--      Type extension for binary type constructors
+------------------------------------------------------------------------------
+
+-- | Flexible type extension
+ext2 :: (Data a, Typeable2 t)
+     => c a
+     -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))
+     -> c a
+ext2 def ext = maybe def id (dataCast2 ext)
+
+
+-- | Type extension of transformations for unary type constructors
+ext2T :: (Data d, Typeable2 t)
+      => (forall e. Data e => e -> e)
+      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> t d1 d2)
+      -> d -> d
+ext2T def ext = unT ((T def) `ext2` (T ext))
+
+
+-- | Type extension of monadic transformations for type constructors
+ext2M :: (Monad m, Data d, Typeable2 t)
+      => (forall e. Data e => e -> m e)
+      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> m (t d1 d2))
+      -> d -> m d
+ext2M def ext = unM ((M def) `ext2` (M ext))
+
+
+-- | Type extension of queries for type constructors
+ext2Q :: (Data d, Typeable2 t)
+      => (d -> q)
+      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
+      -> d -> q
+ext2Q def ext = unQ ((Q def) `ext2` (Q ext))
+
+
+-- | Type extension of readers for type constructors
+ext2R :: (Monad m, Data d, Typeable2 t)
+      => m d
+      -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2))
+      -> m d
+ext2R def ext = unR ((R def) `ext2` (R ext))
+
+
+-- | Type extension of builders for type constructors
+ext2B :: (Data a, Typeable2 t)
+      => a
+      -> (forall d1 d2. (Data d1, Data d2) => (t d1 d2))
+      -> a
+ext2B def ext = unB ((B def) `ext2` (B ext))
+
+------------------------------------------------------------------------------
+--
+--      Type constructors for type-level lambdas
+--
+------------------------------------------------------------------------------
+
+
+-- | The type constructor for transformations
+newtype T x = T { unT :: x -> x }
+
+-- | The type constructor for transformations
+newtype M m x = M { unM :: x -> m x }
+
+-- | The type constructor for queries
+newtype Q q x = Q { unQ :: x -> q }
+
+-- | The type constructor for readers
+newtype R m x = R { unR :: m x }
+
+-- | The type constructor for builders
+newtype B x = B {unB :: x}
src/Data/Generics/Basics.hs view
@@ -1,26 +1,23 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Basics--- Copyright   :  (c) The University of Glasgow, CWI 2001--2004--- License     :  BSD-style (see the LICENSE file)--- --- Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable (local universal quantification)------ \"Scrap your boilerplate\" --- Generic programming in Haskell.--- See <http://www.cs.vu.nl/boilerplate/>. This module provides--- the 'Data' class with its primitives for generic programming,--- which is now defined in @Data.Data@. Therefore this module simply--- re-exports @Data.Data@.------ For more information, please visit the new--- SYB wiki: <http://www.cs.uu.nl/wiki/bin/view/GenericProgramming/SYB>.-----------------------------------------------------------------------------------module Data.Generics.Basics (-        module Data.Data-  ) where--import Data.Data+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Generics.Basics
+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004
+-- License     :  BSD-style (see the LICENSE file)
+-- 
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (local universal quantification)
+--
+-- \"Scrap your boilerplate\" --- Generic programming in Haskell.
+-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. This module provides
+-- the 'Data' class with its primitives for generic programming,
+-- which is now defined in @Data.Data@. Therefore this module simply
+-- re-exports @Data.Data@.
+--
+-----------------------------------------------------------------------------
+
+module Data.Generics.Basics (
+        module Data.Data
+  ) where
+
+import Data.Data
src/Data/Generics/Instances.hs view
@@ -1,195 +1,192 @@-{-# OPTIONS_GHC -cpp                  #-}-{-# LANGUAGE DeriveDataTypeable       #-}-{-# LANGUAGE StandaloneDeriving       #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Instances--- Copyright   :  (c) The University of Glasgow, CWI 2001--2004--- License     :  BSD-style (see the LICENSE file)--- --- Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable (uses Data.Data)------ \"Scrap your boilerplate\" --- Generic programming in Haskell --- See <http://www.cs.vu.nl/boilerplate/>. The present module--- contains thirteen 'Data' instances which are considered dubious (either--- because the types are abstract or just not meant to be traversed).--- Instances in this module might change or disappear in future releases--- of this package. ------ For more information, please visit the new--- SYB wiki: <http://www.cs.uu.nl/wiki/bin/view/GenericProgramming/SYB>.------ (This module does not export anything. It really just defines instances.)-----------------------------------------------------------------------------------{-# OPTIONS_GHC -fno-warn-orphans #-}-module Data.Generics.Instances () where----------------------------------------------------------------------------------import Data.Data--#ifdef __GLASGOW_HASKELL__-#if __GLASGOW_HASKELL__ >= 611-import GHC.IO.Handle         -- So we can give Data instance for Handle-#else-import GHC.IOBase            -- So we can give Data instance for IO, Handle-#endif-import GHC.Stable            -- So we can give Data instance for StablePtr-import GHC.ST                -- So we can give Data instance for ST-import GHC.Conc              -- So we can give Data instance for TVar-import Data.IORef            -- So we can give Data instance for IORef-import Control.Concurrent    -- So we can give Data instance for MVar-#else-# ifdef __HUGS__-import Hugs.Prelude( Ratio(..) )-# endif-import System.IO-import Foreign.Ptr-import Foreign.ForeignPtr-import Foreign.StablePtr-import Control.Monad.ST-#endif--#include "Typeable.h"---- Version compatibility issues caused by #2760-myMkNoRepType :: String -> DataType-#if __GLASGOW_HASKELL__ >= 611-myMkNoRepType = mkNoRepType-#else-myMkNoRepType = mkNorepType-#endif---------------------------------------------------------------------------------------      Instances of the Data class for Prelude-like types.---      We define top-level definitions for representations.---------------------------------------------------------------------------------------------------------------------------------------------------------------------- Instances of abstract datatypes (6)---------------------------------------------------------------------------------instance Data TypeRep where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = myMkNoRepType "Data.Typeable.TypeRep"-----------------------------------------------------------------------------------instance Data TyCon where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = myMkNoRepType "Data.Typeable.TyCon"-----------------------------------------------------------------------------------INSTANCE_TYPEABLE0(DataType,dataTypeTc,"DataType")--instance Data DataType where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = myMkNoRepType "Data.Generics.Basics.DataType"-----------------------------------------------------------------------------------instance Data Handle where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = myMkNoRepType "GHC.IOBase.Handle"-----------------------------------------------------------------------------------instance Typeable a => Data (StablePtr a) where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = myMkNoRepType "GHC.Stable.StablePtr"-----------------------------------------------------------------------------------#ifdef __GLASGOW_HASKELL__-instance Data ThreadId where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = myMkNoRepType "GHC.Conc.ThreadId"-#endif------------------------------------------------------------------------------------ Dubious instances (7)---------------------------------------------------------------------------------#ifdef __GLASGOW_HASKELL__-instance Typeable a => Data (TVar a) where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = myMkNoRepType "GHC.Conc.TVar"-#endif-----------------------------------------------------------------------------------instance Typeable a => Data (MVar a) where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = myMkNoRepType "GHC.Conc.MVar"-----------------------------------------------------------------------------------#ifdef __GLASGOW_HASKELL__-instance Typeable a => Data (STM a) where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = myMkNoRepType "GHC.Conc.STM"-#endif-----------------------------------------------------------------------------------instance (Typeable s, Typeable a) => Data (ST s a) where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = myMkNoRepType "GHC.ST.ST"-----------------------------------------------------------------------------------instance Typeable a => Data (IORef a) where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = myMkNoRepType "GHC.IOBase.IORef"-----------------------------------------------------------------------------------instance Typeable a => Data (IO a) where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = myMkNoRepType "GHC.IOBase.IO"--------------------------------------------------------------------------------------- A last resort for functions-----instance (Data a, Data b) => Data (a -> b) where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = myMkNoRepType "Prelude.(->)"-  dataCast2 f  = gcast2 f-+{-# OPTIONS_GHC -cpp                  #-}
+{-# LANGUAGE DeriveDataTypeable       #-}
+{-# LANGUAGE StandaloneDeriving       #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Generics.Instances
+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004
+-- License     :  BSD-style (see the LICENSE file)
+-- 
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (uses Data.Data)
+--
+-- \"Scrap your boilerplate\" --- Generic programming in Haskell 
+-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module
+-- contains thirteen 'Data' instances which are considered dubious (either
+-- because the types are abstract or just not meant to be traversed).
+-- Instances in this module might change or disappear in future releases
+-- of this package. 
+--
+-- (This module does not export anything. It really just defines instances.)
+--
+-----------------------------------------------------------------------------
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Data.Generics.Instances () where
+
+------------------------------------------------------------------------------
+
+import Data.Data
+
+#ifdef __GLASGOW_HASKELL__
+#if __GLASGOW_HASKELL__ >= 611
+import GHC.IO.Handle         -- So we can give Data instance for Handle
+#else
+import GHC.IOBase            -- So we can give Data instance for IO, Handle
+#endif
+import GHC.Stable            -- So we can give Data instance for StablePtr
+import GHC.ST                -- So we can give Data instance for ST
+import GHC.Conc              -- So we can give Data instance for TVar
+import Data.IORef            -- So we can give Data instance for IORef
+import Control.Concurrent    -- So we can give Data instance for MVar
+#else
+# ifdef __HUGS__
+import Hugs.Prelude( Ratio(..) )
+# endif
+import System.IO
+import Foreign.Ptr
+import Foreign.ForeignPtr
+import Foreign.StablePtr
+import Control.Monad.ST
+#endif
+
+#include "Typeable.h"
+
+-- Version compatibility issues caused by #2760
+myMkNoRepType :: String -> DataType
+#if __GLASGOW_HASKELL__ >= 611
+myMkNoRepType = mkNoRepType
+#else
+myMkNoRepType = mkNorepType
+#endif
+
+
+------------------------------------------------------------------------------
+--
+--      Instances of the Data class for Prelude-like types.
+--      We define top-level definitions for representations.
+--
+------------------------------------------------------------------------------
+
+
+------------------------------------------------------------------------------
+-- Instances of abstract datatypes (6)
+------------------------------------------------------------------------------
+
+instance Data TypeRep where
+  toConstr _   = error "toConstr"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = myMkNoRepType "Data.Typeable.TypeRep"
+
+
+------------------------------------------------------------------------------
+
+instance Data TyCon where
+  toConstr _   = error "toConstr"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = myMkNoRepType "Data.Typeable.TyCon"
+
+
+------------------------------------------------------------------------------
+
+INSTANCE_TYPEABLE0(DataType,dataTypeTc,"DataType")
+
+instance Data DataType where
+  toConstr _   = error "toConstr"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = myMkNoRepType "Data.Generics.Basics.DataType"
+
+
+------------------------------------------------------------------------------
+
+instance Data Handle where
+  toConstr _   = error "toConstr"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = myMkNoRepType "GHC.IOBase.Handle"
+
+
+------------------------------------------------------------------------------
+
+instance Typeable a => Data (StablePtr a) where
+  toConstr _   = error "toConstr"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = myMkNoRepType "GHC.Stable.StablePtr"
+
+
+------------------------------------------------------------------------------
+
+#ifdef __GLASGOW_HASKELL__
+instance Data ThreadId where
+  toConstr _   = error "toConstr"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = myMkNoRepType "GHC.Conc.ThreadId"
+#endif
+
+
+------------------------------------------------------------------------------
+-- Dubious instances (7)
+------------------------------------------------------------------------------
+
+#ifdef __GLASGOW_HASKELL__
+instance Typeable a => Data (TVar a) where
+  toConstr _   = error "toConstr"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = myMkNoRepType "GHC.Conc.TVar"
+#endif
+
+
+------------------------------------------------------------------------------
+
+instance Typeable a => Data (MVar a) where
+  toConstr _   = error "toConstr"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = myMkNoRepType "GHC.Conc.MVar"
+
+
+------------------------------------------------------------------------------
+
+#ifdef __GLASGOW_HASKELL__
+instance Typeable a => Data (STM a) where
+  toConstr _   = error "toConstr"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = myMkNoRepType "GHC.Conc.STM"
+#endif
+
+
+------------------------------------------------------------------------------
+
+instance (Typeable s, Typeable a) => Data (ST s a) where
+  toConstr _   = error "toConstr"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = myMkNoRepType "GHC.ST.ST"
+
+
+------------------------------------------------------------------------------
+
+instance Typeable a => Data (IORef a) where
+  toConstr _   = error "toConstr"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = myMkNoRepType "GHC.IOBase.IORef"
+
+
+------------------------------------------------------------------------------
+
+instance Typeable a => Data (IO a) where
+  toConstr _   = error "toConstr"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = myMkNoRepType "GHC.IOBase.IO"
+
+------------------------------------------------------------------------------
+
+--
+-- A last resort for functions
+--
+
+instance (Data a, Data b) => Data (a -> b) where
+  toConstr _   = error "toConstr"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = myMkNoRepType "Prelude.(->)"
+  dataCast2 f  = gcast2 f
+
src/Data/Generics/Schemes.hs view
@@ -1,177 +1,177 @@-{-# OPTIONS_GHC -cpp                  #-}-{-# LANGUAGE Rank2Types               #-}-{-# LANGUAGE ScopedTypeVariables      #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Schemes--- Copyright   :  (c) The University of Glasgow, CWI 2001--2003--- License     :  BSD-style (see the LICENSE file)--- --- Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable (local universal quantification)------ \"Scrap your boilerplate\" --- Generic programming in Haskell --- See <http://www.cs.vu.nl/boilerplate/>. The present module provides--- frequently used generic traversal schemes.-----------------------------------------------------------------------------------module Data.Generics.Schemes (--        everywhere,-        everywhere',-        everywhereBut,-        everywhereM,-        somewhere,-        everything,-        everythingBut,-        listify,-        something,-        synthesize,-        gsize,-        glength,-        gdepth,-        gcount,-        gnodecount,-        gtypecount,-        gfindtype-- ) where----------------------------------------------------------------------------------#ifdef __HADDOCK__-import Prelude-#endif-import Data.Data-import Data.Generics.Aliases-import Control.Monad----- | Apply a transformation everywhere in bottom-up manner-everywhere :: (forall a. Data a => a -> a)-           -> (forall a. Data a => a -> a)---- Use gmapT to recurse into immediate subterms;--- recall: gmapT preserves the outermost constructor;--- post-process recursively transformed result via f--- -everywhere f = f . gmapT (everywhere f)----- | Apply a transformation everywhere in top-down manner-everywhere' :: (forall a. Data a => a -> a)-            -> (forall a. Data a => a -> a)---- Arguments of (.) are flipped compared to everywhere-everywhere' f = gmapT (everywhere' f) . f----- | Variation on everywhere with an extra stop condition-everywhereBut :: GenericQ Bool -> GenericT -> GenericT---- Guarded to let traversal cease if predicate q holds for x-everywhereBut q f x-    | q x       = x-    | otherwise = f (gmapT (everywhereBut q f) x)----- | Monadic variation on everywhere-everywhereM :: Monad m => GenericM m -> GenericM m---- Bottom-up order is also reflected in order of do-actions-everywhereM f x = do x' <- gmapM (everywhereM f) x-                     f x'----- | Apply a monadic transformation at least somewhere-somewhere :: MonadPlus m => GenericM m -> GenericM m---- We try "f" in top-down manner, but descent into "x" when we fail--- at the root of the term. The transformation fails if "f" fails--- everywhere, say succeeds nowhere.--- -somewhere f x = f x `mplus` gmapMp (somewhere f) x----- | Summarise all nodes in top-down, left-to-right order-everything :: (r -> r -> r) -> GenericQ r -> GenericQ r---- Apply f to x to summarise top-level node;--- use gmapQ to recurse into immediate subterms;--- use ordinary foldl to reduce list of intermediate results--- -everything k f x = foldl k (f x) (gmapQ (everything k f) x)---- | Variation of "everything" with an added stop condition-everythingBut :: (r -> r -> r) -> GenericQ (r, Bool) -> GenericQ r-everythingBut k f x = let (v, stop) = f x-                      in if stop-                           then v-                           else foldl k v (gmapQ (everythingBut k f) x)---- | Get a list of all entities that meet a predicate-listify :: Typeable r => (r -> Bool) -> GenericQ [r]-listify p = everything (++) ([] `mkQ` (\x -> if p x then [x] else []))----- | Look up a subterm by means of a maybe-typed filter-something :: GenericQ (Maybe u) -> GenericQ (Maybe u)---- "something" can be defined in terms of "everything"--- when a suitable "choice" operator is used for reduction--- -something = everything orElse----- | Bottom-up synthesis of a data structure;---   1st argument z is the initial element for the synthesis;---   2nd argument o is for reduction of results from subterms;---   3rd argument f updates the synthesised data according to the given term----synthesize :: s  -> (t -> s -> s) -> GenericQ (s -> t) -> GenericQ t-synthesize z o f x = f x (foldr o z (gmapQ (synthesize z o f) x))----- | Compute size of an arbitrary data structure-gsize :: Data a => a -> Int-gsize t = 1 + sum (gmapQ gsize t)----- | Count the number of immediate subterms of the given term-glength :: GenericQ Int-glength = length . gmapQ (const ())----- | Determine depth of the given term-gdepth :: GenericQ Int-gdepth = (+) 1 . foldr max 0 . gmapQ gdepth----- | Determine the number of all suitable nodes in a given term-gcount :: GenericQ Bool -> GenericQ Int-gcount p =  everything (+) (\x -> if p x then 1 else 0)----- | Determine the number of all nodes in a given term-gnodecount :: GenericQ Int-gnodecount = gcount (const True)----- | Determine the number of nodes of a given type in a given term-gtypecount :: Typeable a => a -> GenericQ Int-gtypecount (_::a) = gcount (False `mkQ` (\(_::a) -> True))----- | Find (unambiguously) an immediate subterm of a given type-gfindtype :: (Data x, Typeable y) => x -> Maybe y-gfindtype = singleton-          . foldl unJust []-          . gmapQ (Nothing `mkQ` Just)- where-  unJust l (Just x) = x:l-  unJust l Nothing  = l-  singleton [s] = Just s-  singleton _   = Nothing+{-# OPTIONS_GHC -cpp                  #-}
+{-# LANGUAGE Rank2Types               #-}
+{-# LANGUAGE ScopedTypeVariables      #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Generics.Schemes
+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2003
+-- License     :  BSD-style (see the LICENSE file)
+-- 
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (local universal quantification)
+--
+-- \"Scrap your boilerplate\" --- Generic programming in Haskell 
+-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module
+-- provides frequently used generic traversal schemes.
+--
+-----------------------------------------------------------------------------
+
+module Data.Generics.Schemes (
+
+        everywhere,
+        everywhere',
+        everywhereBut,
+        everywhereM,
+        somewhere,
+        everything,
+        everythingBut,
+        listify,
+        something,
+        synthesize,
+        gsize,
+        glength,
+        gdepth,
+        gcount,
+        gnodecount,
+        gtypecount,
+        gfindtype
+
+ ) where
+
+------------------------------------------------------------------------------
+
+#ifdef __HADDOCK__
+import Prelude
+#endif
+import Data.Data
+import Data.Generics.Aliases
+import Control.Monad
+
+
+-- | Apply a transformation everywhere in bottom-up manner
+everywhere :: (forall a. Data a => a -> a)
+           -> (forall a. Data a => a -> a)
+
+-- Use gmapT to recurse into immediate subterms;
+-- recall: gmapT preserves the outermost constructor;
+-- post-process recursively transformed result via f
+-- 
+everywhere f = f . gmapT (everywhere f)
+
+
+-- | Apply a transformation everywhere in top-down manner
+everywhere' :: (forall a. Data a => a -> a)
+            -> (forall a. Data a => a -> a)
+
+-- Arguments of (.) are flipped compared to everywhere
+everywhere' f = gmapT (everywhere' f) . f
+
+
+-- | Variation on everywhere with an extra stop condition
+everywhereBut :: GenericQ Bool -> GenericT -> GenericT
+
+-- Guarded to let traversal cease if predicate q holds for x
+everywhereBut q f x
+    | q x       = x
+    | otherwise = f (gmapT (everywhereBut q f) x)
+
+
+-- | Monadic variation on everywhere
+everywhereM :: Monad m => GenericM m -> GenericM m
+
+-- Bottom-up order is also reflected in order of do-actions
+everywhereM f x = do x' <- gmapM (everywhereM f) x
+                     f x'
+
+
+-- | Apply a monadic transformation at least somewhere
+somewhere :: MonadPlus m => GenericM m -> GenericM m
+
+-- We try "f" in top-down manner, but descent into "x" when we fail
+-- at the root of the term. The transformation fails if "f" fails
+-- everywhere, say succeeds nowhere.
+-- 
+somewhere f x = f x `mplus` gmapMp (somewhere f) x
+
+
+-- | Summarise all nodes in top-down, left-to-right order
+everything :: (r -> r -> r) -> GenericQ r -> GenericQ r
+
+-- Apply f to x to summarise top-level node;
+-- use gmapQ to recurse into immediate subterms;
+-- use ordinary foldl to reduce list of intermediate results
+-- 
+everything k f x = foldl k (f x) (gmapQ (everything k f) x)
+
+-- | Variation of "everything" with an added stop condition
+everythingBut :: (r -> r -> r) -> GenericQ (r, Bool) -> GenericQ r
+everythingBut k f x = let (v, stop) = f x
+                      in if stop
+                           then v
+                           else foldl k v (gmapQ (everythingBut k f) x)
+
+-- | Get a list of all entities that meet a predicate
+listify :: Typeable r => (r -> Bool) -> GenericQ [r]
+listify p = everything (++) ([] `mkQ` (\x -> if p x then [x] else []))
+
+
+-- | Look up a subterm by means of a maybe-typed filter
+something :: GenericQ (Maybe u) -> GenericQ (Maybe u)
+
+-- "something" can be defined in terms of "everything"
+-- when a suitable "choice" operator is used for reduction
+-- 
+something = everything orElse
+
+
+-- | Bottom-up synthesis of a data structure;
+--   1st argument z is the initial element for the synthesis;
+--   2nd argument o is for reduction of results from subterms;
+--   3rd argument f updates the synthesised data according to the given term
+--
+synthesize :: s  -> (t -> s -> s) -> GenericQ (s -> t) -> GenericQ t
+synthesize z o f x = f x (foldr o z (gmapQ (synthesize z o f) x))
+
+
+-- | Compute size of an arbitrary data structure
+gsize :: Data a => a -> Int
+gsize t = 1 + sum (gmapQ gsize t)
+
+
+-- | Count the number of immediate subterms of the given term
+glength :: GenericQ Int
+glength = length . gmapQ (const ())
+
+
+-- | Determine depth of the given term
+gdepth :: GenericQ Int
+gdepth = (+) 1 . foldr max 0 . gmapQ gdepth
+
+
+-- | Determine the number of all suitable nodes in a given term
+gcount :: GenericQ Bool -> GenericQ Int
+gcount p =  everything (+) (\x -> if p x then 1 else 0)
+
+
+-- | Determine the number of all nodes in a given term
+gnodecount :: GenericQ Int
+gnodecount = gcount (const True)
+
+
+-- | Determine the number of nodes of a given type in a given term
+gtypecount :: Typeable a => a -> GenericQ Int
+gtypecount (_::a) = gcount (False `mkQ` (\(_::a) -> True))
+
+
+-- | Find (unambiguously) an immediate subterm of a given type
+gfindtype :: (Data x, Typeable y) => x -> Maybe y
+gfindtype = singleton
+          . foldl unJust []
+          . gmapQ (Nothing `mkQ` Just)
+ where
+  unJust l (Just x) = x:l
+  unJust l Nothing  = l
+  singleton [s] = Just s
+  singleton _   = Nothing
src/Data/Generics/Text.hs view
@@ -1,131 +1,131 @@-{-# OPTIONS_GHC -cpp                  #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Text--- Copyright   :  (c) The University of Glasgow, CWI 2001--2003--- License     :  BSD-style (see the LICENSE file)--- --- Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable (uses Data.Generics.Basics)------ \"Scrap your boilerplate\" --- Generic programming in Haskell --- See <http://www.cs.vu.nl/boilerplate/>. The present module provides--- generic operations for text serialisation of terms.-----------------------------------------------------------------------------------module Data.Generics.Text (--    -- * Generic show-    gshow, gshows,--    -- * Generic read-    gread-- ) where----------------------------------------------------------------------------------#ifdef __HADDOCK__-import Prelude-#endif-import Control.Monad-import Data.Data-import Data.Generics.Aliases-import Text.ParserCombinators.ReadP------------------------------------------------------------------------------------- | Generic show: an alternative to \"deriving Show\"-gshow :: Data a => a -> String-gshow x = gshows x ""---- | Generic shows-gshows :: Data a => a -> ShowS---- This is a prefix-show using surrounding "(" and ")",--- where we recurse into subterms with gmapQ.-gshows = ( \t ->-                showChar '('-              . (showString . showConstr . toConstr $ t)-              . (foldr (.) id . gmapQ ((showChar ' ' .) . gshows) $ t)-              . showChar ')'-         ) `extQ` (shows :: String -> ShowS)----- | Generic read: an alternative to \"deriving Read\"-gread :: Data a => ReadS a--{---This is a read operation which insists on prefix notation.  (The-Haskell 98 read deals with infix operators subject to associativity-and precedence as well.) We use fromConstrM to "parse" the input. To be-precise, fromConstrM is used for all types except String. The-type-specific case for String uses basic String read.---}--gread = readP_to_S gread'-- where--  -- Helper for recursive read-  gread' :: Data a' => ReadP a'-  gread' = allButString `extR` stringCase--   where--    -- A specific case for strings-    stringCase :: ReadP String-    stringCase = readS_to_P reads--    -- Determine result type-    myDataType = dataTypeOf (getArg allButString)-     where-      getArg :: ReadP a'' -> a''-      getArg = undefined--    -- The generic default for gread-    allButString =-      do-                -- Drop "  (  "-         skipSpaces                     -- Discard leading space-         _ <- char '('                  -- Parse '('-         skipSpaces                     -- Discard following space--                -- Do the real work-         str  <- parseConstr            -- Get a lexeme for the constructor-         con  <- str2con str            -- Convert it to a Constr (may fail)-         x    <- fromConstrM gread' con -- Read the children--                -- Drop "  )  "-         skipSpaces                     -- Discard leading space-         _ <- char ')'                  -- Parse ')'-         skipSpaces                     -- Discard following space--         return x--    -- Turn string into constructor driven by the requested result type,-    -- failing in the monad if it isn't a constructor of this data type-    str2con :: String -> ReadP Constr-    str2con = maybe mzero return-            . readConstr myDataType--    -- Get a Constr's string at the front of an input string-    parseConstr :: ReadP String-    parseConstr =-               string "[]"     -- Compound lexeme "[]"-          <++  string "()"     -- singleton "()"-          <++  infixOp         -- Infix operator in parantheses-          <++  readS_to_P lex  -- Ordinary constructors and literals--    -- Handle infix operators such as (:)-    infixOp :: ReadP String-    infixOp = do c1  <- char '('-                 str <- munch1 (not . (==) ')')-                 c2  <- char ')'-                 return $ [c1] ++ str ++ [c2]+{-# OPTIONS_GHC -cpp                  #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Generics.Text
+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2003
+-- License     :  BSD-style (see the LICENSE file)
+-- 
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (uses Data.Generics.Basics)
+--
+-- \"Scrap your boilerplate\" --- Generic programming in Haskell 
+-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module
+-- provides generic operations for text serialisation of terms.
+--
+-----------------------------------------------------------------------------
+
+module Data.Generics.Text (
+
+    -- * Generic show
+    gshow, gshows,
+
+    -- * Generic read
+    gread
+
+ ) where
+
+------------------------------------------------------------------------------
+
+#ifdef __HADDOCK__
+import Prelude
+#endif
+import Control.Monad
+import Data.Data
+import Data.Generics.Aliases
+import Text.ParserCombinators.ReadP
+
+------------------------------------------------------------------------------
+
+
+-- | Generic show: an alternative to \"deriving Show\"
+gshow :: Data a => a -> String
+gshow x = gshows x ""
+
+-- | Generic shows
+gshows :: Data a => a -> ShowS
+
+-- This is a prefix-show using surrounding "(" and ")",
+-- where we recurse into subterms with gmapQ.
+gshows = ( \t ->
+                showChar '('
+              . (showString . showConstr . toConstr $ t)
+              . (foldr (.) id . gmapQ ((showChar ' ' .) . gshows) $ t)
+              . showChar ')'
+         ) `extQ` (shows :: String -> ShowS)
+
+
+-- | Generic read: an alternative to \"deriving Read\"
+gread :: Data a => ReadS a
+
+{-
+
+This is a read operation which insists on prefix notation.  (The
+Haskell 98 read deals with infix operators subject to associativity
+and precedence as well.) We use fromConstrM to "parse" the input. To be
+precise, fromConstrM is used for all types except String. The
+type-specific case for String uses basic String read.
+
+-}
+
+gread = readP_to_S gread'
+
+ where
+
+  -- Helper for recursive read
+  gread' :: Data a' => ReadP a'
+  gread' = allButString `extR` stringCase
+
+   where
+
+    -- A specific case for strings
+    stringCase :: ReadP String
+    stringCase = readS_to_P reads
+
+    -- Determine result type
+    myDataType = dataTypeOf (getArg allButString)
+     where
+      getArg :: ReadP a'' -> a''
+      getArg = undefined
+
+    -- The generic default for gread
+    allButString =
+      do
+                -- Drop "  (  "
+         skipSpaces                     -- Discard leading space
+         _ <- char '('                  -- Parse '('
+         skipSpaces                     -- Discard following space
+
+                -- Do the real work
+         str  <- parseConstr            -- Get a lexeme for the constructor
+         con  <- str2con str            -- Convert it to a Constr (may fail)
+         x    <- fromConstrM gread' con -- Read the children
+
+                -- Drop "  )  "
+         skipSpaces                     -- Discard leading space
+         _ <- char ')'                  -- Parse ')'
+         skipSpaces                     -- Discard following space
+
+         return x
+
+    -- Turn string into constructor driven by the requested result type,
+    -- failing in the monad if it isn't a constructor of this data type
+    str2con :: String -> ReadP Constr
+    str2con = maybe mzero return
+            . readConstr myDataType
+
+    -- Get a Constr's string at the front of an input string
+    parseConstr :: ReadP String
+    parseConstr =
+               string "[]"     -- Compound lexeme "[]"
+          <++  string "()"     -- singleton "()"
+          <++  infixOp         -- Infix operator in parantheses
+          <++  readS_to_P lex  -- Ordinary constructors and literals
+
+    -- Handle infix operators such as (:)
+    infixOp :: ReadP String
+    infixOp = do c1  <- char '('
+                 str <- munch1 (not . (==) ')')
+                 c2  <- char ')'
+                 return $ [c1] ++ str ++ [c2]
src/Data/Generics/Twins.hs view
@@ -1,272 +1,272 @@-{-# OPTIONS_GHC -cpp                  #-}-{-# LANGUAGE Rank2Types               #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Twins--- Copyright   :  (c) The University of Glasgow, CWI 2001--2004--- License     :  BSD-style (see the LICENSE file)--- --- Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable (local universal quantification)------ \"Scrap your boilerplate\" --- Generic programming in Haskell --- See <http://www.cs.vu.nl/boilerplate/>. The present module --- provides support for multi-parameter traversal, which is also --- demonstrated with generic operations like equality.-----------------------------------------------------------------------------------module Data.Generics.Twins (--        -- * Generic folds and maps that also accumulate-        gfoldlAccum,-        gmapAccumT,-        gmapAccumM,-        gmapAccumQl,-        gmapAccumQr,-        gmapAccumQ,-        gmapAccumA,--        -- * Mapping combinators for twin traversal-        gzipWithT,-        gzipWithM,-        gzipWithQ,--        -- * Typical twin traversals-        geq,-        gzip--  ) where-----------------------------------------------------------------------------------#ifdef __HADDOCK__-import Prelude-#endif-import Data.Data-import Data.Generics.Aliases--#ifdef __GLASGOW_HASKELL__-import Prelude hiding ( GT )-#endif--import Control.Applicative (Applicative(..))-----------------------------------------------------------------------------------------------------------------------------------------------------------------------      Generic folds and maps that also accumulate------------------------------------------------------------------------------------{----------------------------------------------------------------A list map can be elaborated to perform accumulation.-In the same sense, we can elaborate generic maps over terms.--We recall the type of map:-map :: (a -> b) -> [a] -> [b]--We recall the type of an accumulating map (see Data.List):-mapAccumL :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])--Applying the same scheme we obtain an accumulating gfoldl.----------------------------------------------------------------}---- | gfoldl with accumulation--gfoldlAccum :: Data d-            => (forall e r. Data e => a -> c (e -> r) -> e -> (a, c r))-            -> (forall g. a -> g -> (a, c g))-            -> a -> d -> (a, c d)--gfoldlAccum k z a0 d = unA (gfoldl k' z' d) a0- where-  k' c y = A (\a -> let (a', c') = unA c a in k a' c' y)-  z' f   = A (\a -> z a f)----- | A type constructor for accumulation-newtype A a c d = A { unA :: a -> (a, c d) }----- | gmapT with accumulation-gmapAccumT :: Data d-           => (forall e. Data e => a -> e -> (a,e))-           -> a -> d -> (a, d)-gmapAccumT f a0 d0 = let (a1, d1) = gfoldlAccum k z a0 d0-                     in (a1, unID d1)- where-  k a (ID c) d = let (a',d') = f a d-                  in (a', ID (c d'))-  z a x = (a, ID x)----- | Applicative version-gmapAccumA :: forall b d a. (Data d, Applicative a)-           => (forall e. Data e => b -> e -> (b, a e))-           -> b -> d -> (b, a d)-gmapAccumA f a0 d0 = gfoldlAccum k z a0 d0-    where-      k :: forall d' e. (Data d') =>-           b -> a (d' -> e) -> d' -> (b, a e)-      k a c d = let (a',d') = f a d-                    c' = c <*> d'-                in (a', c')-      z :: forall t c a'. (Applicative a') =>-           t -> c -> (t, a' c)-      z a x = (a, pure x)----- | gmapM with accumulation-gmapAccumM :: (Data d, Monad m)-           => (forall e. Data e => a -> e -> (a, m e))-           -> a -> d -> (a, m d)-gmapAccumM f = gfoldlAccum k z- where-  k a c d = let (a',d') = f a d-             in (a', d' >>= \d'' -> c >>= \c' -> return (c' d''))-  z a x = (a, return x)----- | gmapQl with accumulation-gmapAccumQl :: Data d-            => (r -> r' -> r)-            -> r-            -> (forall e. Data e => a -> e -> (a,r'))-            -> a -> d -> (a, r)-gmapAccumQl o r0 f a0 d0 = let (a1, r1) = gfoldlAccum k z a0 d0-                           in (a1, unCONST r1)- where-  k a (CONST c) d = let (a', r) = f a d-                     in (a', CONST (c `o` r))-  z a _ = (a, CONST r0)----- | gmapQr with accumulation-gmapAccumQr :: Data d-            => (r' -> r -> r)-            -> r-            -> (forall e. Data e => a -> e -> (a,r'))-            -> a -> d -> (a, r)-gmapAccumQr o r0 f a0 d0 = let (a1, l) = gfoldlAccum k z a0 d0-                           in (a1, unQr l r0)- where-  k a (Qr c) d = let (a',r') = f a d-                  in (a', Qr (\r -> c (r' `o` r)))-  z a _ = (a, Qr id)----- | gmapQ with accumulation-gmapAccumQ :: Data d-           => (forall e. Data e => a -> e -> (a,q))-           -> a -> d -> (a, [q])-gmapAccumQ f = gmapAccumQr (:) [] f----------------------------------------------------------------------------------------      Helper type constructors--------------------------------------------------------------------------------------- | The identity type constructor needed for the definition of gmapAccumT-newtype ID x = ID { unID :: x }----- | The constant type constructor needed for the definition of gmapAccumQl-newtype CONST c a = CONST { unCONST :: c }----- | The type constructor needed for the definition of gmapAccumQr-newtype Qr r a = Qr { unQr  :: r -> r }----------------------------------------------------------------------------------------      Mapping combinators for twin traversal--------------------------------------------------------------------------------------- | Twin map for transformation -gzipWithT :: GenericQ (GenericT) -> GenericQ (GenericT)-gzipWithT f x y = case gmapAccumT perkid funs y of-                    ([], c) -> c-                    _       -> error "gzipWithT"- where-  perkid a d = (tail a, unGT (head a) d)-  funs = gmapQ (\k -> GT (f k)) x------ | Twin map for monadic transformation -gzipWithM :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m)-gzipWithM f x y = case gmapAccumM perkid funs y of-                    ([], c) -> c-                    _       -> error "gzipWithM"- where-  perkid a d = (tail a, unGM (head a) d)-  funs = gmapQ (\k -> GM (f k)) x----- | Twin map for queries-gzipWithQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r])-gzipWithQ f x y = case gmapAccumQ perkid funs y of-                   ([], r) -> r-                   _       -> error "gzipWithQ"- where-  perkid a d = (tail a, unGQ (head a) d)-  funs = gmapQ (\k -> GQ (f k)) x----------------------------------------------------------------------------------------      Typical twin traversals-------------------------------------------------------------------------------------- | Generic equality: an alternative to \"deriving Eq\"-geq :: Data a => a -> a -> Bool--{---Testing for equality of two terms goes like this. Firstly, we-establish the equality of the two top-level datatype-constructors. Secondly, we use a twin gmap combinator, namely tgmapQ,-to compare the two lists of immediate subterms.--(Note for the experts: the type of the worker geq' is rather general-but precision is recovered via the restrictive type of the top-level-operation geq. The imprecision of geq' is caused by the type system's-unability to express the type equivalence for the corresponding-couples of immediate subterms from the two given input terms.)---}--geq x0 y0 = geq' x0 y0-  where-    geq' :: GenericQ (GenericQ Bool)-    geq' x y =     (toConstr x == toConstr y)-                && and (gzipWithQ geq' x y)----- | Generic zip controlled by a function with type-specific branches-gzip :: GenericQ (GenericM Maybe) -> GenericQ (GenericM Maybe)--- See testsuite/.../Generics/gzip.hs for an illustration-gzip f x y =-  f x y-  `orElse`-  if toConstr x == toConstr y-    then gzipWithM (gzip f) x y-    else Nothing+{-# OPTIONS_GHC -cpp                  #-}
+{-# LANGUAGE Rank2Types               #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Generics.Twins
+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004
+-- License     :  BSD-style (see the LICENSE file)
+-- 
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (local universal quantification)
+--
+-- \"Scrap your boilerplate\" --- Generic programming in Haskell 
+-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module 
+-- provides support for multi-parameter traversal, which is also 
+-- demonstrated with generic operations like equality.
+--
+-----------------------------------------------------------------------------
+
+module Data.Generics.Twins (
+
+        -- * Generic folds and maps that also accumulate
+        gfoldlAccum,
+        gmapAccumT,
+        gmapAccumM,
+        gmapAccumQl,
+        gmapAccumQr,
+        gmapAccumQ,
+        gmapAccumA,
+
+        -- * Mapping combinators for twin traversal
+        gzipWithT,
+        gzipWithM,
+        gzipWithQ,
+
+        -- * Typical twin traversals
+        geq,
+        gzip
+
+  ) where
+
+
+------------------------------------------------------------------------------
+
+#ifdef __HADDOCK__
+import Prelude
+#endif
+import Data.Data
+import Data.Generics.Aliases
+
+#ifdef __GLASGOW_HASKELL__
+import Prelude hiding ( GT )
+#endif
+
+import Control.Applicative (Applicative(..))
+
+------------------------------------------------------------------------------
+
+
+------------------------------------------------------------------------------
+--
+--      Generic folds and maps that also accumulate
+--
+------------------------------------------------------------------------------
+
+{--------------------------------------------------------------
+
+A list map can be elaborated to perform accumulation.
+In the same sense, we can elaborate generic maps over terms.
+
+We recall the type of map:
+map :: (a -> b) -> [a] -> [b]
+
+We recall the type of an accumulating map (see Data.List):
+mapAccumL :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])
+
+Applying the same scheme we obtain an accumulating gfoldl.
+
+--------------------------------------------------------------}
+
+-- | gfoldl with accumulation
+
+gfoldlAccum :: Data d
+            => (forall e r. Data e => a -> c (e -> r) -> e -> (a, c r))
+            -> (forall g. a -> g -> (a, c g))
+            -> a -> d -> (a, c d)
+
+gfoldlAccum k z a0 d = unA (gfoldl k' z' d) a0
+ where
+  k' c y = A (\a -> let (a', c') = unA c a in k a' c' y)
+  z' f   = A (\a -> z a f)
+
+
+-- | A type constructor for accumulation
+newtype A a c d = A { unA :: a -> (a, c d) }
+
+
+-- | gmapT with accumulation
+gmapAccumT :: Data d
+           => (forall e. Data e => a -> e -> (a,e))
+           -> a -> d -> (a, d)
+gmapAccumT f a0 d0 = let (a1, d1) = gfoldlAccum k z a0 d0
+                     in (a1, unID d1)
+ where
+  k a (ID c) d = let (a',d') = f a d
+                  in (a', ID (c d'))
+  z a x = (a, ID x)
+
+
+-- | Applicative version
+gmapAccumA :: forall b d a. (Data d, Applicative a)
+           => (forall e. Data e => b -> e -> (b, a e))
+           -> b -> d -> (b, a d)
+gmapAccumA f a0 d0 = gfoldlAccum k z a0 d0
+    where
+      k :: forall d' e. (Data d') =>
+           b -> a (d' -> e) -> d' -> (b, a e)
+      k a c d = let (a',d') = f a d
+                    c' = c <*> d'
+                in (a', c')
+      z :: forall t c a'. (Applicative a') =>
+           t -> c -> (t, a' c)
+      z a x = (a, pure x)
+
+
+-- | gmapM with accumulation
+gmapAccumM :: (Data d, Monad m)
+           => (forall e. Data e => a -> e -> (a, m e))
+           -> a -> d -> (a, m d)
+gmapAccumM f = gfoldlAccum k z
+ where
+  k a c d = let (a',d') = f a d
+             in (a', d' >>= \d'' -> c >>= \c' -> return (c' d''))
+  z a x = (a, return x)
+
+
+-- | gmapQl with accumulation
+gmapAccumQl :: Data d
+            => (r -> r' -> r)
+            -> r
+            -> (forall e. Data e => a -> e -> (a,r'))
+            -> a -> d -> (a, r)
+gmapAccumQl o r0 f a0 d0 = let (a1, r1) = gfoldlAccum k z a0 d0
+                           in (a1, unCONST r1)
+ where
+  k a (CONST c) d = let (a', r) = f a d
+                     in (a', CONST (c `o` r))
+  z a _ = (a, CONST r0)
+
+
+-- | gmapQr with accumulation
+gmapAccumQr :: Data d
+            => (r' -> r -> r)
+            -> r
+            -> (forall e. Data e => a -> e -> (a,r'))
+            -> a -> d -> (a, r)
+gmapAccumQr o r0 f a0 d0 = let (a1, l) = gfoldlAccum k z a0 d0
+                           in (a1, unQr l r0)
+ where
+  k a (Qr c) d = let (a',r') = f a d
+                  in (a', Qr (\r -> c (r' `o` r)))
+  z a _ = (a, Qr id)
+
+
+-- | gmapQ with accumulation
+gmapAccumQ :: Data d
+           => (forall e. Data e => a -> e -> (a,q))
+           -> a -> d -> (a, [q])
+gmapAccumQ f = gmapAccumQr (:) [] f
+
+
+
+------------------------------------------------------------------------------
+--
+--      Helper type constructors
+--
+------------------------------------------------------------------------------
+
+
+-- | The identity type constructor needed for the definition of gmapAccumT
+newtype ID x = ID { unID :: x }
+
+
+-- | The constant type constructor needed for the definition of gmapAccumQl
+newtype CONST c a = CONST { unCONST :: c }
+
+
+-- | The type constructor needed for the definition of gmapAccumQr
+newtype Qr r a = Qr { unQr  :: r -> r }
+
+
+
+------------------------------------------------------------------------------
+--
+--      Mapping combinators for twin traversal
+--
+------------------------------------------------------------------------------
+
+
+-- | Twin map for transformation 
+gzipWithT :: GenericQ (GenericT) -> GenericQ (GenericT)
+gzipWithT f x y = case gmapAccumT perkid funs y of
+                    ([], c) -> c
+                    _       -> error "gzipWithT"
+ where
+  perkid a d = (tail a, unGT (head a) d)
+  funs = gmapQ (\k -> GT (f k)) x
+
+
+
+-- | Twin map for monadic transformation 
+gzipWithM :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m)
+gzipWithM f x y = case gmapAccumM perkid funs y of
+                    ([], c) -> c
+                    _       -> error "gzipWithM"
+ where
+  perkid a d = (tail a, unGM (head a) d)
+  funs = gmapQ (\k -> GM (f k)) x
+
+
+-- | Twin map for queries
+gzipWithQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r])
+gzipWithQ f x y = case gmapAccumQ perkid funs y of
+                   ([], r) -> r
+                   _       -> error "gzipWithQ"
+ where
+  perkid a d = (tail a, unGQ (head a) d)
+  funs = gmapQ (\k -> GQ (f k)) x
+
+
+
+------------------------------------------------------------------------------
+--
+--      Typical twin traversals
+--
+------------------------------------------------------------------------------
+
+-- | Generic equality: an alternative to \"deriving Eq\"
+geq :: Data a => a -> a -> Bool
+
+{-
+
+Testing for equality of two terms goes like this. Firstly, we
+establish the equality of the two top-level datatype
+constructors. Secondly, we use a twin gmap combinator, namely tgmapQ,
+to compare the two lists of immediate subterms.
+
+(Note for the experts: the type of the worker geq' is rather general
+but precision is recovered via the restrictive type of the top-level
+operation geq. The imprecision of geq' is caused by the type system's
+unability to express the type equivalence for the corresponding
+couples of immediate subterms from the two given input terms.)
+
+-}
+
+geq x0 y0 = geq' x0 y0
+  where
+    geq' :: GenericQ (GenericQ Bool)
+    geq' x y =     (toConstr x == toConstr y)
+                && and (gzipWithQ geq' x y)
+
+
+-- | Generic zip controlled by a function with type-specific branches
+gzip :: GenericQ (GenericM Maybe) -> GenericQ (GenericM Maybe)
+-- See testsuite/.../Generics/gzip.hs for an illustration
+gzip f x y =
+  f x y
+  `orElse`
+  if toConstr x == toConstr y
+    then gzipWithM (gzip f) x y
+    else Nothing
src/Generics/SYB.hs view
@@ -1,17 +1,17 @@--------------------------------------------------------------------------------- |--- Module      :  Generics.SYB--- Copyright   :  (c) The University of Glasgow, CWI 2001--2004--- License     :  BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable (local universal quantification)------ Convenience alias for "Data.Generics".-----------------------------------------------------------------------------------module Generics.SYB (module Data.Generics) where--import Data.Generics+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.SYB
+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (local universal quantification)
+--
+-- Convenience alias for "Data.Generics".
+--
+-----------------------------------------------------------------------------
+
+module Generics.SYB (module Data.Generics) where
+
+import Data.Generics
src/Generics/SYB/Aliases.hs view
@@ -1,17 +1,17 @@--------------------------------------------------------------------------------- |--- Module      :  Generics.SYB.Aliases--- Copyright   :  (c) The University of Glasgow, CWI 2001--2004--- License     :  BSD-style (see the LICENSE file)--- --- Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable (local universal quantification)------ Convenience alias for "Data.Generics.Aliases".-----------------------------------------------------------------------------------module Generics.SYB.Aliases (module Data.Generics.Aliases) where--import Data.Generics.Aliases+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.SYB.Aliases
+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004
+-- License     :  BSD-style (see the LICENSE file)
+-- 
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (local universal quantification)
+--
+-- Convenience alias for "Data.Generics.Aliases".
+--
+-----------------------------------------------------------------------------
+
+module Generics.SYB.Aliases (module Data.Generics.Aliases) where
+
+import Data.Generics.Aliases
src/Generics/SYB/Basics.hs view
@@ -1,17 +1,17 @@--------------------------------------------------------------------------------- |--- Module      :  Generics.SYB.Basics--- Copyright   :  (c) The University of Glasgow, CWI 2001--2004--- License     :  BSD-style (see the LICENSE file)--- --- Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable (local universal quantification)------ Convenience alias for "Data.Generics.Basics".-----------------------------------------------------------------------------------module Generics.SYB.Basics (module Data.Generics.Basics) where--import Data.Generics.Basics+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.SYB.Basics
+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004
+-- License     :  BSD-style (see the LICENSE file)
+-- 
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (local universal quantification)
+--
+-- Convenience alias for "Data.Generics.Basics".
+--
+-----------------------------------------------------------------------------
+
+module Generics.SYB.Basics (module Data.Generics.Basics) where
+
+import Data.Generics.Basics
src/Generics/SYB/Builders.hs view
@@ -1,17 +1,17 @@--------------------------------------------------------------------------------- |--- Module      :  Generics.SYB.Builders--- Copyright   :  (c) The University of Glasgow, CWI 2001--2004--- License     :  BSD-style (see the LICENSE file)--- --- Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable (local universal quantification)------ Convenience alias for "Data.Generics.Builders".-----------------------------------------------------------------------------------module Generics.SYB.Builders (module Data.Generics.Builders) where--import Data.Generics.Builders+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.SYB.Builders
+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004
+-- License     :  BSD-style (see the LICENSE file)
+-- 
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (local universal quantification)
+--
+-- Convenience alias for "Data.Generics.Builders".
+--
+-----------------------------------------------------------------------------
+
+module Generics.SYB.Builders (module Data.Generics.Builders) where
+
+import Data.Generics.Builders
src/Generics/SYB/Instances.hs view
@@ -1,17 +1,17 @@--------------------------------------------------------------------------------- |--- Module      :  Generics.SYB.Instances--- Copyright   :  (c) The University of Glasgow, CWI 2001--2004--- License     :  BSD-style (see the LICENSE file)--- --- Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable (local universal quantification)------ Convenience alias for "Data.Generics.Instances".-----------------------------------------------------------------------------------module Generics.SYB.Instances () where--import Data.Generics.Instances ()+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.SYB.Instances
+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004
+-- License     :  BSD-style (see the LICENSE file)
+-- 
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (local universal quantification)
+--
+-- Convenience alias for "Data.Generics.Instances".
+--
+-----------------------------------------------------------------------------
+
+module Generics.SYB.Instances () where
+
+import Data.Generics.Instances ()
src/Generics/SYB/Schemes.hs view
@@ -1,17 +1,17 @@--------------------------------------------------------------------------------- |--- Module      :  Generics.SYB.Schemes--- Copyright   :  (c) The University of Glasgow, CWI 2001--2004--- License     :  BSD-style (see the LICENSE file)--- --- Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable (local universal quantification)------ Convenience alias for "Data.Generics.Schemes".-----------------------------------------------------------------------------------module Generics.SYB.Schemes (module Data.Generics.Schemes) where--import Data.Generics.Schemes+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.SYB.Schemes
+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004
+-- License     :  BSD-style (see the LICENSE file)
+-- 
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (local universal quantification)
+--
+-- Convenience alias for "Data.Generics.Schemes".
+--
+-----------------------------------------------------------------------------
+
+module Generics.SYB.Schemes (module Data.Generics.Schemes) where
+
+import Data.Generics.Schemes
src/Generics/SYB/Text.hs view
@@ -1,17 +1,17 @@--------------------------------------------------------------------------------- |--- Module      :  Generics.SYB.Text--- Copyright   :  (c) The University of Glasgow, CWI 2001--2004--- License     :  BSD-style (see the LICENSE file)--- --- Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable (local universal quantification)------ Convenience alias for "Data.Generics.Text".-----------------------------------------------------------------------------------module Generics.SYB.Text (module Data.Generics.Text) where--import Data.Generics.Text+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.SYB.Text
+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004
+-- License     :  BSD-style (see the LICENSE file)
+-- 
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (local universal quantification)
+--
+-- Convenience alias for "Data.Generics.Text".
+--
+-----------------------------------------------------------------------------
+
+module Generics.SYB.Text (module Data.Generics.Text) where
+
+import Data.Generics.Text
src/Generics/SYB/Twins.hs view
@@ -1,17 +1,17 @@--------------------------------------------------------------------------------- |--- Module      :  Generics.SYB.Twins--- Copyright   :  (c) The University of Glasgow, CWI 2001--2004--- License     :  BSD-style (see the LICENSE file)--- --- Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable (local universal quantification)------ Convenience alias for "Data.Generics.Twins".-----------------------------------------------------------------------------------module Generics.SYB.Twins (module Data.Generics.Twins) where--import Data.Generics.Twins+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.SYB.Twins
+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004
+-- License     :  BSD-style (see the LICENSE file)
+-- 
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (local universal quantification)
+--
+-- Convenience alias for "Data.Generics.Twins".
+--
+-----------------------------------------------------------------------------
+
+module Generics.SYB.Twins (module Data.Generics.Twins) where
+
+import Data.Generics.Twins
syb.cabal view
@@ -1,54 +1,54 @@-name:                 syb-version:              0.3.3-license:              BSD3-license-file:         LICENSE-author:               Ralf Lammel, Simon Peyton Jones-maintainer:           generics@haskell.org-homepage:             http://www.cs.uu.nl/wiki/GenericProgramming/SYB-bug-reports:          http://code.google.com/p/scrapyourboilerplate/issues/list-synopsis:             Scrap Your Boilerplate-description:-    This package contains the generics system described in the-    /Scrap Your Boilerplate/ papers (see -    <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>).-    It defines the @Data@ class of types permitting folding and unfolding-    of constructor applications, instances of this class for primitive-    types, and a variety of traversals.--category:               Generics-stability:              provisional-build-type:             Custom-cabal-version:          >= 1.6-tested-with:            GHC == 6.10.4, GHC == 6.12.3, GHC == 7.0.1--extra-source-files:     tests/*.hs,-                        README--Library {-  hs-source-dirs:         src-  build-depends:          base >= 4.0 && < 4.5-  exposed-modules:        Data.Generics,-                          Data.Generics.Basics,-                          Data.Generics.Instances,-                          Data.Generics.Aliases,-                          Data.Generics.Schemes,-                          Data.Generics.Text,-                          Data.Generics.Twins,-                          Data.Generics.Builders,-                          -                          Generics.SYB,-                          Generics.SYB.Basics,-                          Generics.SYB.Instances,-                          Generics.SYB.Aliases,-                          Generics.SYB.Schemes,-                          Generics.SYB.Text,-                          Generics.SYB.Twins,-                          Generics.SYB.Builders--  extensions:             CPP, Rank2Types, ScopedTypeVariables--  if impl(ghc < 6.12) -    ghc-options:          -package-name syb-  -  ghc-options:            -Wall-}+name:                 syb
+version:              0.3.4
+license:              BSD3
+license-file:         LICENSE
+author:               Ralf Lammel, Simon Peyton Jones
+maintainer:           generics@haskell.org
+homepage:             http://www.cs.uu.nl/wiki/GenericProgramming/SYB
+bug-reports:          http://code.google.com/p/scrapyourboilerplate/issues/list
+synopsis:             Scrap Your Boilerplate
+description:
+    This package contains the generics system described in the
+    /Scrap Your Boilerplate/ papers (see 
+    <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>).
+    It defines the @Data@ class of types permitting folding and unfolding
+    of constructor applications, instances of this class for primitive
+    types, and a variety of traversals.
+
+category:               Generics
+stability:              provisional
+build-type:             Custom
+cabal-version:          >= 1.6
+tested-with:            GHC == 6.10.4, GHC == 6.12.3, GHC == 7.0.1
+
+extra-source-files:     tests/*.hs,
+                        README
+
+Library {
+  hs-source-dirs:         src
+  build-depends:          base >= 4.0 && < 4.5
+  exposed-modules:        Data.Generics,
+                          Data.Generics.Basics,
+                          Data.Generics.Instances,
+                          Data.Generics.Aliases,
+                          Data.Generics.Schemes,
+                          Data.Generics.Text,
+                          Data.Generics.Twins,
+                          Data.Generics.Builders,
+                          
+                          Generics.SYB,
+                          Generics.SYB.Basics,
+                          Generics.SYB.Instances,
+                          Generics.SYB.Aliases,
+                          Generics.SYB.Schemes,
+                          Generics.SYB.Text,
+                          Generics.SYB.Twins,
+                          Generics.SYB.Builders
+
+  extensions:             CPP, Rank2Types, ScopedTypeVariables
+
+  if impl(ghc < 6.12) 
+    ghc-options:          -package-name syb
+  
+  ghc-options:            -Wall
+}
tests/Bits.hs view
@@ -1,214 +1,214 @@-{-# OPTIONS -fglasgow-exts #-}--module Bits (tests) where--{-- -This test exercices some oldies of generic programming, namely-encoding terms as bit streams and decoding these bit streams in turn-to obtain terms again. (This sort of function might actually be useful-for serialisation and sending companies and other terms over the-internet.)--Here is how it works.--A constuctor is encoded as a bit stream. To this end, we encode the-index of the constructor as a binary number of a fixed length taking-into account the maximum index for the type at hand. (Similarly, we-could view the list of constructors as a binary tree, and then encode-a constructor as the path to the constructor in this tree.) If there-is just a single constructor, as for newtypes, for example, then the-computed bit stream is empty.--Otherwise we just recurse into subterms.--Well, we need to handle basic datatypes in a special way. We observe-such basic datatypes by testing the maximum index to be 0 for the-datatype at hand. An efficient encoding should be tuned per basic-datatype. The following solution is generic, but it wastes space.-That is, we turn the basic value into a string relying on the general-Data API. This string can now be encoded by first converting it into a-list of bit streams at the term level, which can then be easily-encoded as a single bit stream (because lists and bits can be-encoded).---}--import Test.HUnit--import Data.Generics-import Data.Char-import Maybe-import Monad-import CompanyDatatypes--------------------------------------------------------------------------------------- | We need bits and bit streams.-data Bit = Zero | One deriving (Show, Eq, Typeable, Data)-type Bin = [Bit]--------------------------------------------------------------------------------------- Compute length of bit stream for a natural-lengthNat :: Int -> Int-lengthNat x = ceiling (logBase 2 (fromIntegral (x + 1)))----- Encode a natural as a bit stream-varNat2bin :: Int -> Bin-varNat2bin 0 = []-varNat2bin x =-  ( ( if even x then Zero else One )-  : varNat2bin (x `div` 2)-  ) ----- Encode a natural as a bit stream of fixed length-fixedNat2bin :: Int -> Int -> Bin-fixedNat2bin 0 0 = []-fixedNat2bin p x | p>0 =-  ( ( if even x then Zero else One )-  : fixedNat2bin (p - 1) (x `div` 2)-  ) ----- Decode a natural-bin2nat :: Bin -> Int-bin2nat []          = 0-bin2nat (Zero : bs) = 2 * (bin2nat bs)-bin2nat (One  : bs) = 2 * (bin2nat bs) + 1--------------------------------------------------------------------------------------- | Generically map terms to bit streams-showBin :: Data t => t -> Bin--showBin t-  = if isAlgType myDataType-      then con2bin ++ concat (gmapQ showBin t)-      else showBin base-- where--  -- The datatype for introspection-  myDataType = dataTypeOf t--  -- Obtain the maximum index for the type at hand-  max :: Int-  max = maxConstrIndex myDataType--  -- Obtain the index for the constructor at hand-  idx :: Int-  idx = constrIndex (toConstr t)--  -- Map basic values to strings, then to lists of bit streams-  base = map (varNat2bin . ord) (showConstr (toConstr t))--  -- Map constructors to bit streams of fixed length-  con2bin = fixedNat2bin (lengthNat (max - 1)) (idx - 1)-------------------------------------------------------------------------------------- | A monad on bit streams-data ReadB a = ReadB (Bin -> (Maybe a, Bin))-unReadB (ReadB f) = f----- It's a monad.-instance Monad ReadB where-  return a = ReadB (\bs -> (Just a, bs))-  (ReadB c) >>= f = ReadB (\bs -> case c bs of-                             (Just a, bs')  -> unReadB (f a) bs'-                             (Nothing, bs') -> (Nothing, bs')-                          )----- It's a bit monad with 0 and +.-instance MonadPlus ReadB where-  mzero = ReadB (\bs -> (Nothing, bs))-  (ReadB f) `mplus` (ReadB g) = ReadB (\bs -> case f bs of-                                         (Just a, bs') -> (Just a, bs')-                                         (Nothing, _)  -> g bs-                                      )----- Read a few bits-readB :: Int -> ReadB Bin-readB x = ReadB (\bs -> if length bs >= x-                          then (Just (take x bs), drop x bs)-                          else (Nothing, bs)-                )--------------------------------------------------------------------------------------- | Generically map bit streams to terms-readBin :: Data t => ReadB t-readBin = result- where--  -- The worker, which we also use as type argument-  result = if isAlgType myDataType--             then do bin <- readB (lengthNat (max - 1))-                     fromConstrM readBin (bin2con bin)--             else do str <- readBin-                     con <- str2con (map (chr . bin2nat) str)-                     return (fromConstr con)--  -- Determine result type-  myDataType = dataTypeOf (getArg result)-     where-      getArg :: ReadB a -> a-      getArg = undefined--  -- Obtain the maximum index for the type at hand-  max :: Int-  max = maxConstrIndex myDataType--  -- Convert a bit stream into a constructor -  bin2con :: Bin -> Constr-  bin2con bin = indexConstr myDataType ((bin2nat bin) + 1)--  -- Convert string to constructor; could fail-  str2con :: String -> ReadB Constr-  str2con = maybe mzero return-                . readConstr myDataType-------------------------------------------------------------------------------------tests = (   showBin True-        , ( showBin [True]-        , ( showBin (1::Int)-        , ( showBin "1"-        , ( showBin genCom-        , ( geq genCom genCom' -        )))))) ~=? output- where-  genCom' = fromJust (fst (unReadB readBin (showBin genCom))) :: Company--output = ([One],([One,One,Zero],([One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero],([One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero],([One,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,Zero,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,One,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,One,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,Zero,Zero],True)))))+{-# OPTIONS -fglasgow-exts #-}
+
+module Bits (tests) where
+
+{-
+ 
+This test exercices some oldies of generic programming, namely
+encoding terms as bit streams and decoding these bit streams in turn
+to obtain terms again. (This sort of function might actually be useful
+for serialisation and sending companies and other terms over the
+internet.)
+
+Here is how it works.
+
+A constuctor is encoded as a bit stream. To this end, we encode the
+index of the constructor as a binary number of a fixed length taking
+into account the maximum index for the type at hand. (Similarly, we
+could view the list of constructors as a binary tree, and then encode
+a constructor as the path to the constructor in this tree.) If there
+is just a single constructor, as for newtypes, for example, then the
+computed bit stream is empty.
+
+Otherwise we just recurse into subterms.
+
+Well, we need to handle basic datatypes in a special way. We observe
+such basic datatypes by testing the maximum index to be 0 for the
+datatype at hand. An efficient encoding should be tuned per basic
+datatype. The following solution is generic, but it wastes space.
+That is, we turn the basic value into a string relying on the general
+Data API. This string can now be encoded by first converting it into a
+list of bit streams at the term level, which can then be easily
+encoded as a single bit stream (because lists and bits can be
+encoded).
+
+-}
+
+import Test.HUnit
+
+import Data.Generics
+import Data.Char
+import Maybe
+import Monad
+import CompanyDatatypes
+
+
+
+-----------------------------------------------------------------------------
+
+
+
+-- | We need bits and bit streams.
+data Bit = Zero | One deriving (Show, Eq, Typeable, Data)
+type Bin = [Bit]
+
+
+
+-----------------------------------------------------------------------------
+
+
+
+-- Compute length of bit stream for a natural
+lengthNat :: Int -> Int
+lengthNat x = ceiling (logBase 2 (fromIntegral (x + 1)))
+
+
+-- Encode a natural as a bit stream
+varNat2bin :: Int -> Bin
+varNat2bin 0 = []
+varNat2bin x =
+  ( ( if even x then Zero else One )
+  : varNat2bin (x `div` 2)
+  ) 
+
+
+-- Encode a natural as a bit stream of fixed length
+fixedNat2bin :: Int -> Int -> Bin
+fixedNat2bin 0 0 = []
+fixedNat2bin p x | p>0 =
+  ( ( if even x then Zero else One )
+  : fixedNat2bin (p - 1) (x `div` 2)
+  ) 
+
+
+-- Decode a natural
+bin2nat :: Bin -> Int
+bin2nat []          = 0
+bin2nat (Zero : bs) = 2 * (bin2nat bs)
+bin2nat (One  : bs) = 2 * (bin2nat bs) + 1
+
+
+
+-----------------------------------------------------------------------------
+
+
+
+-- | Generically map terms to bit streams
+showBin :: Data t => t -> Bin
+
+showBin t
+  = if isAlgType myDataType
+      then con2bin ++ concat (gmapQ showBin t)
+      else showBin base
+
+ where
+
+  -- The datatype for introspection
+  myDataType = dataTypeOf t
+
+  -- Obtain the maximum index for the type at hand
+  max :: Int
+  max = maxConstrIndex myDataType
+
+  -- Obtain the index for the constructor at hand
+  idx :: Int
+  idx = constrIndex (toConstr t)
+
+  -- Map basic values to strings, then to lists of bit streams
+  base = map (varNat2bin . ord) (showConstr (toConstr t))
+
+  -- Map constructors to bit streams of fixed length
+  con2bin = fixedNat2bin (lengthNat (max - 1)) (idx - 1)
+
+
+-----------------------------------------------------------------------------
+
+
+
+-- | A monad on bit streams
+data ReadB a = ReadB (Bin -> (Maybe a, Bin))
+unReadB (ReadB f) = f
+
+
+-- It's a monad.
+instance Monad ReadB where
+  return a = ReadB (\bs -> (Just a, bs))
+  (ReadB c) >>= f = ReadB (\bs -> case c bs of
+                             (Just a, bs')  -> unReadB (f a) bs'
+                             (Nothing, bs') -> (Nothing, bs')
+                          )
+
+
+-- It's a bit monad with 0 and +.
+instance MonadPlus ReadB where
+  mzero = ReadB (\bs -> (Nothing, bs))
+  (ReadB f) `mplus` (ReadB g) = ReadB (\bs -> case f bs of
+                                         (Just a, bs') -> (Just a, bs')
+                                         (Nothing, _)  -> g bs
+                                      )
+
+
+-- Read a few bits
+readB :: Int -> ReadB Bin
+readB x = ReadB (\bs -> if length bs >= x
+                          then (Just (take x bs), drop x bs)
+                          else (Nothing, bs)
+                )
+
+
+
+-----------------------------------------------------------------------------
+
+
+
+-- | Generically map bit streams to terms
+readBin :: Data t => ReadB t
+readBin = result
+ where
+
+  -- The worker, which we also use as type argument
+  result = if isAlgType myDataType
+
+             then do bin <- readB (lengthNat (max - 1))
+                     fromConstrM readBin (bin2con bin)
+
+             else do str <- readBin
+                     con <- str2con (map (chr . bin2nat) str)
+                     return (fromConstr con)
+
+  -- Determine result type
+  myDataType = dataTypeOf (getArg result)
+     where
+      getArg :: ReadB a -> a
+      getArg = undefined
+
+  -- Obtain the maximum index for the type at hand
+  max :: Int
+  max = maxConstrIndex myDataType
+
+  -- Convert a bit stream into a constructor 
+  bin2con :: Bin -> Constr
+  bin2con bin = indexConstr myDataType ((bin2nat bin) + 1)
+
+  -- Convert string to constructor; could fail
+  str2con :: String -> ReadB Constr
+  str2con = maybe mzero return
+                . readConstr myDataType
+
+
+
+-----------------------------------------------------------------------------
+
+
+
+tests = (   showBin True
+        , ( showBin [True]
+        , ( showBin (1::Int)
+        , ( showBin "1"
+        , ( showBin genCom
+        , ( geq genCom genCom' 
+        )))))) ~=? output
+ where
+  genCom' = fromJust (fst (unReadB readBin (showBin genCom))) :: Company
+
+output = ([One],([One,One,Zero],([One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero],([One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero],([One,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,Zero,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,One,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,One,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,Zero,Zero],True)))))
tests/Builders.hs view
@@ -1,20 +1,20 @@-{-# OPTIONS -fglasgow-exts #-}--module Builders (tests) where---- Testing Data.Generics.Builders functionality --import Test.HUnit--import Data.Data-import Data.Generics.Builders----- Main function for testing-tests = ( constrs :: [Maybe Int]-        , constrs :: [String]-        , constrs :: [Either Int Float]-        , constrs :: [((), Integer)]-        ) ~=? output-+{-# OPTIONS -fglasgow-exts #-}
+
+module Builders (tests) where
+
+-- Testing Data.Generics.Builders functionality 
+
+import Test.HUnit
+
+import Data.Data
+import Data.Generics.Builders
+
+
+-- Main function for testing
+tests = ( constrs :: [Maybe Int]
+        , constrs :: [String]
+        , constrs :: [Either Int Float]
+        , constrs :: [((), Integer)]
+        ) ~=? output
+
 output = ([Nothing,Just 0],["","\NUL"],[Left 0,Right 0.0],[((),0)])
tests/CompanyDatatypes.hs view
@@ -1,39 +1,39 @@-{-# OPTIONS -fglasgow-exts #-}--module CompanyDatatypes where--import Data.Generics hiding (Unit)---- The organisational structure of a company--data Company  = C [Dept]               deriving (Eq, Show, Typeable, Data)-data Dept     = D Name Manager [Unit]  deriving (Eq, Show, Typeable, Data)-data Unit     = PU Employee | DU Dept  deriving (Eq, Show, Typeable, Data)-data Employee = E Person Salary        deriving (Eq, Show, Typeable, Data)-data Person   = P Name Address         deriving (Eq, Show, Typeable, Data)-data Salary   = S Float                deriving (Eq, Show, Typeable, Data)-type Manager  = Employee-type Name     = String-type Address  = String---- An illustrative company-genCom :: Company-genCom = C [D "Research" laemmel [PU joost, PU marlow],-            D "Strategy" blair   []]---- A typo for the sake of testing equality;--- (cf. lammel vs. laemmel)-genCom' :: Company-genCom' = C [D "Research" lammel [PU joost, PU marlow],-             D "Strategy" blair   []]--lammel, laemmel, joost, blair :: Employee-lammel  = E (P "Lammel" "Amsterdam") (S 8000)-laemmel = E (P "Laemmel" "Amsterdam") (S 8000)-joost   = E (P "Joost"   "Amsterdam") (S 1000)-marlow  = E (P "Marlow"  "Cambridge") (S 2000)-blair   = E (P "Blair"   "London")    (S 100000)---- Some more test data-person1 = P "Lazy" "Home"-dept1   = D "Useless" (E person1 undefined) []+{-# OPTIONS -fglasgow-exts #-}
+
+module CompanyDatatypes where
+
+import Data.Generics (Data, Typeable)
+
+-- The organisational structure of a company
+
+data Company  = C [Dept]               deriving (Eq, Show, Typeable, Data)
+data Dept     = D Name Manager [Unit]  deriving (Eq, Show, Typeable, Data)
+data Unit     = PU Employee | DU Dept  deriving (Eq, Show, Typeable, Data)
+data Employee = E Person Salary        deriving (Eq, Show, Typeable, Data)
+data Person   = P Name Address         deriving (Eq, Show, Typeable, Data)
+data Salary   = S Float                deriving (Eq, Show, Typeable, Data)
+type Manager  = Employee
+type Name     = String
+type Address  = String
+
+-- An illustrative company
+genCom :: Company
+genCom = C [D "Research" laemmel [PU joost, PU marlow],
+            D "Strategy" blair   []]
+
+-- A typo for the sake of testing equality;
+-- (cf. lammel vs. laemmel)
+genCom' :: Company
+genCom' = C [D "Research" lammel [PU joost, PU marlow],
+             D "Strategy" blair   []]
+
+lammel, laemmel, joost, blair :: Employee
+lammel  = E (P "Lammel" "Amsterdam") (S 8000)
+laemmel = E (P "Laemmel" "Amsterdam") (S 8000)
+joost   = E (P "Joost"   "Amsterdam") (S 1000)
+marlow  = E (P "Marlow"  "Cambridge") (S 2000)
+blair   = E (P "Blair"   "London")    (S 100000)
+
+-- Some more test data
+person1 = P "Lazy" "Home"
+dept1   = D "Useless" (E person1 undefined) []
+ 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/Ext1.hs view
@@ -1,124 +1,124 @@-{-# OPTIONS -fglasgow-exts #-}--module Ext1 (tests) where--{---This example records some experiments with polymorphic datatypes.---}--import Test.HUnit--import Data.Generics-import GHC.Base----- Unsafe coerce-unsafeCoerce :: a -> b-unsafeCoerce = unsafeCoerce#----- Handy type constructors-newtype ID x = ID { unID :: x }-newtype CONST c a = CONST { unCONST :: c }----- Extension of a query with a para. poly. list case-extListQ' :: Data d-          => (d -> q)-          -> (forall d. [d] -> q)-          -> d -> q-extListQ' def ext d =-  if isList d-    then ext (unsafeCoerce d)-    else def d ----- Test extListQ'-foo1 :: Data d => d -> Int-foo1 = const 0 `extListQ'` length-t1 = foo1 True -- should count as 0-t2 = foo1 [True,True] -- should count as 2----- Infeasible extension of a query with a data-polymorphic list case-extListQ'' :: Data d-           => (d -> q)-           -> (forall d. Data d => [d] -> q)-           -> d -> q-extListQ'' def ext d =-  if isList d-    then undefined -- hard to avoid an ambiguous type-    else def d ----- Test extListQ from Data.Generics.Aliases-foo2 :: Data a => a -> Int-foo2 = const 0 `ext1Q` list- where-  list :: Data a => [a] -> Int-  list l = foldr (+) 0 $ map glength l--t3 = foo2 (True,True) -- should count as 0-t4 = foo2 [(True,True),(True,True)] -- should count as 2+2=4----- Customisation for lists without type cast-foo3 :: Data a => a -> Int-foo3 x = if isList x-          then foldr (+) 0 $ gmapListQ glength x-          else 0--t5 = foo3 (True,True) -- should count as 0-t6 = foo3 [(True,True),(True,True)] -- should count as 2+2=4----- Test for list datatype-isList :: Data a => a -> Bool-isList x = typeRepTyCon (typeOf x) ==-           typeRepTyCon (typeOf (undefined::[()]))----- Test for nil-isNil :: Data a => a -> Bool-isNil x = toConstr x == toConstr ([]::[()])----- Test for cons-isCons :: Data a => a -> Bool-isCons x = toConstr x == toConstr (():[])----- gmapQ for polymorphic lists-gmapListQ :: forall a q. Data a => (forall a. Data a => a -> q) -> a -> [q]-gmapListQ f x =-  if not $ isList x -    then error "gmapListQ"-    else if isNil x-           then []-           else if isCons x-                  then ( gmapQi 0 f x : gmapQi 1 (gmapListQ f) x )-                  else error "gmapListQ"----- Build nil-mkNil :: Data a => a-mkNil = fromConstr $ toConstr ([]::[()])----- Build cons-mkCons :: Data a => a-mkCons = fromConstr $ toConstr ((undefined:undefined)::[()])----- Main function for testing-tests = ( t1-        , ( t2-        , ( t3-        , ( t4-        , ( t5-        , ( t6-        )))))) ~=? output--output = (0,(2,(0,(4,(0,4)))))+{-# OPTIONS -fglasgow-exts #-}
+
+module Ext1 (tests) where
+
+{-
+
+This example records some experiments with polymorphic datatypes.
+
+-}
+
+import Test.HUnit
+
+import Data.Generics
+import GHC.Base
+
+
+-- Unsafe coerce
+unsafeCoerce :: a -> b
+unsafeCoerce = unsafeCoerce#
+
+
+-- Handy type constructors
+newtype ID x = ID { unID :: x }
+newtype CONST c a = CONST { unCONST :: c }
+
+
+-- Extension of a query with a para. poly. list case
+extListQ' :: Data d
+          => (d -> q)
+          -> (forall d. [d] -> q)
+          -> d -> q
+extListQ' def ext d =
+  if isList d
+    then ext (unsafeCoerce d)
+    else def d 
+
+
+-- Test extListQ'
+foo1 :: Data d => d -> Int
+foo1 = const 0 `extListQ'` length
+t1 = foo1 True -- should count as 0
+t2 = foo1 [True,True] -- should count as 2
+
+
+-- Infeasible extension of a query with a data-polymorphic list case
+extListQ'' :: Data d
+           => (d -> q)
+           -> (forall d. Data d => [d] -> q)
+           -> d -> q
+extListQ'' def ext d =
+  if isList d
+    then undefined -- hard to avoid an ambiguous type
+    else def d 
+
+
+-- Test extListQ from Data.Generics.Aliases
+foo2 :: Data a => a -> Int
+foo2 = const 0 `ext1Q` list
+ where
+  list :: Data a => [a] -> Int
+  list l = foldr (+) 0 $ map glength l
+
+t3 = foo2 (True,True) -- should count as 0
+t4 = foo2 [(True,True),(True,True)] -- should count as 2+2=4
+
+
+-- Customisation for lists without type cast
+foo3 :: Data a => a -> Int
+foo3 x = if isList x
+          then foldr (+) 0 $ gmapListQ glength x
+          else 0
+
+t5 = foo3 (True,True) -- should count as 0
+t6 = foo3 [(True,True),(True,True)] -- should count as 2+2=4
+
+
+-- Test for list datatype
+isList :: Data a => a -> Bool
+isList x = typeRepTyCon (typeOf x) ==
+           typeRepTyCon (typeOf (undefined::[()]))
+
+
+-- Test for nil
+isNil :: Data a => a -> Bool
+isNil x = toConstr x == toConstr ([]::[()])
+
+
+-- Test for cons
+isCons :: Data a => a -> Bool
+isCons x = toConstr x == toConstr (():[])
+
+
+-- gmapQ for polymorphic lists
+gmapListQ :: forall a q. Data a => (forall a. Data a => a -> q) -> a -> [q]
+gmapListQ f x =
+  if not $ isList x 
+    then error "gmapListQ"
+    else if isNil x
+           then []
+           else if isCons x
+                  then ( gmapQi 0 f x : gmapQi 1 (gmapListQ f) x )
+                  else error "gmapListQ"
+
+
+-- Build nil
+mkNil :: Data a => a
+mkNil = fromConstr $ toConstr ([]::[()])
+
+
+-- Build cons
+mkCons :: Data a => a
+mkCons = fromConstr $ toConstr ((undefined:undefined)::[()])
+
+
+-- Main function for testing
+tests = ( t1
+        , ( t2
+        , ( t3
+        , ( t4
+        , ( t5
+        , ( t6
+        )))))) ~=? output
+
+output = (0,(2,(0,(4,(0,4)))))
tests/Ext2.hs view
@@ -1,65 +1,65 @@-{-# LANGUAGE DeriveDataTypeable #-}--module Ext2 (tests) where---- Tests for ext2 and friends--import Test.HUnit-import Data.Generics----- A type of lists-data List a = Nil | Cons a (List a) deriving (Data, Typeable, Show, Eq)---- Example lists-l1, l2 :: List Int-l1 = Cons 1 (Cons 2 Nil)-l2 = Cons 0 l1---- A type of pairs-data Pair a b = Pair1 a b | Pair2 a b deriving (Data, Typeable, Show, Eq)---- Example pairs-p1, p2 :: Pair Int Char-p1 = Pair1 2 'p'-p2 = Pair2 3 'q'---- Structures containing the above-s1 :: [Pair Int Char]-s1 = [p1, p2]--s2 :: (Pair Int Char, List Int)-s2 = (p2, l2)----- Auxiliary functions-unifyPair :: Pair a b -> Pair a b -> Bool-unifyPair (Pair1 _ _) (Pair1 _ _) = True-unifyPair (Pair2 _ _) (Pair2 _ _) = True-unifyPair _           _           = False--flipPair :: Pair a b -> Pair a b-flipPair (Pair1 a b) = Pair2 a b-flipPair (Pair2 a b) = Pair1 a b---- Tests-t1 = everywhere (id `ext2T` flipPair) (s1,s2)-t2 = let f :: (Data a) => a -> Maybe a-         f = (const Nothing) `ext2M` (Just . flipPair)-     in (f p1, f l1)-t3 = everything (+) ( const 0-             `ext1Q` (const 1  :: List a   -> Int)-             `ext2Q` (const 10 :: Pair a b -> Int))-               $ s2-t4 = unifyPair (t4' :: Pair Int Char) t4' where-  t4' :: Data a => a-  t4' = undefined `ext1B` Nil `ext2B` (Pair1 undefined undefined)----- Main function for testing-tests = (t1, t2, t3, t4) ~=? output--output = ((map flipPair s1, (flipPair p2, l2))-         ,(Just (flipPair p1),Nothing)-         ,14-         ,True)+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Ext2 (tests) where
+
+-- Tests for ext2 and friends
+
+import Test.HUnit
+import Data.Generics
+
+
+-- A type of lists
+data List a = Nil | Cons a (List a) deriving (Data, Typeable, Show, Eq)
+
+-- Example lists
+l1, l2 :: List Int
+l1 = Cons 1 (Cons 2 Nil)
+l2 = Cons 0 l1
+
+-- A type of pairs
+data Pair a b = Pair1 a b | Pair2 a b deriving (Data, Typeable, Show, Eq)
+
+-- Example pairs
+p1, p2 :: Pair Int Char
+p1 = Pair1 2 'p'
+p2 = Pair2 3 'q'
+
+-- Structures containing the above
+s1 :: [Pair Int Char]
+s1 = [p1, p2]
+
+s2 :: (Pair Int Char, List Int)
+s2 = (p2, l2)
+
+
+-- Auxiliary functions
+unifyPair :: Pair a b -> Pair a b -> Bool
+unifyPair (Pair1 _ _) (Pair1 _ _) = True
+unifyPair (Pair2 _ _) (Pair2 _ _) = True
+unifyPair _           _           = False
+
+flipPair :: Pair a b -> Pair a b
+flipPair (Pair1 a b) = Pair2 a b
+flipPair (Pair2 a b) = Pair1 a b
+
+-- Tests
+t1 = everywhere (id `ext2T` flipPair) (s1,s2)
+t2 = let f :: (Data a) => a -> Maybe a
+         f = (const Nothing) `ext2M` (Just . flipPair)
+     in (f p1, f l1)
+t3 = everything (+) ( const 0
+             `ext1Q` (const 1  :: List a   -> Int)
+             `ext2Q` (const 10 :: Pair a b -> Int))
+               $ s2
+t4 = unifyPair (t4' :: Pair Int Char) t4' where
+  t4' :: Data a => a
+  t4' = undefined `ext1B` Nil `ext2B` (Pair1 undefined undefined)
+
+
+-- Main function for testing
+tests = (t1, t2, t3, t4) ~=? output
+
+output = ((map flipPair s1, (flipPair p2, l2))
+         ,(Just (flipPair p1),Nothing)
+         ,14
+         ,True)
+ 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/FreeNames.hs view
@@ -1,120 +1,120 @@-{-# OPTIONS -fglasgow-exts #-}--module FreeNames (tests) where--{---This example illustrates the kind of traversals that naturally show up-in language processing. That is, the free names (say, variables) are-derived for a given program fragment. To this end, we need several-worker functions that extract declaring and referencing occurrences-from given program fragments; see "decsExpr", "decsEqua",-etc. below. Then, we need a traversal "freeNames" that traverses over-the program fragment in a bottom-up manner so that free names from-subterms do not escape to the top when corresponding declarations are-provided. The "freeNames" algorithm uses set operations "union" and-"//" to compute sets of free names from the declared and referenced-names of the root term and free names of the immediate subterms.--Contributed by Ralf Laemmel, ralf@cwi.nl---}--import Test.HUnit--import Data.Generics-import Data.List--data System     = S [Function]                     deriving (Typeable, Data)--data Function   = F Name [Equation]                deriving (Typeable, Data)--data Equation   = E [Pattern] Expression System    deriving (Typeable, Data)--data Pattern    = PVar Name-                | PTerm Name [Pattern]             deriving (Typeable, Data)--data Expression = Var Name-                | App Expression Expression-                | Lambda Name Expression           deriving (Typeable, Data)--type Name       = String---- A little sample program--sys1   = S [f1,f2]-f1     = F "f1" [e11]-f2     = F "f2" [e21,e22]-e11    = E [] (Var "id") (S [])-e21    = E [ PTerm "C" [ PVar "x" ] ] (Var "x") (S [])-e22    = E [] (Var "id") (S [])----- Names declared in an expression-decsExpr :: Expression -> [Name]-decsExpr (Lambda n _) = [n]-decsExpr _            = []---- Names declared in an equation-decsEqua :: Equation -> [Name]-decsEqua (E ps _ _) = everything union ([] `mkQ` pvar) ps-  where-    pvar (PVar n) = [n]-    pvar _        = []---- Names declared in a system-decsSyst :: System -> [Name]-decsSyst (S l) = nub $ map (\(F n _) -> n) l---- Names referenced in an expression-refsExpr :: Expression -> [Name]-refsExpr (Var n) = [n]---- Names referenced in an equation-refsEqua :: Equation -> [Name]-refsEqua (E ps _ _) = everything union ([] `mkQ` pterm) ps-  where-    pterm (PTerm n _) = [n]-    pterm _           = []---- Combine the above type-specific cases to obtain--- generic functions that find declared and referenced names----decsFun :: Data a => a -> [Name]-decsFun =  const [] `extQ` decsExpr `extQ` decsEqua `extQ` decsSyst--refsFun :: Data a => a -> [Name]-refsFun =  const [] `extQ` refsExpr `extQ` refsEqua----{---Free name analysis: Take the union of free names obtained from the-immediate subterms (via gmapQ) and the names being referred to at the-root of the present term, but subtract all the names that are declared-at the root.---}- -freeNames :: Data a => a -> [Name]-freeNames x = ( (refsFun x)-                `union`-                (nub . concat . gmapQ freeNames) x-              )-              \\-              decsFun x--{---Print the free names for the sample program sys1; see module-FunDatatypes.hs. This should print the list ["id","C"] because the-"Prelude" function "id" is used in the sample program, and also the-term constructor "C" occurs in a pattern; we assume a language without-explicit datatype declarations ;-)---}--tests = freeNames sys1 ~=? output--output = ["id","C"]+{-# OPTIONS -fglasgow-exts #-}
+
+module FreeNames (tests) where
+
+{-
+
+This example illustrates the kind of traversals that naturally show up
+in language processing. That is, the free names (say, variables) are
+derived for a given program fragment. To this end, we need several
+worker functions that extract declaring and referencing occurrences
+from given program fragments; see "decsExpr", "decsEqua",
+etc. below. Then, we need a traversal "freeNames" that traverses over
+the program fragment in a bottom-up manner so that free names from
+subterms do not escape to the top when corresponding declarations are
+provided. The "freeNames" algorithm uses set operations "union" and
+"//" to compute sets of free names from the declared and referenced
+names of the root term and free names of the immediate subterms.
+
+Contributed by Ralf Laemmel, ralf@cwi.nl
+
+-}
+
+import Test.HUnit
+
+import Data.Generics
+import Data.List
+
+data System     = S [Function]                     deriving (Typeable, Data)
+
+data Function   = F Name [Equation]                deriving (Typeable, Data)
+
+data Equation   = E [Pattern] Expression System    deriving (Typeable, Data)
+
+data Pattern    = PVar Name
+                | PTerm Name [Pattern]             deriving (Typeable, Data)
+
+data Expression = Var Name
+                | App Expression Expression
+                | Lambda Name Expression           deriving (Typeable, Data)
+
+type Name       = String
+
+-- A little sample program
+
+sys1   = S [f1,f2]
+f1     = F "f1" [e11]
+f2     = F "f2" [e21,e22]
+e11    = E [] (Var "id") (S [])
+e21    = E [ PTerm "C" [ PVar "x" ] ] (Var "x") (S [])
+e22    = E [] (Var "id") (S [])
+
+
+-- Names declared in an expression
+decsExpr :: Expression -> [Name]
+decsExpr (Lambda n _) = [n]
+decsExpr _            = []
+
+-- Names declared in an equation
+decsEqua :: Equation -> [Name]
+decsEqua (E ps _ _) = everything union ([] `mkQ` pvar) ps
+  where
+    pvar (PVar n) = [n]
+    pvar _        = []
+
+-- Names declared in a system
+decsSyst :: System -> [Name]
+decsSyst (S l) = nub $ map (\(F n _) -> n) l
+
+-- Names referenced in an expression
+refsExpr :: Expression -> [Name]
+refsExpr (Var n) = [n]
+
+-- Names referenced in an equation
+refsEqua :: Equation -> [Name]
+refsEqua (E ps _ _) = everything union ([] `mkQ` pterm) ps
+  where
+    pterm (PTerm n _) = [n]
+    pterm _           = []
+
+-- Combine the above type-specific cases to obtain
+-- generic functions that find declared and referenced names
+--
+decsFun :: Data a => a -> [Name]
+decsFun =  const [] `extQ` decsExpr `extQ` decsEqua `extQ` decsSyst
+
+refsFun :: Data a => a -> [Name]
+refsFun =  const [] `extQ` refsExpr `extQ` refsEqua
+
+
+
+{-
+
+Free name analysis: Take the union of free names obtained from the
+immediate subterms (via gmapQ) and the names being referred to at the
+root of the present term, but subtract all the names that are declared
+at the root.
+
+-}
+ 
+freeNames :: Data a => a -> [Name]
+freeNames x = ( (refsFun x)
+                `union`
+                (nub . concat . gmapQ freeNames) x
+              )
+              \\
+              decsFun x
+
+{-
+
+Print the free names for the sample program sys1; see module
+FunDatatypes.hs. This should print the list ["id","C"] because the
+"Prelude" function "id" is used in the sample program, and also the
+term constructor "C" occurs in a pattern; we assume a language without
+explicit datatype declarations ;-)
+
+-}
+
+tests = freeNames sys1 ~=? output
+
+output = ["id","C"]
tests/GEq.hs view
@@ -1,21 +1,21 @@-{-# OPTIONS -fglasgow-exts #-}--module GEq (tests) where--{---This test exercices GENERIC read, show, and eq for the company-datatypes which we use a lot. The output of the program should be-"True" which means that "gread" reads what "gshow" shows while the-read term is equal to the original term in terms of "geq".---}--import Test.HUnit--import Data.Generics-import CompanyDatatypes--tests = ( geq genCom genCom-        , geq genCom genCom'-        ) ~=? (True,False)+{-# OPTIONS -fglasgow-exts #-}
+
+module GEq (tests) where
+
+{-
+
+This test exercices GENERIC read, show, and eq for the company
+datatypes which we use a lot. The output of the program should be
+"True" which means that "gread" reads what "gshow" shows while the
+read term is equal to the original term in terms of "geq".
+
+-}
+
+import Test.HUnit
+
+import Data.Generics
+import CompanyDatatypes
+
+tests = ( geq genCom genCom
+        , geq genCom genCom'
+        ) ~=? (True,False)
tests/GMapQAssoc.hs view
@@ -1,68 +1,68 @@-{-# OPTIONS -fglasgow-exts #-}--module GMapQAssoc (tests) where--{---This example demonstrates the inadequacy of an apparently simpler-variation on gmapQ. To this end, let us first recall a few facts.-Firstly, function application (including constructor application) is-left-associative. This is the reason why we had preferred our generic-fold to be left-associative too. (In "The Sketch Of a Polymorphic-Symphony" you can find a right-associative generic fold.)  Secondly,-lists are right-associative. Because of these inverse associativities-queries for the synthesis of lists require some extra effort to-reflect the left-to-right of immediate subterms in the queried list.-In the module Data.Generics, we solve the problem by a common-higher-order trick, that is, we do not cons lists during folding but-we pass functions on lists starting from the identity function and-passing [] to the resulting function. The following example-illustrates that we get indeed an undesirable right-to-left order if-we just apply the simple constant datatype constructor CONST instead-of the higher-order trick.--Contributed by Ralf Laemmel, ralf@cwi.nl---}--import Test.HUnit--import Data.Generics----- The plain constant type constructor-newtype CONST x y = CONST x-unCONST (CONST x) = x----- A variation on the gmapQ combinator using CONST and not Q-gmapQ' :: Data a => (forall a. Data a => a -> u) -> a -> [u]-gmapQ' f = unCONST . gfoldl f' z-  where-    f' r a = CONST (f a : unCONST r)-    z  = const (CONST [])----- A trivial datatype used for this test case-data IntTree = Leaf Int | Fork IntTree IntTree-               deriving (Typeable, Data)----- Select int if faced with a leaf -leaf (Leaf i) = [i]-leaf _        = []----- A test term-term = Fork (Leaf 1) (Leaf 2)----- Process test term---  gmapQ  gives left-to-right order---  gmapQ' gives right-to-left order----tests = show ( gmapQ   ([] `mkQ` leaf) term-             , gmapQ'  ([] `mkQ` leaf) term-             ) ~=? output--output = show ([[1],[2]],[[2],[1]])+{-# OPTIONS -fglasgow-exts #-}
+
+module GMapQAssoc (tests) where
+
+{-
+
+This example demonstrates the inadequacy of an apparently simpler
+variation on gmapQ. To this end, let us first recall a few facts.
+Firstly, function application (including constructor application) is
+left-associative. This is the reason why we had preferred our generic
+fold to be left-associative too. (In "The Sketch Of a Polymorphic
+Symphony" you can find a right-associative generic fold.)  Secondly,
+lists are right-associative. Because of these inverse associativities
+queries for the synthesis of lists require some extra effort to
+reflect the left-to-right of immediate subterms in the queried list.
+In the module Data.Generics, we solve the problem by a common
+higher-order trick, that is, we do not cons lists during folding but
+we pass functions on lists starting from the identity function and
+passing [] to the resulting function. The following example
+illustrates that we get indeed an undesirable right-to-left order if
+we just apply the simple constant datatype constructor CONST instead
+of the higher-order trick.
+
+Contributed by Ralf Laemmel, ralf@cwi.nl
+
+-}
+
+import Test.HUnit
+
+import Data.Generics
+
+
+-- The plain constant type constructor
+newtype CONST x y = CONST x
+unCONST (CONST x) = x
+
+
+-- A variation on the gmapQ combinator using CONST and not Q
+gmapQ' :: Data a => (forall a. Data a => a -> u) -> a -> [u]
+gmapQ' f = unCONST . gfoldl f' z
+  where
+    f' r a = CONST (f a : unCONST r)
+    z  = const (CONST [])
+
+
+-- A trivial datatype used for this test case
+data IntTree = Leaf Int | Fork IntTree IntTree
+               deriving (Typeable, Data)
+
+
+-- Select int if faced with a leaf 
+leaf (Leaf i) = [i]
+leaf _        = []
+
+
+-- A test term
+term = Fork (Leaf 1) (Leaf 2)
+
+
+-- Process test term
+--  gmapQ  gives left-to-right order
+--  gmapQ' gives right-to-left order
+--
+tests = show ( gmapQ   ([] `mkQ` leaf) term
+             , gmapQ'  ([] `mkQ` leaf) term
+             ) ~=? output
+
+output = show ([[1],[2]],[[2],[1]])
+ 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/GShow.hs view
@@ -1,52 +1,52 @@-{-# OPTIONS -fglasgow-exts #-}- -module GShow (tests) where--{-- -The generic show example from the 2nd boilerplate paper.-(There were some typos in the ICFP 2004 paper.)-Also check out Data.Generics.Text.- --}--import Test.HUnit--import Data.Generics hiding (gshow)-import Prelude hiding (showString)-- -gshow :: Data a => a -> String-gshow = gshow_help `extQ` showString--gshow_help :: Data a => a -> String-gshow_help t -     =  "("-     ++ showConstr (toConstr t)-     ++ concat (intersperse " " (gmapQ gshow t))-     ++ ")"--showString :: String -> String-showString s = "\"" ++ concat (map escape s) ++ "\"" -               where-                 escape '\n' = "\\n"-                 escape other_char = [other_char]--gshowList :: Data b => [b] -> String-gshowList xs-    = "[" ++ concat (intersperse "," (map gshow xs)) ++ "]"--gshow' :: Data a => a -> String-gshow' = gshow_help `ext1Q` gshowList -                    `extQ`  showString--intersperse :: a -> [a] -> [a]-intersperse _ []     = []-intersperse x [e]    = [e]-intersperse x (e:es) = (e:(x:intersperse x es))--tests = ( gshow' "foo"-        , gshow' [True,False]-        ) ~=? output--output = ("\"foo\"","[(True),(False)]")+{-# OPTIONS -fglasgow-exts #-}
+ 
+module GShow (tests) where
+
+{-
+ 
+The generic show example from the 2nd boilerplate paper.
+(There were some typos in the ICFP 2004 paper.)
+Also check out Data.Generics.Text.
+ 
+-}
+
+import Test.HUnit
+
+import Data.Generics hiding (gshow)
+import Prelude hiding (showString)
+
+ 
+gshow :: Data a => a -> String
+gshow = gshow_help `extQ` showString
+
+gshow_help :: Data a => a -> String
+gshow_help t 
+     =  "("
+     ++ showConstr (toConstr t)
+     ++ concat (intersperse " " (gmapQ gshow t))
+     ++ ")"
+
+showString :: String -> String
+showString s = "\"" ++ concat (map escape s) ++ "\"" 
+               where
+                 escape '\n' = "\\n"
+                 escape other_char = [other_char]
+
+gshowList :: Data b => [b] -> String
+gshowList xs
+    = "[" ++ concat (intersperse "," (map gshow xs)) ++ "]"
+
+gshow' :: Data a => a -> String
+gshow' = gshow_help `ext1Q` gshowList 
+                    `extQ`  showString
+
+intersperse :: a -> [a] -> [a]
+intersperse _ []     = []
+intersperse x [e]    = [e]
+intersperse x (e:es) = (e:(x:intersperse x es))
+
+tests = ( gshow' "foo"
+        , gshow' [True,False]
+        ) ~=? output
+
+output = ("\"foo\"","[(True),(False)]")
+ 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/GZip.hs view
@@ -1,46 +1,46 @@-{-# OPTIONS -fglasgow-exts #-}--module GZip (tests) where--{---This test illustrates zipping for the company datatypes which we use a-lot. We process two companies that happen to agree on the overall-shape but differ in the salaries in a few positions. So whenever we-encounter salaries we take the maximum of the two.---}--import Test.HUnit--import Data.Generics-import CompanyDatatypes---- The main function which prints the result of zipping-tests = gzip (\x y -> mkTT maxS x y) genCom1 genCom2 ~=? output-  -- NB: the argument has to be eta-expanded to match-  --     the type of gzip's argument type, which is-  --     GenericQ (GenericM Maybe)-  where--    -- Variations on the show case company "genCom"-    genCom1 = everywhere (mkT (double "Joost")) genCom-    genCom2 = everywhere (mkT (double "Marlow")) genCom-    double x (E p@(P y _) (S s)) | x == y = E p (S (2*s))-    double _ e = e--    -- Sum up two salaries-    maxS (S x) (S y) = S (max x y)--    -- Make a two-arguments, generic function transformer-    mkTT :: (Typeable a, Typeable b, Typeable c)-         => (a -> a -> a) -> b -> c -> Maybe c-    mkTT (f::a -> a -> a) x y =-      case (cast x,cast y) of-        (Just (x'::a),Just (y'::a)) -> cast (f x' y')-        _                           -> Nothing--output = Just (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) -           [PU (E (P "Joost" "Amsterdam") (S 2000.0))-           ,PU (E (P "Marlow" "Cambridge") (S 4000.0))]-           ,D "Strategy" (E (P "Blair" "London") (S 100000.0)) []])+{-# OPTIONS -fglasgow-exts #-}
+
+module GZip (tests) where
+
+{-
+
+This test illustrates zipping for the company datatypes which we use a
+lot. We process two companies that happen to agree on the overall
+shape but differ in the salaries in a few positions. So whenever we
+encounter salaries we take the maximum of the two.
+
+-}
+
+import Test.HUnit
+
+import Data.Generics
+import CompanyDatatypes
+
+-- The main function which prints the result of zipping
+tests = gzip (\x y -> mkTT maxS x y) genCom1 genCom2 ~=? output
+  -- NB: the argument has to be eta-expanded to match
+  --     the type of gzip's argument type, which is
+  --     GenericQ (GenericM Maybe)
+  where
+
+    -- Variations on the show case company "genCom"
+    genCom1 = everywhere (mkT (double "Joost")) genCom
+    genCom2 = everywhere (mkT (double "Marlow")) genCom
+    double x (E p@(P y _) (S s)) | x == y = E p (S (2*s))
+    double _ e = e
+
+    -- Sum up two salaries
+    maxS (S x) (S y) = S (max x y)
+
+    -- Make a two-arguments, generic function transformer
+    mkTT :: (Typeable a, Typeable b, Typeable c)
+         => (a -> a -> a) -> b -> c -> Maybe c
+    mkTT (f::a -> a -> a) x y =
+      case (cast x,cast y) of
+        (Just (x'::a),Just (y'::a)) -> cast (f x' y')
+        _                           -> Nothing
+
+output = Just (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) 
+           [PU (E (P "Joost" "Amsterdam") (S 2000.0))
+           ,PU (E (P "Marlow" "Cambridge") (S 4000.0))]
+           ,D "Strategy" (E (P "Blair" "London") (S 100000.0)) []])
tests/GenUpTo.hs view
@@ -1,94 +1,94 @@-{-# OPTIONS -fglasgow-exts #-}--module GenUpTo (tests) where--{---This example illustrate test-set generation,-namely all terms of a given depth are generated.---}--import Test.HUnit--import Data.Generics---{---The following datatypes comprise the abstract syntax of a simple-imperative language. Some provisions are such that the discussion-of test-set generation is simplified. In particular, we do not -consider anything but monomorphic *data*types --- no primitive-types, no tuples, ...---}- -data Prog = Prog Dec Stat -            deriving (Show, Eq, Typeable, Data)--data Dec  = Nodec-          | Ondec Id Type -          | Manydecs Dec Dec-            deriving (Show, Eq, Typeable, Data)--data Id = A | B-          deriving (Show, Eq, Typeable, Data)--data Type = Int | Bool-            deriving (Show, Eq, Typeable, Data)--data Stat = Noop-          | Assign Id Exp-          | Seq Stat Stat-            deriving (Show, Eq, Typeable, Data)--data Exp = Zero -         | Succ Exp-           deriving (Show, Eq, Typeable, Data)----- Generate all terms of a given depth-genUpTo :: Data a => Int -> [a]-genUpTo 0 = []-genUpTo d = result-   where-     -- Getting hold of the result (type)-     result = concat (map recurse cons)--     -- Retrieve constructors of the requested type-     cons :: [Constr]-     cons = dataTypeConstrs (dataTypeOf (head result))--     -- Find all terms headed by a specific Constr-     recurse :: Data a => Constr -> [a]-     recurse con = gmapM (\_ -> genUpTo (d-1)) -                         (fromConstr con)--     -- We could also deal with primitive types easily.-     -- Then we had to use cons' instead of cons.-     ---     cons' :: [Constr]-     cons' = case dataTypeRep ty of-              AlgRep cons -> cons-              IntRep      -> [mkIntegralConstr ty 0]-              FloatRep    -> [mkIntegralConstr ty 0]-              CharRep     -> [mkCharConstr ty 'x']-      where-        ty = dataTypeOf (head result)     ----- For silly tests-data T0 = T0 T1 T2 T3 deriving (Show, Eq, Typeable, Data)-data T1 = T1a | T1b   deriving (Show, Eq, Typeable, Data)-data T2 = T2a | T2b   deriving (Show, Eq, Typeable, Data)-data T3 = T3a | T3b   deriving (Show, Eq, Typeable, Data)--tests = (   genUpTo 0 :: [Id]-        , ( genUpTo 1 :: [Id]-        , ( genUpTo 2 :: [Id]-        , ( genUpTo 2 :: [T0]-        , ( genUpTo 3 :: [Prog]-        ))))) ~=? output--output = ([],([A,B],([A,B],([T0 T1a T2a T3a,T0 T1a T2a T3b,T0 T1a T2b T3a,T0 T1a T2b T3b,T0 T1b T2a T3a,T0 T1b T2a T3b,T0 T1b T2b T3a,T0 T1b T2b T3b],[Prog Nodec Noop,Prog Nodec (Assign A Zero),Prog Nodec (Assign B Zero),Prog Nodec (Seq Noop Noop),Prog (Ondec A Int) Noop,Prog (Ondec A Int) (Assign A Zero),Prog (Ondec A Int) (Assign B Zero),Prog (Ondec A Int) (Seq Noop Noop),Prog (Ondec A Bool) Noop,Prog (Ondec A Bool) (Assign A Zero),Prog (Ondec A Bool) (Assign B Zero),Prog (Ondec A Bool) (Seq Noop Noop),Prog (Ondec B Int) Noop,Prog (Ondec B Int) (Assign A Zero),Prog (Ondec B Int) (Assign B Zero),Prog (Ondec B Int) (Seq Noop Noop),Prog (Ondec B Bool) Noop,Prog (Ondec B Bool) (Assign A Zero),Prog (Ondec B Bool) (Assign B Zero),Prog (Ondec B Bool) (Seq Noop Noop),Prog (Manydecs Nodec Nodec) Noop,Prog (Manydecs Nodec Nodec) (Assign A Zero),Prog (Manydecs Nodec Nodec) (Assign B Zero),Prog (Manydecs Nodec Nodec) (Seq Noop Noop)]))))+{-# OPTIONS -fglasgow-exts #-}
+
+module GenUpTo (tests) where
+
+{-
+
+This example illustrate test-set generation,
+namely all terms of a given depth are generated.
+
+-}
+
+import Test.HUnit
+
+import Data.Generics
+
+
+{-
+
+The following datatypes comprise the abstract syntax of a simple
+imperative language. Some provisions are such that the discussion
+of test-set generation is simplified. In particular, we do not 
+consider anything but monomorphic *data*types --- no primitive
+types, no tuples, ...
+
+-}
+ 
+data Prog = Prog Dec Stat 
+            deriving (Show, Eq, Typeable, Data)
+
+data Dec  = Nodec
+          | Ondec Id Type 
+          | Manydecs Dec Dec
+            deriving (Show, Eq, Typeable, Data)
+
+data Id = A | B
+          deriving (Show, Eq, Typeable, Data)
+
+data Type = Int | Bool
+            deriving (Show, Eq, Typeable, Data)
+
+data Stat = Noop
+          | Assign Id Exp
+          | Seq Stat Stat
+            deriving (Show, Eq, Typeable, Data)
+
+data Exp = Zero 
+         | Succ Exp
+           deriving (Show, Eq, Typeable, Data)
+
+
+-- Generate all terms of a given depth
+genUpTo :: Data a => Int -> [a]
+genUpTo 0 = []
+genUpTo d = result
+   where
+     -- Getting hold of the result (type)
+     result = concat (map recurse cons)
+
+     -- Retrieve constructors of the requested type
+     cons :: [Constr]
+     cons = dataTypeConstrs (dataTypeOf (head result))
+
+     -- Find all terms headed by a specific Constr
+     recurse :: Data a => Constr -> [a]
+     recurse con = gmapM (\_ -> genUpTo (d-1)) 
+                         (fromConstr con)
+
+     -- We could also deal with primitive types easily.
+     -- Then we had to use cons' instead of cons.
+     --
+     cons' :: [Constr]
+     cons' = case dataTypeRep ty of
+              AlgRep cons -> cons
+              IntRep      -> [mkIntegralConstr ty 0]
+              FloatRep    -> [mkIntegralConstr ty 0]
+              CharRep     -> [mkCharConstr ty 'x']
+      where
+        ty = dataTypeOf (head result)     
+
+
+-- For silly tests
+data T0 = T0 T1 T2 T3 deriving (Show, Eq, Typeable, Data)
+data T1 = T1a | T1b   deriving (Show, Eq, Typeable, Data)
+data T2 = T2a | T2b   deriving (Show, Eq, Typeable, Data)
+data T3 = T3a | T3b   deriving (Show, Eq, Typeable, Data)
+
+tests = (   genUpTo 0 :: [Id]
+        , ( genUpTo 1 :: [Id]
+        , ( genUpTo 2 :: [Id]
+        , ( genUpTo 2 :: [T0]
+        , ( genUpTo 3 :: [Prog]
+        ))))) ~=? output
+
+output = ([],([A,B],([A,B],([T0 T1a T2a T3a,T0 T1a T2a T3b,T0 T1a T2b T3a,T0 T1a T2b T3b,T0 T1b T2a T3a,T0 T1b T2a T3b,T0 T1b T2b T3a,T0 T1b T2b T3b],[Prog Nodec Noop,Prog Nodec (Assign A Zero),Prog Nodec (Assign B Zero),Prog Nodec (Seq Noop Noop),Prog (Ondec A Int) Noop,Prog (Ondec A Int) (Assign A Zero),Prog (Ondec A Int) (Assign B Zero),Prog (Ondec A Int) (Seq Noop Noop),Prog (Ondec A Bool) Noop,Prog (Ondec A Bool) (Assign A Zero),Prog (Ondec A Bool) (Assign B Zero),Prog (Ondec A Bool) (Seq Noop Noop),Prog (Ondec B Int) Noop,Prog (Ondec B Int) (Assign A Zero),Prog (Ondec B Int) (Assign B Zero),Prog (Ondec B Int) (Seq Noop Noop),Prog (Ondec B Bool) Noop,Prog (Ondec B Bool) (Assign A Zero),Prog (Ondec B Bool) (Assign B Zero),Prog (Ondec B Bool) (Seq Noop Noop),Prog (Manydecs Nodec Nodec) Noop,Prog (Manydecs Nodec Nodec) (Assign A Zero),Prog (Manydecs Nodec Nodec) (Assign B Zero),Prog (Manydecs Nodec Nodec) (Seq Noop Noop)]))))
+ 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/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/LocalQuantors.hs view
@@ -1,21 +1,21 @@-{-# OPTIONS -fglasgow-exts #-}--module LocalQuantors () where---- A datatype with a locally quantified component--- Seems to be too polymorphic to descend into structure!--- Largely irrelevant?!--import Data.Generics--data Test = Test (GenericT) deriving Typeable--instance Data Test-  where-    gfoldl _ z x = z x -- folding without descent -    toConstr (Test _) = testConstr-    gunfold _ _ = error "gunfold"-    dataTypeOf _ = testDataType--testConstr   = mkConstr testDataType "Test" [] Prefix-testDataType = mkDataType "Main.Test" [testConstr]+{-# OPTIONS -fglasgow-exts #-}
+
+module LocalQuantors () where
+
+-- A datatype with a locally quantified component
+-- Seems to be too polymorphic to descend into structure!
+-- Largely irrelevant?!
+
+import Data.Generics
+
+data Test = Test (GenericT) deriving Typeable
+
+instance Data Test
+  where
+    gfoldl _ z x = z x -- folding without descent 
+    toConstr (Test _) = testConstr
+    gunfold _ _ = error "gunfold"
+    dataTypeOf _ = testDataType
+
+testConstr   = mkConstr testDataType "Test" [] Prefix
+testDataType = mkDataType "Main.Test" [testConstr]
tests/Main.hs view
@@ -1,84 +1,84 @@--module Main where--import Test.HUnit-import System.Exit--import qualified Bits-import qualified Builders-import qualified Datatype-import qualified Ext1-import qualified Ext2-import qualified FoldTree-import qualified FreeNames-import qualified GEq-import qualified GMapQAssoc-import qualified GRead-import qualified GShow-import qualified GShow2-import qualified GZip-import qualified GenUpTo-import qualified GetC-import qualified HList-import qualified HOPat-import qualified Labels-import qualified Newtype-import qualified Paradise-import qualified Perm-import qualified Reify-import qualified Strings-import qualified Tree-import qualified Twin-import qualified Typeable-import qualified Typecase1-import qualified Typecase2-import qualified Where-import qualified XML--import qualified Encode           -- no tests, should compile-import qualified Ext              -- no tests, should compile-import qualified GRead2           -- no tests, should compile-import qualified LocalQuantors    -- no tests, should compile-import qualified NestedDatatypes  -- no tests, should compile-import qualified Polymatch        -- no tests, should compile---tests =-  "All" ~: [ Datatype.tests-           , FoldTree.tests-           , GetC.tests-           , GMapQAssoc.tests-           , GRead.tests-           , GShow.tests-           , GShow2.tests-           , HList.tests-           , HOPat.tests-           , Labels.tests-           , Newtype.tests-           , Perm.tests-           , Twin.tests-           , Typeable.tests-           , Typecase1.tests-           , Typecase2.tests-           , Where.tests-           , XML.tests-           , Tree.tests-           , Strings.tests-           , Reify.tests-           , Paradise.tests-           , GZip.tests-           , GEq.tests-           , GenUpTo.tests-           , FreeNames.tests-           , Ext1.tests-           , Ext2.tests-           , Bits.tests-           , Builders.tests-           ]--main = do-         putStrLn "Running tests for syb..."-         counts <- runTestTT tests-         if (failures counts > 0)-           then exitFailure-             else exitSuccess+
+module Main where
+
+import Test.HUnit
+import System.Exit
+
+import qualified Bits
+import qualified Builders
+import qualified Datatype
+import qualified Ext1
+import qualified Ext2
+import qualified FoldTree
+import qualified FreeNames
+import qualified GEq
+import qualified GMapQAssoc
+import qualified GRead
+import qualified GShow
+import qualified GShow2
+import qualified GZip
+import qualified GenUpTo
+import qualified GetC
+import qualified HList
+import qualified HOPat
+import qualified Labels
+import qualified Newtype
+import qualified Paradise
+import qualified Perm
+import qualified Reify
+import qualified Strings
+import qualified Tree
+import qualified Twin
+import qualified Typeable
+import qualified Typecase1
+import qualified Typecase2
+import qualified Where
+import qualified XML
+
+import qualified Encode           -- no tests, should compile
+import qualified Ext              -- no tests, should compile
+import qualified GRead2           -- no tests, should compile
+import qualified LocalQuantors    -- no tests, should compile
+import qualified NestedDatatypes  -- no tests, should compile
+import qualified Polymatch        -- no tests, should compile
+
+
+tests =
+  "All" ~: [ Datatype.tests
+           , FoldTree.tests
+           , GetC.tests
+           , GMapQAssoc.tests
+           , GRead.tests
+           , GShow.tests
+           , GShow2.tests
+           , HList.tests
+           , HOPat.tests
+           , Labels.tests
+           , Newtype.tests
+           , Perm.tests
+           , Twin.tests
+           , Typeable.tests
+           , Typecase1.tests
+           , Typecase2.tests
+           , Where.tests
+           , XML.tests
+           , Tree.tests
+           , Strings.tests
+           , Reify.tests
+           , Paradise.tests
+           , GZip.tests
+           , GEq.tests
+           , GenUpTo.tests
+           , FreeNames.tests
+           , Ext1.tests
+           , Ext2.tests
+           , Bits.tests
+           , Builders.tests
+           ]
+
+main = do
+         putStrLn "Running tests for syb..."
+         counts <- runTestTT tests
+         if (failures counts > 0)
+           then exitFailure
+             else exitSuccess
tests/NestedDatatypes.hs view
@@ -1,52 +1,52 @@-{-# OPTIONS -fglasgow-exts #-}-{-# LANGUAGE UndecidableInstances #-}--module NestedDatatypes () where--{---We provide an illustrative ScrapYourBoilerplate example for a nested-datatype.  For clarity, we do not derive the Typeable and Data-instances by the deriving mechanism but we show the intended-definitions. The overall conclusion is that nested datatypes do not-pose any challenge for the ScrapYourBoilerplate scheme. Well, this is-maybe not quite true because it seems like we need to allow-undecidable instances.---}--import Data.Dynamic-import Data.Generics-- --- A nested datatype-data Nest a = Box a | Wrap (Nest [a])----- The representation of the type constructor    -nestTc = mkTyCon "Nest"----- The Typeable instance for the nested datatype    -instance Typeable1 Nest-  where-    typeOf1 n = mkTyConApp nestTc []----- The Data instance for the nested datatype-instance (Data a, Data [a]) => Data (Nest a)-  where-    gfoldl k z (Box a)  = z Box `k` a-    gfoldl k z (Wrap w) = z Wrap `k` w-    gmapT f (Box a)  = Box (f a)-    gmapT f (Wrap w) = Wrap (f w)-    toConstr (Box _)  = boxConstr-    toConstr (Wrap _) = wrapConstr-    gunfold k z c = case constrIndex c of-                      1 -> k (z Box)-                      2 -> k (z Wrap)-    dataTypeOf _ = nestDataType--boxConstr    = mkConstr nestDataType "Box"  [] Prefix-wrapConstr   = mkConstr nestDataType "Wrap" [] Prefix-nestDataType = mkDataType "Main.Nest" [boxConstr,wrapConstr]+{-# OPTIONS -fglasgow-exts #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module NestedDatatypes () where
+
+{-
+
+We provide an illustrative ScrapYourBoilerplate example for a nested
+datatype.  For clarity, we do not derive the Typeable and Data
+instances by the deriving mechanism but we show the intended
+definitions. The overall conclusion is that nested datatypes do not
+pose any challenge for the ScrapYourBoilerplate scheme. Well, this is
+maybe not quite true because it seems like we need to allow
+undecidable instances.
+
+-}
+
+import Data.Dynamic
+import Data.Generics
+
+ 
+-- A nested datatype
+data Nest a = Box a | Wrap (Nest [a])
+
+
+-- The representation of the type constructor    
+nestTc = mkTyCon "Nest"
+
+
+-- The Typeable instance for the nested datatype    
+instance Typeable1 Nest
+  where
+    typeOf1 n = mkTyConApp nestTc []
+
+
+-- The Data instance for the nested datatype
+instance (Data a, Data [a]) => Data (Nest a)
+  where
+    gfoldl k z (Box a)  = z Box `k` a
+    gfoldl k z (Wrap w) = z Wrap `k` w
+    gmapT f (Box a)  = Box (f a)
+    gmapT f (Wrap w) = Wrap (f w)
+    toConstr (Box _)  = boxConstr
+    toConstr (Wrap _) = wrapConstr
+    gunfold k z c = case constrIndex c of
+                      1 -> k (z Box)
+                      2 -> k (z Wrap)
+    dataTypeOf _ = nestDataType
+
+boxConstr    = mkConstr nestDataType "Box"  [] Prefix
+wrapConstr   = mkConstr nestDataType "Wrap" [] Prefix
+nestDataType = mkDataType "Main.Nest" [boxConstr,wrapConstr]
+ 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/Paradise.hs view
@@ -1,29 +1,29 @@-{-# OPTIONS -fglasgow-exts #-}--module Paradise (tests) where--{---This test runs the infamous PARADISE benchmark,-which is the HELLO WORLD example of generic programming,-i.e., the "increase salary" function is applied to-a typical company just as shown in the boilerplate paper.---}--import Test.HUnit--import Data.Generics-import CompanyDatatypes---- Increase salary by percentage-increase :: Float -> Company -> Company-increase k = everywhere (mkT (incS k))---- "interesting" code for increase-incS :: Float -> Salary -> Salary-incS k (S s) = S (s * (1+k))--tests = increase 0.1 genCom ~=? output--output = C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8800.0)) [PU (E (P "Joost" "Amsterdam") (S 1100.0)),PU (E (P "Marlow" "Cambridge") (S 2200.0))],D "Strategy" (E (P "Blair" "London") (S 110000.0)) []]+{-# OPTIONS -fglasgow-exts #-}
+
+module Paradise (tests) where
+
+{-
+
+This test runs the infamous PARADISE benchmark,
+which is the HELLO WORLD example of generic programming,
+i.e., the "increase salary" function is applied to
+a typical company just as shown in the boilerplate paper.
+
+-}
+
+import Test.HUnit
+
+import Data.Generics
+import CompanyDatatypes
+
+-- Increase salary by percentage
+increase :: Float -> Company -> Company
+increase k = everywhere (mkT (incS k))
+
+-- "interesting" code for increase
+incS :: Float -> Salary -> Salary
+incS k (S s) = S (s * (1+k))
+
+tests = increase 0.1 genCom ~=? output
+
+output = C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8800.0)) [PU (E (P "Joost" "Amsterdam") (S 1100.0)),PU (E (P "Marlow" "Cambridge") (S 2200.0))],D "Strategy" (E (P "Blair" "London") (S 110000.0)) []]
+ 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/Reify.hs view
@@ -1,413 +1,413 @@-{-# OPTIONS -fglasgow-exts #-}--module Reify (tests) where--{---The following examples illustrate the reification facilities for type-structure. Most notably, we generate shallow terms using the depth of-types and constructors as means to steer the generation.---}--import Test.HUnit--import Data.Maybe-import Data.Generics-import Control.Monad.State-import CompanyDatatypes----------------------------------------------------------------------------------------	Encoding types as values; some other way.------------------------------------------------------------------------------------{- --This group provides a style of encoding types as values and using-them. This style is seen as an alternative to the pragmatic style used-in Data.Typeable.typeOf and elsewhere, i.e., simply use an "undefined"-to denote a type argument. This pragmatic style suffers from lack-of robustness: one feels tempted to pattern match on undefineds.-Maybe Data.Typeable.typeOf etc. should be rewritten accordingly.---}----- | Type as values to stipulate use of undefineds-type TypeVal a = a -> ()----- | The value that denotes a type-typeVal :: TypeVal a-typeVal = const ()----- | Test for type equivalence-sameType :: (Typeable a, Typeable b) => TypeVal a -> TypeVal b -> Bool-sameType tva tvb = typeOf (type2val tva) ==-                   typeOf (type2val tvb)----- | Map a value to its type-val2type :: a -> TypeVal a-val2type _ = typeVal----- | Stipulate this idiom!-type2val :: TypeVal a -> a-type2val _ = undefined----- | Constrain a type-withType :: a -> TypeVal a -> a-withType x _ = x----- | The argument type of a function-argType :: (a -> b) -> TypeVal a-argType _ = typeVal----- | The result type of a function-resType :: (a -> b) -> TypeVal b-resType _ = typeVal----- | The parameter type of type constructor-paraType :: t a -> TypeVal a-paraType _ = typeVal----- Type functions,--- i.e., functions mapping types to values----type TypeFun a r = TypeVal a -> r------ Generic type functions,--- i.e., functions mapping types to values----type GTypeFun r  = forall a. Data a => TypeFun a r------ | Extend a type function-extType :: (Data a, Typeable r) => GTypeFun r -> TypeFun a r -> GTypeFun r-extType f x = maybe f id (cast x)----------------------------------------------------------------------------------------	Mapping operators to map over type structure--------------------------------------------------------------------------------------- | Query all constructors of a given type--gmapType :: ([(Constr,r')] -> r)-         -> GTypeFun (Constr -> r')-         -> GTypeFun r--gmapType (o::[(Constr,r')] -> r) f (t::TypeVal a)- = -   o $ zip cons query-- where--  -- All constructors of the given type-  cons :: [Constr]-  cons  = if isAlgType $ dataTypeOf $ type2val t-           then dataTypeConstrs $ dataTypeOf $ type2val t-	   else []--  -- Query constructors-  query :: [r']-  query = map (f t) cons----- | Query all subterm types of a given constructor--gmapConstr :: ([r] -> r')-           -> GTypeFun r-           -> GTypeFun (Constr -> r')--gmapConstr (o::[r] -> r') f (t::TypeVal a) c- = -   o $ query-- where--  -- Term for the given constructor-  term :: a-  term = fromConstr c--  -- Query subterm types-  query ::  [r]-  query = gmapQ (f . val2type) term----- | Compute arity of a given constructor-constrArity :: GTypeFun (Constr -> Int)-constrArity t c = glength $ withType (fromConstr c) t----- | Query all immediate subterm types of a given type-gmapSubtermTypes :: (Data a, Typeable r) -         => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r-gmapSubtermTypes o (r::r) f (t::TypeVal a)-  =-    reduce (concat (map (gmapQ (query . val2type)) terms))-           (GTypeFun' f)-- where--  -- All constructors of the given type-  cons :: [Constr]-  cons  = if isAlgType $ dataTypeOf $ type2val t-           then dataTypeConstrs $ dataTypeOf $ type2val t-           else []--  -- Terms for all constructors-  terms :: [a]-  terms =  map fromConstr cons--  -- Query a subterm type-  query :: Data b => TypeVal b -> GTypeFun' r -> (r,GTypeFun' r)-  query t f = (unGTypeFun' f t, GTypeFun' (disable t (unGTypeFun' f)))--  -- Constant out given type-  disable :: Data b => TypeVal b -> GTypeFun r -> GTypeFun r-  disable (t::TypeVal b) f = f `extType` \(_::TypeVal b) -> r--  -- Reduce all subterm types-  reduce :: [GTypeFun' r -> (r,GTypeFun' r)] -> GTypeFun' r -> r-  reduce [] _ = r-  reduce (xy:z) g = fst (xy g) `o` reduce z (snd (xy g))----- First-class polymorphic variation on GTypeFun-newtype GTypeFun' r = GTypeFun' (GTypeFun r)-unGTypeFun' (GTypeFun' f) = f----- | Query all immediate subterm types.---   There is an extra argument to \"constant out\" the type at hand.---   This can be used to avoid cycles.--gmapSubtermTypesConst :: (Data a, Typeable r)-                      => (r -> r -> r)-                      -> r-                      -> GTypeFun r -                      -> TypeVal a -                      -> r-gmapSubtermTypesConst o (r::r) f (t::TypeVal a)-  =-    gmapSubtermTypes o r f' t-  where-    f' :: GTypeFun r-    f' = f `extType` \(_::TypeVal a) -> r----- Count all distinct subterm types-gcountSubtermTypes :: Data a => TypeVal a -> Int-gcountSubtermTypes = gmapSubtermTypes (+) (0::Int) (const 1)----- | A simplied variation on gmapSubtermTypes.---   Weakness: no awareness of doubles.---   Strength: easy to comprehend as it uses gmapType and gmapConstr.--_gmapSubtermTypes :: (Data a, Typeable r) -                  => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r-_gmapSubtermTypes o (r::r) f-  =-    gmapType otype (gmapConstr oconstr f)-- where--  otype :: [(Constr,r)] -> r-  otype = foldr (\x y -> snd x `o` y) r--  oconstr :: [r] -> r-  oconstr = foldr o r---------------------------------------------------------------------------------------	Some reifying relations on types--------------------------------------------------------------------------------------- | Reachability relation on types, i.e.,---   test if nodes of type @a@ are reachable from nodes of type @b@.---   The relation is defined to be reflexive.--reachableType :: (Data a, Data b) => TypeVal a -> TypeVal b -> Bool-reachableType (a::TypeVal a) (b::TypeVal b)-  =-    or [ sameType a b-       , gmapSubtermTypesConst (\x y -> or [x,y]) False (reachableType a) b-       ]----- | Depth of a datatype as the constructor with the minimum depth.---   The outermost 'Nothing' denotes a type without constructors.---   The innermost 'Nothing' denotes potentially infinite.--depthOfType :: GTypeFun Bool -> GTypeFun (Maybe (Constr, Maybe Int))-depthOfType p (t::TypeVal a)-  = -    gmapType o f t-- where-   -  o :: [(Constr, Maybe Int)] -> Maybe (Constr, Maybe Int)-  o l = if null l then Nothing else Just (foldr1 min' l)--  f :: GTypeFun (Constr -> Maybe Int)-  f = depthOfConstr p'--  -- Specific minimum operator-  min' :: (Constr, Maybe Int) -> (Constr, Maybe Int) -> (Constr, Maybe Int)-  min' x (_, Nothing) = x-  min' (_, Nothing) x = x-  min' (c, Just i) (c', Just i') | i <= i' = (c, Just i)-  min' (c, Just i) (c', Just i')           = (c', Just i')--  -- Updated predicate for unblocked types-  p' :: GTypeFun Bool-  p' = p `extType` \(_::TypeVal a) -> False----- | Depth of a constructor.---   Depth is viewed as the maximum depth of all subterm types + 1.---   'Nothing' denotes potentially infinite.--depthOfConstr :: GTypeFun Bool -> GTypeFun (Constr -> Maybe Int)-depthOfConstr p (t::TypeVal a) c-  =-    gmapConstr o f t c-- where--  o :: [Maybe Int] -> Maybe Int-  o = inc' . foldr max' (Just 0)--  f :: GTypeFun (Maybe Int)-  f t' = if p t'-            then-                 case depthOfType p t' of-                   Nothing     -> Just 0-                   Just (_, x) -> x-            else Nothing--  -- Specific maximum operator-  max' Nothing _ = Nothing-  max' _ Nothing = Nothing-  max' (Just i) (Just i') | i >= i' = Just i-  max' (Just i) (Just i')           = Just i'--  -- Specific increment operator-  inc' Nothing = Nothing-  inc' (Just i) = Just (i+1)---------------------------------------------------------------------------------------	Build a shallow term ------------------------------------------------------------------------------------shallowTerm :: (forall a. Data a => Maybe a) -> (forall b. Data b => b)-shallowTerm cust-  = result-  where-    result :: forall b. Data b => b-	-- Need a type signature here to bring 'b' into scope-    result = maybe gdefault id cust-	 where--	  -- The worker, also used for type disambiguation-	  gdefault :: b-	  gdefault = case con of-	              Just (con, Just _) -> fromConstrB (shallowTerm cust) con-	              _ -> error "no shallow term!"--	  -- The type to be constructed-	  typeVal :: TypeVal b-	  typeVal = val2type gdefault--          -- The most shallow constructor if any -          con :: Maybe (Constr, Maybe Int)-          con = depthOfType (const True) typeVal------ For testing shallowTerm-shallowTermBase :: GenericR Maybe-shallowTermBase =        Nothing -                  `extR` Just (1.23::Float)-                  `extR` Just ("foo"::String)------ Sample datatypes-data T1 = T1a               deriving (Typeable, Data) -- just a constant-data T2 = T2 T1             deriving (Typeable, Data) -- little detour-data T3 = T3a T3 | T3b T2   deriving (Typeable, Data) -- recursive case-data T4 = T4 T3 T3          deriving (Typeable, Data) -- sum matters------ Sample type arguments-t0 = typeVal :: TypeVal Int-t1 = typeVal :: TypeVal T1-t2 = typeVal :: TypeVal T2-t3 = typeVal :: TypeVal T3-t4 = typeVal :: TypeVal T4-tCompany  = typeVal :: TypeVal Company-tPerson   = typeVal :: TypeVal Person-tEmployee = typeVal :: TypeVal Employee-tDept     = typeVal :: TypeVal Dept------ Test cases-test0   = t1 `reachableType` t1 -- True-test1   = t1 `reachableType` t2 -- True-test2   = t2 `reachableType` t1 -- False-test3   = t1 `reachableType` t3-test4   = tPerson `reachableType` tCompany-test5   = gcountSubtermTypes tPerson-test6   = gcountSubtermTypes tEmployee-test7   = gcountSubtermTypes tDept-test8   = shallowTerm shallowTermBase :: Person-test9   = shallowTerm shallowTermBase :: Employee-test10  = shallowTerm shallowTermBase :: Dept----tests = (   test0-        , ( test1-        , ( test2-        , ( test3-        , ( test4-        , ( test5-        , ( test6-        , ( test7-        , ( test8-        , ( test9-        , ( test10-        ))))))))))) ~=? output--output = (True,(True,(False,(True,(True,(1,(2,(3,(P "foo" "foo",-           (E (P "foo" "foo") (S 1.23),-              D "foo" (E (P "foo" "foo") (S 1.23)) []))))))))))+{-# OPTIONS -fglasgow-exts #-}
+
+module Reify (tests) where
+
+{-
+
+The following examples illustrate the reification facilities for type
+structure. Most notably, we generate shallow terms using the depth of
+types and constructors as means to steer the generation.
+
+-}
+
+import Test.HUnit
+
+import Data.Maybe
+import Data.Generics
+import Control.Monad.State
+import CompanyDatatypes
+
+
+
+------------------------------------------------------------------------------
+--
+--	Encoding types as values; some other way.
+--
+------------------------------------------------------------------------------
+
+{- 
+
+This group provides a style of encoding types as values and using
+them. This style is seen as an alternative to the pragmatic style used
+in Data.Typeable.typeOf and elsewhere, i.e., simply use an "undefined"
+to denote a type argument. This pragmatic style suffers from lack
+of robustness: one feels tempted to pattern match on undefineds.
+Maybe Data.Typeable.typeOf etc. should be rewritten accordingly.
+
+-}
+
+
+-- | Type as values to stipulate use of undefineds
+type TypeVal a = a -> ()
+
+
+-- | The value that denotes a type
+typeVal :: TypeVal a
+typeVal = const ()
+
+
+-- | Test for type equivalence
+sameType :: (Typeable a, Typeable b) => TypeVal a -> TypeVal b -> Bool
+sameType tva tvb = typeOf (type2val tva) ==
+                   typeOf (type2val tvb)
+
+
+-- | Map a value to its type
+val2type :: a -> TypeVal a
+val2type _ = typeVal
+
+
+-- | Stipulate this idiom!
+type2val :: TypeVal a -> a
+type2val _ = undefined
+
+
+-- | Constrain a type
+withType :: a -> TypeVal a -> a
+withType x _ = x
+
+
+-- | The argument type of a function
+argType :: (a -> b) -> TypeVal a
+argType _ = typeVal
+
+
+-- | The result type of a function
+resType :: (a -> b) -> TypeVal b
+resType _ = typeVal
+
+
+-- | The parameter type of type constructor
+paraType :: t a -> TypeVal a
+paraType _ = typeVal
+
+
+-- Type functions,
+-- i.e., functions mapping types to values
+--
+type TypeFun a r = TypeVal a -> r
+
+
+
+-- Generic type functions,
+-- i.e., functions mapping types to values
+--
+type GTypeFun r  = forall a. Data a => TypeFun a r
+
+
+
+-- | Extend a type function
+extType :: (Data a, Typeable r) => GTypeFun r -> TypeFun a r -> GTypeFun r
+extType f x = maybe f id (cast x)
+
+
+
+------------------------------------------------------------------------------
+--
+--	Mapping operators to map over type structure
+--
+------------------------------------------------------------------------------
+
+
+-- | Query all constructors of a given type
+
+gmapType :: ([(Constr,r')] -> r)
+         -> GTypeFun (Constr -> r')
+         -> GTypeFun r
+
+gmapType (o::[(Constr,r')] -> r) f (t::TypeVal a)
+ = 
+   o $ zip cons query
+
+ where
+
+  -- All constructors of the given type
+  cons :: [Constr]
+  cons  = if isAlgType $ dataTypeOf $ type2val t
+           then dataTypeConstrs $ dataTypeOf $ type2val t
+	   else []
+
+  -- Query constructors
+  query :: [r']
+  query = map (f t) cons
+
+
+-- | Query all subterm types of a given constructor
+
+gmapConstr :: ([r] -> r')
+           -> GTypeFun r
+           -> GTypeFun (Constr -> r')
+
+gmapConstr (o::[r] -> r') f (t::TypeVal a) c
+ = 
+   o $ query
+
+ where
+
+  -- Term for the given constructor
+  term :: a
+  term = fromConstr c
+
+  -- Query subterm types
+  query ::  [r]
+  query = gmapQ (f . val2type) term
+
+
+-- | Compute arity of a given constructor
+constrArity :: GTypeFun (Constr -> Int)
+constrArity t c = glength $ withType (fromConstr c) t
+
+
+-- | Query all immediate subterm types of a given type
+gmapSubtermTypes :: (Data a, Typeable r) 
+         => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r
+gmapSubtermTypes o (r::r) f (t::TypeVal a)
+  =
+    reduce (concat (map (gmapQ (query . val2type)) terms))
+           (GTypeFun' f)
+
+ where
+
+  -- All constructors of the given type
+  cons :: [Constr]
+  cons  = if isAlgType $ dataTypeOf $ type2val t
+           then dataTypeConstrs $ dataTypeOf $ type2val t
+           else []
+
+  -- Terms for all constructors
+  terms :: [a]
+  terms =  map fromConstr cons
+
+  -- Query a subterm type
+  query :: Data b => TypeVal b -> GTypeFun' r -> (r,GTypeFun' r)
+  query t f = (unGTypeFun' f t, GTypeFun' (disable t (unGTypeFun' f)))
+
+  -- Constant out given type
+  disable :: Data b => TypeVal b -> GTypeFun r -> GTypeFun r
+  disable (t::TypeVal b) f = f `extType` \(_::TypeVal b) -> r
+
+  -- Reduce all subterm types
+  reduce :: [GTypeFun' r -> (r,GTypeFun' r)] -> GTypeFun' r -> r
+  reduce [] _ = r
+  reduce (xy:z) g = fst (xy g) `o` reduce z (snd (xy g))
+
+
+-- First-class polymorphic variation on GTypeFun
+newtype GTypeFun' r = GTypeFun' (GTypeFun r)
+unGTypeFun' (GTypeFun' f) = f
+
+
+-- | Query all immediate subterm types.
+--   There is an extra argument to \"constant out\" the type at hand.
+--   This can be used to avoid cycles.
+
+gmapSubtermTypesConst :: (Data a, Typeable r)
+                      => (r -> r -> r)
+                      -> r
+                      -> GTypeFun r 
+                      -> TypeVal a 
+                      -> r
+gmapSubtermTypesConst o (r::r) f (t::TypeVal a)
+  =
+    gmapSubtermTypes o r f' t
+  where
+    f' :: GTypeFun r
+    f' = f `extType` \(_::TypeVal a) -> r
+
+
+-- Count all distinct subterm types
+gcountSubtermTypes :: Data a => TypeVal a -> Int
+gcountSubtermTypes = gmapSubtermTypes (+) (0::Int) (const 1)
+
+
+-- | A simplied variation on gmapSubtermTypes.
+--   Weakness: no awareness of doubles.
+--   Strength: easy to comprehend as it uses gmapType and gmapConstr.
+
+_gmapSubtermTypes :: (Data a, Typeable r) 
+                  => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r
+_gmapSubtermTypes o (r::r) f
+  =
+    gmapType otype (gmapConstr oconstr f)
+
+ where
+
+  otype :: [(Constr,r)] -> r
+  otype = foldr (\x y -> snd x `o` y) r
+
+  oconstr :: [r] -> r
+  oconstr = foldr o r
+
+
+------------------------------------------------------------------------------
+--
+--	Some reifying relations on types
+--
+------------------------------------------------------------------------------
+
+
+-- | Reachability relation on types, i.e.,
+--   test if nodes of type @a@ are reachable from nodes of type @b@.
+--   The relation is defined to be reflexive.
+
+reachableType :: (Data a, Data b) => TypeVal a -> TypeVal b -> Bool
+reachableType (a::TypeVal a) (b::TypeVal b)
+  =
+    or [ sameType a b
+       , gmapSubtermTypesConst (\x y -> or [x,y]) False (reachableType a) b
+       ]
+
+
+-- | Depth of a datatype as the constructor with the minimum depth.
+--   The outermost 'Nothing' denotes a type without constructors.
+--   The innermost 'Nothing' denotes potentially infinite.
+
+depthOfType :: GTypeFun Bool -> GTypeFun (Maybe (Constr, Maybe Int))
+depthOfType p (t::TypeVal a)
+  = 
+    gmapType o f t
+
+ where
+   
+  o :: [(Constr, Maybe Int)] -> Maybe (Constr, Maybe Int)
+  o l = if null l then Nothing else Just (foldr1 min' l)
+
+  f :: GTypeFun (Constr -> Maybe Int)
+  f = depthOfConstr p'
+
+  -- Specific minimum operator
+  min' :: (Constr, Maybe Int) -> (Constr, Maybe Int) -> (Constr, Maybe Int)
+  min' x (_, Nothing) = x
+  min' (_, Nothing) x = x
+  min' (c, Just i) (c', Just i') | i <= i' = (c, Just i)
+  min' (c, Just i) (c', Just i')           = (c', Just i')
+
+  -- Updated predicate for unblocked types
+  p' :: GTypeFun Bool
+  p' = p `extType` \(_::TypeVal a) -> False
+
+
+-- | Depth of a constructor.
+--   Depth is viewed as the maximum depth of all subterm types + 1.
+--   'Nothing' denotes potentially infinite.
+
+depthOfConstr :: GTypeFun Bool -> GTypeFun (Constr -> Maybe Int)
+depthOfConstr p (t::TypeVal a) c
+  =
+    gmapConstr o f t c
+
+ where
+
+  o :: [Maybe Int] -> Maybe Int
+  o = inc' . foldr max' (Just 0)
+
+  f :: GTypeFun (Maybe Int)
+  f t' = if p t'
+            then
+                 case depthOfType p t' of
+                   Nothing     -> Just 0
+                   Just (_, x) -> x
+            else Nothing
+
+  -- Specific maximum operator
+  max' Nothing _ = Nothing
+  max' _ Nothing = Nothing
+  max' (Just i) (Just i') | i >= i' = Just i
+  max' (Just i) (Just i')           = Just i'
+
+  -- Specific increment operator
+  inc' Nothing = Nothing
+  inc' (Just i) = Just (i+1)
+
+
+------------------------------------------------------------------------------
+--
+--	Build a shallow term 
+--
+------------------------------------------------------------------------------
+
+shallowTerm :: (forall a. Data a => Maybe a) -> (forall b. Data b => b)
+shallowTerm cust
+  = result
+  where
+    result :: forall b. Data b => b
+	-- Need a type signature here to bring 'b' into scope
+    result = maybe gdefault id cust
+	 where
+
+	  -- The worker, also used for type disambiguation
+	  gdefault :: b
+	  gdefault = case con of
+	              Just (con, Just _) -> fromConstrB (shallowTerm cust) con
+	              _ -> error "no shallow term!"
+
+	  -- The type to be constructed
+	  typeVal :: TypeVal b
+	  typeVal = val2type gdefault
+
+          -- The most shallow constructor if any 
+          con :: Maybe (Constr, Maybe Int)
+          con = depthOfType (const True) typeVal
+
+
+
+-- For testing shallowTerm
+shallowTermBase :: GenericR Maybe
+shallowTermBase =        Nothing 
+                  `extR` Just (1.23::Float)
+                  `extR` Just ("foo"::String)
+
+
+
+-- Sample datatypes
+data T1 = T1a               deriving (Typeable, Data) -- just a constant
+data T2 = T2 T1             deriving (Typeable, Data) -- little detour
+data T3 = T3a T3 | T3b T2   deriving (Typeable, Data) -- recursive case
+data T4 = T4 T3 T3          deriving (Typeable, Data) -- sum matters
+
+
+
+-- Sample type arguments
+t0 = typeVal :: TypeVal Int
+t1 = typeVal :: TypeVal T1
+t2 = typeVal :: TypeVal T2
+t3 = typeVal :: TypeVal T3
+t4 = typeVal :: TypeVal T4
+tCompany  = typeVal :: TypeVal Company
+tPerson   = typeVal :: TypeVal Person
+tEmployee = typeVal :: TypeVal Employee
+tDept     = typeVal :: TypeVal Dept
+
+
+
+-- Test cases
+test0   = t1 `reachableType` t1 -- True
+test1   = t1 `reachableType` t2 -- True
+test2   = t2 `reachableType` t1 -- False
+test3   = t1 `reachableType` t3
+test4   = tPerson `reachableType` tCompany
+test5   = gcountSubtermTypes tPerson
+test6   = gcountSubtermTypes tEmployee
+test7   = gcountSubtermTypes tDept
+test8   = shallowTerm shallowTermBase :: Person
+test9   = shallowTerm shallowTermBase :: Employee
+test10  = shallowTerm shallowTermBase :: Dept
+
+
+
+tests = (   test0
+        , ( test1
+        , ( test2
+        , ( test3
+        , ( test4
+        , ( test5
+        , ( test6
+        , ( test7
+        , ( test8
+        , ( test9
+        , ( test10
+        ))))))))))) ~=? output
+
+output = (True,(True,(False,(True,(True,(1,(2,(3,(P "foo" "foo",
+           (E (P "foo" "foo") (S 1.23),
+              D "foo" (E (P "foo" "foo") (S 1.23)) []))))))))))
tests/Strings.hs view
@@ -1,21 +1,21 @@-{-# OPTIONS -fglasgow-exts #-}--module Strings (tests) where--{---This test exercices GENERIC read, show, and eq for the company-datatypes which we use a lot. The output of the program should be-"True" which means that "gread" reads what "gshow" shows while the-read term is equal to the original term in terms of "geq".---}--import Test.HUnit--import Data.Generics-import CompanyDatatypes--tests = (case gread (gshow genCom) of-           [(x,_)] -> geq genCom x-           _ -> False) ~=? True+{-# OPTIONS -fglasgow-exts #-}
+
+module Strings (tests) where
+
+{-
+
+This test exercices GENERIC read, show, and eq for the company
+datatypes which we use a lot. The output of the program should be
+"True" which means that "gread" reads what "gshow" shows while the
+read term is equal to the original term in terms of "geq".
+
+-}
+
+import Test.HUnit
+
+import Data.Generics
+import CompanyDatatypes
+
+tests = (case gread (gshow genCom) of
+           [(x,_)] -> geq genCom x
+           _ -> False) ~=? True
tests/Tree.hs view
@@ -1,62 +1,62 @@-{-# OPTIONS -fglasgow-exts #-}--module Tree (tests) where--{---This example illustrates serialisation and de-serialisation,-but we replace *series* by *trees* so to say.---}--import Test.HUnit--import Control.Monad.Reader-import Data.Generics-import Data.Maybe-import Data.Tree-import CompanyDatatypes----- Trealise Data to Tree-data2tree :: Data a => a -> Tree String-data2tree = gdefault `extQ` atString-  where-    atString (x::String) = Node x []-    gdefault x = Node (showConstr (toConstr x)) (gmapQ data2tree x)----- De-trealise Tree to Data-tree2data :: Data a => Tree String -> Maybe a-tree2data = gdefault `extR` atString-  where-    atString (Node x []) = Just x-    gdefault (Node x ts) = res-      where--	-- a helper for type capture-        res  = maybe Nothing (kids . fromConstr) con--	-- the type to constructed-        ta   = fromJust res--	-- construct constructor-        con  = readConstr (dataTypeOf ta) x--        -- recursion per kid with accumulation-        perkid ts = const (tail ts, tree2data (head ts)) --        -- recurse into kids-        kids x =-          do guard (glength x == length ts)-             snd (gmapAccumM perkid ts x)----- Main function for testing-tests = (   genCom-        , ( data2tree genCom -        , ( (tree2data (data2tree genCom)) :: Maybe Company -        , ( Just genCom == tree2data (data2tree genCom)-        )))) ~=? output--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)) []],(Node {rootLabel = "C", subForest = [Node {rootLabel = "(:)", subForest = [Node {rootLabel = "D", subForest = [Node {rootLabel = "Research", subForest = []},Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Laemmel", subForest = []},Node {rootLabel = "Amsterdam", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "8000.0", subForest = []}]}]},Node {rootLabel = "(:)", subForest = [Node {rootLabel = "PU", subForest = [Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Joost", subForest = []},Node {rootLabel = "Amsterdam", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "1000.0", subForest = []}]}]}]},Node {rootLabel = "(:)", subForest = [Node {rootLabel = "PU", subForest = [Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Marlow", subForest = []},Node {rootLabel = "Cambridge", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "2000.0", subForest = []}]}]}]},Node {rootLabel = "[]", subForest = []}]}]}]},Node {rootLabel = "(:)", subForest = [Node {rootLabel = "D", subForest = [Node {rootLabel = "Strategy", subForest = []},Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Blair", subForest = []},Node {rootLabel = "London", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "100000.0", subForest = []}]}]},Node {rootLabel = "[]", subForest = []}]},Node {rootLabel = "[]", subForest = []}]}]}]},(Just (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)) []]),True)))+{-# OPTIONS -fglasgow-exts #-}
+
+module Tree (tests) where
+
+{-
+
+This example illustrates serialisation and de-serialisation,
+but we replace *series* by *trees* so to say.
+
+-}
+
+import Test.HUnit
+
+import Control.Monad.Reader
+import Data.Generics
+import Data.Maybe
+import Data.Tree
+import CompanyDatatypes
+
+
+-- Trealise Data to Tree
+data2tree :: Data a => a -> Tree String
+data2tree = gdefault `extQ` atString
+  where
+    atString (x::String) = Node x []
+    gdefault x = Node (showConstr (toConstr x)) (gmapQ data2tree x)
+
+
+-- De-trealise Tree to Data
+tree2data :: Data a => Tree String -> Maybe a
+tree2data = gdefault `extR` atString
+  where
+    atString (Node x []) = Just x
+    gdefault (Node x ts) = res
+      where
+
+	-- a helper for type capture
+        res  = maybe Nothing (kids . fromConstr) con
+
+	-- the type to constructed
+        ta   = fromJust res
+
+	-- construct constructor
+        con  = readConstr (dataTypeOf ta) x
+
+        -- recursion per kid with accumulation
+        perkid ts = const (tail ts, tree2data (head ts)) 
+
+        -- recurse into kids
+        kids x =
+          do guard (glength x == length ts)
+             snd (gmapAccumM perkid ts x)
+
+
+-- Main function for testing
+tests = (   genCom
+        , ( data2tree genCom 
+        , ( (tree2data (data2tree genCom)) :: Maybe Company 
+        , ( Just genCom == tree2data (data2tree genCom)
+        )))) ~=? output
+
+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)) []],(Node {rootLabel = "C", subForest = [Node {rootLabel = "(:)", subForest = [Node {rootLabel = "D", subForest = [Node {rootLabel = "Research", subForest = []},Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Laemmel", subForest = []},Node {rootLabel = "Amsterdam", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "8000.0", subForest = []}]}]},Node {rootLabel = "(:)", subForest = [Node {rootLabel = "PU", subForest = [Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Joost", subForest = []},Node {rootLabel = "Amsterdam", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "1000.0", subForest = []}]}]}]},Node {rootLabel = "(:)", subForest = [Node {rootLabel = "PU", subForest = [Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Marlow", subForest = []},Node {rootLabel = "Cambridge", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "2000.0", subForest = []}]}]}]},Node {rootLabel = "[]", subForest = []}]}]}]},Node {rootLabel = "(:)", subForest = [Node {rootLabel = "D", subForest = [Node {rootLabel = "Strategy", subForest = []},Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Blair", subForest = []},Node {rootLabel = "London", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "100000.0", subForest = []}]}]},Node {rootLabel = "[]", subForest = []}]},Node {rootLabel = "[]", subForest = []}]}]}]},(Just (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)) []]),True)))
+ 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/Typeable.hs view
@@ -1,19 +1,19 @@-{-# OPTIONS -fglasgow-exts #-}--module Typeable (tests) where--import Test.HUnit--import Data.Typeable--newtype Y e = Y { unY :: (e (Y e)) } --instance Typeable1 e => Typeable (Y e) where-   typeOf _ = mkTyConApp yTc [typeOf1 (undefined :: e ())]--yTc :: TyCon-yTc = mkTyCon "Typeable.Y"--tests = show (typeOf (undefined :: Y [])) ~=? output--output = "Typeable.Y []"+{-# OPTIONS -fglasgow-exts #-}
+
+module Typeable (tests) where
+
+import Test.HUnit
+
+import Data.Typeable
+
+newtype Y e = Y { unY :: (e (Y e)) } 
+
+instance Typeable1 e => Typeable (Y e) where
+   typeOf _ = mkTyConApp yTc [typeOf1 (undefined :: e ())]
+
+yTc :: TyCon
+yTc = mkTyCon "Typeable.Y"
+
+tests = show (typeOf (undefined :: Y [])) ~=? output
+
+output = "Typeable.Y []"
+ 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)))))))"
tests/XML.hs view
@@ -1,195 +1,195 @@-{-# OPTIONS -fglasgow-exts #-}--module XML (tests) where--{---This example illustrates XMLish services-to trealise (say, "serialise") heterogenous-Haskell data as homogeneous tree structures-(say, XMLish elements) and vice versa.---}--import Test.HUnit--import Control.Monad-import Data.Maybe-import Data.Generics-import CompanyDatatypes----- HaXml-like types for XML elements-data Element   = Elem Name [Attribute] [Content]-                 deriving (Show, Eq, Typeable, Data)--data Content   = CElem Element-               | CString Bool CharData-                        -- ^ bool is whether whitespace is significant-               | CRef Reference-               | CMisc Misc-                 deriving (Show, Eq, Typeable, Data)--type CharData = String----- In this simple example we disable some parts of XML-type Attribute = ()-type Reference = ()-type Misc      = ()----- Trealisation-data2content :: Data a => a -> [Content]-data2content =         element-               `ext1Q` list-               `extQ`  string -               `extQ`  float-- where--  -- Handle an element-  element x = [CElem (Elem (tyconUQname (dataTypeName (dataTypeOf x)))-                           [] -- no attributes -                           (concat (gmapQ data2content x)))]--  -- A special case for lists-  list :: Data a => [a] -> [Content]-  list = concat . map data2content--  -- A special case for strings-  string :: String -> [Content]-  string x = [CString True x]--  -- A special case for floats-  float :: Float -> [Content]-  float x = [CString True (show x)]----- De-trealisation-content2data :: forall a. Data a => ReadX a-content2data = result-- where- -  -- Case-discriminating worker-  result =         element-           `ext1R` list-           `extR`  string-           `extR`  float---  -- Determine type of data to be constructed-  myType = myTypeOf result-    where-      myTypeOf :: forall a. ReadX a -> a-      myTypeOf =  undefined--  -- Handle an element-  element = do c <- readX-               case c of-                 (CElem (Elem x as cs))-                    |    as == [] -- no attributes-                      && x  == (tyconUQname (dataTypeName (dataTypeOf myType)))-                   -> alts cs-                 _ -> mzero---  -- A special case for lists-  list :: forall a. Data a => ReadX [a]-  list =          ( do h <- content2data-                       t <- list-                       return (h:t) )-         `mplus`  return []--  -- Fold over all alternatives, say constructors-  alts cs = foldr (mplus . recurse cs) mzero shapes--  -- Possible top-level shapes-  shapes = map fromConstr consOf--  -- Retrieve all constructors of the requested type-  consOf = dataTypeConstrs-         $ dataTypeOf -         $ myType--  -- Recurse into subterms-  recurse cs x = maybe mzero-                       return-                       (runReadX (gmapM (const content2data) x) cs)--  -- A special case for strings-  string :: ReadX String-  string =  do c <- readX-               case c of-                 (CString _ x) -> return x-                 _             -> mzero--  -- A special case for floats-  float :: ReadX Float-  float =  do c <- readX-              case c of-                (CString _ x) -> return (read x)-                _             -> mzero--------------------------------------------------------------------------------------- An XML-hungry parser-like monad------------------------------------------------------------------------------------- Type constructor-newtype ReadX a =-        ReadX { unReadX :: [Content]-                        -> Maybe ([Content], a) }---- Run a computation-runReadX x y = case unReadX x y of -                 Just ([],y) -> Just y-                 _           -> Nothing---- Read one content particle-readX :: ReadX Content-readX =  ReadX (\x -> if null x -                        then Nothing-                        else Just (tail x, head x)-               )---- ReadX is a monad!-instance Monad ReadX where-  return x = ReadX (\y -> Just (y,x))-  c >>= f  = ReadX (\x -> case unReadX c x of-                            Nothing -> Nothing-                            Just (x', a) -> unReadX (f a) x'-                   )---- ReadX also accommodates mzero and mplus!-instance MonadPlus ReadX where-  mzero = ReadX (const Nothing)-  f `mplus` g = ReadX (\x -> case unReadX f x of-                               Nothing -> unReadX g x-                               y -> y-                      )---------------------------------------------------------------------------------------	Main function for testing-----------------------------------------------------------------------------------tests = (   genCom-        , ( data2content genCom-        , ( zigzag person1 :: Maybe Person-        , ( zigzag genCom  :: Maybe Company-        , ( zigzag genCom == Just genCom-        ))))) ~=? output- where -  -- Trealise back and forth-  zigzag :: Data a => a -> Maybe a-  zigzag = runReadX content2data . data2content--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)) []],([CElem (Elem "Company" [] [CElem (Elem "Dept" [] [CString True "Research",CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Laemmel",CString True "Amsterdam"]),CElem (Elem "Salary" [] [CString True "8000.0"])]),CElem (Elem "Unit" [] [CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Joost",CString True "Amsterdam"]),CElem (Elem "Salary" [] [CString True "1000.0"])])]),CElem (Elem "Unit" [] [CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Marlow",CString True "Cambridge"]),CElem (Elem "Salary" [] [CString True "2000.0"])])])]),CElem (Elem "Dept" [] [CString True "Strategy",CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Blair",CString True "London"]),CElem (Elem "Salary" [] [CString True "100000.0"])])])])],(Just (P "Lazy" "Home"),(Just (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)) []]),True))))+{-# OPTIONS -fglasgow-exts #-}
+
+module XML (tests) where
+
+{-
+
+This example illustrates XMLish services
+to trealise (say, "serialise") heterogenous
+Haskell data as homogeneous tree structures
+(say, XMLish elements) and vice versa.
+
+-}
+
+import Test.HUnit
+
+import Control.Monad
+import Data.Maybe
+import Data.Generics
+import CompanyDatatypes
+
+
+-- HaXml-like types for XML elements
+data Element   = Elem Name [Attribute] [Content]
+                 deriving (Show, Eq, Typeable, Data)
+
+data Content   = CElem Element
+               | CString Bool CharData
+                        -- ^ bool is whether whitespace is significant
+               | CRef Reference
+               | CMisc Misc
+                 deriving (Show, Eq, Typeable, Data)
+
+type CharData = String
+
+
+-- In this simple example we disable some parts of XML
+type Attribute = ()
+type Reference = ()
+type Misc      = ()
+
+
+-- Trealisation
+data2content :: Data a => a -> [Content]
+data2content =         element
+               `ext1Q` list
+               `extQ`  string 
+               `extQ`  float
+
+ where
+
+  -- Handle an element
+  element x = [CElem (Elem (tyconUQname (dataTypeName (dataTypeOf x)))
+                           [] -- no attributes 
+                           (concat (gmapQ data2content x)))]
+
+  -- A special case for lists
+  list :: Data a => [a] -> [Content]
+  list = concat . map data2content
+
+  -- A special case for strings
+  string :: String -> [Content]
+  string x = [CString True x]
+
+  -- A special case for floats
+  float :: Float -> [Content]
+  float x = [CString True (show x)]
+
+
+-- De-trealisation
+content2data :: forall a. Data a => ReadX a
+content2data = result
+
+ where
+ 
+  -- Case-discriminating worker
+  result =         element
+           `ext1R` list
+           `extR`  string
+           `extR`  float
+
+
+  -- Determine type of data to be constructed
+  myType = myTypeOf result
+    where
+      myTypeOf :: forall a. ReadX a -> a
+      myTypeOf =  undefined
+
+  -- Handle an element
+  element = do c <- readX
+               case c of
+                 (CElem (Elem x as cs))
+                    |    as == [] -- no attributes
+                      && x  == (tyconUQname (dataTypeName (dataTypeOf myType)))
+                   -> alts cs
+                 _ -> mzero
+
+
+  -- A special case for lists
+  list :: forall a. Data a => ReadX [a]
+  list =          ( do h <- content2data
+                       t <- list
+                       return (h:t) )
+         `mplus`  return []
+
+  -- Fold over all alternatives, say constructors
+  alts cs = foldr (mplus . recurse cs) mzero shapes
+
+  -- Possible top-level shapes
+  shapes = map fromConstr consOf
+
+  -- Retrieve all constructors of the requested type
+  consOf = dataTypeConstrs
+         $ dataTypeOf 
+         $ myType
+
+  -- Recurse into subterms
+  recurse cs x = maybe mzero
+                       return
+                       (runReadX (gmapM (const content2data) x) cs)
+
+  -- A special case for strings
+  string :: ReadX String
+  string =  do c <- readX
+               case c of
+                 (CString _ x) -> return x
+                 _             -> mzero
+
+  -- A special case for floats
+  float :: ReadX Float
+  float =  do c <- readX
+              case c of
+                (CString _ x) -> return (read x)
+                _             -> mzero
+
+
+
+-----------------------------------------------------------------------------
+--
+-- An XML-hungry parser-like monad
+--
+-----------------------------------------------------------------------------
+
+-- Type constructor
+newtype ReadX a =
+        ReadX { unReadX :: [Content]
+                        -> Maybe ([Content], a) }
+
+-- Run a computation
+runReadX x y = case unReadX x y of 
+                 Just ([],y) -> Just y
+                 _           -> Nothing
+
+-- Read one content particle
+readX :: ReadX Content
+readX =  ReadX (\x -> if null x 
+                        then Nothing
+                        else Just (tail x, head x)
+               )
+
+-- ReadX is a monad!
+instance Monad ReadX where
+  return x = ReadX (\y -> Just (y,x))
+  c >>= f  = ReadX (\x -> case unReadX c x of
+                            Nothing -> Nothing
+                            Just (x', a) -> unReadX (f a) x'
+                   )
+
+-- ReadX also accommodates mzero and mplus!
+instance MonadPlus ReadX where
+  mzero = ReadX (const Nothing)
+  f `mplus` g = ReadX (\x -> case unReadX f x of
+                               Nothing -> unReadX g x
+                               y -> y
+                      )
+
+
+
+-----------------------------------------------------------------------------
+--
+--	Main function for testing
+--
+-----------------------------------------------------------------------------
+
+tests = (   genCom
+        , ( data2content genCom
+        , ( zigzag person1 :: Maybe Person
+        , ( zigzag genCom  :: Maybe Company
+        , ( zigzag genCom == Just genCom
+        ))))) ~=? output
+ where 
+  -- Trealise back and forth
+  zigzag :: Data a => a -> Maybe a
+  zigzag = runReadX content2data . data2content
+
+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)) []],([CElem (Elem "Company" [] [CElem (Elem "Dept" [] [CString True "Research",CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Laemmel",CString True "Amsterdam"]),CElem (Elem "Salary" [] [CString True "8000.0"])]),CElem (Elem "Unit" [] [CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Joost",CString True "Amsterdam"]),CElem (Elem "Salary" [] [CString True "1000.0"])])]),CElem (Elem "Unit" [] [CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Marlow",CString True "Cambridge"]),CElem (Elem "Salary" [] [CString True "2000.0"])])])]),CElem (Elem "Dept" [] [CString True "Strategy",CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Blair",CString True "London"]),CElem (Elem "Salary" [] [CString True "100000.0"])])])])],(Just (P "Lazy" "Home"),(Just (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)) []]),True))))
− 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/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/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/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)))))))"