diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,5 @@ +2019-06-15 Sergey Vinokurov + + * 0.7.1: Define recursive traversals in two parts, non-recursive + wrapper and recursive local helper to facilitate inlining and + avoid passing the same argument to all recursive calls diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. + +----------------------------------------------------------------------------- diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,43 +0,0 @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +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: + + https://github.com/dreixel/syb/issues + +For discussion about the library with the authors, maintainers, and other +interested persons use the mailing list: + + http://www.haskell.org/mailman/listinfo/generics diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,3 +1,3 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/src/Data/Generics.hs b/src/Data/Generics.hs --- a/src/Data/Generics.hs +++ b/src/Data/Generics.hs @@ -1,39 +1,39 @@ -{-# LANGUAGE 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 . 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 +{-# LANGUAGE 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 . 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 diff --git a/src/Data/Generics/Aliases.hs b/src/Data/Generics/Aliases.hs --- a/src/Data/Generics/Aliases.hs +++ b/src/Data/Generics/Aliases.hs @@ -1,439 +1,439 @@ -{-# LANGUAGE RankNTypes, CPP #-} ------------------------------------------------------------------------------ --- | --- 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 . --- 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 ------------------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ >= 707 -#define Typeable1 Typeable -#define Typeable2 Typeable -#endif - --- | 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} +{-# LANGUAGE RankNTypes, CPP #-} +----------------------------------------------------------------------------- +-- | +-- 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 . +-- 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 +------------------------------------------------------------------------------ + +#if __GLASGOW_HASKELL__ >= 707 +#define Typeable1 Typeable +#define Typeable2 Typeable +#endif + +-- | 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} diff --git a/src/Data/Generics/Basics.hs b/src/Data/Generics/Basics.hs --- a/src/Data/Generics/Basics.hs +++ b/src/Data/Generics/Basics.hs @@ -1,23 +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 . 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 +----------------------------------------------------------------------------- +-- | +-- 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 . 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 diff --git a/src/Data/Generics/Instances.hs b/src/Data/Generics/Instances.hs --- a/src/Data/Generics/Instances.hs +++ b/src/Data/Generics/Instances.hs @@ -1,190 +1,190 @@ -{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, CPP #-} ------------------------------------------------------------------------------ --- | --- 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 . 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 - --- 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) ------------------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ < 801 -instance Data TypeRep where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = myMkNoRepType "Data.Typeable.TypeRep" -#endif - - ------------------------------------------------------------------------------- - -instance Data TyCon where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = myMkNoRepType "Data.Typeable.TyCon" - - ------------------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ < 709 -deriving instance Typeable DataType -#endif - -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 - +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, CPP #-} +----------------------------------------------------------------------------- +-- | +-- 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 . 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 + +-- 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) +------------------------------------------------------------------------------ + +#if __GLASGOW_HASKELL__ < 801 +instance Data TypeRep where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = myMkNoRepType "Data.Typeable.TypeRep" +#endif + + +------------------------------------------------------------------------------ + +instance Data TyCon where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = myMkNoRepType "Data.Typeable.TyCon" + + +------------------------------------------------------------------------------ +#if __GLASGOW_HASKELL__ < 709 +deriving instance Typeable DataType +#endif + +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 + diff --git a/src/Data/Generics/Schemes.hs b/src/Data/Generics/Schemes.hs --- a/src/Data/Generics/Schemes.hs +++ b/src/Data/Generics/Schemes.hs @@ -1,182 +1,208 @@ -{-# LANGUAGE RankNTypes, ScopedTypeVariables, CPP #-} ------------------------------------------------------------------------------ --- | --- 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 . The present module --- provides frequently used generic traversal schemes. --- ------------------------------------------------------------------------------ - -module Data.Generics.Schemes ( - - everywhere, - everywhere', - everywhereBut, - everywhereM, - somewhere, - everything, - everythingBut, - everythingWithContext, - 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) - --- | Summarise all nodes in top-down, left-to-right order, carrying some state --- down the tree during the computation, but not left-to-right to siblings. -everythingWithContext :: s -> (r -> r -> r) -> GenericQ (s -> (r, s)) -> GenericQ r -everythingWithContext s0 f q x = - foldl f r (gmapQ (everythingWithContext s' f q) x) - where (r, s') = q x s0 - --- | 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 +{-# LANGUAGE RankNTypes, ScopedTypeVariables, CPP #-} +----------------------------------------------------------------------------- +-- | +-- 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 . The present module +-- provides frequently used generic traversal schemes. +-- +----------------------------------------------------------------------------- + +module Data.Generics.Schemes ( + + everywhere, + everywhere', + everywhereBut, + everywhereM, + somewhere, + everything, + everythingBut, + everythingWithContext, + 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 = go + where + go :: forall a. Data a => a -> a + go = f . gmapT go + +-- | 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 = go + where + go :: forall a. Data a => a -> a + go = gmapT go . 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 = go + where + go :: GenericT + go x + | q x = x + | otherwise = f (gmapT go x) + + +-- | Monadic variation on everywhere +everywhereM :: forall m. Monad m => GenericM m -> GenericM m + +-- Bottom-up order is also reflected in order of do-actions +everywhereM f = go + where + go :: GenericM m + go x = do + x' <- gmapM go x + f x' + + +-- | Apply a monadic transformation at least somewhere +somewhere :: forall m. 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 = go + where + go :: GenericM m + go x = f x `mplus` gmapMp go x + + +-- | Summarise all nodes in top-down, left-to-right order +everything :: forall r. (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 = go + where + go :: GenericQ r + go x = foldl k (f x) (gmapQ go x) + +-- | Variation of "everything" with an added stop condition +everythingBut :: forall r. (r -> r -> r) -> GenericQ (r, Bool) -> GenericQ r +everythingBut k f = go + where + go :: GenericQ r + go x = let (v, stop) = f x + in if stop + then v + else foldl k v (gmapQ go x) + +-- | Summarise all nodes in top-down, left-to-right order, carrying some state +-- down the tree during the computation, but not left-to-right to siblings. +everythingWithContext :: forall s r. s -> (r -> r -> r) -> GenericQ (s -> (r, s)) -> GenericQ r +everythingWithContext s0 f q = go s0 + where + go :: s -> GenericQ r + go s x = foldl f r (gmapQ (go s') x) + where (r, s') = q x s + +-- | 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 :: forall s t. s -> (t -> s -> s) -> GenericQ (s -> t) -> GenericQ t +synthesize z o f = go + where + go :: GenericQ t + go x = f x (foldr o z (gmapQ go 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 diff --git a/src/Data/Generics/Text.hs b/src/Data/Generics/Text.hs --- a/src/Data/Generics/Text.hs +++ b/src/Data/Generics/Text.hs @@ -1,131 +1,131 @@ -{-# LANGUAGE 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 . 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 -import Text.Read.Lex - ------------------------------------------------------------------------------- - - --- | 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 - <++ hsLex -- 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] +{-# LANGUAGE 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 . 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 +import Text.Read.Lex + +------------------------------------------------------------------------------ + + +-- | 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 + <++ hsLex -- 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] diff --git a/src/Data/Generics/Twins.hs b/src/Data/Generics/Twins.hs --- a/src/Data/Generics/Twins.hs +++ b/src/Data/Generics/Twins.hs @@ -1,291 +1,294 @@ -{-# LANGUAGE RankNTypes, ScopedTypeVariables, CPP #-} ------------------------------------------------------------------------------ --- | --- 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 . 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, - gcompare - - ) where - - ------------------------------------------------------------------------------- - -#ifdef __HADDOCK__ -import Prelude -#endif -import Data.Data -import Data.Generics.Aliases - -#ifdef __GLASGOW_HASKELL__ -import Prelude hiding ( GT ) -#endif - -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative (Applicative(..)) -import Data.Monoid ( mappend, mconcat ) -#endif - ------------------------------------------------------------------------------- - - ------------------------------------------------------------------------------- --- --- 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 - --- | Generic comparison: an alternative to \"deriving Ord\" -gcompare :: Data a => a -> a -> Ordering -gcompare = gcompare' - where - gcompare' :: (Data a, Data b) => a -> b -> Ordering - gcompare' x y - = let repX = constrRep $ toConstr x - repY = constrRep $ toConstr y - in - case (repX, repY) of - (AlgConstr nX, AlgConstr nY) -> - nX `compare` nY `mappend` mconcat (gzipWithQ gcompare' x y) - (IntConstr iX, IntConstr iY) -> iX `compare` iY - (FloatConstr rX, FloatConstr rY) -> rX `compare` rY - (CharConstr cX, CharConstr cY) -> cX `compare` cY - _ -> error "type incompatibility in gcompare" +{-# LANGUAGE RankNTypes, ScopedTypeVariables, CPP #-} +----------------------------------------------------------------------------- +-- | +-- 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 . 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, + gcompare + + ) where + + +------------------------------------------------------------------------------ + +#ifdef __HADDOCK__ +import Prelude +#endif +import Data.Data +import Data.Generics.Aliases + +#ifdef __GLASGOW_HASKELL__ +import Prelude hiding ( GT ) +#endif + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative (Applicative(..)) +import Data.Monoid ( mappend, mconcat ) +#endif + +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +-- +-- 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 = go + where + go :: GenericQ (GenericM Maybe) + go x y = + f x y + `orElse` + if toConstr x == toConstr y + then gzipWithM go x y + else Nothing + +-- | Generic comparison: an alternative to \"deriving Ord\" +gcompare :: Data a => a -> a -> Ordering +gcompare = gcompare' + where + gcompare' :: (Data a, Data b) => a -> b -> Ordering + gcompare' x y + = let repX = constrRep $ toConstr x + repY = constrRep $ toConstr y + in + case (repX, repY) of + (AlgConstr nX, AlgConstr nY) -> + nX `compare` nY `mappend` mconcat (gzipWithQ gcompare' x y) + (IntConstr iX, IntConstr iY) -> iX `compare` iY + (FloatConstr rX, FloatConstr rY) -> rX `compare` rY + (CharConstr cX, CharConstr cY) -> cX `compare` cY + _ -> error "type incompatibility in gcompare" diff --git a/src/Generics/SYB.hs b/src/Generics/SYB.hs --- a/src/Generics/SYB.hs +++ b/src/Generics/SYB.hs @@ -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 diff --git a/src/Generics/SYB/Aliases.hs b/src/Generics/SYB/Aliases.hs --- a/src/Generics/SYB/Aliases.hs +++ b/src/Generics/SYB/Aliases.hs @@ -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 diff --git a/src/Generics/SYB/Basics.hs b/src/Generics/SYB/Basics.hs --- a/src/Generics/SYB/Basics.hs +++ b/src/Generics/SYB/Basics.hs @@ -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 diff --git a/src/Generics/SYB/Builders.hs b/src/Generics/SYB/Builders.hs --- a/src/Generics/SYB/Builders.hs +++ b/src/Generics/SYB/Builders.hs @@ -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 diff --git a/src/Generics/SYB/Instances.hs b/src/Generics/SYB/Instances.hs --- a/src/Generics/SYB/Instances.hs +++ b/src/Generics/SYB/Instances.hs @@ -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 () diff --git a/src/Generics/SYB/Schemes.hs b/src/Generics/SYB/Schemes.hs --- a/src/Generics/SYB/Schemes.hs +++ b/src/Generics/SYB/Schemes.hs @@ -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 diff --git a/src/Generics/SYB/Text.hs b/src/Generics/SYB/Text.hs --- a/src/Generics/SYB/Text.hs +++ b/src/Generics/SYB/Text.hs @@ -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 diff --git a/src/Generics/SYB/Twins.hs b/src/Generics/SYB/Twins.hs --- a/src/Generics/SYB/Twins.hs +++ b/src/Generics/SYB/Twins.hs @@ -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 diff --git a/syb.cabal b/syb.cabal --- a/syb.cabal +++ b/syb.cabal @@ -1,65 +1,66 @@ -name: syb -version: 0.7 -license: BSD3 -license-file: LICENSE -author: Ralf Lammel, Simon Peyton Jones, Jose Pedro Magalhaes -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 - ). - 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: Simple -cabal-version: >= 1.8 -tested-with: GHC >=7.0 && <=7.10.2, GHC==7.11.* - -extra-source-files: tests/*.hs, - README - -source-repository head - type: git - location: https://github.com/dreixel/syb - -Library - hs-source-dirs: src - build-depends: base >= 4.0 && < 5.0 - 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 - - if impl(ghc < 6.12) - ghc-options: -package-name syb - - ghc-options: -Wall - -test-suite unit-tests - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: Main.hs - build-depends: base - , syb - , HUnit - , containers - , mtl +name: syb +version: 0.7.1 +license: BSD3 +license-file: LICENSE +author: Ralf Lammel, Simon Peyton Jones, Jose Pedro Magalhaes +maintainer: Sergey Vinokurov +homepage: http://www.cs.uu.nl/wiki/GenericProgramming/SYB +bug-reports: https://github.com/dreixel/syb/issues +synopsis: Scrap Your Boilerplate +description: + This package contains the generics system described in the + /Scrap Your Boilerplate/ papers (see + ). + 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: Simple +cabal-version: >= 1.8 +tested-with: GHC >=7.0 && <=7.10.2, GHC==7.11.*, GHC==8.0, GHC==8.2, GHC==8.4.4, GHC==8.6.5 + +extra-source-files: tests/*.hs, + README.md, + ChangeLog + +source-repository head + type: git + location: https://github.com/dreixel/syb + +Library + hs-source-dirs: src + build-depends: base >= 4.0 && < 5.0 + 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 + + if impl(ghc < 6.12) + ghc-options: -package-name syb + + ghc-options: -Wall + +test-suite unit-tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Main.hs + build-depends: base + , syb + , HUnit + , containers + , mtl diff --git a/tests/Bits.hs b/tests/Bits.hs --- a/tests/Bits.hs +++ b/tests/Bits.hs @@ -1,225 +1,225 @@ -{-# 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 Data.Maybe -import Control.Applicative (Alternative(..), Applicative(..)) -import Control.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 - -instance Functor ReadB where - fmap = liftM - -instance Applicative ReadB where - pure = return - (<*>) = ap - -instance Alternative ReadB where - (<|>) = mplus - empty = mzero - --- 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 Data.Maybe +import Control.Applicative (Alternative(..), Applicative(..)) +import Control.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 + +instance Functor ReadB where + fmap = liftM + +instance Applicative ReadB where + pure = return + (<*>) = ap + +instance Alternative ReadB where + (<|>) = mplus + empty = mzero + +-- 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))))) diff --git a/tests/Builders.hs b/tests/Builders.hs --- a/tests/Builders.hs +++ b/tests/Builders.hs @@ -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)]) diff --git a/tests/CompanyDatatypes.hs b/tests/CompanyDatatypes.hs --- a/tests/CompanyDatatypes.hs +++ b/tests/CompanyDatatypes.hs @@ -1,39 +1,39 @@ -{-# 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, marlow, 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, marlow, 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) [] diff --git a/tests/Datatype.hs b/tests/Datatype.hs --- a/tests/Datatype.hs +++ b/tests/Datatype.hs @@ -1,55 +1,55 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS -fglasgow-exts #-} - --- These are simple tests to observe (data)type representations. -module Datatype where - -import Test.HUnit - -import Data.Tree -import Data.Generics - --- A simple polymorphic datatype -data MyDataType a = MyDataType a - deriving (Typeable, Data) - - --- Some terms and corresponding type representations -myTerm = undefined :: MyDataType Int -myTypeRep = typeOf myTerm -- type representation in Typeable -myDataType = dataTypeOf myTerm -- datatype representation in Data - -#if MIN_VERSION_base(4,5,0) -myTyCon = typeRepTyCon myTypeRep -- type constructor via Typeable -myString1 = tyConName 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 - -#if __GLASGOW_HASKELL__ >= 709 --- In GHC 7.10 module name is stripped from DataType -output = "(MyDataType Int,(DataType {tycon = \"MyDataType\", datarep = AlgRep [MyDataType]},(\"\",(\"MyDataType\",(\"\",\"MyDataType\")))))" -#else -output = "(MyDataType Int,(DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]},(\"\",(\"MyDataType\",(\"Datatype\",\"MyDataType\")))))" -#endif - -#else - -tests = show ( myTypeRep, myDataType ) - ~?= output - -#if __GLASGOW_HASKELL__ >= 701 -output = "(MyDataType Int,DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]})" -#else -output = "(Datatype.MyDataType Int,DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]})" -#endif - -#endif +{-# LANGUAGE CPP #-} +{-# OPTIONS -fglasgow-exts #-} + +-- These are simple tests to observe (data)type representations. +module Datatype where + +import Test.HUnit + +import Data.Tree +import Data.Generics + +-- A simple polymorphic datatype +data MyDataType a = MyDataType a + deriving (Typeable, Data) + + +-- Some terms and corresponding type representations +myTerm = undefined :: MyDataType Int +myTypeRep = typeOf myTerm -- type representation in Typeable +myDataType = dataTypeOf myTerm -- datatype representation in Data + +#if MIN_VERSION_base(4,5,0) +myTyCon = typeRepTyCon myTypeRep -- type constructor via Typeable +myString1 = tyConName 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 + +#if __GLASGOW_HASKELL__ >= 709 +-- In GHC 7.10 module name is stripped from DataType +output = "(MyDataType Int,(DataType {tycon = \"MyDataType\", datarep = AlgRep [MyDataType]},(\"\",(\"MyDataType\",(\"\",\"MyDataType\")))))" +#else +output = "(MyDataType Int,(DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]},(\"\",(\"MyDataType\",(\"Datatype\",\"MyDataType\")))))" +#endif + +#else + +tests = show ( myTypeRep, myDataType ) + ~?= output + +#if __GLASGOW_HASKELL__ >= 701 +output = "(MyDataType Int,DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]})" +#else +output = "(Datatype.MyDataType Int,DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]})" +#endif + +#endif diff --git a/tests/Encode.hs b/tests/Encode.hs --- a/tests/Encode.hs +++ b/tests/Encode.hs @@ -1,88 +1,88 @@ -{-# 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 Control.Applicative (Applicative(..)) -import Control.Monad (ap, liftM) -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 Functor EncM where - fmap = liftM -instance Applicative EncM where - pure = return - (<*>) = ap -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) } +{-# 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 Control.Applicative (Applicative(..)) +import Control.Monad (ap, liftM) +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 Functor EncM where + fmap = liftM +instance Applicative EncM where + pure = return + (<*>) = ap +instance Monad EncM + where + return = undefined + c >>= f = undefined + +runEnc :: EncM () -> [Bit] +emitCon :: DataType -> Constr -> EncM () + +runEnc = undefined +emitCon = undefined + +data2bits'' :: Data a => a -> [Bit] +data2bits'' t = runEnc (emit t) + +emit :: Data a => a -> EncM () +emit t = do { emitCon (dataTypeOf t) (toConstr t) + ; sequence_ (gmapQ emit t) } diff --git a/tests/Ext.hs b/tests/Ext.hs --- a/tests/Ext.hs +++ b/tests/Ext.hs @@ -1,30 +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) +{-# OPTIONS -fglasgow-exts #-} + +module Ext () where + +-- There were typos in these definitions in the ICFP 2004 paper. + +import Data.Generics + +extQ fn spec_fn arg + = case gcast (Q spec_fn) of + Just (Q spec_fn') -> spec_fn' arg + Nothing -> fn arg + +newtype Q r a = Q (a -> r) + +extT fn spec_fn arg + = case gcast (T spec_fn) of + Just (T spec_fn') -> spec_fn' arg + Nothing -> fn arg + +newtype T a = T (a -> a) + +extM :: (Typeable a, Typeable b) + => (a -> m a) -> (b -> m b) -> (a -> m a) +extM fn spec_fn + = case gcast (M spec_fn) of + Just (M spec_fn') -> spec_fn' + Nothing -> fn + +newtype M m a = M (a -> m a) diff --git a/tests/Ext1.hs b/tests/Ext1.hs --- a/tests/Ext1.hs +++ b/tests/Ext1.hs @@ -1,128 +1,128 @@ -{-# OPTIONS -fglasgow-exts #-} -{-# LANGUAGE CPP #-} - -module Ext1 (tests) where - -{- - -This example records some experiments with polymorphic datatypes. - --} - -import Test.HUnit - -import Data.Generics -#if MIN_VERSION_base(4,8,0) -import GHC.Base hiding(foldr) -#else -import GHC.Base -#endif - --- 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 #-} +{-# LANGUAGE CPP #-} + +module Ext1 (tests) where + +{- + +This example records some experiments with polymorphic datatypes. + +-} + +import Test.HUnit + +import Data.Generics +#if MIN_VERSION_base(4,8,0) +import GHC.Base hiding(foldr) +#else +import GHC.Base +#endif + +-- 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))))) diff --git a/tests/Ext2.hs b/tests/Ext2.hs --- a/tests/Ext2.hs +++ b/tests/Ext2.hs @@ -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) diff --git a/tests/FoldTree.hs b/tests/FoldTree.hs --- a/tests/FoldTree.hs +++ b/tests/FoldTree.hs @@ -1,73 +1,73 @@ -{-# 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 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])" +{-# 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 Tree a w = Leaf a + | Fork (Tree a w) (Tree a w) + | WithWeight (Tree a w) w + deriving (Typeable, Data) + + +-- A typical tree +mytree :: Tree Int Int +mytree = Fork (WithWeight (Leaf 42) 1) + (WithWeight (Fork (Leaf 88) (Leaf 37)) 2) + +-- A less typical tree, used for testing everythingBut +mytree' :: Tree Int Int +mytree' = Fork (Leaf 42) + (WithWeight (Fork (Leaf 88) (Leaf 37)) 2) + + +-- Print everything like an Int in mytree +-- In fact, we show two attempts: +-- 1. print really just everything like an Int +-- 2. print everything wrapped with Leaf +-- So (1.) confuses leafs and weights whereas (2.) does not. +-- Additionally we test everythingBut, stopping when we see a WithWeight node +tests = show ( listify (\(_::Int) -> True) mytree + , everything (++) ([] `mkQ` fromLeaf) mytree + , everythingBut (++) + (([],False) `mkQ` (\x -> (fromLeaf x, stop x))) mytree' + ) ~=? output + where + fromLeaf :: Tree Int Int -> [Int] + fromLeaf (Leaf x) = [x] + fromLeaf _ = [] + stop :: (Data a, Data b) => Tree a b -> Bool + stop (WithWeight _ _) = True + stop _ = False + +output = "([42,1,88,37,2],[42,88,37],[42])" diff --git a/tests/FreeNames.hs b/tests/FreeNames.hs --- a/tests/FreeNames.hs +++ b/tests/FreeNames.hs @@ -1,118 +1,118 @@ -{-# 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"] diff --git a/tests/GEq.hs b/tests/GEq.hs --- a/tests/GEq.hs +++ b/tests/GEq.hs @@ -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) diff --git a/tests/GMapQAssoc.hs b/tests/GMapQAssoc.hs --- a/tests/GMapQAssoc.hs +++ b/tests/GMapQAssoc.hs @@ -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]]) diff --git a/tests/GRead.hs b/tests/GRead.hs --- a/tests/GRead.hs +++ b/tests/GRead.hs @@ -1,45 +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],"")]]) +{-# OPTIONS -fglasgow-exts #-} + +module GRead (tests) where + +{- + +The following examples achieve branch coverage for the various +productions in the definition of gread. Also, negative test cases are +provided; see str2 and str3. Also, the potential of heading or +trailing spaces as well incomplete parsing of the input is exercised; +see str5. + +-} + +import Test.HUnit + +import Data.Generics + +str1 = "(True)" -- reads fine as a Bool +str2 = "(Treu)" -- invalid constructor +str3 = "True" -- lacks parentheses +str4 = "(1)" -- could be an Int +str5 = "( 2 ) ..." -- could be an Int with some trailing left-over +str6 = "([])" -- test empty list +str7 = "((:)" ++ " " ++ str4 ++ " " ++ str6 ++ ")" + +tests = show ( ( [ gread str1, + gread str2, + gread str3 + ] + , [ gread str4, + gread str5 + ] + , [ gread str6, + gread str7 + ] + ) + :: ( [[(Bool, String)]] + , [[(Int, String)]] + , [[([Int], String)]] + ) + ) ~=? output + +output = show + ([[(True,"")],[],[]],[[(1,"")],[(2,"...")]],[[([],"")],[([1],"")]]) diff --git a/tests/GRead2.hs b/tests/GRead2.hs --- a/tests/GRead2.hs +++ b/tests/GRead2.hs @@ -1,75 +1,75 @@ -{-# 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 Control.Applicative (Applicative(..)) -import Control.Monad (ap, liftM) -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 Functor DecM where - fmap = liftM - -instance Applicative DecM where - pure = return - (<*>) = ap - -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 } +{-# 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 Control.Applicative (Applicative(..)) +import Control.Monad (ap, liftM) +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 Functor DecM where + fmap = liftM + +instance Applicative DecM where + pure = return + (<*>) = ap + +instance Monad DecM where + return a = D (\s -> Just (s,a)) + (D m) >>= k = D (\s -> + case m s of + Nothing -> Nothing + Just (s1,a) -> let D n = k a + in n s1) + +runDec :: String -> DecM a -> Maybe a +runDec input (D m) = do (_,x) <- m input + return x + +parseConstr :: DataType -> DecM Constr +parseConstr ty = D (\s -> + match s (dataTypeConstrs ty)) + where + match :: String -> [Constr] + -> Maybe (String, Constr) + match _ [] = Nothing + match input (con:cons) + | take n input == showConstr con + = Just (drop n input, con) + | otherwise + = match input cons + where + n = length (showConstr con) + + +readM :: forall a. Data a => DecM a +readM = read + where + read :: DecM a + read = do { let val = argOf read + ; let ty = dataTypeOf val + ; constr <- parseConstr ty + ; let con::a = fromConstr constr + ; gmapM (\_ -> readM) con } + +argOf :: c a -> a +argOf = undefined + +yareadM :: forall a. Data a => DecM a +yareadM = do { let ty = dataTypeOf (undefined::a) + ; constr <- parseConstr ty + ; let con::a = fromConstr constr + ; gmapM (\_ -> yareadM) con } diff --git a/tests/GShow.hs b/tests/GShow.hs --- a/tests/GShow.hs +++ b/tests/GShow.hs @@ -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)]") diff --git a/tests/GShow2.hs b/tests/GShow2.hs --- a/tests/GShow2.hs +++ b/tests/GShow2.hs @@ -1,47 +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))) ([])) ([]))))" +{-# OPTIONS -fglasgow-exts #-} + +module GShow2 (tests) where + +{- + +This test exercices GENERIC show for the infamous company datatypes. The +output of the program should be some representation of the infamous +"genCom" company. + +-} + +import Test.HUnit + +import Data.Generics +import CompanyDatatypes + +tests = gshow genCom ~=? output + +{- + +Here is another exercise: +The following function gshow' is a completely generic variation on gshow. +It would print strings as follows: + +*Main> gshow' "abc" +"((:) ('a') ((:) ('b') ((:) ('c') ([]))))" + +The original gshow does a better job because it is customised for strings: + +*Main> gshow "foo" +"\"foo\"" + +In fact, this is what Haskell's normal show would also do: + +*Main> show "foo" +"\"foo\"" + +-} + +gshow' :: Data a => a -> String +gshow' t = "(" + ++ showConstr (toConstr t) + ++ concat (gmapQ ((++) " " . gshow') t) + ++ ")" + +output = "(C ((:) (D \"Research\" (E (P \"Laemmel\" \"Amsterdam\") (S (8000.0))) ((:) (PU (E (P \"Joost\" \"Amsterdam\") (S (1000.0)))) ((:) (PU (E (P \"Marlow\" \"Cambridge\") (S (2000.0)))) ([])))) ((:) (D \"Strategy\" (E (P \"Blair\" \"London\") (S (100000.0))) ([])) ([]))))" diff --git a/tests/GZip.hs b/tests/GZip.hs --- a/tests/GZip.hs +++ b/tests/GZip.hs @@ -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)) []]) diff --git a/tests/GenUpTo.hs b/tests/GenUpTo.hs --- a/tests/GenUpTo.hs +++ b/tests/GenUpTo.hs @@ -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)])))) diff --git a/tests/GetC.hs b/tests/GetC.hs --- a/tests/GetC.hs +++ b/tests/GetC.hs @@ -1,121 +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 +{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE OverlappingInstances, UndecidableInstances #-} + +module GetC (tests) where + +import Test.HUnit + +{- + +Ralf Laemmel, 5 November 2004 + +Joe Stoy suggested the idiom to test for the outermost constructor. + +Given is a term t +and a constructor f (say the empty constructor application). + +isC f t returns True if the outermost constructor of t is f. +isC f t returns False otherwise. +Modulo type checking, i.e., the data type of f and t must be the same. +If not, we want to see a type error, of course. + +-} + +import Data.Typeable -- to cast t's subterms, which will be reused for f. +import Data.Generics -- to access t's subterms and constructors. + + +-- Some silly data types +data T1 = T1a Int String | T1b String Int deriving (Typeable, Data) +data T2 = T2a Int Int | T2b String String deriving (Typeable, Data) +data T3 = T3! Int deriving (Typeable, Data) + + +-- Test cases +tests = show [ isC T1a (T1a 1 "foo") -- typechecks, returns True + , isC T1a (T1b "foo" 1) -- typechecks, returns False + , isC T3 (T3 42)] -- works for strict data too + ~=? output +-- err = show $ isC T2b (T1b "foo" 1) -- must not typecheck + +output = show [True,False,True] + +-- +-- We look at a datum a. +-- We look at a constructor function f. +-- The class GetT checks that f constructs data of type a. +-- The class GetC computes maybe the constructor ... +-- ... if the subterms of the datum at hand fit for f. +-- Finally we compare the constructors. +-- + +isC :: (Data a, GetT f a, GetC f) => f -> a -> Bool +isC f t = maybe False ((==) (toConstr t)) con + where + kids = gmapQ ExTypeable t -- homogenify subterms in list for reuse + con = getC f kids -- compute constructor from constructor application + + +-- +-- We prepare for a list of kids using existential envelopes. +-- We could also just operate on TypeReps for non-strict datatypes. +-- + +data ExTypeable = forall a. Typeable a => ExTypeable a +unExTypeable (ExTypeable a) = cast a + + +-- +-- Compute the result type of a function type. +-- Beware: the TypeUnify constraint causes headache. +-- We can't have GetT t t because the FD will be violated then. +-- We can't omit the FD because unresolvable overlapping will hold then. +-- + +class GetT f t | f -> t -- FD is optional +instance GetT g t => GetT (x -> g) t +instance TypeUnify t t' => GetT t t' + + +-- +-- Obtain the constructor if term can be completed +-- + +class GetC f + where + getC :: f -> [ExTypeable] -> Maybe Constr + +instance (Typeable x, GetC g) => GetC (x -> g) + where + getC _ [] = Nothing + getC (f::x->g) (h:t) + = + do + (x::x) <- unExTypeable h + getC (f x) t + +instance Data t => GetC t + where + getC y [] = Just $ toConstr y + getC _ (_:_) = Nothing + + +-- +-- Type unification; we could try this: +-- class TypeUnify a b | a -> b, b -> a +-- instance TypeUnify a a +-- +-- However, if the instance is placed in the present module, +-- then type improvement would inline this instance. Sigh!!! +-- +-- So we need type unification with type improvement blocker +-- The following solution works with GHC for ages. +-- Other solutions; see the HList paper. +-- + +class TypeUnify a b | a -> b, b -> a +class TypeUnify' x a b | x a -> b, x b -> a +class TypeUnify'' x a b | x a -> b, x b -> a +instance TypeUnify' () a b => TypeUnify a b +instance TypeUnify'' x a b => TypeUnify' x a b +instance TypeUnify'' () a a diff --git a/tests/HList.hs b/tests/HList.hs --- a/tests/HList.hs +++ b/tests/HList.hs @@ -1,62 +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 - +{-# OPTIONS -fglasgow-exts #-} + +module HList (tests) where + +{- + +This module illustrates heterogeneously typed lists. + +-} + +import Test.HUnit + +import Data.Typeable + + +-- Heterogeneously typed lists +type HList = [DontKnow] + +data DontKnow = forall a. Typeable a => DontKnow a + +-- The empty list +initHList :: HList +initHList = [] + +-- Add an entry +addHList :: Typeable a => a -> HList -> HList +addHList a l = (DontKnow a:l) + +-- Test for an empty list +nullHList :: HList -> Bool +nullHList = null + +-- Retrieve head by type case +headHList :: Typeable a => HList -> Maybe a +headHList [] = Nothing +headHList (DontKnow a:_) = cast a + +-- Retrieve tail by type case +tailHList :: HList -> HList +tailHList = tail + +-- Access per index; starts at 1 +nth1HList :: Typeable a => Int -> HList -> Maybe a +nth1HList i l = case (l !! (i-1)) of (DontKnow a) -> cast a + + +---------------------------------------------------------------------------- + +-- A demo list +mylist = addHList (1::Int) $ + addHList (True::Bool) $ + addHList ("42"::String) $ + initHList + +-- Main function for testing +tests = ( show (nth1HList 1 mylist :: Maybe Int) -- shows Just 1 + , ( show (nth1HList 1 mylist :: Maybe Bool) -- shows Nothing + , ( show (nth1HList 2 mylist :: Maybe Bool) -- shows Just True + , ( show (nth1HList 3 mylist :: Maybe String) -- shows Just "42" + )))) ~=? output + output = ("Just 1",("Nothing",("Just True","Just \"42\""))) diff --git a/tests/HOPat.hs b/tests/HOPat.hs --- a/tests/HOPat.hs +++ b/tests/HOPat.hs @@ -1,67 +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) - +{-# OPTIONS -fglasgow-exts #-} + +module HOPat (tests) where + +{- + +This module is in reply to an email by C. Barry Jay +received on March 15, and handled within hours. CBJ +raises the very interesting issue of higher-order patterns. +It turns out that some form of it is readily covered in +our setting. + +-} + +import Test.HUnit + +import Data.Generics + + +-- Sample datatypes +data T1 = T1a Int | T1b Float + deriving (Show, Eq, Typeable, Data) +data T2 = T2a T1 T2 | T2b + deriving (Show, Eq, Typeable, Data) + +-- Eliminate a constructor if feasible +elim' :: (Data y, Data x) => Constr -> y -> Maybe x +elim' c y = if toConstr y == c + then unwrap y + else Nothing + + +-- Unwrap a term; Return its single component +unwrap :: (Data y, Data x) => y -> Maybe x +unwrap y = case gmapQ (Nothing `mkQ` Just) y of + [Just x] -> Just x + _ -> Nothing + + +-- Eliminate a constructor if feasible; 2nd try +elim :: forall x y. (Data y, Data x) => (x -> y) -> y -> Maybe x +elim c y = elim' (toConstr (c (undefined::x))) y + + +-- Visit a data structure +visitor :: (Data x, Data y, Data z) + => (x -> y) -> (x -> x) -> z -> z +visitor c f = everywhere (mkT g) + where + g y = case elim c y of + Just x -> c (f x) + Nothing -> y + + +-- Main function for testing +tests = ( ( elim' (toConstr t1a) t1a) :: Maybe Int + , ( (elim' (toConstr t1a) t1b) :: Maybe Int + , ( (elim T1a t1a) :: Maybe Int + , ( (elim T1a t1b) :: Maybe Int + , ( (visitor T1a ((+) 46) t2) :: T2 + ))))) ~=? output + where + t1a = T1a 42 + t1b = T1b 3.14 + t2 = T2a t1a (T2a t1a T2b) + output = (Just 42,(Nothing,(Just 42,(Nothing,T2a (T1a 88) (T2a (T1a 88) T2b))))) diff --git a/tests/Labels.hs b/tests/Labels.hs --- a/tests/Labels.hs +++ b/tests/Labels.hs @@ -1,30 +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"]) +{-# OPTIONS -fglasgow-exts #-} + +module Labels (tests) where + +-- This module tests availability of field labels. + +import Test.HUnit + +import Data.Generics + +-- A datatype without labels +data NoLabels = NoLabels Int Float + deriving (Typeable, Data) + +-- A datatype with labels +data YesLabels = YesLabels { myint :: Int + , myfloat :: Float + } + deriving (Typeable, Data) + +-- Test terms +noLabels = NoLabels 42 3.14 +yesLabels = YesLabels 42 3.14 + +-- Main function for testing +tests = ( constrFields $ toConstr noLabels + , constrFields $ toConstr yesLabels + ) ~=? output + +output = ([],["myint","myfloat"]) diff --git a/tests/LocalQuantors.hs b/tests/LocalQuantors.hs --- a/tests/LocalQuantors.hs +++ b/tests/LocalQuantors.hs @@ -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] diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,82 +1,82 @@ - -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 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 - , 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 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 + , 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 diff --git a/tests/NestedDatatypes.hs b/tests/NestedDatatypes.hs --- a/tests/NestedDatatypes.hs +++ b/tests/NestedDatatypes.hs @@ -1,43 +1,43 @@ -{-# OPTIONS -fglasgow-exts #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DeriveDataTypeable #-} - -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]) deriving Typeable - - --- 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 #-} +{-# LANGUAGE DeriveDataTypeable #-} + +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]) deriving Typeable + + +-- 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] diff --git a/tests/Newtype.hs b/tests/Newtype.hs --- a/tests/Newtype.hs +++ b/tests/Newtype.hs @@ -1,20 +1,20 @@ -{-# LANGUAGE CPP #-} -{-# 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 - -#if __GLASGOW_HASKELL__ >= 701 -output = "T" -#else -output = "Newtype.T" -#endif +{-# LANGUAGE CPP #-} +{-# 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 + +#if __GLASGOW_HASKELL__ >= 701 +output = "T" +#else +output = "Newtype.T" +#endif diff --git a/tests/Paradise.hs b/tests/Paradise.hs --- a/tests/Paradise.hs +++ b/tests/Paradise.hs @@ -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)) []] diff --git a/tests/Perm.hs b/tests/Perm.hs --- a/tests/Perm.hs +++ b/tests/Perm.hs @@ -1,139 +1,139 @@ -{-# 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.Applicative (Alternative(..), Applicative(..)) -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) - ) - -instance Functor ReadT where - fmap = liftM - -instance Applicative ReadT where - pure = return - (<*>) = ap - -instance Alternative ReadT where - (<|>) = mplus - empty = mzero - --- 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)))) +{-# 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.Applicative (Alternative(..), Applicative(..)) +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) + ) + +instance Functor ReadT where + fmap = liftM + +instance Applicative ReadT where + pure = return + (<*>) = ap + +instance Alternative ReadT where + (<|>) = mplus + empty = mzero + +-- ReadT is a monad! +instance Monad ReadT where + return x = ReadT (\y -> Just (y,x)) + c >>= f = ReadT (\x -> case unReadT c x of + Nothing -> Nothing + Just (x', a) -> unReadT (f a) x' + ) + +-- ReadT also accommodates mzero and mplus! +instance MonadPlus ReadT where + mzero = ReadT (const Nothing) + f `mplus` g = ReadT (\x -> case unReadT f x of + Nothing -> unReadT g x + y -> y + ) + + +--------------------------------------------------------------------------- +-- A helper type to appeal to predicative type system. +--------------------------------------------------------------------------- + +newtype GenM = GenM { unGenM :: forall a. Data a => a -> ReadT a } + + +--------------------------------------------------------------------------- +-- The function that reads and copes with all permutations. +--------------------------------------------------------------------------- + +buildT :: forall a. Data a => ReadT a +buildT = result + + where + result = do str <- readT + con <- string2constr str + ske <- return $ fromConstr con + fs <- return $ gmapQ buildT' ske + perm [] fs ske + + -- Determine type of data to be constructed + myType = myTypeOf result + where + myTypeOf :: forall a. ReadT a -> a + myTypeOf = undefined + + -- Turn string into constructor + string2constr str = maybe mzero + return + (readConstr (dataTypeOf myType) str) + + -- Specialise buildT per kid type + buildT' :: forall a. Data a => a -> GenM + buildT' (_::a) = GenM (const mzero `extM` const (buildT::ReadT a)) + + -- The permutation exploration function + perm :: forall a. Data a => [GenM] -> [GenM] -> a -> ReadT a + perm [] [] a = return a + perm fs [] a = perm [] fs a + perm fs (f:fs') a = ( + do a' <- gmapMo (unGenM f) a + perm fs fs' a' + ) + `mplus` + ( + do guard (not (null fs')) + perm (f:fs) fs' a + ) + + +--------------------------------------------------------------------------- +-- The main function for testing +--------------------------------------------------------------------------- + +tests = + ( runReadT buildT ["T1"] :: Maybe T1 -- should parse fine + , ( runReadT buildT ["T2"] :: Maybe T2 -- should parse fine + , ( runReadT buildT ["T3","T1","T2"] :: Maybe T3 -- should parse fine + , ( runReadT buildT ["T3","T2","T1"] :: Maybe T3 -- should parse fine + , ( runReadT buildT ["T3","T2","T2"] :: Maybe T3 -- should fail + ))))) ~=? output + +output = (Just T1,(Just T2,(Just (T3 T1 T2),(Just (T3 T1 T2),Nothing)))) diff --git a/tests/Polymatch.hs b/tests/Polymatch.hs --- a/tests/Polymatch.hs +++ b/tests/Polymatch.hs @@ -1,70 +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") +{-# OPTIONS -fglasgow-exts #-} + +module Polymatch () where + + +import Data.Typeable +import Data.Generics + + +-- Representation of kids +kids x = gmapQ Kid x -- get all kids +type Kids = [Kid] +data Kid = forall k. Typeable k => Kid k + + +-- Build term from a list of kids and the constructor +fromConstrL :: Data a => Kids -> Constr -> Maybe a +fromConstrL l = unIDL . gunfold k z + where + z c = IDL (Just c) l + k (IDL Nothing _) = IDL Nothing undefined + k (IDL (Just f) (Kid x:l)) = IDL f' l + where + f' = case cast x of + (Just x') -> Just (f x') + _ -> Nothing + + +-- Helper datatype +data IDL x = IDL (Maybe x) Kids +unIDL (IDL mx _) = mx + + +-- Two sample datatypes +data A = A String deriving (Read, Show, Eq, Data, Typeable) +data B = B String deriving (Read, Show, Eq, Data, Typeable) + + +-- Mediate between two "left-equal" Either types +f :: (Data a, Data b, Show a, Read b) + => (a->b) -> Either String a -> Either String b + +f g (Right a) = Right $ g a -- conversion really needed +-- f g (Left s) = Left s -- unappreciated conversion +-- f g s = s -- doesn't typecheck +-- f g s = deep_rebuild s -- too expensive +f g s = just (shallow_rebuild s) -- perhaps this is Ok? + + +-- Get rid of maybies +just = maybe (error "tried, but failed.") id + + +-- Just mentioned for completeness' sake +deep_rebuild :: (Show a, Read b) => a -> b +deep_rebuild = read . show + + +-- For the record: it's possible. +shallow_rebuild :: (Data a, Data b) => a -> Maybe b +shallow_rebuild a = b + where + b = fromConstrL (kids a) constr + constr = indexConstr (dataTypeOf b) (constrIndex (toConstr a)) + + +-- Test cases +a2b (A s) = B s -- silly conversion +t1 = f a2b (Left "x") -- prints Left "x" +t2 = f a2b (Right (A "y")) -- prints Right (B "y") diff --git a/tests/Reify.hs b/tests/Reify.hs --- a/tests/Reify.hs +++ b/tests/Reify.hs @@ -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)) [])))))))))) diff --git a/tests/Strings.hs b/tests/Strings.hs --- a/tests/Strings.hs +++ b/tests/Strings.hs @@ -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 diff --git a/tests/Tree.hs b/tests/Tree.hs --- a/tests/Tree.hs +++ b/tests/Tree.hs @@ -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))) diff --git a/tests/Twin.hs b/tests/Twin.hs --- a/tests/Twin.hs +++ b/tests/Twin.hs @@ -1,90 +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) +{-# OPTIONS -fglasgow-exts #-} + +module Twin (tests) where + +{- + +For the discussion in the 2nd boilerplate paper, +we favour some simplified development of twin traversal. +So the full general, stepwise story is in Data.Generics.Twin, +but the short version from the paper is turned into a test +case below. + +See the paper for an explanation. + +-} + +import Test.HUnit + +import Data.Generics hiding (GQ,gzipWithQ,geq) + +geq' :: GenericQ (GenericQ Bool) +geq' x y = toConstr x == toConstr y + && and (gzipWithQ geq' x y) + +geq :: Data a => a -> a -> Bool +geq = geq' + +newtype GQ r = GQ (GenericQ r) + +gzipWithQ :: GenericQ (GenericQ r) + -> GenericQ (GenericQ [r]) +gzipWithQ f t1 t2 + = gApplyQ (gmapQ (\x -> GQ (f x)) t1) t2 + +gApplyQ :: Data a => [GQ r] -> a -> [r] +gApplyQ qs t = reverse (snd (gfoldlQ k z t)) + where + k :: ([GQ r], [r]) -> GenericQ ([GQ r], [r]) + k (GQ q : qs, rs) child = (qs, q child : rs) + z = (qs, []) + +newtype R r x = R { unR :: r } + +gfoldlQ :: (r -> GenericQ r) + -> r + -> GenericQ r + +gfoldlQ k z t = unR (gfoldl k' z' t) + where + z' _ = R z + k' (R r) c = R (k r c) + +----------------------------------------------------------------------------- + +-- A dependently polymorphic geq +geq'' :: Data a => a -> a -> Bool +geq'' x y = toConstr x == toConstr y + && and (gzipWithQ' geq'' x y) + +-- A helper type for existentially quantified queries +data XQ r = forall a. Data a => XQ (a -> r) + +-- A dependently polymorphic gzipWithQ +gzipWithQ' :: (forall a. Data a => a -> a -> r) + -> (forall a. Data a => a -> a -> [r]) +gzipWithQ' f t1 t2 + = gApplyQ' (gmapQ (\x -> XQ (f x)) t1) t2 + +-- Apply existentially quantified queries +-- Insist on equal types! +-- +gApplyQ' :: Data a => [XQ r] -> a -> [r] +gApplyQ' qs t = reverse (snd (gfoldlQ k z t)) + where + z = (qs, []) + k :: ([XQ r], [r]) -> GenericQ ([XQ r], [r]) + k (XQ q : qs, rs) child = (qs, q' child : rs) + where + q' = error "Twin mismatch" `extQ` q + + +----------------------------------------------------------------------------- + +tests = ( geq [True,True] [True,True] + , geq [True,True] [True,False] + , geq'' [True,True] [True,True] + , geq'' [True,True] [True,False] + ) ~=? output + +output = (True,False,True,False) diff --git a/tests/Typecase1.hs b/tests/Typecase1.hs --- a/tests/Typecase1.hs +++ b/tests/Typecase1.hs @@ -1,59 +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\"" +{-# OPTIONS -fglasgow-exts #-} + +module Typecase1 (tests) where + +{- + +This test demonstrates type case as it lives in Data.Typeable. +We define a function f that converts typeables into strings in some way. +Note: we only need Data.Typeable. Say: Dynamics are NOT involved. + +-} + +import Test.HUnit + +import Data.Typeable +import Data.Maybe + +-- Some datatype. +data MyTypeable = MyCons String deriving (Show, Typeable) + +-- +-- Some function that performs type case. +-- +f :: (Show a, Typeable a) => a -> String +f a = (maybe (maybe (maybe others + mytys (cast a) ) + float (cast a) ) + int (cast a) ) + + where + + -- do something with ints + int :: Int -> String + int a = "got an int, incremented: " ++ show (a + 1) + + -- do something with floats + float :: Float -> String + float a = "got a float, multiplied by .42: " ++ show (a * 0.42) + + -- do something with my typeables + mytys :: MyTypeable -> String + mytys a = "got a term: " ++ show a + + -- do something with all other typeables + others = "got something else: " ++ show a + + +-- +-- Test the type case +-- +tests = ( f (41::Int) + , f (88::Float) + , f (MyCons "42") + , f True) ~=? output + +output = ( "got an int, incremented: 42" + , "got a float, multiplied by .42: 36.96" + , "got a term: MyCons \"42\"" , "got something else: True") diff --git a/tests/Typecase2.hs b/tests/Typecase2.hs --- a/tests/Typecase2.hs +++ b/tests/Typecase2.hs @@ -1,61 +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)") - +{-# OPTIONS -fglasgow-exts #-} + +module Typecase2 (tests) where + +{- + +This test provides a variation on typecase1.hs. +This time, we use generic show as defined for all instances of Data. +Thereby, we get rid of the Show constraint in our functions. +So we only keep a single constraint: the one for class Data. + +-} + +import Test.HUnit + +import Data.Generics +import Data.Maybe + +-- Some datatype. +data MyData = MyCons String deriving (Typeable, Data) + +-- +-- Some function that performs type case. +-- +f :: Data a => a -> String +f a = (maybe (maybe (maybe others + mytys (cast a) ) + float (cast a) ) + int (cast a) ) + + where + + -- do something with ints + int :: Int -> String + int a = "got an int, incremented: " ++ show (a + 1) + + -- do something with floats + float :: Float -> String + float a = "got a float, multiplied by .42: " ++ show (a * 0.42) + + -- do something with my data + mytys :: MyData -> String + mytys a = "got my data: " ++ gshow a + + -- do something with all other data + others = "got something else: " ++ gshow a + + +-- +-- Test the type case +-- +tests = ( f (41::Int) + , f (88::Float) + , f (MyCons "42") + , f True) ~=? output + +output = ( "got an int, incremented: 42" + , "got a float, multiplied by .42: 36.96" + , "got my data: (MyCons \"42\")" + , "got something else: (True)") + diff --git a/tests/Where.hs b/tests/Where.hs --- a/tests/Where.hs +++ b/tests/Where.hs @@ -1,125 +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)))))))" +{-# OPTIONS -fglasgow-exts #-} + +module Where (tests) where + +{- + +This example illustrates some differences between certain traversal +schemes. To this end, we use a simple system of datatypes, and the +running example shall be to replace "T1a 42" by "T1a 88". It is our +intention to illustrate a few dimensions of designing traversals. + +1. We can decide on whether we prefer "rewrite steps" (i.e., +monomorphic functions on data) that succeed either for all input +patterns or only if the encounter a term pattern to be replaced. In +the first case, the catch-all equation of such a function describes +identity (see "stepid" below). In the second case, the catch-call +equation describes failure using the Maybe type constructor (see +"stepfail" below). As an intermediate assessment, the failure approach +is more general because it allows one to observe if a rewrite step was +meaningful or not. Often the identity approach is more convenient and +sufficient. + +2. We can now also decide on whether we want monadic or simple +traversals; recall monadic generic functions GenericM from +Data.Generics. The monad can serve for success/failure, state, +environment and others. One can now subdivide monadic traversal +schemes with respect to the question whether they simply support +monadic style of whether they even interact with the relevant +monad. The scheme "everywereM" from the library belongs to the first +category while "somewhere" belongs to the second category as it uses +the operation "mplus" of a monad with addition. So while "everywhereM" +makes very well sense without a monad --- as demonstrated by +"everywhere", the scheme "somewhere" is immediately monadic. + +3. We can now also decide on whether we want rewrite steps to succeed +for all possible subterms, at least for one subterm, exactly for one +subterm, and others. The various traversal schemes make different +assumptions in this respect. + +a) everywhere + + By its type, succeeds and requires non-failing rewrite steps. + However, we do not get any feedback on whether terms were actually + rewritten. (Say, we might have performed accidentally the identity + function on all nodes.) + +b) everywhereM + + Attempts to reach all nodes where all the sub-traversals are performed + in monadic bind-sequence. Failure of the traversal for a given subterm + implies failure of the entire traversal. Hence, the argument of + "everywhereM" should be designed in a way that it tends to succeed + except for the purpose of propagating a proper error in the sense of + violating a pre-/post-condition. For example, "mkM stepfail" should + not be passed to "everywhereM" as it will fail for all but one term + pattern; see "recovered" for a way to massage "stepfail" accordingly. + +c) somewhere + + Descends into term in a top-down manner, and stops in a given + branch when the argument succeeds for the subterm at hand. To this + end, it takes an argument that is perfectly intended to fail for + certain term patterns. Thanks to the employment of gmapF, the + traversal scheme recovers from failure when mapping over the immediate + subterms while insisting success for at least one subterm (say, branch). + This scheme is appropriate if you want to make sure that a given + rewrite step was actually used in a traversal. So failure of the + traversal would mean that the argument failed for all subterms. + +Contributed by Ralf Laemmel, ralf@cwi.nl + +-} + +import Test.HUnit + +import Data.Generics +import Control.Monad + + +-- Two mutually recursive datatypes +data T1 = T1a Int | T1b T2 deriving (Typeable, Data) +data T2 = T2 T1 deriving (Typeable, Data) + + +-- A rewrite step with identity as catch-all case +stepid (T1a 42) = T1a 88 +stepid x = x + + +-- The same rewrite step but now with failure as catch-all case +stepfail (T1a 42) = Just (T1a 88) +stepfail _ = Nothing + + +-- We can let recover potentially failing generic functions from failure; +-- this is illustrated for a generic made from stepfail via mkM. +recovered x = mkM stepfail x `mplus` Just x + + +-- A test term that comprehends a redex +term42 = T1b (T2 (T1a 42)) + + +-- A test term that does not comprehend a redex +term37 = T1b (T2 (T1a 37)) + + +-- A number of traversals +result1 = everywhere (mkT stepid) term42 -- rewrites term accordingly +result2 = everywhere (mkT stepid) term37 -- preserves term without notice +result3 = everywhereM (mkM stepfail) term42 -- fails in a harsh manner +result4 = everywhereM (mkM stepfail) term37 -- fails rather early +result5 = everywhereM recovered term37 -- preserves term without notice +result6 = somewhere (mkMp stepfail) term42 -- rewrites term accordingly +result7 = somewhere (mkMp stepfail) term37 -- fails to notice lack of redex + +tests = gshow ( result1, + ( result2, + ( result3, + ( result4, + ( result5, + ( result6, + ( result7 ))))))) ~=? output + +output = "((,) (T1b (T2 (T1a (88)))) ((,) (T1b (T2 (T1a (37)))) ((,) (Nothing) ((,) (Nothing) ((,) (Just (T1b (T2 (T1a (37))))) ((,) (Just (T1b (T2 (T1a (88))))) (Nothing)))))))" diff --git a/tests/XML.hs b/tests/XML.hs --- a/tests/XML.hs +++ b/tests/XML.hs @@ -1,207 +1,207 @@ -{-# 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.Applicative (Alternative(..), Applicative(..)) -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) - ) - -instance Functor ReadX where - fmap = liftM - -instance Applicative ReadX where - pure = return - (<*>) = ap - -instance Alternative ReadX where - (<|>) = mplus - empty = mzero - --- 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.Applicative (Alternative(..), Applicative(..)) +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) + ) + +instance Functor ReadX where + fmap = liftM + +instance Applicative ReadX where + pure = return + (<*>) = ap + +instance Alternative ReadX where + (<|>) = mplus + empty = mzero + +-- 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))))