syb 0.4.1 → 0.4.2
raw patch · 13 files changed
+1697/−1697 lines, 13 filesdep ~basesetup-changed
Dependency ranges changed: base
Files
- Setup.lhs +3/−3
- src/Data/Generics.hs +39/−39
- src/Data/Generics/Aliases.hs +439/−439
- src/Data/Generics/Instances.hs +189/−189
- src/Data/Generics/Schemes.hs +182/−182
- src/Data/Generics/Text.hs +130/−130
- src/Data/Generics/Twins.hs +270/−270
- syb.cabal +64/−64
- tests/Bits.hs +214/−214
- tests/CompanyDatatypes.hs +1/−1
- tests/Datatype.hs +33/−33
- tests/FreeNames.hs +118/−118
- tests/Newtype.hs +15/−15
Setup.lhs view
@@ -1,3 +1,3 @@-#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain +#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
src/Data/Generics.hs view
@@ -1,39 +1,39 @@-{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Generics --- Copyright : (c) The University of Glasgow, CWI 2001--2004 --- License : BSD-style (see the LICENSE file) --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable (uses Data.Generics.Basics) --- --- \"Scrap your boilerplate\" --- Generic programming in Haskell --- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. To scrap your --- boilerplate it is sufficient to import the present module, which simply --- re-exports all themes of the Data.Generics library. --- ------------------------------------------------------------------------------ - -module Data.Generics ( - - -- * All Data.Generics modules - module Data.Data, -- primitives and instances of the Data class - module Data.Generics.Aliases, -- aliases for type case, generic types - module Data.Generics.Schemes, -- traversal schemes (everywhere etc.) - module Data.Generics.Text, -- generic read and show - module Data.Generics.Twins, -- twin traversal, e.g., generic eq - module Data.Generics.Builders, -- term builders - - ) where - ------------------------------------------------------------------------------- - -import Data.Data -import Data.Generics.Instances () -import Data.Generics.Aliases -import Data.Generics.Schemes -import Data.Generics.Text -import Data.Generics.Twins -import Data.Generics.Builders +{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Generics+-- Copyright : (c) The University of Glasgow, CWI 2001--2004+-- License : BSD-style (see the LICENSE file)+-- +-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable (uses Data.Generics.Basics)+--+-- \"Scrap your boilerplate\" --- Generic programming in Haskell +-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. To scrap your+-- boilerplate it is sufficient to import the present module, which simply+-- re-exports all themes of the Data.Generics library.+--+-----------------------------------------------------------------------------++module Data.Generics (++ -- * All Data.Generics modules+ module Data.Data, -- primitives and instances of the Data class+ module Data.Generics.Aliases, -- aliases for type case, generic types+ module Data.Generics.Schemes, -- traversal schemes (everywhere etc.)+ module Data.Generics.Text, -- generic read and show+ module Data.Generics.Twins, -- twin traversal, e.g., generic eq+ module Data.Generics.Builders, -- term builders++ ) where++------------------------------------------------------------------------------++import Data.Data+import Data.Generics.Instances ()+import Data.Generics.Aliases+import Data.Generics.Schemes+import Data.Generics.Text+import Data.Generics.Twins+import Data.Generics.Builders
src/Data/Generics/Aliases.hs view
@@ -1,439 +1,439 @@-{-# LANGUAGE RankNTypes, CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Generics.Aliases --- Copyright : (c) The University of Glasgow, CWI 2001--2004 --- License : BSD-style (see the LICENSE file) --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable (local universal quantification) --- --- \"Scrap your boilerplate\" --- Generic programming in Haskell --- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. --- The present module provides a number of declarations for typical generic --- function types, corresponding type case, and others. --- ------------------------------------------------------------------------------ - -module Data.Generics.Aliases ( - - -- * Combinators to \"make\" generic functions via cast - mkT, mkQ, mkM, mkMp, mkR, - ext0, extT, extQ, extM, extMp, extB, extR, - - -- * Type synonyms for generic function types - GenericT, - GenericQ, - GenericM, - GenericB, - GenericR, - Generic, - Generic'(..), - GenericT'(..), - GenericQ'(..), - GenericM'(..), - - -- * Ingredients of generic functions - orElse, - - -- * Function combinators on generic functions - recoverMp, - recoverQ, - choiceMp, - choiceQ, - - -- * Type extension for unary type constructors - ext1, - ext1T, - ext1M, - ext1Q, - ext1R, - ext1B, - - -- * Type extension for binary type constructors - ext2T, - ext2M, - ext2Q, - ext2R, - ext2B - - ) where - -#ifdef __HADDOCK__ -import Prelude -#endif -import Control.Monad -import Data.Data - ------------------------------------------------------------------------------- --- --- Combinators to "make" generic functions --- We use type-safe cast in a number of ways to make generic functions. --- ------------------------------------------------------------------------------- - --- | Make a generic transformation; --- start from a type-specific case; --- preserve the term otherwise --- -mkT :: ( Typeable a - , Typeable b - ) - => (b -> b) - -> a - -> a -mkT = extT id - - --- | Make a generic query; --- start from a type-specific case; --- return a constant otherwise --- -mkQ :: ( Typeable a - , Typeable b - ) - => r - -> (b -> r) - -> a - -> r -(r `mkQ` br) a = case cast a of - Just b -> br b - Nothing -> r - - --- | Make a generic monadic transformation; --- start from a type-specific case; --- resort to return otherwise --- -mkM :: ( Monad m - , Typeable a - , Typeable b - ) - => (b -> m b) - -> a - -> m a -mkM = extM return - - -{- - -For the remaining definitions, we stick to a more concise style, i.e., -we fold maybes with "maybe" instead of case ... of ..., and we also -use a point-free style whenever possible. - --} - - --- | Make a generic monadic transformation for MonadPlus; --- use \"const mzero\" (i.e., failure) instead of return as default. --- -mkMp :: ( MonadPlus m - , Typeable a - , Typeable b - ) - => (b -> m b) - -> a - -> m a -mkMp = extM (const mzero) - - --- | Make a generic builder; --- start from a type-specific ase; --- resort to no build (i.e., mzero) otherwise --- -mkR :: ( MonadPlus m - , Typeable a - , Typeable b - ) - => m b -> m a -mkR f = mzero `extR` f - - --- | Flexible type extension -ext0 :: (Typeable a, Typeable b) => c a -> c b -> c a -ext0 def ext = maybe def id (gcast ext) - - --- | Extend a generic transformation by a type-specific case -extT :: ( Typeable a - , Typeable b - ) - => (a -> a) - -> (b -> b) - -> a - -> a -extT def ext = unT ((T def) `ext0` (T ext)) - - --- | Extend a generic query by a type-specific case -extQ :: ( Typeable a - , Typeable b - ) - => (a -> q) - -> (b -> q) - -> a - -> q -extQ f g a = maybe (f a) g (cast a) - - --- | Extend a generic monadic transformation by a type-specific case -extM :: ( Monad m - , Typeable a - , Typeable b - ) - => (a -> m a) -> (b -> m b) -> a -> m a -extM def ext = unM ((M def) `ext0` (M ext)) - - --- | Extend a generic MonadPlus transformation by a type-specific case -extMp :: ( MonadPlus m - , Typeable a - , Typeable b - ) - => (a -> m a) -> (b -> m b) -> a -> m a -extMp = extM - - --- | Extend a generic builder -extB :: ( Typeable a - , Typeable b - ) - => a -> b -> a -extB a = maybe a id . cast - - --- | Extend a generic reader -extR :: ( Monad m - , Typeable a - , Typeable b - ) - => m a -> m b -> m a -extR def ext = unR ((R def) `ext0` (R ext)) - - - ------------------------------------------------------------------------------- --- --- Type synonyms for generic function types --- ------------------------------------------------------------------------------- - - --- | Generic transformations, --- i.e., take an \"a\" and return an \"a\" --- -type GenericT = forall a. Data a => a -> a - - --- | Generic queries of type \"r\", --- i.e., take any \"a\" and return an \"r\" --- -type GenericQ r = forall a. Data a => a -> r - - --- | Generic monadic transformations, --- i.e., take an \"a\" and compute an \"a\" --- -type GenericM m = forall a. Data a => a -> m a - - --- | Generic builders --- i.e., produce an \"a\". --- -type GenericB = forall a. Data a => a - - --- | Generic readers, say monadic builders, --- i.e., produce an \"a\" with the help of a monad \"m\". --- -type GenericR m = forall a. Data a => m a - - --- | The general scheme underlying generic functions --- assumed by gfoldl; there are isomorphisms such as --- GenericT = Generic T. --- -type Generic c = forall a. Data a => a -> c a - - --- | Wrapped generic functions; --- recall: [Generic c] would be legal but [Generic' c] not. --- -data Generic' c = Generic' { unGeneric' :: Generic c } - - --- | Other first-class polymorphic wrappers -newtype GenericT' = GT { unGT :: forall a. Data a => a -> a } -newtype GenericQ' r = GQ { unGQ :: GenericQ r } -newtype GenericM' m = GM { unGM :: forall a. Data a => a -> m a } - - --- | Left-biased choice on maybes -orElse :: Maybe a -> Maybe a -> Maybe a -x `orElse` y = case x of - Just _ -> x - Nothing -> y - - -{- - -The following variations take "orElse" to the function -level. Furthermore, we generalise from "Maybe" to any -"MonadPlus". This makes sense for monadic transformations and -queries. We say that the resulting combinators modell choice. We also -provide a prime example of choice, that is, recovery from failure. In -the case of transformations, we recover via return whereas for -queries a given constant is returned. - --} - --- | Choice for monadic transformations -choiceMp :: MonadPlus m => GenericM m -> GenericM m -> GenericM m -choiceMp f g x = f x `mplus` g x - - --- | Choice for monadic queries -choiceQ :: MonadPlus m => GenericQ (m r) -> GenericQ (m r) -> GenericQ (m r) -choiceQ f g x = f x `mplus` g x - - --- | Recover from the failure of monadic transformation by identity -recoverMp :: MonadPlus m => GenericM m -> GenericM m -recoverMp f = f `choiceMp` return - - --- | Recover from the failure of monadic query by a constant -recoverQ :: MonadPlus m => r -> GenericQ (m r) -> GenericQ (m r) -recoverQ r f = f `choiceQ` const (return r) - - - ------------------------------------------------------------------------------- --- Type extension for unary type constructors ------------------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ >= 707 -#define Typeable1 Typeable -#define Typeable2 Typeable -#endif - --- | Flexible type extension -ext1 :: (Data a, Typeable1 t) - => c a - -> (forall d. Data d => c (t d)) - -> c a -ext1 def ext = maybe def id (dataCast1 ext) - - --- | Type extension of transformations for unary type constructors -ext1T :: (Data d, Typeable1 t) - => (forall e. Data e => e -> e) - -> (forall f. Data f => t f -> t f) - -> d -> d -ext1T def ext = unT ((T def) `ext1` (T ext)) - - --- | Type extension of monadic transformations for type constructors -ext1M :: (Monad m, Data d, Typeable1 t) - => (forall e. Data e => e -> m e) - -> (forall f. Data f => t f -> m (t f)) - -> d -> m d -ext1M def ext = unM ((M def) `ext1` (M ext)) - - --- | Type extension of queries for type constructors -ext1Q :: (Data d, Typeable1 t) - => (d -> q) - -> (forall e. Data e => t e -> q) - -> d -> q -ext1Q def ext = unQ ((Q def) `ext1` (Q ext)) - - --- | Type extension of readers for type constructors -ext1R :: (Monad m, Data d, Typeable1 t) - => m d - -> (forall e. Data e => m (t e)) - -> m d -ext1R def ext = unR ((R def) `ext1` (R ext)) - - --- | Type extension of builders for type constructors -ext1B :: (Data a, Typeable1 t) - => a - -> (forall b. Data b => (t b)) - -> a -ext1B def ext = unB ((B def) `ext1` (B ext)) - ------------------------------------------------------------------------------- --- Type extension for binary type constructors ------------------------------------------------------------------------------- - --- | Flexible type extension -ext2 :: (Data a, Typeable2 t) - => c a - -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2)) - -> c a -ext2 def ext = maybe def id (dataCast2 ext) - - --- | Type extension of transformations for unary type constructors -ext2T :: (Data d, Typeable2 t) - => (forall e. Data e => e -> e) - -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> t d1 d2) - -> d -> d -ext2T def ext = unT ((T def) `ext2` (T ext)) - - --- | Type extension of monadic transformations for type constructors -ext2M :: (Monad m, Data d, Typeable2 t) - => (forall e. Data e => e -> m e) - -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> m (t d1 d2)) - -> d -> m d -ext2M def ext = unM ((M def) `ext2` (M ext)) - - --- | Type extension of queries for type constructors -ext2Q :: (Data d, Typeable2 t) - => (d -> q) - -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) - -> d -> q -ext2Q def ext = unQ ((Q def) `ext2` (Q ext)) - - --- | Type extension of readers for type constructors -ext2R :: (Monad m, Data d, Typeable2 t) - => m d - -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2)) - -> m d -ext2R def ext = unR ((R def) `ext2` (R ext)) - - --- | Type extension of builders for type constructors -ext2B :: (Data a, Typeable2 t) - => a - -> (forall d1 d2. (Data d1, Data d2) => (t d1 d2)) - -> a -ext2B def ext = unB ((B def) `ext2` (B ext)) - ------------------------------------------------------------------------------- --- --- Type constructors for type-level lambdas --- ------------------------------------------------------------------------------- - - --- | The type constructor for transformations -newtype T x = T { unT :: x -> x } - --- | The type constructor for transformations -newtype M m x = M { unM :: x -> m x } - --- | The type constructor for queries -newtype Q q x = Q { unQ :: x -> q } - --- | The type constructor for readers -newtype R m x = R { unR :: m x } - --- | The type constructor for builders -newtype B x = B {unB :: x} +{-# LANGUAGE RankNTypes, CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Generics.Aliases+-- Copyright : (c) The University of Glasgow, CWI 2001--2004+-- License : BSD-style (see the LICENSE file)+-- +-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable (local universal quantification)+--+-- \"Scrap your boilerplate\" --- Generic programming in Haskell +-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>.+-- The present module provides a number of declarations for typical generic+-- function types, corresponding type case, and others.+--+-----------------------------------------------------------------------------++module Data.Generics.Aliases (++ -- * Combinators to \"make\" generic functions via cast+ mkT, mkQ, mkM, mkMp, mkR,+ ext0, extT, extQ, extM, extMp, extB, extR,++ -- * Type synonyms for generic function types+ GenericT,+ GenericQ,+ GenericM,+ GenericB,+ GenericR,+ Generic,+ Generic'(..),+ GenericT'(..),+ GenericQ'(..),+ GenericM'(..),++ -- * Ingredients of generic functions+ orElse,++ -- * Function combinators on generic functions+ recoverMp,+ recoverQ,+ choiceMp,+ choiceQ,++ -- * Type extension for unary type constructors+ ext1,+ ext1T,+ ext1M,+ ext1Q,+ ext1R,+ ext1B,++ -- * Type extension for binary type constructors+ ext2T,+ ext2M,+ ext2Q,+ ext2R,+ ext2B++ ) where++#ifdef __HADDOCK__+import Prelude+#endif+import Control.Monad+import Data.Data++------------------------------------------------------------------------------+--+-- Combinators to "make" generic functions+-- We use type-safe cast in a number of ways to make generic functions.+--+------------------------------------------------------------------------------++-- | Make a generic transformation;+-- start from a type-specific case;+-- preserve the term otherwise+--+mkT :: ( Typeable a+ , Typeable b+ )+ => (b -> b)+ -> a+ -> a+mkT = extT id+++-- | Make a generic query;+-- start from a type-specific case;+-- return a constant otherwise+--+mkQ :: ( Typeable a+ , Typeable b+ )+ => r+ -> (b -> r)+ -> a+ -> r+(r `mkQ` br) a = case cast a of+ Just b -> br b+ Nothing -> r+++-- | Make a generic monadic transformation;+-- start from a type-specific case;+-- resort to return otherwise+--+mkM :: ( Monad m+ , Typeable a+ , Typeable b+ )+ => (b -> m b)+ -> a+ -> m a+mkM = extM return+++{-++For the remaining definitions, we stick to a more concise style, i.e.,+we fold maybes with "maybe" instead of case ... of ..., and we also+use a point-free style whenever possible.++-}+++-- | Make a generic monadic transformation for MonadPlus;+-- use \"const mzero\" (i.e., failure) instead of return as default.+--+mkMp :: ( MonadPlus m+ , Typeable a+ , Typeable b+ )+ => (b -> m b)+ -> a+ -> m a+mkMp = extM (const mzero)+++-- | Make a generic builder;+-- start from a type-specific ase;+-- resort to no build (i.e., mzero) otherwise+--+mkR :: ( MonadPlus m+ , Typeable a+ , Typeable b+ )+ => m b -> m a+mkR f = mzero `extR` f+++-- | Flexible type extension+ext0 :: (Typeable a, Typeable b) => c a -> c b -> c a+ext0 def ext = maybe def id (gcast ext)+++-- | Extend a generic transformation by a type-specific case+extT :: ( Typeable a+ , Typeable b+ )+ => (a -> a)+ -> (b -> b)+ -> a+ -> a+extT def ext = unT ((T def) `ext0` (T ext))+++-- | Extend a generic query by a type-specific case+extQ :: ( Typeable a+ , Typeable b+ )+ => (a -> q)+ -> (b -> q)+ -> a+ -> q+extQ f g a = maybe (f a) g (cast a)+++-- | Extend a generic monadic transformation by a type-specific case+extM :: ( Monad m+ , Typeable a+ , Typeable b+ )+ => (a -> m a) -> (b -> m b) -> a -> m a+extM def ext = unM ((M def) `ext0` (M ext))+++-- | Extend a generic MonadPlus transformation by a type-specific case+extMp :: ( MonadPlus m+ , Typeable a+ , Typeable b+ )+ => (a -> m a) -> (b -> m b) -> a -> m a+extMp = extM+++-- | Extend a generic builder+extB :: ( Typeable a+ , Typeable b+ )+ => a -> b -> a+extB a = maybe a id . cast+++-- | Extend a generic reader+extR :: ( Monad m+ , Typeable a+ , Typeable b+ )+ => m a -> m b -> m a+extR def ext = unR ((R def) `ext0` (R ext))++++------------------------------------------------------------------------------+--+-- Type synonyms for generic function types+--+------------------------------------------------------------------------------+++-- | Generic transformations,+-- i.e., take an \"a\" and return an \"a\"+--+type GenericT = forall a. Data a => a -> a+++-- | Generic queries of type \"r\",+-- i.e., take any \"a\" and return an \"r\"+--+type GenericQ r = forall a. Data a => a -> r+++-- | Generic monadic transformations,+-- i.e., take an \"a\" and compute an \"a\"+--+type GenericM m = forall a. Data a => a -> m a+++-- | Generic builders+-- i.e., produce an \"a\".+--+type GenericB = forall a. Data a => a+++-- | Generic readers, say monadic builders,+-- i.e., produce an \"a\" with the help of a monad \"m\".+--+type GenericR m = forall a. Data a => m a+++-- | The general scheme underlying generic functions+-- assumed by gfoldl; there are isomorphisms such as+-- GenericT = Generic T.+--+type Generic c = forall a. Data a => a -> c a+++-- | Wrapped generic functions;+-- recall: [Generic c] would be legal but [Generic' c] not.+--+data Generic' c = Generic' { unGeneric' :: Generic c }+++-- | Other first-class polymorphic wrappers+newtype GenericT' = GT { unGT :: forall a. Data a => a -> a }+newtype GenericQ' r = GQ { unGQ :: GenericQ r }+newtype GenericM' m = GM { unGM :: forall a. Data a => a -> m a }+++-- | Left-biased choice on maybes+orElse :: Maybe a -> Maybe a -> Maybe a+x `orElse` y = case x of+ Just _ -> x+ Nothing -> y+++{-++The following variations take "orElse" to the function+level. Furthermore, we generalise from "Maybe" to any+"MonadPlus". This makes sense for monadic transformations and+queries. We say that the resulting combinators modell choice. We also+provide a prime example of choice, that is, recovery from failure. In+the case of transformations, we recover via return whereas for+queries a given constant is returned.++-}++-- | Choice for monadic transformations+choiceMp :: MonadPlus m => GenericM m -> GenericM m -> GenericM m+choiceMp f g x = f x `mplus` g x+++-- | Choice for monadic queries+choiceQ :: MonadPlus m => GenericQ (m r) -> GenericQ (m r) -> GenericQ (m r)+choiceQ f g x = f x `mplus` g x+++-- | Recover from the failure of monadic transformation by identity+recoverMp :: MonadPlus m => GenericM m -> GenericM m+recoverMp f = f `choiceMp` return+++-- | Recover from the failure of monadic query by a constant+recoverQ :: MonadPlus m => r -> GenericQ (m r) -> GenericQ (m r)+recoverQ r f = f `choiceQ` const (return r)++++------------------------------------------------------------------------------+-- Type extension for unary type constructors+------------------------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 707+#define Typeable1 Typeable+#define Typeable2 Typeable+#endif++-- | Flexible type extension+ext1 :: (Data a, Typeable1 t)+ => c a+ -> (forall d. Data d => c (t d))+ -> c a+ext1 def ext = maybe def id (dataCast1 ext)+++-- | Type extension of transformations for unary type constructors+ext1T :: (Data d, Typeable1 t)+ => (forall e. Data e => e -> e)+ -> (forall f. Data f => t f -> t f)+ -> d -> d+ext1T def ext = unT ((T def) `ext1` (T ext))+++-- | Type extension of monadic transformations for type constructors+ext1M :: (Monad m, Data d, Typeable1 t)+ => (forall e. Data e => e -> m e)+ -> (forall f. Data f => t f -> m (t f))+ -> d -> m d+ext1M def ext = unM ((M def) `ext1` (M ext))+++-- | Type extension of queries for type constructors+ext1Q :: (Data d, Typeable1 t)+ => (d -> q)+ -> (forall e. Data e => t e -> q)+ -> d -> q+ext1Q def ext = unQ ((Q def) `ext1` (Q ext))+++-- | Type extension of readers for type constructors+ext1R :: (Monad m, Data d, Typeable1 t)+ => m d+ -> (forall e. Data e => m (t e))+ -> m d+ext1R def ext = unR ((R def) `ext1` (R ext))+++-- | Type extension of builders for type constructors+ext1B :: (Data a, Typeable1 t)+ => a+ -> (forall b. Data b => (t b))+ -> a+ext1B def ext = unB ((B def) `ext1` (B ext))++------------------------------------------------------------------------------+-- Type extension for binary type constructors+------------------------------------------------------------------------------++-- | Flexible type extension+ext2 :: (Data a, Typeable2 t)+ => c a+ -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))+ -> c a+ext2 def ext = maybe def id (dataCast2 ext)+++-- | Type extension of transformations for unary type constructors+ext2T :: (Data d, Typeable2 t)+ => (forall e. Data e => e -> e)+ -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> t d1 d2)+ -> d -> d+ext2T def ext = unT ((T def) `ext2` (T ext))+++-- | Type extension of monadic transformations for type constructors+ext2M :: (Monad m, Data d, Typeable2 t)+ => (forall e. Data e => e -> m e)+ -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> m (t d1 d2))+ -> d -> m d+ext2M def ext = unM ((M def) `ext2` (M ext))+++-- | Type extension of queries for type constructors+ext2Q :: (Data d, Typeable2 t)+ => (d -> q)+ -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)+ -> d -> q+ext2Q def ext = unQ ((Q def) `ext2` (Q ext))+++-- | Type extension of readers for type constructors+ext2R :: (Monad m, Data d, Typeable2 t)+ => m d+ -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2))+ -> m d+ext2R def ext = unR ((R def) `ext2` (R ext))+++-- | Type extension of builders for type constructors+ext2B :: (Data a, Typeable2 t)+ => a+ -> (forall d1 d2. (Data d1, Data d2) => (t d1 d2))+ -> a+ext2B def ext = unB ((B def) `ext2` (B ext))++------------------------------------------------------------------------------+--+-- Type constructors for type-level lambdas+--+------------------------------------------------------------------------------+++-- | The type constructor for transformations+newtype T x = T { unT :: x -> x }++-- | The type constructor for transformations+newtype M m x = M { unM :: x -> m x }++-- | The type constructor for queries+newtype Q q x = Q { unQ :: x -> q }++-- | The type constructor for readers+newtype R m x = R { unR :: m x }++-- | The type constructor for builders+newtype B x = B {unB :: x}
src/Data/Generics/Instances.hs view
@@ -1,189 +1,189 @@-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Generics.Instances --- Copyright : (c) The University of Glasgow, CWI 2001--2004 --- License : BSD-style (see the LICENSE file) --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable (uses Data.Data) --- --- \"Scrap your boilerplate\" --- Generic programming in Haskell --- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module --- contains thirteen 'Data' instances which are considered dubious (either --- because the types are abstract or just not meant to be traversed). --- Instances in this module might change or disappear in future releases --- of this package. --- --- (This module does not export anything. It really just defines instances.) --- ------------------------------------------------------------------------------ - -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Data.Generics.Instances () where - ------------------------------------------------------------------------------- - -import Data.Data - -#ifdef __GLASGOW_HASKELL__ -#if __GLASGOW_HASKELL__ >= 611 -import GHC.IO.Handle -- So we can give Data instance for Handle -#else -import GHC.IOBase -- So we can give Data instance for IO, Handle -#endif -import GHC.Stable -- So we can give Data instance for StablePtr -import GHC.ST -- So we can give Data instance for ST -import GHC.Conc -- So we can give Data instance for TVar -import Data.IORef -- So we can give Data instance for IORef -import Control.Concurrent -- So we can give Data instance for MVar -#else -# ifdef __HUGS__ -import Hugs.Prelude( Ratio(..) ) -# endif -import System.IO -import Foreign.Ptr -import Foreign.ForeignPtr -import Foreign.StablePtr -import Control.Monad.ST -#endif - -#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. --- We define top-level definitions for representations. --- ------------------------------------------------------------------------------- - - ------------------------------------------------------------------------------- --- Instances of abstract datatypes (6) ------------------------------------------------------------------------------- - -instance Data TypeRep where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = myMkNoRepType "Data.Typeable.TypeRep" - - ------------------------------------------------------------------------------- - -instance Data TyCon where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = myMkNoRepType "Data.Typeable.TyCon" - - ------------------------------------------------------------------------------- - -INSTANCE_TYPEABLE0(DataType,dataTypeTc,"DataType") - -instance Data DataType where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = myMkNoRepType "Data.Generics.Basics.DataType" - - ------------------------------------------------------------------------------- - -instance Data Handle where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = myMkNoRepType "GHC.IOBase.Handle" - - ------------------------------------------------------------------------------- - -instance Typeable a => Data (StablePtr a) where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = myMkNoRepType "GHC.Stable.StablePtr" - - ------------------------------------------------------------------------------- - -#ifdef __GLASGOW_HASKELL__ -instance Data ThreadId where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = myMkNoRepType "GHC.Conc.ThreadId" -#endif - - ------------------------------------------------------------------------------- --- Dubious instances (7) ------------------------------------------------------------------------------- - -#ifdef __GLASGOW_HASKELL__ -instance Typeable a => Data (TVar a) where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = myMkNoRepType "GHC.Conc.TVar" -#endif - - ------------------------------------------------------------------------------- - -instance Typeable a => Data (MVar a) where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = myMkNoRepType "GHC.Conc.MVar" - - ------------------------------------------------------------------------------- - -#ifdef __GLASGOW_HASKELL__ -instance Typeable a => Data (STM a) where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = myMkNoRepType "GHC.Conc.STM" -#endif - - ------------------------------------------------------------------------------- - -instance (Typeable s, Typeable a) => Data (ST s a) where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = myMkNoRepType "GHC.ST.ST" - - ------------------------------------------------------------------------------- - -instance Typeable a => Data (IORef a) where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = myMkNoRepType "GHC.IOBase.IORef" - - ------------------------------------------------------------------------------- - -instance Typeable a => Data (IO a) where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = myMkNoRepType "GHC.IOBase.IO" - ------------------------------------------------------------------------------- - --- --- A last resort for functions --- - -instance (Data a, Data b) => Data (a -> b) where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = myMkNoRepType "Prelude.(->)" - dataCast2 f = gcast2 f - +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Generics.Instances+-- Copyright : (c) The University of Glasgow, CWI 2001--2004+-- License : BSD-style (see the LICENSE file)+-- +-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable (uses Data.Data)+--+-- \"Scrap your boilerplate\" --- Generic programming in Haskell +-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module+-- contains thirteen 'Data' instances which are considered dubious (either+-- because the types are abstract or just not meant to be traversed).+-- Instances in this module might change or disappear in future releases+-- of this package. +--+-- (This module does not export anything. It really just defines instances.)+--+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.Generics.Instances () where++------------------------------------------------------------------------------++import Data.Data++#ifdef __GLASGOW_HASKELL__+#if __GLASGOW_HASKELL__ >= 611+import GHC.IO.Handle -- So we can give Data instance for Handle+#else+import GHC.IOBase -- So we can give Data instance for IO, Handle+#endif+import GHC.Stable -- So we can give Data instance for StablePtr+import GHC.ST -- So we can give Data instance for ST+import GHC.Conc -- So we can give Data instance for TVar+import Data.IORef -- So we can give Data instance for IORef+import Control.Concurrent -- So we can give Data instance for MVar+#else+# ifdef __HUGS__+import Hugs.Prelude( Ratio(..) )+# endif+import System.IO+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.StablePtr+import Control.Monad.ST+#endif++-- Version compatibility issues caused by #2760+myMkNoRepType :: String -> DataType+#if __GLASGOW_HASKELL__ >= 611+myMkNoRepType = mkNoRepType+#else+myMkNoRepType = mkNorepType+#endif+++------------------------------------------------------------------------------+--+-- Instances of the Data class for Prelude-like types.+-- We define top-level definitions for representations.+--+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- Instances of abstract datatypes (6)+------------------------------------------------------------------------------++instance Data TypeRep where+ toConstr _ = error "toConstr"+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = myMkNoRepType "Data.Typeable.TypeRep"+++------------------------------------------------------------------------------++instance Data TyCon where+ toConstr _ = error "toConstr"+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = myMkNoRepType "Data.Typeable.TyCon"+++------------------------------------------------------------------------------+#if __GLASGOW_HASKELL__ < 709+#include "Typeable.h"+INSTANCE_TYPEABLE0(DataType,dataTypeTc,"DataType")+#endif++instance Data DataType where+ toConstr _ = error "toConstr"+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = myMkNoRepType "Data.Generics.Basics.DataType"+++------------------------------------------------------------------------------++instance Data Handle where+ toConstr _ = error "toConstr"+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = myMkNoRepType "GHC.IOBase.Handle"+++------------------------------------------------------------------------------++instance Typeable a => Data (StablePtr a) where+ toConstr _ = error "toConstr"+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = myMkNoRepType "GHC.Stable.StablePtr"+++------------------------------------------------------------------------------++#ifdef __GLASGOW_HASKELL__+instance Data ThreadId where+ toConstr _ = error "toConstr"+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = myMkNoRepType "GHC.Conc.ThreadId"+#endif+++------------------------------------------------------------------------------+-- Dubious instances (7)+------------------------------------------------------------------------------++#ifdef __GLASGOW_HASKELL__+instance Typeable a => Data (TVar a) where+ toConstr _ = error "toConstr"+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = myMkNoRepType "GHC.Conc.TVar"+#endif+++------------------------------------------------------------------------------++instance Typeable a => Data (MVar a) where+ toConstr _ = error "toConstr"+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = myMkNoRepType "GHC.Conc.MVar"+++------------------------------------------------------------------------------++#ifdef __GLASGOW_HASKELL__+instance Typeable a => Data (STM a) where+ toConstr _ = error "toConstr"+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = myMkNoRepType "GHC.Conc.STM"+#endif+++------------------------------------------------------------------------------++instance (Typeable s, Typeable a) => Data (ST s a) where+ toConstr _ = error "toConstr"+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = myMkNoRepType "GHC.ST.ST"+++------------------------------------------------------------------------------++instance Typeable a => Data (IORef a) where+ toConstr _ = error "toConstr"+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = myMkNoRepType "GHC.IOBase.IORef"+++------------------------------------------------------------------------------++instance Typeable a => Data (IO a) where+ toConstr _ = error "toConstr"+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = myMkNoRepType "GHC.IOBase.IO"++------------------------------------------------------------------------------++--+-- A last resort for functions+--++instance (Data a, Data b) => Data (a -> b) where+ toConstr _ = error "toConstr"+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = myMkNoRepType "Prelude.(->)"+ dataCast2 f = gcast2 f+
src/Data/Generics/Schemes.hs view
@@ -1,182 +1,182 @@-{-# LANGUAGE RankNTypes, ScopedTypeVariables, CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Generics.Schemes --- Copyright : (c) The University of Glasgow, CWI 2001--2003 --- License : BSD-style (see the LICENSE file) --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable (local universal quantification) --- --- \"Scrap your boilerplate\" --- Generic programming in Haskell --- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module --- provides frequently used generic traversal schemes. --- ------------------------------------------------------------------------------ - -module Data.Generics.Schemes ( - - everywhere, - everywhere', - everywhereBut, - everywhereM, - somewhere, - everything, - everythingBut, - everythingWithContext, - listify, - something, - synthesize, - gsize, - glength, - gdepth, - gcount, - gnodecount, - gtypecount, - gfindtype - - ) where - ------------------------------------------------------------------------------- - -#ifdef __HADDOCK__ -import Prelude -#endif -import Data.Data -import Data.Generics.Aliases -import Control.Monad - - --- | Apply a transformation everywhere in bottom-up manner -everywhere :: (forall a. Data a => a -> a) - -> (forall a. Data a => a -> a) - --- Use gmapT to recurse into immediate subterms; --- recall: gmapT preserves the outermost constructor; --- post-process recursively transformed result via f --- -everywhere f = f . gmapT (everywhere f) - - --- | Apply a transformation everywhere in top-down manner -everywhere' :: (forall a. Data a => a -> a) - -> (forall a. Data a => a -> a) - --- Arguments of (.) are flipped compared to everywhere -everywhere' f = gmapT (everywhere' f) . f - - --- | Variation on everywhere with an extra stop condition -everywhereBut :: GenericQ Bool -> GenericT -> GenericT - --- Guarded to let traversal cease if predicate q holds for x -everywhereBut q f x - | q x = x - | otherwise = f (gmapT (everywhereBut q f) x) - - --- | Monadic variation on everywhere -everywhereM :: Monad m => GenericM m -> GenericM m - --- Bottom-up order is also reflected in order of do-actions -everywhereM f x = do x' <- gmapM (everywhereM f) x - f x' - - --- | Apply a monadic transformation at least somewhere -somewhere :: MonadPlus m => GenericM m -> GenericM m - --- We try "f" in top-down manner, but descent into "x" when we fail --- at the root of the term. The transformation fails if "f" fails --- everywhere, say succeeds nowhere. --- -somewhere f x = f x `mplus` gmapMp (somewhere f) x - - --- | Summarise all nodes in top-down, left-to-right order -everything :: (r -> r -> r) -> GenericQ r -> GenericQ r - --- Apply f to x to summarise top-level node; --- use gmapQ to recurse into immediate subterms; --- use ordinary foldl to reduce list of intermediate results --- -everything k f x = foldl k (f x) (gmapQ (everything k f) x) - --- | Variation of "everything" with an added stop condition -everythingBut :: (r -> r -> r) -> GenericQ (r, Bool) -> GenericQ r -everythingBut k f x = let (v, stop) = f x - in if stop - then v - else foldl k v (gmapQ (everythingBut k f) x) - --- | Summarise all nodes in top-down, left-to-right order, carrying some state --- down the tree during the computation, but not left-to-right to siblings. -everythingWithContext :: s -> (r -> r -> r) -> GenericQ (s -> (r, s)) -> GenericQ r -everythingWithContext s0 f q x = - foldl f r (gmapQ (everythingWithContext s' f q) x) - where (r, s') = q x s0 - --- | Get a list of all entities that meet a predicate -listify :: Typeable r => (r -> Bool) -> GenericQ [r] -listify p = everything (++) ([] `mkQ` (\x -> if p x then [x] else [])) - - --- | Look up a subterm by means of a maybe-typed filter -something :: GenericQ (Maybe u) -> GenericQ (Maybe u) - --- "something" can be defined in terms of "everything" --- when a suitable "choice" operator is used for reduction --- -something = everything orElse - - --- | Bottom-up synthesis of a data structure; --- 1st argument z is the initial element for the synthesis; --- 2nd argument o is for reduction of results from subterms; --- 3rd argument f updates the synthesised data according to the given term --- -synthesize :: s -> (t -> s -> s) -> GenericQ (s -> t) -> GenericQ t -synthesize z o f x = f x (foldr o z (gmapQ (synthesize z o f) x)) - - --- | Compute size of an arbitrary data structure -gsize :: Data a => a -> Int -gsize t = 1 + sum (gmapQ gsize t) - - --- | Count the number of immediate subterms of the given term -glength :: GenericQ Int -glength = length . gmapQ (const ()) - - --- | Determine depth of the given term -gdepth :: GenericQ Int -gdepth = (+) 1 . foldr max 0 . gmapQ gdepth - - --- | Determine the number of all suitable nodes in a given term -gcount :: GenericQ Bool -> GenericQ Int -gcount p = everything (+) (\x -> if p x then 1 else 0) - - --- | Determine the number of all nodes in a given term -gnodecount :: GenericQ Int -gnodecount = gcount (const True) - - --- | Determine the number of nodes of a given type in a given term -gtypecount :: Typeable a => a -> GenericQ Int -gtypecount (_::a) = gcount (False `mkQ` (\(_::a) -> True)) - - --- | Find (unambiguously) an immediate subterm of a given type -gfindtype :: (Data x, Typeable y) => x -> Maybe y -gfindtype = singleton - . foldl unJust [] - . gmapQ (Nothing `mkQ` Just) - where - unJust l (Just x) = x:l - unJust l Nothing = l - singleton [s] = Just s - singleton _ = Nothing +{-# LANGUAGE RankNTypes, ScopedTypeVariables, CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Generics.Schemes+-- Copyright : (c) The University of Glasgow, CWI 2001--2003+-- License : BSD-style (see the LICENSE file)+-- +-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable (local universal quantification)+--+-- \"Scrap your boilerplate\" --- Generic programming in Haskell +-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module+-- provides frequently used generic traversal schemes.+--+-----------------------------------------------------------------------------++module Data.Generics.Schemes (++ everywhere,+ everywhere',+ everywhereBut,+ everywhereM,+ somewhere,+ everything,+ everythingBut,+ everythingWithContext,+ listify,+ something,+ synthesize,+ gsize,+ glength,+ gdepth,+ gcount,+ gnodecount,+ gtypecount,+ gfindtype++ ) where++------------------------------------------------------------------------------++#ifdef __HADDOCK__+import Prelude+#endif+import Data.Data+import Data.Generics.Aliases+import Control.Monad+++-- | Apply a transformation everywhere in bottom-up manner+everywhere :: (forall a. Data a => a -> a)+ -> (forall a. Data a => a -> a)++-- Use gmapT to recurse into immediate subterms;+-- recall: gmapT preserves the outermost constructor;+-- post-process recursively transformed result via f+-- +everywhere f = f . gmapT (everywhere f)+++-- | Apply a transformation everywhere in top-down manner+everywhere' :: (forall a. Data a => a -> a)+ -> (forall a. Data a => a -> a)++-- Arguments of (.) are flipped compared to everywhere+everywhere' f = gmapT (everywhere' f) . f+++-- | Variation on everywhere with an extra stop condition+everywhereBut :: GenericQ Bool -> GenericT -> GenericT++-- Guarded to let traversal cease if predicate q holds for x+everywhereBut q f x+ | q x = x+ | otherwise = f (gmapT (everywhereBut q f) x)+++-- | Monadic variation on everywhere+everywhereM :: Monad m => GenericM m -> GenericM m++-- Bottom-up order is also reflected in order of do-actions+everywhereM f x = do x' <- gmapM (everywhereM f) x+ f x'+++-- | Apply a monadic transformation at least somewhere+somewhere :: MonadPlus m => GenericM m -> GenericM m++-- We try "f" in top-down manner, but descent into "x" when we fail+-- at the root of the term. The transformation fails if "f" fails+-- everywhere, say succeeds nowhere.+-- +somewhere f x = f x `mplus` gmapMp (somewhere f) x+++-- | Summarise all nodes in top-down, left-to-right order+everything :: (r -> r -> r) -> GenericQ r -> GenericQ r++-- Apply f to x to summarise top-level node;+-- use gmapQ to recurse into immediate subterms;+-- use ordinary foldl to reduce list of intermediate results+-- +everything k f x = foldl k (f x) (gmapQ (everything k f) x)++-- | Variation of "everything" with an added stop condition+everythingBut :: (r -> r -> r) -> GenericQ (r, Bool) -> GenericQ r+everythingBut k f x = let (v, stop) = f x+ in if stop+ then v+ else foldl k v (gmapQ (everythingBut k f) x)++-- | Summarise all nodes in top-down, left-to-right order, carrying some state+-- down the tree during the computation, but not left-to-right to siblings.+everythingWithContext :: s -> (r -> r -> r) -> GenericQ (s -> (r, s)) -> GenericQ r+everythingWithContext s0 f q x =+ foldl f r (gmapQ (everythingWithContext s' f q) x)+ where (r, s') = q x s0++-- | Get a list of all entities that meet a predicate+listify :: Typeable r => (r -> Bool) -> GenericQ [r]+listify p = everything (++) ([] `mkQ` (\x -> if p x then [x] else []))+++-- | Look up a subterm by means of a maybe-typed filter+something :: GenericQ (Maybe u) -> GenericQ (Maybe u)++-- "something" can be defined in terms of "everything"+-- when a suitable "choice" operator is used for reduction+-- +something = everything orElse+++-- | Bottom-up synthesis of a data structure;+-- 1st argument z is the initial element for the synthesis;+-- 2nd argument o is for reduction of results from subterms;+-- 3rd argument f updates the synthesised data according to the given term+--+synthesize :: s -> (t -> s -> s) -> GenericQ (s -> t) -> GenericQ t+synthesize z o f x = f x (foldr o z (gmapQ (synthesize z o f) x))+++-- | Compute size of an arbitrary data structure+gsize :: Data a => a -> Int+gsize t = 1 + sum (gmapQ gsize t)+++-- | Count the number of immediate subterms of the given term+glength :: GenericQ Int+glength = length . gmapQ (const ())+++-- | Determine depth of the given term+gdepth :: GenericQ Int+gdepth = (+) 1 . foldr max 0 . gmapQ gdepth+++-- | Determine the number of all suitable nodes in a given term+gcount :: GenericQ Bool -> GenericQ Int+gcount p = everything (+) (\x -> if p x then 1 else 0)+++-- | Determine the number of all nodes in a given term+gnodecount :: GenericQ Int+gnodecount = gcount (const True)+++-- | Determine the number of nodes of a given type in a given term+gtypecount :: Typeable a => a -> GenericQ Int+gtypecount (_::a) = gcount (False `mkQ` (\(_::a) -> True))+++-- | Find (unambiguously) an immediate subterm of a given type+gfindtype :: (Data x, Typeable y) => x -> Maybe y+gfindtype = singleton+ . foldl unJust []+ . gmapQ (Nothing `mkQ` Just)+ where+ unJust l (Just x) = x:l+ unJust l Nothing = l+ singleton [s] = Just s+ singleton _ = Nothing
src/Data/Generics/Text.hs view
@@ -1,130 +1,130 @@-{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Generics.Text --- Copyright : (c) The University of Glasgow, CWI 2001--2003 --- License : BSD-style (see the LICENSE file) --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable (uses Data.Generics.Basics) --- --- \"Scrap your boilerplate\" --- Generic programming in Haskell --- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module --- provides generic operations for text serialisation of terms. --- ------------------------------------------------------------------------------ - -module Data.Generics.Text ( - - -- * Generic show - gshow, gshows, - - -- * Generic read - gread - - ) where - ------------------------------------------------------------------------------- - -#ifdef __HADDOCK__ -import Prelude -#endif -import Control.Monad -import Data.Data -import Data.Generics.Aliases -import Text.ParserCombinators.ReadP - ------------------------------------------------------------------------------- - - --- | Generic show: an alternative to \"deriving Show\" -gshow :: Data a => a -> String -gshow x = gshows x "" - --- | Generic shows -gshows :: Data a => a -> ShowS - --- This is a prefix-show using surrounding "(" and ")", --- where we recurse into subterms with gmapQ. -gshows = ( \t -> - showChar '(' - . (showString . showConstr . toConstr $ t) - . (foldr (.) id . gmapQ ((showChar ' ' .) . gshows) $ t) - . showChar ')' - ) `extQ` (shows :: String -> ShowS) - - --- | Generic read: an alternative to \"deriving Read\" -gread :: Data a => ReadS a - -{- - -This is a read operation which insists on prefix notation. (The -Haskell 98 read deals with infix operators subject to associativity -and precedence as well.) We use fromConstrM to "parse" the input. To be -precise, fromConstrM is used for all types except String. The -type-specific case for String uses basic String read. - --} - -gread = readP_to_S gread' - - where - - -- Helper for recursive read - gread' :: Data a' => ReadP a' - gread' = allButString `extR` stringCase - - where - - -- A specific case for strings - stringCase :: ReadP String - stringCase = readS_to_P reads - - -- Determine result type - myDataType = dataTypeOf (getArg allButString) - where - getArg :: ReadP a'' -> a'' - getArg = undefined - - -- The generic default for gread - allButString = - do - -- Drop " ( " - skipSpaces -- Discard leading space - _ <- char '(' -- Parse '(' - skipSpaces -- Discard following space - - -- Do the real work - str <- parseConstr -- Get a lexeme for the constructor - con <- str2con str -- Convert it to a Constr (may fail) - x <- fromConstrM gread' con -- Read the children - - -- Drop " ) " - skipSpaces -- Discard leading space - _ <- char ')' -- Parse ')' - skipSpaces -- Discard following space - - return x - - -- Turn string into constructor driven by the requested result type, - -- failing in the monad if it isn't a constructor of this data type - str2con :: String -> ReadP Constr - str2con = maybe mzero return - . readConstr myDataType - - -- Get a Constr's string at the front of an input string - parseConstr :: ReadP String - parseConstr = - string "[]" -- Compound lexeme "[]" - <++ string "()" -- singleton "()" - <++ infixOp -- Infix operator in parantheses - <++ readS_to_P lex -- Ordinary constructors and literals - - -- Handle infix operators such as (:) - infixOp :: ReadP String - infixOp = do c1 <- char '(' - str <- munch1 (not . (==) ')') - c2 <- char ')' - return $ [c1] ++ str ++ [c2] +{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Generics.Text+-- Copyright : (c) The University of Glasgow, CWI 2001--2003+-- License : BSD-style (see the LICENSE file)+-- +-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable (uses Data.Generics.Basics)+--+-- \"Scrap your boilerplate\" --- Generic programming in Haskell +-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module+-- provides generic operations for text serialisation of terms.+--+-----------------------------------------------------------------------------++module Data.Generics.Text (++ -- * Generic show+ gshow, gshows,++ -- * Generic read+ gread++ ) where++------------------------------------------------------------------------------++#ifdef __HADDOCK__+import Prelude+#endif+import Control.Monad+import Data.Data+import Data.Generics.Aliases+import Text.ParserCombinators.ReadP++------------------------------------------------------------------------------+++-- | Generic show: an alternative to \"deriving Show\"+gshow :: Data a => a -> String+gshow x = gshows x ""++-- | Generic shows+gshows :: Data a => a -> ShowS++-- This is a prefix-show using surrounding "(" and ")",+-- where we recurse into subterms with gmapQ.+gshows = ( \t ->+ showChar '('+ . (showString . showConstr . toConstr $ t)+ . (foldr (.) id . gmapQ ((showChar ' ' .) . gshows) $ t)+ . showChar ')'+ ) `extQ` (shows :: String -> ShowS)+++-- | Generic read: an alternative to \"deriving Read\"+gread :: Data a => ReadS a++{-++This is a read operation which insists on prefix notation. (The+Haskell 98 read deals with infix operators subject to associativity+and precedence as well.) We use fromConstrM to "parse" the input. To be+precise, fromConstrM is used for all types except String. The+type-specific case for String uses basic String read.++-}++gread = readP_to_S gread'++ where++ -- Helper for recursive read+ gread' :: Data a' => ReadP a'+ gread' = allButString `extR` stringCase++ where++ -- A specific case for strings+ stringCase :: ReadP String+ stringCase = readS_to_P reads++ -- Determine result type+ myDataType = dataTypeOf (getArg allButString)+ where+ getArg :: ReadP a'' -> a''+ getArg = undefined++ -- The generic default for gread+ allButString =+ do+ -- Drop " ( "+ skipSpaces -- Discard leading space+ _ <- char '(' -- Parse '('+ skipSpaces -- Discard following space++ -- Do the real work+ str <- parseConstr -- Get a lexeme for the constructor+ con <- str2con str -- Convert it to a Constr (may fail)+ x <- fromConstrM gread' con -- Read the children++ -- Drop " ) "+ skipSpaces -- Discard leading space+ _ <- char ')' -- Parse ')'+ skipSpaces -- Discard following space++ return x++ -- Turn string into constructor driven by the requested result type,+ -- failing in the monad if it isn't a constructor of this data type+ str2con :: String -> ReadP Constr+ str2con = maybe mzero return+ . readConstr myDataType++ -- Get a Constr's string at the front of an input string+ parseConstr :: ReadP String+ parseConstr =+ string "[]" -- Compound lexeme "[]"+ <++ string "()" -- singleton "()"+ <++ infixOp -- Infix operator in parantheses+ <++ readS_to_P lex -- Ordinary constructors and literals++ -- Handle infix operators such as (:)+ infixOp :: ReadP String+ infixOp = do c1 <- char '('+ str <- munch1 (not . (==) ')')+ c2 <- char ')'+ return $ [c1] ++ str ++ [c2]
src/Data/Generics/Twins.hs view
@@ -1,270 +1,270 @@-{-# LANGUAGE RankNTypes, ScopedTypeVariables, CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Generics.Twins --- Copyright : (c) The University of Glasgow, CWI 2001--2004 --- License : BSD-style (see the LICENSE file) --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable (local universal quantification) --- --- \"Scrap your boilerplate\" --- Generic programming in Haskell --- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module --- provides support for multi-parameter traversal, which is also --- demonstrated with generic operations like equality. --- ------------------------------------------------------------------------------ - -module Data.Generics.Twins ( - - -- * Generic folds and maps that also accumulate - gfoldlAccum, - gmapAccumT, - gmapAccumM, - gmapAccumQl, - gmapAccumQr, - gmapAccumQ, - gmapAccumA, - - -- * Mapping combinators for twin traversal - gzipWithT, - gzipWithM, - gzipWithQ, - - -- * Typical twin traversals - geq, - gzip - - ) where - - ------------------------------------------------------------------------------- - -#ifdef __HADDOCK__ -import Prelude -#endif -import Data.Data -import Data.Generics.Aliases - -#ifdef __GLASGOW_HASKELL__ -import Prelude hiding ( GT ) -#endif - -import Control.Applicative (Applicative(..)) - ------------------------------------------------------------------------------- - - ------------------------------------------------------------------------------- --- --- Generic folds and maps that also accumulate --- ------------------------------------------------------------------------------- - -{-------------------------------------------------------------- - -A list map can be elaborated to perform accumulation. -In the same sense, we can elaborate generic maps over terms. - -We recall the type of map: -map :: (a -> b) -> [a] -> [b] - -We recall the type of an accumulating map (see Data.List): -mapAccumL :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c]) - -Applying the same scheme we obtain an accumulating gfoldl. - ---------------------------------------------------------------} - --- | gfoldl with accumulation - -gfoldlAccum :: Data d - => (forall e r. Data e => a -> c (e -> r) -> e -> (a, c r)) - -> (forall g. a -> g -> (a, c g)) - -> a -> d -> (a, c d) - -gfoldlAccum k z a0 d = unA (gfoldl k' z' d) a0 - where - k' c y = A (\a -> let (a', c') = unA c a in k a' c' y) - z' f = A (\a -> z a f) - - --- | A type constructor for accumulation -newtype A a c d = A { unA :: a -> (a, c d) } - - --- | gmapT with accumulation -gmapAccumT :: Data d - => (forall e. Data e => a -> e -> (a,e)) - -> a -> d -> (a, d) -gmapAccumT f a0 d0 = let (a1, d1) = gfoldlAccum k z a0 d0 - in (a1, unID d1) - where - k a (ID c) d = let (a',d') = f a d - in (a', ID (c d')) - z a x = (a, ID x) - - --- | Applicative version -gmapAccumA :: forall b d a. (Data d, Applicative a) - => (forall e. Data e => b -> e -> (b, a e)) - -> b -> d -> (b, a d) -gmapAccumA f a0 d0 = gfoldlAccum k z a0 d0 - where - k :: forall d' e. (Data d') => - b -> a (d' -> e) -> d' -> (b, a e) - k a c d = let (a',d') = f a d - c' = c <*> d' - in (a', c') - z :: forall t c a'. (Applicative a') => - t -> c -> (t, a' c) - z a x = (a, pure x) - - --- | gmapM with accumulation -gmapAccumM :: (Data d, Monad m) - => (forall e. Data e => a -> e -> (a, m e)) - -> a -> d -> (a, m d) -gmapAccumM f = gfoldlAccum k z - where - k a c d = let (a',d') = f a d - in (a', d' >>= \d'' -> c >>= \c' -> return (c' d'')) - z a x = (a, return x) - - --- | gmapQl with accumulation -gmapAccumQl :: Data d - => (r -> r' -> r) - -> r - -> (forall e. Data e => a -> e -> (a,r')) - -> a -> d -> (a, r) -gmapAccumQl o r0 f a0 d0 = let (a1, r1) = gfoldlAccum k z a0 d0 - in (a1, unCONST r1) - where - k a (CONST c) d = let (a', r) = f a d - in (a', CONST (c `o` r)) - z a _ = (a, CONST r0) - - --- | gmapQr with accumulation -gmapAccumQr :: Data d - => (r' -> r -> r) - -> r - -> (forall e. Data e => a -> e -> (a,r')) - -> a -> d -> (a, r) -gmapAccumQr o r0 f a0 d0 = let (a1, l) = gfoldlAccum k z a0 d0 - in (a1, unQr l r0) - where - k a (Qr c) d = let (a',r') = f a d - in (a', Qr (\r -> c (r' `o` r))) - z a _ = (a, Qr id) - - --- | gmapQ with accumulation -gmapAccumQ :: Data d - => (forall e. Data e => a -> e -> (a,q)) - -> a -> d -> (a, [q]) -gmapAccumQ f = gmapAccumQr (:) [] f - - - ------------------------------------------------------------------------------- --- --- Helper type constructors --- ------------------------------------------------------------------------------- - - --- | The identity type constructor needed for the definition of gmapAccumT -newtype ID x = ID { unID :: x } - - --- | The constant type constructor needed for the definition of gmapAccumQl -newtype CONST c a = CONST { unCONST :: c } - - --- | The type constructor needed for the definition of gmapAccumQr -newtype Qr r a = Qr { unQr :: r -> r } - - - ------------------------------------------------------------------------------- --- --- Mapping combinators for twin traversal --- ------------------------------------------------------------------------------- - - --- | Twin map for transformation -gzipWithT :: GenericQ (GenericT) -> GenericQ (GenericT) -gzipWithT f x y = case gmapAccumT perkid funs y of - ([], c) -> c - _ -> error "gzipWithT" - where - perkid a d = (tail a, unGT (head a) d) - funs = gmapQ (\k -> GT (f k)) x - - - --- | Twin map for monadic transformation -gzipWithM :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m) -gzipWithM f x y = case gmapAccumM perkid funs y of - ([], c) -> c - _ -> error "gzipWithM" - where - perkid a d = (tail a, unGM (head a) d) - funs = gmapQ (\k -> GM (f k)) x - - --- | Twin map for queries -gzipWithQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r]) -gzipWithQ f x y = case gmapAccumQ perkid funs y of - ([], r) -> r - _ -> error "gzipWithQ" - where - perkid a d = (tail a, unGQ (head a) d) - funs = gmapQ (\k -> GQ (f k)) x - - - ------------------------------------------------------------------------------- --- --- Typical twin traversals --- ------------------------------------------------------------------------------- - --- | Generic equality: an alternative to \"deriving Eq\" -geq :: Data a => a -> a -> Bool - -{- - -Testing for equality of two terms goes like this. Firstly, we -establish the equality of the two top-level datatype -constructors. Secondly, we use a twin gmap combinator, namely tgmapQ, -to compare the two lists of immediate subterms. - -(Note for the experts: the type of the worker geq' is rather general -but precision is recovered via the restrictive type of the top-level -operation geq. The imprecision of geq' is caused by the type system's -unability to express the type equivalence for the corresponding -couples of immediate subterms from the two given input terms.) - --} - -geq x0 y0 = geq' x0 y0 - where - geq' :: GenericQ (GenericQ Bool) - geq' x y = (toConstr x == toConstr y) - && and (gzipWithQ geq' x y) - - --- | Generic zip controlled by a function with type-specific branches -gzip :: GenericQ (GenericM Maybe) -> GenericQ (GenericM Maybe) --- See testsuite/.../Generics/gzip.hs for an illustration -gzip f x y = - f x y - `orElse` - if toConstr x == toConstr y - then gzipWithM (gzip f) x y - else Nothing +{-# LANGUAGE RankNTypes, ScopedTypeVariables, CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Generics.Twins+-- Copyright : (c) The University of Glasgow, CWI 2001--2004+-- License : BSD-style (see the LICENSE file)+-- +-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable (local universal quantification)+--+-- \"Scrap your boilerplate\" --- Generic programming in Haskell +-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module +-- provides support for multi-parameter traversal, which is also +-- demonstrated with generic operations like equality.+--+-----------------------------------------------------------------------------++module Data.Generics.Twins (++ -- * Generic folds and maps that also accumulate+ gfoldlAccum,+ gmapAccumT,+ gmapAccumM,+ gmapAccumQl,+ gmapAccumQr,+ gmapAccumQ,+ gmapAccumA,++ -- * Mapping combinators for twin traversal+ gzipWithT,+ gzipWithM,+ gzipWithQ,++ -- * Typical twin traversals+ geq,+ gzip++ ) where+++------------------------------------------------------------------------------++#ifdef __HADDOCK__+import Prelude+#endif+import Data.Data+import Data.Generics.Aliases++#ifdef __GLASGOW_HASKELL__+import Prelude hiding ( GT )+#endif++import Control.Applicative (Applicative(..))++------------------------------------------------------------------------------+++------------------------------------------------------------------------------+--+-- Generic folds and maps that also accumulate+--+------------------------------------------------------------------------------++{--------------------------------------------------------------++A list map can be elaborated to perform accumulation.+In the same sense, we can elaborate generic maps over terms.++We recall the type of map:+map :: (a -> b) -> [a] -> [b]++We recall the type of an accumulating map (see Data.List):+mapAccumL :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])++Applying the same scheme we obtain an accumulating gfoldl.++--------------------------------------------------------------}++-- | gfoldl with accumulation++gfoldlAccum :: Data d+ => (forall e r. Data e => a -> c (e -> r) -> e -> (a, c r))+ -> (forall g. a -> g -> (a, c g))+ -> a -> d -> (a, c d)++gfoldlAccum k z a0 d = unA (gfoldl k' z' d) a0+ where+ k' c y = A (\a -> let (a', c') = unA c a in k a' c' y)+ z' f = A (\a -> z a f)+++-- | A type constructor for accumulation+newtype A a c d = A { unA :: a -> (a, c d) }+++-- | gmapT with accumulation+gmapAccumT :: Data d+ => (forall e. Data e => a -> e -> (a,e))+ -> a -> d -> (a, d)+gmapAccumT f a0 d0 = let (a1, d1) = gfoldlAccum k z a0 d0+ in (a1, unID d1)+ where+ k a (ID c) d = let (a',d') = f a d+ in (a', ID (c d'))+ z a x = (a, ID x)+++-- | Applicative version+gmapAccumA :: forall b d a. (Data d, Applicative a)+ => (forall e. Data e => b -> e -> (b, a e))+ -> b -> d -> (b, a d)+gmapAccumA f a0 d0 = gfoldlAccum k z a0 d0+ where+ k :: forall d' e. (Data d') =>+ b -> a (d' -> e) -> d' -> (b, a e)+ k a c d = let (a',d') = f a d+ c' = c <*> d'+ in (a', c')+ z :: forall t c a'. (Applicative a') =>+ t -> c -> (t, a' c)+ z a x = (a, pure x)+++-- | gmapM with accumulation+gmapAccumM :: (Data d, Monad m)+ => (forall e. Data e => a -> e -> (a, m e))+ -> a -> d -> (a, m d)+gmapAccumM f = gfoldlAccum k z+ where+ k a c d = let (a',d') = f a d+ in (a', d' >>= \d'' -> c >>= \c' -> return (c' d''))+ z a x = (a, return x)+++-- | gmapQl with accumulation+gmapAccumQl :: Data d+ => (r -> r' -> r)+ -> r+ -> (forall e. Data e => a -> e -> (a,r'))+ -> a -> d -> (a, r)+gmapAccumQl o r0 f a0 d0 = let (a1, r1) = gfoldlAccum k z a0 d0+ in (a1, unCONST r1)+ where+ k a (CONST c) d = let (a', r) = f a d+ in (a', CONST (c `o` r))+ z a _ = (a, CONST r0)+++-- | gmapQr with accumulation+gmapAccumQr :: Data d+ => (r' -> r -> r)+ -> r+ -> (forall e. Data e => a -> e -> (a,r'))+ -> a -> d -> (a, r)+gmapAccumQr o r0 f a0 d0 = let (a1, l) = gfoldlAccum k z a0 d0+ in (a1, unQr l r0)+ where+ k a (Qr c) d = let (a',r') = f a d+ in (a', Qr (\r -> c (r' `o` r)))+ z a _ = (a, Qr id)+++-- | gmapQ with accumulation+gmapAccumQ :: Data d+ => (forall e. Data e => a -> e -> (a,q))+ -> a -> d -> (a, [q])+gmapAccumQ f = gmapAccumQr (:) [] f++++------------------------------------------------------------------------------+--+-- Helper type constructors+--+------------------------------------------------------------------------------+++-- | The identity type constructor needed for the definition of gmapAccumT+newtype ID x = ID { unID :: x }+++-- | The constant type constructor needed for the definition of gmapAccumQl+newtype CONST c a = CONST { unCONST :: c }+++-- | The type constructor needed for the definition of gmapAccumQr+newtype Qr r a = Qr { unQr :: r -> r }++++------------------------------------------------------------------------------+--+-- Mapping combinators for twin traversal+--+------------------------------------------------------------------------------+++-- | Twin map for transformation +gzipWithT :: GenericQ (GenericT) -> GenericQ (GenericT)+gzipWithT f x y = case gmapAccumT perkid funs y of+ ([], c) -> c+ _ -> error "gzipWithT"+ where+ perkid a d = (tail a, unGT (head a) d)+ funs = gmapQ (\k -> GT (f k)) x++++-- | Twin map for monadic transformation +gzipWithM :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m)+gzipWithM f x y = case gmapAccumM perkid funs y of+ ([], c) -> c+ _ -> error "gzipWithM"+ where+ perkid a d = (tail a, unGM (head a) d)+ funs = gmapQ (\k -> GM (f k)) x+++-- | Twin map for queries+gzipWithQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r])+gzipWithQ f x y = case gmapAccumQ perkid funs y of+ ([], r) -> r+ _ -> error "gzipWithQ"+ where+ perkid a d = (tail a, unGQ (head a) d)+ funs = gmapQ (\k -> GQ (f k)) x++++------------------------------------------------------------------------------+--+-- Typical twin traversals+--+------------------------------------------------------------------------------++-- | Generic equality: an alternative to \"deriving Eq\"+geq :: Data a => a -> a -> Bool++{-++Testing for equality of two terms goes like this. Firstly, we+establish the equality of the two top-level datatype+constructors. Secondly, we use a twin gmap combinator, namely tgmapQ,+to compare the two lists of immediate subterms.++(Note for the experts: the type of the worker geq' is rather general+but precision is recovered via the restrictive type of the top-level+operation geq. The imprecision of geq' is caused by the type system's+unability to express the type equivalence for the corresponding+couples of immediate subterms from the two given input terms.)++-}++geq x0 y0 = geq' x0 y0+ where+ geq' :: GenericQ (GenericQ Bool)+ geq' x y = (toConstr x == toConstr y)+ && and (gzipWithQ geq' x y)+++-- | Generic zip controlled by a function with type-specific branches+gzip :: GenericQ (GenericM Maybe) -> GenericQ (GenericM Maybe)+-- See testsuite/.../Generics/gzip.hs for an illustration+gzip f x y =+ f x y+ `orElse`+ if toConstr x == toConstr y+ then gzipWithM (gzip f) x y+ else Nothing
syb.cabal view
@@ -1,64 +1,64 @@-name: syb -version: 0.4.1 -license: BSD3 -license-file: LICENSE -author: Ralf Lammel, Simon Peyton Jones, Jose Pedro Magalhaes -maintainer: generics@haskell.org -homepage: http://www.cs.uu.nl/wiki/GenericProgramming/SYB -bug-reports: http://code.google.com/p/scrapyourboilerplate/issues/list -synopsis: Scrap Your Boilerplate -description: - This package contains the generics system described in the - /Scrap Your Boilerplate/ papers (see - <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>). - It defines the @Data@ class of types permitting folding and unfolding - of constructor applications, instances of this class for primitive - types, and a variety of traversals. - -category: Generics -stability: provisional -build-type: Simple -cabal-version: >= 1.8 - -extra-source-files: tests/*.hs, - README - -source-repository head - type: git - location: https://github.com/dreixel/syb - -Library - hs-source-dirs: src - build-depends: base >= 4.0 && < 5.0 - exposed-modules: Data.Generics, - Data.Generics.Basics, - Data.Generics.Instances, - Data.Generics.Aliases, - Data.Generics.Schemes, - Data.Generics.Text, - Data.Generics.Twins, - Data.Generics.Builders, - - Generics.SYB, - Generics.SYB.Basics, - Generics.SYB.Instances, - Generics.SYB.Aliases, - Generics.SYB.Schemes, - Generics.SYB.Text, - Generics.SYB.Twins, - Generics.SYB.Builders - - if impl(ghc < 6.12) - ghc-options: -package-name syb - - ghc-options: -Wall - -test-suite unit-tests - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: Main.hs - build-depends: base - , syb - , HUnit - , containers - , mtl +name: syb+version: 0.4.2+license: BSD3+license-file: LICENSE+author: Ralf Lammel, Simon Peyton Jones, Jose Pedro Magalhaes+maintainer: generics@haskell.org+homepage: http://www.cs.uu.nl/wiki/GenericProgramming/SYB+bug-reports: http://code.google.com/p/scrapyourboilerplate/issues/list+synopsis: Scrap Your Boilerplate+description:+ This package contains the generics system described in the+ /Scrap Your Boilerplate/ papers (see + <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>).+ It defines the @Data@ class of types permitting folding and unfolding+ of constructor applications, instances of this class for primitive+ types, and a variety of traversals.++category: Generics+stability: provisional+build-type: Simple+cabal-version: >= 1.8++extra-source-files: tests/*.hs,+ README++source-repository head+ type: git+ location: https://github.com/dreixel/syb++Library+ hs-source-dirs: src+ build-depends: base >= 4.0 && < 5.0+ exposed-modules: Data.Generics,+ Data.Generics.Basics,+ Data.Generics.Instances,+ Data.Generics.Aliases,+ Data.Generics.Schemes,+ Data.Generics.Text,+ Data.Generics.Twins,+ Data.Generics.Builders,+ + Generics.SYB,+ Generics.SYB.Basics,+ Generics.SYB.Instances,+ Generics.SYB.Aliases,+ Generics.SYB.Schemes,+ Generics.SYB.Text,+ Generics.SYB.Twins,+ Generics.SYB.Builders++ if impl(ghc < 6.12) + ghc-options: -package-name syb+ + ghc-options: -Wall++test-suite unit-tests+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Main.hs+ build-depends: base+ , syb+ , HUnit+ , containers+ , mtl
tests/Bits.hs view
@@ -1,214 +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 Data.Maybe -import Control.Monad -import CompanyDatatypes - - - ------------------------------------------------------------------------------ - - - --- | We need bits and bit streams. -data Bit = Zero | One deriving (Show, Eq, Typeable, Data) -type Bin = [Bit] - - - ------------------------------------------------------------------------------ - - - --- Compute length of bit stream for a natural -lengthNat :: Int -> Int -lengthNat x = ceiling (logBase 2 (fromIntegral (x + 1))) - - --- Encode a natural as a bit stream -varNat2bin :: Int -> Bin -varNat2bin 0 = [] -varNat2bin x = - ( ( if even x then Zero else One ) - : varNat2bin (x `div` 2) - ) - - --- Encode a natural as a bit stream of fixed length -fixedNat2bin :: Int -> Int -> Bin -fixedNat2bin 0 0 = [] -fixedNat2bin p x | p>0 = - ( ( if even x then Zero else One ) - : fixedNat2bin (p - 1) (x `div` 2) - ) - - --- Decode a natural -bin2nat :: Bin -> Int -bin2nat [] = 0 -bin2nat (Zero : bs) = 2 * (bin2nat bs) -bin2nat (One : bs) = 2 * (bin2nat bs) + 1 - - - ------------------------------------------------------------------------------ - - - --- | Generically map terms to bit streams -showBin :: Data t => t -> Bin - -showBin t - = if isAlgType myDataType - then con2bin ++ concat (gmapQ showBin t) - else showBin base - - where - - -- The datatype for introspection - myDataType = dataTypeOf t - - -- Obtain the maximum index for the type at hand - max :: Int - max = maxConstrIndex myDataType - - -- Obtain the index for the constructor at hand - idx :: Int - idx = constrIndex (toConstr t) - - -- Map basic values to strings, then to lists of bit streams - base = map (varNat2bin . ord) (showConstr (toConstr t)) - - -- Map constructors to bit streams of fixed length - con2bin = fixedNat2bin (lengthNat (max - 1)) (idx - 1) - - ------------------------------------------------------------------------------ - - - --- | A monad on bit streams -data ReadB a = ReadB (Bin -> (Maybe a, Bin)) -unReadB (ReadB f) = f - - --- It's a monad. -instance Monad ReadB where - return a = ReadB (\bs -> (Just a, bs)) - (ReadB c) >>= f = ReadB (\bs -> case c bs of - (Just a, bs') -> unReadB (f a) bs' - (Nothing, bs') -> (Nothing, bs') - ) - - --- It's a bit monad with 0 and +. -instance MonadPlus ReadB where - mzero = ReadB (\bs -> (Nothing, bs)) - (ReadB f) `mplus` (ReadB g) = ReadB (\bs -> case f bs of - (Just a, bs') -> (Just a, bs') - (Nothing, _) -> g bs - ) - - --- Read a few bits -readB :: Int -> ReadB Bin -readB x = ReadB (\bs -> if length bs >= x - then (Just (take x bs), drop x bs) - else (Nothing, bs) - ) - - - ------------------------------------------------------------------------------ - - - --- | Generically map bit streams to terms -readBin :: Data t => ReadB t -readBin = result - where - - -- The worker, which we also use as type argument - result = if isAlgType myDataType - - then do bin <- readB (lengthNat (max - 1)) - fromConstrM readBin (bin2con bin) - - else do str <- readBin - con <- str2con (map (chr . bin2nat) str) - return (fromConstr con) - - -- Determine result type - myDataType = dataTypeOf (getArg result) - where - getArg :: ReadB a -> a - getArg = undefined - - -- Obtain the maximum index for the type at hand - max :: Int - max = maxConstrIndex myDataType - - -- Convert a bit stream into a constructor - bin2con :: Bin -> Constr - bin2con bin = indexConstr myDataType ((bin2nat bin) + 1) - - -- Convert string to constructor; could fail - str2con :: String -> ReadB Constr - str2con = maybe mzero return - . readConstr myDataType - - - ------------------------------------------------------------------------------ - - - -tests = ( showBin True - , ( showBin [True] - , ( showBin (1::Int) - , ( showBin "1" - , ( showBin genCom - , ( geq genCom genCom' - )))))) ~=? output - where - genCom' = fromJust (fst (unReadB readBin (showBin genCom))) :: Company - -output = ([One],([One,One,Zero],([One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero],([One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero],([One,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,Zero,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,One,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,One,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,Zero,One,Zero,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,One,One,Zero,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,One,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,One,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,One,One,Zero,One,One,One,One,One,One,One,One,Zero,One,Zero,One,One,Zero,Zero,Zero,One,One,One,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,One,One,Zero,One,One,One,One,One,One,One,Zero,One,One,Zero,One,One,Zero,One,Zero,One,Zero,One,Zero,One,One,One,One,Zero,Zero,Zero,Zero],True))))) +{-# OPTIONS -fglasgow-exts #-}++module Bits (tests) where++{-+ +This test exercices some oldies of generic programming, namely+encoding terms as bit streams and decoding these bit streams in turn+to obtain terms again. (This sort of function might actually be useful+for serialisation and sending companies and other terms over the+internet.)++Here is how it works.++A constuctor is encoded as a bit stream. To this end, we encode the+index of the constructor as a binary number of a fixed length taking+into account the maximum index for the type at hand. (Similarly, we+could view the list of constructors as a binary tree, and then encode+a constructor as the path to the constructor in this tree.) If there+is just a single constructor, as for newtypes, for example, then the+computed bit stream is empty.++Otherwise we just recurse into subterms.++Well, we need to handle basic datatypes in a special way. We observe+such basic datatypes by testing the maximum index to be 0 for the+datatype at hand. An efficient encoding should be tuned per basic+datatype. The following solution is generic, but it wastes space.+That is, we turn the basic value into a string relying on the general+Data API. This string can now be encoded by first converting it into a+list of bit streams at the term level, which can then be easily+encoded as a single bit stream (because lists and bits can be+encoded).++-}++import Test.HUnit++import Data.Generics+import Data.Char+import Data.Maybe+import Control.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/CompanyDatatypes.hs view
@@ -27,7 +27,7 @@ genCom' = C [D "Research" lammel [PU joost, PU marlow], D "Strategy" blair []] -lammel, laemmel, joost, blair :: Employee+lammel, laemmel, joost, marlow, blair :: Employee lammel = E (P "Lammel" "Amsterdam") (S 8000) laemmel = E (P "Laemmel" "Amsterdam") (S 8000) joost = E (P "Joost" "Amsterdam") (S 1000)
tests/Datatype.hs view
@@ -1,34 +1,34 @@-{-# OPTIONS -fglasgow-exts #-} - --- These are simple tests to observe (data)type representations. -module Datatype where - -import Test.HUnit - -import Data.Tree -import Data.Generics - --- A simple polymorphic datatype -data MyDataType a = MyDataType a - deriving (Typeable, Data) - - --- Some terms and corresponding type representations -myTerm = undefined :: MyDataType Int -myTypeRep = typeOf myTerm -- type representation in Typeable -myTyCon = typeRepTyCon myTypeRep -- type constructor via Typeable -myDataType = dataTypeOf myTerm -- datatype representation in Data -myString1 = tyConName myTyCon -- type constructor via Typeable -myString2 = dataTypeName myDataType -- type constructor via Data - --- Main function for testing -tests = show ( myTypeRep - , ( myDataType - , ( tyconModule myString1 - , ( tyconUQname myString1 - , ( tyconModule myString2 - , ( tyconUQname myString2 - )))))) - ~=? output - +{-# OPTIONS -fglasgow-exts #-}++-- These are simple tests to observe (data)type representations.+module Datatype where++import Test.HUnit++import Data.Tree+import Data.Generics++-- A simple polymorphic datatype+data MyDataType a = MyDataType a+ deriving (Typeable, Data)+++-- Some terms and corresponding type representations+myTerm = undefined :: MyDataType Int+myTypeRep = typeOf myTerm -- type representation in Typeable+myTyCon = typeRepTyCon myTypeRep -- type constructor via Typeable+myDataType = dataTypeOf myTerm -- datatype representation in Data+myString1 = tyConName myTyCon -- type constructor via Typeable+myString2 = dataTypeName myDataType -- type constructor via Data++-- Main function for testing+tests = show ( myTypeRep+ , ( myDataType+ , ( tyconModule myString1+ , ( tyconUQname myString1+ , ( tyconModule myString2+ , ( tyconUQname myString2+ ))))))+ ~=? output+ output = "(MyDataType Int,(DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]},(\"\",(\"MyDataType\",(\"Datatype\",\"MyDataType\")))))"
tests/FreeNames.hs view
@@ -1,118 +1,118 @@-{-# OPTIONS -fglasgow-exts #-} - -module FreeNames (tests) where - -{- - -This example illustrates the kind of traversals that naturally show up -in language processing. That is, the free names (say, variables) are -derived for a given program fragment. To this end, we need several -worker functions that extract declaring and referencing occurrences -from given program fragments; see "decsExpr", "decsEqua", -etc. below. Then, we need a traversal "freeNames" that traverses over -the program fragment in a bottom-up manner so that free names from -subterms do not escape to the top when corresponding declarations are -provided. The "freeNames" algorithm uses set operations "union" and -"//" to compute sets of free names from the declared and referenced -names of the root term and free names of the immediate subterms. - -Contributed by Ralf Laemmel, ralf@cwi.nl - --} - -import Test.HUnit - -import Data.Generics -import Data.List - -data System = S [Function] deriving (Typeable, Data) - -data Function = F Name [Equation] deriving (Typeable, Data) - -data Equation = E [Pattern] Expression System deriving (Typeable, Data) - -data Pattern = PVar Name - | PTerm Name [Pattern] deriving (Typeable, Data) - -data Expression = Var Name - | App Expression Expression - | Lambda Name Expression deriving (Typeable, Data) - -type Name = String - --- A little sample program - -sys1 = S [f1,f2] -f1 = F "f1" [e11] -f2 = F "f2" [e21,e22] -e11 = E [] (Var "id") (S []) -e21 = E [ PTerm "C" [ PVar "x" ] ] (Var "x") (S []) -e22 = E [] (Var "id") (S []) - - --- Names declared in an expression -decsExpr :: Expression -> [Name] -decsExpr (Lambda n _) = [n] -decsExpr _ = [] - --- Names declared in an equation -decsEqua :: Equation -> [Name] -decsEqua (E ps _ _) = everything union ([] `mkQ` pvar) ps - where - pvar (PVar n) = [n] - pvar _ = [] - --- Names declared in a system -decsSyst :: System -> [Name] -decsSyst (S l) = nub $ map (\(F n _) -> n) l - --- Names referenced in an expression -refsExpr :: Expression -> [Name] -refsExpr (Var n) = [n] - --- Names referenced in an equation -refsEqua :: Equation -> [Name] -refsEqua (E ps _ _) = everything union ([] `mkQ` pterm) ps - where - pterm (PTerm n _) = [n] - pterm _ = [] - --- Combine the above type-specific cases to obtain --- generic functions that find declared and referenced names --- -decsFun :: Data a => a -> [Name] -decsFun = const [] `extQ` decsExpr `extQ` decsEqua `extQ` decsSyst - -refsFun :: Data a => a -> [Name] -refsFun = const [] `extQ` refsExpr `extQ` refsEqua - - - -{- - -Free name analysis: Take the union of free names obtained from the -immediate subterms (via gmapQ) and the names being referred to at the -root of the present term, but subtract all the names that are declared -at the root. - --} - -freeNames :: Data a => a -> [Name] -freeNames x = ( (refsFun x) - `union` - (nub . concat . gmapQ freeNames) x - ) \\ decsFun x - -{- - -Print the free names for the sample program sys1; see module -FunDatatypes.hs. This should print the list ["id","C"] because the -"Prelude" function "id" is used in the sample program, and also the -term constructor "C" occurs in a pattern; we assume a language without -explicit datatype declarations ;-) - --} - -tests = freeNames sys1 ~=? output - -output = ["id","C"] +{-# 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/Newtype.hs view
@@ -1,15 +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 = "T" +{-# OPTIONS -fglasgow-exts #-}++module Newtype (tests) where++-- The type of a newtype should treat the newtype as opaque++import Test.HUnit++import Data.Generics++newtype T = MkT Int deriving( Typeable )++tests = show (typeOf (undefined :: T)) ~=? output++output = "T"