syb 0.1.0.3 → 0.2
raw patch · 55 files changed
+3233/−64 lines, 55 filesbuild-type:Customsetup-changed
Files
- Setup.hs +11/−2
- src/Data/Generics.hs +7/−3
- src/Data/Generics/Aliases.hs +20/−7
- src/Data/Generics/Basics.hs +1/−1
- src/Data/Generics/Builders.hs +65/−0
- src/Data/Generics/Instances.hs +31/−22
- src/Data/Generics/Schemes.hs +5/−1
- src/Data/Generics/Text.hs +21/−14
- src/Data/Generics/Twins.hs +23/−1
- src/Generics/SYB.hs +17/−0
- src/Generics/SYB/Aliases.hs +17/−0
- src/Generics/SYB/Basics.hs +17/−0
- src/Generics/SYB/Builders.hs +17/−0
- src/Generics/SYB/Instances.hs +17/−0
- src/Generics/SYB/Schemes.hs +17/−0
- src/Generics/SYB/Text.hs +17/−0
- src/Generics/SYB/Twins.hs +17/−0
- syb.cabal +27/−13
- tests/Bits.hs +214/−0
- tests/Builders.hs +20/−0
- tests/CompanyDatatypes.hs +39/−0
- tests/Datatype.hs +35/−0
- tests/Encode.hs +81/−0
- tests/Ext.hs +30/−0
- tests/Ext1.hs +124/−0
- tests/FoldTree.hs +63/−0
- tests/FreeNames.hs +120/−0
- tests/GEq.hs +21/−0
- tests/GMapQAssoc.hs +68/−0
- tests/GShow.hs +52/−0
- tests/GShow2.hs +47/−0
- tests/GZip.hs +46/−0
- tests/GenUpTo.hs +94/−0
- tests/GetC.hs +121/−0
- tests/Gread.hs +45/−0
- tests/Gread2.hs +66/−0
- tests/HList.hs +62/−0
- tests/HOPat.hs +67/−0
- tests/Labels.hs +30/−0
- tests/LocalQuantors.hs +21/−0
- tests/Main.hs +82/−0
- tests/NestedDatatypes.hs +52/−0
- tests/Newtype.hs +15/−0
- tests/Paradise.hs +29/−0
- tests/Perm.hs +127/−0
- tests/Polymatch.hs +70/−0
- tests/Reify.hs +413/−0
- tests/Strings.hs +21/−0
- tests/Tree.hs +62/−0
- tests/Twin.hs +90/−0
- tests/Typeable.hs +19/−0
- tests/Typecase1.hs +59/−0
- tests/Typecase2.hs +61/−0
- tests/Where.hs +125/−0
- tests/XML.hs +195/−0
Setup.hs view
@@ -1,6 +1,15 @@ module Main (main) where -import Distribution.Simple+import Distribution.Simple ( defaultMainWithHooks, simpleUserHooks+ , UserHooks(runTests))+import System.Cmd (system) main :: IO ()-main = defaultMain+main = defaultMainWithHooks hooks+ where hooks = simpleUserHooks { runTests = runTests' }++-- Runs the testsuite+runTests' _ _ _ _ = system cmd >> return ()+ where testdir = "tests"+ testcmd = "runhaskell ./Main.hs"+ cmd = "cd " ++ testdir ++ " && " ++ testcmd
src/Data/Generics.hs view
@@ -1,8 +1,10 @@+{-# OPTIONS_GHC -cpp #-}+ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics -- Copyright : (c) The University of Glasgow, CWI 2001--2004--- License : BSD-style (see the file libraries/base/LICENSE)+-- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental@@ -26,19 +28,20 @@ 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 +#ifdef __GLASGOW_HASKELL__ #ifndef __HADDOCK__ -- Data types for the sum-of-products type encoding; -- included for backwards compatibility; maybe obsolete. (:*:)(..), (:+:)(..), Unit(..) #endif+#endif ) where ------------------------------------------------------------------------------ -import Prelude -- So that 'make depend' works- #ifdef __GLASGOW_HASKELL__ #ifndef __HADDOCK__ -- Data types for the sum-of-products type encoding;@@ -53,3 +56,4 @@ import Data.Generics.Schemes import Data.Generics.Text import Data.Generics.Twins+import Data.Generics.Builders
src/Data/Generics/Aliases.hs view
@@ -1,8 +1,11 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE Rank2Types #-}+ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Aliases -- Copyright : (c) The University of Glasgow, CWI 2001--2004--- License : BSD-style (see the file libraries/base/LICENSE)+-- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental@@ -33,7 +36,7 @@ GenericQ'(..), GenericM'(..), - -- * Inredients of generic functions+ -- * Ingredients of generic functions orElse, -- * Function combinators on generic functions@@ -46,7 +49,8 @@ ext1T, ext1M, ext1Q,- ext1R+ ext1R,+ ext1B ) where @@ -109,7 +113,7 @@ {- 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+we fold maybes with "maybe" instead of case ... of ..., and we also use a point-free style whenever possible. -}@@ -254,12 +258,12 @@ -- | Other first-class polymorphic wrappers-newtype GenericT' = GT { unGT :: Data a => a -> a }+newtype GenericT' = GT { unGT :: forall a. Data a => a -> a } newtype GenericQ' r = GQ { unGQ :: GenericQ r }-newtype GenericM' m = GM { unGM :: Data a => a -> m a }+newtype GenericM' m = GM { unGM :: forall a. Data a => a -> m a } --- | Left-biased choice on maybies+-- | Left-biased choice on maybes orElse :: Maybe a -> Maybe a -> Maybe a x `orElse` y = case x of Just _ -> x@@ -347,6 +351,12 @@ ext1R def ext = unR ((R def) `ext1` (R ext)) +-- | Type extension of builders for type constructors+ext1B :: (Data a, Typeable1 t)+ => a+ -> (forall b. Data b => (t b))+ -> a+ext1B def ext = unB ((B def) `ext1` (B ext)) ------------------------------------------------------------------------------ --@@ -366,3 +376,6 @@ -- | 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
@@ -2,7 +2,7 @@ -- | -- Module : Data.Generics.Basics -- Copyright : (c) The University of Glasgow, CWI 2001--2004--- License : BSD-style (see the file libraries/base/LICENSE)+-- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental
+ src/Data/Generics/Builders.hs view
@@ -0,0 +1,65 @@+{-# 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. +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. +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
@@ -1,8 +1,10 @@+{-# OPTIONS_GHC -cpp #-}+ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Instances -- Copyright : (c) The University of Glasgow, CWI 2001--2004--- License : BSD-style (see the file libraries/base/LICENSE)+-- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental@@ -27,18 +29,19 @@ ------------------------------------------------------------------------------ -#ifdef __HADDOCK__-import Prelude-#endif- import Data.Data-import Data.Typeable #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 MVar & Co.+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(..) )@@ -48,13 +51,19 @@ import Foreign.ForeignPtr import Foreign.StablePtr import Control.Monad.ST-import Control.Concurrent-import Data.IORef #endif #include "Typeable.h" +-- Version compatibility issues caused by #2760+myMkNoRepType :: String -> DataType+#if __GLASGOW_HASKELL__ >= 611+myMkNoRepType = mkNoRepType+#else+myMkNoRepType = mkNorepType+#endif + ------------------------------------------------------------------------------ -- -- Instances of the Data class for Prelude-like types.@@ -70,7 +79,7 @@ instance Data TypeRep where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold"- dataTypeOf _ = mkNorepType "Data.Typeable.TypeRep"+ dataTypeOf _ = myMkNoRepType "Data.Typeable.TypeRep" ------------------------------------------------------------------------------@@ -78,7 +87,7 @@ instance Data TyCon where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold"- dataTypeOf _ = mkNorepType "Data.Typeable.TyCon"+ dataTypeOf _ = myMkNoRepType "Data.Typeable.TyCon" ------------------------------------------------------------------------------@@ -88,7 +97,7 @@ instance Data DataType where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold"- dataTypeOf _ = mkNorepType "Data.Generics.Basics.DataType"+ dataTypeOf _ = myMkNoRepType "Data.Generics.Basics.DataType" ------------------------------------------------------------------------------@@ -96,7 +105,7 @@ instance Data Handle where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold"- dataTypeOf _ = mkNorepType "GHC.IOBase.Handle"+ dataTypeOf _ = myMkNoRepType "GHC.IOBase.Handle" ------------------------------------------------------------------------------@@ -104,7 +113,7 @@ instance Typeable a => Data (StablePtr a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold"- dataTypeOf _ = mkNorepType "GHC.Stable.StablePtr"+ dataTypeOf _ = myMkNoRepType "GHC.Stable.StablePtr" ------------------------------------------------------------------------------@@ -113,7 +122,7 @@ instance Data ThreadId where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold"- dataTypeOf _ = mkNorepType "GHC.Conc.ThreadId"+ dataTypeOf _ = myMkNoRepType "GHC.Conc.ThreadId" #endif @@ -125,7 +134,7 @@ instance Typeable a => Data (TVar a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold"- dataTypeOf _ = mkNorepType "GHC.Conc.TVar"+ dataTypeOf _ = myMkNoRepType "GHC.Conc.TVar" #endif @@ -134,7 +143,7 @@ instance Typeable a => Data (MVar a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold"- dataTypeOf _ = mkNorepType "GHC.Conc.MVar"+ dataTypeOf _ = myMkNoRepType "GHC.Conc.MVar" ------------------------------------------------------------------------------@@ -143,7 +152,7 @@ instance Typeable a => Data (STM a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold"- dataTypeOf _ = mkNorepType "GHC.Conc.STM"+ dataTypeOf _ = myMkNoRepType "GHC.Conc.STM" #endif @@ -152,7 +161,7 @@ instance (Typeable s, Typeable a) => Data (ST s a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold"- dataTypeOf _ = mkNorepType "GHC.ST.ST"+ dataTypeOf _ = myMkNoRepType "GHC.ST.ST" ------------------------------------------------------------------------------@@ -160,7 +169,7 @@ instance Typeable a => Data (IORef a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold"- dataTypeOf _ = mkNorepType "GHC.IOBase.IORef"+ dataTypeOf _ = myMkNoRepType "GHC.IOBase.IORef" ------------------------------------------------------------------------------@@ -168,7 +177,7 @@ instance Typeable a => Data (IO a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold"- dataTypeOf _ = mkNorepType "GHC.IOBase.IO"+ dataTypeOf _ = myMkNoRepType "GHC.IOBase.IO" ------------------------------------------------------------------------------ @@ -179,6 +188,6 @@ instance (Data a, Data b) => Data (a -> b) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold"- dataTypeOf _ = mkNorepType "Prelude.(->)"+ dataTypeOf _ = myMkNoRepType "Prelude.(->)" dataCast2 f = gcast2 f
src/Data/Generics/Schemes.hs view
@@ -1,8 +1,12 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Schemes -- Copyright : (c) The University of Glasgow, CWI 2001--2003--- License : BSD-style (see the file libraries/base/LICENSE)+-- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental
src/Data/Generics/Text.hs view
@@ -1,8 +1,10 @@+{-# OPTIONS_GHC -cpp #-}+ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Text -- Copyright : (c) The University of Glasgow, CWI 2001--2003--- License : BSD-style (see the file libraries/base/LICENSE)+-- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental@@ -16,9 +18,12 @@ module Data.Generics.Text ( - gshow,- gread+ -- * Generic show+ gshow, gshows, + -- * Generic read+ gread+ ) where ------------------------------------------------------------------------------@@ -27,7 +32,6 @@ import Prelude #endif import Control.Monad-import Data.Maybe import Data.Data import Data.Generics.Aliases import Text.ParserCombinators.ReadP@@ -37,17 +41,19 @@ -- | Generic show: an alternative to \"deriving Show\" gshow :: Data a => a -> String+gshow x = gshows x "" +-- | Generic shows+gshows :: Data a => a -> ShowS+ -- This is a prefix-show using surrounding "(" and ")", -- where we recurse into subterms with gmapQ.--- -gshow = ( \t ->- "("- ++ showConstr (toConstr t)- ++ concat (gmapQ ((++) " " . gshow) t)- ++ ")"- ) `extQ` (show :: String -> String)-+gshows = ( \t ->+ showChar '('+ . (showString . showConstr . toConstr $ t)+ . (foldr (.) id . gmapQ ((showChar ' ' .) . gshows) $ t)+ . showChar ')'+ ) `extQ` (shows :: String -> ShowS) -- | Generic read: an alternative to \"deriving Read\"@@ -88,7 +94,7 @@ do -- Drop " ( " skipSpaces -- Discard leading space- char '(' -- Parse '('+ _ <- char '(' -- Parse '(' skipSpaces -- Discard following space -- Do the real work@@ -98,7 +104,7 @@ -- Drop " ) " skipSpaces -- Discard leading space- char ')' -- Parse ')'+ _ <- char ')' -- Parse ')' skipSpaces -- Discard following space return x@@ -113,6 +119,7 @@ parseConstr :: ReadP String parseConstr = string "[]" -- Compound lexeme "[]"+ <++ string "()" -- singleton "()" <++ infixOp -- Infix operator in parantheses <++ readS_to_P lex -- Ordinary constructors and literals
src/Data/Generics/Twins.hs view
@@ -1,8 +1,11 @@+{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE Rank2Types #-}+ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Twins -- Copyright : (c) The University of Glasgow, CWI 2001--2004--- License : BSD-style (see the file libraries/base/LICENSE)+-- License : BSD-style (see the LICENSE file) -- -- Maintainer : generics@haskell.org -- Stability : experimental@@ -24,6 +27,7 @@ gmapAccumQl, gmapAccumQr, gmapAccumQ,+ gmapAccumA, -- * Mapping combinators for twin traversal gzipWithT,@@ -49,6 +53,8 @@ import Prelude hiding ( GT ) #endif +import Control.Applicative (Applicative(..))+ ------------------------------------------------------------------------------ @@ -100,6 +106,22 @@ k a (ID c) d = let (a',d') = f a d in (a', ID (c d')) z a x = (a, ID x)+++-- | Applicative version+gmapAccumA :: forall b d a. (Data d, Applicative a)+ => (forall e. Data e => b -> e -> (b, a e))+ -> b -> d -> (b, a d)+gmapAccumA f a0 d0 = gfoldlAccum k z a0 d0+ where+ k :: forall d' e. (Data d') =>+ b -> a (d' -> e) -> d' -> (b, a e)+ k a c d = let (a',d') = f a d+ c' = c <*> d'+ in (a', c')+ z :: forall t c a'. (Applicative a') =>+ t -> c -> (t, a' c)+ z a x = (a, pure x) -- | gmapM with accumulation
+ 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,11 +1,12 @@-name: syb-version: 0.1.0.3-license: BSD3-license-file: LICENSE-author: Ralf Lämmel, Simon Peyton Jones-maintainer: generics@haskell.org-homepage: http://www.cs.uu.nl/wiki/GenericProgramming/SYB-synopsis: Scrap Your Boilerplate+name: syb+version: 0.2+license: BSD3+license-file: LICENSE+author: Ralf Lammel, Simon Peyton Jones+maintainer: generics@haskell.org+homepage: http://www.cs.uu.nl/wiki/GenericProgramming/SYB+bug-reports: http://code.google.com/p/scrapyourboilerplate/issues/list+synopsis: Scrap Your Boilerplate description: This package contains the generics system described in the /Scrap Your Boilerplate/ papers (see <http://www.cs.vu.nl/boilerplate/>).@@ -15,24 +16,37 @@ category: Generics stability: provisional-build-type: Simple-cabal-version: >= 1.2.1+build-type: Custom+cabal-version: >= 1.6 tested-with: GHC == 6.10.4, GHC == 6.12.1 +extra-source-files: tests/*.hs+ Library { hs-source-dirs: src-+ build-depends: base >= 4.0 && < 4.3 exposed-modules: Data.Generics, Data.Generics.Basics, Data.Generics.Instances, Data.Generics.Aliases, Data.Generics.Schemes, Data.Generics.Text,- Data.Generics.Twins+ 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 - build-depends: base >= 4.0 && < 4.3 extensions: CPP, Rank2Types, ScopedTypeVariables+ if impl(ghc < 6.12) ghc-options: -package-name syb+ ghc-options: -Wall }
+ tests/Bits.hs view
@@ -0,0 +1,214 @@+{-# OPTIONS -fglasgow-exts #-}++module Bits (tests) where++{-+ +This test exercices some oldies of generic programming, namely+encoding terms as bit streams and decoding these bit streams in turn+to obtain terms again. (This sort of function might actually be useful+for serialisation and sending companies and other terms over the+internet.)++Here is how it works.++A constuctor is encoded as a bit stream. To this end, we encode the+index of the constructor as a binary number of a fixed length taking+into account the maximum index for the type at hand. (Similarly, we+could view the list of constructors as a binary tree, and then encode+a constructor as the path to the constructor in this tree.) If there+is just a single constructor, as for newtypes, for example, then the+computed bit stream is empty.++Otherwise we just recurse into subterms.++Well, we need to handle basic datatypes in a special way. We observe+such basic datatypes by testing the maximum index to be 0 for the+datatype at hand. An efficient encoding should be tuned per basic+datatype. The following solution is generic, but it wastes space.+That is, we turn the basic value into a string relying on the general+Data API. This string can now be encoded by first converting it into a+list of bit streams at the term level, which can then be easily+encoded as a single bit stream (because lists and bits can be+encoded).++-}++import Test.HUnit++import Data.Generics+import Data.Char+import Maybe+import Monad+import CompanyDatatypes++++-----------------------------------------------------------------------------++++-- | We need bits and bit streams.+data Bit = Zero | One deriving (Show, Eq, Typeable, Data)+type Bin = [Bit]++++-----------------------------------------------------------------------------++++-- Compute length of bit stream for a natural+lengthNat :: Int -> Int+lengthNat x = ceiling (logBase 2 (fromIntegral (x + 1)))+++-- Encode a natural as a bit stream+varNat2bin :: Int -> Bin+varNat2bin 0 = []+varNat2bin x =+ ( ( if even x then Zero else One )+ : varNat2bin (x `div` 2)+ ) +++-- Encode a natural as a bit stream of fixed length+fixedNat2bin :: Int -> Int -> Bin+fixedNat2bin 0 0 = []+fixedNat2bin p x | p>0 =+ ( ( if even x then Zero else One )+ : fixedNat2bin (p - 1) (x `div` 2)+ ) +++-- Decode a natural+bin2nat :: Bin -> Int+bin2nat [] = 0+bin2nat (Zero : bs) = 2 * (bin2nat bs)+bin2nat (One : bs) = 2 * (bin2nat bs) + 1++++-----------------------------------------------------------------------------++++-- | Generically map terms to bit streams+showBin :: Data t => t -> Bin++showBin t+ = if isAlgType myDataType+ then con2bin ++ concat (gmapQ showBin t)+ else showBin base++ where++ -- The datatype for introspection+ myDataType = dataTypeOf t++ -- Obtain the maximum index for the type at hand+ max :: Int+ max = maxConstrIndex myDataType++ -- Obtain the index for the constructor at hand+ idx :: Int+ idx = constrIndex (toConstr t)++ -- Map basic values to strings, then to lists of bit streams+ base = map (varNat2bin . ord) (showConstr (toConstr t))++ -- Map constructors to bit streams of fixed length+ con2bin = fixedNat2bin (lengthNat (max - 1)) (idx - 1)+++-----------------------------------------------------------------------------++++-- | A monad on bit streams+data ReadB a = ReadB (Bin -> (Maybe a, Bin))+unReadB (ReadB f) = f+++-- It's a monad.+instance Monad ReadB where+ return a = ReadB (\bs -> (Just a, bs))+ (ReadB c) >>= f = ReadB (\bs -> case c bs of+ (Just a, bs') -> unReadB (f a) bs'+ (Nothing, bs') -> (Nothing, bs')+ )+++-- It's a bit monad with 0 and +.+instance MonadPlus ReadB where+ mzero = ReadB (\bs -> (Nothing, bs))+ (ReadB f) `mplus` (ReadB g) = ReadB (\bs -> case f bs of+ (Just a, bs') -> (Just a, bs')+ (Nothing, _) -> g bs+ )+++-- Read a few bits+readB :: Int -> ReadB Bin+readB x = ReadB (\bs -> if length bs >= x+ then (Just (take x bs), drop x bs)+ else (Nothing, bs)+ )++++-----------------------------------------------------------------------------++++-- | Generically map bit streams to terms+readBin :: Data t => ReadB t+readBin = result+ where++ -- The worker, which we also use as type argument+ result = if isAlgType myDataType++ then do bin <- readB (lengthNat (max - 1))+ fromConstrM readBin (bin2con bin)++ else do str <- readBin+ con <- str2con (map (chr . bin2nat) str)+ return (fromConstr con)++ -- Determine result type+ myDataType = dataTypeOf (getArg result)+ where+ getArg :: ReadB a -> a+ getArg = undefined++ -- Obtain the maximum index for the type at hand+ max :: Int+ max = maxConstrIndex myDataType++ -- Convert a bit stream into a constructor + bin2con :: Bin -> Constr+ bin2con bin = indexConstr myDataType ((bin2nat bin) + 1)++ -- Convert string to constructor; could fail+ str2con :: String -> ReadB Constr+ str2con = maybe mzero return+ . readConstr myDataType++++-----------------------------------------------------------------------------++++tests = ( showBin True+ , ( showBin [True]+ , ( showBin (1::Int)+ , ( showBin "1"+ , ( showBin genCom+ , ( geq genCom genCom' + )))))) ~=? output+ where+ genCom' = fromJust (fst (unReadB readBin (showBin genCom))) :: Company++output = ([One],([One,One,Zero],([One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero],([One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero],([One,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,Zero,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,One,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,One,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,Zero,Zero],True)))))
+ tests/Builders.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS -fglasgow-exts #-}++module Builders (tests) where++-- Testing Data.Generics.Builders functionality ++import Test.HUnit++import Data.Data+import Data.Generics.Builders+++-- Main function for testing+tests = ( constrs :: [Maybe Int]+ , constrs :: [String]+ , constrs :: [Either Int Float]+ , constrs :: [((), Integer)]+ ) ~=? output++output = ([Nothing,Just 0],["","\NUL"],[Left 0,Right 0.0],[((),0)])
+ tests/CompanyDatatypes.hs view
@@ -0,0 +1,39 @@+{-# OPTIONS -fglasgow-exts #-}++module CompanyDatatypes where++import Data.Generics hiding (Unit)++-- The organisational structure of a company++data Company = C [Dept] deriving (Eq, Show, Typeable, Data)+data Dept = D Name Manager [Unit] deriving (Eq, Show, Typeable, Data)+data Unit = PU Employee | DU Dept deriving (Eq, Show, Typeable, Data)+data Employee = E Person Salary deriving (Eq, Show, Typeable, Data)+data Person = P Name Address deriving (Eq, Show, Typeable, Data)+data Salary = S Float deriving (Eq, Show, Typeable, Data)+type Manager = Employee+type Name = String+type Address = String++-- An illustrative company+genCom :: Company+genCom = C [D "Research" laemmel [PU joost, PU marlow],+ D "Strategy" blair []]++-- A typo for the sake of testing equality;+-- (cf. lammel vs. laemmel)+genCom' :: Company+genCom' = C [D "Research" lammel [PU joost, PU marlow],+ D "Strategy" blair []]++lammel, laemmel, joost, blair :: Employee+lammel = E (P "Lammel" "Amsterdam") (S 8000)+laemmel = E (P "Laemmel" "Amsterdam") (S 8000)+joost = E (P "Joost" "Amsterdam") (S 1000)+marlow = E (P "Marlow" "Cambridge") (S 2000)+blair = E (P "Blair" "London") (S 100000)++-- Some more test data+person1 = P "Lazy" "Home"+dept1 = D "Useless" (E person1 undefined) []
+ tests/Datatype.hs view
@@ -0,0 +1,35 @@+{-# OPTIONS -fglasgow-exts #-}++-- These are simple tests to observe (data)type representations.+module Datatype (tests) where++import Test.HUnit++import Data.Tree+import Data.Generics++-- A simple polymorphic datatype+data Data a =>+ MyDataType a = MyDataType a+ deriving (Typeable, Data)+++-- Some terms and corresponding type representations+myTerm = undefined :: MyDataType Int+myTypeRep = typeOf myTerm -- type representation in Typeable+myTyCon = typeRepTyCon myTypeRep -- type constructor via Typeable+myDataType = dataTypeOf myTerm -- datatype representation in Data+myString1 = tyConString myTyCon -- type constructor via Typeable+myString2 = dataTypeName myDataType -- type constructor via Data++-- Main function for testing+tests = show ( myTypeRep+ , ( myDataType+ , ( tyconModule myString1+ , ( tyconUQname myString1+ , ( tyconModule myString2+ , ( tyconUQname myString2+ ))))))+ ~=? output++output = "(Datatype.MyDataType Int,(DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]},(\"Datatype\",(\"MyDataType\",(\"Datatype\",\"MyDataType\")))))"
+ tests/Encode.hs view
@@ -0,0 +1,81 @@+{-# OPTIONS -fglasgow-exts #-}++-- A bit more test code for the 2nd boilerplate paper.+-- These are downscaled versions of library functionality or real test cases.+-- We just wanted to typecheck the fragments as shown in the paper.++module Encode () where++import Data.Generics++data Bit = Zero | One++------------------------------------------------------------------------------+-- Sec. 3.2++data2bits :: Data a => a -> [Bit]+data2bits t = encodeCon (dataTypeOf t) (toConstr t)+ ++ concat (gmapQ data2bits t)++-- The encoder for constructors+encodeCon :: DataType -> Constr -> [Bit]+encodeCon ty con = natToBin (max-1) (idx-1)+ where+ max = maxConstrIndex ty+ idx = constrIndex con+++natToBin :: Int -> Int -> [Bit]+natToBin = undefined++------------------------------------------------------------------------------+-- Sec. 3.3++data State -- Abstract+initState :: State+encodeCon' :: DataType -> Constr+ -> State -> (State, [Bit])++initState = undefined+encodeCon' = undefined++data2bits' :: Data a => a -> [Bit]+data2bits' t = snd (show_bin t initState)++show_bin :: Data a => a -> State -> (State, [Bit])+show_bin t st = (st2, con_bits ++ args_bits)+ where+ (st1, con_bits) = encodeCon' (dataTypeOf t)+ (toConstr t) st+ (st2, args_bits) = foldr do_arg (st1,[])+ enc_args++ enc_args :: [State -> (State,[Bit])]+ enc_args = gmapQ show_bin t++ do_arg fn (st,bits) = (st', bits' ++ bits)+ where+ (st', bits') = fn st+++------------------------------------------------------------------------------+-- Sec. 3.3 cont'd++data EncM a -- The encoder monad+instance Monad EncM+ where+ return = undefined+ c >>= f = undefined++runEnc :: EncM () -> [Bit]+emitCon :: DataType -> Constr -> EncM ()++runEnc = undefined+emitCon = undefined++data2bits'' :: Data a => a -> [Bit]+data2bits'' t = runEnc (emit t)++emit :: Data a => a -> EncM ()+emit t = do { emitCon (dataTypeOf t) (toConstr t) + ; sequence_ (gmapQ emit t) }
+ tests/Ext.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS -fglasgow-exts #-}++module Ext () where++-- There were typos in these definitions in the ICFP 2004 paper.++import Data.Generics++extQ fn spec_fn arg+ = case gcast (Q spec_fn) of+ Just (Q spec_fn') -> spec_fn' arg+ Nothing -> fn arg+ +newtype Q r a = Q (a -> r)+ +extT fn spec_fn arg+ = case gcast (T spec_fn) of+ Just (T spec_fn') -> spec_fn' arg+ Nothing -> fn arg+ +newtype T a = T (a -> a)++extM :: (Typeable a, Typeable b)+ => (a -> m a) -> (b -> m b) -> (a -> m a)+extM fn spec_fn+ = case gcast (M spec_fn) of+ Just (M spec_fn') -> spec_fn'+ Nothing -> fn++newtype M m a = M (a -> m a)
+ tests/Ext1.hs view
@@ -0,0 +1,124 @@+{-# OPTIONS -fglasgow-exts #-}++module Ext1 (tests) where++{-++This example records some experiments with polymorphic datatypes.++-}++import Test.HUnit++import Data.Generics+import GHC.Base+++-- Unsafe coerce+unsafeCoerce :: a -> b+unsafeCoerce = unsafeCoerce#+++-- Handy type constructors+newtype ID x = ID { unID :: x }+newtype CONST c a = CONST { unCONST :: c }+++-- Extension of a query with a para. poly. list case+extListQ' :: Data d+ => (d -> q)+ -> (forall d. [d] -> q)+ -> d -> q+extListQ' def ext d =+ if isList d+ then ext (unsafeCoerce d)+ else def d +++-- Test extListQ'+foo1 :: Data d => d -> Int+foo1 = const 0 `extListQ'` length+t1 = foo1 True -- should count as 0+t2 = foo1 [True,True] -- should count as 2+++-- Infeasible extension of a query with a data-polymorphic list case+extListQ'' :: Data d+ => (d -> q)+ -> (forall d. Data d => [d] -> q)+ -> d -> q+extListQ'' def ext d =+ if isList d+ then undefined -- hard to avoid an ambiguous type+ else def d +++-- Test extListQ from Data.Generics.Aliases+foo2 :: Data a => a -> Int+foo2 = const 0 `ext1Q` list+ where+ list :: Data a => [a] -> Int+ list l = foldr (+) 0 $ map glength l++t3 = foo2 (True,True) -- should count as 0+t4 = foo2 [(True,True),(True,True)] -- should count as 2+2=4+++-- Customisation for lists without type cast+foo3 :: Data a => a -> Int+foo3 x = if isList x+ then foldr (+) 0 $ gmapListQ glength x+ else 0++t5 = foo3 (True,True) -- should count as 0+t6 = foo3 [(True,True),(True,True)] -- should count as 2+2=4+++-- Test for list datatype+isList :: Data a => a -> Bool+isList x = typeRepTyCon (typeOf x) ==+ typeRepTyCon (typeOf (undefined::[()]))+++-- Test for nil+isNil :: Data a => a -> Bool+isNil x = toConstr x == toConstr ([]::[()])+++-- Test for cons+isCons :: Data a => a -> Bool+isCons x = toConstr x == toConstr (():[])+++-- gmapQ for polymorphic lists+gmapListQ :: forall a q. Data a => (forall a. Data a => a -> q) -> a -> [q]+gmapListQ f x =+ if not $ isList x + then error "gmapListQ"+ else if isNil x+ then []+ else if isCons x+ then ( gmapQi 0 f x : gmapQi 1 (gmapListQ f) x )+ else error "gmapListQ"+++-- Build nil+mkNil :: Data a => a+mkNil = fromConstr $ toConstr ([]::[()])+++-- Build cons+mkCons :: Data a => a+mkCons = fromConstr $ toConstr ((undefined:undefined)::[()])+++-- Main function for testing+tests = ( t1+ , ( t2+ , ( t3+ , ( t4+ , ( t5+ , ( t6+ )))))) ~=? output++output = (0,(2,(0,(4,(0,4)))))
+ tests/FoldTree.hs view
@@ -0,0 +1,63 @@+{-# OPTIONS -fglasgow-exts #-}++{-++A very, very simple example: "extract all Ints from a tree of Ints".+The text book approach is to write a generalised fold for that. One+can also turn the Tree datatype into functorial style and then write a+Functor instance for the functorial datatype including a definition of+fmap. (The original Tree datatype can be related to the functorial+version by the usual injection and projection.)++You can scrap all such boilerplate by using a traversal scheme based+on gmap combinators as illustrated below. To get it a little more+interesting, we use a datatype Tree with not just a case for leafs and+fork trees, but we also add a case for trees with a weight.++For completeness' sake, we mention that the fmap/generalised fold+approach differs from the gmap approach in some details. Most notably,+the gmap approach does not generally facilitate the identification of+term components that relate to the type parameter of a parameterised+datatype. The consequence of this is illustrated below as well.+Sec. 6.3 in "Scrap Your Boilerplate ..." discusses such `type+distinctions' as well.++-}++module FoldTree (tests) where++import Test.HUnit++-- Enable "ScrapYourBoilerplate"+import Data.Generics+++-- A parameterised datatype for binary trees with data at the leafs+data (Data a, Data w) =>+ Tree a w = Leaf a+ | Fork (Tree a w) (Tree a w)+ | WithWeight (Tree a w) w + deriving (Typeable, Data)+++-- A typical tree+mytree :: Tree Int Int+mytree = Fork (WithWeight (Leaf 42) 1)+ (WithWeight (Fork (Leaf 88) (Leaf 37)) 2)+++-- 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.+-- +tests = show ( listify (\(_::Int) -> True) mytree+ , everything (++) ([] `mkQ` fromLeaf) mytree+ ) ~=? output+ where+ fromLeaf :: Tree Int Int -> [Int]+ fromLeaf (Leaf x) = [x]+ fromLeaf _ = []++output = "([42,1,88,37,2],[42,88,37])"
+ tests/FreeNames.hs view
@@ -0,0 +1,120 @@+{-# OPTIONS -fglasgow-exts #-}++module FreeNames (tests) where++{-++This example illustrates the kind of traversals that naturally show up+in language processing. That is, the free names (say, variables) are+derived for a given program fragment. To this end, we need several+worker functions that extract declaring and referencing occurrences+from given program fragments; see "decsExpr", "decsEqua",+etc. below. Then, we need a traversal "freeNames" that traverses over+the program fragment in a bottom-up manner so that free names from+subterms do not escape to the top when corresponding declarations are+provided. The "freeNames" algorithm uses set operations "union" and+"//" to compute sets of free names from the declared and referenced+names of the root term and free names of the immediate subterms.++Contributed by Ralf Laemmel, ralf@cwi.nl++-}++import Test.HUnit++import Data.Generics+import Data.List++data System = S [Function] deriving (Typeable, Data)++data Function = F Name [Equation] deriving (Typeable, Data)++data Equation = E [Pattern] Expression System deriving (Typeable, Data)++data Pattern = PVar Name+ | PTerm Name [Pattern] deriving (Typeable, Data)++data Expression = Var Name+ | App Expression Expression+ | Lambda Name Expression deriving (Typeable, Data)++type Name = String++-- A little sample program++sys1 = S [f1,f2]+f1 = F "f1" [e11]+f2 = F "f2" [e21,e22]+e11 = E [] (Var "id") (S [])+e21 = E [ PTerm "C" [ PVar "x" ] ] (Var "x") (S [])+e22 = E [] (Var "id") (S [])+++-- Names declared in an expression+decsExpr :: Expression -> [Name]+decsExpr (Lambda n _) = [n]+decsExpr _ = []++-- Names declared in an equation+decsEqua :: Equation -> [Name]+decsEqua (E ps _ _) = everything union ([] `mkQ` pvar) ps+ where+ pvar (PVar n) = [n]+ pvar _ = []++-- Names declared in a system+decsSyst :: System -> [Name]+decsSyst (S l) = nub $ map (\(F n _) -> n) l++-- Names referenced in an expression+refsExpr :: Expression -> [Name]+refsExpr (Var n) = [n]++-- Names referenced in an equation+refsEqua :: Equation -> [Name]+refsEqua (E ps _ _) = everything union ([] `mkQ` pterm) ps+ where+ pterm (PTerm n _) = [n]+ pterm _ = []++-- Combine the above type-specific cases to obtain+-- generic functions that find declared and referenced names+--+decsFun :: Data a => a -> [Name]+decsFun = const [] `extQ` decsExpr `extQ` decsEqua `extQ` decsSyst++refsFun :: Data a => a -> [Name]+refsFun = const [] `extQ` refsExpr `extQ` refsEqua++++{-++Free name analysis: Take the union of free names obtained from the+immediate subterms (via gmapQ) and the names being referred to at the+root of the present term, but subtract all the names that are declared+at the root.++-}+ +freeNames :: Data a => a -> [Name]+freeNames x = ( (refsFun x)+ `union`+ (nub . concat . gmapQ freeNames) x+ )+ \\+ decsFun x++{-++Print the free names for the sample program sys1; see module+FunDatatypes.hs. This should print the list ["id","C"] because the+"Prelude" function "id" is used in the sample program, and also the+term constructor "C" occurs in a pattern; we assume a language without+explicit datatype declarations ;-)++-}++tests = freeNames sys1 ~=? output++output = ["id","C"]
+ tests/GEq.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS -fglasgow-exts #-}++module GEq (tests) where++{-++This test exercices GENERIC read, show, and eq for the company+datatypes which we use a lot. The output of the program should be+"True" which means that "gread" reads what "gshow" shows while the+read term is equal to the original term in terms of "geq".++-}++import Test.HUnit++import Data.Generics+import CompanyDatatypes++tests = ( geq genCom genCom+ , geq genCom genCom'+ ) ~=? (True,False)
+ tests/GMapQAssoc.hs view
@@ -0,0 +1,68 @@+{-# OPTIONS -fglasgow-exts #-}++module GMapQAssoc (tests) where++{-++This example demonstrates the inadequacy of an apparently simpler+variation on gmapQ. To this end, let us first recall a few facts.+Firstly, function application (including constructor application) is+left-associative. This is the reason why we had preferred our generic+fold to be left-associative too. (In "The Sketch Of a Polymorphic+Symphony" you can find a right-associative generic fold.) Secondly,+lists are right-associative. Because of these inverse associativities+queries for the synthesis of lists require some extra effort to+reflect the left-to-right of immediate subterms in the queried list.+In the module Data.Generics, we solve the problem by a common+higher-order trick, that is, we do not cons lists during folding but+we pass functions on lists starting from the identity function and+passing [] to the resulting function. The following example+illustrates that we get indeed an undesirable right-to-left order if+we just apply the simple constant datatype constructor CONST instead+of the higher-order trick.++Contributed by Ralf Laemmel, ralf@cwi.nl++-}++import Test.HUnit++import Data.Generics+++-- The plain constant type constructor+newtype CONST x y = CONST x+unCONST (CONST x) = x+++-- A variation on the gmapQ combinator using CONST and not Q+gmapQ' :: Data a => (forall a. Data a => a -> u) -> a -> [u]+gmapQ' f = unCONST . gfoldl f' z+ where+ f' r a = CONST (f a : unCONST r)+ z = const (CONST [])+++-- A trivial datatype used for this test case+data IntTree = Leaf Int | Fork IntTree IntTree+ deriving (Typeable, Data)+++-- Select int if faced with a leaf +leaf (Leaf i) = [i]+leaf _ = []+++-- A test term+term = Fork (Leaf 1) (Leaf 2)+++-- Process test term+-- gmapQ gives left-to-right order+-- gmapQ' gives right-to-left order+--+tests = show ( gmapQ ([] `mkQ` leaf) term+ , gmapQ' ([] `mkQ` leaf) term+ ) ~=? output++output = show ([[1],[2]],[[2],[1]])
+ tests/GShow.hs view
@@ -0,0 +1,52 @@+{-# OPTIONS -fglasgow-exts #-}+ +module GShow (tests) where++{-+ +The generic show example from the 2nd boilerplate paper.+(There were some typos in the ICFP 2004 paper.)+Also check out Data.Generics.Text.+ +-}++import Test.HUnit++import Data.Generics hiding (gshow)+import Prelude hiding (showString)++ +gshow :: Data a => a -> String+gshow = gshow_help `extQ` showString++gshow_help :: Data a => a -> String+gshow_help t + = "("+ ++ showConstr (toConstr t)+ ++ concat (intersperse " " (gmapQ gshow t))+ ++ ")"++showString :: String -> String+showString s = "\"" ++ concat (map escape s) ++ "\"" + where+ escape '\n' = "\\n"+ escape other_char = [other_char]++gshowList :: Data b => [b] -> String+gshowList xs+ = "[" ++ concat (intersperse "," (map gshow xs)) ++ "]"++gshow' :: Data a => a -> String+gshow' = gshow_help `ext1Q` gshowList + `extQ` showString++intersperse :: a -> [a] -> [a]+intersperse _ [] = []+intersperse x [e] = [e]+intersperse x (e:es) = (e:(x:intersperse x es))++tests = ( gshow' "foo"+ , gshow' [True,False]+ ) ~=? output++output = ("\"foo\"","[(True),(False)]")
+ tests/GShow2.hs view
@@ -0,0 +1,47 @@+{-# OPTIONS -fglasgow-exts #-}++module GShow2 (tests) where++{-++This test exercices GENERIC show for the infamous company datatypes. The+output of the program should be some representation of the infamous+"genCom" company.++-}++import Test.HUnit++import Data.Generics+import CompanyDatatypes++tests = gshow genCom ~=? output++{-++Here is another exercise:+The following function gshow' is a completely generic variation on gshow.+It would print strings as follows:++*Main> gshow' "abc"+"((:) ('a') ((:) ('b') ((:) ('c') ([]))))"++The original gshow does a better job because it is customised for strings:++*Main> gshow "foo"+"\"foo\""++In fact, this is what Haskell's normal show would also do:++*Main> show "foo"+"\"foo\""++-}++gshow' :: Data a => a -> String+gshow' t = "("+ ++ showConstr (toConstr t)+ ++ concat (gmapQ ((++) " " . gshow') t)+ ++ ")"++output = "(C ((:) (D \"Research\" (E (P \"Laemmel\" \"Amsterdam\") (S (8000.0))) ((:) (PU (E (P \"Joost\" \"Amsterdam\") (S (1000.0)))) ((:) (PU (E (P \"Marlow\" \"Cambridge\") (S (2000.0)))) ([])))) ((:) (D \"Strategy\" (E (P \"Blair\" \"London\") (S (100000.0))) ([])) ([]))))"
+ tests/GZip.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS -fglasgow-exts #-}++module GZip (tests) where++{-++This test illustrates zipping for the company datatypes which we use a+lot. We process two companies that happen to agree on the overall+shape but differ in the salaries in a few positions. So whenever we+encounter salaries we take the maximum of the two.++-}++import Test.HUnit++import Data.Generics+import CompanyDatatypes++-- The main function which prints the result of zipping+tests = gzip (\x y -> mkTT maxS x y) genCom1 genCom2 ~=? output+ -- NB: the argument has to be eta-expanded to match+ -- the type of gzip's argument type, which is+ -- GenericQ (GenericM Maybe)+ where++ -- Variations on the show case company "genCom"+ genCom1 = everywhere (mkT (double "Joost")) genCom+ genCom2 = everywhere (mkT (double "Marlow")) genCom+ double x (E p@(P y _) (S s)) | x == y = E p (S (2*s))+ double _ e = e++ -- Sum up two salaries+ maxS (S x) (S y) = S (max x y)++ -- Make a two-arguments, generic function transformer+ mkTT :: (Typeable a, Typeable b, Typeable c)+ => (a -> a -> a) -> b -> c -> Maybe c+ mkTT (f::a -> a -> a) x y =+ case (cast x,cast y) of+ (Just (x'::a),Just (y'::a)) -> cast (f x' y')+ _ -> Nothing++output = Just (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) + [PU (E (P "Joost" "Amsterdam") (S 2000.0))+ ,PU (E (P "Marlow" "Cambridge") (S 4000.0))]+ ,D "Strategy" (E (P "Blair" "London") (S 100000.0)) []])
+ tests/GenUpTo.hs view
@@ -0,0 +1,94 @@+{-# OPTIONS -fglasgow-exts #-}++module GenUpTo (tests) where++{-++This example illustrate test-set generation,+namely all terms of a given depth are generated.++-}++import Test.HUnit++import Data.Generics+++{-++The following datatypes comprise the abstract syntax of a simple+imperative language. Some provisions are such that the discussion+of test-set generation is simplified. In particular, we do not +consider anything but monomorphic *data*types --- no primitive+types, no tuples, ...++-}+ +data Prog = Prog Dec Stat + deriving (Show, Eq, Typeable, Data)++data Dec = Nodec+ | Ondec Id Type + | Manydecs Dec Dec+ deriving (Show, Eq, Typeable, Data)++data Id = A | B+ deriving (Show, Eq, Typeable, Data)++data Type = Int | Bool+ deriving (Show, Eq, Typeable, Data)++data Stat = Noop+ | Assign Id Exp+ | Seq Stat Stat+ deriving (Show, Eq, Typeable, Data)++data Exp = Zero + | Succ Exp+ deriving (Show, Eq, Typeable, Data)+++-- Generate all terms of a given depth+genUpTo :: Data a => Int -> [a]+genUpTo 0 = []+genUpTo d = result+ where+ -- Getting hold of the result (type)+ result = concat (map recurse cons)++ -- Retrieve constructors of the requested type+ cons :: [Constr]+ cons = dataTypeConstrs (dataTypeOf (head result))++ -- Find all terms headed by a specific Constr+ recurse :: Data a => Constr -> [a]+ recurse con = gmapM (\_ -> genUpTo (d-1)) + (fromConstr con)++ -- We could also deal with primitive types easily.+ -- Then we had to use cons' instead of cons.+ --+ cons' :: [Constr]+ cons' = case dataTypeRep ty of+ AlgRep cons -> cons+ IntRep -> [mkIntegralConstr ty 0]+ FloatRep -> [mkIntegralConstr ty 0]+ CharRep -> [mkCharConstr ty 'x']+ where+ ty = dataTypeOf (head result) +++-- For silly tests+data T0 = T0 T1 T2 T3 deriving (Show, Eq, Typeable, Data)+data T1 = T1a | T1b deriving (Show, Eq, Typeable, Data)+data T2 = T2a | T2b deriving (Show, Eq, Typeable, Data)+data T3 = T3a | T3b deriving (Show, Eq, Typeable, Data)++tests = ( genUpTo 0 :: [Id]+ , ( genUpTo 1 :: [Id]+ , ( genUpTo 2 :: [Id]+ , ( genUpTo 2 :: [T0]+ , ( genUpTo 3 :: [Prog]+ ))))) ~=? output++output = ([],([A,B],([A,B],([T0 T1a T2a T3a,T0 T1a T2a T3b,T0 T1a T2b T3a,T0 T1a T2b T3b,T0 T1b T2a T3a,T0 T1b T2a T3b,T0 T1b T2b T3a,T0 T1b T2b T3b],[Prog Nodec Noop,Prog Nodec (Assign A Zero),Prog Nodec (Assign B Zero),Prog Nodec (Seq Noop Noop),Prog (Ondec A Int) Noop,Prog (Ondec A Int) (Assign A Zero),Prog (Ondec A Int) (Assign B Zero),Prog (Ondec A Int) (Seq Noop Noop),Prog (Ondec A Bool) Noop,Prog (Ondec A Bool) (Assign A Zero),Prog (Ondec A Bool) (Assign B Zero),Prog (Ondec A Bool) (Seq Noop Noop),Prog (Ondec B Int) Noop,Prog (Ondec B Int) (Assign A Zero),Prog (Ondec B Int) (Assign B Zero),Prog (Ondec B Int) (Seq Noop Noop),Prog (Ondec B Bool) Noop,Prog (Ondec B Bool) (Assign A Zero),Prog (Ondec B Bool) (Assign B Zero),Prog (Ondec B Bool) (Seq Noop Noop),Prog (Manydecs Nodec Nodec) Noop,Prog (Manydecs Nodec Nodec) (Assign A Zero),Prog (Manydecs Nodec Nodec) (Assign B Zero),Prog (Manydecs Nodec Nodec) (Seq Noop Noop)]))))
+ tests/GetC.hs view
@@ -0,0 +1,121 @@+{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE OverlappingInstances, UndecidableInstances #-}++module GetC (tests) where++import Test.HUnit++{-++Ralf Laemmel, 5 November 2004 ++Joe Stoy suggested the idiom to test for the outermost constructor.++Given is a term t+and a constructor f (say the empty constructor application).++isC f t returns True if the outermost constructor of t is f.+isC f t returns False otherwise.+Modulo type checking, i.e., the data type of f and t must be the same.+If not, we want to see a type error, of course.++-}++import Data.Typeable -- to cast t's subterms, which will be reused for f.+import Data.Generics -- to access t's subterms and constructors.+++-- Some silly data types+data T1 = T1a Int String | T1b String Int deriving (Typeable, Data)+data T2 = T2a Int Int | T2b String String deriving (Typeable, Data)+data T3 = T3! Int deriving (Typeable, Data)+++-- Test cases+tests = show [ isC T1a (T1a 1 "foo") -- typechecks, returns True+ , isC T1a (T1b "foo" 1) -- typechecks, returns False+ , isC T3 (T3 42)] -- works for strict data too+ ~=? output+-- err = show $ isC T2b (T1b "foo" 1) -- must not typecheck++output = show [True,False,True]++--+-- We look at a datum a.+-- We look at a constructor function f.+-- The class GetT checks that f constructs data of type a.+-- The class GetC computes maybe the constructor ...+-- ... if the subterms of the datum at hand fit for f.+-- Finally we compare the constructors.+-- ++isC :: (Data a, GetT f a, GetC f) => f -> a -> Bool+isC f t = maybe False ((==) (toConstr t)) con+ where+ kids = gmapQ ExTypeable t -- homogenify subterms in list for reuse+ con = getC f kids -- compute constructor from constructor application+++--+-- We prepare for a list of kids using existential envelopes.+-- We could also just operate on TypeReps for non-strict datatypes.+-- ++data ExTypeable = forall a. Typeable a => ExTypeable a+unExTypeable (ExTypeable a) = cast a+++-- +-- Compute the result type of a function type.+-- Beware: the TypeUnify constraint causes headache.+-- We can't have GetT t t because the FD will be violated then.+-- We can't omit the FD because unresolvable overlapping will hold then. +-- ++class GetT f t | f -> t -- FD is optional+instance GetT g t => GetT (x -> g) t+instance TypeUnify t t' => GetT t t'+++--+-- Obtain the constructor if term can be completed+-- ++class GetC f+ where+ getC :: f -> [ExTypeable] -> Maybe Constr++instance (Typeable x, GetC g) => GetC (x -> g)+ where+ getC _ [] = Nothing+ getC (f::x->g) (h:t)+ =+ do+ (x::x) <- unExTypeable h+ getC (f x) t++instance Data t => GetC t+ where+ getC y [] = Just $ toConstr y+ getC _ (_:_) = Nothing+++--+-- Type unification; we could try this:+-- class TypeUnify a b | a -> b, b -> a+-- instance TypeUnify a a+-- +-- However, if the instance is placed in the present module,+-- then type improvement would inline this instance. Sigh!!!+--+-- So we need type unification with type improvement blocker+-- The following solution works with GHC for ages.+-- Other solutions; see the HList paper.+--++class TypeUnify a b | a -> b, b -> a+class TypeUnify' x a b | x a -> b, x b -> a +class TypeUnify'' x a b | x a -> b, x b -> a +instance TypeUnify' () a b => TypeUnify a b+instance TypeUnify'' x a b => TypeUnify' x a b+instance TypeUnify'' () a a
+ tests/Gread.hs view
@@ -0,0 +1,45 @@+{-# OPTIONS -fglasgow-exts #-}++module GRead (tests) where++{-++The following examples achieve branch coverage for the various+productions in the definition of gread. Also, negative test cases are+provided; see str2 and str3. Also, the potential of heading or+trailing spaces as well incomplete parsing of the input is exercised;+see str5.++-}++import Test.HUnit++import Data.Generics++str1 = "(True)" -- reads fine as a Bool+str2 = "(Treu)" -- invalid constructor+str3 = "True" -- lacks parentheses+str4 = "(1)" -- could be an Int+str5 = "( 2 ) ..." -- could be an Int with some trailing left-over+str6 = "([])" -- test empty list+str7 = "((:)" ++ " " ++ str4 ++ " " ++ str6 ++ ")" ++tests = show ( ( [ gread str1,+ gread str2,+ gread str3+ ]+ , [ gread str4,+ gread str5+ ]+ , [ gread str6,+ gread str7+ ]+ )+ :: ( [[(Bool, String)]]+ , [[(Int, String)]]+ , [[([Int], String)]]+ ) + ) ~=? output++output = show + ([[(True,"")],[],[]],[[(1,"")],[(2,"...")]],[[([],"")],[([1],"")]])
+ tests/Gread2.hs view
@@ -0,0 +1,66 @@+{-# OPTIONS -fglasgow-exts #-}++module GRead2 () where++{-++For the discussion in the 2nd boilerplate paper,+we favour some simplified generic read, which is checked to compile.+For the full/real story see Data.Generics.Text.++-}++import Data.Generics++gread :: Data a => String -> Maybe a+gread input = runDec input readM++-- The decoder monad+newtype DecM a = D (String -> Maybe (String, a))++instance Monad DecM where+ return a = D (\s -> Just (s,a))+ (D m) >>= k = D (\s ->+ case m s of+ Nothing -> Nothing+ Just (s1,a) -> let D n = k a+ in n s1)+ +runDec :: String -> DecM a -> Maybe a+runDec input (D m) = do (_,x) <- m input+ return x++parseConstr :: DataType -> DecM Constr+parseConstr ty = D (\s ->+ match s (dataTypeConstrs ty))+ where+ match :: String -> [Constr]+ -> Maybe (String, Constr)+ match _ [] = Nothing+ match input (con:cons)+ | take n input == showConstr con+ = Just (drop n input, con)+ | otherwise+ = match input cons+ where+ n = length (showConstr con)+++readM :: forall a. Data a => DecM a+readM = read+ where+ read :: DecM a+ read = do { let val = argOf read+ ; let ty = dataTypeOf val+ ; constr <- parseConstr ty+ ; let con::a = fromConstr constr+ ; gmapM (\_ -> readM) con }++argOf :: c a -> a+argOf = undefined++yareadM :: forall a. Data a => DecM a+yareadM = do { let ty = dataTypeOf (undefined::a)+ ; constr <- parseConstr ty+ ; let con::a = fromConstr constr+ ; gmapM (\_ -> yareadM) con }
+ tests/HList.hs view
@@ -0,0 +1,62 @@+{-# OPTIONS -fglasgow-exts #-}++module HList (tests) where++{-++This module illustrates heterogeneously typed lists.++-}++import Test.HUnit++import Data.Typeable+++-- Heterogeneously typed lists+type HList = [DontKnow]++data DontKnow = forall a. Typeable a => DontKnow a ++-- The empty list+initHList :: HList+initHList = []++-- Add an entry+addHList :: Typeable a => a -> HList -> HList+addHList a l = (DontKnow a:l)++-- Test for an empty list+nullHList :: HList -> Bool+nullHList = null++-- Retrieve head by type case+headHList :: Typeable a => HList -> Maybe a+headHList [] = Nothing+headHList (DontKnow a:_) = cast a++-- Retrieve tail by type case+tailHList :: HList -> HList+tailHList = tail++-- Access per index; starts at 1+nth1HList :: Typeable a => Int -> HList -> Maybe a+nth1HList i l = case (l !! (i-1)) of (DontKnow a) -> cast a+++----------------------------------------------------------------------------++-- A demo list+mylist = addHList (1::Int) $+ addHList (True::Bool) $+ addHList ("42"::String) $+ initHList++-- Main function for testing+tests = ( show (nth1HList 1 mylist :: Maybe Int) -- shows Just 1+ , ( show (nth1HList 1 mylist :: Maybe Bool) -- shows Nothing+ , ( show (nth1HList 2 mylist :: Maybe Bool) -- shows Just True+ , ( show (nth1HList 3 mylist :: Maybe String) -- shows Just "42"+ )))) ~=? output++output = ("Just 1",("Nothing",("Just True","Just \"42\"")))
+ tests/HOPat.hs view
@@ -0,0 +1,67 @@+{-# OPTIONS -fglasgow-exts #-}++module HOPat (tests) where++{-++This module is in reply to an email by C. Barry Jay+received on March 15, and handled within hours. CBJ+raises the very interesting issue of higher-order patterns.+It turns out that some form of it is readily covered in+our setting.++-}++import Test.HUnit++import Data.Generics+++-- Sample datatypes+data T1 = T1a Int | T1b Float+ deriving (Show, Eq, Typeable, Data)+data T2 = T2a T1 T2 | T2b+ deriving (Show, Eq, Typeable, Data)++-- Eliminate a constructor if feasible+elim' :: (Data y, Data x) => Constr -> y -> Maybe x+elim' c y = if toConstr y == c+ then unwrap y+ else Nothing+++-- Unwrap a term; Return its single component+unwrap :: (Data y, Data x) => y -> Maybe x +unwrap y = case gmapQ (Nothing `mkQ` Just) y of+ [Just x] -> Just x+ _ -> Nothing+++-- Eliminate a constructor if feasible; 2nd try+elim :: forall x y. (Data y, Data x) => (x -> y) -> y -> Maybe x+elim c y = elim' (toConstr (c (undefined::x))) y+++-- Visit a data structure+visitor :: (Data x, Data y, Data z)+ => (x -> y) -> (x -> x) -> z -> z+visitor c f = everywhere (mkT g)+ where+ g y = case elim c y of+ Just x -> c (f x) + Nothing -> y+++-- Main function for testing+tests = ( ( elim' (toConstr t1a) t1a) :: Maybe Int+ , ( (elim' (toConstr t1a) t1b) :: Maybe Int+ , ( (elim T1a t1a) :: Maybe Int+ , ( (elim T1a t1b) :: Maybe Int+ , ( (visitor T1a ((+) 46) t2) :: T2+ ))))) ~=? output+ where+ t1a = T1a 42+ t1b = T1b 3.14+ t2 = T2a t1a (T2a t1a T2b)++output = (Just 42,(Nothing,(Just 42,(Nothing,T2a (T1a 88) (T2a (T1a 88) T2b)))))
+ tests/Labels.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS -fglasgow-exts #-}++module Labels (tests) where++-- This module tests availability of field labels.++import Test.HUnit++import Data.Generics++-- A datatype without labels+data NoLabels = NoLabels Int Float+ deriving (Typeable, Data)++-- A datatype with labels+data YesLabels = YesLabels { myint :: Int+ , myfloat :: Float+ }+ deriving (Typeable, Data)++-- Test terms+noLabels = NoLabels 42 3.14+yesLabels = YesLabels 42 3.14++-- Main function for testing+tests = ( constrFields $ toConstr noLabels+ , constrFields $ toConstr yesLabels+ ) ~=? output++output = ([],["myint","myfloat"])
+ tests/LocalQuantors.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS -fglasgow-exts #-}++module LocalQuantors () where++-- A datatype with a locally quantified component+-- Seems to be too polymorphic to descend into structure!+-- Largely irrelevant?!++import Data.Generics++data Test = Test (GenericT) deriving Typeable++instance Data Test+ where+ gfoldl _ z x = z x -- folding without descent + toConstr (Test _) = testConstr+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = testDataType++testConstr = mkConstr testDataType "Test" [] Prefix+testDataType = mkDataType "Main.Test" [testConstr]
+ tests/Main.hs view
@@ -0,0 +1,82 @@++module Main where++import Test.HUnit+import System.Exit++import qualified Bits+import qualified Builders+import qualified Datatype+import qualified Ext1+import qualified FoldTree+import qualified FreeNames+import qualified GEq+import qualified GMapQAssoc+import qualified GRead+import qualified GShow+import qualified GShow2+import qualified GZip+import qualified GenUpTo+import qualified GetC+import qualified HList+import qualified HOPat+import qualified Labels+import qualified Newtype+import qualified Paradise+import qualified Perm+import qualified Reify+import qualified Strings+import qualified Tree+import qualified Twin+import qualified Typeable+import qualified Typecase1+import qualified Typecase2+import qualified Where+import qualified XML++import qualified Encode -- no tests, should compile+import qualified Ext -- no tests, should compile+import qualified GRead2 -- no tests, should compile+import qualified LocalQuantors -- no tests, should compile+import qualified NestedDatatypes -- no tests, should compile+import qualified Polymatch -- no tests, should compile+++tests =+ "All" ~: [ Datatype.tests+ , FoldTree.tests+ , GetC.tests+ , GMapQAssoc.tests+ , GRead.tests+ , GShow.tests+ , GShow2.tests+ , HList.tests+ , HOPat.tests+ , Labels.tests+ , Newtype.tests+ , Perm.tests+ , Twin.tests+ , Typeable.tests+ , Typecase1.tests+ , Typecase2.tests+ , Where.tests+ , XML.tests+ , Tree.tests+ , Strings.tests+ , Reify.tests+ , Paradise.tests+ , GZip.tests+ , GEq.tests+ , GenUpTo.tests+ , FreeNames.tests+ , Ext1.tests+ , Bits.tests+ , Builders.tests+ ]++main = do+ putStrLn "Running tests for syb..."+ counts <- runTestTT tests+ if (failures counts > 0)+ then exitFailure+ else exitSuccess
+ tests/NestedDatatypes.hs view
@@ -0,0 +1,52 @@+{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE UndecidableInstances #-}++module NestedDatatypes () where++{-++We provide an illustrative ScrapYourBoilerplate example for a nested+datatype. For clarity, we do not derive the Typeable and Data+instances by the deriving mechanism but we show the intended+definitions. The overall conclusion is that nested datatypes do not+pose any challenge for the ScrapYourBoilerplate scheme. Well, this is+maybe not quite true because it seems like we need to allow+undecidable instances.++-}++import Data.Dynamic+import Data.Generics++ +-- A nested datatype+data Nest a = Box a | Wrap (Nest [a])+++-- The representation of the type constructor +nestTc = mkTyCon "Nest"+++-- The Typeable instance for the nested datatype +instance Typeable1 Nest+ where+ typeOf1 n = mkTyConApp nestTc []+++-- The Data instance for the nested datatype+instance (Data a, Data [a]) => Data (Nest a)+ where+ gfoldl k z (Box a) = z Box `k` a+ gfoldl k z (Wrap w) = z Wrap `k` w+ gmapT f (Box a) = Box (f a)+ gmapT f (Wrap w) = Wrap (f w)+ toConstr (Box _) = boxConstr+ toConstr (Wrap _) = wrapConstr+ gunfold k z c = case constrIndex c of+ 1 -> k (z Box)+ 2 -> k (z Wrap)+ dataTypeOf _ = nestDataType++boxConstr = mkConstr nestDataType "Box" [] Prefix+wrapConstr = mkConstr nestDataType "Wrap" [] Prefix+nestDataType = mkDataType "Main.Nest" [boxConstr,wrapConstr]
+ tests/Newtype.hs view
@@ -0,0 +1,15 @@+{-# OPTIONS -fglasgow-exts #-}++module Newtype (tests) where++-- The type of a newtype should treat the newtype as opaque++import Test.HUnit++import Data.Generics++newtype T = MkT Int deriving( Typeable )++tests = show (typeOf (undefined :: T)) ~=? output++output = "Newtype.T"
+ tests/Paradise.hs view
@@ -0,0 +1,29 @@+{-# OPTIONS -fglasgow-exts #-}++module Paradise (tests) where++{-++This test runs the infamous PARADISE benchmark,+which is the HELLO WORLD example of generic programming,+i.e., the "increase salary" function is applied to+a typical company just as shown in the boilerplate paper.++-}++import Test.HUnit++import Data.Generics+import CompanyDatatypes++-- Increase salary by percentage+increase :: Float -> Company -> Company+increase k = everywhere (mkT (incS k))++-- "interesting" code for increase+incS :: Float -> Salary -> Salary+incS k (S s) = S (s * (1+k))++tests = increase 0.1 genCom ~=? output++output = C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8800.0)) [PU (E (P "Joost" "Amsterdam") (S 1100.0)),PU (E (P "Marlow" "Cambridge") (S 2200.0))],D "Strategy" (E (P "Blair" "London") (S 110000.0)) []]
+ tests/Perm.hs view
@@ -0,0 +1,127 @@+{-# OPTIONS -fglasgow-exts #-}++module Perm (tests) where++{-++This module illustrates permutation phrases.+Disclaimer: this is a perhaps naive, certainly undebugged example.++-}++import Test.HUnit++import Control.Monad+import Data.Generics++---------------------------------------------------------------------------+-- We want to read terms of type T3 regardless of the order T1 and T2.+---------------------------------------------------------------------------++data T1 = T1 deriving (Show, Eq, Typeable, Data)+data T2 = T2 deriving (Show, Eq, Typeable, Data)+data T3 = T3 T1 T2 deriving (Show, Eq, Typeable, Data)+++---------------------------------------------------------------------------+-- A silly monad that we use to read lists of constructor strings.+---------------------------------------------------------------------------++-- Type constructor+newtype ReadT a = ReadT { unReadT :: [String] -> Maybe ([String],a) }++++-- Run a computation+runReadT x y = case unReadT x y of+ Just ([],y) -> Just y+ _ -> Nothing++-- Read one string+readT :: ReadT String+readT = ReadT (\x -> if null x+ then Nothing+ else Just (tail x, head x)+ )++-- ReadT is a monad!+instance Monad ReadT where+ return x = ReadT (\y -> Just (y,x))+ c >>= f = ReadT (\x -> case unReadT c x of+ Nothing -> Nothing+ Just (x', a) -> unReadT (f a) x'+ )++-- ReadT also accommodates mzero and mplus!+instance MonadPlus ReadT where+ mzero = ReadT (const Nothing)+ f `mplus` g = ReadT (\x -> case unReadT f x of+ Nothing -> unReadT g x+ y -> y+ )+++---------------------------------------------------------------------------+-- A helper type to appeal to predicative type system.+---------------------------------------------------------------------------++newtype GenM = GenM { unGenM :: forall a. Data a => a -> ReadT a }+++---------------------------------------------------------------------------+-- The function that reads and copes with all permutations.+---------------------------------------------------------------------------++buildT :: forall a. Data a => ReadT a+buildT = result++ where+ result = do str <- readT+ con <- string2constr str+ ske <- return $ fromConstr con+ fs <- return $ gmapQ buildT' ske+ perm [] fs ske++ -- Determine type of data to be constructed+ myType = myTypeOf result+ where+ myTypeOf :: forall a. ReadT a -> a+ myTypeOf = undefined++ -- Turn string into constructor+ string2constr str = maybe mzero+ return+ (readConstr (dataTypeOf myType) str)++ -- Specialise buildT per kid type+ buildT' :: forall a. Data a => a -> GenM+ buildT' (_::a) = GenM (const mzero `extM` const (buildT::ReadT a))++ -- The permutation exploration function+ perm :: forall a. Data a => [GenM] -> [GenM] -> a -> ReadT a+ perm [] [] a = return a+ perm fs [] a = perm [] fs a+ perm fs (f:fs') a = (+ do a' <- gmapMo (unGenM f) a+ perm fs fs' a'+ )+ `mplus`+ (+ do guard (not (null fs'))+ perm (f:fs) fs' a+ )+++---------------------------------------------------------------------------+-- The main function for testing+---------------------------------------------------------------------------++tests =+ ( runReadT buildT ["T1"] :: Maybe T1 -- should parse fine+ , ( runReadT buildT ["T2"] :: Maybe T2 -- should parse fine+ , ( runReadT buildT ["T3","T1","T2"] :: Maybe T3 -- should parse fine+ , ( runReadT buildT ["T3","T2","T1"] :: Maybe T3 -- should parse fine+ , ( runReadT buildT ["T3","T2","T2"] :: Maybe T3 -- should fail+ ))))) ~=? output++output = (Just T1,(Just T2,(Just (T3 T1 T2),(Just (T3 T1 T2),Nothing))))
+ tests/Polymatch.hs view
@@ -0,0 +1,70 @@+{-# OPTIONS -fglasgow-exts #-}++module Polymatch () where+++import Data.Typeable+import Data.Generics+++-- Representation of kids+kids x = gmapQ Kid x -- get all kids+type Kids = [Kid]+data Kid = forall k. Typeable k => Kid k+++-- Build term from a list of kids and the constructor +fromConstrL :: Data a => Kids -> Constr -> Maybe a+fromConstrL l = unIDL . gunfold k z+ where+ z c = IDL (Just c) l+ k (IDL Nothing _) = IDL Nothing undefined+ k (IDL (Just f) (Kid x:l)) = IDL f' l+ where+ f' = case cast x of+ (Just x') -> Just (f x')+ _ -> Nothing+++-- Helper datatype+data IDL x = IDL (Maybe x) Kids+unIDL (IDL mx _) = mx+++-- Two sample datatypes+data A = A String deriving (Read, Show, Eq, Data, Typeable)+data B = B String deriving (Read, Show, Eq, Data, Typeable)+++-- Mediate between two "left-equal" Either types+f :: (Data a, Data b, Show a, Read b)+ => (a->b) -> Either String a -> Either String b++f g (Right a) = Right $ g a -- conversion really needed+-- f g (Left s) = Left s -- unappreciated conversion+-- f g s = s -- doesn't typecheck +-- f g s = deep_rebuild s -- too expensive+f g s = just (shallow_rebuild s) -- perhaps this is Ok?+++-- Get rid of maybies+just = maybe (error "tried, but failed.") id+++-- Just mentioned for completeness' sake+deep_rebuild :: (Show a, Read b) => a -> b+deep_rebuild = read . show+++-- For the record: it's possible.+shallow_rebuild :: (Data a, Data b) => a -> Maybe b+shallow_rebuild a = b + where+ b = fromConstrL (kids a) constr+ constr = indexConstr (dataTypeOf b) (constrIndex (toConstr a))+++-- Test cases+a2b (A s) = B s -- silly conversion+t1 = f a2b (Left "x") -- prints Left "x"+t2 = f a2b (Right (A "y")) -- prints Right (B "y")
+ tests/Reify.hs view
@@ -0,0 +1,413 @@+{-# OPTIONS -fglasgow-exts #-}++module Reify (tests) where++{-++The following examples illustrate the reification facilities for type+structure. Most notably, we generate shallow terms using the depth of+types and constructors as means to steer the generation.++-}++import Test.HUnit++import Data.Maybe+import Data.Generics+import Control.Monad.State+import CompanyDatatypes++++------------------------------------------------------------------------------+--+-- Encoding types as values; some other way.+--+------------------------------------------------------------------------------++{- ++This group provides a style of encoding types as values and using+them. This style is seen as an alternative to the pragmatic style used+in Data.Typeable.typeOf and elsewhere, i.e., simply use an "undefined"+to denote a type argument. This pragmatic style suffers from lack+of robustness: one feels tempted to pattern match on undefineds.+Maybe Data.Typeable.typeOf etc. should be rewritten accordingly.++-}+++-- | Type as values to stipulate use of undefineds+type TypeVal a = a -> ()+++-- | The value that denotes a type+typeVal :: TypeVal a+typeVal = const ()+++-- | Test for type equivalence+sameType :: (Typeable a, Typeable b) => TypeVal a -> TypeVal b -> Bool+sameType tva tvb = typeOf (type2val tva) ==+ typeOf (type2val tvb)+++-- | Map a value to its type+val2type :: a -> TypeVal a+val2type _ = typeVal+++-- | Stipulate this idiom!+type2val :: TypeVal a -> a+type2val _ = undefined+++-- | Constrain a type+withType :: a -> TypeVal a -> a+withType x _ = x+++-- | The argument type of a function+argType :: (a -> b) -> TypeVal a+argType _ = typeVal+++-- | The result type of a function+resType :: (a -> b) -> TypeVal b+resType _ = typeVal+++-- | The parameter type of type constructor+paraType :: t a -> TypeVal a+paraType _ = typeVal+++-- Type functions,+-- i.e., functions mapping types to values+--+type TypeFun a r = TypeVal a -> r++++-- Generic type functions,+-- i.e., functions mapping types to values+--+type GTypeFun r = forall a. Data a => TypeFun a r++++-- | Extend a type function+extType :: (Data a, Typeable r) => GTypeFun r -> TypeFun a r -> GTypeFun r+extType f x = maybe f id (cast x)++++------------------------------------------------------------------------------+--+-- Mapping operators to map over type structure+--+------------------------------------------------------------------------------+++-- | Query all constructors of a given type++gmapType :: ([(Constr,r')] -> r)+ -> GTypeFun (Constr -> r')+ -> GTypeFun r++gmapType (o::[(Constr,r')] -> r) f (t::TypeVal a)+ = + o $ zip cons query++ where++ -- All constructors of the given type+ cons :: [Constr]+ cons = if isAlgType $ dataTypeOf $ type2val t+ then dataTypeConstrs $ dataTypeOf $ type2val t+ else []++ -- Query constructors+ query :: [r']+ query = map (f t) cons+++-- | Query all subterm types of a given constructor++gmapConstr :: ([r] -> r')+ -> GTypeFun r+ -> GTypeFun (Constr -> r')++gmapConstr (o::[r] -> r') f (t::TypeVal a) c+ = + o $ query++ where++ -- Term for the given constructor+ term :: a+ term = fromConstr c++ -- Query subterm types+ query :: [r]+ query = gmapQ (f . val2type) term+++-- | Compute arity of a given constructor+constrArity :: GTypeFun (Constr -> Int)+constrArity t c = glength $ withType (fromConstr c) t+++-- | Query all immediate subterm types of a given type+gmapSubtermTypes :: (Data a, Typeable r) + => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r+gmapSubtermTypes o (r::r) f (t::TypeVal a)+ =+ reduce (concat (map (gmapQ (query . val2type)) terms))+ (GTypeFun' f)++ where++ -- All constructors of the given type+ cons :: [Constr]+ cons = if isAlgType $ dataTypeOf $ type2val t+ then dataTypeConstrs $ dataTypeOf $ type2val t+ else []++ -- Terms for all constructors+ terms :: [a]+ terms = map fromConstr cons++ -- Query a subterm type+ query :: Data b => TypeVal b -> GTypeFun' r -> (r,GTypeFun' r)+ query t f = (unGTypeFun' f t, GTypeFun' (disable t (unGTypeFun' f)))++ -- Constant out given type+ disable :: Data b => TypeVal b -> GTypeFun r -> GTypeFun r+ disable (t::TypeVal b) f = f `extType` \(_::TypeVal b) -> r++ -- Reduce all subterm types+ reduce :: [GTypeFun' r -> (r,GTypeFun' r)] -> GTypeFun' r -> r+ reduce [] _ = r+ reduce (xy:z) g = fst (xy g) `o` reduce z (snd (xy g))+++-- First-class polymorphic variation on GTypeFun+newtype GTypeFun' r = GTypeFun' (GTypeFun r)+unGTypeFun' (GTypeFun' f) = f+++-- | Query all immediate subterm types.+-- There is an extra argument to \"constant out\" the type at hand.+-- This can be used to avoid cycles.++gmapSubtermTypesConst :: (Data a, Typeable r)+ => (r -> r -> r)+ -> r+ -> GTypeFun r + -> TypeVal a + -> r+gmapSubtermTypesConst o (r::r) f (t::TypeVal a)+ =+ gmapSubtermTypes o r f' t+ where+ f' :: GTypeFun r+ f' = f `extType` \(_::TypeVal a) -> r+++-- Count all distinct subterm types+gcountSubtermTypes :: Data a => TypeVal a -> Int+gcountSubtermTypes = gmapSubtermTypes (+) (0::Int) (const 1)+++-- | A simplied variation on gmapSubtermTypes.+-- Weakness: no awareness of doubles.+-- Strength: easy to comprehend as it uses gmapType and gmapConstr.++_gmapSubtermTypes :: (Data a, Typeable r) + => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r+_gmapSubtermTypes o (r::r) f+ =+ gmapType otype (gmapConstr oconstr f)++ where++ otype :: [(Constr,r)] -> r+ otype = foldr (\x y -> snd x `o` y) r++ oconstr :: [r] -> r+ oconstr = foldr o r+++------------------------------------------------------------------------------+--+-- Some reifying relations on types+--+------------------------------------------------------------------------------+++-- | Reachability relation on types, i.e.,+-- test if nodes of type @a@ are reachable from nodes of type @b@.+-- The relation is defined to be reflexive.++reachableType :: (Data a, Data b) => TypeVal a -> TypeVal b -> Bool+reachableType (a::TypeVal a) (b::TypeVal b)+ =+ or [ sameType a b+ , gmapSubtermTypesConst (\x y -> or [x,y]) False (reachableType a) b+ ]+++-- | Depth of a datatype as the constructor with the minimum depth.+-- The outermost 'Nothing' denotes a type without constructors.+-- The innermost 'Nothing' denotes potentially infinite.++depthOfType :: GTypeFun Bool -> GTypeFun (Maybe (Constr, Maybe Int))+depthOfType p (t::TypeVal a)+ = + gmapType o f t++ where+ + o :: [(Constr, Maybe Int)] -> Maybe (Constr, Maybe Int)+ o l = if null l then Nothing else Just (foldr1 min' l)++ f :: GTypeFun (Constr -> Maybe Int)+ f = depthOfConstr p'++ -- Specific minimum operator+ min' :: (Constr, Maybe Int) -> (Constr, Maybe Int) -> (Constr, Maybe Int)+ min' x (_, Nothing) = x+ min' (_, Nothing) x = x+ min' (c, Just i) (c', Just i') | i <= i' = (c, Just i)+ min' (c, Just i) (c', Just i') = (c', Just i')++ -- Updated predicate for unblocked types+ p' :: GTypeFun Bool+ p' = p `extType` \(_::TypeVal a) -> False+++-- | Depth of a constructor.+-- Depth is viewed as the maximum depth of all subterm types + 1.+-- 'Nothing' denotes potentially infinite.++depthOfConstr :: GTypeFun Bool -> GTypeFun (Constr -> Maybe Int)+depthOfConstr p (t::TypeVal a) c+ =+ gmapConstr o f t c++ where++ o :: [Maybe Int] -> Maybe Int+ o = inc' . foldr max' (Just 0)++ f :: GTypeFun (Maybe Int)+ f t' = if p t'+ then+ case depthOfType p t' of+ Nothing -> Just 0+ Just (_, x) -> x+ else Nothing++ -- Specific maximum operator+ max' Nothing _ = Nothing+ max' _ Nothing = Nothing+ max' (Just i) (Just i') | i >= i' = Just i+ max' (Just i) (Just i') = Just i'++ -- Specific increment operator+ inc' Nothing = Nothing+ inc' (Just i) = Just (i+1)+++------------------------------------------------------------------------------+--+-- Build a shallow term +--+------------------------------------------------------------------------------++shallowTerm :: (forall a. Data a => Maybe a) -> (forall b. Data b => b)+shallowTerm cust+ = result+ where+ result :: forall b. Data b => b+ -- Need a type signature here to bring 'b' into scope+ result = maybe gdefault id cust+ where++ -- The worker, also used for type disambiguation+ gdefault :: b+ gdefault = case con of+ Just (con, Just _) -> fromConstrB (shallowTerm cust) con+ _ -> error "no shallow term!"++ -- The type to be constructed+ typeVal :: TypeVal b+ typeVal = val2type gdefault++ -- The most shallow constructor if any + con :: Maybe (Constr, Maybe Int)+ con = depthOfType (const True) typeVal++++-- For testing shallowTerm+shallowTermBase :: GenericR Maybe+shallowTermBase = Nothing + `extR` Just (1.23::Float)+ `extR` Just ("foo"::String)++++-- Sample datatypes+data T1 = T1a deriving (Typeable, Data) -- just a constant+data T2 = T2 T1 deriving (Typeable, Data) -- little detour+data T3 = T3a T3 | T3b T2 deriving (Typeable, Data) -- recursive case+data T4 = T4 T3 T3 deriving (Typeable, Data) -- sum matters++++-- Sample type arguments+t0 = typeVal :: TypeVal Int+t1 = typeVal :: TypeVal T1+t2 = typeVal :: TypeVal T2+t3 = typeVal :: TypeVal T3+t4 = typeVal :: TypeVal T4+tCompany = typeVal :: TypeVal Company+tPerson = typeVal :: TypeVal Person+tEmployee = typeVal :: TypeVal Employee+tDept = typeVal :: TypeVal Dept++++-- Test cases+test0 = t1 `reachableType` t1 -- True+test1 = t1 `reachableType` t2 -- True+test2 = t2 `reachableType` t1 -- False+test3 = t1 `reachableType` t3+test4 = tPerson `reachableType` tCompany+test5 = gcountSubtermTypes tPerson+test6 = gcountSubtermTypes tEmployee+test7 = gcountSubtermTypes tDept+test8 = shallowTerm shallowTermBase :: Person+test9 = shallowTerm shallowTermBase :: Employee+test10 = shallowTerm shallowTermBase :: Dept++++tests = ( test0+ , ( test1+ , ( test2+ , ( test3+ , ( test4+ , ( test5+ , ( test6+ , ( test7+ , ( test8+ , ( test9+ , ( test10+ ))))))))))) ~=? output++output = (True,(True,(False,(True,(True,(1,(2,(3,(P "foo" "foo",+ (E (P "foo" "foo") (S 1.23),+ D "foo" (E (P "foo" "foo") (S 1.23)) []))))))))))
+ tests/Strings.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS -fglasgow-exts #-}++module Strings (tests) where++{-++This test exercices GENERIC read, show, and eq for the company+datatypes which we use a lot. The output of the program should be+"True" which means that "gread" reads what "gshow" shows while the+read term is equal to the original term in terms of "geq".++-}++import Test.HUnit++import Data.Generics+import CompanyDatatypes++tests = (case gread (gshow genCom) of+ [(x,_)] -> geq genCom x+ _ -> False) ~=? True
+ tests/Tree.hs view
@@ -0,0 +1,62 @@+{-# OPTIONS -fglasgow-exts #-}++module Tree (tests) where++{-++This example illustrates serialisation and de-serialisation,+but we replace *series* by *trees* so to say.++-}++import Test.HUnit++import Control.Monad.Reader+import Data.Generics+import Data.Maybe+import Data.Tree+import CompanyDatatypes+++-- Trealise Data to Tree+data2tree :: Data a => a -> Tree String+data2tree = gdefault `extQ` atString+ where+ atString (x::String) = Node x []+ gdefault x = Node (showConstr (toConstr x)) (gmapQ data2tree x)+++-- De-trealise Tree to Data+tree2data :: Data a => Tree String -> Maybe a+tree2data = gdefault `extR` atString+ where+ atString (Node x []) = Just x+ gdefault (Node x ts) = res+ where++ -- a helper for type capture+ res = maybe Nothing (kids . fromConstr) con++ -- the type to constructed+ ta = fromJust res++ -- construct constructor+ con = readConstr (dataTypeOf ta) x++ -- recursion per kid with accumulation+ perkid ts = const (tail ts, tree2data (head ts)) ++ -- recurse into kids+ kids x =+ do guard (glength x == length ts)+ snd (gmapAccumM perkid ts x)+++-- Main function for testing+tests = ( genCom+ , ( data2tree genCom + , ( (tree2data (data2tree genCom)) :: Maybe Company + , ( Just genCom == tree2data (data2tree genCom)+ )))) ~=? output++output = (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []],(Node {rootLabel = "C", subForest = [Node {rootLabel = "(:)", subForest = [Node {rootLabel = "D", subForest = [Node {rootLabel = "Research", subForest = []},Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Laemmel", subForest = []},Node {rootLabel = "Amsterdam", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "8000.0", subForest = []}]}]},Node {rootLabel = "(:)", subForest = [Node {rootLabel = "PU", subForest = [Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Joost", subForest = []},Node {rootLabel = "Amsterdam", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "1000.0", subForest = []}]}]}]},Node {rootLabel = "(:)", subForest = [Node {rootLabel = "PU", subForest = [Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Marlow", subForest = []},Node {rootLabel = "Cambridge", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "2000.0", subForest = []}]}]}]},Node {rootLabel = "[]", subForest = []}]}]}]},Node {rootLabel = "(:)", subForest = [Node {rootLabel = "D", subForest = [Node {rootLabel = "Strategy", subForest = []},Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Blair", subForest = []},Node {rootLabel = "London", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "100000.0", subForest = []}]}]},Node {rootLabel = "[]", subForest = []}]},Node {rootLabel = "[]", subForest = []}]}]}]},(Just (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []]),True)))
+ tests/Twin.hs view
@@ -0,0 +1,90 @@+{-# OPTIONS -fglasgow-exts #-}+ +module Twin (tests) where++{-++For the discussion in the 2nd boilerplate paper,+we favour some simplified development of twin traversal.+So the full general, stepwise story is in Data.Generics.Twin,+but the short version from the paper is turned into a test+case below. ++See the paper for an explanation.+ +-}++import Test.HUnit++import Data.Generics hiding (GQ,gzipWithQ,geq)++geq' :: GenericQ (GenericQ Bool)+geq' x y = toConstr x == toConstr y+ && and (gzipWithQ geq' x y)++geq :: Data a => a -> a -> Bool+geq = geq'++newtype GQ r = GQ (GenericQ r)++gzipWithQ :: GenericQ (GenericQ r)+ -> GenericQ (GenericQ [r])+gzipWithQ f t1 t2 + = gApplyQ (gmapQ (\x -> GQ (f x)) t1) t2++gApplyQ :: Data a => [GQ r] -> a -> [r]+gApplyQ qs t = reverse (snd (gfoldlQ k z t))+ where+ k :: ([GQ r], [r]) -> GenericQ ([GQ r], [r])+ k (GQ q : qs, rs) child = (qs, q child : rs)+ z = (qs, [])++newtype R r x = R { unR :: r }++gfoldlQ :: (r -> GenericQ r)+ -> r + -> GenericQ r++gfoldlQ k z t = unR (gfoldl k' z' t)+ where+ z' _ = R z+ k' (R r) c = R (k r c)++-----------------------------------------------------------------------------++-- A dependently polymorphic geq+geq'' :: Data a => a -> a -> Bool+geq'' x y = toConstr x == toConstr y+ && and (gzipWithQ' geq'' x y)++-- A helper type for existentially quantified queries+data XQ r = forall a. Data a => XQ (a -> r)++-- A dependently polymorphic gzipWithQ+gzipWithQ' :: (forall a. Data a => a -> a -> r)+ -> (forall a. Data a => a -> a -> [r])+gzipWithQ' f t1 t2+ = gApplyQ' (gmapQ (\x -> XQ (f x)) t1) t2++-- Apply existentially quantified queries+-- Insist on equal types!+--+gApplyQ' :: Data a => [XQ r] -> a -> [r]+gApplyQ' qs t = reverse (snd (gfoldlQ k z t))+ where+ z = (qs, [])+ k :: ([XQ r], [r]) -> GenericQ ([XQ r], [r])+ k (XQ q : qs, rs) child = (qs, q' child : rs)+ where+ q' = error "Twin mismatch" `extQ` q+++-----------------------------------------------------------------------------++tests = ( geq [True,True] [True,True]+ , geq [True,True] [True,False]+ , geq'' [True,True] [True,True]+ , geq'' [True,True] [True,False]+ ) ~=? output++output = (True,False,True,False)
+ tests/Typeable.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS -fglasgow-exts #-}++module Typeable (tests) where++import Test.HUnit++import Data.Typeable++newtype Y e = Y { unY :: (e (Y e)) } ++instance Typeable1 e => Typeable (Y e) where+ typeOf _ = mkTyConApp yTc [typeOf1 (undefined :: e ())]++yTc :: TyCon+yTc = mkTyCon "Typeable.Y"++tests = show (typeOf (undefined :: Y [])) ~=? output++output = "Typeable.Y []"
+ tests/Typecase1.hs view
@@ -0,0 +1,59 @@+{-# OPTIONS -fglasgow-exts #-}++module Typecase1 (tests) where++{-++This test demonstrates type case as it lives in Data.Typeable.+We define a function f that converts typeables into strings in some way.+Note: we only need Data.Typeable. Say: Dynamics are NOT involved.++-}++import Test.HUnit++import Data.Typeable+import Data.Maybe++-- Some datatype.+data MyTypeable = MyCons String deriving (Show, Typeable)++--+-- Some function that performs type case.+--+f :: (Show a, Typeable a) => a -> String+f a = (maybe (maybe (maybe others + mytys (cast a) )+ float (cast a) )+ int (cast a) )++ where++ -- do something with ints+ int :: Int -> String+ int a = "got an int, incremented: " ++ show (a + 1)+ + -- do something with floats+ float :: Float -> String+ float a = "got a float, multiplied by .42: " ++ show (a * 0.42)++ -- do something with my typeables+ mytys :: MyTypeable -> String+ mytys a = "got a term: " ++ show a++ -- do something with all other typeables+ others = "got something else: " ++ show a+++--+-- Test the type case+--+tests = ( f (41::Int)+ , f (88::Float)+ , f (MyCons "42")+ , f True) ~=? output++output = ( "got an int, incremented: 42"+ , "got a float, multiplied by .42: 36.96"+ , "got a term: MyCons \"42\""+ , "got something else: True")
+ tests/Typecase2.hs view
@@ -0,0 +1,61 @@+{-# OPTIONS -fglasgow-exts #-}++module Typecase2 (tests) where++{-++This test provides a variation on typecase1.hs.+This time, we use generic show as defined for all instances of Data.+Thereby, we get rid of the Show constraint in our functions.+So we only keep a single constraint: the one for class Data.++-}++import Test.HUnit++import Data.Generics+import Data.Maybe++-- Some datatype.+data MyData = MyCons String deriving (Typeable, Data)++--+-- Some function that performs type case.+--+f :: Data a => a -> String+f a = (maybe (maybe (maybe others + mytys (cast a) )+ float (cast a) )+ int (cast a) )++ where++ -- do something with ints+ int :: Int -> String+ int a = "got an int, incremented: " ++ show (a + 1)+ + -- do something with floats+ float :: Float -> String+ float a = "got a float, multiplied by .42: " ++ show (a * 0.42)++ -- do something with my data+ mytys :: MyData -> String+ mytys a = "got my data: " ++ gshow a++ -- do something with all other data+ others = "got something else: " ++ gshow a+++--+-- Test the type case+--+tests = ( f (41::Int)+ , f (88::Float)+ , f (MyCons "42")+ , f True) ~=? output++output = ( "got an int, incremented: 42"+ , "got a float, multiplied by .42: 36.96"+ , "got my data: (MyCons \"42\")"+ , "got something else: (True)")+
+ tests/Where.hs view
@@ -0,0 +1,125 @@+{-# OPTIONS -fglasgow-exts #-}++module Where (tests) where++{-++This example illustrates some differences between certain traversal+schemes. To this end, we use a simple system of datatypes, and the+running example shall be to replace "T1a 42" by "T1a 88". It is our+intention to illustrate a few dimensions of designing traversals.++1. We can decide on whether we prefer "rewrite steps" (i.e.,+monomorphic functions on data) that succeed either for all input+patterns or only if the encounter a term pattern to be replaced. In+the first case, the catch-all equation of such a function describes+identity (see "stepid" below). In the second case, the catch-call+equation describes failure using the Maybe type constructor (see+"stepfail" below). As an intermediate assessment, the failure approach+is more general because it allows one to observe if a rewrite step was+meaningful or not. Often the identity approach is more convenient and+sufficient.++2. We can now also decide on whether we want monadic or simple+traversals; recall monadic generic functions GenericM from+Data.Generics. The monad can serve for success/failure, state,+environment and others. One can now subdivide monadic traversal+schemes with respect to the question whether they simply support+monadic style of whether they even interact with the relevant+monad. The scheme "everywereM" from the library belongs to the first+category while "somewhere" belongs to the second category as it uses+the operation "mplus" of a monad with addition. So while "everywhereM"+makes very well sense without a monad --- as demonstrated by+"everywhere", the scheme "somewhere" is immediately monadic.++3. We can now also decide on whether we want rewrite steps to succeed+for all possible subterms, at least for one subterm, exactly for one+subterm, and others. The various traversal schemes make different+assumptions in this respect.++a) everywhere++ By its type, succeeds and requires non-failing rewrite steps.+ However, we do not get any feedback on whether terms were actually+ rewritten. (Say, we might have performed accidentally the identity+ function on all nodes.)++b) everywhereM++ Attempts to reach all nodes where all the sub-traversals are performed+ in monadic bind-sequence. Failure of the traversal for a given subterm+ implies failure of the entire traversal. Hence, the argument of + "everywhereM" should be designed in a way that it tends to succeed+ except for the purpose of propagating a proper error in the sense of+ violating a pre-/post-condition. For example, "mkM stepfail" should+ not be passed to "everywhereM" as it will fail for all but one term + pattern; see "recovered" for a way to massage "stepfail" accordingly.++c) somewhere++ Descends into term in a top-down manner, and stops in a given+ branch when the argument succeeds for the subterm at hand. To this+ end, it takes an argument that is perfectly intended to fail for+ certain term patterns. Thanks to the employment of gmapF, the+ traversal scheme recovers from failure when mapping over the immediate+ subterms while insisting success for at least one subterm (say, branch).+ This scheme is appropriate if you want to make sure that a given+ rewrite step was actually used in a traversal. So failure of the+ traversal would mean that the argument failed for all subterms.++Contributed by Ralf Laemmel, ralf@cwi.nl++-}++import Test.HUnit++import Data.Generics+import Control.Monad+++-- Two mutually recursive datatypes+data T1 = T1a Int | T1b T2 deriving (Typeable, Data)+data T2 = T2 T1 deriving (Typeable, Data)+++-- A rewrite step with identity as catch-all case+stepid (T1a 42) = T1a 88+stepid x = x+++-- The same rewrite step but now with failure as catch-all case+stepfail (T1a 42) = Just (T1a 88)+stepfail _ = Nothing+++-- We can let recover potentially failing generic functions from failure;+-- this is illustrated for a generic made from stepfail via mkM.+recovered x = mkM stepfail x `mplus` Just x+++-- A test term that comprehends a redex+term42 = T1b (T2 (T1a 42))+++-- A test term that does not comprehend a redex+term37 = T1b (T2 (T1a 37))+++-- A number of traversals+result1 = everywhere (mkT stepid) term42 -- rewrites term accordingly+result2 = everywhere (mkT stepid) term37 -- preserves term without notice+result3 = everywhereM (mkM stepfail) term42 -- fails in a harsh manner+result4 = everywhereM (mkM stepfail) term37 -- fails rather early+result5 = everywhereM recovered term37 -- preserves term without notice+result6 = somewhere (mkMp stepfail) term42 -- rewrites term accordingly+result7 = somewhere (mkMp stepfail) term37 -- fails to notice lack of redex++tests = gshow ( result1,+ ( result2,+ ( result3,+ ( result4,+ ( result5,+ ( result6,+ ( result7 ))))))) ~=? output++output = "((,) (T1b (T2 (T1a (88)))) ((,) (T1b (T2 (T1a (37)))) ((,) (Nothing) ((,) (Nothing) ((,) (Just (T1b (T2 (T1a (37))))) ((,) (Just (T1b (T2 (T1a (88))))) (Nothing)))))))"
+ tests/XML.hs view
@@ -0,0 +1,195 @@+{-# OPTIONS -fglasgow-exts #-}++module XML (tests) where++{-++This example illustrates XMLish services+to trealise (say, "serialise") heterogenous+Haskell data as homogeneous tree structures+(say, XMLish elements) and vice versa.++-}++import Test.HUnit++import Control.Monad+import Data.Maybe+import Data.Generics+import CompanyDatatypes+++-- HaXml-like types for XML elements+data Element = Elem Name [Attribute] [Content]+ deriving (Show, Eq, Typeable, Data)++data Content = CElem Element+ | CString Bool CharData+ -- ^ bool is whether whitespace is significant+ | CRef Reference+ | CMisc Misc+ deriving (Show, Eq, Typeable, Data)++type CharData = String+++-- In this simple example we disable some parts of XML+type Attribute = ()+type Reference = ()+type Misc = ()+++-- Trealisation+data2content :: Data a => a -> [Content]+data2content = element+ `ext1Q` list+ `extQ` string + `extQ` float++ where++ -- Handle an element+ element x = [CElem (Elem (tyconUQname (dataTypeName (dataTypeOf x)))+ [] -- no attributes + (concat (gmapQ data2content x)))]++ -- A special case for lists+ list :: Data a => [a] -> [Content]+ list = concat . map data2content++ -- A special case for strings+ string :: String -> [Content]+ string x = [CString True x]++ -- A special case for floats+ float :: Float -> [Content]+ float x = [CString True (show x)]+++-- De-trealisation+content2data :: forall a. Data a => ReadX a+content2data = result++ where+ + -- Case-discriminating worker+ result = element+ `ext1R` list+ `extR` string+ `extR` float+++ -- Determine type of data to be constructed+ myType = myTypeOf result+ where+ myTypeOf :: forall a. ReadX a -> a+ myTypeOf = undefined++ -- Handle an element+ element = do c <- readX+ case c of+ (CElem (Elem x as cs))+ | as == [] -- no attributes+ && x == (tyconUQname (dataTypeName (dataTypeOf myType)))+ -> alts cs+ _ -> mzero+++ -- A special case for lists+ list :: forall a. Data a => ReadX [a]+ list = ( do h <- content2data+ t <- list+ return (h:t) )+ `mplus` return []++ -- Fold over all alternatives, say constructors+ alts cs = foldr (mplus . recurse cs) mzero shapes++ -- Possible top-level shapes+ shapes = map fromConstr consOf++ -- Retrieve all constructors of the requested type+ consOf = dataTypeConstrs+ $ dataTypeOf + $ myType++ -- Recurse into subterms+ recurse cs x = maybe mzero+ return+ (runReadX (gmapM (const content2data) x) cs)++ -- A special case for strings+ string :: ReadX String+ string = do c <- readX+ case c of+ (CString _ x) -> return x+ _ -> mzero++ -- A special case for floats+ float :: ReadX Float+ float = do c <- readX+ case c of+ (CString _ x) -> return (read x)+ _ -> mzero++++-----------------------------------------------------------------------------+--+-- An XML-hungry parser-like monad+--+-----------------------------------------------------------------------------++-- Type constructor+newtype ReadX a =+ ReadX { unReadX :: [Content]+ -> Maybe ([Content], a) }++-- Run a computation+runReadX x y = case unReadX x y of + Just ([],y) -> Just y+ _ -> Nothing++-- Read one content particle+readX :: ReadX Content+readX = ReadX (\x -> if null x + then Nothing+ else Just (tail x, head x)+ )++-- ReadX is a monad!+instance Monad ReadX where+ return x = ReadX (\y -> Just (y,x))+ c >>= f = ReadX (\x -> case unReadX c x of+ Nothing -> Nothing+ Just (x', a) -> unReadX (f a) x'+ )++-- ReadX also accommodates mzero and mplus!+instance MonadPlus ReadX where+ mzero = ReadX (const Nothing)+ f `mplus` g = ReadX (\x -> case unReadX f x of+ Nothing -> unReadX g x+ y -> y+ )++++-----------------------------------------------------------------------------+--+-- Main function for testing+--+-----------------------------------------------------------------------------++tests = ( genCom+ , ( data2content genCom+ , ( zigzag person1 :: Maybe Person+ , ( zigzag genCom :: Maybe Company+ , ( zigzag genCom == Just genCom+ ))))) ~=? output+ where + -- Trealise back and forth+ zigzag :: Data a => a -> Maybe a+ zigzag = runReadX content2data . data2content++output = (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []],([CElem (Elem "Company" [] [CElem (Elem "Dept" [] [CString True "Research",CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Laemmel",CString True "Amsterdam"]),CElem (Elem "Salary" [] [CString True "8000.0"])]),CElem (Elem "Unit" [] [CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Joost",CString True "Amsterdam"]),CElem (Elem "Salary" [] [CString True "1000.0"])])]),CElem (Elem "Unit" [] [CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Marlow",CString True "Cambridge"]),CElem (Elem "Salary" [] [CString True "2000.0"])])])]),CElem (Elem "Dept" [] [CString True "Strategy",CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Blair",CString True "London"]),CElem (Elem "Salary" [] [CString True "100000.0"])])])])],(Just (P "Lazy" "Home"),(Just (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []]),True))))