packages feed

syb 0.1.0.2 → 0.7.4

raw patch · 65 files changed

Files

+ Changelog.md view
@@ -0,0 +1,29 @@+# 0.7.4++- Export new function `gshowsF` that allows more flexibility than `gshows`.+  It allows users to override how some children types should be printed. (https://github.com/dreixel/syb/pull/55)++# 0.7.3++- Fix `gread` to recognize negative numbers (https://github.com/dreixel/syb/issues/13)+- Bump minimum required GHC to 8.0+- `Generic'` is now a newtype instead of data, add `GenericR'` and `GenericB'` (https://github.com/dreixel/syb/issues/49)++# 0.7.2.4+- Improved documentation (thanks to @BinderDavid)+- Export `ext2` function which was already defined but not exported++# 0.7.2.3+- Compatibility with `mtl` 2.3 and GHC 9.6++# 0.7.2.2+- Compatibility with GHC 9.4++# 0.7.2.1+- Update cabal version++# 0.7.2+- Add compatibility with GHC 9, switch to tasty for tests, fix tests on GHCJS++# 0.7.1+- Define recursive traversals in two parts, non-recursive wrapper and recursive local helper to facilitate inlining and avoid passing the same argument to all recursive calls
− Data/Generics.hs 
@@ -1,53 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Generics--- Copyright   :  (c) The University of Glasgow, CWI 2001--2004--- License     :  BSD-style (see the LICENSE file)--- --- Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable (uses Data.Generics.Basics)------ \"Scrap your boilerplate\" --- Generic programming in Haskell --- See <http://www.cs.vu.nl/boilerplate/>. To scrap your boilerplate it--- is sufficient to import the present module, which simply re-exports all--- themes of the Data.Generics library.------ For more information, please visit the new--- SYB wiki: <http://www.cs.uu.nl/wiki/bin/view/GenericProgramming/SYB>.-----------------------------------------------------------------------------------module Data.Generics (--  -- * All Data.Generics modules-  module Data.Data,               -- primitives and instances of the Data class-  module Data.Generics.Aliases,   -- aliases for type case, generic types-  module Data.Generics.Schemes,   -- traversal schemes (everywhere etc.)-  module Data.Generics.Text,      -- generic read and show-  module Data.Generics.Twins,     -- twin traversal, e.g., generic eq--#ifndef __HADDOCK__-        -- Data types for the sum-of-products type encoding;-        -- included for backwards compatibility; maybe obsolete.-        (:*:)(..), (:+:)(..), Unit(..)-#endif-- ) where----------------------------------------------------------------------------------#ifdef __GLASGOW_HASKELL__-#ifndef __HADDOCK__-        -- Data types for the sum-of-products type encoding;-        -- included for backwards compatibility; maybe obsolete.-import GHC.Base ( (:*:)(..), (:+:)(..), Unit(..) )-#endif-#endif--import Data.Data-import Data.Generics.Instances ()-import Data.Generics.Aliases-import Data.Generics.Schemes-import Data.Generics.Text-import Data.Generics.Twins
− Data/Generics/Aliases.hs 
@@ -1,368 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Aliases--- Copyright   :  (c) The University of Glasgow, CWI 2001--2004--- License     :  BSD-style (see the LICENSE file)--- --- Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable (local universal quantification)------ \"Scrap your boilerplate\" --- Generic programming in Haskell --- See <http://www.cs.vu.nl/boilerplate/>. The present module provides--- a number of declarations for typical generic function types,--- corresponding type case, and others.-----------------------------------------------------------------------------------module Data.Generics.Aliases (--        -- * Combinators to \"make\" generic functions via cast-        mkT, mkQ, mkM, mkMp, mkR,-        ext0, extT, extQ, extM, extMp, extB, extR,--        -- * Type synonyms for generic function types-        GenericT,-        GenericQ,-        GenericM,-        GenericB,-        GenericR,-        Generic,-        Generic'(..),-        GenericT'(..),-        GenericQ'(..),-        GenericM'(..),--        -- * Inredients of generic functions-        orElse,--        -- * Function combinators on generic functions-        recoverMp,-        recoverQ,-        choiceMp,-        choiceQ,--        -- * Type extension for unary type constructors-        ext1T,-        ext1M,-        ext1Q,-        ext1R--  ) where--#ifdef __HADDOCK__-import Prelude-#endif-import Control.Monad-import Data.Data--------------------------------------------------------------------------------------      Combinators to "make" generic functions---      We use type-safe cast in a number of ways to make generic functions.-------------------------------------------------------------------------------------- | Make a generic transformation;---   start from a type-specific case;---   preserve the term otherwise----mkT :: ( Typeable a-       , Typeable b-       )-    => (b -> b)-    -> a-    -> a-mkT = extT id----- | Make a generic query;---   start from a type-specific case;---   return a constant otherwise----mkQ :: ( Typeable a-       , Typeable b-       )-    => r-    -> (b -> r)-    -> a-    -> r-(r `mkQ` br) a = case cast a of-                        Just b  -> br b-                        Nothing -> r----- | Make a generic monadic transformation;---   start from a type-specific case;---   resort to return otherwise----mkM :: ( Monad m-       , Typeable a-       , Typeable b-       )-    => (b -> m b)-    -> a-    -> m a-mkM = extM return---{---For the remaining definitions, we stick to a more concise style, i.e.,-we fold maybies with "maybe" instead of case ... of ..., and we also-use a point-free style whenever possible.---}----- | Make a generic monadic transformation for MonadPlus;---   use \"const mzero\" (i.e., failure) instead of return as default.----mkMp :: ( MonadPlus m-        , Typeable a-        , Typeable b-        )-     => (b -> m b)-     -> a-     -> m a-mkMp = extM (const mzero)----- | Make a generic builder;---   start from a type-specific ase;---   resort to no build (i.e., mzero) otherwise----mkR :: ( MonadPlus m-       , Typeable a-       , Typeable b-       )-    => m b -> m a-mkR f = mzero `extR` f----- | Flexible type extension-ext0 :: (Typeable a, Typeable b) => c a -> c b -> c a-ext0 def ext = maybe def id (gcast ext)----- | Extend a generic transformation by a type-specific case-extT :: ( Typeable a-        , Typeable b-        )-     => (a -> a)-     -> (b -> b)-     -> a-     -> a-extT def ext = unT ((T def) `ext0` (T ext))----- | Extend a generic query by a type-specific case-extQ :: ( Typeable a-        , Typeable b-        )-     => (a -> q)-     -> (b -> q)-     -> a-     -> q-extQ f g a = maybe (f a) g (cast a)----- | Extend a generic monadic transformation by a type-specific case-extM :: ( Monad m-        , Typeable a-        , Typeable b-        )-     => (a -> m a) -> (b -> m b) -> a -> m a-extM def ext = unM ((M def) `ext0` (M ext))----- | Extend a generic MonadPlus transformation by a type-specific case-extMp :: ( MonadPlus m-         , Typeable a-         , Typeable b-         )-      => (a -> m a) -> (b -> m b) -> a -> m a-extMp = extM----- | Extend a generic builder-extB :: ( Typeable a-        , Typeable b-        )-     => a -> b -> a-extB a = maybe a id . cast----- | Extend a generic reader-extR :: ( Monad m-        , Typeable a-        , Typeable b-        )-     => m a -> m b -> m a-extR def ext = unR ((R def) `ext0` (R ext))----------------------------------------------------------------------------------------      Type synonyms for generic function types--------------------------------------------------------------------------------------- | Generic transformations,---   i.e., take an \"a\" and return an \"a\"----type GenericT = forall a. Data a => a -> a----- | Generic queries of type \"r\",---   i.e., take any \"a\" and return an \"r\"----type GenericQ r = forall a. Data a => a -> r----- | Generic monadic transformations,---   i.e., take an \"a\" and compute an \"a\"----type GenericM m = forall a. Data a => a -> m a----- | Generic builders---   i.e., produce an \"a\".----type GenericB = forall a. Data a => a----- | Generic readers, say monadic builders,---   i.e., produce an \"a\" with the help of a monad \"m\".----type GenericR m = forall a. Data a => m a----- | The general scheme underlying generic functions---   assumed by gfoldl; there are isomorphisms such as---   GenericT = Generic T.----type Generic c = forall a. Data a => a -> c a----- | Wrapped generic functions;---   recall: [Generic c] would be legal but [Generic' c] not.----data Generic' c = Generic' { unGeneric' :: Generic c }----- | Other first-class polymorphic wrappers-newtype GenericT'   = GT { unGT :: Data a => a -> a }-newtype GenericQ' r = GQ { unGQ :: GenericQ r }-newtype GenericM' m = GM { unGM :: Data a => a -> m a }----- | Left-biased choice on maybies-orElse :: Maybe a -> Maybe a -> Maybe a-x `orElse` y = case x of-                 Just _  -> x-                 Nothing -> y---{---The following variations take "orElse" to the function-level. Furthermore, we generalise from "Maybe" to any-"MonadPlus". This makes sense for monadic transformations and-queries. We say that the resulting combinators modell choice. We also-provide a prime example of choice, that is, recovery from failure. In-the case of transformations, we recover via return whereas for-queries a given constant is returned.---}---- | Choice for monadic transformations-choiceMp :: MonadPlus m => GenericM m -> GenericM m -> GenericM m-choiceMp f g x = f x `mplus` g x----- | Choice for monadic queries-choiceQ :: MonadPlus m => GenericQ (m r) -> GenericQ (m r) -> GenericQ (m r)-choiceQ f g x = f x `mplus` g x----- | Recover from the failure of monadic transformation by identity-recoverMp :: MonadPlus m => GenericM m -> GenericM m-recoverMp f = f `choiceMp` return----- | Recover from the failure of monadic query by a constant-recoverQ :: MonadPlus m => r -> GenericQ (m r) -> GenericQ (m r)-recoverQ r f = f `choiceQ` const (return r)----------------------------------------------------------------------------------------      Type extension for unary type constructors---------------------------------------------------------------------------------------- | Flexible type extension-ext1 :: (Data a, Typeable1 t)-     => c a-     -> (forall d. Data d => c (t d))-     -> c a-ext1 def ext = maybe def id (dataCast1 ext)----- | Type extension of transformations for unary type constructors-ext1T :: (Data d, Typeable1 t)-      => (forall e. Data e => e -> e)-      -> (forall f. Data f => t f -> t f)-      -> d -> d-ext1T def ext = unT ((T def) `ext1` (T ext))----- | Type extension of monadic transformations for type constructors-ext1M :: (Monad m, Data d, Typeable1 t)-      => (forall e. Data e => e -> m e)-      -> (forall f. Data f => t f -> m (t f))-      -> d -> m d-ext1M def ext = unM ((M def) `ext1` (M ext))----- | Type extension of queries for type constructors-ext1Q :: (Data d, Typeable1 t)-      => (d -> q)-      -> (forall e. Data e => t e -> q)-      -> d -> q-ext1Q def ext = unQ ((Q def) `ext1` (Q ext))----- | Type extension of readers for type constructors-ext1R :: (Monad m, Data d, Typeable1 t)-      => m d-      -> (forall e. Data e => m (t e))-      -> m d-ext1R def ext = unR ((R def) `ext1` (R ext))----------------------------------------------------------------------------------------      Type 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 }
− Data/Generics/Basics.hs 
@@ -1,26 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Basics--- Copyright   :  (c) The University of Glasgow, CWI 2001--2004--- License     :  BSD-style (see the LICENSE file)--- --- Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable (local universal quantification)------ \"Scrap your boilerplate\" --- Generic programming in Haskell.--- See <http://www.cs.vu.nl/boilerplate/>. This module provides--- the 'Data' class with its primitives for generic programming,--- which is now defined in @Data.Data@. Therefore this module simply--- re-exports @Data.Data@.------ For more information, please visit the new--- SYB wiki: <http://www.cs.uu.nl/wiki/bin/view/GenericProgramming/SYB>.-----------------------------------------------------------------------------------module Data.Generics.Basics (-        module Data.Data-  ) where--import Data.Data
− Data/Generics/Instances.hs 
@@ -1,185 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Instances--- Copyright   :  (c) The University of Glasgow, CWI 2001--2004--- License     :  BSD-style (see the LICENSE file)--- --- Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable (uses Data.Data)------ \"Scrap your boilerplate\" --- Generic programming in Haskell --- See <http://www.cs.vu.nl/boilerplate/>. The present module--- contains thirteen 'Data' instances which are considered dubious (either--- because the types are abstract or just not meant to be traversed).--- Instances in this module might change or disappear in future releases--- of this package. ------ For more information, please visit the new--- SYB wiki: <http://www.cs.uu.nl/wiki/bin/view/GenericProgramming/SYB>.------ (This module does not export anything. It really just defines instances.)-----------------------------------------------------------------------------------{-# OPTIONS_GHC -fno-warn-orphans #-}-module Data.Generics.Instances () where----------------------------------------------------------------------------------import Data.Data--#ifdef __GLASGOW_HASKELL__-#if __GLASGOW_HASKELL__ >= 611-import GHC.IO.Handle         -- So we can give Data instance for Handle-#else-import GHC.IOBase            -- So we can give Data instance for IO, Handle-#endif-import GHC.Stable            -- So we can give Data instance for StablePtr-import GHC.ST                -- So we can give Data instance for ST-import GHC.MVar              -- So we can give Data instance for MVar-import GHC.Conc              -- So we can give Data instance for TVar-import GHC.IORef-#else-# ifdef __HUGS__-import Hugs.Prelude( Ratio(..) )-# endif-import System.IO-import Foreign.Ptr-import Foreign.ForeignPtr-import Foreign.StablePtr-import Control.Monad.ST-import Control.Concurrent-import Data.IORef-#endif--#include "Typeable.h"---------------------------------------------------------------------------------------      Instances of the Data class for Prelude-like types.---      We define top-level definitions for representations.---------------------------------------------------------------------------------------------------------------------------------------------------------------------- Instances of abstract datatypes (6)---------------------------------------------------------------------------------instance Data TypeRep where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "Data.Typeable.TypeRep"-----------------------------------------------------------------------------------instance Data TyCon where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "Data.Typeable.TyCon"-----------------------------------------------------------------------------------INSTANCE_TYPEABLE0(DataType,dataTypeTc,"DataType")--instance Data DataType where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "Data.Generics.Basics.DataType"-----------------------------------------------------------------------------------instance Data Handle where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "GHC.IOBase.Handle"-----------------------------------------------------------------------------------instance Typeable a => Data (StablePtr a) where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "GHC.Stable.StablePtr"-----------------------------------------------------------------------------------#ifdef __GLASGOW_HASKELL__-instance Data ThreadId where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "GHC.Conc.ThreadId"-#endif------------------------------------------------------------------------------------ Dubious instances (7)---------------------------------------------------------------------------------#ifdef __GLASGOW_HASKELL__-instance Typeable a => Data (TVar a) where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "GHC.Conc.TVar"-#endif-----------------------------------------------------------------------------------instance Typeable a => Data (MVar a) where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "GHC.Conc.MVar"-----------------------------------------------------------------------------------#ifdef __GLASGOW_HASKELL__-instance Typeable a => Data (STM a) where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "GHC.Conc.STM"-#endif-----------------------------------------------------------------------------------instance (Typeable s, Typeable a) => Data (ST s a) where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "GHC.ST.ST"-----------------------------------------------------------------------------------instance Typeable a => Data (IORef a) where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "GHC.IOBase.IORef"-----------------------------------------------------------------------------------instance Typeable a => Data (IO a) where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "GHC.IOBase.IO"--------------------------------------------------------------------------------------- A last resort for functions-----instance (Data a, Data b) => Data (a -> b) where-  toConstr _   = error "toConstr"-  gunfold _ _  = error "gunfold"-  dataTypeOf _ = mkNoRepType "Prelude.(->)"-  dataCast2 f  = gcast2 f-
− Data/Generics/Schemes.hs 
@@ -1,168 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Schemes--- Copyright   :  (c) The University of Glasgow, CWI 2001--2003--- License     :  BSD-style (see the LICENSE file)--- --- Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable (local universal quantification)------ \"Scrap your boilerplate\" --- Generic programming in Haskell --- See <http://www.cs.vu.nl/boilerplate/>. The present module provides--- frequently used generic traversal schemes.-----------------------------------------------------------------------------------module Data.Generics.Schemes (--        everywhere,-        everywhere',-        everywhereBut,-        everywhereM,-        somewhere,-        everything,-        listify,-        something,-        synthesize,-        gsize,-        glength,-        gdepth,-        gcount,-        gnodecount,-        gtypecount,-        gfindtype-- ) where----------------------------------------------------------------------------------#ifdef __HADDOCK__-import Prelude-#endif-import Data.Data-import Data.Generics.Aliases-import Control.Monad----- | Apply a transformation everywhere in bottom-up manner-everywhere :: (forall a. Data a => a -> a)-           -> (forall a. Data a => a -> a)---- Use gmapT to recurse into immediate subterms;--- recall: gmapT preserves the outermost constructor;--- post-process recursively transformed result via f--- -everywhere f = f . gmapT (everywhere f)----- | Apply a transformation everywhere in top-down manner-everywhere' :: (forall a. Data a => a -> a)-            -> (forall a. Data a => a -> a)---- Arguments of (.) are flipped compared to everywhere-everywhere' f = gmapT (everywhere' f) . f----- | Variation on everywhere with an extra stop condition-everywhereBut :: GenericQ Bool -> GenericT -> GenericT---- Guarded to let traversal cease if predicate q holds for x-everywhereBut q f x-    | q x       = x-    | otherwise = f (gmapT (everywhereBut q f) x)----- | Monadic variation on everywhere-everywhereM :: Monad m => GenericM m -> GenericM m---- Bottom-up order is also reflected in order of do-actions-everywhereM f x = do x' <- gmapM (everywhereM f) x-                     f x'----- | Apply a monadic transformation at least somewhere-somewhere :: MonadPlus m => GenericM m -> GenericM m---- We try "f" in top-down manner, but descent into "x" when we fail--- at the root of the term. The transformation fails if "f" fails--- everywhere, say succeeds nowhere.--- -somewhere f x = f x `mplus` gmapMp (somewhere f) x----- | Summarise all nodes in top-down, left-to-right order-everything :: (r -> r -> r) -> GenericQ r -> GenericQ r---- Apply f to x to summarise top-level node;--- use gmapQ to recurse into immediate subterms;--- use ordinary foldl to reduce list of intermediate results--- -everything k f x-  = foldl k (f x) (gmapQ (everything k f) x)----- | Get a list of all entities that meet a predicate-listify :: Typeable r => (r -> Bool) -> GenericQ [r]-listify p-  = everything (++) ([] `mkQ` (\x -> if p x then [x] else []))----- | Look up a subterm by means of a maybe-typed filter-something :: GenericQ (Maybe u) -> GenericQ (Maybe u)---- "something" can be defined in terms of "everything"--- when a suitable "choice" operator is used for reduction--- -something = everything orElse----- | Bottom-up synthesis of a data structure;---   1st argument z is the initial element for the synthesis;---   2nd argument o is for reduction of results from subterms;---   3rd argument f updates the synthesised data according to the given term----synthesize :: s  -> (t -> s -> s) -> GenericQ (s -> t) -> GenericQ t-synthesize z o f x = f x (foldr o z (gmapQ (synthesize z o f) x))----- | Compute size of an arbitrary data structure-gsize :: Data a => a -> Int-gsize t = 1 + sum (gmapQ gsize t)----- | Count the number of immediate subterms of the given term-glength :: GenericQ Int-glength = length . gmapQ (const ())----- | Determine depth of the given term-gdepth :: GenericQ Int-gdepth = (+) 1 . foldr max 0 . gmapQ gdepth----- | Determine the number of all suitable nodes in a given term-gcount :: GenericQ Bool -> GenericQ Int-gcount p =  everything (+) (\x -> if p x then 1 else 0)----- | Determine the number of all nodes in a given term-gnodecount :: GenericQ Int-gnodecount = gcount (const True)----- | Determine the number of nodes of a given type in a given term-gtypecount :: Typeable a => a -> GenericQ Int-gtypecount (_::a) = gcount (False `mkQ` (\(_::a) -> True))----- | Find (unambiguously) an immediate subterm of a given type-gfindtype :: (Data x, Typeable y) => x -> Maybe y-gfindtype = singleton-          . foldl unJust []-          . gmapQ (Nothing `mkQ` Just)- where-  unJust l (Just x) = x:l-  unJust l Nothing  = l-  singleton [s] = Just s-  singleton _   = Nothing
− Data/Generics/Text.hs 
@@ -1,123 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Text--- Copyright   :  (c) The University of Glasgow, CWI 2001--2003--- License     :  BSD-style (see the LICENSE file)--- --- Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable (uses Data.Generics.Basics)------ \"Scrap your boilerplate\" --- Generic programming in Haskell --- See <http://www.cs.vu.nl/boilerplate/>. The present module provides--- generic operations for text serialisation of terms.-----------------------------------------------------------------------------------module Data.Generics.Text (--        gshow,-        gread-- ) where----------------------------------------------------------------------------------#ifdef __HADDOCK__-import Prelude-#endif-import Control.Monad-import Data.Data-import Data.Generics.Aliases-import Text.ParserCombinators.ReadP------------------------------------------------------------------------------------- | Generic show: an alternative to \"deriving Show\"-gshow :: Data a => a -> String---- This is a prefix-show using surrounding "(" and ")",--- where we recurse into subterms with gmapQ.--- -gshow = ( \t ->-                "("-             ++ showConstr (toConstr t)-             ++ concat (gmapQ ((++) " " . gshow) t)-             ++ ")"-        ) `extQ` (show :: String -> String)------ | Generic read: an alternative to \"deriving Read\"-gread :: Data a => ReadS a--{---This is a read operation which insists on prefix notation.  (The-Haskell 98 read deals with infix operators subject to associativity-and precedence as well.) We use fromConstrM to "parse" the input. To be-precise, fromConstrM is used for all types except String. The-type-specific case for String uses basic String read.---}--gread = readP_to_S gread'-- where--  -- Helper for recursive read-  gread' :: Data a' => ReadP a'-  gread' = allButString `extR` stringCase--   where--    -- A specific case for strings-    stringCase :: ReadP String-    stringCase = readS_to_P reads--    -- Determine result type-    myDataType = dataTypeOf (getArg allButString)-     where-      getArg :: ReadP a'' -> a''-      getArg = undefined--    -- The generic default for gread-    allButString =-      do-                -- Drop "  (  "-         skipSpaces                     -- Discard leading space-         _ <- char '('                  -- Parse '('-         skipSpaces                     -- Discard following space--                -- Do the real work-         str  <- parseConstr            -- Get a lexeme for the constructor-         con  <- str2con str            -- Convert it to a Constr (may fail)-         x    <- fromConstrM gread' con -- Read the children--                -- Drop "  )  "-         skipSpaces                     -- Discard leading space-         _ <- char ')'                  -- Parse ')'-         skipSpaces                     -- Discard following space--         return x--    -- Turn string into constructor driven by the requested result type,-    -- failing in the monad if it isn't a constructor of this data type-    str2con :: String -> ReadP Constr-    str2con = maybe mzero return-            . readConstr myDataType--    -- Get a Constr's string at the front of an input string-    parseConstr :: ReadP String-    parseConstr =-               string "[]"     -- Compound lexeme "[]"-          <++  infixOp         -- Infix operator in parantheses-          <++  readS_to_P lex  -- Ordinary constructors and literals--    -- Handle infix operators such as (:)-    infixOp :: ReadP String-    infixOp = do c1  <- char '('-                 str <- munch1 (not . (==) ')')-                 c2  <- char ')'-                 return $ [c1] ++ str ++ [c2]
− Data/Generics/Twins.hs 
@@ -1,250 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Twins--- Copyright   :  (c) The University of Glasgow, CWI 2001--2004--- License     :  BSD-style (see the LICENSE file)--- --- Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable (local universal quantification)------ \"Scrap your boilerplate\" --- Generic programming in Haskell --- See <http://www.cs.vu.nl/boilerplate/>. The present module --- provides support for multi-parameter traversal, which is also --- demonstrated with generic operations like equality.-----------------------------------------------------------------------------------module Data.Generics.Twins (--        -- * Generic folds and maps that also accumulate-        gfoldlAccum,-        gmapAccumT,-        gmapAccumM,-        gmapAccumQl,-        gmapAccumQr,-        gmapAccumQ,--        -- * Mapping combinators for twin traversal-        gzipWithT,-        gzipWithM,-        gzipWithQ,--        -- * Typical twin traversals-        geq,-        gzip--  ) where-----------------------------------------------------------------------------------#ifdef __HADDOCK__-import Prelude-#endif-import Data.Data-import Data.Generics.Aliases--#ifdef __GLASGOW_HASKELL__-import Prelude hiding ( GT )-#endif-----------------------------------------------------------------------------------------------------------------------------------------------------------------------      Generic folds and maps that also accumulate------------------------------------------------------------------------------------{----------------------------------------------------------------A list map can be elaborated to perform accumulation.-In the same sense, we can elaborate generic maps over terms.--We recall the type of map:-map :: (a -> b) -> [a] -> [b]--We recall the type of an accumulating map (see Data.List):-mapAccumL :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])--Applying the same scheme we obtain an accumulating gfoldl.----------------------------------------------------------------}---- | gfoldl with accumulation--gfoldlAccum :: Data d-            => (forall e r. Data e => a -> c (e -> r) -> e -> (a, c r))-            -> (forall g. a -> g -> (a, c g))-            -> a -> d -> (a, c d)--gfoldlAccum k z a0 d = unA (gfoldl k' z' d) a0- where-  k' c y = A (\a -> let (a', c') = unA c a in k a' c' y)-  z' f   = A (\a -> z a f)----- | A type constructor for accumulation-newtype A a c d = A { unA :: a -> (a, c d) }----- | gmapT with accumulation-gmapAccumT :: Data d-           => (forall e. Data e => a -> e -> (a,e))-           -> a -> d -> (a, d)-gmapAccumT f a0 d0 = let (a1, d1) = gfoldlAccum k z a0 d0-                     in (a1, unID d1)- where-  k a (ID c) d = let (a',d') = f a d-                  in (a', ID (c d'))-  z a x = (a, ID x)----- | gmapM with accumulation-gmapAccumM :: (Data d, Monad m)-           => (forall e. Data e => a -> e -> (a, m e))-           -> a -> d -> (a, m d)-gmapAccumM f = gfoldlAccum k z- where-  k a c d = let (a',d') = f a d-             in (a', d' >>= \d'' -> c >>= \c' -> return (c' d''))-  z a x = (a, return x)----- | gmapQl with accumulation-gmapAccumQl :: Data d-            => (r -> r' -> r)-            -> r-            -> (forall e. Data e => a -> e -> (a,r'))-            -> a -> d -> (a, r)-gmapAccumQl o r0 f a0 d0 = let (a1, r1) = gfoldlAccum k z a0 d0-                           in (a1, unCONST r1)- where-  k a (CONST c) d = let (a', r) = f a d-                     in (a', CONST (c `o` r))-  z a _ = (a, CONST r0)----- | gmapQr with accumulation-gmapAccumQr :: Data d-            => (r' -> r -> r)-            -> r-            -> (forall e. Data e => a -> e -> (a,r'))-            -> a -> d -> (a, r)-gmapAccumQr o r0 f a0 d0 = let (a1, l) = gfoldlAccum k z a0 d0-                           in (a1, unQr l r0)- where-  k a (Qr c) d = let (a',r') = f a d-                  in (a', Qr (\r -> c (r' `o` r)))-  z a _ = (a, Qr id)----- | gmapQ with accumulation-gmapAccumQ :: Data d-           => (forall e. Data e => a -> e -> (a,q))-           -> a -> d -> (a, [q])-gmapAccumQ f = gmapAccumQr (:) [] f----------------------------------------------------------------------------------------      Helper type constructors--------------------------------------------------------------------------------------- | The identity type constructor needed for the definition of gmapAccumT-newtype ID x = ID { unID :: x }----- | The constant type constructor needed for the definition of gmapAccumQl-newtype CONST c a = CONST { unCONST :: c }----- | The type constructor needed for the definition of gmapAccumQr-newtype Qr r a = Qr { unQr  :: r -> r }----------------------------------------------------------------------------------------      Mapping combinators for twin traversal--------------------------------------------------------------------------------------- | Twin map for transformation -gzipWithT :: GenericQ (GenericT) -> GenericQ (GenericT)-gzipWithT f x y = case gmapAccumT perkid funs y of-                    ([], c) -> c-                    _       -> error "gzipWithT"- where-  perkid a d = (tail a, unGT (head a) d)-  funs = gmapQ (\k -> GT (f k)) x------ | Twin map for monadic transformation -gzipWithM :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m)-gzipWithM f x y = case gmapAccumM perkid funs y of-                    ([], c) -> c-                    _       -> error "gzipWithM"- where-  perkid a d = (tail a, unGM (head a) d)-  funs = gmapQ (\k -> GM (f k)) x----- | Twin map for queries-gzipWithQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r])-gzipWithQ f x y = case gmapAccumQ perkid funs y of-                   ([], r) -> r-                   _       -> error "gzipWithQ"- where-  perkid a d = (tail a, unGQ (head a) d)-  funs = gmapQ (\k -> GQ (f k)) x----------------------------------------------------------------------------------------      Typical twin traversals-------------------------------------------------------------------------------------- | Generic equality: an alternative to \"deriving Eq\"-geq :: Data a => a -> a -> Bool--{---Testing for equality of two terms goes like this. Firstly, we-establish the equality of the two top-level datatype-constructors. Secondly, we use a twin gmap combinator, namely tgmapQ,-to compare the two lists of immediate subterms.--(Note for the experts: the type of the worker geq' is rather general-but precision is recovered via the restrictive type of the top-level-operation geq. The imprecision of geq' is caused by the type system's-unability to express the type equivalence for the corresponding-couples of immediate subterms from the two given input terms.)---}--geq x0 y0 = geq' x0 y0-  where-    geq' :: GenericQ (GenericQ Bool)-    geq' x y =     (toConstr x == toConstr y)-                && and (gzipWithQ geq' x y)----- | Generic zip controlled by a function with type-specific branches-gzip :: GenericQ (GenericM Maybe) -> GenericQ (GenericM Maybe)--- See testsuite/.../Generics/gzip.hs for an illustration-gzip f x y =-  f x y-  `orElse`-  if toConstr x == toConstr y-    then gzipWithM (gzip f) x y-    else Nothing
+ README.md view
@@ -0,0 +1,42 @@+syb: Scrap Your Boilerplate!+================================================================================++Scrap Your Boilerplate (SYB) is a library for generic programming in Haskell. It+is supported since the GHC >= 6.0 implementation of Haskell. Using this+approach, you can write generic functions such as traversal schemes (e.g.,+everywhere and everything), as well as generic read, generic show and generic+equality (i.e., gread, gshow, and geq). This approach is based on just a few+primitives for type-safe cast and processing constructor applications.++It was originally developed by Ralf Lämmel and Simon Peyton Jones. Since then,+many people have contributed with research relating to SYB or its applications.++More information is available on the webpage:+http://www.cs.uu.nl/wiki/GenericProgramming/SYB+++Features+--------++* Easy generic programming with combinators+* GHC can derive Data and Typeable instances for your datatypes+* Comes with many useful generic functions+++Requirements+------------++* GHC 8.0 or later+* Cabal 3.0 or later++Bugs & Support+--------------++Please report issues or request features at the bug tracker:++  https://github.com/dreixel/syb/issues++For discussion about the library with the authors, maintainers, and other+interested persons use the mailing list:++  http://www.haskell.org/mailman/listinfo/generics
− Setup.hs 
@@ -1,6 +0,0 @@-module Main (main) where--import Distribution.Simple--main :: IO ()-main = defaultMain
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ src/Data/Generics.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (uses Data.Generics.Basics)+--+-- \"Scrap your boilerplate\" --- Generic programming in Haskell +-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. To scrap your+-- boilerplate it is sufficient to import the present module, which simply+-- re-exports all themes of the Data.Generics library.+--+-----------------------------------------------------------------------------++module Data.Generics (++  -- * All Data.Generics modules+  module Data.Data,               -- primitives and instances of the Data class+  module Data.Generics.Aliases,   -- aliases for type case, generic types+  module Data.Generics.Schemes,   -- traversal schemes (everywhere etc.)+  module Data.Generics.Text,      -- generic read and show+  module Data.Generics.Twins,     -- twin traversal, e.g., generic eq+  module Data.Generics.Builders,  -- term builders++ ) where++------------------------------------------------------------------------------++import Data.Data+import Data.Generics.Instances ()+import Data.Generics.Aliases+import Data.Generics.Schemes+import Data.Generics.Text+import Data.Generics.Twins+import Data.Generics.Builders
+ src/Data/Generics/Aliases.hs view
@@ -0,0 +1,750 @@+{-# LANGUAGE RankNTypes, CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Aliases+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004+-- License     :  BSD-style (see the LICENSE file)+--+-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (local universal quantification)+--+-- This module provides a number of declarations for typical generic+-- function types, corresponding type case, and others.+--+-----------------------------------------------------------------------------++module Data.Generics.Aliases (++        -- * Combinators which create generic functions via cast+        --+        -- $castcombinators++        -- ** Transformations+        mkT,+        extT,+        -- ** Queries+        mkQ,+        extQ,+        -- ** Monadic transformations+        mkM,+        extM,+        -- ** MonadPlus transformations+        mkMp,+        extMp,+        -- ** Readers+        mkR,+        extR,+        -- ** Builders+        extB,+        -- ** Other+        ext0,+        -- * Types for generic functions+        -- ** Transformations+        GenericT,+        GenericT'(..),+        -- ** Queries+        GenericQ,+        GenericQ'(..),+        -- ** Monadic transformations+        GenericM,+        GenericM'(..),+        -- ** Readers+        GenericR,+        GenericR'(..),+        -- ** Builders+        GenericB,+        GenericB'(..),+        -- ** Other+        Generic,+        Generic'(..),++        -- * Ingredients of generic functions+        orElse,++        -- * Function combinators on generic functions+        recoverMp,+        recoverQ,+        choiceMp,+        choiceQ,++        -- * Type extension for unary type constructors+        ext1,+        ext1T,+        ext1M,+        ext1Q,+        ext1R,+        ext1B,++        -- * Type extension for binary type constructors+        ext2,+        ext2T,+        ext2M,+        ext2Q,+        ext2R,+        ext2B++  ) where++#ifdef __HADDOCK__+import Prelude+#endif+import Control.Monad+import Data.Data++------------------------------------------------------------------------------+--+--      Combinators to "make" generic functions+--      We use type-safe cast in a number of ways to make generic functions.+--+------------------------------------------------------------------------------++-- $castcombinators+--+-- Other programming languages sometimes provide an operator @instanceof@ which+-- can check whether an expression is an instance of a given type. This operator+-- allows programmers to implement a function @f :: forall a. a -> a@ which exhibits+-- a different behaviour depending on whether a `Bool` or a `Char` is passed.+-- In Haskell this is not the case: A function with type @forall a. a -> a@+-- can only be the identity function or a function which loops indefinitely+-- or throws an exception. That is, it must implement exactly the same behaviour+-- for any type at which it is used. But sometimes it is very useful to have+-- a function which can accept (almost) any type and exhibit a different behaviour+-- for different types. Haskell provides this functionality with the 'Typeable'+-- typeclass, whose instances can be automatically derived by GHC for almost all+-- types. This typeclass allows the definition of a functon 'cast' which has type+-- @forall a b. (Typeable a, Typeable b) => a -> Maybe b@. The 'cast' function allows+-- to implement a polymorphic function with different behaviour at different types:+--+-- >>> cast True :: Maybe Bool+-- Just True+--+-- >>> cast True :: Maybe Int+-- Nothing+--+-- This section provides combinators which make use of 'cast' internally to+-- provide various polymorphic functions with type-specific behaviour.+++-- | Extend the identity function with a type-specific transformation.+-- The function created by @mkT ext@ behaves like the identity function on all+-- arguments which cannot be cast to type @b@, and like the function @ext@ otherwise.+-- The name 'mkT' is short for "make transformation".+--+-- === __Examples__+--+-- >>> mkT not True+-- False+--+-- >>> mkT not 'a'+-- 'a'+--+-- @since 0.1.0.0+mkT :: ( Typeable a+       , Typeable b+       )+    => (b -> b)+    -- ^ The type-specific transformation+    -> a+    -- ^ The argument we try to cast to type @b@+    -> a+mkT = extT id+++-- | The function created by @mkQ def f@ returns the default result+-- @def@ if its argument cannot be cast to type @b@, otherwise it returns+-- the result of applying @f@ to its argument.+-- The name 'mkQ' is short for "make query".+--+-- === __Examples__+--+-- >>> mkQ "default" (show :: Bool -> String) True+-- "True"+--+-- >>> mkQ "default" (show :: Bool -> String) ()+-- "default"+--+-- @since 0.1.0.0+mkQ :: ( Typeable a+       , Typeable b+       )+    => r+    -- ^ The default result+    -> (b -> r)+    -- ^ The transformation to apply if the cast is successful+    -> a+    -- ^ The argument we try to cast to type @b@+    -> r+(r `mkQ` br) a = case cast a of+                        Just b  -> br b+                        Nothing -> r+++-- | Extend the default monadic action @pure :: Monad m => a -> m a@ by a type-specific+-- monadic action. The function created by @mkM act@ behaves like 'pure' if its+-- argument cannot be cast to type @b@, and like the monadic action @act@ otherwise.+-- The name 'mkM' is short for "make monadic transformation".+--+-- === __Examples__+--+-- >>> mkM (\x -> [x, not x]) True+-- [True,False]+--+-- >>> mkM (\x -> [x, not x]) (5 :: Int)+-- [5]+--+-- @since 0.1.0.0+mkM :: ( Monad m+       , Typeable a+       , Typeable b+       )+    => (b -> m b)+    -- ^ The type-specific monadic transformation+    -> a+    -- ^ The argument we try to cast to type @b@+    -> m a+mkM = extM return++-- | Extend the default 'MonadPlus' action @const mzero@ by a type-specific 'MonadPlus'+-- action. The function created by @mkMp act@ behaves like @const mzero@ if its argument+-- cannot be cast to type @b@, and like the monadic action @act@ otherwise.+-- The name 'mkMp' is short for "make MonadPlus transformation".+--+-- === __Examples__+--+-- >>> mkMp (\x -> Just (not x)) True+-- Just False+--+-- >>> mkMp (\x -> Just (not x)) 'a'+-- Nothing+--+-- @since 0.1.0.0+mkMp :: ( MonadPlus m+        , Typeable a+        , Typeable b+        )+     => (b -> m b)+     -- ^ The type-specific MonadPlus action+     -> a+     -- ^ The argument we try to cast to type @b@+     -> m a+mkMp = extM (const mzero)+++-- | Make a generic reader from a type-specific case.+-- The function created by @mkR f@ behaves like the reader @f@ if an expression+-- of type @a@ can be cast to type @b@, and like the expression @mzero@ otherwise.+-- The name 'mkR' is short for "make reader".+--+-- === __Examples__+--+-- >>> mkR (Just True) :: Maybe Bool+-- Just True+--+-- >>> mkR (Just True) :: Maybe Int+-- Nothing+--+-- @since 0.1.0.0+mkR :: ( MonadPlus m+       , Typeable a+       , Typeable b+       )+    => m b+    -- ^ The type-specific reader+    -> m a+mkR f = mzero `extR` f+++-- | Flexible type extension+--+-- === __Examples__+--+-- >>> ext0 [1 :: Int, 2, 3] [True, False] :: [Int]+-- [1,2,3]+--+-- >>> ext0 [1 :: Int, 2, 3] [4 :: Int, 5, 6] :: [Int]+-- [4,5,6]+--+-- @since 0.1.0.0+ext0 :: (Typeable a, Typeable b) => c a -> c b -> c a+ext0 def ext = maybe def id (gcast ext)+++-- | Extend a generic transformation by a type-specific transformation.+-- The function created by @extT def ext@ behaves like the generic transformation+-- @def@ if its argument cannot be cast to the type @b@, and like the type-specific+-- transformation @ext@ otherwise.+-- The name 'extT' is short for "extend transformation".+--+-- === __Examples__+--+-- >>> extT id not True+-- False+--+-- >>> extT id not 'a'+-- 'a'+--+-- @since 0.1.0.0+extT :: ( Typeable a+        , Typeable b+        )+     => (a -> a)+     -- ^ The transformation we want to extend+     -> (b -> b)+     -- ^ The type-specific transformation+     -> a+     -- ^ The argument we try to cast to type @b@+     -> a+extT def ext = unT ((T def) `ext0` (T ext))+++-- | Extend a generic query by a type-specific query. The function created by @extQ def ext@ behaves+-- like the generic query @def@ if its argument cannot be cast to the type @b@, and like the type-specific+-- query @ext@ otherwise.+-- The name 'extQ' is short for "extend query".+--+-- === __Examples__+--+-- >>> extQ (const True) not True+-- False+--+-- >>> extQ (const True) not 'a'+-- True+--+-- @since 0.1.0.0+extQ :: ( Typeable a+        , Typeable b+        )+     => (a -> r)+     -- ^ The query we want to extend+     -> (b -> r)+     -- ^ The type-specific query+     -> a+     -- ^ The argument we try to cast to type @b@+     -> r+extQ f g a = maybe (f a) g (cast a)+++-- | Extend a generic monadic transformation by a type-specific case.+-- The function created by @extM def ext@ behaves like the monadic transformation+-- @def@ if its argument cannot be cast to type @b@, and like the monadic transformation+-- @ext@ otherwise.+-- The name 'extM' is short for "extend monadic transformation".+--+-- === __Examples__+--+-- >>> extM (\x -> [x,x])(\x -> [not x, x]) True+-- [False,True]+--+-- >>> extM (\x -> [x,x])(\x -> [not x, x]) (5 :: Int)+-- [5,5]+--+-- @since 0.1.0.0+extM :: ( Monad m+        , Typeable a+        , Typeable b+        )+     => (a -> m a)+     -- ^ The monadic transformation we want to extend+     -> (b -> m b)+     -- ^ The type-specific monadic transformation+     -> a+     -- ^ The argument we try to cast to type @b@+     -> m a+extM def ext = unM ((M def) `ext0` (M ext))+++-- | Extend a generic MonadPlus transformation by a type-specific case.+-- The function created by @extMp def ext@ behaves like 'MonadPlus' transformation @def@+-- if its argument cannot be cast to type @b@, and like the transformation @ext@ otherwise.+-- Note that 'extMp' behaves exactly like 'extM'.+-- The name 'extMp' is short for "extend MonadPlus transformation".+--+-- === __Examples__+--+-- >>> extMp (\x -> [x,x])(\x -> [not x, x]) True+-- [False,True]+--+-- >>> extMp (\x -> [x,x])(\x -> [not x, x]) (5 :: Int)+-- [5,5]+--+-- @since 0.1.0.0+extMp :: ( MonadPlus m+         , Typeable a+         , Typeable b+         )+      => (a -> m a)+      -- ^ The 'MonadPlus' transformation we want to extend+      -> (b -> m b)+      -- ^ The type-specific 'MonadPlus' transformation+      -> a+      -- ^ The argument we try to cast to type @b@+      -> m a+extMp = extM+++-- | Extend a generic builder by a type-specific case.+-- The builder created by @extB def ext@ returns @def@ if @ext@ cannot be cast+-- to type @a@, and like @ext@ otherwise.+-- The name 'extB' is short for "extend builder".+--+-- === __Examples__+--+-- >>> extB True 'a'+-- True+--+-- >>> extB True False+-- False+--+-- @since 0.1.0.0+extB :: ( Typeable a+        , Typeable b+        )+     => a+     -- ^ The default result+     -> b+     -- ^ The argument we try to cast to type @a@+     -> a+extB a = maybe a id . cast+++-- | Extend a generic reader by a type-specific case.+-- The reader created by @extR def ext@ behaves like the reader @def@+-- if expressions of type @b@ cannot be cast to type @a@, and like the+-- reader @ext@ otherwise.+-- The name 'extR' is short for "extend reader".+--+-- === __Examples__+--+-- >>> extR (Just True) (Just 'a')+-- Just True+--+-- >>> extR (Just True) (Just False)+-- Just False+--+-- @since 0.1.0.0+extR :: ( Monad m+        , Typeable a+        , Typeable b+        )+     => m a+     -- ^ The generic reader we want to extend+     -> m b+     -- ^ The type-specific reader+     -> m a+extR def ext = unR ((R def) `ext0` (R ext))++++------------------------------------------------------------------------------+--+--      Types for generic functions+--+------------------------------------------------------------------------------+++-- | Generic transformations,+--   i.e., take an \"a\" and return an \"a\"+--+-- @since 0.1.0.0+type GenericT = forall a. Data a => a -> a++-- | The type synonym `GenericT` has a polymorphic type, and can therefore not+--   appear in places where monomorphic types are expected, for example in a list.+--   The newtype `GenericT'` wraps `GenericT` in a newtype to lift this restriction.+--+-- @since 0.1.0.0+newtype GenericT' = GT { unGT :: GenericT }++-- | Generic queries of type \"r\",+--   i.e., take any \"a\" and return an \"r\"+--+-- @since 0.1.0.0+type GenericQ r = forall a. Data a => a -> r++-- | The type synonym `GenericQ` has a polymorphic type, and can therefore not+--   appear in places where monomorphic types are expected, for example in a list.+--   The newtype `GenericQ'` wraps `GenericQ` in a newtype to lift this restriction.+--+-- @since 0.1.0.0+newtype GenericQ' r = GQ { unGQ :: GenericQ r }++-- | Generic monadic transformations,+--   i.e., take an \"a\" and compute an \"a\"+--+-- @since 0.1.0.0+type GenericM m = forall a. Data a => a -> m a++-- | The type synonym `GenericM` has a polymorphic type, and can therefore not+--   appear in places where monomorphic types are expected, for example in a list.+--   The newtype `GenericM'` wraps `GenericM` in a newtype to lift this restriction.+--+-- @since 0.1.0.0+newtype GenericM' m = GM { unGM :: GenericM m }++-- | Generic builders+--   i.e., produce an \"a\".+--+-- @since 0.1.0.0+type GenericB = forall a. Data a => a++-- | The type synonym `GenericB` has a polymorphic type, and can therefore not+--   appear in places where monomorphic types are expected, for example in a list.+--   The data type `GenericB'` wraps `GenericB` in a data type to lift this restriction.+--+-- @since 0.7.3+newtype GenericB' = GenericB' { unGenericB' :: GenericB }++-- | Generic readers, say monadic builders,+--   i.e., produce an \"a\" with the help of a monad \"m\".+--+-- @since 0.1.0.0+type GenericR m = forall a. Data a => m a++-- | The type synonym `GenericR` has a polymorphic type, and can therefore not+--   appear in places where monomorphic types are expected, for example in a list.+--   The data type `GenericR'` wraps `GenericR` in a data type to lift this restriction.+--+-- @since 0.7.3+newtype GenericR' m = GenericR' { unGenericR' :: GenericR m }++-- | The general scheme underlying generic functions+--   assumed by gfoldl; there are isomorphisms such as+--   GenericT = Generic T.+--+-- @since 0.1.0.0+type Generic c = forall a. Data a => a -> c a+++-- | The type synonym `Generic` has a polymorphic type, and can therefore not+--   appear in places where monomorphic types are expected, for example in a list.+--   The data type `Generic'` wraps `Generic` in a data type to lift this restriction.+--+-- @since 0.1.0.0+newtype Generic' c = Generic' { unGeneric' :: Generic c }++------------------------------------------------------------------------------+--+-- Ingredients of generic functions+--+------------------------------------------------------------------------------++-- | Left-biased choice on maybes+--+-- === __Examples__+--+-- >>> orElse Nothing Nothing+-- Nothing+--+-- >>> orElse Nothing (Just 'a')+-- Just 'a'+--+-- >>> orElse (Just 'a') Nothing+-- Just 'a'+--+-- >>> orElse (Just 'a') (Just 'b')+-- Just 'a'+--+-- @since 0.1.0.0+orElse :: Maybe a -> Maybe a -> Maybe a+x `orElse` y = case x of+                 Just _  -> x+                 Nothing -> y+++------------------------------------------------------------------------------+--+-- Function combinators on generic functions+--+------------------------------------------------------------------------------+{-++The following variations take "orElse" to the function+level. Furthermore, we generalise from "Maybe" to any+"MonadPlus". This makes sense for monadic transformations and+queries. We say that the resulting combinators modell choice. We also+provide a prime example of choice, that is, recovery from failure. In+the case of transformations, we recover via return whereas for+queries a given constant is returned.++-}++-- | Choice for monadic transformations+--+-- @since 0.1.0.0+choiceMp :: MonadPlus m => GenericM m -> GenericM m -> GenericM m+choiceMp f g x = f x `mplus` g x+++-- | Choice for monadic queries+--+-- @since 0.1.0.0+choiceQ :: MonadPlus m => GenericQ (m r) -> GenericQ (m r) -> GenericQ (m r)+choiceQ f g x = f x `mplus` g x+++-- | Recover from the failure of monadic transformation by identity+--+-- @since 0.1.0.0+recoverMp :: MonadPlus m => GenericM m -> GenericM m+recoverMp f = f `choiceMp` return+++-- | Recover from the failure of monadic query by a constant+--+-- @since 0.1.0.0+recoverQ :: MonadPlus m => r -> GenericQ (m r) -> GenericQ (m r)+recoverQ r f = f `choiceQ` const (return r)++++------------------------------------------------------------------------------+--      Type extension for unary type constructors+------------------------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 707+#define Typeable1 Typeable+#define Typeable2 Typeable+#endif++-- | Flexible type extension+--+-- @since 0.3+ext1 :: (Data a, Typeable1 t)+     => c a+     -> (forall d. Data d => c (t d))+     -> c a+ext1 def ext = maybe def id (dataCast1 ext)+++-- | Type extension of transformations for unary type constructors+--+-- @since 0.1.0.0+ext1T :: (Data d, Typeable1 t)+      => (forall e. Data e => e -> e)+      -> (forall f. Data f => t f -> t f)+      -> d -> d+ext1T def ext = unT ((T def) `ext1` (T ext))+++-- | Type extension of monadic transformations for type constructors+--+-- @since 0.1.0.0+ext1M :: (Monad m, Data d, Typeable1 t)+      => (forall e. Data e => e -> m e)+      -> (forall f. Data f => t f -> m (t f))+      -> d -> m d+ext1M def ext = unM ((M def) `ext1` (M ext))+++-- | Type extension of queries for type constructors+--+-- @since 0.1.0.0+ext1Q :: (Data d, Typeable1 t)+      => (d -> q)+      -> (forall e. Data e => t e -> q)+      -> d -> q+ext1Q def ext = unQ ((Q def) `ext1` (Q ext))+++-- | Type extension of readers for type constructors+--+-- @since 0.1.0.0+ext1R :: (Monad m, Data d, Typeable1 t)+      => m d+      -> (forall e. Data e => m (t e))+      -> m d+ext1R def ext = unR ((R def) `ext1` (R ext))+++-- | Type extension of builders for type constructors+--+-- @since 0.2+ext1B :: (Data a, Typeable1 t)+      => a+      -> (forall b. Data b => (t b))+      -> a+ext1B def ext = unB ((B def) `ext1` (B ext))++------------------------------------------------------------------------------+--      Type extension for binary type constructors+------------------------------------------------------------------------------++-- | Flexible type extension+ext2 :: (Data a, Typeable2 t)+     => c a+     -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))+     -> c a+ext2 def ext = maybe def id (dataCast2 ext)+++-- | Type extension of transformations for unary type constructors+--+-- @since 0.3+ext2T :: (Data d, Typeable2 t)+      => (forall e. Data e => e -> e)+      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> t d1 d2)+      -> d -> d+ext2T def ext = unT ((T def) `ext2` (T ext))+++-- | Type extension of monadic transformations for type constructors+--+-- @since 0.3+ext2M :: (Monad m, Data d, Typeable2 t)+      => (forall e. Data e => e -> m e)+      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> m (t d1 d2))+      -> d -> m d+ext2M def ext = unM ((M def) `ext2` (M ext))+++-- | Type extension of queries for type constructors+--+-- @since 0.3+ext2Q :: (Data d, Typeable2 t)+      => (d -> q)+      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)+      -> d -> q+ext2Q def ext = unQ ((Q def) `ext2` (Q ext))+++-- | Type extension of readers for type constructors+--+-- @since 0.3+ext2R :: (Monad m, Data d, Typeable2 t)+      => m d+      -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2))+      -> m d+ext2R def ext = unR ((R def) `ext2` (R ext))+++-- | Type extension of builders for type constructors+--+-- @since 0.3+ext2B :: (Data a, Typeable2 t)+      => a+      -> (forall d1 d2. (Data d1, Data d2) => (t d1 d2))+      -> a+ext2B def ext = unB ((B def) `ext2` (B ext))++------------------------------------------------------------------------------+--+--      Type constructors for type-level lambdas+--+------------------------------------------------------------------------------+++-- | The type constructor for transformations+newtype T x = T { unT :: x -> x }++-- | The type constructor for transformations+newtype M m x = M { unM :: x -> m x }++-- | The type constructor for queries+newtype Q q x = Q { unQ :: x -> q }++-- | The type constructor for readers+newtype R m x = R { unR :: m x }++-- | The type constructor for builders+newtype B x = B {unB :: x}
+ src/Data/Generics/Basics.hs view
@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Basics+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (local universal quantification)+--+-- \"Scrap your boilerplate\" --- Generic programming in Haskell.+-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. This module provides+-- the 'Data' class with its primitives for generic programming,+-- which is now defined in @Data.Data@. Therefore this module simply+-- re-exports @Data.Data@.+--+-----------------------------------------------------------------------------++module Data.Generics.Basics (+        module Data.Data+  ) where++import Data.Data
+ src/Data/Generics/Builders.hs view
@@ -0,0 +1,69 @@+{-# 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]
+ src/Data/Generics/Instances.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Instances+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004+-- License     :  BSD-style (see the LICENSE file)+--+-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (uses Data.Data)+--+-- \"Scrap your boilerplate\" --- Generic programming in Haskell+-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module+-- contains thirteen 'Data' instances which are considered dubious (either+-- because the types are abstract or just not meant to be traversed).+-- Instances in this module might change or disappear in future releases+-- of this package.+--+-- (This module does not export anything. It really just defines instances.)+--+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.Generics.Instances () where++------------------------------------------------------------------------------++import Data.Data++#ifdef __GLASGOW_HASKELL__+#if __GLASGOW_HASKELL__ >= 611+import GHC.IO.Handle         -- So we can give Data instance for Handle+#else+import GHC.IOBase            -- So we can give Data instance for IO, Handle+#endif+import GHC.Stable            -- So we can give Data instance for StablePtr+import GHC.ST                -- So we can give Data instance for ST+import GHC.Conc              -- So we can give Data instance for TVar+import Data.IORef            -- So we can give Data instance for IORef+import Control.Concurrent    -- So we can give Data instance for MVar+#else+# ifdef __HUGS__+import Hugs.Prelude( Ratio(..) )+# endif+import System.IO+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.StablePtr+import Control.Monad.ST+#endif++-- 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+
+ src/Data/Generics/Schemes.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE RankNTypes, ScopedTypeVariables, CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Schemes+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2003+-- License     :  BSD-style (see the LICENSE file)+--+-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (local universal quantification)+--+-- \"Scrap your boilerplate\" --- Generic programming in Haskell+-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module+-- provides frequently used generic traversal schemes.+--+-----------------------------------------------------------------------------++module Data.Generics.Schemes (++        everywhere,+        everywhere',+        everywhereBut,+        everywhereM,+        somewhere,+        everything,+        everythingBut,+        everythingWithContext,+        listify,+        something,+        synthesize,+        gsize,+        glength,+        gdepth,+        gcount,+        gnodecount,+        gtypecount,+        gfindtype++ ) where++------------------------------------------------------------------------------++#ifdef __HADDOCK__+import Prelude+#endif+import Data.Data+import Data.Generics.Aliases+import Control.Monad++-- | Apply a transformation everywhere in bottom-up manner+--+-- @since 0.1.0.0+everywhere :: (forall a. Data a => a -> a)+           -> (forall a. Data a => a -> a)++-- Use gmapT to recurse into immediate subterms;+-- recall: gmapT preserves the outermost constructor;+-- post-process recursively transformed result via f+--+everywhere f = go+  where+    go :: forall a. Data a => a -> a+    go = f . gmapT go++-- | Apply a transformation everywhere in top-down manner+--+-- @since 0.1.0.0+everywhere' :: (forall a. Data a => a -> a)+            -> (forall a. Data a => a -> a)++-- Arguments of (.) are flipped compared to everywhere+everywhere' f = go+  where+    go :: forall a. Data a => a -> a+    go = gmapT go . f+++-- | Variation on everywhere with an extra stop condition+--+-- @since 0.1.0.0+everywhereBut :: GenericQ Bool -> GenericT -> GenericT++-- Guarded to let traversal cease if predicate q holds for x+everywhereBut q f = go+  where+    go :: GenericT+    go x+      | q x       = x+      | otherwise = f (gmapT go x)+++-- | Monadic variation on everywhere+--+-- @since 0.1.0.0+everywhereM :: forall m. Monad m => GenericM m -> GenericM m++-- Bottom-up order is also reflected in order of do-actions+everywhereM f = go+  where+    go :: GenericM m+    go x = do+      x' <- gmapM go x+      f x'+++-- | Apply a monadic transformation at least somewhere+--+-- @since 0.1.0.0+somewhere :: forall m. MonadPlus m => GenericM m -> GenericM m++-- We try "f" in top-down manner, but descent into "x" when we fail+-- at the root of the term. The transformation fails if "f" fails+-- everywhere, say succeeds nowhere.+--+somewhere f = go+  where+    go :: GenericM m+    go x = f x `mplus` gmapMp go x+++-- | Summarise all nodes in top-down, left-to-right order+--+-- @since 0.1.0.0+everything :: forall r. (r -> r -> r) -> GenericQ r -> GenericQ r++-- Apply f to x to summarise top-level node;+-- use gmapQ to recurse into immediate subterms;+-- use ordinary foldl to reduce list of intermediate results+--+everything k f = go+  where+    go :: GenericQ r+    go x = foldl k (f x) (gmapQ go x)++-- | Variation of "everything" with an added stop condition+--+-- @since 0.3+everythingBut :: forall r. (r -> r -> r) -> GenericQ (r, Bool) -> GenericQ r+everythingBut k f = go+  where+    go :: GenericQ r+    go x = let (v, stop) = f x+           in if stop+                then v+                else foldl k v (gmapQ go x)++-- | Summarise all nodes in top-down, left-to-right order, carrying some state+-- down the tree during the computation, but not left-to-right to siblings.+--+-- @since 0.3.7+everythingWithContext :: forall s r. s -> (r -> r -> r) -> GenericQ (s -> (r, s)) -> GenericQ r+everythingWithContext s0 f q = go s0+  where+    go :: s -> GenericQ r+    go s x = foldl f r (gmapQ (go s') x)+      where (r, s') = q x s++-- | Get a list of all entities that meet a predicate+--+-- @since 0.1.0.0+listify :: Typeable r => (r -> Bool) -> GenericQ [r]+listify p = everything (++) ([] `mkQ` (\x -> if p x then [x] else []))+++-- | Look up a subterm by means of a maybe-typed filter+--+-- @since 0.1.0.0+something :: GenericQ (Maybe u) -> GenericQ (Maybe u)++-- "something" can be defined in terms of "everything"+-- when a suitable "choice" operator is used for reduction+--+something = everything orElse+++-- | Bottom-up synthesis of a data structure;+--   1st argument z is the initial element for the synthesis;+--   2nd argument o is for reduction of results from subterms;+--   3rd argument f updates the synthesised data according to the given term+--+-- @since 0.1.0.0+synthesize :: forall s t. s  -> (t -> s -> s) -> GenericQ (s -> t) -> GenericQ t+synthesize z o f = go+  where+    go :: GenericQ t+    go x = f x (foldr o z (gmapQ go x))+++-- | Compute size of an arbitrary data structure+--+-- @since 0.1.0.0+gsize :: Data a => a -> Int+gsize t = 1 + sum (gmapQ gsize t)+++-- | Count the number of immediate subterms of the given term+--+-- @since 0.1.0.0+glength :: GenericQ Int+glength = length . gmapQ (const ())+++-- | Determine depth of the given term+--+-- @since 0.1.0.0+gdepth :: GenericQ Int+gdepth = (+) 1 . foldr max 0 . gmapQ gdepth+++-- | Determine the number of all suitable nodes in a given term+--+-- @since 0.1.0.0+gcount :: GenericQ Bool -> GenericQ Int+gcount p =  everything (+) (\x -> if p x then 1 else 0)+++-- | Determine the number of all nodes in a given term+--+-- @since 0.1.0.0+gnodecount :: GenericQ Int+gnodecount = gcount (const True)+++-- | Determine the number of nodes of a given type in a given term+--+-- @since 0.1.0.0+gtypecount :: Typeable a => a -> GenericQ Int+gtypecount (_::a) = gcount (False `mkQ` (\(_::a) -> True))+++-- | Find (unambiguously) an immediate subterm of a given type+--+-- @since 0.1.0.0+gfindtype :: (Data x, Typeable y) => x -> Maybe y+gfindtype = singleton+          . foldl unJust []+          . gmapQ (Nothing `mkQ` Just)+ where+  unJust l (Just x) = x:l+  unJust l Nothing  = l+  singleton [s] = Just s+  singleton _   = Nothing
+ src/Data/Generics/Text.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Text+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2003+-- License     :  BSD-style (see the LICENSE file)+--+-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (uses Data.Generics.Basics)+--+-- \"Scrap your boilerplate\" --- Generic programming in Haskell+-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module+-- provides generic operations for text serialisation of terms.+--+-----------------------------------------------------------------------------++module Data.Generics.Text (++    -- * Generic show+    gshow, gshows, gshowsF,++    -- * Generic read+    gread++ ) where++------------------------------------------------------------------------------++#ifdef __HADDOCK__+import Prelude+#endif+import Control.Monad+import Data.Data+import Data.Generics.Aliases+import Text.ParserCombinators.ReadP+import Text.Read.Lex++------------------------------------------------------------------------------+++-- | Generic 'show': an alternative to @deriving@ 'Show'.+--+-- @since 0.1.0.0+gshow :: Data a => a -> String+gshow x = gshows x ""++-- | Generic 'shows'.+--+-- @since 0.2+gshows :: Data a => a -> ShowS++-- This is a prefix-show using surrounding "(" and ")",+-- where we recurse into subterms with gmapQ.+gshows = gshowsF gshows++--  | Generic 'shows' but allowing the user to change cases.+gshowsF :: Data b => (forall a. Data a => a -> ShowS) -> b -> ShowS+gshowsF fun = ( \t ->+                showChar '('+              . (showString . showConstr . toConstr $ t)+              . (foldr (.) id . gmapQ ((showChar ' ' .) . fun) $ t)+              . showChar ')'+         ) `extQ` (shows :: String -> ShowS)++-- | Generic 'reads' (not 'read'): an alternative to @deriving@ 'Read'.+--+-- @since 0.1.0.0+gread :: Data a => ReadS a++{-++This is a read operation which insists on prefix notation.  (The+Haskell 98 read deals with infix operators subject to associativity+and precedence as well.) We use fromConstrM to "parse" the input. To be+precise, fromConstrM is used for all types except String. The+type-specific case for String uses basic String read.++-}++gread = readP_to_S gread'++ where++  -- Helper for recursive read+  gread' :: Data a' => ReadP a'+  gread' = allButString `extR` stringCase++   where++    -- A specific case for strings+    stringCase :: ReadP String+    stringCase = readS_to_P reads++    -- Determine result type+    myDataType = dataTypeOf (getArg allButString)+     where+      getArg :: ReadP a'' -> a''+      getArg = undefined++    -- The generic default for gread+    allButString =+      do+                -- Drop "  (  "+         skipSpaces                     -- Discard leading space+         _ <- char '('                  -- Parse '('+         skipSpaces                     -- Discard following space++                -- Do the real work+         str  <- parseConstr            -- Get a lexeme for the constructor+         con  <- str2con str            -- Convert it to a Constr (may fail)+         x    <- fromConstrM gread' con -- Read the children++                -- Drop "  )  "+         skipSpaces                     -- Discard leading space+         _ <- char ')'                  -- Parse ')'+         skipSpaces                     -- Discard following space++         return x++    -- Turn string into constructor driven by the requested result type,+    -- failing in the monad if it isn't a constructor of this data type+    str2con :: String -> ReadP Constr+    str2con = maybe mzero return+            . readConstr myDataType++    -- Get a Constr's string at the front of an input string+    parseConstr :: ReadP String+    parseConstr =+               string "[]"     -- Compound lexeme "[]"+          <++  string "()"     -- singleton "()"+          <++  infixOp         -- Infix operator in parantheses+          <++  negativeNumber  -- prefix "-" and number literal+          <++  hsLex           -- Ordinary constructors and literals++    -- Handle infix operators such as (:)+    infixOp :: ReadP String+    infixOp = do c1  <- char '('+                 str <- munch1 (not . (==) ')')+                 c2  <- char ')'+                 return $ [c1] ++ str ++ [c2]++    -- Handle negative number literals+    negativeNumber :: ReadP String+    negativeNumber = do c1 <- char '-'+                        str <- hsLex+                        return $ c1 : str
+ src/Data/Generics/Twins.hs view
@@ -0,0 +1,317 @@+{-# 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 <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module+-- provides support for multi-parameter traversal, which is also+-- demonstrated with generic operations like equality.+--+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-}++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 Control.Applicative (Const(..))+import Data.Data+import Data.Generics.Aliases+import Data.Functor.Identity (Identity(..))++#ifdef __GLASGOW_HASKELL__+import Prelude hiding ( GT )+#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, runIdentity d1)+ where+  k a (Identity c) d =+    let (a',d') = f a d+    in (a', Identity (c d'))+  z a x = (a, Identity x)+++-- | Applicative version+--+-- @since 0.2+gmapAccumA :: forall b d a. (Data d, Applicative a)+           => (forall e. Data e => b -> e -> (b, a e))+           -> b -> d -> (b, a d)+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, getConst r1)+ where+  k a (Const c) d =+    let (a', r) = f a d+    in (a', Const (c `o` r))+  z a _ = (a, Const r0)+++-- | 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 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 :: Data b => [GenericT'] -> b -> ([GenericT'], b)+  perkid a d = (tail a, unGT (head a) d)++  funs :: [GenericT']+  funs = gmapQ (\k -> GT (f k)) x++++-- | Twin map for monadic transformation+--+-- @since 0.1.0.0+gzipWithM :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m)+gzipWithM f x y = case gmapAccumM perkid funs y of+                    ([], c) -> c+                    _       -> 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 :: forall r. GenericQ (GenericQ r) -> GenericQ (GenericQ [r])+gzipWithQ f x y = case gmapAccumQ perkid funs y of+                   ([], r) -> r+                   _       -> error "gzipWithQ"+ where+  perkid :: Data c => [GenericQ' b] -> c -> ([GenericQ' b], b)+  perkid a d = (tail a, unGQ (head a) d)+  funs :: [GenericQ' r]+  funs = gmapQ (\k -> GQ (f k)) x++++------------------------------------------------------------------------------+--+--      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"
+ src/Generics/SYB.hs view
@@ -0,0 +1,17 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.SYB+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (local universal quantification)+--+-- Convenience alias for "Data.Generics".+--+-----------------------------------------------------------------------------++module Generics.SYB (module Data.Generics) where++import Data.Generics
+ src/Generics/SYB/Aliases.hs view
@@ -0,0 +1,17 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.SYB.Aliases+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (local universal quantification)+--+-- Convenience alias for "Data.Generics.Aliases".+--+-----------------------------------------------------------------------------++module Generics.SYB.Aliases (module Data.Generics.Aliases) where++import Data.Generics.Aliases
+ src/Generics/SYB/Basics.hs view
@@ -0,0 +1,17 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.SYB.Basics+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (local universal quantification)+--+-- Convenience alias for "Data.Generics.Basics".+--+-----------------------------------------------------------------------------++module Generics.SYB.Basics (module Data.Generics.Basics) where++import Data.Generics.Basics
+ src/Generics/SYB/Builders.hs view
@@ -0,0 +1,17 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.SYB.Builders+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (local universal quantification)+--+-- Convenience alias for "Data.Generics.Builders".+--+-----------------------------------------------------------------------------++module Generics.SYB.Builders (module Data.Generics.Builders) where++import Data.Generics.Builders
+ src/Generics/SYB/Instances.hs view
@@ -0,0 +1,17 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.SYB.Instances+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (local universal quantification)+--+-- Convenience alias for "Data.Generics.Instances".+--+-----------------------------------------------------------------------------++module Generics.SYB.Instances () where++import Data.Generics.Instances ()
+ src/Generics/SYB/Schemes.hs view
@@ -0,0 +1,17 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.SYB.Schemes+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (local universal quantification)+--+-- Convenience alias for "Data.Generics.Schemes".+--+-----------------------------------------------------------------------------++module Generics.SYB.Schemes (module Data.Generics.Schemes) where++import Data.Generics.Schemes
+ src/Generics/SYB/Text.hs view
@@ -0,0 +1,17 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.SYB.Text+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (local universal quantification)+--+-- Convenience alias for "Data.Generics.Text".+--+-----------------------------------------------------------------------------++module Generics.SYB.Text (module Data.Generics.Text) where++import Data.Generics.Text
+ src/Generics/SYB/Twins.hs view
@@ -0,0 +1,17 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.SYB.Twins+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (local universal quantification)+--+-- Convenience alias for "Data.Generics.Twins".+--+-----------------------------------------------------------------------------++module Generics.SYB.Twins (module Data.Generics.Twins) where++import Data.Generics.Twins
syb.cabal view
@@ -1,31 +1,115 @@-name:           syb-version:        0.1.0.2-license:        BSD3-license-file:   LICENSE-maintainer:     libraries@haskell.org-synopsis:       Scrap Your Boilerplate+name:                 syb+version:              0.7.4+license:              BSD3+license-file:         LICENSE+author:               Ralf Lammel, Simon Peyton Jones, Jose Pedro Magalhaes+maintainer:           Sergey Vinokurov <serg.foo@gmail.com>+homepage:             https://github.com/dreixel/syb+bug-reports:          https://github.com/dreixel/syb/issues+synopsis:             Scrap Your Boilerplate description:     This package contains the generics system described in the-    /Scrap Your Boilerplate/ papers (see <http://www.cs.vu.nl/boilerplate/>).+    /Scrap Your Boilerplate/ papers (see+    <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>).     It defines the @Data@ class of types permitting folding and unfolding     of constructor applications, instances of this class for primitive     types, and a variety of traversals.-cabal-version:  >=1.2.3-build-type: Simple -Library {-    build-depends: base >= 4.1 && < 4.3-    Extensions: CPP, Rank2Types, ScopedTypeVariables-    exposed-modules:-            Data.Generics-            Data.Generics.Aliases-            Data.Generics.Basics-            Data.Generics.Instances-            Data.Generics.Schemes-            Data.Generics.Text-            Data.Generics.Twins+category:               Generics+stability:              provisional+build-type:             Simple+cabal-version:          >= 1.10+tested-with:+  GHC == 9.14+  GHC == 9.12+  GHC == 9.10+  GHC == 9.8+  GHC == 9.6+  GHC == 9.4+  GHC == 9.2+  GHC == 9.0+  GHC == 8.10+  GHC == 8.8+  GHC == 8.6+  GHC == 8.4+  GHC == 8.2+  GHC == 8.0 -    if impl(ghc < 6.10) -       -- PatternSignatures was deprecated in 6.10-       extensions: PatternSignatures-}+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.9 && < 5+  exposed-modules:        Data.Generics+                          Data.Generics.Basics+                          Data.Generics.Instances+                          Data.Generics.Aliases+                          Data.Generics.Schemes+                          Data.Generics.Text+                          Data.Generics.Twins+                          Data.Generics.Builders++                          Generics.SYB+                          Generics.SYB.Basics+                          Generics.SYB.Instances+                          Generics.SYB.Aliases+                          Generics.SYB.Schemes+                          Generics.SYB.Text+                          Generics.SYB.Twins+                          Generics.SYB.Builders++  ghc-options:            -Wall -Wcompat++test-suite unit-tests+  type:                   exitcode-stdio-1.0+  hs-source-dirs:         tests+  default-language:       Haskell98+  main-is:                Main.hs+  build-depends:          base+                        , syb+                        , tasty+                        , tasty-hunit+                        , containers+                        , mtl+  other-modules:          Bits+                          Builders+                          CompanyDatatypes+                          Datatype+                          Encode+                          Ext+                          Ext1+                          Ext2+                          FoldTree+                          FreeNames+                          GEq+                          GMapQAssoc+                          GRead+                          GRead2+                          GShow+                          GShow2+                          GZip+                          GenUpTo+                          GetC+                          HList+                          HOPat+                          Labels+                          LocalQuantors+                          NestedDatatypes+                          Newtype+                          Paradise+                          Perm+                          Polymatch+                          Reify+                          Strings+                          Tree+                          Twin+                          Typecase1+                          Typecase2+                          Where+                          XML
+ tests/Bits.hs view
@@ -0,0 +1,225 @@+{-# 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)))))
+ tests/Builders.hs view
@@ -0,0 +1,17 @@+module Builders (tests) where++import Test.Tasty.HUnit++import Data.Generics.Builders+++-- Main function for testing+tests :: Assertion+tests = ( constrs :: [Maybe Int]+        , constrs :: [String]+        , constrs :: [Either Int Double]+        , constrs :: [((), Integer)]+        ) @=? output++output :: ([Maybe Int], [String], [Either Int Double], [((), Integer)])+output = ([Nothing,Just 0],["","\NUL"],[Left 0,Right 0.0],[((),0)])
+ tests/CompanyDatatypes.hs view
@@ -0,0 +1,39 @@+{-# 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) []
+ tests/Datatype.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- These are simple tests to observe (data)type representations.+module Datatype  where++import Test.Tasty.HUnit++import Data.Tree+import Data.Generics++-- A simple polymorphic datatype+data MyDataType a = MyDataType a+                  deriving (Typeable, Data)+++-- Some terms and corresponding type representations+myTerm     = undefined :: MyDataType Int+myTypeRep  = typeOf myTerm            -- type representation in Typeable+myDataType = dataTypeOf myTerm        -- datatype representation in Data++#if MIN_VERSION_base(4,5,0)+myTyCon    = typeRepTyCon myTypeRep   -- type constructor via Typeable+myString1  = tyConName myTyCon        -- type constructor via Typeable+myString2  = dataTypeName myDataType  -- type constructor via Data++-- Main function for testing+tests =  show ( myTypeRep+            , ( myDataType+            , ( tyconModule myString1+            , ( tyconUQname myString1+            , ( tyconModule myString2+            , ( tyconUQname myString2+            ))))))+       @?= output++# if __GLASGOW_HASKELL__ >= 904+-- In GHC 9.4 module name is included+output = "(MyDataType Int,(DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]},(\"\",(\"MyDataType\",(\"Datatype\",\"MyDataType\")))))"+# elif __GLASGOW_HASKELL__ >= 709+-- In GHC 7.10 module name is stripped from DataType+output = "(MyDataType Int,(DataType {tycon = \"MyDataType\", datarep = AlgRep [MyDataType]},(\"\",(\"MyDataType\",(\"\",\"MyDataType\")))))"+# else+output = "(MyDataType Int,(DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]},(\"\",(\"MyDataType\",(\"Datatype\",\"MyDataType\")))))"+# endif++#else++tests = show ( myTypeRep, myDataType )+        @?= output++# if __GLASGOW_HASKELL__ >= 701+output = "(MyDataType Int,DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]})"+# else+output = "(Datatype.MyDataType Int,DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]})"+# endif++#endif
+ tests/Encode.hs view
@@ -0,0 +1,88 @@+{-# 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) }
+ tests/Ext.hs view
@@ -0,0 +1,28 @@+module Ext () where++-- There were typos in these definitions in the ICFP 2004 paper.++import Data.Generics++extQ fn spec_fn arg+  = case gcast (Q spec_fn) of+      Just (Q spec_fn') -> spec_fn' arg+      Nothing           -> fn       arg++newtype Q r a = Q (a -> r)++extT fn spec_fn arg+  = case gcast (T spec_fn) of+      Just (T spec_fn') -> spec_fn' arg+      Nothing           -> fn       arg++newtype T a = T (a -> a)++extM :: (Typeable a, Typeable b)+     => (a -> m a) -> (b -> m b) -> (a -> m a)+extM fn spec_fn+  = case gcast (M spec_fn) of+      Just (M spec_fn') -> spec_fn'+      Nothing           -> fn++newtype M m a = M (a -> m a)
+ tests/Ext1.hs view
@@ -0,0 +1,121 @@+{-# 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#)+import GHC.Base hiding (foldr)++-- Unsafe coerce+unsafeCoerce :: a -> b+unsafeCoerce = unsafeCoerce#++-- 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 :: Int+t1 = foo1 True -- should count as 0++t2 :: Int+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 :: Int+t3 = foo2 (True,True) -- should count as 0++t4 :: Int+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 :: Int+t5 = foo3 (True,True) -- should count as 0++t6 :: Int+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"++-- Main function for testing+tests :: Assertion+tests = ( t1+        , ( t2+        , ( t3+        , ( t4+        , ( t5+        , ( t6+        )))))) @=? output++output :: (Int, (Int, (Int, (Int, (Int, Int)))))+output = (0,(2,(0,(4,(0,4)))))
+ tests/Ext2.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Ext2 (tests) where++-- Tests for ext2 and friends++import Test.Tasty.HUnit+import Data.Generics+++-- A type of lists+data List a = Nil | Cons a (List a) deriving (Data, Typeable, Show, Eq)++-- Example lists+l1, l2 :: List Int+l1 = Cons 1 (Cons 2 Nil)+l2 = Cons 0 l1++-- A type of pairs+data Pair a b = Pair1 a b | Pair2 a b deriving (Data, Typeable, Show, Eq)++-- Example pairs+p1, p2 :: Pair Int Char+p1 = Pair1 2 'p'+p2 = Pair2 3 'q'++-- Structures containing the above+s1 :: [Pair Int Char]+s1 = [p1, p2]++s2 :: (Pair Int Char, List Int)+s2 = (p2, l2)+++-- Auxiliary functions+unifyPair :: Pair a b -> Pair a b -> Bool+unifyPair (Pair1 _ _) (Pair1 _ _) = True+unifyPair (Pair2 _ _) (Pair2 _ _) = True+unifyPair _           _           = False++flipPair :: Pair a b -> Pair a b+flipPair (Pair1 a b) = Pair2 a b+flipPair (Pair2 a b) = Pair1 a b++-- Tests+t1 = everywhere (id `ext2T` flipPair) (s1,s2)+t2 = let f :: (Data a) => a -> Maybe a+         f = (const Nothing) `ext2M` (Just . flipPair)+     in (f p1, f l1)+t3 = everything (+) ( const 0+             `ext1Q` (const 1  :: List a   -> Int)+             `ext2Q` (const 10 :: Pair a b -> Int))+               $ s2+t4 = unifyPair (t4' :: Pair Int Char) t4' where+  t4' :: Data a => a+  t4' = undefined `ext1B` Nil `ext2B` (Pair1 undefined undefined)+++-- Main function for testing+tests = (t1, t2, t3, t4) @=? output++output = ((map flipPair s1, (flipPair p2, l2))+         ,(Just (flipPair p1),Nothing)+         ,14+         ,True)
+ tests/FoldTree.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-++A very, very simple example: "extract all Ints from a tree of Ints".+The text book approach is to write a generalised fold for that. One+can also turn the Tree datatype into functorial style and then write a+Functor instance for the functorial datatype including a definition of+fmap. (The original Tree datatype can be related to the functorial+version by the usual injection and projection.)++You can scrap all such boilerplate by using a traversal scheme based+on gmap combinators as illustrated below. To get it a little more+interesting, we use a datatype Tree with not just a case for leafs and+fork trees, but we also add a case for trees with a weight.++For completeness' sake, we mention that the fmap/generalised fold+approach differs from the gmap approach in some details. Most notably,+the gmap approach does not generally facilitate the identification of+term components that relate to the type parameter of a parameterised+datatype. The consequence of this is illustrated below as well.+Sec. 6.3 in "Scrap Your Boilerplate ..." discusses such `type+distinctions' as well.++-}++module FoldTree (tests) where++import Test.Tasty.HUnit++-- Enable "ScrapYourBoilerplate"+import Data.Generics+++-- A parameterised datatype for binary trees with data at the leafs+data Tree a w = Leaf a+              | Fork (Tree a w) (Tree a w)+              | WithWeight (Tree a w) w+       deriving (Typeable, Data)+++-- A typical tree+mytree :: Tree Int Int+mytree = Fork (WithWeight (Leaf 42) 1)+              (WithWeight (Fork (Leaf 88) (Leaf 37)) 2)++-- A less typical tree, used for testing everythingBut+mytree' :: Tree Int Int+mytree' = Fork (Leaf 42)+               (WithWeight (Fork (Leaf 88) (Leaf 37)) 2)+++-- Print everything like an Int in mytree+-- In fact, we show two attempts:+--   1. print really just everything like an Int+--   2. print everything wrapped with Leaf+-- So (1.) confuses leafs and weights whereas (2.) does not.+-- Additionally we test everythingBut, stopping when we see a WithWeight node+tests = show ( listify (\(_::Int) -> True)         mytree+             , everything (++) ([] `mkQ` fromLeaf) mytree+             , everythingBut (++)+                 (([],False) `mkQ` (\x -> (fromLeaf x, stop x))) mytree'+             ) @=? output+  where+    fromLeaf :: Tree Int Int -> [Int]+    fromLeaf (Leaf x) = [x]+    fromLeaf _        = []+    stop :: (Data a, Data b) => Tree a b -> Bool+    stop (WithWeight _ _) = True+    stop _                = False++output = "([42,1,88,37,2],[42,88,37],[42])"
+ tests/FreeNames.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE DeriveDataTypeable #-}++module FreeNames (tests) where++{-++This example illustrates the kind of traversals that naturally show up+in language processing. That is, the free names (say, variables) are+derived for a given program fragment. To this end, we need several+worker functions that extract declaring and referencing occurrences+from given program fragments; see "decsExpr", "decsEqua",+etc. below. Then, we need a traversal "freeNames" that traverses over+the program fragment in a bottom-up manner so that free names from+subterms do not escape to the top when corresponding declarations are+provided. The "freeNames" algorithm uses set operations "union" and+"//" to compute sets of free names from the declared and referenced+names of the root term and free names of the immediate subterms.++Contributed by Ralf Laemmel, ralf@cwi.nl++-}++import Test.Tasty.HUnit++import Data.Generics+import Data.List++data System     = S [Function]                     deriving (Typeable, Data)++data Function   = F Name [Equation]                deriving (Typeable, Data)++data Equation   = E [Pattern] Expression System    deriving (Typeable, Data)++data Pattern    = PVar Name+                | PTerm Name [Pattern]             deriving (Typeable, Data)++data Expression = Var Name+                | App Expression Expression+                | Lambda Name Expression           deriving (Typeable, Data)++type Name       = String++-- A little sample program++sys1   = S [f1,f2]+f1     = F "f1" [e11]+f2     = F "f2" [e21,e22]+e11    = E [] (Var "id") (S [])+e21    = E [ PTerm "C" [ PVar "x" ] ] (Var "x") (S [])+e22    = E [] (Var "id") (S [])+++-- Names declared in an expression+decsExpr :: Expression -> [Name]+decsExpr (Lambda n _) = [n]+decsExpr _            = []++-- Names declared in an equation+decsEqua :: Equation -> [Name]+decsEqua (E ps _ _) = everything union ([] `mkQ` pvar) ps+  where+    pvar (PVar n) = [n]+    pvar _        = []++-- Names declared in a system+decsSyst :: System -> [Name]+decsSyst (S l) = nub $ map (\(F n _) -> n) l++-- Names referenced in an expression+refsExpr :: Expression -> [Name]+refsExpr (Var n) = [n]++-- Names referenced in an equation+refsEqua :: Equation -> [Name]+refsEqua (E ps _ _) = everything union ([] `mkQ` pterm) ps+  where+    pterm (PTerm n _) = [n]+    pterm _           = []++-- Combine the above type-specific cases to obtain+-- generic functions that find declared and referenced names+--+decsFun :: Data a => a -> [Name]+decsFun =  const [] `extQ` decsExpr `extQ` decsEqua `extQ` decsSyst++refsFun :: Data a => a -> [Name]+refsFun =  const [] `extQ` refsExpr `extQ` refsEqua++++{-++Free name analysis: Take the union of free names obtained from the+immediate subterms (via gmapQ) and the names being referred to at the+root of the present term, but subtract all the names that are declared+at the root.++-}++freeNames :: Data a => a -> [Name]+freeNames x = ( (refsFun x)+                `union`+                (nub . concat . gmapQ freeNames) x+              ) \\ decsFun x++{-++Print the free names for the sample program sys1; see module+FunDatatypes.hs. This should print the list ["id","C"] because the+"Prelude" function "id" is used in the sample program, and also the+term constructor "C" occurs in a pattern; we assume a language without+explicit datatype declarations ;-)++-}++tests = freeNames sys1 @=? output++output = ["id","C"]
+ tests/GEq.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DeriveDataTypeable #-}++module GEq (tests) where++{-++This test exercices GENERIC read, show, and eq for the company+datatypes which we use a lot. The output of the program should be+"True" which means that "gread" reads what "gshow" shows while the+read term is equal to the original term in terms of "geq".++-}++import Test.Tasty.HUnit++import Data.Generics+import CompanyDatatypes++tests = ( geq genCom genCom+        , geq genCom genCom'+        ) @=? (True,False)
+ tests/GMapQAssoc.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes         #-}++module GMapQAssoc (tests) where++{-++This example demonstrates the inadequacy of an apparently simpler+variation on gmapQ. To this end, let us first recall a few facts.+Firstly, function application (including constructor application) is+left-associative. This is the reason why we had preferred our generic+fold to be left-associative too. (In "The Sketch Of a Polymorphic+Symphony" you can find a right-associative generic fold.)  Secondly,+lists are right-associative. Because of these inverse associativities+queries for the synthesis of lists require some extra effort to+reflect the left-to-right of immediate subterms in the queried list.+In the module Data.Generics, we solve the problem by a common+higher-order trick, that is, we do not cons lists during folding but+we pass functions on lists starting from the identity function and+passing [] to the resulting function. The following example+illustrates that we get indeed an undesirable right-to-left order if+we just apply the simple constant datatype constructor CONST instead+of the higher-order trick.++Contributed by Ralf Laemmel, ralf@cwi.nl++-}++import Test.Tasty.HUnit++import Data.Generics+++-- The plain constant type constructor+newtype CONST x y = CONST x+unCONST (CONST x) = x+++-- A variation on the gmapQ combinator using CONST and not Q+gmapQ' :: Data a => (forall a. Data a => a -> u) -> a -> [u]+gmapQ' f = unCONST . gfoldl f' z+  where+    f' r a = CONST (f a : unCONST r)+    z  = const (CONST [])+++-- A trivial datatype used for this test case+data IntTree = Leaf Int | Fork IntTree IntTree+               deriving (Typeable, Data)+++-- Select int if faced with a leaf+leaf (Leaf i) = [i]+leaf _        = []+++-- A test term+term = Fork (Leaf 1) (Leaf 2)+++-- Process test term+--  gmapQ  gives left-to-right order+--  gmapQ' gives right-to-left order+--+tests = show ( gmapQ   ([] `mkQ` leaf) term+             , gmapQ'  ([] `mkQ` leaf) term+             ) @=? output++output = show ([[1],[2]],[[2],[1]])
+ tests/GRead.hs view
@@ -0,0 +1,55 @@+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, str2, str3, str4, str4a, str5, str6, str7 :: String+str1  = "(True)"     -- reads fine as a Bool+str2  = "(Treu)"     -- invalid constructor+str3  = "True"       -- lacks parentheses+str4  = "(1)"        -- could be an Int+str4a = "(-1)"       -- negative literal+str5  = "( 2 ) ..."  -- could be an Int with some trailing left-over+str6  = "([])"       -- test empty list+str7  = "((:)" ++ " " ++ str4 ++ " " ++ str6 ++ ")"++expected ::+  ( [[(Bool,  String)]]+  , [[(Int,   String)]]+  , [[([Int], String)]]+  )+expected =+  ( [ gread str1,+      gread str2,+      gread str3+    ]+  , [ gread str4,+      gread str4a,+      gread str5+    ]+  , [ gread str6,+      gread str7+    ]+  )++tests :: Assertion+tests = show expected @=? show output++output ::+  ( [[(Bool,  String)]]+  , [[(Int,   String)]]+  , [[([Int], String)]]+  )+output =+  ([[(True,"")],[],[]],[[(1,"")],[(-1,"")],[(2,"...")]],[[([],"")],[([1],"")]])
+ tests/GRead2.hs view
@@ -0,0 +1,76 @@+{-# 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 }
+ tests/GShow.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DeriveDataTypeable #-}++module GShow (tests) where++{-++The generic show example from the 2nd boilerplate paper.+(There were some typos in the ICFP 2004 paper.)+Also check out Data.Generics.Text.++-}++import Test.Tasty.HUnit++import Data.Generics hiding (gshow)+import Prelude hiding (showString)+++gshow :: Data a => a -> String+gshow = gshow_help `extQ` showString++gshow_help :: Data a => a -> String+gshow_help t+     =  "("+     ++ showConstr (toConstr t)+     ++ concat (intersperse " " (gmapQ gshow t))+     ++ ")"++showString :: String -> String+showString s = "\"" ++ concat (map escape s) ++ "\""+               where+                 escape '\n' = "\\n"+                 escape other_char = [other_char]++gshowList :: Data b => [b] -> String+gshowList xs+    = "[" ++ concat (intersperse "," (map gshow xs)) ++ "]"++gshow' :: Data a => a -> String+gshow' = gshow_help `ext1Q` gshowList+                    `extQ`  showString++intersperse :: a -> [a] -> [a]+intersperse _ []     = []+intersperse x [e]    = [e]+intersperse x (e:es) = (e:(x:intersperse x es))++tests = ( gshow' "foo"+        , gshow' [True,False]+        ) @=? output++output = ("\"foo\"","[(True),(False)]")
+ tests/GShow2.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DeriveDataTypeable #-}++module GShow2 (tests) where++{-++This test exercices GENERIC show for the infamous company datatypes. The+output of the program should be some representation of the infamous+"genCom" company.++-}++import Test.Tasty.HUnit++import Data.Generics+import CompanyDatatypes++tests = gshow genCom @=? output++{-++Here is another exercise:+The following function gshow' is a completely generic variation on gshow.+It would print strings as follows:++*Main> gshow' "abc"+"((:) ('a') ((:) ('b') ((:) ('c') ([]))))"++The original gshow does a better job because it is customised for strings:++*Main> gshow "foo"+"\"foo\""++In fact, this is what Haskell's normal show would also do:++*Main> show "foo"+"\"foo\""++-}++gshow' :: Data a => a -> String+gshow' t =     "("+            ++ showConstr (toConstr t)+            ++ concat (gmapQ ((++) " " . gshow') t)+            ++ ")"++output = "(C ((:) (D \"Research\" (E (P \"Laemmel\" \"Amsterdam\") (S (8000.0))) ((:) (PU (E (P \"Joost\" \"Amsterdam\") (S (1000.0)))) ((:) (PU (E (P \"Marlow\" \"Cambridge\") (S (2000.0)))) ([])))) ((:) (D \"Strategy\" (E (P \"Blair\" \"London\") (S (100000.0))) ([])) ([]))))"
+ tests/GZip.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE ScopedTypeVariables #-}++module GZip (tests) where++{-++This test illustrates zipping for the company datatypes which we use a+lot. We process two companies that happen to agree on the overall+shape but differ in the salaries in a few positions. So whenever we+encounter salaries we take the maximum of the two.++-}++import Test.Tasty.HUnit++import Data.Generics+import CompanyDatatypes++-- The main function which prints the result of zipping+tests = gzip (\x y -> mkTT maxS x y) genCom1 genCom2 @=? output+  -- NB: the argument has to be eta-expanded to match+  --     the type of gzip's argument type, which is+  --     GenericQ (GenericM Maybe)+  where++    -- Variations on the show case company "genCom"+    genCom1 = everywhere (mkT (double "Joost")) genCom+    genCom2 = everywhere (mkT (double "Marlow")) genCom+    double x (E p@(P y _) (S s)) | x == y = E p (S (2*s))+    double _ e = e++    -- Sum up two salaries+    maxS (S x) (S y) = S (max x y)++    -- Make a two-arguments, generic function transformer+    mkTT :: (Typeable a, Typeable b, Typeable c)+         => (a -> a -> a) -> b -> c -> Maybe c+    mkTT (f::a -> a -> a) x y =+      case (cast x,cast y) of+        (Just (x'::a),Just (y'::a)) -> cast (f x' y')+        _                           -> Nothing++output = Just (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0))+           [PU (E (P "Joost" "Amsterdam") (S 2000.0))+           ,PU (E (P "Marlow" "Cambridge") (S 4000.0))]+           ,D "Strategy" (E (P "Blair" "London") (S 100000.0)) []])
+ tests/GenUpTo.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE DeriveDataTypeable #-}++{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-}++module GenUpTo (tests) where++{-++This example illustrate test-set generation,+namely all terms of a given depth are generated.++-}++import Test.Tasty.HUnit++import Data.Generics+++{-++The following datatypes comprise the abstract syntax of a simple+imperative language. Some provisions are such that the discussion+of test-set generation is simplified. In particular, we do not+consider anything but monomorphic *data*types --- no primitive+types, no tuples, ...++-}++data Prog = Prog Dec Stat+            deriving (Show, Eq, Data)++data Dec  = Nodec+          | Ondec Id Type+          | Manydecs Dec Dec+            deriving (Show, Eq, Data)++data Id = A | B+          deriving (Show, Eq, Data)++data Type = Int | Bool+            deriving (Show, Eq, Data)++data Stat = Noop+          | Assign Id Exp+          | Seq Stat Stat+            deriving (Show, Eq, Data)++data Exp = Zero+         | Succ Exp+           deriving (Show, Eq, Data)+++-- Generate all terms of a given depth+genUpTo :: Data a => Int -> [a]+genUpTo 0 = []+genUpTo d = result+   where+     -- Getting hold of the result (type)+     result = concat (map recurse cons)++     -- Retrieve constructors of the requested type+     cons :: [Constr]+     cons = dataTypeConstrs (dataTypeOf (head result))++     -- Find all terms headed by a specific Constr+     recurse :: Data a => Constr -> [a]+     recurse con = gmapM (\_ -> genUpTo (d-1))+                         (fromConstr con)++     -- We could also deal with primitive types easily.+     -- Then we had to use cons' instead of cons.+     --+     cons' :: [Constr]+     cons' = case dataTypeRep ty of+              AlgRep cons'' -> cons''+              IntRep        -> [mkIntegralConstr ty 0]+              FloatRep      -> [mkIntegralConstr ty 0]+              CharRep       -> [mkCharConstr ty 'x']+              NoRep         -> []+      where+        ty = dataTypeOf (head result)+++-- For silly tests+data T0 = T0 T1 T2 T3 deriving (Show, Eq, Data)+data T1 = T1a | T1b   deriving (Show, Eq, Data)+data T2 = T2a | T2b   deriving (Show, Eq, Data)+data T3 = T3a | T3b   deriving (Show, Eq, Data)++tests :: Assertion+tests = (   genUpTo 0 :: [Id]+        , ( genUpTo 1 :: [Id]+        , ( genUpTo 2 :: [Id]+        , ( genUpTo 2 :: [T0]+        , ( genUpTo 3 :: [Prog]+        ))))) @=? output++output :: ([a], ([Id], ([Id], ([T0], [Prog]))))+output = ([],([A,B],([A,B],([T0 T1a T2a T3a,T0 T1a T2a T3b,T0 T1a T2b T3a,T0 T1a T2b T3b,T0 T1b T2a T3a,T0 T1b T2a T3b,T0 T1b T2b T3a,T0 T1b T2b T3b],[Prog Nodec Noop,Prog Nodec (Assign A Zero),Prog Nodec (Assign B Zero),Prog Nodec (Seq Noop Noop),Prog (Ondec A Int) Noop,Prog (Ondec A Int) (Assign A Zero),Prog (Ondec A Int) (Assign B Zero),Prog (Ondec A Int) (Seq Noop Noop),Prog (Ondec A Bool) Noop,Prog (Ondec A Bool) (Assign A Zero),Prog (Ondec A Bool) (Assign B Zero),Prog (Ondec A Bool) (Seq Noop Noop),Prog (Ondec B Int) Noop,Prog (Ondec B Int) (Assign A Zero),Prog (Ondec B Int) (Assign B Zero),Prog (Ondec B Int) (Seq Noop Noop),Prog (Ondec B Bool) Noop,Prog (Ondec B Bool) (Assign A Zero),Prog (Ondec B Bool) (Assign B Zero),Prog (Ondec B Bool) (Seq Noop Noop),Prog (Manydecs Nodec Nodec) Noop,Prog (Manydecs Nodec Nodec) (Assign A Zero),Prog (Manydecs Nodec Nodec) (Assign B Zero),Prog (Manydecs Nodec Nodec) (Seq Noop Noop)]))))
+ tests/GetC.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE FunctionalDependencies    #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE UndecidableInstances      #-}++{-# LANGUAGE CPP #-}+# if __GLASGOW_HASKELL__ <= 708+{-# LANGUAGE OverlappingInstances      #-}+#endif++module GetC (tests) where++import Test.Tasty.HUnit++{-++Ralf Laemmel, 5 November 2004++Joe Stoy suggested the idiom to test for the outermost constructor.++Given is a term t+and a constructor f (say the empty constructor application).++isC f t returns True if the outermost constructor of t is f.+isC f t returns False otherwise.+Modulo type checking, i.e., the data type of f and t must be the same.+If not, we want to see a type error, of course.++-}++import Data.Typeable  -- to cast t's subterms, which will be reused for f.+import Data.Generics  -- to access t's subterms and constructors.+++-- Some silly data types+data T1 = T1a Int String | T1b String Int     deriving (Typeable, Data)+data T2 = T2a Int Int    | T2b String String  deriving (Typeable, Data)+data T3 = T3  !Int                            deriving (Typeable, Data)+++-- Test cases+tests = show [ isC T1a (T1a 1 "foo")   -- typechecks, returns True+             , isC T1a (T1b "foo" 1)   -- typechecks, returns False+             , isC T3  (T3 42)]        -- works for strict data too+        @=? output+-- err = show $ isC T2b (T1b "foo" 1)  -- must not typecheck++output = show [True,False,True]++--+-- We look at a datum a.+-- We look at a constructor function f.+-- The class GetT checks that f constructs data of type a.+-- The class GetC computes maybe the constructor ...+-- ... if the subterms of the datum at hand fit for f.+-- Finally we compare the constructors.+--++isC :: (Data a, GetT f a, GetC f) => f -> a -> Bool+isC f t = maybe False ((==) (toConstr t)) con+ where+  kids = gmapQ ExTypeable t -- homogenify subterms in list for reuse+  con  = getC f kids        -- compute constructor from constructor application+++--+-- We prepare for a list of kids using existential envelopes.+-- We could also just operate on TypeReps for non-strict datatypes.+--++data ExTypeable = forall a. Typeable a => ExTypeable a+unExTypeable (ExTypeable a) = cast a+++--+-- Compute the result type of a function type.+-- Beware: the TypeUnify constraint causes headache.+-- We can't have GetT t t because the FD will be violated then.+-- We can't omit the FD because unresolvable overlapping will hold then.+--++class GetT f t | f -> t -- FD is optional+instance  GetT g t => GetT (x -> g) t+instance {-# OVERLAPPABLE #-} TypeUnify t t' => GetT t t'+++--+-- Obtain the constructor if term can be completed+--++class GetC f+ where+  getC :: f -> [ExTypeable] -> Maybe Constr++instance (Typeable x, GetC g) => GetC (x -> g)+ where+  getC _ [] = Nothing+  getC (f::x->g) (h:t)+    =+      do+         (x::x) <- unExTypeable h+         getC (f x) t++instance {-# OVERLAPPABLE #-} Data t => GetC t+ where+  getC y []    = Just $ toConstr y+  getC _ (_:_) = Nothing+++--+-- Type unification; we could try this:+--  class TypeUnify a b | a -> b, b -> a+--  instance TypeUnify a a+--+-- However, if the instance is placed in the present module,+-- then type improvement would inline this instance. Sigh!!!+--+-- So we need type unification with type improvement blocker+-- The following solution works with GHC for ages.+-- Other solutions; see the HList paper.+--++class    TypeUnify   a  b   |    a -> b,   b -> a+class    TypeUnify'  x  a b |  x a -> b, x b -> a+class    TypeUnify'' x  a b |  x a -> b, x b -> a+instance TypeUnify'  () a b => TypeUnify    a b+instance TypeUnify'' x  a b => TypeUnify' x a b+instance TypeUnify'' () a a
+ tests/HList.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE ExistentialQuantification #-}++module HList (tests) where++{-++This module illustrates heterogeneously typed lists.++-}++import Test.Tasty.HUnit++import Data.Typeable+++-- Heterogeneously typed lists+type HList = [DontKnow]++data DontKnow = forall a. Typeable a => DontKnow a++-- The empty list+initHList :: HList+initHList = []++-- Add an entry+addHList :: Typeable a => a -> HList -> HList+addHList a l = (DontKnow a:l)++-- Access per index; starts at 1+nth1HList :: Typeable a => Int -> HList -> Maybe a+nth1HList i l = case (l !! (i-1)) of (DontKnow a) -> cast a+++----------------------------------------------------------------------------++-- A demo list+mylist :: HList+mylist = addHList (1::Int)       $+         addHList (True::Bool)   $+         addHList ("42"::String) $+         initHList++-- Main function for testing+tests :: Assertion+tests = (   show (nth1HList 1 mylist :: Maybe Int)    -- shows Just 1+        , ( show (nth1HList 1 mylist :: Maybe Bool)   -- shows Nothing+        , ( show (nth1HList 2 mylist :: Maybe Bool)   -- shows Just True+        , ( show (nth1HList 3 mylist :: Maybe String) -- shows Just "42"+        )))) @=? output++output :: (String, (String, (String, String)))+output = ("Just 1",("Nothing",("Just True","Just \"42\"")))
+ tests/HOPat.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExplicitForAll     #-}++module HOPat (tests) where++{-++This module is in reply to an email by C. Barry Jay+received on March 15, and handled within hours. CBJ+raises the very interesting issue of higher-order patterns.+It turns out that some form of it is readily covered in+our setting.++-}++import Test.Tasty.HUnit++import Data.Generics+++-- Sample datatypes+data T1 = T1a Int | T1b Double+        deriving (Show, Eq, Typeable, Data)+data T2 = T2a T1 T2 | T2b+        deriving (Show, Eq, Typeable, Data)++-- Eliminate a constructor if feasible+elim' :: (Data y, Data x) => Constr -> y -> Maybe x+elim' c y = if toConstr y == c+                then unwrap y+                else Nothing+++-- Unwrap a term; Return its single component+unwrap :: (Data y, Data x) => y -> Maybe x+unwrap y = case gmapQ (Nothing `mkQ` Just) y of+             [Just x] -> Just x+             _ -> Nothing+++-- Eliminate a constructor if feasible; 2nd try+elim :: forall x y. (Data y, Data x) => (x -> y) -> y -> Maybe x+elim c y = elim' (toConstr (c (undefined::x))) y+++-- Visit a data structure+visitor :: (Data x, Data y, Data z)+        => (x -> y) -> (x -> x) -> z -> z+visitor c f = everywhere (mkT g)+  where+    g y = case elim c y of+            Just x  -> c (f x)+            Nothing -> y+++-- Main function for testing+tests = ( (  elim' (toConstr t1a) t1a) :: Maybe Int+        , ( (elim' (toConstr t1a) t1b) :: Maybe Int+        , ( (elim  T1a t1a)            :: Maybe Int+        , ( (elim  T1a t1b)            :: Maybe Int+        , ( (visitor T1a ((+) 46) t2)  :: T2+        ))))) @=? output+ where+   t1a = T1a 42+   t1b = T1b 3.14+   t2  = T2a t1a (T2a t1a T2b)++output = (Just 42,(Nothing,(Just 42,(Nothing,T2a (T1a 88) (T2a (T1a 88) T2b)))))
+ tests/Labels.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Labels (tests) where++-- This module tests availability of field labels.++import Test.Tasty.HUnit++import Data.Generics++-- A datatype without labels+data NoLabels = NoLabels Int Double+              deriving (Typeable, Data)++-- A datatype with labels+data YesLabels = YesLabels { myint   :: Int+                           , myfloat :: Double+                           }+               deriving (Typeable, Data)++-- Test terms+noLabels  = NoLabels  42 3.14+yesLabels = YesLabels 42 3.14++-- Main function for testing+tests = ( constrFields $ toConstr noLabels+        , constrFields $ toConstr yesLabels+        ) @=? output++output = ([],["myint","myfloat"])
+ tests/LocalQuantors.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes         #-}++module LocalQuantors () where++-- A datatype with a locally quantified component+-- Seems to be too polymorphic to descend into structure!+-- Largely irrelevant?!++import Data.Generics++data Test = Test (GenericT) deriving Typeable++instance Data Test+  where+    gfoldl _ z x = z x -- folding without descent+    toConstr (Test _) = testConstr+    gunfold _ _ = error "gunfold"+    dataTypeOf _ = testDataType++testConstr   = mkConstr testDataType "Test" [] Prefix+testDataType = mkDataType "Main.Test" [testConstr]
+ tests/Main.hs view
@@ -0,0 +1,75 @@++module Main where++import Test.Tasty+import Test.Tasty.HUnit+import System.Exit++import qualified Bits+import qualified Builders+import qualified Datatype+import qualified Ext1+import qualified Ext2+import qualified FoldTree+import qualified FreeNames+import qualified GEq+import qualified GMapQAssoc+import qualified GRead+import qualified GShow+import qualified GShow2+import qualified GZip+import qualified GenUpTo+import qualified GetC+import qualified HList+import qualified HOPat+import qualified Labels+import qualified Newtype+import qualified Paradise+import qualified Perm+import qualified Reify+import qualified Strings+import qualified Tree+import qualified Twin+import qualified Typecase1+import qualified Typecase2+import qualified Where+import qualified XML++import qualified Encode           -- no tests, should compile+import qualified Ext              -- no tests, should compile+import qualified GRead2           -- no tests, should compile+import qualified LocalQuantors    -- no tests, should compile+import qualified NestedDatatypes  -- no tests, should compile+import qualified Polymatch        -- no tests, should compile++main = defaultMain $ testGroup "All"+  [ testCase "Datatype"   Datatype.tests+  , testCase "FoldTree"   FoldTree.tests+  , testCase "GetC"       GetC.tests+  , testCase "GMapQAssoc" GMapQAssoc.tests+  , testCase "GRead"      GRead.tests+  , testCase "GShow"      GShow.tests+  , testCase "GShow2"     GShow2.tests+  , testCase "HList"      HList.tests+  , testCase "HOPat"      HOPat.tests+  , testCase "Labels"     Labels.tests+  , testCase "Newtype"    Newtype.tests+  , testCase "Perm"       Perm.tests+  , testCase "Twin"       Twin.tests+  , testCase "Typecase1"  Typecase1.tests+  , testCase "Typecase2"  Typecase2.tests+  , testCase "Where"      Where.tests+  , testCase "XML"        XML.tests+  , testCase "Tree"       Tree.tests+  , testCase "Strings"    Strings.tests+  , testCase "Reify"      Reify.tests+  , testCase "Paradise"   Paradise.tests+  , testCase "GZip"       GZip.tests+  , testCase "GEq"        GEq.tests+  , testCase "GenUpTo"    GenUpTo.tests+  , testCase "FreeNames"  FreeNames.tests+  , testCase "Ext1"       Ext1.tests+  , testCase "Ext2"       Ext2.tests+  , testCase "Bits"       Bits.tests+  , testCase "Builders"   Builders.tests+  ]
+ tests/NestedDatatypes.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE MonoLocalBinds       #-}+{-# LANGUAGE UndecidableInstances #-}++module NestedDatatypes () where++{-++We provide an illustrative ScrapYourBoilerplate example for a nested+datatype.  For clarity, we do not derive the Typeable and Data+instances by the deriving mechanism but we show the intended+definitions. The overall conclusion is that nested datatypes do not+pose any challenge for the ScrapYourBoilerplate scheme. Well, this is+maybe not quite true because it seems like we need to allow+undecidable instances.++-}++import Data.Dynamic+import Data.Generics+++-- A nested datatype+data Nest a = Box a | Wrap (Nest [a]) deriving Typeable+++-- The Data instance for the nested datatype+instance (Data a, Data [a]) => Data (Nest a)+  where+    gfoldl k z (Box a)  = z Box `k` a+    gfoldl k z (Wrap w) = z Wrap `k` w+    gmapT f (Box a)  = Box (f a)+    gmapT f (Wrap w) = Wrap (f w)+    toConstr (Box _)  = boxConstr+    toConstr (Wrap _) = wrapConstr+    gunfold k z c = case constrIndex c of+                      1 -> k (z Box)+                      2 -> k (z Wrap)+    dataTypeOf _ = nestDataType++boxConstr    = mkConstr nestDataType "Box"  [] Prefix+wrapConstr   = mkConstr nestDataType "Wrap" [] Prefix+nestDataType = mkDataType "Main.Nest" [boxConstr,wrapConstr]
+ tests/Newtype.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Newtype (tests) where++-- The type of a newtype should treat the newtype as opaque++import Test.Tasty.HUnit++import Data.Generics++newtype T = MkT Int deriving( Typeable )++tests = show (typeOf (undefined :: T)) @?= output++#if __GLASGOW_HASKELL__ >= 701+output = "T"+#else+output = "Newtype.T"+#endif
+ tests/Paradise.hs view
@@ -0,0 +1,27 @@+module Paradise (tests) where++{-++This test runs the infamous PARADISE benchmark,+which is the HELLO WORLD example of generic programming,+i.e., the "increase salary" function is applied to+a typical company just as shown in the boilerplate paper.++-}++import Test.Tasty.HUnit++import Data.Generics+import CompanyDatatypes++-- Increase salary by percentage+increase :: Double -> Company -> Company+increase k = everywhere (mkT (incS k))++-- "interesting" code for increase+incS :: Double -> Salary -> Salary+incS k (S s) = S (s * (1+k))++tests = increase 0.125 genCom @=? output++output = C [D "Research" (E (P "Laemmel" "Amsterdam") (S 9000)) [PU (E (P "Joost" "Amsterdam") (S 1125)),PU (E (P "Marlow" "Cambridge") (S 2250))],D "Strategy" (E (P "Blair" "London") (S 112500)) []]
+ tests/Perm.hs view
@@ -0,0 +1,144 @@+{-# 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(..))+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, Data)+data T2 = T2       deriving (Show, Eq, Data)+data T3 = T3 T1 T2 deriving (Show, Eq, 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 :: ReadT a -> [String] -> Maybe a+runReadT x y = case unReadT x y of+                 Just ([],z) -> Just z+                 _           -> Nothing++-- Read one string+readT :: ReadT String+readT =  ReadT (\x -> case x of+                        []     -> Nothing+                        y : ys -> Just (ys, y)+               )++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 b. ReadT b -> b+      myTypeOf =  undefined++  -- Turn string into constructor+  string2constr str = maybe mzero+                            return+                            (readConstr (dataTypeOf myType) str)++  -- Specialise buildT per kid type+  buildT' :: forall b. Data b => b -> GenM+  buildT' (_::b) = GenM (const mzero `extM` const (buildT::ReadT b))++  -- The permutation exploration function+  perm :: forall b. Data b => [GenM] -> [GenM] -> b -> ReadT b+  perm [] [] a = return a+  perm fs [] a = perm [] fs a+  perm fs (f:fs') a = (+                        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 :: Assertion+tests =+     ( runReadT buildT ["T1"] :: Maybe T1           -- should parse fine+   , ( runReadT buildT ["T2"] :: Maybe T2           -- should parse fine+   , ( runReadT buildT ["T3","T1","T2"] :: Maybe T3 -- should parse fine+   , ( runReadT buildT ["T3","T2","T1"] :: Maybe T3 -- should parse fine+   , ( runReadT buildT ["T3","T2","T2"] :: Maybe T3 -- should fail+   ))))) @=? output++output :: (Maybe T1, (Maybe T2, (Maybe T3, (Maybe T3, Maybe a))))+output = (Just T1,(Just T2,(Just (T3 T1 T2),(Just (T3 T1 T2),Nothing))))
+ tests/Polymatch.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE ExistentialQuantification #-}++module Polymatch () where+++import Data.Typeable+import Data.Generics+++-- Representation of kids+kids x = gmapQ Kid x -- get all kids+type Kids = [Kid]+data Kid  = forall k. Typeable k => Kid k+++-- Build term from a list of kids and the constructor+fromConstrL :: Data a => Kids -> Constr -> Maybe a+fromConstrL l = unIDL . gunfold k z+ where+  z c = IDL (Just c) l+  k (IDL Nothing _) = IDL Nothing undefined+  k (IDL (Just f) (Kid x:l)) = IDL f' l+   where+    f' = case cast x of+          (Just x') -> Just (f x')+          _         -> Nothing+++-- Helper datatype+data IDL x = IDL (Maybe x) Kids+unIDL (IDL mx _) = mx+++-- Two sample datatypes+data A = A String deriving (Read, Show, Eq, Data, Typeable)+data B = B String deriving (Read, Show, Eq, Data, Typeable)+++-- Mediate between two "left-equal" Either types+f :: (Data a, Data b, Show a, Read b)+  => (a->b) -> Either String a -> Either String b++f g (Right a)    = Right $ g a       -- conversion really needed+-- f g (Left  s) = Left s            -- unappreciated conversion+-- f g s         = s                 -- doesn't typecheck+-- f g s         = deep_rebuild s    -- too expensive+f g s            = just (shallow_rebuild s) -- perhaps this is Ok?+++-- Get rid of maybies+just = maybe (error "tried, but failed.") id+++-- Just mentioned for completeness' sake+deep_rebuild :: (Show a, Read b) => a -> b+deep_rebuild = read . show+++-- For the record: it's possible.+shallow_rebuild :: (Data a, Data b) => a -> Maybe b+shallow_rebuild a = b+ where+  b      = fromConstrL (kids a) constr+  constr = indexConstr (dataTypeOf b) (constrIndex (toConstr a))+++-- Test cases+a2b (A s) = B s            -- silly conversion+t1 = f a2b (Left "x")      -- prints Left "x"+t2 = f a2b (Right (A "y")) -- prints Right (B "y")
+ tests/Reify.hs view
@@ -0,0 +1,416 @@++{-# 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)) []))))))))))
+ tests/Strings.hs view
@@ -0,0 +1,19 @@+module Strings (tests) where++{-++This test exercices GENERIC read, show, and eq for the company+datatypes which we use a lot. The output of the program should be+"True" which means that "gread" reads what "gshow" shows while the+read term is equal to the original term in terms of "geq".++-}++import Test.Tasty.HUnit++import Data.Generics+import CompanyDatatypes++tests = (case gread (gshow genCom) of+           [(x,_)] -> geq genCom x+           _ -> False) @=? True
+ tests/Tree.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-}++module Tree (tests) where++{-++This example illustrates serialisation and de-serialisation,+but we replace *series* by *trees* so to say.++-}++import Test.Tasty.HUnit++import Control.Monad (guard)+import Data.Generics+import Data.Maybe+import Data.Tree++import CompanyDatatypes+++-- Trealise Data to Tree+data2tree :: Data a => a -> Tree String+data2tree = gdefault `extQ` atString+  where+    atString (x::String) = Node x []+    gdefault x = Node (showConstr (toConstr x)) (gmapQ data2tree x)+++-- De-trealise Tree to Data+tree2data :: Data a => Tree String -> Maybe a+tree2data = gdefault `extR` atString+  where+    atString (Node x []) = Just x+    gdefault (Node x ts) = res+      where++        -- a helper for type capture+        res  = maybe Nothing (kids . fromConstr) con++        -- the type to constructed+        ta   = fromJust res++        -- construct constructor+        con  = readConstr (dataTypeOf ta) x++        -- recursion per kid with accumulation+        perkid ts = const (tail ts, tree2data (head ts))++        -- recurse into kids+        kids y =+          do guard (glength y == length ts)+             snd (gmapAccumM perkid ts y)+++-- Main function for testing+tests :: Assertion+tests = (   genCom+        , ( data2tree genCom+        , ( (tree2data (data2tree genCom)) :: Maybe Company+        , ( Just genCom == tree2data (data2tree genCom)+        )))) @=? output++output :: (Company, (Tree String, (Maybe Company, Bool)))+output = (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []],(Node {rootLabel = "C", subForest = [Node {rootLabel = "(:)", subForest = [Node {rootLabel = "D", subForest = [Node {rootLabel = "Research", subForest = []},Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Laemmel", subForest = []},Node {rootLabel = "Amsterdam", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "8000.0", subForest = []}]}]},Node {rootLabel = "(:)", subForest = [Node {rootLabel = "PU", subForest = [Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Joost", subForest = []},Node {rootLabel = "Amsterdam", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "1000.0", subForest = []}]}]}]},Node {rootLabel = "(:)", subForest = [Node {rootLabel = "PU", subForest = [Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Marlow", subForest = []},Node {rootLabel = "Cambridge", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "2000.0", subForest = []}]}]}]},Node {rootLabel = "[]", subForest = []}]}]}]},Node {rootLabel = "(:)", subForest = [Node {rootLabel = "D", subForest = [Node {rootLabel = "Strategy", subForest = []},Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Blair", subForest = []},Node {rootLabel = "London", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "100000.0", subForest = []}]}]},Node {rootLabel = "[]", subForest = []}]},Node {rootLabel = "[]", subForest = []}]}]}]},(Just (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []]),True)))
+ tests/Twin.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes                #-}++module Twin (tests) where++{-++For the discussion in the 2nd boilerplate paper,+we favour some simplified development of twin traversal.+So the full general, stepwise story is in Data.Generics.Twin,+but the short version from the paper is turned into a test+case below.++See the paper for an explanation.++-}++import Test.Tasty.HUnit++import Data.Generics hiding (GQ,gzipWithQ,geq)++geq' :: GenericQ (GenericQ Bool)+geq' x y =  toConstr x == toConstr y+         && and (gzipWithQ geq' x y)++geq :: Data a => a -> a -> Bool+geq a = geq' a++newtype GQ r = GQ (GenericQ r)++gzipWithQ :: GenericQ (GenericQ r)+          -> GenericQ (GenericQ [r])+gzipWithQ f t1 t2+    = gApplyQ (gmapQ (\x -> GQ (f x)) t1) t2++gApplyQ :: Data a => [GQ r] -> a -> [r]+gApplyQ qs t = reverse (snd (gfoldlQ k z t))+    where+      k :: ([GQ r], [r]) -> GenericQ ([GQ r], [r])+      k (GQ q : qs, rs) child = (qs, q child : rs)+      z = (qs, [])++newtype R r x = R { unR :: r }++gfoldlQ :: (r -> GenericQ r)+        -> r+        -> GenericQ r++gfoldlQ k z t = unR (gfoldl k' z' t)+    where+      z' _ = R z+      k' (R r) c = R (k r c)++-----------------------------------------------------------------------------++-- A dependently polymorphic geq+geq'' :: Data a => a -> a -> Bool+geq'' x y =  toConstr x == toConstr y+          && and (gzipWithQ' geq'' x y)++-- A helper type for existentially quantified queries+data XQ r = forall a. Data a => XQ (a -> r)++-- A dependently polymorphic gzipWithQ+gzipWithQ' :: (forall a. Data a => a -> a -> r)+           -> (forall a. Data a => a -> a -> [r])+gzipWithQ' f t1 t2+    = gApplyQ' (gmapQ (\x -> XQ (f x)) t1) t2++-- Apply existentially quantified queries+-- Insist on equal types!+--+gApplyQ' :: Data a => [XQ r] -> a -> [r]+gApplyQ' qs t = reverse (snd (gfoldlQ k z t))+    where+      z = (qs, [])+      k :: ([XQ r], [r]) -> GenericQ ([XQ r], [r])+      k (XQ q : qs, rs) child = (qs, q' child : rs)+        where+          q' = error "Twin mismatch" `extQ` q+++-----------------------------------------------------------------------------++tests = ( geq   [True,True] [True,True]+        , geq   [True,True] [True,False]+        , geq'' [True,True] [True,True]+        , geq'' [True,True] [True,False]+        ) @=? output++output = (True,False,True,False)
+ tests/Typecase1.hs view
@@ -0,0 +1,59 @@+{-# 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")
+ tests/Typecase2.hs view
@@ -0,0 +1,61 @@+{-# 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)")+
+ tests/Where.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Where (tests) where++{-++This example illustrates some differences between certain traversal+schemes. To this end, we use a simple system of datatypes, and the+running example shall be to replace "T1a 42" by "T1a 88". It is our+intention to illustrate a few dimensions of designing traversals.++1. We can decide on whether we prefer "rewrite steps" (i.e.,+monomorphic functions on data) that succeed either for all input+patterns or only if the encounter a term pattern to be replaced. In+the first case, the catch-all equation of such a function describes+identity (see "stepid" below). In the second case, the catch-call+equation describes failure using the Maybe type constructor (see+"stepfail" below). As an intermediate assessment, the failure approach+is more general because it allows one to observe if a rewrite step was+meaningful or not. Often the identity approach is more convenient and+sufficient.++2. We can now also decide on whether we want monadic or simple+traversals; recall monadic generic functions GenericM from+Data.Generics.  The monad can serve for success/failure, state,+environment and others.  One can now subdivide monadic traversal+schemes with respect to the question whether they simply support+monadic style of whether they even interact with the relevant+monad. The scheme "everywereM" from the library belongs to the first+category while "somewhere" belongs to the second category as it uses+the operation "mplus" of a monad with addition. So while "everywhereM"+makes very well sense without a monad --- as demonstrated by+"everywhere", the scheme "somewhere" is immediately monadic.++3. We can now also decide on whether we want rewrite steps to succeed+for all possible subterms, at least for one subterm, exactly for one+subterm, and others.  The various traversal schemes make different+assumptions in this respect.++a) everywhere++   By its type, succeeds and requires non-failing rewrite steps.+   However, we do not get any feedback on whether terms were actually+   rewritten. (Say, we might have performed accidentally the identity+   function on all nodes.)++b) everywhereM++   Attempts to reach all nodes where all the sub-traversals are performed+   in monadic bind-sequence. Failure of the traversal for a given subterm+   implies failure of the entire traversal. Hence, the argument of+   "everywhereM" should be designed in a way that it tends to succeed+   except for the purpose of propagating a proper error in the sense of+   violating a pre-/post-condition. For example, "mkM stepfail" should+   not be passed to "everywhereM" as it will fail for all but one term+   pattern; see "recovered" for a way to massage "stepfail" accordingly.++c) somewhere++   Descends into term in a top-down manner, and stops in a given+   branch when the argument succeeds for the subterm at hand. To this+   end, it takes an argument that is perfectly intended to fail for+   certain term patterns. Thanks to the employment of gmapF, the+   traversal scheme recovers from failure when mapping over the immediate+   subterms while insisting success for at least one subterm (say, branch).+   This scheme is appropriate if you want to make sure that a given+   rewrite step was actually used in a traversal. So failure of the+   traversal would mean that the argument failed for all subterms.++Contributed by Ralf Laemmel, ralf@cwi.nl++-}++import Test.Tasty.HUnit++import Data.Generics+import Control.Monad+++-- Two mutually recursive datatypes+data T1 = T1a Int | T1b T2  deriving (Typeable, Data)+data T2 = T2 T1             deriving (Typeable, Data)+++-- A rewrite step with identity as catch-all case+stepid (T1a 42) = T1a 88+stepid x        = x+++-- The same rewrite step but now with failure as catch-all case+stepfail (T1a 42) = Just (T1a 88)+stepfail _        = Nothing+++-- We can let recover potentially failing generic functions from failure;+-- this is illustrated for a generic made from stepfail via mkM.+recovered x = mkM stepfail x `mplus` Just x+++-- A test term that comprehends a redex+term42 = T1b (T2 (T1a 42))+++-- A test term that does not comprehend a redex+term37 = T1b (T2 (T1a 37))+++-- A number of traversals+result1 = everywhere (mkT stepid)    term42   -- rewrites term accordingly+result2 = everywhere (mkT stepid)    term37   -- preserves term without notice+result3 = everywhereM (mkM stepfail) term42   -- fails in a harsh manner+result4 = everywhereM (mkM stepfail) term37   -- fails rather early+result5 = everywhereM recovered      term37   -- preserves term without notice+result6 = somewhere (mkMp stepfail)  term42   -- rewrites term accordingly+result7 = somewhere (mkMp stepfail)  term37   -- fails to notice lack of redex++tests = gshow ( result1,+              ( result2,+              ( result3,+              ( result4,+              ( result5,+              ( result6,+              ( result7 ))))))) @=? output++output = "((,) (T1b (T2 (T1a (88)))) ((,) (T1b (T2 (T1a (37)))) ((,) (Nothing) ((,) (Nothing) ((,) (Just (T1b (T2 (T1a (37))))) ((,) (Just (T1b (T2 (T1a (88))))) (Nothing)))))))"
+ tests/XML.hs view
@@ -0,0 +1,210 @@+{-# 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(..))+import Control.Monad+import Data.Generics+import CompanyDatatypes+++-- HaXml-like types for XML elements+data Element   = Elem Name [Attribute] [Content]+                 deriving (Show, Eq, Data)++data Content   = CElem Element+               | CString Bool CharData+                        -- ^ bool is whether whitespace is significant+               | CRef Reference+               | CMisc Misc+                 deriving (Show, Eq, 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 b. ReadX b -> b+      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 b. Data b => ReadX [b]+  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 :: ReadX a -> [Content] -> Maybe a+runReadX x y = case unReadX x y of+                 Just ([],z) -> Just z+                 _           -> Nothing++-- Read one content particle+readX :: ReadX Content+readX =  ReadX (\x -> case x of+                        [] -> Nothing+                        y : ys -> Just (ys, y)+               )++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 :: Assertion+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 :: (Company, ([Content], (Maybe Person, (Maybe Company, Bool))))+output = (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []],([CElem (Elem "Company" [] [CElem (Elem "Dept" [] [CString True "Research",CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Laemmel",CString True "Amsterdam"]),CElem (Elem "Salary" [] [CString True "8000.0"])]),CElem (Elem "Unit" [] [CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Joost",CString True "Amsterdam"]),CElem (Elem "Salary" [] [CString True "1000.0"])])]),CElem (Elem "Unit" [] [CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Marlow",CString True "Cambridge"]),CElem (Elem "Salary" [] [CString True "2000.0"])])])]),CElem (Elem "Dept" [] [CString True "Strategy",CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Blair",CString True "London"]),CElem (Elem "Salary" [] [CString True "100000.0"])])])])],(Just (P "Lazy" "Home"),(Just (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []]),True))))