syb 0.4.4 → 0.7.4
raw patch · 59 files changed
Files
- Changelog.md +29/−0
- LICENSE +83/−83
- README +0/−43
- README.md +42/−0
- Setup.lhs +3/−3
- src/Data/Generics.hs +39/−39
- src/Data/Generics/Aliases.hs +750/−439
- src/Data/Generics/Basics.hs +23/−23
- src/Data/Generics/Builders.hs +5/−1
- src/Data/Generics/Instances.hs +2/−0
- src/Data/Generics/Schemes.hs +242/−182
- src/Data/Generics/Text.hs +148/−130
- src/Data/Generics/Twins.hs +75/−30
- src/Generics/SYB.hs +17/−17
- src/Generics/SYB/Aliases.hs +17/−17
- src/Generics/SYB/Basics.hs +17/−17
- src/Generics/SYB/Builders.hs +17/−17
- src/Generics/SYB/Instances.hs +17/−17
- src/Generics/SYB/Schemes.hs +17/−17
- src/Generics/SYB/Text.hs +17/−17
- src/Generics/SYB/Twins.hs +17/−17
- syb.cabal +79/−28
- tests/Bits.hs +10/−10
- tests/Builders.hs +16/−19
- tests/CompanyDatatypes.hs +2/−2
- tests/Datatype.hs +57/−33
- tests/Encode.hs +6/−6
- tests/Ext.hs +28/−30
- tests/Ext1.hs +22/−29
- tests/Ext2.hs +65/−65
- tests/FoldTree.hs +73/−73
- tests/FreeNames.hs +118/−118
- tests/GEq.hs +21/−21
- tests/GMapQAssoc.hs +69/−68
- tests/GRead.hs +38/−28
- tests/GRead2.hs +5/−4
- tests/GShow.hs +52/−52
- tests/GShow2.hs +47/−47
- tests/GZip.hs +47/−46
- tests/GenUpTo.hs +99/−94
- tests/GetC.hs +132/−121
- tests/HList.hs +51/−61
- tests/HOPat.hs +67/−66
- tests/Labels.hs +30/−30
- tests/LocalQuantors.hs +22/−21
- tests/Main.hs +75/−82
- tests/NestedDatatypes.hs +44/−43
- tests/Newtype.hs +20/−15
- tests/Paradise.hs +27/−29
- tests/Perm.hs +22/−17
- tests/Polymatch.hs +71/−70
- tests/Reify.hs +8/−5
- tests/Strings.hs +19/−21
- tests/Tree.hs +67/−62
- tests/Twin.hs +91/−90
- tests/Typecase1.hs +5/−5
- tests/Typecase2.hs +5/−5
- tests/Where.hs +125/−125
- tests/XML.hs +26/−23
+ Changelog.md view
@@ -0,0 +1,29 @@+# 0.7.4++- Export new function `gshowsF` that allows more flexibility than `gshows`.+ It allows users to override how some children types should be printed. (https://github.com/dreixel/syb/pull/55)++# 0.7.3++- Fix `gread` to recognize negative numbers (https://github.com/dreixel/syb/issues/13)+- Bump minimum required GHC to 8.0+- `Generic'` is now a newtype instead of data, add `GenericR'` and `GenericB'` (https://github.com/dreixel/syb/issues/49)++# 0.7.2.4+- Improved documentation (thanks to @BinderDavid)+- Export `ext2` function which was already defined but not exported++# 0.7.2.3+- Compatibility with `mtl` 2.3 and GHC 9.6++# 0.7.2.2+- Compatibility with GHC 9.4++# 0.7.2.1+- Update cabal version++# 0.7.2+- Add compatibility with GHC 9, switch to tasty for tests, fix tests on GHCJS++# 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
LICENSE view
@@ -1,83 +1,83 @@-This library (libraries/syb) is derived from code from several -sources: - - * Code from the GHC project which is largely (c) The University of - Glasgow, and distributable under a BSD-style license (see below), - - * Code from the Haskell 98 Report which is (c) Simon Peyton Jones - and freely redistributable (but see the full license for - restrictions). - - * Code from the Haskell Foreign Function Interface specification, - which is (c) Manuel M. T. Chakravarty and freely redistributable - (but see the full license for restrictions). - -The full text of these licenses is reproduced below. All of the -licenses are BSD-style or compatible. - ------------------------------------------------------------------------------ - -The Glasgow Haskell Compiler License - -Copyright 2004, The University Court of the University of Glasgow. -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -- Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -- Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution. - -- Neither name of the University nor the names of its contributors may be -used to endorse or promote products derived from this software without -specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF -GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, -INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH -DAMAGE. - ------------------------------------------------------------------------------ - -Code derived from the document "Report on the Programming Language -Haskell 98", is distributed under the following license: - - Copyright (c) 2002 Simon Peyton Jones - - The authors intend this Report to belong to the entire Haskell - community, and so we grant permission to copy and distribute it for - any purpose, provided that it is reproduced in its entirety, - including this Notice. Modified versions of this Report may also be - copied and distributed for any purpose, provided that the modified - version is clearly presented as such, and that it does not claim to - be a definition of the Haskell 98 Language. - ------------------------------------------------------------------------------ - -Code derived from the document "The Haskell 98 Foreign Function -Interface, An Addendum to the Haskell 98 Report" is distributed under -the following license: - - Copyright (c) 2002 Manuel M. T. Chakravarty - - The authors intend this Report to belong to the entire Haskell - community, and so we grant permission to copy and distribute it for - any purpose, provided that it is reproduced in its entirety, - including this Notice. Modified versions of this Report may also be - copied and distributed for any purpose, provided that the modified - version is clearly presented as such, and that it does not claim to - be a definition of the Haskell 98 Foreign Function Interface. - ------------------------------------------------------------------------------ +This library (libraries/syb) is derived from code from several+sources: ++ * Code from the GHC project which is largely (c) The University of+ Glasgow, and distributable under a BSD-style license (see below),++ * Code from the Haskell 98 Report which is (c) Simon Peyton Jones+ and freely redistributable (but see the full license for+ restrictions).++ * Code from the Haskell Foreign Function Interface specification,+ which is (c) Manuel M. T. Chakravarty and freely redistributable+ (but see the full license for restrictions).++The full text of these licenses is reproduced below. All of the+licenses are BSD-style or compatible.++-----------------------------------------------------------------------------++The Glasgow Haskell Compiler License++Copyright 2004, The University Court of the University of Glasgow. +All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.++-----------------------------------------------------------------------------++Code derived from the document "Report on the Programming Language+Haskell 98", is distributed under the following license:++ Copyright (c) 2002 Simon Peyton Jones++ The authors intend this Report to belong to the entire Haskell+ community, and so we grant permission to copy and distribute it for+ any purpose, provided that it is reproduced in its entirety,+ including this Notice. Modified versions of this Report may also be+ copied and distributed for any purpose, provided that the modified+ version is clearly presented as such, and that it does not claim to+ be a definition of the Haskell 98 Language.++-----------------------------------------------------------------------------++Code derived from the document "The Haskell 98 Foreign Function+Interface, An Addendum to the Haskell 98 Report" is distributed under+the following license:++ Copyright (c) 2002 Manuel M. T. Chakravarty++ The authors intend this Report to belong to the entire Haskell+ community, and so we grant permission to copy and distribute it for+ any purpose, provided that it is reproduced in its entirety,+ including this Notice. Modified versions of this Report may also be+ copied and distributed for any purpose, provided that the modified+ version is clearly presented as such, and that it does not claim to+ be a definition of the Haskell 98 Foreign Function Interface.++-----------------------------------------------------------------------------
− README
@@ -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
+ README.md view
@@ -0,0 +1,42 @@+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 8.0 or later+* Cabal 3.0 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
Setup.lhs view
@@ -1,3 +1,3 @@-#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain +#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
src/Data/Generics.hs view
@@ -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 <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. To scrap your --- boilerplate it is sufficient to import the present module, which simply --- re-exports all themes of the Data.Generics library. --- ------------------------------------------------------------------------------ - -module Data.Generics ( - - -- * All Data.Generics modules - module Data.Data, -- primitives and instances of the Data class - module Data.Generics.Aliases, -- aliases for type case, generic types - module Data.Generics.Schemes, -- traversal schemes (everywhere etc.) - module Data.Generics.Text, -- generic read and show - module Data.Generics.Twins, -- twin traversal, e.g., generic eq - module Data.Generics.Builders, -- term builders - - ) where - ------------------------------------------------------------------------------- - -import Data.Data -import Data.Generics.Instances () -import Data.Generics.Aliases -import Data.Generics.Schemes -import Data.Generics.Text -import Data.Generics.Twins -import Data.Generics.Builders +{-# 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 <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. To scrap your+-- boilerplate it is sufficient to import the present module, which simply+-- re-exports all themes of the Data.Generics library.+--+-----------------------------------------------------------------------------++module Data.Generics (++ -- * All Data.Generics modules+ module Data.Data, -- primitives and instances of the Data class+ module Data.Generics.Aliases, -- aliases for type case, generic types+ module Data.Generics.Schemes, -- traversal schemes (everywhere etc.)+ module Data.Generics.Text, -- generic read and show+ module Data.Generics.Twins, -- twin traversal, e.g., generic eq+ module Data.Generics.Builders, -- term builders++ ) where++------------------------------------------------------------------------------++import Data.Data+import Data.Generics.Instances ()+import Data.Generics.Aliases+import Data.Generics.Schemes+import Data.Generics.Text+import Data.Generics.Twins+import Data.Generics.Builders
src/Data/Generics/Aliases.hs view
@@ -1,439 +1,750 @@-{-# 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 <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. --- The present module provides a number of declarations for typical generic --- function types, corresponding type case, and others. --- ------------------------------------------------------------------------------ - -module Data.Generics.Aliases ( - - -- * Combinators to \"make\" generic functions via cast - mkT, mkQ, mkM, mkMp, mkR, - ext0, extT, extQ, extM, extMp, extB, extR, - - -- * Type synonyms for generic function types - GenericT, - GenericQ, - GenericM, - GenericB, - GenericR, - Generic, - Generic'(..), - GenericT'(..), - GenericQ'(..), - GenericM'(..), - - -- * Ingredients of generic functions - orElse, - - -- * Function combinators on generic functions - recoverMp, - recoverQ, - choiceMp, - choiceQ, - - -- * Type extension for unary type constructors - ext1, - ext1T, - ext1M, - ext1Q, - ext1R, - ext1B, - - -- * Type extension for binary type constructors - ext2T, - ext2M, - ext2Q, - ext2R, - ext2B - - ) where - -#ifdef __HADDOCK__ -import Prelude -#endif -import Control.Monad -import Data.Data - ------------------------------------------------------------------------------- --- --- Combinators to "make" generic functions --- We use type-safe cast in a number of ways to make generic functions. --- ------------------------------------------------------------------------------- - --- | Make a generic transformation; --- start from a type-specific case; --- preserve the term otherwise --- -mkT :: ( Typeable a - , Typeable b - ) - => (b -> b) - -> a - -> a -mkT = extT id - - --- | Make a generic query; --- start from a type-specific case; --- return a constant otherwise --- -mkQ :: ( Typeable a - , Typeable b - ) - => r - -> (b -> r) - -> a - -> r -(r `mkQ` br) a = case cast a of - Just b -> br b - Nothing -> r - - --- | Make a generic monadic transformation; --- start from a type-specific case; --- resort to return otherwise --- -mkM :: ( Monad m - , Typeable a - , Typeable b - ) - => (b -> m b) - -> a - -> m a -mkM = extM return - - -{- - -For the remaining definitions, we stick to a more concise style, i.e., -we fold maybes with "maybe" instead of case ... of ..., and we also -use a point-free style whenever possible. - --} - - --- | Make a generic monadic transformation for MonadPlus; --- use \"const mzero\" (i.e., failure) instead of return as default. --- -mkMp :: ( MonadPlus m - , Typeable a - , Typeable b - ) - => (b -> m b) - -> a - -> m a -mkMp = extM (const mzero) - - --- | Make a generic builder; --- start from a type-specific ase; --- resort to no build (i.e., mzero) otherwise --- -mkR :: ( MonadPlus m - , Typeable a - , Typeable b - ) - => m b -> m a -mkR f = mzero `extR` f - - --- | Flexible type extension -ext0 :: (Typeable a, Typeable b) => c a -> c b -> c a -ext0 def ext = maybe def id (gcast ext) - - --- | Extend a generic transformation by a type-specific case -extT :: ( Typeable a - , Typeable b - ) - => (a -> a) - -> (b -> b) - -> a - -> a -extT def ext = unT ((T def) `ext0` (T ext)) - - --- | Extend a generic query by a type-specific case -extQ :: ( Typeable a - , Typeable b - ) - => (a -> q) - -> (b -> q) - -> a - -> q -extQ f g a = maybe (f a) g (cast a) - - --- | Extend a generic monadic transformation by a type-specific case -extM :: ( Monad m - , Typeable a - , Typeable b - ) - => (a -> m a) -> (b -> m b) -> a -> m a -extM def ext = unM ((M def) `ext0` (M ext)) - - --- | Extend a generic MonadPlus transformation by a type-specific case -extMp :: ( MonadPlus m - , Typeable a - , Typeable b - ) - => (a -> m a) -> (b -> m b) -> a -> m a -extMp = extM - - --- | Extend a generic builder -extB :: ( Typeable a - , Typeable b - ) - => a -> b -> a -extB a = maybe a id . cast - - --- | Extend a generic reader -extR :: ( Monad m - , Typeable a - , Typeable b - ) - => m a -> m b -> m a -extR def ext = unR ((R def) `ext0` (R ext)) - - - ------------------------------------------------------------------------------- --- --- Type synonyms for generic function types --- ------------------------------------------------------------------------------- - - --- | Generic transformations, --- i.e., take an \"a\" and return an \"a\" --- -type GenericT = forall a. Data a => a -> a - - --- | Generic queries of type \"r\", --- i.e., take any \"a\" and return an \"r\" --- -type GenericQ r = forall a. Data a => a -> r - - --- | Generic monadic transformations, --- i.e., take an \"a\" and compute an \"a\" --- -type GenericM m = forall a. Data a => a -> m a - - --- | Generic builders --- i.e., produce an \"a\". --- -type GenericB = forall a. Data a => a - - --- | Generic readers, say monadic builders, --- i.e., produce an \"a\" with the help of a monad \"m\". --- -type GenericR m = forall a. Data a => m a - - --- | The general scheme underlying generic functions --- assumed by gfoldl; there are isomorphisms such as --- GenericT = Generic T. --- -type Generic c = forall a. Data a => a -> c a - - --- | Wrapped generic functions; --- recall: [Generic c] would be legal but [Generic' c] not. --- -data Generic' c = Generic' { unGeneric' :: Generic c } - - --- | Other first-class polymorphic wrappers -newtype GenericT' = GT { unGT :: forall a. Data a => a -> a } -newtype GenericQ' r = GQ { unGQ :: GenericQ r } -newtype GenericM' m = GM { unGM :: forall a. Data a => a -> m a } - - --- | Left-biased choice on maybes -orElse :: Maybe a -> Maybe a -> Maybe a -x `orElse` y = case x of - Just _ -> x - Nothing -> y - - -{- - -The following variations take "orElse" to the function -level. Furthermore, we generalise from "Maybe" to any -"MonadPlus". This makes sense for monadic transformations and -queries. We say that the resulting combinators modell choice. We also -provide a prime example of choice, that is, recovery from failure. In -the case of transformations, we recover via return whereas for -queries a given constant is returned. - --} - --- | Choice for monadic transformations -choiceMp :: MonadPlus m => GenericM m -> GenericM m -> GenericM m -choiceMp f g x = f x `mplus` g x - - --- | Choice for monadic queries -choiceQ :: MonadPlus m => GenericQ (m r) -> GenericQ (m r) -> GenericQ (m r) -choiceQ f g x = f x `mplus` g x - - --- | Recover from the failure of monadic transformation by identity -recoverMp :: MonadPlus m => GenericM m -> GenericM m -recoverMp f = f `choiceMp` return - - --- | Recover from the failure of monadic query by a constant -recoverQ :: MonadPlus m => r -> GenericQ (m r) -> GenericQ (m r) -recoverQ r f = f `choiceQ` const (return r) - - - ------------------------------------------------------------------------------- --- Type extension for unary type constructors ------------------------------------------------------------------------------- - -#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)+--+-- This module provides a number of declarations for typical generic+-- function types, corresponding type case, and others.+--+-----------------------------------------------------------------------------++module Data.Generics.Aliases (++ -- * Combinators which create generic functions via cast+ --+ -- $castcombinators++ -- ** Transformations+ mkT,+ extT,+ -- ** Queries+ mkQ,+ extQ,+ -- ** Monadic transformations+ mkM,+ extM,+ -- ** MonadPlus transformations+ mkMp,+ extMp,+ -- ** Readers+ mkR,+ extR,+ -- ** Builders+ extB,+ -- ** Other+ ext0,+ -- * Types for generic functions+ -- ** Transformations+ GenericT,+ GenericT'(..),+ -- ** Queries+ GenericQ,+ GenericQ'(..),+ -- ** Monadic transformations+ GenericM,+ GenericM'(..),+ -- ** Readers+ GenericR,+ GenericR'(..),+ -- ** Builders+ GenericB,+ GenericB'(..),+ -- ** Other+ Generic,+ Generic'(..),++ -- * 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+ ext2,+ 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.+--+------------------------------------------------------------------------------++-- $castcombinators+--+-- Other programming languages sometimes provide an operator @instanceof@ which+-- can check whether an expression is an instance of a given type. This operator+-- allows programmers to implement a function @f :: forall a. a -> a@ which exhibits+-- a different behaviour depending on whether a `Bool` or a `Char` is passed.+-- In Haskell this is not the case: A function with type @forall a. a -> a@+-- can only be the identity function or a function which loops indefinitely+-- or throws an exception. That is, it must implement exactly the same behaviour+-- for any type at which it is used. But sometimes it is very useful to have+-- a function which can accept (almost) any type and exhibit a different behaviour+-- for different types. Haskell provides this functionality with the 'Typeable'+-- typeclass, whose instances can be automatically derived by GHC for almost all+-- types. This typeclass allows the definition of a functon 'cast' which has type+-- @forall a b. (Typeable a, Typeable b) => a -> Maybe b@. The 'cast' function allows+-- to implement a polymorphic function with different behaviour at different types:+--+-- >>> cast True :: Maybe Bool+-- Just True+--+-- >>> cast True :: Maybe Int+-- Nothing+--+-- This section provides combinators which make use of 'cast' internally to+-- provide various polymorphic functions with type-specific behaviour.+++-- | Extend the identity function with a type-specific transformation.+-- The function created by @mkT ext@ behaves like the identity function on all+-- arguments which cannot be cast to type @b@, and like the function @ext@ otherwise.+-- The name 'mkT' is short for "make transformation".+--+-- === __Examples__+--+-- >>> mkT not True+-- False+--+-- >>> mkT not 'a'+-- 'a'+--+-- @since 0.1.0.0+mkT :: ( Typeable a+ , Typeable b+ )+ => (b -> b)+ -- ^ The type-specific transformation+ -> a+ -- ^ The argument we try to cast to type @b@+ -> a+mkT = extT id+++-- | The function created by @mkQ def f@ returns the default result+-- @def@ if its argument cannot be cast to type @b@, otherwise it returns+-- the result of applying @f@ to its argument.+-- The name 'mkQ' is short for "make query".+--+-- === __Examples__+--+-- >>> mkQ "default" (show :: Bool -> String) True+-- "True"+--+-- >>> mkQ "default" (show :: Bool -> String) ()+-- "default"+--+-- @since 0.1.0.0+mkQ :: ( Typeable a+ , Typeable b+ )+ => r+ -- ^ The default result+ -> (b -> r)+ -- ^ The transformation to apply if the cast is successful+ -> a+ -- ^ The argument we try to cast to type @b@+ -> r+(r `mkQ` br) a = case cast a of+ Just b -> br b+ Nothing -> r+++-- | Extend the default monadic action @pure :: Monad m => a -> m a@ by a type-specific+-- monadic action. The function created by @mkM act@ behaves like 'pure' if its+-- argument cannot be cast to type @b@, and like the monadic action @act@ otherwise.+-- The name 'mkM' is short for "make monadic transformation".+--+-- === __Examples__+--+-- >>> mkM (\x -> [x, not x]) True+-- [True,False]+--+-- >>> mkM (\x -> [x, not x]) (5 :: Int)+-- [5]+--+-- @since 0.1.0.0+mkM :: ( Monad m+ , Typeable a+ , Typeable b+ )+ => (b -> m b)+ -- ^ The type-specific monadic transformation+ -> a+ -- ^ The argument we try to cast to type @b@+ -> m a+mkM = extM return++-- | Extend the default 'MonadPlus' action @const mzero@ by a type-specific 'MonadPlus'+-- action. The function created by @mkMp act@ behaves like @const mzero@ if its argument+-- cannot be cast to type @b@, and like the monadic action @act@ otherwise.+-- The name 'mkMp' is short for "make MonadPlus transformation".+--+-- === __Examples__+--+-- >>> mkMp (\x -> Just (not x)) True+-- Just False+--+-- >>> mkMp (\x -> Just (not x)) 'a'+-- Nothing+--+-- @since 0.1.0.0+mkMp :: ( MonadPlus m+ , Typeable a+ , Typeable b+ )+ => (b -> m b)+ -- ^ The type-specific MonadPlus action+ -> a+ -- ^ The argument we try to cast to type @b@+ -> m a+mkMp = extM (const mzero)+++-- | Make a generic reader from a type-specific case.+-- The function created by @mkR f@ behaves like the reader @f@ if an expression+-- of type @a@ can be cast to type @b@, and like the expression @mzero@ otherwise.+-- The name 'mkR' is short for "make reader".+--+-- === __Examples__+--+-- >>> mkR (Just True) :: Maybe Bool+-- Just True+--+-- >>> mkR (Just True) :: Maybe Int+-- Nothing+--+-- @since 0.1.0.0+mkR :: ( MonadPlus m+ , Typeable a+ , Typeable b+ )+ => m b+ -- ^ The type-specific reader+ -> m a+mkR f = mzero `extR` f+++-- | Flexible type extension+--+-- === __Examples__+--+-- >>> ext0 [1 :: Int, 2, 3] [True, False] :: [Int]+-- [1,2,3]+--+-- >>> ext0 [1 :: Int, 2, 3] [4 :: Int, 5, 6] :: [Int]+-- [4,5,6]+--+-- @since 0.1.0.0+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 transformation.+-- The function created by @extT def ext@ behaves like the generic transformation+-- @def@ if its argument cannot be cast to the type @b@, and like the type-specific+-- transformation @ext@ otherwise.+-- The name 'extT' is short for "extend transformation".+--+-- === __Examples__+--+-- >>> extT id not True+-- False+--+-- >>> extT id not 'a'+-- 'a'+--+-- @since 0.1.0.0+extT :: ( Typeable a+ , Typeable b+ )+ => (a -> a)+ -- ^ The transformation we want to extend+ -> (b -> b)+ -- ^ The type-specific transformation+ -> a+ -- ^ The argument we try to cast to type @b@+ -> a+extT def ext = unT ((T def) `ext0` (T ext))+++-- | Extend a generic query by a type-specific query. The function created by @extQ def ext@ behaves+-- like the generic query @def@ if its argument cannot be cast to the type @b@, and like the type-specific+-- query @ext@ otherwise.+-- The name 'extQ' is short for "extend query".+--+-- === __Examples__+--+-- >>> extQ (const True) not True+-- False+--+-- >>> extQ (const True) not 'a'+-- True+--+-- @since 0.1.0.0+extQ :: ( Typeable a+ , Typeable b+ )+ => (a -> r)+ -- ^ The query we want to extend+ -> (b -> r)+ -- ^ The type-specific query+ -> a+ -- ^ The argument we try to cast to type @b@+ -> r+extQ f g a = maybe (f a) g (cast a)+++-- | Extend a generic monadic transformation by a type-specific case.+-- The function created by @extM def ext@ behaves like the monadic transformation+-- @def@ if its argument cannot be cast to type @b@, and like the monadic transformation+-- @ext@ otherwise.+-- The name 'extM' is short for "extend monadic transformation".+--+-- === __Examples__+--+-- >>> extM (\x -> [x,x])(\x -> [not x, x]) True+-- [False,True]+--+-- >>> extM (\x -> [x,x])(\x -> [not x, x]) (5 :: Int)+-- [5,5]+--+-- @since 0.1.0.0+extM :: ( Monad m+ , Typeable a+ , Typeable b+ )+ => (a -> m a)+ -- ^ The monadic transformation we want to extend+ -> (b -> m b)+ -- ^ The type-specific monadic transformation+ -> a+ -- ^ The argument we try to cast to type @b@+ -> m a+extM def ext = unM ((M def) `ext0` (M ext))+++-- | Extend a generic MonadPlus transformation by a type-specific case.+-- The function created by @extMp def ext@ behaves like 'MonadPlus' transformation @def@+-- if its argument cannot be cast to type @b@, and like the transformation @ext@ otherwise.+-- Note that 'extMp' behaves exactly like 'extM'.+-- The name 'extMp' is short for "extend MonadPlus transformation".+--+-- === __Examples__+--+-- >>> extMp (\x -> [x,x])(\x -> [not x, x]) True+-- [False,True]+--+-- >>> extMp (\x -> [x,x])(\x -> [not x, x]) (5 :: Int)+-- [5,5]+--+-- @since 0.1.0.0+extMp :: ( MonadPlus m+ , Typeable a+ , Typeable b+ )+ => (a -> m a)+ -- ^ The 'MonadPlus' transformation we want to extend+ -> (b -> m b)+ -- ^ The type-specific 'MonadPlus' transformation+ -> a+ -- ^ The argument we try to cast to type @b@+ -> m a+extMp = extM+++-- | Extend a generic builder by a type-specific case.+-- The builder created by @extB def ext@ returns @def@ if @ext@ cannot be cast+-- to type @a@, and like @ext@ otherwise.+-- The name 'extB' is short for "extend builder".+--+-- === __Examples__+--+-- >>> extB True 'a'+-- True+--+-- >>> extB True False+-- False+--+-- @since 0.1.0.0+extB :: ( Typeable a+ , Typeable b+ )+ => a+ -- ^ The default result+ -> b+ -- ^ The argument we try to cast to type @a@+ -> a+extB a = maybe a id . cast+++-- | Extend a generic reader by a type-specific case.+-- The reader created by @extR def ext@ behaves like the reader @def@+-- if expressions of type @b@ cannot be cast to type @a@, and like the+-- reader @ext@ otherwise.+-- The name 'extR' is short for "extend reader".+--+-- === __Examples__+--+-- >>> extR (Just True) (Just 'a')+-- Just True+--+-- >>> extR (Just True) (Just False)+-- Just False+--+-- @since 0.1.0.0+extR :: ( Monad m+ , Typeable a+ , Typeable b+ )+ => m a+ -- ^ The generic reader we want to extend+ -> m b+ -- ^ The type-specific reader+ -> m a+extR def ext = unR ((R def) `ext0` (R ext))++++------------------------------------------------------------------------------+--+-- Types for generic functions+--+------------------------------------------------------------------------------+++-- | Generic transformations,+-- i.e., take an \"a\" and return an \"a\"+--+-- @since 0.1.0.0+type GenericT = forall a. Data a => a -> a++-- | The type synonym `GenericT` has a polymorphic type, and can therefore not+-- appear in places where monomorphic types are expected, for example in a list.+-- The newtype `GenericT'` wraps `GenericT` in a newtype to lift this restriction.+--+-- @since 0.1.0.0+newtype GenericT' = GT { unGT :: GenericT }++-- | Generic queries of type \"r\",+-- i.e., take any \"a\" and return an \"r\"+--+-- @since 0.1.0.0+type GenericQ r = forall a. Data a => a -> r++-- | The type synonym `GenericQ` has a polymorphic type, and can therefore not+-- appear in places where monomorphic types are expected, for example in a list.+-- The newtype `GenericQ'` wraps `GenericQ` in a newtype to lift this restriction.+--+-- @since 0.1.0.0+newtype GenericQ' r = GQ { unGQ :: GenericQ r }++-- | Generic monadic transformations,+-- i.e., take an \"a\" and compute an \"a\"+--+-- @since 0.1.0.0+type GenericM m = forall a. Data a => a -> m a++-- | The type synonym `GenericM` has a polymorphic type, and can therefore not+-- appear in places where monomorphic types are expected, for example in a list.+-- The newtype `GenericM'` wraps `GenericM` in a newtype to lift this restriction.+--+-- @since 0.1.0.0+newtype GenericM' m = GM { unGM :: GenericM m }++-- | Generic builders+-- i.e., produce an \"a\".+--+-- @since 0.1.0.0+type GenericB = forall a. Data a => a++-- | The type synonym `GenericB` has a polymorphic type, and can therefore not+-- appear in places where monomorphic types are expected, for example in a list.+-- The data type `GenericB'` wraps `GenericB` in a data type to lift this restriction.+--+-- @since 0.7.3+newtype GenericB' = GenericB' { unGenericB' :: GenericB }++-- | Generic readers, say monadic builders,+-- i.e., produce an \"a\" with the help of a monad \"m\".+--+-- @since 0.1.0.0+type GenericR m = forall a. Data a => m a++-- | The type synonym `GenericR` has a polymorphic type, and can therefore not+-- appear in places where monomorphic types are expected, for example in a list.+-- The data type `GenericR'` wraps `GenericR` in a data type to lift this restriction.+--+-- @since 0.7.3+newtype GenericR' m = GenericR' { unGenericR' :: GenericR m }++-- | The general scheme underlying generic functions+-- assumed by gfoldl; there are isomorphisms such as+-- GenericT = Generic T.+--+-- @since 0.1.0.0+type Generic c = forall a. Data a => a -> c a+++-- | The type synonym `Generic` has a polymorphic type, and can therefore not+-- appear in places where monomorphic types are expected, for example in a list.+-- The data type `Generic'` wraps `Generic` in a data type to lift this restriction.+--+-- @since 0.1.0.0+newtype Generic' c = Generic' { unGeneric' :: Generic c }++------------------------------------------------------------------------------+--+-- Ingredients of generic functions+--+------------------------------------------------------------------------------++-- | Left-biased choice on maybes+--+-- === __Examples__+--+-- >>> orElse Nothing Nothing+-- Nothing+--+-- >>> orElse Nothing (Just 'a')+-- Just 'a'+--+-- >>> orElse (Just 'a') Nothing+-- Just 'a'+--+-- >>> orElse (Just 'a') (Just 'b')+-- Just 'a'+--+-- @since 0.1.0.0+orElse :: Maybe a -> Maybe a -> Maybe a+x `orElse` y = case x of+ Just _ -> x+ Nothing -> y+++------------------------------------------------------------------------------+--+-- Function combinators on generic functions+--+------------------------------------------------------------------------------+{-++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+--+-- @since 0.1.0.0+choiceMp :: MonadPlus m => GenericM m -> GenericM m -> GenericM m+choiceMp f g x = f x `mplus` g x+++-- | Choice for monadic queries+--+-- @since 0.1.0.0+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+--+-- @since 0.1.0.0+recoverMp :: MonadPlus m => GenericM m -> GenericM m+recoverMp f = f `choiceMp` return+++-- | Recover from the failure of monadic query by a constant+--+-- @since 0.1.0.0+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+--+-- @since 0.3+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+--+-- @since 0.1.0.0+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+--+-- @since 0.1.0.0+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+--+-- @since 0.1.0.0+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+--+-- @since 0.1.0.0+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+--+-- @since 0.2+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+--+-- @since 0.3+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+--+-- @since 0.3+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+--+-- @since 0.3+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+--+-- @since 0.3+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+--+-- @since 0.3+ext2B :: (Data a, Typeable2 t)+ => a+ -> (forall d1 d2. (Data d1, Data d2) => (t d1 d2))+ -> a+ext2B def ext = unB ((B def) `ext2` (B ext))++------------------------------------------------------------------------------+--+-- Type constructors for type-level lambdas+--+------------------------------------------------------------------------------+++-- | The type constructor for transformations+newtype T x = T { unT :: x -> x }++-- | The type constructor for transformations+newtype M m x = M { unM :: x -> m x }++-- | The type constructor for queries+newtype Q q x = Q { unQ :: x -> q }++-- | The type constructor for readers+newtype R m x = R { unR :: m x }++-- | The type constructor for builders+newtype B x = B {unB :: x}
src/Data/Generics/Basics.hs view
@@ -1,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 <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. This module provides --- the 'Data' class with its primitives for generic programming, --- which is now defined in @Data.Data@. Therefore this module simply --- re-exports @Data.Data@. --- ------------------------------------------------------------------------------ - -module Data.Generics.Basics ( - module Data.Data - ) where - -import Data.Data +-----------------------------------------------------------------------------+-- |+-- Module : Data.Generics.Basics+-- Copyright : (c) The University of Glasgow, CWI 2001--2004+-- License : BSD-style (see the LICENSE file)+-- +-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable (local universal quantification)+--+-- \"Scrap your boilerplate\" --- Generic programming in Haskell.+-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. This module provides+-- the 'Data' class with its primitives for generic programming,+-- which is now defined in @Data.Data@. Therefore this module simply+-- re-exports @Data.Data@.+--+-----------------------------------------------------------------------------++module Data.Generics.Basics (+ module Data.Data+ ) where++import Data.Data
src/Data/Generics/Builders.hs view
@@ -6,7 +6,7 @@ -- Module : Data.Generics.Builders -- Copyright : (c) 2008 Universiteit Utrecht -- License : BSD-style --- +-- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable @@ -22,6 +22,8 @@ -- | Construct the empty value for a datatype. For algebraic datatypes, the -- leftmost constructor is chosen. +-- +-- @since 0.2 empty :: forall a. Data a => a empty = general `extB` char @@ -43,6 +45,8 @@ -- | Return a list of values of a datatype. Each value is one of the possible -- constructors of the datatype, populated with 'empty' values. +-- +-- @since 0.2 constrs :: forall a. Data a => [a] constrs = general `extB` char
src/Data/Generics/Instances.hs view
@@ -70,10 +70,12 @@ -- 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 ------------------------------------------------------------------------------
src/Data/Generics/Schemes.hs view
@@ -1,182 +1,242 @@-{-# 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 <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module --- provides frequently used generic traversal schemes. --- ------------------------------------------------------------------------------ - -module Data.Generics.Schemes ( - - everywhere, - everywhere', - everywhereBut, - everywhereM, - somewhere, - everything, - everythingBut, - 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 <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module+-- provides frequently used generic traversal schemes.+--+-----------------------------------------------------------------------------++module Data.Generics.Schemes (++ everywhere,+ everywhere',+ everywhereBut,+ everywhereM,+ somewhere,+ everything,+ everythingBut,+ 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+--+-- @since 0.1.0.0+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+--+-- @since 0.1.0.0+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+--+-- @since 0.1.0.0+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+--+-- @since 0.1.0.0+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+--+-- @since 0.1.0.0+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+--+-- @since 0.1.0.0+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+--+-- @since 0.3+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.+--+-- @since 0.3.7+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+--+-- @since 0.1.0.0+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+--+-- @since 0.1.0.0+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+--+-- @since 0.1.0.0+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+--+-- @since 0.1.0.0+gsize :: Data a => a -> Int+gsize t = 1 + sum (gmapQ gsize t)+++-- | Count the number of immediate subterms of the given term+--+-- @since 0.1.0.0+glength :: GenericQ Int+glength = length . gmapQ (const ())+++-- | Determine depth of the given term+--+-- @since 0.1.0.0+gdepth :: GenericQ Int+gdepth = (+) 1 . foldr max 0 . gmapQ gdepth+++-- | Determine the number of all suitable nodes in a given term+--+-- @since 0.1.0.0+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+--+-- @since 0.1.0.0+gnodecount :: GenericQ Int+gnodecount = gcount (const True)+++-- | Determine the number of nodes of a given type in a given term+--+-- @since 0.1.0.0+gtypecount :: Typeable a => a -> GenericQ Int+gtypecount (_::a) = gcount (False `mkQ` (\(_::a) -> True))+++-- | Find (unambiguously) an immediate subterm of a given type+--+-- @since 0.1.0.0+gfindtype :: (Data x, Typeable y) => x -> Maybe y+gfindtype = singleton+ . foldl unJust []+ . gmapQ (Nothing `mkQ` Just)+ where+ unJust l (Just x) = x:l+ unJust l Nothing = l+ singleton [s] = Just s+ singleton _ = Nothing
src/Data/Generics/Text.hs view
@@ -1,130 +1,148 @@-{-# 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 <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module --- provides generic operations for text serialisation of terms. --- ------------------------------------------------------------------------------ - -module Data.Generics.Text ( - - -- * Generic show - gshow, gshows, - - -- * Generic read - gread - - ) where - ------------------------------------------------------------------------------- - -#ifdef __HADDOCK__ -import Prelude -#endif -import Control.Monad -import Data.Data -import Data.Generics.Aliases -import Text.ParserCombinators.ReadP - ------------------------------------------------------------------------------- - - --- | Generic show: an alternative to \"deriving Show\" -gshow :: Data a => a -> String -gshow x = gshows x "" - --- | Generic shows -gshows :: Data a => a -> ShowS - --- This is a prefix-show using surrounding "(" and ")", --- where we recurse into subterms with gmapQ. -gshows = ( \t -> - showChar '(' - . (showString . showConstr . toConstr $ t) - . (foldr (.) id . gmapQ ((showChar ' ' .) . gshows) $ t) - . showChar ')' - ) `extQ` (shows :: String -> ShowS) - - --- | Generic read: an alternative to \"deriving Read\" -gread :: Data a => ReadS a - -{- - -This is a read operation which insists on prefix notation. (The -Haskell 98 read deals with infix operators subject to associativity -and precedence as well.) We use fromConstrM to "parse" the input. To be -precise, fromConstrM is used for all types except String. The -type-specific case for String uses basic String read. - --} - -gread = readP_to_S gread' - - where - - -- Helper for recursive read - gread' :: Data a' => ReadP a' - gread' = allButString `extR` stringCase - - where - - -- A specific case for strings - stringCase :: ReadP String - stringCase = readS_to_P reads - - -- Determine result type - myDataType = dataTypeOf (getArg allButString) - where - getArg :: ReadP a'' -> a'' - getArg = undefined - - -- The generic default for gread - allButString = - do - -- Drop " ( " - skipSpaces -- Discard leading space - _ <- char '(' -- Parse '(' - skipSpaces -- Discard following space - - -- Do the real work - str <- parseConstr -- Get a lexeme for the constructor - con <- str2con str -- Convert it to a Constr (may fail) - x <- fromConstrM gread' con -- Read the children - - -- Drop " ) " - skipSpaces -- Discard leading space - _ <- char ')' -- Parse ')' - skipSpaces -- Discard following space - - return x - - -- Turn string into constructor driven by the requested result type, - -- failing in the monad if it isn't a constructor of this data type - str2con :: String -> ReadP Constr - str2con = maybe mzero return - . readConstr myDataType - - -- Get a Constr's string at the front of an input string - parseConstr :: ReadP String - parseConstr = - string "[]" -- Compound lexeme "[]" - <++ string "()" -- singleton "()" - <++ infixOp -- Infix operator in parantheses - <++ readS_to_P lex -- Ordinary constructors and literals - - -- Handle infix operators such as (:) - infixOp :: ReadP String - infixOp = do c1 <- char '(' - str <- munch1 (not . (==) ')') - c2 <- char ')' - return $ [c1] ++ str ++ [c2] +{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Generics.Text+-- Copyright : (c) The University of Glasgow, CWI 2001--2003+-- License : BSD-style (see the LICENSE file)+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable (uses Data.Generics.Basics)+--+-- \"Scrap your boilerplate\" --- Generic programming in Haskell+-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module+-- provides generic operations for text serialisation of terms.+--+-----------------------------------------------------------------------------++module Data.Generics.Text (++ -- * Generic show+ gshow, gshows, gshowsF,++ -- * 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'.+--+-- @since 0.1.0.0+gshow :: Data a => a -> String+gshow x = gshows x ""++-- | Generic 'shows'.+--+-- @since 0.2+gshows :: Data a => a -> ShowS++-- This is a prefix-show using surrounding "(" and ")",+-- where we recurse into subterms with gmapQ.+gshows = gshowsF gshows++-- | Generic 'shows' but allowing the user to change cases.+gshowsF :: Data b => (forall a. Data a => a -> ShowS) -> b -> ShowS+gshowsF fun = ( \t ->+ showChar '('+ . (showString . showConstr . toConstr $ t)+ . (foldr (.) id . gmapQ ((showChar ' ' .) . fun) $ t)+ . showChar ')'+ ) `extQ` (shows :: String -> ShowS)++-- | Generic 'reads' (not 'read'): an alternative to @deriving@ 'Read'.+--+-- @since 0.1.0.0+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+ <++ negativeNumber -- prefix "-" and number literal+ <++ 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]++ -- Handle negative number literals+ negativeNumber :: ReadP String+ negativeNumber = do c1 <- char '-'+ str <- hsLex+ return $ c1 : str
src/Data/Generics/Twins.hs view
@@ -16,6 +16,8 @@ -- ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-}+ module Data.Generics.Twins ( -- * Generic folds and maps that also accumulate@@ -34,7 +36,8 @@ -- * Typical twin traversals geq,- gzip+ gzip,+ gcompare ) where @@ -44,17 +47,15 @@ #ifdef __HADDOCK__ import Prelude #endif+import Control.Applicative (Const(..)) import Data.Data import Data.Generics.Aliases+import Data.Functor.Identity (Identity(..)) #ifdef __GLASGOW_HASKELL__ import Prelude hiding ( GT ) #endif -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative (Applicative(..))-#endif- ------------------------------------------------------------------------------ @@ -80,7 +81,8 @@ --------------------------------------------------------------} -- | gfoldl with accumulation-+--+-- @since 0.1.0.0 gfoldlAccum :: Data d => (forall e r. Data e => a -> c (e -> r) -> e -> (a, c r)) -> (forall g. a -> g -> (a, c g))@@ -97,18 +99,23 @@ -- | gmapT with accumulation+--+-- @since 0.1.0.0 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)+ in (a1, runIdentity d1) where- k a (ID c) d = let (a',d') = f a d- in (a', ID (c d'))- z a x = (a, ID x)+ k a (Identity c) d =+ let (a',d') = f a d+ in (a', Identity (c d'))+ z a x = (a, Identity x) -- | Applicative version+--+-- @since 0.2 gmapAccumA :: forall b d a. (Data d, Applicative a) => (forall e. Data e => b -> e -> (b, a e)) -> b -> d -> (b, a d)@@ -125,6 +132,8 @@ -- | gmapM with accumulation+--+-- @since 0.1.0.0 gmapAccumM :: (Data d, Monad m) => (forall e. Data e => a -> e -> (a, m e)) -> a -> d -> (a, m d)@@ -136,20 +145,25 @@ -- | gmapQl with accumulation+--+-- @since 0.1.0.0 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)+ in (a1, getConst r1) where- k a (CONST c) d = let (a', r) = f a d- in (a', CONST (c `o` r))- z a _ = (a, CONST r0)+ 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+--+-- @since 0.1.0.0 gmapAccumQr :: Data d => (r' -> r -> r) -> r@@ -164,6 +178,8 @@ -- | gmapQ with accumulation+--+-- @since 0.1.0.0 gmapAccumQ :: Data d => (forall e. Data e => a -> e -> (a,q)) -> a -> d -> (a, [q])@@ -178,14 +194,6 @@ ------------------------------------------------------------------------------ --- | 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 } @@ -199,17 +207,24 @@ -- | Twin map for transformation-gzipWithT :: GenericQ (GenericT) -> GenericQ (GenericT)+--+-- @since 0.1.0.0+gzipWithT :: GenericQ GenericT -> GenericQ GenericT gzipWithT f x y = case gmapAccumT perkid funs y of ([], c) -> c _ -> error "gzipWithT" where+ perkid :: Data b => [GenericT'] -> b -> ([GenericT'], b) perkid a d = (tail a, unGT (head a) d)++ funs :: [GenericT'] funs = gmapQ (\k -> GT (f k)) x -- | Twin map for monadic transformation+--+-- @since 0.1.0.0 gzipWithM :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m) gzipWithM f x y = case gmapAccumM perkid funs y of ([], c) -> c@@ -220,12 +235,16 @@ -- | Twin map for queries-gzipWithQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r])+--+-- @since 0.1.0.0+gzipWithQ :: forall r. GenericQ (GenericQ r) -> GenericQ (GenericQ [r]) gzipWithQ f x y = case gmapAccumQ perkid funs y of ([], r) -> r _ -> error "gzipWithQ" where+ perkid :: Data c => [GenericQ' b] -> c -> ([GenericQ' b], b) perkid a d = (tail a, unGQ (head a) d)+ funs :: [GenericQ' r] funs = gmapQ (\k -> GQ (f k)) x @@ -237,6 +256,8 @@ ------------------------------------------------------------------------------ -- | Generic equality: an alternative to \"deriving Eq\"+--+-- @since 0.1.0.0 geq :: Data a => a -> a -> Bool {-@@ -262,11 +283,35 @@ -- | Generic zip controlled by a function with type-specific branches+--+-- @since 0.1.0.0 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+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\"+--+-- @since 0.5+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 (\a -> gcompare' a) 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"
src/Generics/SYB.hs view
@@ -1,17 +1,17 @@------------------------------------------------------------------------------ --- | --- Module : Generics.SYB --- Copyright : (c) The University of Glasgow, CWI 2001--2004 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable (local universal quantification) --- --- Convenience alias for "Data.Generics". --- ------------------------------------------------------------------------------ - -module Generics.SYB (module Data.Generics) where - -import Data.Generics +-----------------------------------------------------------------------------+-- |+-- Module : Generics.SYB+-- Copyright : (c) The University of Glasgow, CWI 2001--2004+-- License : BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable (local universal quantification)+--+-- Convenience alias for "Data.Generics".+--+-----------------------------------------------------------------------------++module Generics.SYB (module Data.Generics) where++import Data.Generics
src/Generics/SYB/Aliases.hs view
@@ -1,17 +1,17 @@------------------------------------------------------------------------------ --- | --- Module : Generics.SYB.Aliases --- Copyright : (c) The University of Glasgow, CWI 2001--2004 --- License : BSD-style (see the LICENSE file) --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable (local universal quantification) --- --- Convenience alias for "Data.Generics.Aliases". --- ------------------------------------------------------------------------------ - -module Generics.SYB.Aliases (module Data.Generics.Aliases) where - -import Data.Generics.Aliases +-----------------------------------------------------------------------------+-- |+-- Module : Generics.SYB.Aliases+-- Copyright : (c) The University of Glasgow, CWI 2001--2004+-- License : BSD-style (see the LICENSE file)+-- +-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable (local universal quantification)+--+-- Convenience alias for "Data.Generics.Aliases".+--+-----------------------------------------------------------------------------++module Generics.SYB.Aliases (module Data.Generics.Aliases) where++import Data.Generics.Aliases
src/Generics/SYB/Basics.hs view
@@ -1,17 +1,17 @@------------------------------------------------------------------------------ --- | --- Module : Generics.SYB.Basics --- Copyright : (c) The University of Glasgow, CWI 2001--2004 --- License : BSD-style (see the LICENSE file) --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable (local universal quantification) --- --- Convenience alias for "Data.Generics.Basics". --- ------------------------------------------------------------------------------ - -module Generics.SYB.Basics (module Data.Generics.Basics) where - -import Data.Generics.Basics +-----------------------------------------------------------------------------+-- |+-- Module : Generics.SYB.Basics+-- Copyright : (c) The University of Glasgow, CWI 2001--2004+-- License : BSD-style (see the LICENSE file)+-- +-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable (local universal quantification)+--+-- Convenience alias for "Data.Generics.Basics".+--+-----------------------------------------------------------------------------++module Generics.SYB.Basics (module Data.Generics.Basics) where++import Data.Generics.Basics
src/Generics/SYB/Builders.hs view
@@ -1,17 +1,17 @@------------------------------------------------------------------------------ --- | --- Module : Generics.SYB.Builders --- Copyright : (c) The University of Glasgow, CWI 2001--2004 --- License : BSD-style (see the LICENSE file) --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable (local universal quantification) --- --- Convenience alias for "Data.Generics.Builders". --- ------------------------------------------------------------------------------ - -module Generics.SYB.Builders (module Data.Generics.Builders) where - -import Data.Generics.Builders +-----------------------------------------------------------------------------+-- |+-- Module : Generics.SYB.Builders+-- Copyright : (c) The University of Glasgow, CWI 2001--2004+-- License : BSD-style (see the LICENSE file)+-- +-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable (local universal quantification)+--+-- Convenience alias for "Data.Generics.Builders".+--+-----------------------------------------------------------------------------++module Generics.SYB.Builders (module Data.Generics.Builders) where++import Data.Generics.Builders
src/Generics/SYB/Instances.hs view
@@ -1,17 +1,17 @@------------------------------------------------------------------------------ --- | --- Module : Generics.SYB.Instances --- Copyright : (c) The University of Glasgow, CWI 2001--2004 --- License : BSD-style (see the LICENSE file) --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable (local universal quantification) --- --- Convenience alias for "Data.Generics.Instances". --- ------------------------------------------------------------------------------ - -module Generics.SYB.Instances () where - -import Data.Generics.Instances () +-----------------------------------------------------------------------------+-- |+-- Module : Generics.SYB.Instances+-- Copyright : (c) The University of Glasgow, CWI 2001--2004+-- License : BSD-style (see the LICENSE file)+-- +-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable (local universal quantification)+--+-- Convenience alias for "Data.Generics.Instances".+--+-----------------------------------------------------------------------------++module Generics.SYB.Instances () where++import Data.Generics.Instances ()
src/Generics/SYB/Schemes.hs view
@@ -1,17 +1,17 @@------------------------------------------------------------------------------ --- | --- Module : Generics.SYB.Schemes --- Copyright : (c) The University of Glasgow, CWI 2001--2004 --- License : BSD-style (see the LICENSE file) --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable (local universal quantification) --- --- Convenience alias for "Data.Generics.Schemes". --- ------------------------------------------------------------------------------ - -module Generics.SYB.Schemes (module Data.Generics.Schemes) where - -import Data.Generics.Schemes +-----------------------------------------------------------------------------+-- |+-- Module : Generics.SYB.Schemes+-- Copyright : (c) The University of Glasgow, CWI 2001--2004+-- License : BSD-style (see the LICENSE file)+-- +-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable (local universal quantification)+--+-- Convenience alias for "Data.Generics.Schemes".+--+-----------------------------------------------------------------------------++module Generics.SYB.Schemes (module Data.Generics.Schemes) where++import Data.Generics.Schemes
src/Generics/SYB/Text.hs view
@@ -1,17 +1,17 @@------------------------------------------------------------------------------ --- | --- Module : Generics.SYB.Text --- Copyright : (c) The University of Glasgow, CWI 2001--2004 --- License : BSD-style (see the LICENSE file) --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable (local universal quantification) --- --- Convenience alias for "Data.Generics.Text". --- ------------------------------------------------------------------------------ - -module Generics.SYB.Text (module Data.Generics.Text) where - -import Data.Generics.Text +-----------------------------------------------------------------------------+-- |+-- Module : Generics.SYB.Text+-- Copyright : (c) The University of Glasgow, CWI 2001--2004+-- License : BSD-style (see the LICENSE file)+-- +-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable (local universal quantification)+--+-- Convenience alias for "Data.Generics.Text".+--+-----------------------------------------------------------------------------++module Generics.SYB.Text (module Data.Generics.Text) where++import Data.Generics.Text
src/Generics/SYB/Twins.hs view
@@ -1,17 +1,17 @@------------------------------------------------------------------------------ --- | --- Module : Generics.SYB.Twins --- Copyright : (c) The University of Glasgow, CWI 2001--2004 --- License : BSD-style (see the LICENSE file) --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable (local universal quantification) --- --- Convenience alias for "Data.Generics.Twins". --- ------------------------------------------------------------------------------ - -module Generics.SYB.Twins (module Data.Generics.Twins) where - -import Data.Generics.Twins +-----------------------------------------------------------------------------+-- |+-- Module : Generics.SYB.Twins+-- Copyright : (c) The University of Glasgow, CWI 2001--2004+-- License : BSD-style (see the LICENSE file)+-- +-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable (local universal quantification)+--+-- Convenience alias for "Data.Generics.Twins".+--+-----------------------------------------------------------------------------++module Generics.SYB.Twins (module Data.Generics.Twins) where++import Data.Generics.Twins
syb.cabal view
@@ -1,11 +1,11 @@ name: syb-version: 0.4.4+version: 0.7.4 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+maintainer: Sergey Vinokurov <serg.foo@gmail.com>+homepage: https://github.com/dreixel/syb+bug-reports: https://github.com/dreixel/syb/issues synopsis: Scrap Your Boilerplate description: This package contains the generics system described in the@@ -18,10 +18,25 @@ category: Generics stability: provisional build-type: Simple-cabal-version: >= 1.8+cabal-version: >= 1.10+tested-with:+ GHC == 9.14+ GHC == 9.12+ GHC == 9.10+ GHC == 9.8+ GHC == 9.6+ GHC == 9.4+ GHC == 9.2+ GHC == 9.0+ GHC == 8.10+ GHC == 8.8+ GHC == 8.6+ GHC == 8.4+ GHC == 8.2+ GHC == 8.0 -extra-source-files: tests/*.hs,- README+extra-source-files: README.md,+ Changelog.md source-repository head type: git@@ -29,36 +44,72 @@ 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,+ default-language: Haskell98+ build-depends: base >= 4.9 && < 5+ exposed-modules: Data.Generics+ Data.Generics.Basics+ Data.Generics.Instances+ Data.Generics.Aliases+ Data.Generics.Schemes+ Data.Generics.Text+ Data.Generics.Twins+ Data.Generics.Builders - Generics.SYB,- Generics.SYB.Basics,- Generics.SYB.Instances,- Generics.SYB.Aliases,- Generics.SYB.Schemes,- Generics.SYB.Text,- Generics.SYB.Twins,+ Generics.SYB+ 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+ ghc-options: -Wall -Wcompat test-suite unit-tests type: exitcode-stdio-1.0 hs-source-dirs: tests+ default-language: Haskell98 main-is: Main.hs build-depends: base , syb- , HUnit+ , tasty+ , tasty-hunit , containers , mtl+ other-modules: Bits+ Builders+ CompanyDatatypes+ Datatype+ Encode+ Ext+ Ext1+ Ext2+ FoldTree+ FreeNames+ GEq+ GMapQAssoc+ GRead+ GRead2+ GShow+ GShow2+ GZip+ GenUpTo+ GetC+ HList+ HOPat+ Labels+ LocalQuantors+ NestedDatatypes+ Newtype+ Paradise+ Perm+ Polymatch+ Reify+ Strings+ Tree+ Twin+ Typecase1+ Typecase2+ Where+ XML
tests/Bits.hs view
@@ -1,9 +1,9 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE DeriveDataTypeable #-} 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@@ -34,7 +34,7 @@ -} -import Test.HUnit+import Test.Tasty.HUnit import Data.Generics import Data.Char@@ -70,7 +70,7 @@ varNat2bin x = ( ( if even x then Zero else One ) : varNat2bin (x `div` 2)- ) + ) -- Encode a natural as a bit stream of fixed length@@ -79,7 +79,7 @@ fixedNat2bin p x | p>0 = ( ( if even x then Zero else One ) : fixedNat2bin (p - 1) (x `div` 2)- ) + ) -- Decode a natural@@ -134,7 +134,7 @@ fmap = liftM instance Applicative ReadB where- pure = return+ pure a = ReadB (\bs -> (Just a, bs)) (<*>) = ap instance Alternative ReadB where@@ -143,7 +143,7 @@ -- It's a monad. instance Monad ReadB where- return a = ReadB (\bs -> (Just a, bs))+ return = pure (ReadB c) >>= f = ReadB (\bs -> case c bs of (Just a, bs') -> unReadB (f a) bs' (Nothing, bs') -> (Nothing, bs')@@ -197,7 +197,7 @@ max :: Int max = maxConstrIndex myDataType - -- Convert a bit stream into a constructor + -- Convert a bit stream into a constructor bin2con :: Bin -> Constr bin2con bin = indexConstr myDataType ((bin2nat bin) + 1) @@ -217,8 +217,8 @@ , ( showBin (1::Int) , ( showBin "1" , ( showBin genCom- , ( geq genCom genCom' - )))))) ~=? output+ , ( geq genCom genCom'+ )))))) @=? output where genCom' = fromJust (fst (unReadB readBin (showBin genCom))) :: Company
tests/Builders.hs view
@@ -1,20 +1,17 @@-{-# 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 - +module Builders (tests) where++import Test.Tasty.HUnit++import Data.Generics.Builders+++-- Main function for testing+tests :: Assertion+tests = ( constrs :: [Maybe Int]+ , constrs :: [String]+ , constrs :: [Either Int Double]+ , constrs :: [((), Integer)]+ ) @=? output++output :: ([Maybe Int], [String], [Either Int Double], [((), Integer)]) output = ([Nothing,Just 0],["","\NUL"],[Left 0,Right 0.0],[((),0)])
tests/CompanyDatatypes.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE DeriveDataTypeable #-} module CompanyDatatypes where @@ -11,7 +11,7 @@ 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)+data Salary = S Double deriving (Eq, Show, Typeable, Data) type Manager = Employee type Name = String type Address = String
tests/Datatype.hs view
@@ -1,34 +1,58 @@-{-# 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 -myTyCon = typeRepTyCon myTypeRep -- type constructor via Typeable -myDataType = dataTypeOf myTerm -- datatype representation in Data -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 - +{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- These are simple tests to observe (data)type representations.+module Datatype where++import Test.Tasty.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__ >= 904+-- In GHC 9.4 module name is included output = "(MyDataType Int,(DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]},(\"\",(\"MyDataType\",(\"Datatype\",\"MyDataType\")))))"+# elif __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
tests/Encode.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-} -- A bit more test code for the 2nd boilerplate paper. -- These are downscaled versions of library functionality or real test cases.@@ -67,11 +68,10 @@ instance Functor EncM where fmap = liftM instance Applicative EncM where- pure = return+ pure = undefined (<*>) = ap-instance Monad EncM- where- return = undefined+instance Monad EncM where+ return = pure c >>= f = undefined runEnc :: EncM () -> [Bit]@@ -84,5 +84,5 @@ data2bits'' t = runEnc (emit t) emit :: Data a => a -> EncM ()-emit t = do { emitCon (dataTypeOf t) (toConstr t) +emit t = do { emitCon (dataTypeOf t) (toConstr t) ; sequence_ (gmapQ emit t) }
tests/Ext.hs view
@@ -1,30 +1,28 @@-{-# 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) +module Ext () where++-- There were typos in these definitions in the ICFP 2004 paper.++import Data.Generics++extQ fn spec_fn arg+ = case gcast (Q spec_fn) of+ Just (Q spec_fn') -> spec_fn' arg+ Nothing -> fn arg++newtype Q r a = Q (a -> r)++extT fn spec_fn arg+ = case gcast (T spec_fn) of+ Just (T spec_fn') -> spec_fn' arg+ Nothing -> fn arg++newtype T a = T (a -> a)++extM :: (Typeable a, Typeable b)+ => (a -> m a) -> (b -> m b) -> (a -> m a)+extM fn spec_fn+ = case gcast (M spec_fn) of+ Just (M spec_fn') -> spec_fn'+ Nothing -> fn++newtype M m a = M (a -> m a)
tests/Ext1.hs view
@@ -1,5 +1,6 @@-{-# OPTIONS -fglasgow-exts #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-} module Ext1 (tests) where @@ -9,25 +10,16 @@ -} -import Test.HUnit+import Test.Tasty.HUnit import Data.Generics-#if MIN_VERSION_base(4,8,0)-import GHC.Base hiding(foldr)-#else-import GHC.Base-#endif+import GHC.Exts (unsafeCoerce#)+import GHC.Base hiding (foldr) -- 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)@@ -36,13 +28,17 @@ extListQ' def ext d = if isList d then ext (unsafeCoerce d)- else def d + else def d -- Test extListQ' foo1 :: Data d => d -> Int foo1 = const 0 `extListQ'` length++t1 :: Int t1 = foo1 True -- should count as 0++t2 :: Int t2 = foo1 [True,True] -- should count as 2 @@ -54,7 +50,7 @@ extListQ'' def ext d = if isList d then undefined -- hard to avoid an ambiguous type- else def d + else def d -- Test extListQ from Data.Generics.Aliases@@ -64,7 +60,10 @@ list :: Data a => [a] -> Int list l = foldr (+) 0 $ map glength l +t3 :: Int t3 = foo2 (True,True) -- should count as 0++t4 :: Int t4 = foo2 [(True,True),(True,True)] -- should count as 2+2=4 @@ -74,7 +73,10 @@ then foldr (+) 0 $ gmapListQ glength x else 0 +t5 :: Int t5 = foo3 (True,True) -- should count as 0++t6 :: Int t6 = foo3 [(True,True),(True,True)] -- should count as 2+2=4 @@ -97,7 +99,7 @@ -- 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 + if not $ isList x then error "gmapListQ" else if isNil x then []@@ -105,24 +107,15 @@ 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 :: Assertion tests = ( t1 , ( t2 , ( t3 , ( t4 , ( t5 , ( t6- )))))) ~=? output+ )))))) @=? output +output :: (Int, (Int, (Int, (Int, (Int, Int))))) output = (0,(2,(0,(4,(0,4)))))
tests/Ext2.hs view
@@ -1,65 +1,65 @@-{-# LANGUAGE DeriveDataTypeable #-} - -module Ext2 (tests) where - --- Tests for ext2 and friends - -import Test.HUnit -import Data.Generics - - --- A type of lists -data List a = Nil | Cons a (List a) deriving (Data, Typeable, Show, Eq) - --- Example lists -l1, l2 :: List Int -l1 = Cons 1 (Cons 2 Nil) -l2 = Cons 0 l1 - --- A type of pairs -data Pair a b = Pair1 a b | Pair2 a b deriving (Data, Typeable, Show, Eq) - --- Example pairs -p1, p2 :: Pair Int Char -p1 = Pair1 2 'p' -p2 = Pair2 3 'q' - --- Structures containing the above -s1 :: [Pair Int Char] -s1 = [p1, p2] - -s2 :: (Pair Int Char, List Int) -s2 = (p2, l2) - - --- Auxiliary functions -unifyPair :: Pair a b -> Pair a b -> Bool -unifyPair (Pair1 _ _) (Pair1 _ _) = True -unifyPair (Pair2 _ _) (Pair2 _ _) = True -unifyPair _ _ = False - -flipPair :: Pair a b -> Pair a b -flipPair (Pair1 a b) = Pair2 a b -flipPair (Pair2 a b) = Pair1 a b - --- Tests -t1 = everywhere (id `ext2T` flipPair) (s1,s2) -t2 = let f :: (Data a) => a -> Maybe a - f = (const Nothing) `ext2M` (Just . flipPair) - in (f p1, f l1) -t3 = everything (+) ( const 0 - `ext1Q` (const 1 :: List a -> Int) - `ext2Q` (const 10 :: Pair a b -> Int)) - $ s2 -t4 = unifyPair (t4' :: Pair Int Char) t4' where - t4' :: Data a => a - t4' = undefined `ext1B` Nil `ext2B` (Pair1 undefined undefined) - - --- Main function for testing -tests = (t1, t2, t3, t4) ~=? output - -output = ((map flipPair s1, (flipPair p2, l2)) - ,(Just (flipPair p1),Nothing) - ,14 - ,True) +{-# LANGUAGE DeriveDataTypeable #-}++module Ext2 (tests) where++-- Tests for ext2 and friends++import Test.Tasty.HUnit+import Data.Generics+++-- A type of lists+data List a = Nil | Cons a (List a) deriving (Data, Typeable, Show, Eq)++-- Example lists+l1, l2 :: List Int+l1 = Cons 1 (Cons 2 Nil)+l2 = Cons 0 l1++-- A type of pairs+data Pair a b = Pair1 a b | Pair2 a b deriving (Data, Typeable, Show, Eq)++-- Example pairs+p1, p2 :: Pair Int Char+p1 = Pair1 2 'p'+p2 = Pair2 3 'q'++-- Structures containing the above+s1 :: [Pair Int Char]+s1 = [p1, p2]++s2 :: (Pair Int Char, List Int)+s2 = (p2, l2)+++-- Auxiliary functions+unifyPair :: Pair a b -> Pair a b -> Bool+unifyPair (Pair1 _ _) (Pair1 _ _) = True+unifyPair (Pair2 _ _) (Pair2 _ _) = True+unifyPair _ _ = False++flipPair :: Pair a b -> Pair a b+flipPair (Pair1 a b) = Pair2 a b+flipPair (Pair2 a b) = Pair1 a b++-- Tests+t1 = everywhere (id `ext2T` flipPair) (s1,s2)+t2 = let f :: (Data a) => a -> Maybe a+ f = (const Nothing) `ext2M` (Just . flipPair)+ in (f p1, f l1)+t3 = everything (+) ( const 0+ `ext1Q` (const 1 :: List a -> Int)+ `ext2Q` (const 10 :: Pair a b -> Int))+ $ s2+t4 = unifyPair (t4' :: Pair Int Char) t4' where+ t4' :: Data a => a+ t4' = undefined `ext1B` Nil `ext2B` (Pair1 undefined undefined)+++-- Main function for testing+tests = (t1, t2, t3, t4) @=? output++output = ((map flipPair s1, (flipPair p2, l2))+ ,(Just (flipPair p1),Nothing)+ ,14+ ,True)
tests/FoldTree.hs view
@@ -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.Tasty.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])"
tests/FreeNames.hs view
@@ -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"] +{-# LANGUAGE DeriveDataTypeable #-}++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.Tasty.HUnit++import Data.Generics+import Data.List++data System = S [Function] deriving (Typeable, Data)++data Function = F Name [Equation] deriving (Typeable, Data)++data Equation = E [Pattern] Expression System deriving (Typeable, Data)++data Pattern = PVar Name+ | PTerm Name [Pattern] deriving (Typeable, Data)++data Expression = Var Name+ | App Expression Expression+ | Lambda Name Expression deriving (Typeable, Data)++type Name = String++-- A little sample program++sys1 = S [f1,f2]+f1 = F "f1" [e11]+f2 = F "f2" [e21,e22]+e11 = E [] (Var "id") (S [])+e21 = E [ PTerm "C" [ PVar "x" ] ] (Var "x") (S [])+e22 = E [] (Var "id") (S [])+++-- Names declared in an expression+decsExpr :: Expression -> [Name]+decsExpr (Lambda n _) = [n]+decsExpr _ = []++-- Names declared in an equation+decsEqua :: Equation -> [Name]+decsEqua (E ps _ _) = everything union ([] `mkQ` pvar) ps+ where+ pvar (PVar n) = [n]+ pvar _ = []++-- Names declared in a system+decsSyst :: System -> [Name]+decsSyst (S l) = nub $ map (\(F n _) -> n) l++-- Names referenced in an expression+refsExpr :: Expression -> [Name]+refsExpr (Var n) = [n]++-- Names referenced in an equation+refsEqua :: Equation -> [Name]+refsEqua (E ps _ _) = everything union ([] `mkQ` pterm) ps+ where+ pterm (PTerm n _) = [n]+ pterm _ = []++-- Combine the above type-specific cases to obtain+-- generic functions that find declared and referenced names+--+decsFun :: Data a => a -> [Name]+decsFun = const [] `extQ` decsExpr `extQ` decsEqua `extQ` decsSyst++refsFun :: Data a => a -> [Name]+refsFun = const [] `extQ` refsExpr `extQ` refsEqua++++{-++Free name analysis: Take the union of free names obtained from the+immediate subterms (via gmapQ) and the names being referred to at the+root of the present term, but subtract all the names that are declared+at the root.++-}++freeNames :: Data a => a -> [Name]+freeNames x = ( (refsFun x)+ `union`+ (nub . concat . gmapQ freeNames) x+ ) \\ decsFun x++{-++Print the free names for the sample program sys1; see module+FunDatatypes.hs. This should print the list ["id","C"] because the+"Prelude" function "id" is used in the sample program, and also the+term constructor "C" occurs in a pattern; we assume a language without+explicit datatype declarations ;-)++-}++tests = freeNames sys1 @=? output++output = ["id","C"]
tests/GEq.hs view
@@ -1,21 +1,21 @@-{-# OPTIONS -fglasgow-exts #-} - -module GEq (tests) where - -{- - -This test exercices GENERIC read, show, and eq for the company -datatypes which we use a lot. The output of the program should be -"True" which means that "gread" reads what "gshow" shows while the -read term is equal to the original term in terms of "geq". - --} - -import Test.HUnit - -import Data.Generics -import CompanyDatatypes - -tests = ( geq genCom genCom - , geq genCom genCom' - ) ~=? (True,False) +{-# LANGUAGE DeriveDataTypeable #-}++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.Tasty.HUnit++import Data.Generics+import CompanyDatatypes++tests = ( geq genCom genCom+ , geq genCom genCom'+ ) @=? (True,False)
tests/GMapQAssoc.hs view
@@ -1,68 +1,69 @@-{-# 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]]) +{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}++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.Tasty.HUnit++import Data.Generics+++-- The plain constant type constructor+newtype CONST x y = CONST x+unCONST (CONST x) = x+++-- A variation on the gmapQ combinator using CONST and not Q+gmapQ' :: Data a => (forall a. Data a => a -> u) -> a -> [u]+gmapQ' f = unCONST . gfoldl f' z+ where+ f' r a = CONST (f a : unCONST r)+ z = const (CONST [])+++-- A trivial datatype used for this test case+data IntTree = Leaf Int | Fork IntTree IntTree+ deriving (Typeable, Data)+++-- Select int if faced with a leaf+leaf (Leaf i) = [i]+leaf _ = []+++-- A test term+term = Fork (Leaf 1) (Leaf 2)+++-- Process test term+-- gmapQ gives left-to-right order+-- gmapQ' gives right-to-left order+--+tests = show ( gmapQ ([] `mkQ` leaf) term+ , gmapQ' ([] `mkQ` leaf) term+ ) @=? output++output = show ([[1],[2]],[[2],[1]])
tests/GRead.hs view
@@ -1,5 +1,3 @@-{-# OPTIONS -fglasgow-exts #-}- module GRead (tests) where {-@@ -12,34 +10,46 @@ -} -import Test.HUnit+import Test.Tasty.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 ++ ")"+str1, str2, str3, str4, str4a, str5, str6, str7 :: String+str1 = "(True)" -- reads fine as a Bool+str2 = "(Treu)" -- invalid constructor+str3 = "True" -- lacks parentheses+str4 = "(1)" -- could be an Int+str4a = "(-1)" -- negative literal+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+expected ::+ ( [[(Bool, String)]]+ , [[(Int, String)]]+ , [[([Int], String)]]+ )+expected =+ ( [ gread str1,+ gread str2,+ gread str3+ ]+ , [ gread str4,+ gread str4a,+ gread str5+ ]+ , [ gread str6,+ gread str7+ ]+ ) -output = show- ([[(True,"")],[],[]],[[(1,"")],[(2,"...")]],[[([],"")],[([1],"")]])+tests :: Assertion+tests = show expected @=? show output++output ::+ ( [[(Bool, String)]]+ , [[(Int, String)]]+ , [[([Int], String)]]+ )+output =+ ([[(True,"")],[],[]],[[(1,"")],[(-1,"")],[(2,"...")]],[[([],"")],[([1],"")]])
tests/GRead2.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-} module GRead2 () where @@ -24,17 +25,17 @@ fmap = liftM instance Applicative DecM where- pure = return+ pure a = D (\s -> Just (s,a)) (<*>) = ap instance Monad DecM where- return a = D (\s -> Just (s,a))+ return = pure (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
tests/GShow.hs view
@@ -1,52 +1,52 @@-{-# OPTIONS -fglasgow-exts #-} - -module GShow (tests) where - -{- - -The generic show example from the 2nd boilerplate paper. -(There were some typos in the ICFP 2004 paper.) -Also check out Data.Generics.Text. - --} - -import Test.HUnit - -import Data.Generics hiding (gshow) -import Prelude hiding (showString) - - -gshow :: Data a => a -> String -gshow = gshow_help `extQ` showString - -gshow_help :: Data a => a -> String -gshow_help t - = "(" - ++ showConstr (toConstr t) - ++ concat (intersperse " " (gmapQ gshow t)) - ++ ")" - -showString :: String -> String -showString s = "\"" ++ concat (map escape s) ++ "\"" - where - escape '\n' = "\\n" - escape other_char = [other_char] - -gshowList :: Data b => [b] -> String -gshowList xs - = "[" ++ concat (intersperse "," (map gshow xs)) ++ "]" - -gshow' :: Data a => a -> String -gshow' = gshow_help `ext1Q` gshowList - `extQ` showString - -intersperse :: a -> [a] -> [a] -intersperse _ [] = [] -intersperse x [e] = [e] -intersperse x (e:es) = (e:(x:intersperse x es)) - -tests = ( gshow' "foo" - , gshow' [True,False] - ) ~=? output - -output = ("\"foo\"","[(True),(False)]") +{-# LANGUAGE DeriveDataTypeable #-}++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.Tasty.HUnit++import Data.Generics hiding (gshow)+import Prelude hiding (showString)+++gshow :: Data a => a -> String+gshow = gshow_help `extQ` showString++gshow_help :: Data a => a -> String+gshow_help t+ = "("+ ++ showConstr (toConstr t)+ ++ concat (intersperse " " (gmapQ gshow t))+ ++ ")"++showString :: String -> String+showString s = "\"" ++ concat (map escape s) ++ "\""+ where+ escape '\n' = "\\n"+ escape other_char = [other_char]++gshowList :: Data b => [b] -> String+gshowList xs+ = "[" ++ concat (intersperse "," (map gshow xs)) ++ "]"++gshow' :: Data a => a -> String+gshow' = gshow_help `ext1Q` gshowList+ `extQ` showString++intersperse :: a -> [a] -> [a]+intersperse _ [] = []+intersperse x [e] = [e]+intersperse x (e:es) = (e:(x:intersperse x es))++tests = ( gshow' "foo"+ , gshow' [True,False]+ ) @=? output++output = ("\"foo\"","[(True),(False)]")
tests/GShow2.hs view
@@ -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))) ([])) ([]))))" +{-# LANGUAGE DeriveDataTypeable #-}++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.Tasty.HUnit++import Data.Generics+import CompanyDatatypes++tests = gshow genCom @=? output++{-++Here is another exercise:+The following function gshow' is a completely generic variation on gshow.+It would print strings as follows:++*Main> gshow' "abc"+"((:) ('a') ((:) ('b') ((:) ('c') ([]))))"++The original gshow does a better job because it is customised for strings:++*Main> gshow "foo"+"\"foo\""++In fact, this is what Haskell's normal show would also do:++*Main> show "foo"+"\"foo\""++-}++gshow' :: Data a => a -> String+gshow' t = "("+ ++ showConstr (toConstr t)+ ++ concat (gmapQ ((++) " " . gshow') t)+ ++ ")"++output = "(C ((:) (D \"Research\" (E (P \"Laemmel\" \"Amsterdam\") (S (8000.0))) ((:) (PU (E (P \"Joost\" \"Amsterdam\") (S (1000.0)))) ((:) (PU (E (P \"Marlow\" \"Cambridge\") (S (2000.0)))) ([])))) ((:) (D \"Strategy\" (E (P \"Blair\" \"London\") (S (100000.0))) ([])) ([]))))"
tests/GZip.hs view
@@ -1,46 +1,47 @@-{-# 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)) []]) +{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}++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.Tasty.HUnit++import Data.Generics+import CompanyDatatypes++-- The main function which prints the result of zipping+tests = gzip (\x y -> mkTT maxS x y) genCom1 genCom2 @=? output+ -- NB: the argument has to be eta-expanded to match+ -- the type of gzip's argument type, which is+ -- GenericQ (GenericM Maybe)+ where++ -- Variations on the show case company "genCom"+ genCom1 = everywhere (mkT (double "Joost")) genCom+ genCom2 = everywhere (mkT (double "Marlow")) genCom+ double x (E p@(P y _) (S s)) | x == y = E p (S (2*s))+ double _ e = e++ -- Sum up two salaries+ maxS (S x) (S y) = S (max x y)++ -- Make a two-arguments, generic function transformer+ mkTT :: (Typeable a, Typeable b, Typeable c)+ => (a -> a -> a) -> b -> c -> Maybe c+ mkTT (f::a -> a -> a) x y =+ case (cast x,cast y) of+ (Just (x'::a),Just (y'::a)) -> cast (f x' y')+ _ -> Nothing++output = Just (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0))+ [PU (E (P "Joost" "Amsterdam") (S 2000.0))+ ,PU (E (P "Marlow" "Cambridge") (S 4000.0))]+ ,D "Strategy" (E (P "Blair" "London") (S 100000.0)) []])
tests/GenUpTo.hs view
@@ -1,94 +1,99 @@-{-# 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)])))) +{-# LANGUAGE DeriveDataTypeable #-}++{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-}++module GenUpTo (tests) where++{-++This example illustrate test-set generation,+namely all terms of a given depth are generated.++-}++import Test.Tasty.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, Data)++data Dec = Nodec+ | Ondec Id Type+ | Manydecs Dec Dec+ deriving (Show, Eq, Data)++data Id = A | B+ deriving (Show, Eq, Data)++data Type = Int | Bool+ deriving (Show, Eq, Data)++data Stat = Noop+ | Assign Id Exp+ | Seq Stat Stat+ deriving (Show, Eq, Data)++data Exp = Zero+ | Succ Exp+ deriving (Show, Eq, 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']+ NoRep -> []+ where+ ty = dataTypeOf (head result)+++-- For silly tests+data T0 = T0 T1 T2 T3 deriving (Show, Eq, Data)+data T1 = T1a | T1b deriving (Show, Eq, Data)+data T2 = T2a | T2b deriving (Show, Eq, Data)+data T3 = T3a | T3b deriving (Show, Eq, Data)++tests :: Assertion+tests = ( genUpTo 0 :: [Id]+ , ( genUpTo 1 :: [Id]+ , ( genUpTo 2 :: [Id]+ , ( genUpTo 2 :: [T0]+ , ( genUpTo 3 :: [Prog]+ ))))) @=? output++output :: ([a], ([Id], ([Id], ([T0], [Prog]))))+output = ([],([A,B],([A,B],([T0 T1a T2a T3a,T0 T1a T2a T3b,T0 T1a T2b T3a,T0 T1a T2b T3b,T0 T1b T2a T3a,T0 T1b T2a T3b,T0 T1b T2b T3a,T0 T1b T2b T3b],[Prog Nodec Noop,Prog Nodec (Assign A Zero),Prog Nodec (Assign B Zero),Prog Nodec (Seq Noop Noop),Prog (Ondec A Int) Noop,Prog (Ondec A Int) (Assign A Zero),Prog (Ondec A Int) (Assign B Zero),Prog (Ondec A Int) (Seq Noop Noop),Prog (Ondec A Bool) Noop,Prog (Ondec A Bool) (Assign A Zero),Prog (Ondec A Bool) (Assign B Zero),Prog (Ondec A Bool) (Seq Noop Noop),Prog (Ondec B Int) Noop,Prog (Ondec B Int) (Assign A Zero),Prog (Ondec B Int) (Assign B Zero),Prog (Ondec B Int) (Seq Noop Noop),Prog (Ondec B Bool) Noop,Prog (Ondec B Bool) (Assign A Zero),Prog (Ondec B Bool) (Assign B Zero),Prog (Ondec B Bool) (Seq Noop Noop),Prog (Manydecs Nodec Nodec) Noop,Prog (Manydecs Nodec Nodec) (Assign A Zero),Prog (Manydecs Nodec Nodec) (Assign B Zero),Prog (Manydecs Nodec Nodec) (Seq Noop Noop)]))))
tests/GetC.hs view
@@ -1,121 +1,132 @@-{-# 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 +{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}++{-# LANGUAGE CPP #-}+# if __GLASGOW_HASKELL__ <= 708+{-# LANGUAGE OverlappingInstances #-}+#endif++module GetC (tests) where++import Test.Tasty.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 {-# OVERLAPPABLE #-} 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 {-# OVERLAPPABLE #-} Data t => GetC t+ where+ getC y [] = Just $ toConstr y+ getC _ (_:_) = Nothing+++--+-- Type unification; we could try this:+-- class TypeUnify a b | a -> b, b -> a+-- instance TypeUnify a a+--+-- However, if the instance is placed in the present module,+-- then type improvement would inline this instance. Sigh!!!+--+-- So we need type unification with type improvement blocker+-- The following solution works with GHC for ages.+-- Other solutions; see the HList paper.+--++class TypeUnify a b | a -> b, b -> a+class TypeUnify' x a b | x a -> b, x b -> a+class TypeUnify'' x a b | x a -> b, x b -> a+instance TypeUnify' () a b => TypeUnify a b+instance TypeUnify'' x a b => TypeUnify' x a b+instance TypeUnify'' () a a
tests/HList.hs view
@@ -1,62 +1,52 @@-{-# 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 - +{-# LANGUAGE ExistentialQuantification #-}++module HList (tests) where++{-++This module illustrates heterogeneously typed lists.++-}++import Test.Tasty.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)++-- 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 :: HList+mylist = addHList (1::Int) $+ addHList (True::Bool) $+ addHList ("42"::String) $+ initHList++-- Main function for testing+tests :: Assertion+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 :: (String, (String, (String, String))) output = ("Just 1",("Nothing",("Just True","Just \"42\"")))
tests/HOPat.hs view
@@ -1,67 +1,68 @@-{-# 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) - +{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExplicitForAll #-}++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.Tasty.HUnit++import Data.Generics+++-- Sample datatypes+data T1 = T1a Int | T1b Double+ deriving (Show, Eq, Typeable, Data)+data T2 = T2a T1 T2 | T2b+ deriving (Show, Eq, Typeable, Data)++-- Eliminate a constructor if feasible+elim' :: (Data y, Data x) => Constr -> y -> Maybe x+elim' c y = if toConstr y == c+ then unwrap y+ else Nothing+++-- Unwrap a term; Return its single component+unwrap :: (Data y, Data x) => y -> Maybe x+unwrap y = case gmapQ (Nothing `mkQ` Just) y of+ [Just x] -> Just x+ _ -> Nothing+++-- Eliminate a constructor if feasible; 2nd try+elim :: forall x y. (Data y, Data x) => (x -> y) -> y -> Maybe x+elim c y = elim' (toConstr (c (undefined::x))) y+++-- Visit a data structure+visitor :: (Data x, Data y, Data z)+ => (x -> y) -> (x -> x) -> z -> z+visitor c f = everywhere (mkT g)+ where+ g y = case elim c y of+ Just x -> c (f x)+ Nothing -> y+++-- Main function for testing+tests = ( ( elim' (toConstr t1a) t1a) :: Maybe Int+ , ( (elim' (toConstr t1a) t1b) :: Maybe Int+ , ( (elim T1a t1a) :: Maybe Int+ , ( (elim T1a t1b) :: Maybe Int+ , ( (visitor T1a ((+) 46) t2) :: T2+ ))))) @=? output+ where+ t1a = T1a 42+ t1b = T1b 3.14+ t2 = T2a t1a (T2a t1a T2b)+ output = (Just 42,(Nothing,(Just 42,(Nothing,T2a (T1a 88) (T2a (T1a 88) T2b)))))
tests/Labels.hs view
@@ -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"]) +{-# LANGUAGE DeriveDataTypeable #-}++module Labels (tests) where++-- This module tests availability of field labels.++import Test.Tasty.HUnit++import Data.Generics++-- A datatype without labels+data NoLabels = NoLabels Int Double+ deriving (Typeable, Data)++-- A datatype with labels+data YesLabels = YesLabels { myint :: Int+ , myfloat :: Double+ }+ deriving (Typeable, Data)++-- Test terms+noLabels = NoLabels 42 3.14+yesLabels = YesLabels 42 3.14++-- Main function for testing+tests = ( constrFields $ toConstr noLabels+ , constrFields $ toConstr yesLabels+ ) @=? output++output = ([],["myint","myfloat"])
tests/LocalQuantors.hs view
@@ -1,21 +1,22 @@-{-# 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] +{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}++module LocalQuantors () where++-- A datatype with a locally quantified component+-- Seems to be too polymorphic to descend into structure!+-- Largely irrelevant?!++import Data.Generics++data Test = Test (GenericT) deriving Typeable++instance Data Test+ where+ gfoldl _ z x = z x -- folding without descent+ toConstr (Test _) = testConstr+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = testDataType++testConstr = mkConstr testDataType "Test" [] Prefix+testDataType = mkDataType "Main.Test" [testConstr]
tests/Main.hs view
@@ -1,82 +1,75 @@- -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.Tasty+import Test.Tasty.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++main = defaultMain $ testGroup "All"+ [ testCase "Datatype" Datatype.tests+ , testCase "FoldTree" FoldTree.tests+ , testCase "GetC" GetC.tests+ , testCase "GMapQAssoc" GMapQAssoc.tests+ , testCase "GRead" GRead.tests+ , testCase "GShow" GShow.tests+ , testCase "GShow2" GShow2.tests+ , testCase "HList" HList.tests+ , testCase "HOPat" HOPat.tests+ , testCase "Labels" Labels.tests+ , testCase "Newtype" Newtype.tests+ , testCase "Perm" Perm.tests+ , testCase "Twin" Twin.tests+ , testCase "Typecase1" Typecase1.tests+ , testCase "Typecase2" Typecase2.tests+ , testCase "Where" Where.tests+ , testCase "XML" XML.tests+ , testCase "Tree" Tree.tests+ , testCase "Strings" Strings.tests+ , testCase "Reify" Reify.tests+ , testCase "Paradise" Paradise.tests+ , testCase "GZip" GZip.tests+ , testCase "GEq" GEq.tests+ , testCase "GenUpTo" GenUpTo.tests+ , testCase "FreeNames" FreeNames.tests+ , testCase "Ext1" Ext1.tests+ , testCase "Ext2" Ext2.tests+ , testCase "Bits" Bits.tests+ , testCase "Builders" Builders.tests+ ]
tests/NestedDatatypes.hs view
@@ -1,43 +1,44 @@-{-# 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] +{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE UndecidableInstances #-}++module NestedDatatypes () where++{-++We provide an illustrative ScrapYourBoilerplate example for a nested+datatype. For clarity, we do not derive the Typeable and Data+instances by the deriving mechanism but we show the intended+definitions. The overall conclusion is that nested datatypes do not+pose any challenge for the ScrapYourBoilerplate scheme. Well, this is+maybe not quite true because it seems like we need to allow+undecidable instances.++-}++import Data.Dynamic+import Data.Generics+++-- A nested datatype+data Nest a = Box a | Wrap (Nest [a]) 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]
tests/Newtype.hs view
@@ -1,15 +1,20 @@-{-# OPTIONS -fglasgow-exts #-} - -module Newtype (tests) where - --- The type of a newtype should treat the newtype as opaque - -import Test.HUnit - -import Data.Generics - -newtype T = MkT Int deriving( Typeable ) - -tests = show (typeOf (undefined :: T)) ~=? output - -output = "T" +{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Newtype (tests) where++-- The type of a newtype should treat the newtype as opaque++import Test.Tasty.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
tests/Paradise.hs view
@@ -1,29 +1,27 @@-{-# 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)) []] +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.Tasty.HUnit++import Data.Generics+import CompanyDatatypes++-- Increase salary by percentage+increase :: Double -> Company -> Company+increase k = everywhere (mkT (incS k))++-- "interesting" code for increase+incS :: Double -> Salary -> Salary+incS k (S s) = S (s * (1+k))++tests = increase 0.125 genCom @=? output++output = C [D "Research" (E (P "Laemmel" "Amsterdam") (S 9000)) [PU (E (P "Joost" "Amsterdam") (S 1125)),PU (E (P "Marlow" "Cambridge") (S 2250))],D "Strategy" (E (P "Blair" "London") (S 112500)) []]
tests/Perm.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} module Perm (tests) where @@ -9,9 +11,9 @@ -} -import Test.HUnit+import Test.Tasty.HUnit -import Control.Applicative (Alternative(..), Applicative(..))+import Control.Applicative (Alternative(..)) import Control.Monad import Data.Generics @@ -19,9 +21,9 @@ -- 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)+data T1 = T1 deriving (Show, Eq, Data)+data T2 = T2 deriving (Show, Eq, Data)+data T3 = T3 T1 T2 deriving (Show, Eq, Data) ---------------------------------------------------------------------------@@ -34,22 +36,23 @@ -- Run a computation+runReadT :: ReadT a -> [String] -> Maybe a runReadT x y = case unReadT x y of- Just ([],y) -> Just y+ Just ([],z) -> Just z _ -> Nothing -- Read one string readT :: ReadT String-readT = ReadT (\x -> if null x- then Nothing- else Just (tail x, head x)+readT = ReadT (\x -> case x of+ [] -> Nothing+ y : ys -> Just (ys, y) ) instance Functor ReadT where fmap = liftM instance Applicative ReadT where- pure = return+ pure x = ReadT (\y -> Just (y,x)) (<*>) = ap instance Alternative ReadT where@@ -58,7 +61,7 @@ -- ReadT is a monad! instance Monad ReadT where- return x = ReadT (\y -> Just (y,x))+ return = pure c >>= f = ReadT (\x -> case unReadT c x of Nothing -> Nothing Just (x', a) -> unReadT (f a) x'@@ -97,7 +100,7 @@ -- Determine type of data to be constructed myType = myTypeOf result where- myTypeOf :: forall a. ReadT a -> a+ myTypeOf :: forall b. ReadT b -> b myTypeOf = undefined -- Turn string into constructor@@ -106,11 +109,11 @@ (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))+ buildT' :: forall b. Data b => b -> GenM+ buildT' (_::b) = GenM (const mzero `extM` const (buildT::ReadT b)) -- The permutation exploration function- perm :: forall a. Data a => [GenM] -> [GenM] -> a -> ReadT a+ perm :: forall b. Data b => [GenM] -> [GenM] -> b -> ReadT b perm [] [] a = return a perm fs [] a = perm [] fs a perm fs (f:fs') a = (@@ -128,12 +131,14 @@ -- The main function for testing --------------------------------------------------------------------------- +tests :: Assertion 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 +output :: (Maybe T1, (Maybe T2, (Maybe T3, (Maybe T3, Maybe a)))) output = (Just T1,(Just T2,(Just (T3 T1 T2),(Just (T3 T1 T2),Nothing))))
tests/Polymatch.hs view
@@ -1,70 +1,71 @@-{-# 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") +{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}++module Polymatch () where+++import Data.Typeable+import Data.Generics+++-- Representation of kids+kids x = gmapQ Kid x -- get all kids+type Kids = [Kid]+data Kid = forall k. Typeable k => Kid k+++-- Build term from a list of kids and the constructor+fromConstrL :: Data a => Kids -> Constr -> Maybe a+fromConstrL l = unIDL . gunfold k z+ where+ z c = IDL (Just c) l+ k (IDL Nothing _) = IDL Nothing undefined+ k (IDL (Just f) (Kid x:l)) = IDL f' l+ where+ f' = case cast x of+ (Just x') -> Just (f x')+ _ -> Nothing+++-- Helper datatype+data IDL x = IDL (Maybe x) Kids+unIDL (IDL mx _) = mx+++-- Two sample datatypes+data A = A String deriving (Read, Show, Eq, Data, Typeable)+data B = B String deriving (Read, Show, Eq, Data, Typeable)+++-- Mediate between two "left-equal" Either types+f :: (Data a, Data b, Show a, Read b)+ => (a->b) -> Either String a -> Either String b++f g (Right a) = Right $ g a -- conversion really needed+-- f g (Left s) = Left s -- unappreciated conversion+-- f g s = s -- doesn't typecheck+-- f g s = deep_rebuild s -- too expensive+f g s = just (shallow_rebuild s) -- perhaps this is Ok?+++-- Get rid of maybies+just = maybe (error "tried, but failed.") id+++-- Just mentioned for completeness' sake+deep_rebuild :: (Show a, Read b) => a -> b+deep_rebuild = read . show+++-- For the record: it's possible.+shallow_rebuild :: (Data a, Data b) => a -> Maybe b+shallow_rebuild a = b+ where+ b = fromConstrL (kids a) constr+ constr = indexConstr (dataTypeOf b) (constrIndex (toConstr a))+++-- Test cases+a2b (A s) = B s -- silly conversion+t1 = f a2b (Left "x") -- prints Left "x"+t2 = f a2b (Right (A "y")) -- prints Right (B "y")
tests/Reify.hs view
@@ -1,5 +1,8 @@-{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module Reify (tests) where {-@@ -10,7 +13,7 @@ -} -import Test.HUnit+import Test.Tasty.HUnit import Data.Maybe import Data.Generics@@ -92,7 +95,7 @@ -- Generic type functions, -- i.e., functions mapping types to values ---type GTypeFun r = forall a. Data a => TypeFun a r+type GTypeFun r = forall a. Data a => TypeFun a r @@ -354,7 +357,7 @@ -- For testing shallowTerm shallowTermBase :: GenericR Maybe shallowTermBase = Nothing- `extR` Just (1.23::Float)+ `extR` Just (1.23::Double) `extR` Just ("foo"::String) @@ -406,7 +409,7 @@ , ( test8 , ( test9 , ( test10- ))))))))))) ~=? output+ ))))))))))) @=? output output = (True,(True,(False,(True,(True,(1,(2,(3,(P "foo" "foo", (E (P "foo" "foo") (S 1.23),
tests/Strings.hs view
@@ -1,21 +1,19 @@-{-# 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 +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.Tasty.HUnit++import Data.Generics+import CompanyDatatypes++tests = (case gread (gshow genCom) of+ [(x,_)] -> geq genCom x+ _ -> False) @=? True
tests/Tree.hs view
@@ -1,62 +1,67 @@-{-# 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))) +{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-}++module Tree (tests) where++{-++This example illustrates serialisation and de-serialisation,+but we replace *series* by *trees* so to say.++-}++import Test.Tasty.HUnit++import Control.Monad (guard)+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 y =+ do guard (glength y == length ts)+ snd (gmapAccumM perkid ts y)+++-- Main function for testing+tests :: Assertion+tests = ( genCom+ , ( data2tree genCom+ , ( (tree2data (data2tree genCom)) :: Maybe Company+ , ( Just genCom == tree2data (data2tree genCom)+ )))) @=? output++output :: (Company, (Tree String, (Maybe Company, Bool)))+output = (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []],(Node {rootLabel = "C", subForest = [Node {rootLabel = "(:)", subForest = [Node {rootLabel = "D", subForest = [Node {rootLabel = "Research", subForest = []},Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Laemmel", subForest = []},Node {rootLabel = "Amsterdam", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "8000.0", subForest = []}]}]},Node {rootLabel = "(:)", subForest = [Node {rootLabel = "PU", subForest = [Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Joost", subForest = []},Node {rootLabel = "Amsterdam", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "1000.0", subForest = []}]}]}]},Node {rootLabel = "(:)", subForest = [Node {rootLabel = "PU", subForest = [Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Marlow", subForest = []},Node {rootLabel = "Cambridge", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "2000.0", subForest = []}]}]}]},Node {rootLabel = "[]", subForest = []}]}]}]},Node {rootLabel = "(:)", subForest = [Node {rootLabel = "D", subForest = [Node {rootLabel = "Strategy", subForest = []},Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Blair", subForest = []},Node {rootLabel = "London", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "100000.0", subForest = []}]}]},Node {rootLabel = "[]", subForest = []}]},Node {rootLabel = "[]", subForest = []}]}]}]},(Just (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []]),True)))
tests/Twin.hs view
@@ -1,90 +1,91 @@-{-# 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) +{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}++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.Tasty.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 a = geq' a++newtype GQ r = GQ (GenericQ r)++gzipWithQ :: GenericQ (GenericQ r)+ -> GenericQ (GenericQ [r])+gzipWithQ f t1 t2+ = gApplyQ (gmapQ (\x -> GQ (f x)) t1) t2++gApplyQ :: Data a => [GQ r] -> a -> [r]+gApplyQ qs t = reverse (snd (gfoldlQ k z t))+ where+ k :: ([GQ r], [r]) -> GenericQ ([GQ r], [r])+ k (GQ q : qs, rs) child = (qs, q child : rs)+ z = (qs, [])++newtype R r x = R { unR :: r }++gfoldlQ :: (r -> GenericQ r)+ -> r+ -> GenericQ r++gfoldlQ k z t = unR (gfoldl k' z' t)+ where+ z' _ = R z+ k' (R r) c = R (k r c)++-----------------------------------------------------------------------------++-- A dependently polymorphic geq+geq'' :: Data a => a -> a -> Bool+geq'' x y = toConstr x == toConstr y+ && and (gzipWithQ' geq'' x y)++-- A helper type for existentially quantified queries+data XQ r = forall a. Data a => XQ (a -> r)++-- A dependently polymorphic gzipWithQ+gzipWithQ' :: (forall a. Data a => a -> a -> r)+ -> (forall a. Data a => a -> a -> [r])+gzipWithQ' f t1 t2+ = gApplyQ' (gmapQ (\x -> XQ (f x)) t1) t2++-- Apply existentially quantified queries+-- Insist on equal types!+--+gApplyQ' :: Data a => [XQ r] -> a -> [r]+gApplyQ' qs t = reverse (snd (gfoldlQ k z t))+ where+ z = (qs, [])+ k :: ([XQ r], [r]) -> GenericQ ([XQ r], [r])+ k (XQ q : qs, rs) child = (qs, q' child : rs)+ where+ q' = error "Twin mismatch" `extQ` q+++-----------------------------------------------------------------------------++tests = ( geq [True,True] [True,True]+ , geq [True,True] [True,False]+ , geq'' [True,True] [True,True]+ , geq'' [True,True] [True,False]+ ) @=? output++output = (True,False,True,False)
tests/Typecase1.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE DeriveDataTypeable #-} module Typecase1 (tests) where @@ -10,7 +10,7 @@ -} -import Test.HUnit+import Test.Tasty.HUnit import Data.Typeable import Data.Maybe@@ -34,7 +34,7 @@ int a = "got an int, incremented: " ++ show (a + 1) -- do something with floats- float :: Float -> String+ float :: Double -> String float a = "got a float, multiplied by .42: " ++ show (a * 0.42) -- do something with my typeables@@ -49,9 +49,9 @@ -- Test the type case -- tests = ( f (41::Int)- , f (88::Float)+ , f (88::Double) , f (MyCons "42")- , f True) ~=? output+ , f True) @=? output output = ( "got an int, incremented: 42" , "got a float, multiplied by .42: 36.96"
tests/Typecase2.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE DeriveDataTypeable #-} module Typecase2 (tests) where @@ -11,7 +11,7 @@ -} -import Test.HUnit+import Test.Tasty.HUnit import Data.Generics import Data.Maybe@@ -35,7 +35,7 @@ int a = "got an int, incremented: " ++ show (a + 1) -- do something with floats- float :: Float -> String+ float :: Double -> String float a = "got a float, multiplied by .42: " ++ show (a * 0.42) -- do something with my data@@ -50,9 +50,9 @@ -- Test the type case -- tests = ( f (41::Int)- , f (88::Float)+ , f (88::Double) , f (MyCons "42")- , f True) ~=? output+ , f True) @=? output output = ( "got an int, incremented: 42" , "got a float, multiplied by .42: 36.96"
tests/Where.hs view
@@ -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)))))))" +{-# LANGUAGE DeriveDataTypeable #-}++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.Tasty.HUnit++import Data.Generics+import Control.Monad+++-- Two mutually recursive datatypes+data T1 = T1a Int | T1b T2 deriving (Typeable, Data)+data T2 = T2 T1 deriving (Typeable, Data)+++-- A rewrite step with identity as catch-all case+stepid (T1a 42) = T1a 88+stepid x = x+++-- The same rewrite step but now with failure as catch-all case+stepfail (T1a 42) = Just (T1a 88)+stepfail _ = Nothing+++-- We can let recover potentially failing generic functions from failure;+-- this is illustrated for a generic made from stepfail via mkM.+recovered x = mkM stepfail x `mplus` Just x+++-- A test term that comprehends a redex+term42 = T1b (T2 (T1a 42))+++-- A test term that does not comprehend a redex+term37 = T1b (T2 (T1a 37))+++-- A number of traversals+result1 = everywhere (mkT stepid) term42 -- rewrites term accordingly+result2 = everywhere (mkT stepid) term37 -- preserves term without notice+result3 = everywhereM (mkM stepfail) term42 -- fails in a harsh manner+result4 = everywhereM (mkM stepfail) term37 -- fails rather early+result5 = everywhereM recovered term37 -- preserves term without notice+result6 = somewhere (mkMp stepfail) term42 -- rewrites term accordingly+result7 = somewhere (mkMp stepfail) term37 -- fails to notice lack of redex++tests = gshow ( result1,+ ( result2,+ ( result3,+ ( result4,+ ( result5,+ ( result6,+ ( result7 ))))))) @=? output++output = "((,) (T1b (T2 (T1a (88)))) ((,) (T1b (T2 (T1a (37)))) ((,) (Nothing) ((,) (Nothing) ((,) (Just (T1b (T2 (T1a (37))))) ((,) (Just (T1b (T2 (T1a (88))))) (Nothing)))))))"
tests/XML.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-} module XML (tests) where @@ -11,25 +12,24 @@ -} -import Test.HUnit+import Test.Tasty.HUnit -import Control.Applicative (Alternative(..), Applicative(..))+import Control.Applicative (Alternative(..)) 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)+ deriving (Show, Eq, Data) data Content = CElem Element | CString Bool CharData -- ^ bool is whether whitespace is significant | CRef Reference | CMisc Misc- deriving (Show, Eq, Typeable, Data)+ deriving (Show, Eq, Data) type CharData = String @@ -44,14 +44,14 @@ data2content :: Data a => a -> [Content] data2content = element `ext1Q` list- `extQ` string + `extQ` string `extQ` float where -- Handle an element element x = [CElem (Elem (tyconUQname (dataTypeName (dataTypeOf x)))- [] -- no attributes + [] -- no attributes (concat (gmapQ data2content x)))] -- A special case for lists@@ -63,7 +63,7 @@ string x = [CString True x] -- A special case for floats- float :: Float -> [Content]+ float :: Double -> [Content] float x = [CString True (show x)] @@ -72,7 +72,7 @@ content2data = result where- + -- Case-discriminating worker result = element `ext1R` list@@ -83,7 +83,7 @@ -- Determine type of data to be constructed myType = myTypeOf result where- myTypeOf :: forall a. ReadX a -> a+ myTypeOf :: forall b. ReadX b -> b myTypeOf = undefined -- Handle an element@@ -97,7 +97,7 @@ -- A special case for lists- list :: forall a. Data a => ReadX [a]+ list :: forall b. Data b => ReadX [b] list = ( do h <- content2data t <- list return (h:t) )@@ -111,7 +111,7 @@ -- Retrieve all constructors of the requested type consOf = dataTypeConstrs- $ dataTypeOf + $ dataTypeOf $ myType -- Recurse into subterms@@ -127,7 +127,7 @@ _ -> mzero -- A special case for floats- float :: ReadX Float+ float :: ReadX Double float = do c <- readX case c of (CString _ x) -> return (read x)@@ -147,22 +147,23 @@ -> Maybe ([Content], a) } -- Run a computation-runReadX x y = case unReadX x y of - Just ([],y) -> Just y+runReadX :: ReadX a -> [Content] -> Maybe a+runReadX x y = case unReadX x y of+ Just ([],z) -> Just z _ -> Nothing -- Read one content particle readX :: ReadX Content-readX = ReadX (\x -> if null x - then Nothing- else Just (tail x, head x)+readX = ReadX (\x -> case x of+ [] -> Nothing+ y : ys -> Just (ys, y) ) instance Functor ReadX where fmap = liftM instance Applicative ReadX where- pure = return+ pure x = ReadX (\y -> Just (y,x)) (<*>) = ap instance Alternative ReadX where@@ -171,7 +172,7 @@ -- ReadX is a monad! instance Monad ReadX where- return x = ReadX (\y -> Just (y,x))+ return = pure c >>= f = ReadX (\x -> case unReadX c x of Nothing -> Nothing Just (x', a) -> unReadX (f a) x'@@ -193,15 +194,17 @@ -- ----------------------------------------------------------------------------- +tests :: Assertion tests = ( genCom , ( data2content genCom , ( zigzag person1 :: Maybe Person , ( zigzag genCom :: Maybe Company , ( zigzag genCom == Just genCom- ))))) ~=? output- where + ))))) @=? output+ where -- Trealise back and forth zigzag :: Data a => a -> Maybe a zigzag = runReadX content2data . data2content +output :: (Company, ([Content], (Maybe Person, (Maybe Company, Bool)))) 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))))