syb-0.7.2.4/0000755000000000000000000000000007346545000010650 5ustar0000000000000000syb-0.7.2.4/Changelog.md0000644000000000000000000000101707346545000013060 0ustar0000000000000000# 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 syb-0.7.2.4/LICENSE0000644000000000000000000000745007346545000011663 0ustar0000000000000000This 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. ----------------------------------------------------------------------------- syb-0.7.2.4/README.md0000644000000000000000000000254007346545000012130 0ustar0000000000000000syb: Scrap Your Boilerplate! ================================================================================ Scrap Your Boilerplate (SYB) is a library for generic programming in Haskell. It is supported since the GHC >= 6.0 implementation of Haskell. Using this approach, you can write generic functions such as traversal schemes (e.g., everywhere and everything), as well as generic read, generic show and generic equality (i.e., gread, gshow, and geq). This approach is based on just a few primitives for type-safe cast and processing constructor applications. It was originally developed by Ralf Lämmel and Simon Peyton Jones. Since then, many people have contributed with research relating to SYB or its applications. More information is available on the webpage: http://www.cs.uu.nl/wiki/GenericProgramming/SYB Features -------- * Easy generic programming with combinators * GHC can derive Data and Typeable instances for your datatypes * Comes with many useful generic functions Requirements ------------ * GHC 6.10.1 or later * Cabal 1.6 or later Bugs & Support -------------- Please report issues or request features at the bug tracker: https://github.com/dreixel/syb/issues For discussion about the library with the authors, maintainers, and other interested persons use the mailing list: http://www.haskell.org/mailman/listinfo/generics syb-0.7.2.4/Setup.lhs0000644000000000000000000000011407346545000012454 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain syb-0.7.2.4/src/Data/0000755000000000000000000000000007346545000012310 5ustar0000000000000000syb-0.7.2.4/src/Data/Generics.hs0000644000000000000000000000271407346545000014407 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics -- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (uses Data.Generics.Basics) -- -- \"Scrap your boilerplate\" --- Generic programming in Haskell -- See . To scrap your -- boilerplate it is sufficient to import the present module, which simply -- re-exports all themes of the Data.Generics library. -- ----------------------------------------------------------------------------- module Data.Generics ( -- * All Data.Generics modules module Data.Data, -- primitives and instances of the Data class module Data.Generics.Aliases, -- aliases for type case, generic types module Data.Generics.Schemes, -- traversal schemes (everywhere etc.) module Data.Generics.Text, -- generic read and show module Data.Generics.Twins, -- twin traversal, e.g., generic eq module Data.Generics.Builders, -- term builders ) where ------------------------------------------------------------------------------ import Data.Data import Data.Generics.Instances () import Data.Generics.Aliases import Data.Generics.Schemes import Data.Generics.Text import Data.Generics.Twins import Data.Generics.Builders syb-0.7.2.4/src/Data/Generics/0000755000000000000000000000000007346545000014047 5ustar0000000000000000syb-0.7.2.4/src/Data/Generics/Aliases.hs0000644000000000000000000004700707346545000015774 0ustar0000000000000000{-# 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, -- ** Builders 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 -- | 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 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 data 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} syb-0.7.2.4/src/Data/Generics/Basics.hs0000644000000000000000000000152107346545000015606 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Basics -- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (local universal quantification) -- -- \"Scrap your boilerplate\" --- Generic programming in Haskell. -- See . This module provides -- the 'Data' class with its primitives for generic programming, -- which is now defined in @Data.Data@. Therefore this module simply -- re-exports @Data.Data@. -- ----------------------------------------------------------------------------- module Data.Generics.Basics ( module Data.Data ) where import Data.Data syb-0.7.2.4/src/Data/Generics/Builders.hs0000644000000000000000000000363507346545000016163 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Builders -- Copyright : (c) 2008 Universiteit Utrecht -- License : BSD-style -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable -- -- This module provides generic builder functions. These functions construct -- values of a given type. ----------------------------------------------------------------------------- module Data.Generics.Builders (empty, constrs) where import Data.Data import Data.Generics.Aliases (extB) -- | 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 `extB` int `extB` integer `extB` float `extB` double where -- Generic case general :: Data a => a general = fromConstrB empty (indexConstr (dataTypeOf general) 1) -- Base cases char = '\NUL' int = 0 :: Int integer = 0 :: Integer float = 0.0 :: Float double = 0.0 :: Double -- | 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 `extB` int `extB` integer `extB` float `extB` double where -- Generic case general :: Data a => [a] general = map (fromConstrB empty) (dataTypeConstrs (dataTypeOf (unList general))) where unList :: Data a => [a] -> a unList = undefined -- Base cases char = "\NUL" int = [0 :: Int] integer = [0 :: Integer] float = [0.0 :: Float] double = [0.0 :: Double] syb-0.7.2.4/src/Data/Generics/Instances.hs0000644000000000000000000001351507346545000016337 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Instances -- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (uses Data.Data) -- -- \"Scrap your boilerplate\" --- Generic programming in Haskell -- See . The present module -- contains thirteen 'Data' instances which are considered dubious (either -- because the types are abstract or just not meant to be traversed). -- Instances in this module might change or disappear in future releases -- of this package. -- -- (This module does not export anything. It really just defines instances.) -- ----------------------------------------------------------------------------- {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Generics.Instances () where ------------------------------------------------------------------------------ import Data.Data #ifdef __GLASGOW_HASKELL__ #if __GLASGOW_HASKELL__ >= 611 import GHC.IO.Handle -- So we can give Data instance for Handle #else import GHC.IOBase -- So we can give Data instance for IO, Handle #endif import GHC.Stable -- So we can give Data instance for StablePtr import GHC.ST -- So we can give Data instance for ST import GHC.Conc -- So we can give Data instance for TVar import Data.IORef -- So we can give Data instance for IORef import Control.Concurrent -- So we can give Data instance for MVar #else # ifdef __HUGS__ import Hugs.Prelude( Ratio(..) ) # endif import System.IO import Foreign.Ptr import Foreign.ForeignPtr import Foreign.StablePtr import Control.Monad.ST #endif -- Version compatibility issues caused by #2760 myMkNoRepType :: String -> DataType #if __GLASGOW_HASKELL__ >= 611 myMkNoRepType = mkNoRepType #else myMkNoRepType = mkNorepType #endif ------------------------------------------------------------------------------ -- -- Instances of the Data class for Prelude-like types. -- We define top-level definitions for representations. -- ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- Instances of abstract datatypes (6) ------------------------------------------------------------------------------ #if __GLASGOW_HASKELL__ < 801 instance Data TypeRep where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "Data.Typeable.TypeRep" #endif ------------------------------------------------------------------------------ instance Data TyCon where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "Data.Typeable.TyCon" ------------------------------------------------------------------------------ #if __GLASGOW_HASKELL__ < 709 deriving instance Typeable DataType #endif instance Data DataType where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "Data.Generics.Basics.DataType" ------------------------------------------------------------------------------ instance Data Handle where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "GHC.IOBase.Handle" ------------------------------------------------------------------------------ instance Typeable a => Data (StablePtr a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "GHC.Stable.StablePtr" ------------------------------------------------------------------------------ #ifdef __GLASGOW_HASKELL__ instance Data ThreadId where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "GHC.Conc.ThreadId" #endif ------------------------------------------------------------------------------ -- Dubious instances (7) ------------------------------------------------------------------------------ #ifdef __GLASGOW_HASKELL__ instance Typeable a => Data (TVar a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "GHC.Conc.TVar" #endif ------------------------------------------------------------------------------ instance Typeable a => Data (MVar a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "GHC.Conc.MVar" ------------------------------------------------------------------------------ #ifdef __GLASGOW_HASKELL__ instance Typeable a => Data (STM a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "GHC.Conc.STM" #endif ------------------------------------------------------------------------------ instance (Typeable s, Typeable a) => Data (ST s a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "GHC.ST.ST" ------------------------------------------------------------------------------ instance Typeable a => Data (IORef a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "GHC.IOBase.IORef" ------------------------------------------------------------------------------ instance Typeable a => Data (IO a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "GHC.IOBase.IO" ------------------------------------------------------------------------------ -- -- A last resort for functions -- instance (Data a, Data b) => Data (a -> b) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "Prelude.(->)" dataCast2 f = gcast2 f syb-0.7.2.4/src/Data/Generics/Schemes.hs0000644000000000000000000001426107346545000015776 0ustar0000000000000000{-# LANGUAGE RankNTypes, ScopedTypeVariables, CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Schemes -- Copyright : (c) The University of Glasgow, CWI 2001--2003 -- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (local universal quantification) -- -- \"Scrap your boilerplate\" --- Generic programming in Haskell -- See . The present module -- provides frequently used generic traversal schemes. -- ----------------------------------------------------------------------------- module Data.Generics.Schemes ( everywhere, everywhere', everywhereBut, everywhereM, somewhere, everything, everythingBut, everythingWithContext, listify, something, synthesize, gsize, glength, gdepth, gcount, gnodecount, gtypecount, gfindtype ) where ------------------------------------------------------------------------------ #ifdef __HADDOCK__ import Prelude #endif import Data.Data import Data.Generics.Aliases import Control.Monad -- | Apply a transformation everywhere in bottom-up manner -- -- @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 syb-0.7.2.4/src/Data/Generics/Text.hs0000644000000000000000000001001607346545000015325 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Text -- Copyright : (c) The University of Glasgow, CWI 2001--2003 -- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (uses Data.Generics.Basics) -- -- \"Scrap your boilerplate\" --- Generic programming in Haskell -- See . The present module -- provides generic operations for text serialisation of terms. -- ----------------------------------------------------------------------------- module Data.Generics.Text ( -- * Generic show gshow, gshows, -- * Generic read gread ) where ------------------------------------------------------------------------------ #ifdef __HADDOCK__ import Prelude #endif import Control.Monad import Data.Data import Data.Generics.Aliases import Text.ParserCombinators.ReadP import Text.Read.Lex ------------------------------------------------------------------------------ -- | Generic show: an alternative to \"deriving Show\" -- -- @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 = ( \t -> showChar '(' . (showString . showConstr . toConstr $ t) . (foldr (.) id . gmapQ ((showChar ' ' .) . gshows) $ t) . showChar ')' ) `extQ` (shows :: String -> ShowS) -- | Generic 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 <++ 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] syb-0.7.2.4/src/Data/Generics/Twins.hs0000644000000000000000000002142607346545000015514 0ustar0000000000000000{-# LANGUAGE RankNTypes, ScopedTypeVariables, CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Twins -- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (local universal quantification) -- -- \"Scrap your boilerplate\" --- Generic programming in Haskell -- See . The present module -- provides support for multi-parameter traversal, which is also -- demonstrated with generic operations like equality. -- ----------------------------------------------------------------------------- module Data.Generics.Twins ( -- * Generic folds and maps that also accumulate gfoldlAccum, gmapAccumT, gmapAccumM, gmapAccumQl, gmapAccumQr, gmapAccumQ, gmapAccumA, -- * Mapping combinators for twin traversal gzipWithT, gzipWithM, gzipWithQ, -- * Typical twin traversals geq, gzip, gcompare ) where ------------------------------------------------------------------------------ #ifdef __HADDOCK__ import Prelude #endif import Data.Data import Data.Generics.Aliases #ifdef __GLASGOW_HASKELL__ import Prelude hiding ( GT ) #endif #if __GLASGOW_HASKELL__ < 709 import Control.Applicative (Applicative(..)) import Data.Monoid ( mappend, mconcat ) #endif ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- -- Generic folds and maps that also accumulate -- ------------------------------------------------------------------------------ {-------------------------------------------------------------- A list map can be elaborated to perform accumulation. In the same sense, we can elaborate generic maps over terms. We recall the type of map: map :: (a -> b) -> [a] -> [b] We recall the type of an accumulating map (see Data.List): mapAccumL :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c]) Applying the same scheme we obtain an accumulating gfoldl. --------------------------------------------------------------} -- | gfoldl with accumulation -- -- @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)) -> a -> d -> (a, c d) gfoldlAccum k z a0 d = unA (gfoldl k' z' d) a0 where k' c y = A (\a -> let (a', c') = unA c a in k a' c' y) z' f = A (\a -> z a f) -- | A type constructor for accumulation newtype A a c d = A { unA :: a -> (a, c d) } -- | gmapT with accumulation -- -- @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) where k a (ID c) d = let (a',d') = f a d in (a', ID (c d')) z a x = (a, ID x) -- | Applicative version -- -- @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) gmapAccumA f a0 d0 = gfoldlAccum k z a0 d0 where k :: forall d' e. (Data d') => b -> a (d' -> e) -> d' -> (b, a e) k a c d = let (a',d') = f a d c' = c <*> d' in (a', c') z :: forall t c a'. (Applicative a') => t -> c -> (t, a' c) z a x = (a, pure x) -- | gmapM with accumulation -- -- @since 0.1.0.0 gmapAccumM :: (Data d, Monad m) => (forall e. Data e => a -> e -> (a, m e)) -> a -> d -> (a, m d) gmapAccumM f = gfoldlAccum k z where k a c d = let (a',d') = f a d in (a', d' >>= \d'' -> c >>= \c' -> return (c' d'')) z a x = (a, return x) -- | gmapQl with accumulation -- -- @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) where k a (CONST c) d = let (a', r) = f a d in (a', CONST (c `o` r)) z a _ = (a, CONST r0) -- | gmapQr with accumulation -- -- @since 0.1.0.0 gmapAccumQr :: Data d => (r' -> r -> r) -> r -> (forall e. Data e => a -> e -> (a,r')) -> a -> d -> (a, r) gmapAccumQr o r0 f a0 d0 = let (a1, l) = gfoldlAccum k z a0 d0 in (a1, unQr l r0) where k a (Qr c) d = let (a',r') = f a d in (a', Qr (\r -> c (r' `o` r))) z a _ = (a, Qr id) -- | gmapQ with accumulation -- -- @since 0.1.0.0 gmapAccumQ :: Data d => (forall e. Data e => a -> e -> (a,q)) -> a -> d -> (a, [q]) gmapAccumQ f = gmapAccumQr (:) [] f ------------------------------------------------------------------------------ -- -- Helper type constructors -- ------------------------------------------------------------------------------ -- | The identity type constructor needed for the definition of gmapAccumT newtype ID x = ID { unID :: x } -- | The constant type constructor needed for the definition of gmapAccumQl newtype CONST c a = CONST { unCONST :: c } -- | The type constructor needed for the definition of gmapAccumQr newtype Qr r a = Qr { unQr :: r -> r } ------------------------------------------------------------------------------ -- -- Mapping combinators for twin traversal -- ------------------------------------------------------------------------------ -- | Twin map for transformation -- -- @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 a d = (tail a, unGT (head a) d) 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 _ -> error "gzipWithM" where perkid a d = (tail a, unGM (head a) d) funs = gmapQ (\k -> GM (f k)) x -- | Twin map for queries -- -- @since 0.1.0.0 gzipWithQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r]) gzipWithQ f x y = case gmapAccumQ perkid funs y of ([], r) -> r _ -> error "gzipWithQ" where perkid a d = (tail a, unGQ (head a) d) funs = gmapQ (\k -> GQ (f k)) x ------------------------------------------------------------------------------ -- -- Typical twin traversals -- ------------------------------------------------------------------------------ -- | Generic equality: an alternative to \"deriving Eq\" -- -- @since 0.1.0.0 geq :: Data a => a -> a -> Bool {- Testing for equality of two terms goes like this. Firstly, we establish the equality of the two top-level datatype constructors. Secondly, we use a twin gmap combinator, namely tgmapQ, to compare the two lists of immediate subterms. (Note for the experts: the type of the worker geq' is rather general but precision is recovered via the restrictive type of the top-level operation geq. The imprecision of geq' is caused by the type system's unability to express the type equivalence for the corresponding couples of immediate subterms from the two given input terms.) -} geq x0 y0 = geq' x0 y0 where geq' :: GenericQ (GenericQ Bool) geq' x y = (toConstr x == toConstr y) && and (gzipWithQ geq' x y) -- | Generic zip controlled by a function with type-specific branches -- -- @since 0.1.0.0 gzip :: GenericQ (GenericM Maybe) -> GenericQ (GenericM Maybe) -- See testsuite/.../Generics/gzip.hs for an illustration gzip f = go where go :: GenericQ (GenericM Maybe) go x y = f x y `orElse` if toConstr x == toConstr y then gzipWithM go x y else Nothing -- | Generic comparison: an alternative to \"deriving Ord\" -- -- @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" syb-0.7.2.4/src/Generics/0000755000000000000000000000000007346545000013176 5ustar0000000000000000syb-0.7.2.4/src/Generics/SYB.hs0000644000000000000000000000110407346545000014163 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 syb-0.7.2.4/src/Generics/SYB/0000755000000000000000000000000007346545000013633 5ustar0000000000000000syb-0.7.2.4/src/Generics/SYB/Aliases.hs0000644000000000000000000000113507346545000015550 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 syb-0.7.2.4/src/Generics/SYB/Basics.hs0000644000000000000000000000113007346545000015366 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 syb-0.7.2.4/src/Generics/SYB/Builders.hs0000644000000000000000000000114207346545000015736 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 syb-0.7.2.4/src/Generics/SYB/Instances.hs0000644000000000000000000000111407346545000016113 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 () syb-0.7.2.4/src/Generics/SYB/Schemes.hs0000644000000000000000000000113507346545000015556 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 syb-0.7.2.4/src/Generics/SYB/Text.hs0000644000000000000000000000111607346545000015112 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 syb-0.7.2.4/src/Generics/SYB/Twins.hs0000644000000000000000000000112307346545000015270 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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-0.7.2.4/syb.cabal0000644000000000000000000000744007346545000012436 0ustar0000000000000000name: syb version: 0.7.2.4 license: BSD3 license-file: LICENSE author: Ralf Lammel, Simon Peyton Jones, Jose Pedro Magalhaes maintainer: Sergey Vinokurov 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 /Scrap Your Boilerplate/ papers (see ). It defines the @Data@ class of types permitting folding and unfolding of constructor applications, instances of this class for primitive types, and a variety of traversals. category: Generics stability: provisional build-type: Simple cabal-version: >= 1.10 tested-with: GHC == 9.6.1 GHC == 9.4.4 GHC == 9.2.7 GHC == 9.0.2 GHC == 8.10.7 GHC == 8.8.4 GHC == 8.6.5 GHC == 8.4.4 GHC == 8.2.2 GHC == 8.0.2 GHC == 7.10.3 GHC == 7.8.4 GHC == 7.6.3 GHC == 7.4.2 GHC == 7.2.2 GHC == 7.0.4 extra-source-files: README.md, Changelog.md source-repository head type: git location: https://github.com/dreixel/syb Library hs-source-dirs: src default-language: Haskell98 build-depends: base >= 4.0 && < 5.0 exposed-modules: Data.Generics Data.Generics.Basics Data.Generics.Instances Data.Generics.Aliases Data.Generics.Schemes Data.Generics.Text Data.Generics.Twins Data.Generics.Builders Generics.SYB Generics.SYB.Basics Generics.SYB.Instances Generics.SYB.Aliases Generics.SYB.Schemes Generics.SYB.Text Generics.SYB.Twins Generics.SYB.Builders if impl(ghc < 6.12) ghc-options: -package-name syb ghc-options: -Wall test-suite unit-tests type: exitcode-stdio-1.0 hs-source-dirs: tests default-language: Haskell98 main-is: Main.hs build-depends: base , syb , 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 syb-0.7.2.4/tests/0000755000000000000000000000000007346545000012012 5ustar0000000000000000syb-0.7.2.4/tests/Bits.hs0000644000000000000000000005263207346545000013257 0ustar0000000000000000{-# 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 for serialisation and sending companies and other terms over the internet.) Here is how it works. A constuctor is encoded as a bit stream. To this end, we encode the index of the constructor as a binary number of a fixed length taking into account the maximum index for the type at hand. (Similarly, we could view the list of constructors as a binary tree, and then encode a constructor as the path to the constructor in this tree.) If there is just a single constructor, as for newtypes, for example, then the computed bit stream is empty. Otherwise we just recurse into subterms. Well, we need to handle basic datatypes in a special way. We observe such basic datatypes by testing the maximum index to be 0 for the datatype at hand. An efficient encoding should be tuned per basic datatype. The following solution is generic, but it wastes space. That is, we turn the basic value into a string relying on the general Data API. This string can now be encoded by first converting it into a list of bit streams at the term level, which can then be easily encoded as a single bit stream (because lists and bits can be encoded). -} import Test.Tasty.HUnit import Data.Generics import Data.Char import Data.Maybe import Control.Applicative (Alternative(..), Applicative(..)) import Control.Monad import CompanyDatatypes ----------------------------------------------------------------------------- -- | We need bits and bit streams. data Bit = Zero | One deriving (Show, Eq, Typeable, Data) type Bin = [Bit] ----------------------------------------------------------------------------- -- Compute length of bit stream for a natural lengthNat :: Int -> Int lengthNat x = ceiling (logBase 2 (fromIntegral (x + 1))) -- Encode a natural as a bit stream varNat2bin :: Int -> Bin varNat2bin 0 = [] varNat2bin x = ( ( if even x then Zero else One ) : varNat2bin (x `div` 2) ) -- Encode a natural as a bit stream of fixed length fixedNat2bin :: Int -> Int -> Bin fixedNat2bin 0 0 = [] fixedNat2bin p x | p>0 = ( ( if even x then Zero else One ) : fixedNat2bin (p - 1) (x `div` 2) ) -- Decode a natural bin2nat :: Bin -> Int bin2nat [] = 0 bin2nat (Zero : bs) = 2 * (bin2nat bs) bin2nat (One : bs) = 2 * (bin2nat bs) + 1 ----------------------------------------------------------------------------- -- | Generically map terms to bit streams showBin :: Data t => t -> Bin showBin t = if isAlgType myDataType then con2bin ++ concat (gmapQ showBin t) else showBin base where -- The datatype for introspection myDataType = dataTypeOf t -- Obtain the maximum index for the type at hand max :: Int max = maxConstrIndex myDataType -- Obtain the index for the constructor at hand idx :: Int idx = constrIndex (toConstr t) -- Map basic values to strings, then to lists of bit streams base = map (varNat2bin . ord) (showConstr (toConstr t)) -- Map constructors to bit streams of fixed length con2bin = fixedNat2bin (lengthNat (max - 1)) (idx - 1) ----------------------------------------------------------------------------- -- | A monad on bit streams data ReadB a = ReadB (Bin -> (Maybe a, Bin)) unReadB (ReadB f) = f instance Functor ReadB where fmap = liftM instance Applicative ReadB where pure a = ReadB (\bs -> (Just a, bs)) (<*>) = ap instance Alternative ReadB where (<|>) = mplus empty = mzero -- It's a monad. instance Monad ReadB where return = pure (ReadB c) >>= f = ReadB (\bs -> case c bs of (Just a, bs') -> unReadB (f a) bs' (Nothing, bs') -> (Nothing, bs') ) -- It's a bit monad with 0 and +. instance MonadPlus ReadB where mzero = ReadB (\bs -> (Nothing, bs)) (ReadB f) `mplus` (ReadB g) = ReadB (\bs -> case f bs of (Just a, bs') -> (Just a, bs') (Nothing, _) -> g bs ) -- Read a few bits readB :: Int -> ReadB Bin readB x = ReadB (\bs -> if length bs >= x then (Just (take x bs), drop x bs) else (Nothing, bs) ) ----------------------------------------------------------------------------- -- | Generically map bit streams to terms readBin :: Data t => ReadB t readBin = result where -- The worker, which we also use as type argument result = if isAlgType myDataType then do bin <- readB (lengthNat (max - 1)) fromConstrM readBin (bin2con bin) else do str <- readBin con <- str2con (map (chr . bin2nat) str) return (fromConstr con) -- Determine result type myDataType = dataTypeOf (getArg result) where getArg :: ReadB a -> a getArg = undefined -- Obtain the maximum index for the type at hand max :: Int max = maxConstrIndex myDataType -- Convert a bit stream into a constructor bin2con :: Bin -> Constr bin2con bin = indexConstr myDataType ((bin2nat bin) + 1) -- Convert string to constructor; could fail str2con :: String -> ReadB Constr str2con = maybe mzero return . readConstr myDataType ----------------------------------------------------------------------------- tests = ( showBin True , ( showBin [True] , ( showBin (1::Int) , ( showBin "1" , ( showBin genCom , ( geq genCom genCom' )))))) @=? output where genCom' = fromJust (fst (unReadB readBin (showBin genCom))) :: Company output = ([One],([One,One,Zero],([One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero],([One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero],([One,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,Zero,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,One,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,One,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,Zero,Zero],True))))) syb-0.7.2.4/tests/Builders.hs0000644000000000000000000000063607346545000014124 0ustar0000000000000000module Builders (tests) where -- Testing Data.Generics.Builders functionality import Test.Tasty.HUnit import Data.Data import Data.Generics.Builders -- Main function for testing tests = ( constrs :: [Maybe Int] , constrs :: [String] , constrs :: [Either Int Double] , constrs :: [((), Integer)] ) @=? output output = ([Nothing,Just 0],["","\NUL"],[Left 0,Right 0.0],[((),0)]) syb-0.7.2.4/tests/CompanyDatatypes.hs0000644000000000000000000000254707346545000015643 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module CompanyDatatypes where import Data.Generics (Data, Typeable) -- The organisational structure of a company data Company = C [Dept] deriving (Eq, Show, Typeable, Data) data Dept = D Name Manager [Unit] deriving (Eq, Show, Typeable, Data) data Unit = PU Employee | DU Dept deriving (Eq, Show, Typeable, Data) data Employee = E Person Salary deriving (Eq, Show, Typeable, Data) data Person = P Name Address deriving (Eq, Show, Typeable, Data) data Salary = S Double deriving (Eq, Show, Typeable, Data) type Manager = Employee type Name = String type Address = String -- An illustrative company genCom :: Company genCom = C [D "Research" laemmel [PU joost, PU marlow], D "Strategy" blair []] -- A typo for the sake of testing equality; -- (cf. lammel vs. laemmel) genCom' :: Company genCom' = C [D "Research" lammel [PU joost, PU marlow], D "Strategy" blair []] lammel, laemmel, joost, marlow, blair :: Employee lammel = E (P "Lammel" "Amsterdam") (S 8000) laemmel = E (P "Laemmel" "Amsterdam") (S 8000) joost = E (P "Joost" "Amsterdam") (S 1000) marlow = E (P "Marlow" "Cambridge") (S 2000) blair = E (P "Blair" "London") (S 100000) -- Some more test data person1 = P "Lazy" "Home" dept1 = D "Useless" (E person1 undefined) [] syb-0.7.2.4/tests/Datatype.hs0000644000000000000000000000400507346545000014120 0ustar0000000000000000{-# 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 syb-0.7.2.4/tests/Encode.hs0000644000000000000000000000442707346545000013552 0ustar0000000000000000{-# 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. -- We just wanted to typecheck the fragments as shown in the paper. module Encode () where import Control.Applicative (Applicative(..)) import Control.Monad (ap, liftM) import Data.Generics data Bit = Zero | One ------------------------------------------------------------------------------ -- Sec. 3.2 data2bits :: Data a => a -> [Bit] data2bits t = encodeCon (dataTypeOf t) (toConstr t) ++ concat (gmapQ data2bits t) -- The encoder for constructors encodeCon :: DataType -> Constr -> [Bit] encodeCon ty con = natToBin (max-1) (idx-1) where max = maxConstrIndex ty idx = constrIndex con natToBin :: Int -> Int -> [Bit] natToBin = undefined ------------------------------------------------------------------------------ -- Sec. 3.3 data State -- Abstract initState :: State encodeCon' :: DataType -> Constr -> State -> (State, [Bit]) initState = undefined encodeCon' = undefined data2bits' :: Data a => a -> [Bit] data2bits' t = snd (show_bin t initState) show_bin :: Data a => a -> State -> (State, [Bit]) show_bin t st = (st2, con_bits ++ args_bits) where (st1, con_bits) = encodeCon' (dataTypeOf t) (toConstr t) st (st2, args_bits) = foldr do_arg (st1,[]) enc_args enc_args :: [State -> (State,[Bit])] enc_args = gmapQ show_bin t do_arg fn (st,bits) = (st', bits' ++ bits) where (st', bits') = fn st ------------------------------------------------------------------------------ -- Sec. 3.3 cont'd data EncM a -- The encoder monad instance Functor EncM where fmap = liftM instance Applicative EncM where pure = undefined (<*>) = ap instance Monad EncM where return = pure c >>= f = undefined runEnc :: EncM () -> [Bit] emitCon :: DataType -> Constr -> EncM () runEnc = undefined emitCon = undefined data2bits'' :: Data a => a -> [Bit] data2bits'' t = runEnc (emit t) emit :: Data a => a -> EncM () emit t = do { emitCon (dataTypeOf t) (toConstr t) ; sequence_ (gmapQ emit t) } syb-0.7.2.4/tests/Ext.hs0000644000000000000000000000120707346545000013106 0ustar0000000000000000module 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) syb-0.7.2.4/tests/Ext1.hs0000644000000000000000000000533707346545000013177 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} module Ext1 (tests) where {- This example records some experiments with polymorphic datatypes. -} import Test.Tasty.HUnit import Data.Generics import GHC.Exts (unsafeCoerce#) #if MIN_VERSION_base(4,8,0) import GHC.Base hiding(foldr) #else import GHC.Base #endif -- Unsafe coerce unsafeCoerce :: a -> b unsafeCoerce = unsafeCoerce# -- Handy type constructors newtype ID x = ID { unID :: x } newtype CONST c a = CONST { unCONST :: c } -- Extension of a query with a para. poly. list case extListQ' :: Data d => (d -> q) -> (forall d. [d] -> q) -> d -> q extListQ' def ext d = if isList d then ext (unsafeCoerce d) else def d -- Test extListQ' foo1 :: Data d => d -> Int foo1 = const 0 `extListQ'` length t1 = foo1 True -- should count as 0 t2 = foo1 [True,True] -- should count as 2 -- Infeasible extension of a query with a data-polymorphic list case extListQ'' :: Data d => (d -> q) -> (forall d. Data d => [d] -> q) -> d -> q extListQ'' def ext d = if isList d then undefined -- hard to avoid an ambiguous type else def d -- Test extListQ from Data.Generics.Aliases foo2 :: Data a => a -> Int foo2 = const 0 `ext1Q` list where list :: Data a => [a] -> Int list l = foldr (+) 0 $ map glength l t3 = foo2 (True,True) -- should count as 0 t4 = foo2 [(True,True),(True,True)] -- should count as 2+2=4 -- Customisation for lists without type cast foo3 :: Data a => a -> Int foo3 x = if isList x then foldr (+) 0 $ gmapListQ glength x else 0 t5 = foo3 (True,True) -- should count as 0 t6 = foo3 [(True,True),(True,True)] -- should count as 2+2=4 -- Test for list datatype isList :: Data a => a -> Bool isList x = typeRepTyCon (typeOf x) == typeRepTyCon (typeOf (undefined::[()])) -- Test for nil isNil :: Data a => a -> Bool isNil x = toConstr x == toConstr ([]::[()]) -- Test for cons isCons :: Data a => a -> Bool isCons x = toConstr x == toConstr (():[]) -- gmapQ for polymorphic lists gmapListQ :: forall a q. Data a => (forall a. Data a => a -> q) -> a -> [q] gmapListQ f x = if not $ isList x then error "gmapListQ" else if isNil x then [] else if isCons x then ( gmapQi 0 f x : gmapQi 1 (gmapListQ f) x ) else error "gmapListQ" -- Build nil mkNil :: Data a => a mkNil = fromConstr $ toConstr ([]::[()]) -- Build cons mkCons :: Data a => a mkCons = fromConstr $ toConstr ((undefined:undefined)::[()]) -- Main function for testing tests = ( t1 , ( t2 , ( t3 , ( t4 , ( t5 , ( t6 )))))) @=? output output = (0,(2,(0,(4,(0,4))))) syb-0.7.2.4/tests/Ext2.hs0000644000000000000000000000277407346545000013202 0ustar0000000000000000{-# 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) syb-0.7.2.4/tests/FoldTree.hs0000644000000000000000000000506207346545000014055 0ustar0000000000000000{-# 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])" syb-0.7.2.4/tests/FreeNames.hs0000644000000000000000000000652707346545000014225 0ustar0000000000000000{-# 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"] syb-0.7.2.4/tests/GEq.hs0000644000000000000000000000074207346545000013025 0ustar0000000000000000{-# 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) syb-0.7.2.4/tests/GMapQAssoc.hs0000644000000000000000000000402007346545000014300 0ustar0000000000000000{-# 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]]) syb-0.7.2.4/tests/GRead.hs0000644000000000000000000000235707346545000013337 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module GRead (tests) where {- The following examples achieve branch coverage for the various productions in the definition of gread. Also, negative test cases are provided; see str2 and str3. Also, the potential of heading or trailing spaces as well incomplete parsing of the input is exercised; see str5. -} import Test.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 ++ ")" tests = show ( ( [ gread str1, gread str2, gread str3 ] , [ gread str4, gread str5 ] , [ gread str6, gread str7 ] ) :: ( [[(Bool, String)]] , [[(Int, String)]] , [[([Int], String)]] ) ) @=? output output = show ([[(True,"")],[],[]],[[(1,"")],[(2,"...")]],[[([],"")],[([1],"")]]) syb-0.7.2.4/tests/GRead2.hs0000644000000000000000000000353507346545000013420 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} module GRead2 () where {- For the discussion in the 2nd boilerplate paper, we favour some simplified generic read, which is checked to compile. For the full/real story see Data.Generics.Text. -} import Control.Applicative (Applicative(..)) import Control.Monad (ap, liftM) import Data.Generics gread :: Data a => String -> Maybe a gread input = runDec input readM -- The decoder monad newtype DecM a = D (String -> Maybe (String, a)) instance Functor DecM where fmap = liftM instance Applicative DecM where pure a = D (\s -> Just (s,a)) (<*>) = ap instance Monad DecM where 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 parseConstr :: DataType -> DecM Constr parseConstr ty = D (\s -> match s (dataTypeConstrs ty)) where match :: String -> [Constr] -> Maybe (String, Constr) match _ [] = Nothing match input (con:cons) | take n input == showConstr con = Just (drop n input, con) | otherwise = match input cons where n = length (showConstr con) readM :: forall a. Data a => DecM a readM = read where read :: DecM a read = do { let val = argOf read ; let ty = dataTypeOf val ; constr <- parseConstr ty ; let con::a = fromConstr constr ; gmapM (\_ -> readM) con } argOf :: c a -> a argOf = undefined yareadM :: forall a. Data a => DecM a yareadM = do { let ty = dataTypeOf (undefined::a) ; constr <- parseConstr ty ; let con::a = fromConstr constr ; gmapM (\_ -> yareadM) con } syb-0.7.2.4/tests/GShow.hs0000644000000000000000000000225607346545000013402 0ustar0000000000000000{-# 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)]") syb-0.7.2.4/tests/GShow2.hs0000644000000000000000000000223707346545000013463 0ustar0000000000000000{-# 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))) ([])) ([]))))" syb-0.7.2.4/tests/GZip.hs0000644000000000000000000000305407346545000013221 0ustar0000000000000000{-# 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)) []]) syb-0.7.2.4/tests/GenUpTo.hs0000644000000000000000000000641107346545000013671 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} 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, 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)])))) syb-0.7.2.4/tests/GetC.hs0000644000000000000000000000741207346545000013174 0ustar0000000000000000{-# 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 syb-0.7.2.4/tests/HList.hs0000644000000000000000000000271007346545000013371 0ustar0000000000000000{-# 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) -- Test for an empty list nullHList :: HList -> Bool nullHList = null -- Retrieve head by type case headHList :: Typeable a => HList -> Maybe a headHList [] = Nothing headHList (DontKnow a:_) = cast a -- Retrieve tail by type case tailHList :: HList -> HList tailHList = tail -- Access per index; starts at 1 nth1HList :: Typeable a => Int -> HList -> Maybe a nth1HList i l = case (l !! (i-1)) of (DontKnow a) -> cast a ---------------------------------------------------------------------------- -- A demo list mylist = addHList (1::Int) $ addHList (True::Bool) $ addHList ("42"::String) $ initHList -- Main function for testing tests = ( show (nth1HList 1 mylist :: Maybe Int) -- shows Just 1 , ( show (nth1HList 1 mylist :: Maybe Bool) -- shows Nothing , ( show (nth1HList 2 mylist :: Maybe Bool) -- shows Just True , ( show (nth1HList 3 mylist :: Maybe String) -- shows Just "42" )))) @=? output output = ("Just 1",("Nothing",("Just True","Just \"42\""))) syb-0.7.2.4/tests/HOPat.hs0000644000000000000000000000340007346545000013316 0ustar0000000000000000{-# 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))))) syb-0.7.2.4/tests/Labels.hs0000644000000000000000000000130207346545000013544 0ustar0000000000000000{-# 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"]) syb-0.7.2.4/tests/LocalQuantors.hs0000644000000000000000000000111607346545000015134 0ustar0000000000000000{-# 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] syb-0.7.2.4/tests/Main.hs0000644000000000000000000000441407346545000013235 0ustar0000000000000000 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 ] syb-0.7.2.4/tests/NestedDatatypes.hs0000644000000000000000000000252107346545000015447 0ustar0000000000000000{-# 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] syb-0.7.2.4/tests/Newtype.hs0000644000000000000000000000057607346545000014011 0ustar0000000000000000{-# 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 syb-0.7.2.4/tests/Paradise.hs0000644000000000000000000000141507346545000014077 0ustar0000000000000000module 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)) []] syb-0.7.2.4/tests/Perm.hs0000644000000000000000000001055407346545000013256 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Perm (tests) where {- This module illustrates permutation phrases. Disclaimer: this is a perhaps naive, certainly undebugged example. -} import Test.Tasty.HUnit import Control.Applicative (Alternative(..), Applicative(..)) import Control.Monad import Data.Generics --------------------------------------------------------------------------- -- We want to read terms of type T3 regardless of the order T1 and T2. --------------------------------------------------------------------------- data T1 = T1 deriving (Show, Eq, Typeable, Data) data T2 = T2 deriving (Show, Eq, Typeable, Data) data T3 = T3 T1 T2 deriving (Show, Eq, Typeable, Data) --------------------------------------------------------------------------- -- A silly monad that we use to read lists of constructor strings. --------------------------------------------------------------------------- -- Type constructor newtype ReadT a = ReadT { unReadT :: [String] -> Maybe ([String],a) } -- Run a computation runReadT x y = case unReadT x y of Just ([],y) -> Just y _ -> Nothing -- Read one string readT :: ReadT String readT = ReadT (\x -> if null x then Nothing else Just (tail x, head x) ) instance Functor ReadT where fmap = liftM instance Applicative ReadT where pure x = ReadT (\y -> Just (y,x)) (<*>) = ap instance Alternative ReadT where (<|>) = mplus empty = mzero -- ReadT is a monad! instance Monad ReadT where return = pure c >>= f = ReadT (\x -> case unReadT c x of Nothing -> Nothing Just (x', a) -> unReadT (f a) x' ) -- ReadT also accommodates mzero and mplus! instance MonadPlus ReadT where mzero = ReadT (const Nothing) f `mplus` g = ReadT (\x -> case unReadT f x of Nothing -> unReadT g x y -> y ) --------------------------------------------------------------------------- -- A helper type to appeal to predicative type system. --------------------------------------------------------------------------- newtype GenM = GenM { unGenM :: forall a. Data a => a -> ReadT a } --------------------------------------------------------------------------- -- The function that reads and copes with all permutations. --------------------------------------------------------------------------- buildT :: forall a. Data a => ReadT a buildT = result where result = do str <- readT con <- string2constr str ske <- return $ fromConstr con fs <- return $ gmapQ buildT' ske perm [] fs ske -- Determine type of data to be constructed myType = myTypeOf result where myTypeOf :: forall a. ReadT a -> a myTypeOf = undefined -- Turn string into constructor string2constr str = maybe mzero return (readConstr (dataTypeOf myType) str) -- Specialise buildT per kid type buildT' :: forall a. Data a => a -> GenM buildT' (_::a) = GenM (const mzero `extM` const (buildT::ReadT a)) -- The permutation exploration function perm :: forall a. Data a => [GenM] -> [GenM] -> a -> ReadT a perm [] [] a = return a perm fs [] a = perm [] fs a perm fs (f:fs') a = ( do a' <- gmapMo (unGenM f) a perm fs fs' a' ) `mplus` ( do guard (not (null fs')) perm (f:fs) fs' a ) --------------------------------------------------------------------------- -- The main function for testing --------------------------------------------------------------------------- tests = ( runReadT buildT ["T1"] :: Maybe T1 -- should parse fine , ( runReadT buildT ["T2"] :: Maybe T2 -- should parse fine , ( runReadT buildT ["T3","T1","T2"] :: Maybe T3 -- should parse fine , ( runReadT buildT ["T3","T2","T1"] :: Maybe T3 -- should parse fine , ( runReadT buildT ["T3","T2","T2"] :: Maybe T3 -- should fail ))))) @=? output output = (Just T1,(Just T2,(Just (T3 T1 T2),(Just (T3 T1 T2),Nothing)))) syb-0.7.2.4/tests/Polymatch.hs0000644000000000000000000000351707346545000014314 0ustar0000000000000000{-# 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") syb-0.7.2.4/tests/Reify.hs0000644000000000000000000002470207346545000013431 0ustar0000000000000000 {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Reify (tests) where {- The following examples illustrate the reification facilities for type structure. Most notably, we generate shallow terms using the depth of types and constructors as means to steer the generation. -} import Test.Tasty.HUnit import Data.Maybe import Data.Generics import Control.Monad.State import CompanyDatatypes ------------------------------------------------------------------------------ -- -- Encoding types as values; some other way. -- ------------------------------------------------------------------------------ {- This group provides a style of encoding types as values and using them. This style is seen as an alternative to the pragmatic style used in Data.Typeable.typeOf and elsewhere, i.e., simply use an "undefined" to denote a type argument. This pragmatic style suffers from lack of robustness: one feels tempted to pattern match on undefineds. Maybe Data.Typeable.typeOf etc. should be rewritten accordingly. -} -- | Type as values to stipulate use of undefineds type TypeVal a = a -> () -- | The value that denotes a type typeVal :: TypeVal a typeVal = const () -- | Test for type equivalence sameType :: (Typeable a, Typeable b) => TypeVal a -> TypeVal b -> Bool sameType tva tvb = typeOf (type2val tva) == typeOf (type2val tvb) -- | Map a value to its type val2type :: a -> TypeVal a val2type _ = typeVal -- | Stipulate this idiom! type2val :: TypeVal a -> a type2val _ = undefined -- | Constrain a type withType :: a -> TypeVal a -> a withType x _ = x -- | The argument type of a function argType :: (a -> b) -> TypeVal a argType _ = typeVal -- | The result type of a function resType :: (a -> b) -> TypeVal b resType _ = typeVal -- | The parameter type of type constructor paraType :: t a -> TypeVal a paraType _ = typeVal -- Type functions, -- i.e., functions mapping types to values -- type TypeFun a r = TypeVal a -> r -- Generic type functions, -- i.e., functions mapping types to values -- type GTypeFun r = forall a. Data a => TypeFun a r -- | Extend a type function extType :: (Data a, Typeable r) => GTypeFun r -> TypeFun a r -> GTypeFun r extType f x = maybe f id (cast x) ------------------------------------------------------------------------------ -- -- Mapping operators to map over type structure -- ------------------------------------------------------------------------------ -- | Query all constructors of a given type gmapType :: ([(Constr,r')] -> r) -> GTypeFun (Constr -> r') -> GTypeFun r gmapType (o::[(Constr,r')] -> r) f (t::TypeVal a) = o $ zip cons query where -- All constructors of the given type cons :: [Constr] cons = if isAlgType $ dataTypeOf $ type2val t then dataTypeConstrs $ dataTypeOf $ type2val t else [] -- Query constructors query :: [r'] query = map (f t) cons -- | Query all subterm types of a given constructor gmapConstr :: ([r] -> r') -> GTypeFun r -> GTypeFun (Constr -> r') gmapConstr (o::[r] -> r') f (t::TypeVal a) c = o $ query where -- Term for the given constructor term :: a term = fromConstr c -- Query subterm types query :: [r] query = gmapQ (f . val2type) term -- | Compute arity of a given constructor constrArity :: GTypeFun (Constr -> Int) constrArity t c = glength $ withType (fromConstr c) t -- | Query all immediate subterm types of a given type gmapSubtermTypes :: (Data a, Typeable r) => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r gmapSubtermTypes o (r::r) f (t::TypeVal a) = reduce (concat (map (gmapQ (query . val2type)) terms)) (GTypeFun' f) where -- All constructors of the given type cons :: [Constr] cons = if isAlgType $ dataTypeOf $ type2val t then dataTypeConstrs $ dataTypeOf $ type2val t else [] -- Terms for all constructors terms :: [a] terms = map fromConstr cons -- Query a subterm type query :: Data b => TypeVal b -> GTypeFun' r -> (r,GTypeFun' r) query t f = (unGTypeFun' f t, GTypeFun' (disable t (unGTypeFun' f))) -- Constant out given type disable :: Data b => TypeVal b -> GTypeFun r -> GTypeFun r disable (t::TypeVal b) f = f `extType` \(_::TypeVal b) -> r -- Reduce all subterm types reduce :: [GTypeFun' r -> (r,GTypeFun' r)] -> GTypeFun' r -> r reduce [] _ = r reduce (xy:z) g = fst (xy g) `o` reduce z (snd (xy g)) -- First-class polymorphic variation on GTypeFun newtype GTypeFun' r = GTypeFun' (GTypeFun r) unGTypeFun' (GTypeFun' f) = f -- | Query all immediate subterm types. -- There is an extra argument to \"constant out\" the type at hand. -- This can be used to avoid cycles. gmapSubtermTypesConst :: (Data a, Typeable r) => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r gmapSubtermTypesConst o (r::r) f (t::TypeVal a) = gmapSubtermTypes o r f' t where f' :: GTypeFun r f' = f `extType` \(_::TypeVal a) -> r -- Count all distinct subterm types gcountSubtermTypes :: Data a => TypeVal a -> Int gcountSubtermTypes = gmapSubtermTypes (+) (0::Int) (const 1) -- | A simplied variation on gmapSubtermTypes. -- Weakness: no awareness of doubles. -- Strength: easy to comprehend as it uses gmapType and gmapConstr. _gmapSubtermTypes :: (Data a, Typeable r) => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r _gmapSubtermTypes o (r::r) f = gmapType otype (gmapConstr oconstr f) where otype :: [(Constr,r)] -> r otype = foldr (\x y -> snd x `o` y) r oconstr :: [r] -> r oconstr = foldr o r ------------------------------------------------------------------------------ -- -- Some reifying relations on types -- ------------------------------------------------------------------------------ -- | Reachability relation on types, i.e., -- test if nodes of type @a@ are reachable from nodes of type @b@. -- The relation is defined to be reflexive. reachableType :: (Data a, Data b) => TypeVal a -> TypeVal b -> Bool reachableType (a::TypeVal a) (b::TypeVal b) = or [ sameType a b , gmapSubtermTypesConst (\x y -> or [x,y]) False (reachableType a) b ] -- | Depth of a datatype as the constructor with the minimum depth. -- The outermost 'Nothing' denotes a type without constructors. -- The innermost 'Nothing' denotes potentially infinite. depthOfType :: GTypeFun Bool -> GTypeFun (Maybe (Constr, Maybe Int)) depthOfType p (t::TypeVal a) = gmapType o f t where o :: [(Constr, Maybe Int)] -> Maybe (Constr, Maybe Int) o l = if null l then Nothing else Just (foldr1 min' l) f :: GTypeFun (Constr -> Maybe Int) f = depthOfConstr p' -- Specific minimum operator min' :: (Constr, Maybe Int) -> (Constr, Maybe Int) -> (Constr, Maybe Int) min' x (_, Nothing) = x min' (_, Nothing) x = x min' (c, Just i) (c', Just i') | i <= i' = (c, Just i) min' (c, Just i) (c', Just i') = (c', Just i') -- Updated predicate for unblocked types p' :: GTypeFun Bool p' = p `extType` \(_::TypeVal a) -> False -- | Depth of a constructor. -- Depth is viewed as the maximum depth of all subterm types + 1. -- 'Nothing' denotes potentially infinite. depthOfConstr :: GTypeFun Bool -> GTypeFun (Constr -> Maybe Int) depthOfConstr p (t::TypeVal a) c = gmapConstr o f t c where o :: [Maybe Int] -> Maybe Int o = inc' . foldr max' (Just 0) f :: GTypeFun (Maybe Int) f t' = if p t' then case depthOfType p t' of Nothing -> Just 0 Just (_, x) -> x else Nothing -- Specific maximum operator max' Nothing _ = Nothing max' _ Nothing = Nothing max' (Just i) (Just i') | i >= i' = Just i max' (Just i) (Just i') = Just i' -- Specific increment operator inc' Nothing = Nothing inc' (Just i) = Just (i+1) ------------------------------------------------------------------------------ -- -- Build a shallow term -- ------------------------------------------------------------------------------ shallowTerm :: (forall a. Data a => Maybe a) -> (forall b. Data b => b) shallowTerm cust = result where result :: forall b. Data b => b -- Need a type signature here to bring 'b' into scope result = maybe gdefault id cust where -- The worker, also used for type disambiguation gdefault :: b gdefault = case con of Just (con, Just _) -> fromConstrB (shallowTerm cust) con _ -> error "no shallow term!" -- The type to be constructed typeVal :: TypeVal b typeVal = val2type gdefault -- The most shallow constructor if any con :: Maybe (Constr, Maybe Int) con = depthOfType (const True) typeVal -- For testing shallowTerm shallowTermBase :: GenericR Maybe shallowTermBase = Nothing `extR` Just (1.23::Double) `extR` Just ("foo"::String) -- Sample datatypes data T1 = T1a deriving (Typeable, Data) -- just a constant data T2 = T2 T1 deriving (Typeable, Data) -- little detour data T3 = T3a T3 | T3b T2 deriving (Typeable, Data) -- recursive case data T4 = T4 T3 T3 deriving (Typeable, Data) -- sum matters -- Sample type arguments t0 = typeVal :: TypeVal Int t1 = typeVal :: TypeVal T1 t2 = typeVal :: TypeVal T2 t3 = typeVal :: TypeVal T3 t4 = typeVal :: TypeVal T4 tCompany = typeVal :: TypeVal Company tPerson = typeVal :: TypeVal Person tEmployee = typeVal :: TypeVal Employee tDept = typeVal :: TypeVal Dept -- Test cases test0 = t1 `reachableType` t1 -- True test1 = t1 `reachableType` t2 -- True test2 = t2 `reachableType` t1 -- False test3 = t1 `reachableType` t3 test4 = tPerson `reachableType` tCompany test5 = gcountSubtermTypes tPerson test6 = gcountSubtermTypes tEmployee test7 = gcountSubtermTypes tDept test8 = shallowTerm shallowTermBase :: Person test9 = shallowTerm shallowTermBase :: Employee test10 = shallowTerm shallowTermBase :: Dept tests = ( test0 , ( test1 , ( test2 , ( test3 , ( test4 , ( test5 , ( test6 , ( test7 , ( test8 , ( test9 , ( test10 ))))))))))) @=? output output = (True,(True,(False,(True,(True,(1,(2,(3,(P "foo" "foo", (E (P "foo" "foo") (S 1.23), D "foo" (E (P "foo" "foo") (S 1.23)) [])))))))))) syb-0.7.2.4/tests/Strings.hs0000644000000000000000000000072607346545000014004 0ustar0000000000000000module 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 syb-0.7.2.4/tests/Tree.hs0000644000000000000000000000655107346545000013254 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} 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 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))) syb-0.7.2.4/tests/Twin.hs0000644000000000000000000000451107346545000013270 0ustar0000000000000000{-# 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) syb-0.7.2.4/tests/Typecase1.hs0000644000000000000000000000253707346545000014213 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module Typecase1 (tests) where {- This test demonstrates type case as it lives in Data.Typeable. We define a function f that converts typeables into strings in some way. Note: we only need Data.Typeable. Say: Dynamics are NOT involved. -} import Test.Tasty.HUnit import Data.Typeable import Data.Maybe -- Some datatype. data MyTypeable = MyCons String deriving (Show, Typeable) -- -- Some function that performs type case. -- f :: (Show a, Typeable a) => a -> String f a = (maybe (maybe (maybe others mytys (cast a) ) float (cast a) ) int (cast a) ) where -- do something with ints int :: Int -> String int a = "got an int, incremented: " ++ show (a + 1) -- do something with floats float :: Double -> String float a = "got a float, multiplied by .42: " ++ show (a * 0.42) -- do something with my typeables mytys :: MyTypeable -> String mytys a = "got a term: " ++ show a -- do something with all other typeables others = "got something else: " ++ show a -- -- Test the type case -- tests = ( f (41::Int) , f (88::Double) , f (MyCons "42") , f True) @=? output output = ( "got an int, incremented: 42" , "got a float, multiplied by .42: 36.96" , "got a term: MyCons \"42\"" , "got something else: True") syb-0.7.2.4/tests/Typecase2.hs0000644000000000000000000000255507346545000014214 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module Typecase2 (tests) where {- This test provides a variation on typecase1.hs. This time, we use generic show as defined for all instances of Data. Thereby, we get rid of the Show constraint in our functions. So we only keep a single constraint: the one for class Data. -} import Test.Tasty.HUnit import Data.Generics import Data.Maybe -- Some datatype. data MyData = MyCons String deriving (Typeable, Data) -- -- Some function that performs type case. -- f :: Data a => a -> String f a = (maybe (maybe (maybe others mytys (cast a) ) float (cast a) ) int (cast a) ) where -- do something with ints int :: Int -> String int a = "got an int, incremented: " ++ show (a + 1) -- do something with floats float :: Double -> String float a = "got a float, multiplied by .42: " ++ show (a * 0.42) -- do something with my data mytys :: MyData -> String mytys a = "got my data: " ++ gshow a -- do something with all other data others = "got something else: " ++ gshow a -- -- Test the type case -- tests = ( f (41::Int) , f (88::Double) , f (MyCons "42") , f True) @=? output output = ( "got an int, incremented: 42" , "got a float, multiplied by .42: 36.96" , "got my data: (MyCons \"42\")" , "got something else: (True)") syb-0.7.2.4/tests/Where.hs0000644000000000000000000001200107346545000013412 0ustar0000000000000000{-# 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)))))))" syb-0.7.2.4/tests/XML.hs0000644000000000000000000001456107346545000013015 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} module XML (tests) where {- This example illustrates XMLish services to trealise (say, "serialise") heterogenous Haskell data as homogeneous tree structures (say, XMLish elements) and vice versa. -} import Test.Tasty.HUnit import Control.Applicative (Alternative(..), Applicative(..)) import Control.Monad import Data.Maybe import Data.Generics import CompanyDatatypes -- HaXml-like types for XML elements data Element = Elem Name [Attribute] [Content] deriving (Show, Eq, Typeable, Data) data Content = CElem Element | CString Bool CharData -- ^ bool is whether whitespace is significant | CRef Reference | CMisc Misc deriving (Show, Eq, Typeable, Data) type CharData = String -- In this simple example we disable some parts of XML type Attribute = () type Reference = () type Misc = () -- Trealisation data2content :: Data a => a -> [Content] data2content = element `ext1Q` list `extQ` string `extQ` float where -- Handle an element element x = [CElem (Elem (tyconUQname (dataTypeName (dataTypeOf x))) [] -- no attributes (concat (gmapQ data2content x)))] -- A special case for lists list :: Data a => [a] -> [Content] list = concat . map data2content -- A special case for strings string :: String -> [Content] string x = [CString True x] -- A special case for floats float :: Double -> [Content] float x = [CString True (show x)] -- De-trealisation content2data :: forall a. Data a => ReadX a content2data = result where -- Case-discriminating worker result = element `ext1R` list `extR` string `extR` float -- Determine type of data to be constructed myType = myTypeOf result where myTypeOf :: forall a. ReadX a -> a myTypeOf = undefined -- Handle an element element = do c <- readX case c of (CElem (Elem x as cs)) | as == [] -- no attributes && x == (tyconUQname (dataTypeName (dataTypeOf myType))) -> alts cs _ -> mzero -- A special case for lists list :: forall a. Data a => ReadX [a] list = ( do h <- content2data t <- list return (h:t) ) `mplus` return [] -- Fold over all alternatives, say constructors alts cs = foldr (mplus . recurse cs) mzero shapes -- Possible top-level shapes shapes = map fromConstr consOf -- Retrieve all constructors of the requested type consOf = dataTypeConstrs $ dataTypeOf $ myType -- Recurse into subterms recurse cs x = maybe mzero return (runReadX (gmapM (const content2data) x) cs) -- A special case for strings string :: ReadX String string = do c <- readX case c of (CString _ x) -> return x _ -> mzero -- A special case for floats float :: ReadX Double float = do c <- readX case c of (CString _ x) -> return (read x) _ -> mzero ----------------------------------------------------------------------------- -- -- An XML-hungry parser-like monad -- ----------------------------------------------------------------------------- -- Type constructor newtype ReadX a = ReadX { unReadX :: [Content] -> Maybe ([Content], a) } -- Run a computation runReadX x y = case unReadX x y of Just ([],y) -> Just y _ -> Nothing -- Read one content particle readX :: ReadX Content readX = ReadX (\x -> if null x then Nothing else Just (tail x, head x) ) instance Functor ReadX where fmap = liftM instance Applicative ReadX where pure x = ReadX (\y -> Just (y,x)) (<*>) = ap instance Alternative ReadX where (<|>) = mplus empty = mzero -- ReadX is a monad! instance Monad ReadX where return = pure c >>= f = ReadX (\x -> case unReadX c x of Nothing -> Nothing Just (x', a) -> unReadX (f a) x' ) -- ReadX also accommodates mzero and mplus! instance MonadPlus ReadX where mzero = ReadX (const Nothing) f `mplus` g = ReadX (\x -> case unReadX f x of Nothing -> unReadX g x y -> y ) ----------------------------------------------------------------------------- -- -- Main function for testing -- ----------------------------------------------------------------------------- tests = ( genCom , ( data2content genCom , ( zigzag person1 :: Maybe Person , ( zigzag genCom :: Maybe Company , ( zigzag genCom == Just genCom ))))) @=? output where -- Trealise back and forth zigzag :: Data a => a -> Maybe a zigzag = runReadX content2data . data2content output = (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []],([CElem (Elem "Company" [] [CElem (Elem "Dept" [] [CString True "Research",CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Laemmel",CString True "Amsterdam"]),CElem (Elem "Salary" [] [CString True "8000.0"])]),CElem (Elem "Unit" [] [CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Joost",CString True "Amsterdam"]),CElem (Elem "Salary" [] [CString True "1000.0"])])]),CElem (Elem "Unit" [] [CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Marlow",CString True "Cambridge"]),CElem (Elem "Salary" [] [CString True "2000.0"])])])]),CElem (Elem "Dept" [] [CString True "Strategy",CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Blair",CString True "London"]),CElem (Elem "Salary" [] [CString True "100000.0"])])])])],(Just (P "Lazy" "Home"),(Just (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []]),True))))