diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,29 @@ +# 0.7.4 + +- Export new function `gshowsF` that allows more flexibility than `gshows`. + It allows users to override how some children types should be printed. (https://github.com/dreixel/syb/pull/55) + +# 0.7.3 + +- Fix `gread` to recognize negative numbers (https://github.com/dreixel/syb/issues/13) +- Bump minimum required GHC to 8.0 +- `Generic'` is now a newtype instead of data, add `GenericR'` and `GenericB'` (https://github.com/dreixel/syb/issues/49) + +# 0.7.2.4 +- Improved documentation (thanks to @BinderDavid) +- Export `ext2` function which was already defined but not exported + +# 0.7.2.3 +- Compatibility with `mtl` 2.3 and GHC 9.6 + +# 0.7.2.2 +- Compatibility with GHC 9.4 + +# 0.7.2.1 +- Update cabal version + +# 0.7.2 +- Add compatibility with GHC 9, switch to tasty for tests, fix tests on GHCJS + +# 0.7.1 +- Define recursive traversals in two parts, non-recursive wrapper and recursive local helper to facilitate inlining and avoid passing the same argument to all recursive calls diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,42 @@ +syb: Scrap Your Boilerplate! +================================================================================ + +Scrap Your Boilerplate (SYB) is a library for generic programming in Haskell. It +is supported since the GHC >= 6.0 implementation of Haskell. Using this +approach, you can write generic functions such as traversal schemes (e.g., +everywhere and everything), as well as generic read, generic show and generic +equality (i.e., gread, gshow, and geq). This approach is based on just a few +primitives for type-safe cast and processing constructor applications. + +It was originally developed by Ralf Lämmel and Simon Peyton Jones. Since then, +many people have contributed with research relating to SYB or its applications. + +More information is available on the webpage: +http://www.cs.uu.nl/wiki/GenericProgramming/SYB + + +Features +-------- + +* Easy generic programming with combinators +* GHC can derive Data and Typeable instances for your datatypes +* Comes with many useful generic functions + + +Requirements +------------ + +* GHC 8.0 or later +* Cabal 3.0 or later + +Bugs & Support +-------------- + +Please report issues or request features at the bug tracker: + + https://github.com/dreixel/syb/issues + +For discussion about the library with the authors, maintainers, and other +interested persons use the mailing list: + + http://www.haskell.org/mailman/listinfo/generics diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Main (main) where - -import Distribution.Simple ( defaultMainWithHooks, simpleUserHooks - , UserHooks(runTests)) -import System.Cmd (system) - -main :: IO () -main = defaultMainWithHooks hooks - where hooks = simpleUserHooks { runTests = runTests' } - --- Runs the testsuite -runTests' _ _ _ _ = system cmd >> return () - where testdir = "tests" - testcmd = "runhaskell ./Main.hs" - cmd = "cd " ++ testdir ++ " && " ++ testcmd diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/src/Data/Generics.hs b/src/Data/Generics.hs --- a/src/Data/Generics.hs +++ b/src/Data/Generics.hs @@ -1,5 +1,4 @@ -{-# OPTIONS_GHC -cpp #-} - +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics @@ -11,12 +10,9 @@ -- Portability : non-portable (uses Data.Generics.Basics) -- -- \"Scrap your boilerplate\" --- Generic programming in Haskell --- See . To scrap your boilerplate it --- is sufficient to import the present module, which simply re-exports all --- themes of the Data.Generics library. --- --- For more information, please visit the new --- SYB wiki: . +-- See . To scrap your +-- boilerplate it is sufficient to import the present module, which simply +-- re-exports all themes of the Data.Generics library. -- ----------------------------------------------------------------------------- @@ -30,25 +26,9 @@ module Data.Generics.Twins, -- twin traversal, e.g., generic eq module Data.Generics.Builders, -- term builders -#ifdef __GLASGOW_HASKELL__ -#ifndef __HADDOCK__ - -- Data types for the sum-of-products type encoding; - -- included for backwards compatibility; maybe obsolete. - (:*:)(..), (:+:)(..), Unit(..) -#endif -#endif - ) where ------------------------------------------------------------------------------ - -#ifdef __GLASGOW_HASKELL__ -#ifndef __HADDOCK__ - -- Data types for the sum-of-products type encoding; - -- included for backwards compatibility; maybe obsolete. -import GHC.Base ( (:*:)(..), (:+:)(..), Unit(..) ) -#endif -#endif import Data.Data import Data.Generics.Instances () diff --git a/src/Data/Generics/Aliases.hs b/src/Data/Generics/Aliases.hs --- a/src/Data/Generics/Aliases.hs +++ b/src/Data/Generics/Aliases.hs @@ -1,40 +1,63 @@ -{-# OPTIONS_GHC -cpp #-} -{-# LANGUAGE Rank2Types #-} - +{-# 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 . The present module provides --- a number of declarations for typical generic function types, --- corresponding type case, and others. +-- This 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, + -- * Combinators which create generic functions via cast + -- + -- $castcombinators - -- * Type synonyms for generic function types + -- ** Transformations + mkT, + extT, + -- ** Queries + mkQ, + extQ, + -- ** Monadic transformations + mkM, + extM, + -- ** MonadPlus transformations + mkMp, + extMp, + -- ** Readers + mkR, + extR, + -- ** Builders + extB, + -- ** Other + ext0, + -- * Types for generic functions + -- ** Transformations GenericT, + GenericT'(..), + -- ** Queries GenericQ, + GenericQ'(..), + -- ** Monadic transformations GenericM, - GenericB, + GenericM'(..), + -- ** Readers GenericR, + GenericR'(..), + -- ** Builders + GenericB, + GenericB'(..), + -- ** Other Generic, Generic'(..), - GenericT'(..), - GenericQ'(..), - GenericM'(..), -- * Ingredients of generic functions orElse, @@ -46,12 +69,21 @@ choiceQ, -- * Type extension for unary type constructors + ext1, ext1T, ext1M, ext1Q, ext1R, - ext1B + ext1B, + -- * Type extension for binary type constructors + ext2, + ext2T, + ext2M, + ext2Q, + ext2R, + ext2B + ) where #ifdef __HADDOCK__ @@ -67,149 +99,346 @@ -- ------------------------------------------------------------------------------ --- | Make a generic transformation; --- start from a type-specific case; --- preserve the term otherwise +-- $castcombinators -- +-- Other programming languages sometimes provide an operator @instanceof@ which +-- can check whether an expression is an instance of a given type. This operator +-- allows programmers to implement a function @f :: forall a. a -> a@ which exhibits +-- a different behaviour depending on whether a `Bool` or a `Char` is passed. +-- In Haskell this is not the case: A function with type @forall a. a -> a@ +-- can only be the identity function or a function which loops indefinitely +-- or throws an exception. That is, it must implement exactly the same behaviour +-- for any type at which it is used. But sometimes it is very useful to have +-- a function which can accept (almost) any type and exhibit a different behaviour +-- for different types. Haskell provides this functionality with the 'Typeable' +-- typeclass, whose instances can be automatically derived by GHC for almost all +-- types. This typeclass allows the definition of a functon 'cast' which has type +-- @forall a b. (Typeable a, Typeable b) => a -> Maybe b@. The 'cast' function allows +-- to implement a polymorphic function with different behaviour at different types: +-- +-- >>> cast True :: Maybe Bool +-- Just True +-- +-- >>> cast True :: Maybe Int +-- Nothing +-- +-- This section provides combinators which make use of 'cast' internally to +-- provide various polymorphic functions with type-specific behaviour. + + +-- | Extend the identity function with a type-specific transformation. +-- The function created by @mkT ext@ behaves like the identity function on all +-- arguments which cannot be cast to type @b@, and like the function @ext@ otherwise. +-- The name 'mkT' is short for "make transformation". +-- +-- === __Examples__ +-- +-- >>> mkT not True +-- False +-- +-- >>> mkT not 'a' +-- 'a' +-- +-- @since 0.1.0.0 mkT :: ( Typeable a , Typeable b ) => (b -> b) + -- ^ The type-specific transformation -> a + -- ^ The argument we try to cast to type @b@ -> a mkT = extT id --- | Make a generic query; --- start from a type-specific case; --- return a constant otherwise +-- | The function created by @mkQ def f@ returns the default result +-- @def@ if its argument cannot be cast to type @b@, otherwise it returns +-- the result of applying @f@ to its argument. +-- The name 'mkQ' is short for "make query". -- +-- === __Examples__ +-- +-- >>> mkQ "default" (show :: Bool -> String) True +-- "True" +-- +-- >>> mkQ "default" (show :: Bool -> String) () +-- "default" +-- +-- @since 0.1.0.0 mkQ :: ( Typeable a , Typeable b ) => r + -- ^ The default result -> (b -> r) + -- ^ The transformation to apply if the cast is successful -> a + -- ^ The argument we try to cast to type @b@ -> r (r `mkQ` br) a = case cast a of Just b -> br b Nothing -> r --- | Make a generic monadic transformation; --- start from a type-specific case; --- resort to return otherwise +-- | Extend the default monadic action @pure :: Monad m => a -> m a@ by a type-specific +-- monadic action. The function created by @mkM act@ behaves like 'pure' if its +-- argument cannot be cast to type @b@, and like the monadic action @act@ otherwise. +-- The name 'mkM' is short for "make monadic transformation". -- +-- === __Examples__ +-- +-- >>> mkM (\x -> [x, not x]) True +-- [True,False] +-- +-- >>> mkM (\x -> [x, not x]) (5 :: Int) +-- [5] +-- +-- @since 0.1.0.0 mkM :: ( Monad m , Typeable a , Typeable b ) => (b -> m b) + -- ^ The type-specific monadic transformation -> a + -- ^ The argument we try to cast to type @b@ -> m a mkM = extM return - -{- - -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. +-- | Extend the default 'MonadPlus' action @const mzero@ by a type-specific 'MonadPlus' +-- action. The function created by @mkMp act@ behaves like @const mzero@ if its argument +-- cannot be cast to type @b@, and like the monadic action @act@ otherwise. +-- The name 'mkMp' is short for "make MonadPlus transformation". -- +-- === __Examples__ +-- +-- >>> mkMp (\x -> Just (not x)) True +-- Just False +-- +-- >>> mkMp (\x -> Just (not x)) 'a' +-- Nothing +-- +-- @since 0.1.0.0 mkMp :: ( MonadPlus m , Typeable a , Typeable b ) => (b -> m b) + -- ^ The type-specific MonadPlus action -> a + -- ^ The argument we try to cast to type @b@ -> m a mkMp = extM (const mzero) --- | Make a generic builder; --- start from a type-specific ase; --- resort to no build (i.e., mzero) otherwise +-- | Make a generic reader from a type-specific case. +-- The function created by @mkR f@ behaves like the reader @f@ if an expression +-- of type @a@ can be cast to type @b@, and like the expression @mzero@ otherwise. +-- The name 'mkR' is short for "make reader". -- +-- === __Examples__ +-- +-- >>> mkR (Just True) :: Maybe Bool +-- Just True +-- +-- >>> mkR (Just True) :: Maybe Int +-- Nothing +-- +-- @since 0.1.0.0 mkR :: ( MonadPlus m , Typeable a , Typeable b ) - => m b -> m a + => m b + -- ^ The type-specific reader + -> m a mkR f = mzero `extR` f -- | Flexible type extension +-- +-- === __Examples__ +-- +-- >>> ext0 [1 :: Int, 2, 3] [True, False] :: [Int] +-- [1,2,3] +-- +-- >>> ext0 [1 :: Int, 2, 3] [4 :: Int, 5, 6] :: [Int] +-- [4,5,6] +-- +-- @since 0.1.0.0 ext0 :: (Typeable a, Typeable b) => c a -> c b -> c a ext0 def ext = maybe def id (gcast ext) --- | Extend a generic transformation by a type-specific case +-- | Extend a generic transformation by a type-specific transformation. +-- The function created by @extT def ext@ behaves like the generic transformation +-- @def@ if its argument cannot be cast to the type @b@, and like the type-specific +-- transformation @ext@ otherwise. +-- The name 'extT' is short for "extend transformation". +-- +-- === __Examples__ +-- +-- >>> extT id not True +-- False +-- +-- >>> extT id not 'a' +-- 'a' +-- +-- @since 0.1.0.0 extT :: ( Typeable a , Typeable b ) => (a -> a) + -- ^ The transformation we want to extend -> (b -> b) + -- ^ The type-specific transformation -> a + -- ^ The argument we try to cast to type @b@ -> a extT def ext = unT ((T def) `ext0` (T ext)) --- | Extend a generic query by a type-specific case +-- | Extend a generic query by a type-specific query. The function created by @extQ def ext@ behaves +-- like the generic query @def@ if its argument cannot be cast to the type @b@, and like the type-specific +-- query @ext@ otherwise. +-- The name 'extQ' is short for "extend query". +-- +-- === __Examples__ +-- +-- >>> extQ (const True) not True +-- False +-- +-- >>> extQ (const True) not 'a' +-- True +-- +-- @since 0.1.0.0 extQ :: ( Typeable a , Typeable b ) - => (a -> q) - -> (b -> q) + => (a -> r) + -- ^ The query we want to extend + -> (b -> r) + -- ^ The type-specific query -> a - -> q + -- ^ The argument we try to cast to type @b@ + -> r extQ f g a = maybe (f a) g (cast a) --- | Extend a generic monadic transformation by a type-specific case +-- | Extend a generic monadic transformation by a type-specific case. +-- The function created by @extM def ext@ behaves like the monadic transformation +-- @def@ if its argument cannot be cast to type @b@, and like the monadic transformation +-- @ext@ otherwise. +-- The name 'extM' is short for "extend monadic transformation". +-- +-- === __Examples__ +-- +-- >>> extM (\x -> [x,x])(\x -> [not x, x]) True +-- [False,True] +-- +-- >>> extM (\x -> [x,x])(\x -> [not x, x]) (5 :: Int) +-- [5,5] +-- +-- @since 0.1.0.0 extM :: ( Monad m , Typeable a , Typeable b ) - => (a -> m a) -> (b -> m b) -> a -> m a + => (a -> m a) + -- ^ The monadic transformation we want to extend + -> (b -> m b) + -- ^ The type-specific monadic transformation + -> a + -- ^ The argument we try to cast to type @b@ + -> m a extM def ext = unM ((M def) `ext0` (M ext)) --- | Extend a generic MonadPlus transformation by a type-specific case +-- | Extend a generic MonadPlus transformation by a type-specific case. +-- The function created by @extMp def ext@ behaves like 'MonadPlus' transformation @def@ +-- if its argument cannot be cast to type @b@, and like the transformation @ext@ otherwise. +-- Note that 'extMp' behaves exactly like 'extM'. +-- The name 'extMp' is short for "extend MonadPlus transformation". +-- +-- === __Examples__ +-- +-- >>> extMp (\x -> [x,x])(\x -> [not x, x]) True +-- [False,True] +-- +-- >>> extMp (\x -> [x,x])(\x -> [not x, x]) (5 :: Int) +-- [5,5] +-- +-- @since 0.1.0.0 extMp :: ( MonadPlus m , Typeable a , Typeable b ) - => (a -> m a) -> (b -> m b) -> a -> m a + => (a -> m a) + -- ^ The 'MonadPlus' transformation we want to extend + -> (b -> m b) + -- ^ The type-specific 'MonadPlus' transformation + -> a + -- ^ The argument we try to cast to type @b@ + -> m a extMp = extM --- | Extend a generic builder +-- | Extend a generic builder by a type-specific case. +-- The builder created by @extB def ext@ returns @def@ if @ext@ cannot be cast +-- to type @a@, and like @ext@ otherwise. +-- The name 'extB' is short for "extend builder". +-- +-- === __Examples__ +-- +-- >>> extB True 'a' +-- True +-- +-- >>> extB True False +-- False +-- +-- @since 0.1.0.0 extB :: ( Typeable a , Typeable b ) - => a -> b -> a + => a + -- ^ The default result + -> b + -- ^ The argument we try to cast to type @a@ + -> a extB a = maybe a id . cast --- | Extend a generic reader +-- | Extend a generic reader by a type-specific case. +-- The reader created by @extR def ext@ behaves like the reader @def@ +-- if expressions of type @b@ cannot be cast to type @a@, and like the +-- reader @ext@ otherwise. +-- The name 'extR' is short for "extend reader". +-- +-- === __Examples__ +-- +-- >>> extR (Just True) (Just 'a') +-- Just True +-- +-- >>> extR (Just True) (Just False) +-- Just False +-- +-- @since 0.1.0.0 extR :: ( Monad m , Typeable a , Typeable b ) - => m a -> m b -> m a + => m a + -- ^ The generic reader we want to extend + -> m b + -- ^ The type-specific reader + -> m a extR def ext = unR ((R def) `ext0` (R ext)) ------------------------------------------------------------------------------ -- --- Type synonyms for generic function types +-- Types for generic functions -- ------------------------------------------------------------------------------ @@ -217,59 +446,117 @@ -- | Generic transformations, -- i.e., take an \"a\" and return an \"a\" -- +-- @since 0.1.0.0 type GenericT = forall a. Data a => a -> a +-- | The type synonym `GenericT` has a polymorphic type, and can therefore not +-- appear in places where monomorphic types are expected, for example in a list. +-- The newtype `GenericT'` wraps `GenericT` in a newtype to lift this restriction. +-- +-- @since 0.1.0.0 +newtype GenericT' = GT { unGT :: GenericT } -- | Generic queries of type \"r\", -- i.e., take any \"a\" and return an \"r\" -- +-- @since 0.1.0.0 type GenericQ r = forall a. Data a => a -> r +-- | The type synonym `GenericQ` has a polymorphic type, and can therefore not +-- appear in places where monomorphic types are expected, for example in a list. +-- The newtype `GenericQ'` wraps `GenericQ` in a newtype to lift this restriction. +-- +-- @since 0.1.0.0 +newtype GenericQ' r = GQ { unGQ :: GenericQ r } -- | Generic monadic transformations, -- i.e., take an \"a\" and compute an \"a\" -- +-- @since 0.1.0.0 type GenericM m = forall a. Data a => a -> m a +-- | The type synonym `GenericM` has a polymorphic type, and can therefore not +-- appear in places where monomorphic types are expected, for example in a list. +-- The newtype `GenericM'` wraps `GenericM` in a newtype to lift this restriction. +-- +-- @since 0.1.0.0 +newtype GenericM' m = GM { unGM :: GenericM m } -- | Generic builders -- i.e., produce an \"a\". -- +-- @since 0.1.0.0 type GenericB = forall a. Data a => a +-- | The type synonym `GenericB` has a polymorphic type, and can therefore not +-- appear in places where monomorphic types are expected, for example in a list. +-- The data type `GenericB'` wraps `GenericB` in a data type to lift this restriction. +-- +-- @since 0.7.3 +newtype GenericB' = GenericB' { unGenericB' :: GenericB } -- | Generic readers, say monadic builders, -- i.e., produce an \"a\" with the help of a monad \"m\". -- +-- @since 0.1.0.0 type GenericR m = forall a. Data a => m a +-- | The type synonym `GenericR` has a polymorphic type, and can therefore not +-- appear in places where monomorphic types are expected, for example in a list. +-- The data type `GenericR'` wraps `GenericR` in a data type to lift this restriction. +-- +-- @since 0.7.3 +newtype GenericR' m = GenericR' { unGenericR' :: GenericR m } -- | The general scheme underlying generic functions -- assumed by gfoldl; there are isomorphisms such as -- GenericT = Generic T. -- +-- @since 0.1.0.0 type Generic c = forall a. Data a => a -> c a --- | Wrapped generic functions; --- recall: [Generic c] would be legal but [Generic' c] not. +-- | The type synonym `Generic` has a polymorphic type, and can therefore not +-- appear in places where monomorphic types are expected, for example in a list. +-- The data type `Generic'` wraps `Generic` in a data type to lift this restriction. -- -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 } +-- @since 0.1.0.0 +newtype Generic' c = Generic' { unGeneric' :: Generic c } +------------------------------------------------------------------------------ +-- +-- Ingredients of generic functions +-- +------------------------------------------------------------------------------ -- | Left-biased choice on maybes +-- +-- === __Examples__ +-- +-- >>> orElse Nothing Nothing +-- Nothing +-- +-- >>> orElse Nothing (Just 'a') +-- Just 'a' +-- +-- >>> orElse (Just 'a') Nothing +-- Just 'a' +-- +-- >>> orElse (Just 'a') (Just 'b') +-- Just 'a' +-- +-- @since 0.1.0.0 orElse :: Maybe a -> Maybe a -> Maybe a x `orElse` y = case x of Just _ -> x Nothing -> y +------------------------------------------------------------------------------ +-- +-- Function combinators on generic functions +-- +------------------------------------------------------------------------------ {- The following variations take "orElse" to the function @@ -283,35 +570,46 @@ -} -- | Choice for monadic transformations +-- +-- @since 0.1.0.0 choiceMp :: MonadPlus m => GenericM m -> GenericM m -> GenericM m choiceMp f g x = f x `mplus` g x -- | Choice for monadic queries +-- +-- @since 0.1.0.0 choiceQ :: MonadPlus m => GenericQ (m r) -> GenericQ (m r) -> GenericQ (m r) choiceQ f g x = f x `mplus` g x -- | Recover from the failure of monadic transformation by identity +-- +-- @since 0.1.0.0 recoverMp :: MonadPlus m => GenericM m -> GenericM m recoverMp f = f `choiceMp` return -- | Recover from the failure of monadic query by a constant +-- +-- @since 0.1.0.0 recoverQ :: MonadPlus m => r -> GenericQ (m r) -> GenericQ (m r) recoverQ r f = f `choiceQ` const (return r) ------------------------------------------------------------------------------ --- -- Type extension for unary type constructors --- ------------------------------------------------------------------------------ - +#if __GLASGOW_HASKELL__ >= 707 +#define Typeable1 Typeable +#define Typeable2 Typeable +#endif -- | Flexible type extension +-- +-- @since 0.3 ext1 :: (Data a, Typeable1 t) => c a -> (forall d. Data d => c (t d)) @@ -320,6 +618,8 @@ -- | Type extension of transformations for unary type constructors +-- +-- @since 0.1.0.0 ext1T :: (Data d, Typeable1 t) => (forall e. Data e => e -> e) -> (forall f. Data f => t f -> t f) @@ -328,6 +628,8 @@ -- | Type extension of monadic transformations for type constructors +-- +-- @since 0.1.0.0 ext1M :: (Monad m, Data d, Typeable1 t) => (forall e. Data e => e -> m e) -> (forall f. Data f => t f -> m (t f)) @@ -336,6 +638,8 @@ -- | Type extension of queries for type constructors +-- +-- @since 0.1.0.0 ext1Q :: (Data d, Typeable1 t) => (d -> q) -> (forall e. Data e => t e -> q) @@ -344,6 +648,8 @@ -- | Type extension of readers for type constructors +-- +-- @since 0.1.0.0 ext1R :: (Monad m, Data d, Typeable1 t) => m d -> (forall e. Data e => m (t e)) @@ -352,11 +658,74 @@ -- | Type extension of builders for type constructors +-- +-- @since 0.2 ext1B :: (Data a, Typeable1 t) => a -> (forall b. Data b => (t b)) -> a ext1B def ext = unB ((B def) `ext1` (B ext)) + +------------------------------------------------------------------------------ +-- Type extension for binary type constructors +------------------------------------------------------------------------------ + +-- | Flexible type extension +ext2 :: (Data a, Typeable2 t) + => c a + -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2)) + -> c a +ext2 def ext = maybe def id (dataCast2 ext) + + +-- | Type extension of transformations for unary type constructors +-- +-- @since 0.3 +ext2T :: (Data d, Typeable2 t) + => (forall e. Data e => e -> e) + -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> t d1 d2) + -> d -> d +ext2T def ext = unT ((T def) `ext2` (T ext)) + + +-- | Type extension of monadic transformations for type constructors +-- +-- @since 0.3 +ext2M :: (Monad m, Data d, Typeable2 t) + => (forall e. Data e => e -> m e) + -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> m (t d1 d2)) + -> d -> m d +ext2M def ext = unM ((M def) `ext2` (M ext)) + + +-- | Type extension of queries for type constructors +-- +-- @since 0.3 +ext2Q :: (Data d, Typeable2 t) + => (d -> q) + -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) + -> d -> q +ext2Q def ext = unQ ((Q def) `ext2` (Q ext)) + + +-- | Type extension of readers for type constructors +-- +-- @since 0.3 +ext2R :: (Monad m, Data d, Typeable2 t) + => m d + -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2)) + -> m d +ext2R def ext = unR ((R def) `ext2` (R ext)) + + +-- | Type extension of builders for type constructors +-- +-- @since 0.3 +ext2B :: (Data a, Typeable2 t) + => a + -> (forall d1 d2. (Data d1, Data d2) => (t d1 d2)) + -> a +ext2B def ext = unB ((B def) `ext2` (B ext)) ------------------------------------------------------------------------------ -- diff --git a/src/Data/Generics/Basics.hs b/src/Data/Generics/Basics.hs --- a/src/Data/Generics/Basics.hs +++ b/src/Data/Generics/Basics.hs @@ -9,13 +9,10 @@ -- Portability : non-portable (local universal quantification) -- -- \"Scrap your boilerplate\" --- Generic programming in Haskell. --- See . This module provides +-- See . This module provides -- the 'Data' class with its primitives for generic programming, -- which is now defined in @Data.Data@. Therefore this module simply -- re-exports @Data.Data@. --- --- For more information, please visit the new --- SYB wiki: . -- ----------------------------------------------------------------------------- diff --git a/src/Data/Generics/Builders.hs b/src/Data/Generics/Builders.hs --- a/src/Data/Generics/Builders.hs +++ b/src/Data/Generics/Builders.hs @@ -6,7 +6,7 @@ -- Module : Data.Generics.Builders -- Copyright : (c) 2008 Universiteit Utrecht -- License : BSD-style --- +-- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable @@ -22,6 +22,8 @@ -- | Construct the empty value for a datatype. For algebraic datatypes, the -- leftmost constructor is chosen. +-- +-- @since 0.2 empty :: forall a. Data a => a empty = general `extB` char @@ -43,6 +45,8 @@ -- | Return a list of values of a datatype. Each value is one of the possible -- constructors of the datatype, populated with 'empty' values. +-- +-- @since 0.2 constrs :: forall a. Data a => [a] constrs = general `extB` char diff --git a/src/Data/Generics/Instances.hs b/src/Data/Generics/Instances.hs --- a/src/Data/Generics/Instances.hs +++ b/src/Data/Generics/Instances.hs @@ -1,24 +1,20 @@ -{-# OPTIONS_GHC -cpp #-} - +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Instances -- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the LICENSE file) --- +-- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (uses Data.Data) -- --- \"Scrap your boilerplate\" --- Generic programming in Haskell --- See . The present module +-- \"Scrap your boilerplate\" --- Generic programming in Haskell +-- See . The present module -- contains thirteen 'Data' instances which are considered dubious (either -- because the types are abstract or just not meant to be traversed). -- Instances in this module might change or disappear in future releases --- of this package. --- --- For more information, please visit the new --- SYB wiki: . +-- of this package. -- -- (This module does not export anything. It really just defines instances.) -- @@ -53,8 +49,6 @@ import Control.Monad.ST #endif -#include "Typeable.h" - -- Version compatibility issues caused by #2760 myMkNoRepType :: String -> DataType #if __GLASGOW_HASKELL__ >= 611 @@ -76,10 +70,12 @@ -- Instances of abstract datatypes (6) ------------------------------------------------------------------------------ +#if __GLASGOW_HASKELL__ < 801 instance Data TypeRep where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = myMkNoRepType "Data.Typeable.TypeRep" +#endif ------------------------------------------------------------------------------ @@ -91,8 +87,9 @@ ------------------------------------------------------------------------------ - -INSTANCE_TYPEABLE0(DataType,dataTypeTc,"DataType") +#if __GLASGOW_HASKELL__ < 709 +deriving instance Typeable DataType +#endif instance Data DataType where toConstr _ = error "toConstr" diff --git a/src/Data/Generics/Schemes.hs b/src/Data/Generics/Schemes.hs --- a/src/Data/Generics/Schemes.hs +++ b/src/Data/Generics/Schemes.hs @@ -1,20 +1,17 @@ -{-# OPTIONS_GHC -cpp #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} - +{-# LANGUAGE RankNTypes, ScopedTypeVariables, CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Schemes -- Copyright : (c) The University of Glasgow, CWI 2001--2003 -- License : BSD-style (see the LICENSE file) --- +-- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (local universal quantification) -- --- \"Scrap your boilerplate\" --- Generic programming in Haskell --- See . The present module provides --- frequently used generic traversal schemes. +-- \"Scrap your boilerplate\" --- Generic programming in Haskell +-- See . The present module +-- provides frequently used generic traversal schemes. -- ----------------------------------------------------------------------------- @@ -26,6 +23,8 @@ everywhereM, somewhere, everything, + everythingBut, + everythingWithContext, listify, something, synthesize, @@ -48,76 +47,129 @@ import Data.Generics.Aliases import Control.Monad - -- | Apply a transformation everywhere in bottom-up manner +-- +-- @since 0.1.0.0 everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a) -- Use gmapT to recurse into immediate subterms; -- recall: gmapT preserves the outermost constructor; -- post-process recursively transformed result via f --- -everywhere f = f . gmapT (everywhere f) - +-- +everywhere f = go + where + go :: forall a. Data a => a -> a + go = f . gmapT go -- | Apply a transformation everywhere in top-down manner +-- +-- @since 0.1.0.0 everywhere' :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a) -- Arguments of (.) are flipped compared to everywhere -everywhere' f = gmapT (everywhere' f) . f +everywhere' f = go + where + go :: forall a. Data a => a -> a + go = gmapT go . f -- | Variation on everywhere with an extra stop condition +-- +-- @since 0.1.0.0 everywhereBut :: GenericQ Bool -> GenericT -> GenericT -- Guarded to let traversal cease if predicate q holds for x -everywhereBut q f x - | q x = x - | otherwise = f (gmapT (everywhereBut q f) x) +everywhereBut q f = go + where + go :: GenericT + go x + | q x = x + | otherwise = f (gmapT go x) -- | Monadic variation on everywhere -everywhereM :: Monad m => GenericM m -> GenericM m +-- +-- @since 0.1.0.0 +everywhereM :: forall m. Monad m => GenericM m -> GenericM m -- Bottom-up order is also reflected in order of do-actions -everywhereM f x = do x' <- gmapM (everywhereM f) x - f x' +everywhereM f = go + where + go :: GenericM m + go x = do + x' <- gmapM go x + f x' -- | Apply a monadic transformation at least somewhere -somewhere :: MonadPlus m => GenericM m -> GenericM m +-- +-- @since 0.1.0.0 +somewhere :: forall m. MonadPlus m => GenericM m -> GenericM m -- We try "f" in top-down manner, but descent into "x" when we fail -- at the root of the term. The transformation fails if "f" fails -- everywhere, say succeeds nowhere. --- -somewhere f x = f x `mplus` gmapMp (somewhere f) x +-- +somewhere f = go + where + go :: GenericM m + go x = f x `mplus` gmapMp go x -- | Summarise all nodes in top-down, left-to-right order -everything :: (r -> r -> r) -> GenericQ r -> GenericQ r +-- +-- @since 0.1.0.0 +everything :: forall r. (r -> r -> r) -> GenericQ r -> GenericQ r -- Apply f to x to summarise top-level node; -- use gmapQ to recurse into immediate subterms; -- use ordinary foldl to reduce list of intermediate results --- -everything k f x - = foldl k (f x) (gmapQ (everything k f) x) +-- +everything k f = go + where + go :: GenericQ r + go x = foldl k (f x) (gmapQ go x) +-- | Variation of "everything" with an added stop condition +-- +-- @since 0.3 +everythingBut :: forall r. (r -> r -> r) -> GenericQ (r, Bool) -> GenericQ r +everythingBut k f = go + where + go :: GenericQ r + go x = let (v, stop) = f x + in if stop + then v + else foldl k v (gmapQ go x) +-- | Summarise all nodes in top-down, left-to-right order, carrying some state +-- down the tree during the computation, but not left-to-right to siblings. +-- +-- @since 0.3.7 +everythingWithContext :: forall s r. s -> (r -> r -> r) -> GenericQ (s -> (r, s)) -> GenericQ r +everythingWithContext s0 f q = go s0 + where + go :: s -> GenericQ r + go s x = foldl f r (gmapQ (go s') x) + where (r, s') = q x s + -- | Get a list of all entities that meet a predicate +-- +-- @since 0.1.0.0 listify :: Typeable r => (r -> Bool) -> GenericQ [r] -listify p - = everything (++) ([] `mkQ` (\x -> if p x then [x] else [])) +listify p = everything (++) ([] `mkQ` (\x -> if p x then [x] else [])) -- | Look up a subterm by means of a maybe-typed filter +-- +-- @since 0.1.0.0 something :: GenericQ (Maybe u) -> GenericQ (Maybe u) -- "something" can be defined in terms of "everything" -- when a suitable "choice" operator is used for reduction --- +-- something = everything orElse @@ -126,41 +178,59 @@ -- 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)) +-- @since 0.1.0.0 +synthesize :: forall s t. s -> (t -> s -> s) -> GenericQ (s -> t) -> GenericQ t +synthesize z o f = go + where + go :: GenericQ t + go x = f x (foldr o z (gmapQ go x)) -- | Compute size of an arbitrary data structure +-- +-- @since 0.1.0.0 gsize :: Data a => a -> Int gsize t = 1 + sum (gmapQ gsize t) -- | Count the number of immediate subterms of the given term +-- +-- @since 0.1.0.0 glength :: GenericQ Int glength = length . gmapQ (const ()) -- | Determine depth of the given term +-- +-- @since 0.1.0.0 gdepth :: GenericQ Int gdepth = (+) 1 . foldr max 0 . gmapQ gdepth -- | Determine the number of all suitable nodes in a given term +-- +-- @since 0.1.0.0 gcount :: GenericQ Bool -> GenericQ Int gcount p = everything (+) (\x -> if p x then 1 else 0) -- | Determine the number of all nodes in a given term +-- +-- @since 0.1.0.0 gnodecount :: GenericQ Int gnodecount = gcount (const True) -- | Determine the number of nodes of a given type in a given term +-- +-- @since 0.1.0.0 gtypecount :: Typeable a => a -> GenericQ Int gtypecount (_::a) = gcount (False `mkQ` (\(_::a) -> True)) -- | Find (unambiguously) an immediate subterm of a given type +-- +-- @since 0.1.0.0 gfindtype :: (Data x, Typeable y) => x -> Maybe y gfindtype = singleton . foldl unJust [] diff --git a/src/Data/Generics/Text.hs b/src/Data/Generics/Text.hs --- a/src/Data/Generics/Text.hs +++ b/src/Data/Generics/Text.hs @@ -1,25 +1,25 @@ -{-# OPTIONS_GHC -cpp #-} - +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Text -- Copyright : (c) The University of Glasgow, CWI 2001--2003 -- License : BSD-style (see the LICENSE file) --- +-- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (uses Data.Generics.Basics) -- --- \"Scrap your boilerplate\" --- Generic programming in Haskell --- See . The present module provides --- generic operations for text serialisation of terms. +-- \"Scrap your boilerplate\" --- Generic programming in Haskell +-- See . The present module +-- provides generic operations for text serialisation of terms. -- ----------------------------------------------------------------------------- module Data.Generics.Text ( -- * Generic show - gshow, gshows, + gshow, gshows, gshowsF, -- * Generic read gread @@ -35,28 +35,38 @@ import Data.Data import Data.Generics.Aliases import Text.ParserCombinators.ReadP +import Text.Read.Lex ------------------------------------------------------------------------------ --- | Generic show: an alternative to \"deriving Show\" +-- | Generic 'show': an alternative to @deriving@ 'Show'. +-- +-- @since 0.1.0.0 gshow :: Data a => a -> String gshow x = gshows x "" --- | Generic shows +-- | Generic 'shows'. +-- +-- @since 0.2 gshows :: Data a => a -> ShowS -- This is a prefix-show using surrounding "(" and ")", -- where we recurse into subterms with gmapQ. -gshows = ( \t -> +gshows = gshowsF gshows + +-- | Generic 'shows' but allowing the user to change cases. +gshowsF :: Data b => (forall a. Data a => a -> ShowS) -> b -> ShowS +gshowsF fun = ( \t -> showChar '(' . (showString . showConstr . toConstr $ t) - . (foldr (.) id . gmapQ ((showChar ' ' .) . gshows) $ t) + . (foldr (.) id . gmapQ ((showChar ' ' .) . fun) $ t) . showChar ')' ) `extQ` (shows :: String -> ShowS) - --- | Generic read: an alternative to \"deriving Read\" +-- | Generic 'reads' (not 'read'): an alternative to @deriving@ 'Read'. +-- +-- @since 0.1.0.0 gread :: Data a => ReadS a {- @@ -121,7 +131,8 @@ string "[]" -- Compound lexeme "[]" <++ string "()" -- singleton "()" <++ infixOp -- Infix operator in parantheses - <++ readS_to_P lex -- Ordinary constructors and literals + <++ negativeNumber -- prefix "-" and number literal + <++ hsLex -- Ordinary constructors and literals -- Handle infix operators such as (:) infixOp :: ReadP String @@ -129,3 +140,9 @@ str <- munch1 (not . (==) ')') c2 <- char ')' return $ [c1] ++ str ++ [c2] + + -- Handle negative number literals + negativeNumber :: ReadP String + negativeNumber = do c1 <- char '-' + str <- hsLex + return $ c1 : str diff --git a/src/Data/Generics/Twins.hs b/src/Data/Generics/Twins.hs --- a/src/Data/Generics/Twins.hs +++ b/src/Data/Generics/Twins.hs @@ -1,23 +1,23 @@ -{-# OPTIONS_GHC -cpp #-} -{-# LANGUAGE Rank2Types #-} - +{-# LANGUAGE RankNTypes, ScopedTypeVariables, CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Twins -- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the LICENSE file) --- +-- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable (local universal quantification) -- --- \"Scrap your boilerplate\" --- Generic programming in Haskell --- See . The present module --- provides support for multi-parameter traversal, which is also +-- \"Scrap your boilerplate\" --- Generic programming in Haskell +-- See . The present module +-- provides support for multi-parameter traversal, which is also -- demonstrated with generic operations like equality. -- ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-} + module Data.Generics.Twins ( -- * Generic folds and maps that also accumulate @@ -36,7 +36,8 @@ -- * Typical twin traversals geq, - gzip + gzip, + gcompare ) where @@ -46,15 +47,15 @@ #ifdef __HADDOCK__ import Prelude #endif +import Control.Applicative (Const(..)) import Data.Data import Data.Generics.Aliases +import Data.Functor.Identity (Identity(..)) #ifdef __GLASGOW_HASKELL__ import Prelude hiding ( GT ) #endif -import Control.Applicative (Applicative(..)) - ------------------------------------------------------------------------------ @@ -80,7 +81,8 @@ --------------------------------------------------------------} -- | gfoldl with accumulation - +-- +-- @since 0.1.0.0 gfoldlAccum :: Data d => (forall e r. Data e => a -> c (e -> r) -> e -> (a, c r)) -> (forall g. a -> g -> (a, c g)) @@ -97,18 +99,23 @@ -- | gmapT with accumulation +-- +-- @since 0.1.0.0 gmapAccumT :: Data d => (forall e. Data e => a -> e -> (a,e)) -> a -> d -> (a, d) gmapAccumT f a0 d0 = let (a1, d1) = gfoldlAccum k z a0 d0 - in (a1, unID d1) + in (a1, runIdentity d1) where - k a (ID c) d = let (a',d') = f a d - in (a', ID (c d')) - z a x = (a, ID x) + k a (Identity c) d = + let (a',d') = f a d + in (a', Identity (c d')) + z a x = (a, Identity x) -- | Applicative version +-- +-- @since 0.2 gmapAccumA :: forall b d a. (Data d, Applicative a) => (forall e. Data e => b -> e -> (b, a e)) -> b -> d -> (b, a d) @@ -125,6 +132,8 @@ -- | gmapM with accumulation +-- +-- @since 0.1.0.0 gmapAccumM :: (Data d, Monad m) => (forall e. Data e => a -> e -> (a, m e)) -> a -> d -> (a, m d) @@ -136,20 +145,25 @@ -- | gmapQl with accumulation +-- +-- @since 0.1.0.0 gmapAccumQl :: Data d => (r -> r' -> r) -> r -> (forall e. Data e => a -> e -> (a,r')) -> a -> d -> (a, r) gmapAccumQl o r0 f a0 d0 = let (a1, r1) = gfoldlAccum k z a0 d0 - in (a1, unCONST r1) + in (a1, getConst r1) where - k a (CONST c) d = let (a', r) = f a d - in (a', CONST (c `o` r)) - z a _ = (a, CONST r0) + k a (Const c) d = + let (a', r) = f a d + in (a', Const (c `o` r)) + z a _ = (a, Const r0) -- | gmapQr with accumulation +-- +-- @since 0.1.0.0 gmapAccumQr :: Data d => (r' -> r -> r) -> r @@ -164,6 +178,8 @@ -- | gmapQ with accumulation +-- +-- @since 0.1.0.0 gmapAccumQ :: Data d => (forall e. Data e => a -> e -> (a,q)) -> a -> d -> (a, [q]) @@ -178,14 +194,6 @@ ------------------------------------------------------------------------------ --- | The identity type constructor needed for the definition of gmapAccumT -newtype ID x = ID { unID :: x } - - --- | The constant type constructor needed for the definition of gmapAccumQl -newtype CONST c a = CONST { unCONST :: c } - - -- | The type constructor needed for the definition of gmapAccumQr newtype Qr r a = Qr { unQr :: r -> r } @@ -198,18 +206,25 @@ ------------------------------------------------------------------------------ --- | Twin map for transformation -gzipWithT :: GenericQ (GenericT) -> GenericQ (GenericT) +-- | Twin map for transformation +-- +-- @since 0.1.0.0 +gzipWithT :: GenericQ GenericT -> GenericQ GenericT gzipWithT f x y = case gmapAccumT perkid funs y of ([], c) -> c _ -> error "gzipWithT" where + perkid :: Data b => [GenericT'] -> b -> ([GenericT'], b) perkid a d = (tail a, unGT (head a) d) + + funs :: [GenericT'] funs = gmapQ (\k -> GT (f k)) x --- | Twin map for monadic transformation +-- | Twin map for monadic transformation +-- +-- @since 0.1.0.0 gzipWithM :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m) gzipWithM f x y = case gmapAccumM perkid funs y of ([], c) -> c @@ -220,12 +235,16 @@ -- | Twin map for queries -gzipWithQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r]) +-- +-- @since 0.1.0.0 +gzipWithQ :: forall r. GenericQ (GenericQ r) -> GenericQ (GenericQ [r]) gzipWithQ f x y = case gmapAccumQ perkid funs y of ([], r) -> r _ -> error "gzipWithQ" where + perkid :: Data c => [GenericQ' b] -> c -> ([GenericQ' b], b) perkid a d = (tail a, unGQ (head a) d) + funs :: [GenericQ' r] funs = gmapQ (\k -> GQ (f k)) x @@ -237,6 +256,8 @@ ------------------------------------------------------------------------------ -- | Generic equality: an alternative to \"deriving Eq\" +-- +-- @since 0.1.0.0 geq :: Data a => a -> a -> Bool {- @@ -262,11 +283,35 @@ -- | Generic zip controlled by a function with type-specific branches +-- +-- @since 0.1.0.0 gzip :: GenericQ (GenericM Maybe) -> GenericQ (GenericM Maybe) -- See testsuite/.../Generics/gzip.hs for an illustration -gzip f x y = - f x y - `orElse` - if toConstr x == toConstr y - then gzipWithM (gzip f) x y - else Nothing +gzip f = go + where + go :: GenericQ (GenericM Maybe) + go x y = + f x y + `orElse` + if toConstr x == toConstr y + then gzipWithM go x y + else Nothing + +-- | Generic comparison: an alternative to \"deriving Ord\" +-- +-- @since 0.5 +gcompare :: Data a => a -> a -> Ordering +gcompare = gcompare' + where + gcompare' :: (Data a, Data b) => a -> b -> Ordering + gcompare' x y + = let repX = constrRep $ toConstr x + repY = constrRep $ toConstr y + in + case (repX, repY) of + (AlgConstr nX, AlgConstr nY) -> + nX `compare` nY `mappend` mconcat (gzipWithQ (\a -> gcompare' a) x y) + (IntConstr iX, IntConstr iY) -> iX `compare` iY + (FloatConstr rX, FloatConstr rY) -> rX `compare` rY + (CharConstr cX, CharConstr cY) -> cX `compare` cY + _ -> error "type incompatibility in gcompare" diff --git a/syb.cabal b/syb.cabal --- a/syb.cabal +++ b/syb.cabal @@ -1,52 +1,115 @@ name: syb -version: 0.2 +version: 0.7.4 license: BSD3 license-file: LICENSE -author: Ralf Lammel, Simon Peyton Jones -maintainer: generics@haskell.org -homepage: http://www.cs.uu.nl/wiki/GenericProgramming/SYB -bug-reports: http://code.google.com/p/scrapyourboilerplate/issues/list +author: Ralf Lammel, Simon Peyton Jones, Jose Pedro Magalhaes +maintainer: Sergey Vinokurov +homepage: https://github.com/dreixel/syb +bug-reports: https://github.com/dreixel/syb/issues synopsis: Scrap Your Boilerplate description: This package contains the generics system described in the - /Scrap Your Boilerplate/ papers (see ). + /Scrap Your Boilerplate/ papers (see + ). It defines the @Data@ class of types permitting folding and unfolding of constructor applications, instances of this class for primitive types, and a variety of traversals. category: Generics stability: provisional -build-type: Custom -cabal-version: >= 1.6 -tested-with: GHC == 6.10.4, GHC == 6.12.1 +build-type: Simple +cabal-version: >= 1.10 +tested-with: + GHC == 9.14 + GHC == 9.12 + GHC == 9.10 + GHC == 9.8 + GHC == 9.6 + GHC == 9.4 + GHC == 9.2 + GHC == 9.0 + GHC == 8.10 + GHC == 8.8 + GHC == 8.6 + GHC == 8.4 + GHC == 8.2 + GHC == 8.0 -extra-source-files: tests/*.hs +extra-source-files: README.md, + Changelog.md -Library { +source-repository head + type: git + location: https://github.com/dreixel/syb + +Library hs-source-dirs: src - build-depends: base >= 4.0 && < 4.3 - exposed-modules: Data.Generics, - Data.Generics.Basics, - Data.Generics.Instances, - Data.Generics.Aliases, - Data.Generics.Schemes, - Data.Generics.Text, - Data.Generics.Twins, - Data.Generics.Builders, - - Generics.SYB, - Generics.SYB.Basics, - Generics.SYB.Instances, - Generics.SYB.Aliases, - Generics.SYB.Schemes, - Generics.SYB.Text, - Generics.SYB.Twins, + default-language: Haskell98 + build-depends: base >= 4.9 && < 5 + exposed-modules: Data.Generics + Data.Generics.Basics + Data.Generics.Instances + Data.Generics.Aliases + Data.Generics.Schemes + Data.Generics.Text + Data.Generics.Twins + Data.Generics.Builders + + Generics.SYB + Generics.SYB.Basics + Generics.SYB.Instances + Generics.SYB.Aliases + Generics.SYB.Schemes + Generics.SYB.Text + Generics.SYB.Twins Generics.SYB.Builders - extensions: CPP, Rank2Types, ScopedTypeVariables + ghc-options: -Wall -Wcompat - if impl(ghc < 6.12) - ghc-options: -package-name syb - - ghc-options: -Wall -} +test-suite unit-tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + default-language: Haskell98 + main-is: Main.hs + build-depends: base + , syb + , tasty + , tasty-hunit + , containers + , mtl + other-modules: Bits + Builders + CompanyDatatypes + Datatype + Encode + Ext + Ext1 + Ext2 + FoldTree + FreeNames + GEq + GMapQAssoc + GRead + GRead2 + GShow + GShow2 + GZip + GenUpTo + GetC + HList + HOPat + Labels + LocalQuantors + NestedDatatypes + Newtype + Paradise + Perm + Polymatch + Reify + Strings + Tree + Twin + Typecase1 + Typecase2 + Where + XML diff --git a/tests/Bits.hs b/tests/Bits.hs --- a/tests/Bits.hs +++ b/tests/Bits.hs @@ -1,9 +1,9 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} module Bits (tests) where {- - + This test exercices some oldies of generic programming, namely encoding terms as bit streams and decoding these bit streams in turn to obtain terms again. (This sort of function might actually be useful @@ -34,12 +34,13 @@ -} -import Test.HUnit +import Test.Tasty.HUnit import Data.Generics import Data.Char -import Maybe -import Monad +import Data.Maybe +import Control.Applicative (Alternative(..), Applicative(..)) +import Control.Monad import CompanyDatatypes @@ -69,7 +70,7 @@ varNat2bin x = ( ( if even x then Zero else One ) : varNat2bin (x `div` 2) - ) + ) -- Encode a natural as a bit stream of fixed length @@ -78,7 +79,7 @@ fixedNat2bin p x | p>0 = ( ( if even x then Zero else One ) : fixedNat2bin (p - 1) (x `div` 2) - ) + ) -- Decode a natural @@ -129,10 +130,20 @@ data ReadB a = ReadB (Bin -> (Maybe a, Bin)) unReadB (ReadB f) = f +instance Functor ReadB where + fmap = liftM +instance Applicative ReadB where + pure a = ReadB (\bs -> (Just a, bs)) + (<*>) = ap + +instance Alternative ReadB where + (<|>) = mplus + empty = mzero + -- It's a monad. instance Monad ReadB where - return a = ReadB (\bs -> (Just a, bs)) + return = pure (ReadB c) >>= f = ReadB (\bs -> case c bs of (Just a, bs') -> unReadB (f a) bs' (Nothing, bs') -> (Nothing, bs') @@ -186,7 +197,7 @@ max :: Int max = maxConstrIndex myDataType - -- Convert a bit stream into a constructor + -- Convert a bit stream into a constructor bin2con :: Bin -> Constr bin2con bin = indexConstr myDataType ((bin2nat bin) + 1) @@ -206,8 +217,8 @@ , ( showBin (1::Int) , ( showBin "1" , ( showBin genCom - , ( geq genCom genCom' - )))))) ~=? output + , ( geq genCom genCom' + )))))) @=? output where genCom' = fromJust (fst (unReadB readBin (showBin genCom))) :: Company diff --git a/tests/Builders.hs b/tests/Builders.hs --- a/tests/Builders.hs +++ b/tests/Builders.hs @@ -1,20 +1,17 @@ -{-# OPTIONS -fglasgow-exts #-} - module Builders (tests) where --- Testing Data.Generics.Builders functionality - -import Test.HUnit +import Test.Tasty.HUnit -import Data.Data import Data.Generics.Builders -- Main function for testing +tests :: Assertion tests = ( constrs :: [Maybe Int] , constrs :: [String] - , constrs :: [Either Int Float] + , constrs :: [Either Int Double] , constrs :: [((), Integer)] - ) ~=? output + ) @=? output +output :: ([Maybe Int], [String], [Either Int Double], [((), Integer)]) output = ([Nothing,Just 0],["","\NUL"],[Left 0,Right 0.0],[((),0)]) diff --git a/tests/CompanyDatatypes.hs b/tests/CompanyDatatypes.hs --- a/tests/CompanyDatatypes.hs +++ b/tests/CompanyDatatypes.hs @@ -1,8 +1,8 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} module CompanyDatatypes where -import Data.Generics hiding (Unit) +import Data.Generics (Data, Typeable) -- The organisational structure of a company @@ -11,7 +11,7 @@ data Unit = PU Employee | DU Dept deriving (Eq, Show, Typeable, Data) data Employee = E Person Salary deriving (Eq, Show, Typeable, Data) data Person = P Name Address deriving (Eq, Show, Typeable, Data) -data Salary = S Float deriving (Eq, Show, Typeable, Data) +data Salary = S Double deriving (Eq, Show, Typeable, Data) type Manager = Employee type Name = String type Address = String @@ -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) diff --git a/tests/Datatype.hs b/tests/Datatype.hs --- a/tests/Datatype.hs +++ b/tests/Datatype.hs @@ -1,25 +1,27 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} -- These are simple tests to observe (data)type representations. -module Datatype (tests) where +module Datatype where -import Test.HUnit +import Test.Tasty.HUnit import Data.Tree import Data.Generics -- A simple polymorphic datatype -data Data a => - MyDataType a = MyDataType a +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 = tyConString myTyCon -- type constructor via Typeable + +#if MIN_VERSION_base(4,5,0) +myTyCon = typeRepTyCon myTypeRep -- type constructor via Typeable +myString1 = tyConName myTyCon -- type constructor via Typeable myString2 = dataTypeName myDataType -- type constructor via Data -- Main function for testing @@ -30,6 +32,27 @@ , ( tyconModule myString2 , ( tyconUQname myString2 )))))) - ~=? output + @?= output -output = "(Datatype.MyDataType Int,(DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]},(\"Datatype\",(\"MyDataType\",(\"Datatype\",\"MyDataType\")))))" +# if __GLASGOW_HASKELL__ >= 904 +-- In GHC 9.4 module name is included +output = "(MyDataType Int,(DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]},(\"\",(\"MyDataType\",(\"Datatype\",\"MyDataType\")))))" +# elif __GLASGOW_HASKELL__ >= 709 +-- In GHC 7.10 module name is stripped from DataType +output = "(MyDataType Int,(DataType {tycon = \"MyDataType\", datarep = AlgRep [MyDataType]},(\"\",(\"MyDataType\",(\"\",\"MyDataType\")))))" +# else +output = "(MyDataType Int,(DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]},(\"\",(\"MyDataType\",(\"Datatype\",\"MyDataType\")))))" +# endif + +#else + +tests = show ( myTypeRep, myDataType ) + @?= output + +# if __GLASGOW_HASKELL__ >= 701 +output = "(MyDataType Int,DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]})" +# else +output = "(Datatype.MyDataType Int,DataType {tycon = \"Datatype.MyDataType\", datarep = AlgRep [MyDataType]})" +# endif + +#endif diff --git a/tests/Encode.hs b/tests/Encode.hs --- a/tests/Encode.hs +++ b/tests/Encode.hs @@ -1,4 +1,5 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyDataDecls #-} -- A bit more test code for the 2nd boilerplate paper. -- These are downscaled versions of library functionality or real test cases. @@ -6,6 +7,8 @@ module Encode () where +import Control.Applicative (Applicative(..)) +import Control.Monad (ap, liftM) import Data.Generics data Bit = Zero | One @@ -62,9 +65,13 @@ -- Sec. 3.3 cont'd data EncM a -- The encoder monad -instance Monad EncM - where - return = undefined +instance Functor EncM where + fmap = liftM +instance Applicative EncM where + pure = undefined + (<*>) = ap +instance Monad EncM where + return = pure c >>= f = undefined runEnc :: EncM () -> [Bit] @@ -77,5 +84,5 @@ data2bits'' t = runEnc (emit t) emit :: Data a => a -> EncM () -emit t = do { emitCon (dataTypeOf t) (toConstr t) +emit t = do { emitCon (dataTypeOf t) (toConstr t) ; sequence_ (gmapQ emit t) } diff --git a/tests/Ext.hs b/tests/Ext.hs --- a/tests/Ext.hs +++ b/tests/Ext.hs @@ -1,5 +1,3 @@ -{-# OPTIONS -fglasgow-exts #-} - module Ext () where -- There were typos in these definitions in the ICFP 2004 paper. @@ -10,14 +8,14 @@ = case gcast (Q spec_fn) of Just (Q spec_fn') -> spec_fn' arg Nothing -> fn arg - + newtype Q r a = Q (a -> r) - + extT fn spec_fn arg = case gcast (T spec_fn) of Just (T spec_fn') -> spec_fn' arg Nothing -> fn arg - + newtype T a = T (a -> a) extM :: (Typeable a, Typeable b) diff --git a/tests/Ext1.hs b/tests/Ext1.hs --- a/tests/Ext1.hs +++ b/tests/Ext1.hs @@ -1,4 +1,6 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} module Ext1 (tests) where @@ -8,22 +10,16 @@ -} -import Test.HUnit +import Test.Tasty.HUnit import Data.Generics -import GHC.Base - +import GHC.Exts (unsafeCoerce#) +import GHC.Base hiding (foldr) -- Unsafe coerce unsafeCoerce :: a -> b unsafeCoerce = unsafeCoerce# - --- Handy type constructors -newtype ID x = ID { unID :: x } -newtype CONST c a = CONST { unCONST :: c } - - -- Extension of a query with a para. poly. list case extListQ' :: Data d => (d -> q) @@ -32,13 +28,17 @@ extListQ' def ext d = if isList d then ext (unsafeCoerce d) - else def d + else def d -- Test extListQ' foo1 :: Data d => d -> Int foo1 = const 0 `extListQ'` length + +t1 :: Int t1 = foo1 True -- should count as 0 + +t2 :: Int t2 = foo1 [True,True] -- should count as 2 @@ -50,7 +50,7 @@ extListQ'' def ext d = if isList d then undefined -- hard to avoid an ambiguous type - else def d + else def d -- Test extListQ from Data.Generics.Aliases @@ -60,7 +60,10 @@ list :: Data a => [a] -> Int list l = foldr (+) 0 $ map glength l +t3 :: Int t3 = foo2 (True,True) -- should count as 0 + +t4 :: Int t4 = foo2 [(True,True),(True,True)] -- should count as 2+2=4 @@ -70,7 +73,10 @@ then foldr (+) 0 $ gmapListQ glength x else 0 +t5 :: Int t5 = foo3 (True,True) -- should count as 0 + +t6 :: Int t6 = foo3 [(True,True),(True,True)] -- should count as 2+2=4 @@ -93,7 +99,7 @@ -- gmapQ for polymorphic lists gmapListQ :: forall a q. Data a => (forall a. Data a => a -> q) -> a -> [q] gmapListQ f x = - if not $ isList x + if not $ isList x then error "gmapListQ" else if isNil x then [] @@ -101,24 +107,15 @@ then ( gmapQi 0 f x : gmapQi 1 (gmapListQ f) x ) else error "gmapListQ" - --- Build nil -mkNil :: Data a => a -mkNil = fromConstr $ toConstr ([]::[()]) - - --- Build cons -mkCons :: Data a => a -mkCons = fromConstr $ toConstr ((undefined:undefined)::[()]) - - -- Main function for testing +tests :: Assertion tests = ( t1 , ( t2 , ( t3 , ( t4 , ( t5 , ( t6 - )))))) ~=? output + )))))) @=? output +output :: (Int, (Int, (Int, (Int, (Int, Int))))) output = (0,(2,(0,(4,(0,4))))) diff --git a/tests/Ext2.hs b/tests/Ext2.hs new file mode 100644 --- /dev/null +++ b/tests/Ext2.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Ext2 (tests) where + +-- Tests for ext2 and friends + +import Test.Tasty.HUnit +import Data.Generics + + +-- A type of lists +data List a = Nil | Cons a (List a) deriving (Data, Typeable, Show, Eq) + +-- Example lists +l1, l2 :: List Int +l1 = Cons 1 (Cons 2 Nil) +l2 = Cons 0 l1 + +-- A type of pairs +data Pair a b = Pair1 a b | Pair2 a b deriving (Data, Typeable, Show, Eq) + +-- Example pairs +p1, p2 :: Pair Int Char +p1 = Pair1 2 'p' +p2 = Pair2 3 'q' + +-- Structures containing the above +s1 :: [Pair Int Char] +s1 = [p1, p2] + +s2 :: (Pair Int Char, List Int) +s2 = (p2, l2) + + +-- Auxiliary functions +unifyPair :: Pair a b -> Pair a b -> Bool +unifyPair (Pair1 _ _) (Pair1 _ _) = True +unifyPair (Pair2 _ _) (Pair2 _ _) = True +unifyPair _ _ = False + +flipPair :: Pair a b -> Pair a b +flipPair (Pair1 a b) = Pair2 a b +flipPair (Pair2 a b) = Pair1 a b + +-- Tests +t1 = everywhere (id `ext2T` flipPair) (s1,s2) +t2 = let f :: (Data a) => a -> Maybe a + f = (const Nothing) `ext2M` (Just . flipPair) + in (f p1, f l1) +t3 = everything (+) ( const 0 + `ext1Q` (const 1 :: List a -> Int) + `ext2Q` (const 10 :: Pair a b -> Int)) + $ s2 +t4 = unifyPair (t4' :: Pair Int Char) t4' where + t4' :: Data a => a + t4' = undefined `ext1B` Nil `ext2B` (Pair1 undefined undefined) + + +-- Main function for testing +tests = (t1, t2, t3, t4) @=? output + +output = ((map flipPair s1, (flipPair p2, l2)) + ,(Just (flipPair p1),Nothing) + ,14 + ,True) diff --git a/tests/FoldTree.hs b/tests/FoldTree.hs --- a/tests/FoldTree.hs +++ b/tests/FoldTree.hs @@ -1,4 +1,5 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} {- @@ -26,17 +27,16 @@ module FoldTree (tests) where -import Test.HUnit +import Test.Tasty.HUnit -- Enable "ScrapYourBoilerplate" import Data.Generics -- A parameterised datatype for binary trees with data at the leafs -data (Data a, Data w) => - Tree a w = Leaf a +data Tree a w = Leaf a | Fork (Tree a w) (Tree a w) - | WithWeight (Tree a w) w + | WithWeight (Tree a w) w deriving (Typeable, Data) @@ -45,19 +45,29 @@ mytree = Fork (WithWeight (Leaf 42) 1) (WithWeight (Fork (Leaf 88) (Leaf 37)) 2) +-- A less typical tree, used for testing everythingBut +mytree' :: Tree Int Int +mytree' = Fork (Leaf 42) + (WithWeight (Fork (Leaf 88) (Leaf 37)) 2) + -- Print everything like an Int in mytree -- In fact, we show two attempts: -- 1. print really just everything like an Int -- 2. print everything wrapped with Leaf -- So (1.) confuses leafs and weights whereas (2.) does not. --- +-- Additionally we test everythingBut, stopping when we see a WithWeight node tests = show ( listify (\(_::Int) -> True) mytree , everything (++) ([] `mkQ` fromLeaf) mytree - ) ~=? output + , everythingBut (++) + (([],False) `mkQ` (\x -> (fromLeaf x, stop x))) mytree' + ) @=? output where fromLeaf :: Tree Int Int -> [Int] fromLeaf (Leaf x) = [x] - fromLeaf _ = [] + fromLeaf _ = [] + stop :: (Data a, Data b) => Tree a b -> Bool + stop (WithWeight _ _) = True + stop _ = False -output = "([42,1,88,37,2],[42,88,37])" +output = "([42,1,88,37,2],[42,88,37],[42])" diff --git a/tests/FreeNames.hs b/tests/FreeNames.hs --- a/tests/FreeNames.hs +++ b/tests/FreeNames.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} module FreeNames (tests) where @@ -20,7 +20,7 @@ -} -import Test.HUnit +import Test.Tasty.HUnit import Data.Generics import Data.List @@ -96,14 +96,12 @@ at the root. -} - + freeNames :: Data a => a -> [Name] freeNames x = ( (refsFun x) `union` (nub . concat . gmapQ freeNames) x - ) - \\ - decsFun x + ) \\ decsFun x {- @@ -115,6 +113,6 @@ -} -tests = freeNames sys1 ~=? output +tests = freeNames sys1 @=? output output = ["id","C"] diff --git a/tests/GEq.hs b/tests/GEq.hs --- a/tests/GEq.hs +++ b/tests/GEq.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} module GEq (tests) where @@ -11,11 +11,11 @@ -} -import Test.HUnit +import Test.Tasty.HUnit import Data.Generics import CompanyDatatypes tests = ( geq genCom genCom , geq genCom genCom' - ) ~=? (True,False) + ) @=? (True,False) diff --git a/tests/GMapQAssoc.hs b/tests/GMapQAssoc.hs --- a/tests/GMapQAssoc.hs +++ b/tests/GMapQAssoc.hs @@ -1,4 +1,5 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} module GMapQAssoc (tests) where @@ -25,7 +26,7 @@ -} -import Test.HUnit +import Test.Tasty.HUnit import Data.Generics @@ -48,7 +49,7 @@ deriving (Typeable, Data) --- Select int if faced with a leaf +-- Select int if faced with a leaf leaf (Leaf i) = [i] leaf _ = [] @@ -63,6 +64,6 @@ -- tests = show ( gmapQ ([] `mkQ` leaf) term , gmapQ' ([] `mkQ` leaf) term - ) ~=? output + ) @=? output output = show ([[1],[2]],[[2],[1]]) diff --git a/tests/GRead.hs b/tests/GRead.hs new file mode 100644 --- /dev/null +++ b/tests/GRead.hs @@ -0,0 +1,55 @@ +module GRead (tests) where + +{- + +The following examples achieve branch coverage for the various +productions in the definition of gread. Also, negative test cases are +provided; see str2 and str3. Also, the potential of heading or +trailing spaces as well incomplete parsing of the input is exercised; +see str5. + +-} + +import Test.Tasty.HUnit + +import Data.Generics + +str1, str2, str3, str4, str4a, str5, str6, str7 :: String +str1 = "(True)" -- reads fine as a Bool +str2 = "(Treu)" -- invalid constructor +str3 = "True" -- lacks parentheses +str4 = "(1)" -- could be an Int +str4a = "(-1)" -- negative literal +str5 = "( 2 ) ..." -- could be an Int with some trailing left-over +str6 = "([])" -- test empty list +str7 = "((:)" ++ " " ++ str4 ++ " " ++ str6 ++ ")" + +expected :: + ( [[(Bool, String)]] + , [[(Int, String)]] + , [[([Int], String)]] + ) +expected = + ( [ gread str1, + gread str2, + gread str3 + ] + , [ gread str4, + gread str4a, + gread str5 + ] + , [ gread str6, + gread str7 + ] + ) + +tests :: Assertion +tests = show expected @=? show output + +output :: + ( [[(Bool, String)]] + , [[(Int, String)]] + , [[([Int], String)]] + ) +output = + ([[(True,"")],[],[]],[[(1,"")],[(-1,"")],[(2,"...")]],[[([],"")],[([1],"")]]) diff --git a/tests/GRead2.hs b/tests/GRead2.hs new file mode 100644 --- /dev/null +++ b/tests/GRead2.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module GRead2 () where + +{- + +For the discussion in the 2nd boilerplate paper, +we favour some simplified generic read, which is checked to compile. +For the full/real story see Data.Generics.Text. + +-} + +import Control.Applicative (Applicative(..)) +import Control.Monad (ap, liftM) +import Data.Generics + +gread :: Data a => String -> Maybe a +gread input = runDec input readM + +-- The decoder monad +newtype DecM a = D (String -> Maybe (String, a)) + +instance Functor DecM where + fmap = liftM + +instance Applicative DecM where + pure a = D (\s -> Just (s,a)) + (<*>) = ap + +instance Monad DecM where + return = pure + (D m) >>= k = D (\s -> + case m s of + Nothing -> Nothing + Just (s1,a) -> let D n = k a + in n s1) + +runDec :: String -> DecM a -> Maybe a +runDec input (D m) = do (_,x) <- m input + return x + +parseConstr :: DataType -> DecM Constr +parseConstr ty = D (\s -> + match s (dataTypeConstrs ty)) + where + match :: String -> [Constr] + -> Maybe (String, Constr) + match _ [] = Nothing + match input (con:cons) + | take n input == showConstr con + = Just (drop n input, con) + | otherwise + = match input cons + where + n = length (showConstr con) + + +readM :: forall a. Data a => DecM a +readM = read + where + read :: DecM a + read = do { let val = argOf read + ; let ty = dataTypeOf val + ; constr <- parseConstr ty + ; let con::a = fromConstr constr + ; gmapM (\_ -> readM) con } + +argOf :: c a -> a +argOf = undefined + +yareadM :: forall a. Data a => DecM a +yareadM = do { let ty = dataTypeOf (undefined::a) + ; constr <- parseConstr ty + ; let con::a = fromConstr constr + ; gmapM (\_ -> yareadM) con } diff --git a/tests/GShow.hs b/tests/GShow.hs --- a/tests/GShow.hs +++ b/tests/GShow.hs @@ -1,33 +1,33 @@ -{-# OPTIONS -fglasgow-exts #-} - +{-# LANGUAGE DeriveDataTypeable #-} + module GShow (tests) where {- - + The generic show example from the 2nd boilerplate paper. (There were some typos in the ICFP 2004 paper.) Also check out Data.Generics.Text. - + -} -import Test.HUnit +import Test.Tasty.HUnit import Data.Generics hiding (gshow) import Prelude hiding (showString) - + gshow :: Data a => a -> String gshow = gshow_help `extQ` showString gshow_help :: Data a => a -> String -gshow_help t +gshow_help t = "(" ++ showConstr (toConstr t) ++ concat (intersperse " " (gmapQ gshow t)) ++ ")" showString :: String -> String -showString s = "\"" ++ concat (map escape s) ++ "\"" +showString s = "\"" ++ concat (map escape s) ++ "\"" where escape '\n' = "\\n" escape other_char = [other_char] @@ -37,7 +37,7 @@ = "[" ++ concat (intersperse "," (map gshow xs)) ++ "]" gshow' :: Data a => a -> String -gshow' = gshow_help `ext1Q` gshowList +gshow' = gshow_help `ext1Q` gshowList `extQ` showString intersperse :: a -> [a] -> [a] @@ -47,6 +47,6 @@ tests = ( gshow' "foo" , gshow' [True,False] - ) ~=? output + ) @=? output output = ("\"foo\"","[(True),(False)]") diff --git a/tests/GShow2.hs b/tests/GShow2.hs --- a/tests/GShow2.hs +++ b/tests/GShow2.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} module GShow2 (tests) where @@ -10,12 +10,12 @@ -} -import Test.HUnit +import Test.Tasty.HUnit import Data.Generics import CompanyDatatypes -tests = gshow genCom ~=? output +tests = gshow genCom @=? output {- diff --git a/tests/GZip.hs b/tests/GZip.hs --- a/tests/GZip.hs +++ b/tests/GZip.hs @@ -1,4 +1,5 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} module GZip (tests) where @@ -11,13 +12,13 @@ -} -import Test.HUnit +import Test.Tasty.HUnit import Data.Generics import CompanyDatatypes -- The main function which prints the result of zipping -tests = gzip (\x y -> mkTT maxS x y) genCom1 genCom2 ~=? output +tests = gzip (\x y -> mkTT maxS x y) genCom1 genCom2 @=? output -- NB: the argument has to be eta-expanded to match -- the type of gzip's argument type, which is -- GenericQ (GenericM Maybe) @@ -40,7 +41,7 @@ (Just (x'::a),Just (y'::a)) -> cast (f x' y') _ -> Nothing -output = Just (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) +output = Just (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 2000.0)) ,PU (E (P "Marlow" "Cambridge") (S 4000.0))] ,D "Strategy" (E (P "Blair" "London") (S 100000.0)) []]) diff --git a/tests/GenUpTo.hs b/tests/GenUpTo.hs --- a/tests/GenUpTo.hs +++ b/tests/GenUpTo.hs @@ -1,5 +1,7 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-} + module GenUpTo (tests) where {- @@ -9,7 +11,7 @@ -} -import Test.HUnit +import Test.Tasty.HUnit import Data.Generics @@ -18,34 +20,34 @@ The following datatypes comprise the abstract syntax of a simple imperative language. Some provisions are such that the discussion -of test-set generation is simplified. In particular, we do not +of test-set generation is simplified. In particular, we do not consider anything but monomorphic *data*types --- no primitive types, no tuples, ... -} - -data Prog = Prog Dec Stat - deriving (Show, Eq, Typeable, Data) +data Prog = Prog Dec Stat + deriving (Show, Eq, Data) + data Dec = Nodec - | Ondec Id Type + | Ondec Id Type | Manydecs Dec Dec - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) data Id = A | B - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) data Type = Int | Bool - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) data Stat = Noop | Assign Id Exp | Seq Stat Stat - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) -data Exp = Zero +data Exp = Zero | Succ Exp - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) -- Generate all terms of a given depth @@ -62,7 +64,7 @@ -- Find all terms headed by a specific Constr recurse :: Data a => Constr -> [a] - recurse con = gmapM (\_ -> genUpTo (d-1)) + recurse con = gmapM (\_ -> genUpTo (d-1)) (fromConstr con) -- We could also deal with primitive types easily. @@ -70,25 +72,28 @@ -- cons' :: [Constr] cons' = case dataTypeRep ty of - AlgRep cons -> cons - IntRep -> [mkIntegralConstr ty 0] - FloatRep -> [mkIntegralConstr ty 0] - CharRep -> [mkCharConstr ty 'x'] + AlgRep cons'' -> cons'' + IntRep -> [mkIntegralConstr ty 0] + FloatRep -> [mkIntegralConstr ty 0] + CharRep -> [mkCharConstr ty 'x'] + NoRep -> [] where - ty = dataTypeOf (head result) + ty = dataTypeOf (head result) -- For silly tests -data T0 = T0 T1 T2 T3 deriving (Show, Eq, Typeable, Data) -data T1 = T1a | T1b deriving (Show, Eq, Typeable, Data) -data T2 = T2a | T2b deriving (Show, Eq, Typeable, Data) -data T3 = T3a | T3b deriving (Show, Eq, Typeable, Data) +data T0 = T0 T1 T2 T3 deriving (Show, Eq, Data) +data T1 = T1a | T1b deriving (Show, Eq, Data) +data T2 = T2a | T2b deriving (Show, Eq, Data) +data T3 = T3a | T3b deriving (Show, Eq, Data) +tests :: Assertion tests = ( genUpTo 0 :: [Id] , ( genUpTo 1 :: [Id] , ( genUpTo 2 :: [Id] , ( genUpTo 2 :: [T0] , ( genUpTo 3 :: [Prog] - ))))) ~=? output + ))))) @=? output +output :: ([a], ([Id], ([Id], ([T0], [Prog])))) output = ([],([A,B],([A,B],([T0 T1a T2a T3a,T0 T1a T2a T3b,T0 T1a T2b T3a,T0 T1a T2b T3b,T0 T1b T2a T3a,T0 T1b T2a T3b,T0 T1b T2b T3a,T0 T1b T2b T3b],[Prog Nodec Noop,Prog Nodec (Assign A Zero),Prog Nodec (Assign B Zero),Prog Nodec (Seq Noop Noop),Prog (Ondec A Int) Noop,Prog (Ondec A Int) (Assign A Zero),Prog (Ondec A Int) (Assign B Zero),Prog (Ondec A Int) (Seq Noop Noop),Prog (Ondec A Bool) Noop,Prog (Ondec A Bool) (Assign A Zero),Prog (Ondec A Bool) (Assign B Zero),Prog (Ondec A Bool) (Seq Noop Noop),Prog (Ondec B Int) Noop,Prog (Ondec B Int) (Assign A Zero),Prog (Ondec B Int) (Assign B Zero),Prog (Ondec B Int) (Seq Noop Noop),Prog (Ondec B Bool) Noop,Prog (Ondec B Bool) (Assign A Zero),Prog (Ondec B Bool) (Assign B Zero),Prog (Ondec B Bool) (Seq Noop Noop),Prog (Manydecs Nodec Nodec) Noop,Prog (Manydecs Nodec Nodec) (Assign A Zero),Prog (Manydecs Nodec Nodec) (Assign B Zero),Prog (Manydecs Nodec Nodec) (Seq Noop Noop)])))) diff --git a/tests/GetC.hs b/tests/GetC.hs --- a/tests/GetC.hs +++ b/tests/GetC.hs @@ -1,13 +1,24 @@ -{-# OPTIONS -fglasgow-exts #-} -{-# LANGUAGE OverlappingInstances, UndecidableInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} +# if __GLASGOW_HASKELL__ <= 708 +{-# LANGUAGE OverlappingInstances #-} +#endif + module GetC (tests) where -import Test.HUnit +import Test.Tasty.HUnit {- -Ralf Laemmel, 5 November 2004 +Ralf Laemmel, 5 November 2004 Joe Stoy suggested the idiom to test for the outermost constructor. @@ -28,14 +39,14 @@ -- Some silly data types data T1 = T1a Int String | T1b String Int deriving (Typeable, Data) data T2 = T2a Int Int | T2b String String deriving (Typeable, Data) -data T3 = T3! Int deriving (Typeable, Data) +data T3 = T3 !Int deriving (Typeable, Data) -- Test cases tests = show [ isC T1a (T1a 1 "foo") -- typechecks, returns True , isC T1a (T1b "foo" 1) -- typechecks, returns False , isC T3 (T3 42)] -- works for strict data too - ~=? output + @=? output -- err = show $ isC T2b (T1b "foo" 1) -- must not typecheck output = show [True,False,True] @@ -47,7 +58,7 @@ -- The class GetC computes maybe the constructor ... -- ... if the subterms of the datum at hand fit for f. -- Finally we compare the constructors. --- +-- isC :: (Data a, GetT f a, GetC f) => f -> a -> Bool isC f t = maybe False ((==) (toConstr t)) con @@ -59,27 +70,27 @@ -- -- We prepare for a list of kids using existential envelopes. -- We could also just operate on TypeReps for non-strict datatypes. --- +-- data ExTypeable = forall a. Typeable a => ExTypeable a unExTypeable (ExTypeable a) = cast a --- +-- -- Compute the result type of a function type. -- Beware: the TypeUnify constraint causes headache. -- We can't have GetT t t because the FD will be violated then. --- We can't omit the FD because unresolvable overlapping will hold then. --- +-- We can't omit the FD because unresolvable overlapping will hold then. +-- class GetT f t | f -> t -- FD is optional -instance GetT g t => GetT (x -> g) t -instance TypeUnify t t' => GetT t t' +instance GetT g t => GetT (x -> g) t +instance {-# OVERLAPPABLE #-} TypeUnify t t' => GetT t t' -- -- Obtain the constructor if term can be completed --- +-- class GetC f where @@ -94,7 +105,7 @@ (x::x) <- unExTypeable h getC (f x) t -instance Data t => GetC t +instance {-# OVERLAPPABLE #-} Data t => GetC t where getC y [] = Just $ toConstr y getC _ (_:_) = Nothing @@ -104,7 +115,7 @@ -- Type unification; we could try this: -- class TypeUnify a b | a -> b, b -> a -- instance TypeUnify a a --- +-- -- However, if the instance is placed in the present module, -- then type improvement would inline this instance. Sigh!!! -- @@ -114,8 +125,8 @@ -- class TypeUnify a b | a -> b, b -> a -class TypeUnify' x a b | x a -> b, x b -> a -class TypeUnify'' x a b | x a -> b, x b -> a +class TypeUnify' x a b | x a -> b, x b -> a +class TypeUnify'' x a b | x a -> b, x b -> a instance TypeUnify' () a b => TypeUnify a b instance TypeUnify'' x a b => TypeUnify' x a b instance TypeUnify'' () a a diff --git a/tests/Gread.hs b/tests/Gread.hs deleted file mode 100644 --- a/tests/Gread.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - -module GRead (tests) where - -{- - -The following examples achieve branch coverage for the various -productions in the definition of gread. Also, negative test cases are -provided; see str2 and str3. Also, the potential of heading or -trailing spaces as well incomplete parsing of the input is exercised; -see str5. - --} - -import Test.HUnit - -import Data.Generics - -str1 = "(True)" -- reads fine as a Bool -str2 = "(Treu)" -- invalid constructor -str3 = "True" -- lacks parentheses -str4 = "(1)" -- could be an Int -str5 = "( 2 ) ..." -- could be an Int with some trailing left-over -str6 = "([])" -- test empty list -str7 = "((:)" ++ " " ++ str4 ++ " " ++ str6 ++ ")" - -tests = show ( ( [ gread str1, - gread str2, - gread str3 - ] - , [ gread str4, - gread str5 - ] - , [ gread str6, - gread str7 - ] - ) - :: ( [[(Bool, String)]] - , [[(Int, String)]] - , [[([Int], String)]] - ) - ) ~=? output - -output = show - ([[(True,"")],[],[]],[[(1,"")],[(2,"...")]],[[([],"")],[([1],"")]]) diff --git a/tests/Gread2.hs b/tests/Gread2.hs deleted file mode 100644 --- a/tests/Gread2.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - -module GRead2 () where - -{- - -For the discussion in the 2nd boilerplate paper, -we favour some simplified generic read, which is checked to compile. -For the full/real story see Data.Generics.Text. - --} - -import Data.Generics - -gread :: Data a => String -> Maybe a -gread input = runDec input readM - --- The decoder monad -newtype DecM a = D (String -> Maybe (String, a)) - -instance Monad DecM where - return a = D (\s -> Just (s,a)) - (D m) >>= k = D (\s -> - case m s of - Nothing -> Nothing - Just (s1,a) -> let D n = k a - in n s1) - -runDec :: String -> DecM a -> Maybe a -runDec input (D m) = do (_,x) <- m input - return x - -parseConstr :: DataType -> DecM Constr -parseConstr ty = D (\s -> - match s (dataTypeConstrs ty)) - where - match :: String -> [Constr] - -> Maybe (String, Constr) - match _ [] = Nothing - match input (con:cons) - | take n input == showConstr con - = Just (drop n input, con) - | otherwise - = match input cons - where - n = length (showConstr con) - - -readM :: forall a. Data a => DecM a -readM = read - where - read :: DecM a - read = do { let val = argOf read - ; let ty = dataTypeOf val - ; constr <- parseConstr ty - ; let con::a = fromConstr constr - ; gmapM (\_ -> readM) con } - -argOf :: c a -> a -argOf = undefined - -yareadM :: forall a. Data a => DecM a -yareadM = do { let ty = dataTypeOf (undefined::a) - ; constr <- parseConstr ty - ; let con::a = fromConstr constr - ; gmapM (\_ -> yareadM) con } diff --git a/tests/HList.hs b/tests/HList.hs --- a/tests/HList.hs +++ b/tests/HList.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE ExistentialQuantification #-} module HList (tests) where @@ -8,7 +8,7 @@ -} -import Test.HUnit +import Test.Tasty.HUnit import Data.Typeable @@ -16,7 +16,7 @@ -- Heterogeneously typed lists type HList = [DontKnow] -data DontKnow = forall a. Typeable a => DontKnow a +data DontKnow = forall a. Typeable a => DontKnow a -- The empty list initHList :: HList @@ -26,19 +26,6 @@ addHList :: Typeable a => a -> HList -> HList addHList a l = (DontKnow a:l) --- Test for an empty list -nullHList :: HList -> Bool -nullHList = null - --- Retrieve head by type case -headHList :: Typeable a => HList -> Maybe a -headHList [] = Nothing -headHList (DontKnow a:_) = cast a - --- Retrieve tail by type case -tailHList :: HList -> HList -tailHList = tail - -- Access per index; starts at 1 nth1HList :: Typeable a => Int -> HList -> Maybe a nth1HList i l = case (l !! (i-1)) of (DontKnow a) -> cast a @@ -47,16 +34,19 @@ ---------------------------------------------------------------------------- -- A demo list +mylist :: HList mylist = addHList (1::Int) $ addHList (True::Bool) $ addHList ("42"::String) $ initHList -- Main function for testing +tests :: Assertion tests = ( show (nth1HList 1 mylist :: Maybe Int) -- shows Just 1 , ( show (nth1HList 1 mylist :: Maybe Bool) -- shows Nothing , ( show (nth1HList 2 mylist :: Maybe Bool) -- shows Just True , ( show (nth1HList 3 mylist :: Maybe String) -- shows Just "42" - )))) ~=? output + )))) @=? output +output :: (String, (String, (String, String))) output = ("Just 1",("Nothing",("Just True","Just \"42\""))) diff --git a/tests/HOPat.hs b/tests/HOPat.hs --- a/tests/HOPat.hs +++ b/tests/HOPat.hs @@ -1,4 +1,5 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExplicitForAll #-} module HOPat (tests) where @@ -12,13 +13,13 @@ -} -import Test.HUnit +import Test.Tasty.HUnit import Data.Generics -- Sample datatypes -data T1 = T1a Int | T1b Float +data T1 = T1a Int | T1b Double deriving (Show, Eq, Typeable, Data) data T2 = T2a T1 T2 | T2b deriving (Show, Eq, Typeable, Data) @@ -31,7 +32,7 @@ -- Unwrap a term; Return its single component -unwrap :: (Data y, Data x) => y -> Maybe x +unwrap :: (Data y, Data x) => y -> Maybe x unwrap y = case gmapQ (Nothing `mkQ` Just) y of [Just x] -> Just x _ -> Nothing @@ -48,7 +49,7 @@ visitor c f = everywhere (mkT g) where g y = case elim c y of - Just x -> c (f x) + Just x -> c (f x) Nothing -> y @@ -58,7 +59,7 @@ , ( (elim T1a t1a) :: Maybe Int , ( (elim T1a t1b) :: Maybe Int , ( (visitor T1a ((+) 46) t2) :: T2 - ))))) ~=? output + ))))) @=? output where t1a = T1a 42 t1b = T1b 3.14 diff --git a/tests/Labels.hs b/tests/Labels.hs --- a/tests/Labels.hs +++ b/tests/Labels.hs @@ -1,20 +1,20 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} module Labels (tests) where -- This module tests availability of field labels. -import Test.HUnit +import Test.Tasty.HUnit import Data.Generics -- A datatype without labels -data NoLabels = NoLabels Int Float +data NoLabels = NoLabels Int Double deriving (Typeable, Data) -- A datatype with labels data YesLabels = YesLabels { myint :: Int - , myfloat :: Float + , myfloat :: Double } deriving (Typeable, Data) @@ -25,6 +25,6 @@ -- Main function for testing tests = ( constrFields $ toConstr noLabels , constrFields $ toConstr yesLabels - ) ~=? output + ) @=? output output = ([],["myint","myfloat"]) diff --git a/tests/LocalQuantors.hs b/tests/LocalQuantors.hs --- a/tests/LocalQuantors.hs +++ b/tests/LocalQuantors.hs @@ -1,4 +1,5 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} module LocalQuantors () where @@ -12,7 +13,7 @@ instance Data Test where - gfoldl _ z x = z x -- folding without descent + gfoldl _ z x = z x -- folding without descent toConstr (Test _) = testConstr gunfold _ _ = error "gunfold" dataTypeOf _ = testDataType diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,13 +1,15 @@ module Main where -import Test.HUnit +import Test.Tasty +import Test.Tasty.HUnit import System.Exit import qualified Bits import qualified Builders import qualified Datatype import qualified Ext1 +import qualified Ext2 import qualified FoldTree import qualified FreeNames import qualified GEq @@ -28,7 +30,6 @@ import qualified Strings import qualified Tree import qualified Twin -import qualified Typeable import qualified Typecase1 import qualified Typecase2 import qualified Where @@ -41,42 +42,34 @@ import qualified NestedDatatypes -- no tests, should compile import qualified Polymatch -- no tests, should compile - -tests = - "All" ~: [ Datatype.tests - , FoldTree.tests - , GetC.tests - , GMapQAssoc.tests - , GRead.tests - , GShow.tests - , GShow2.tests - , HList.tests - , HOPat.tests - , Labels.tests - , Newtype.tests - , Perm.tests - , Twin.tests - , Typeable.tests - , Typecase1.tests - , Typecase2.tests - , Where.tests - , XML.tests - , Tree.tests - , Strings.tests - , Reify.tests - , Paradise.tests - , GZip.tests - , GEq.tests - , GenUpTo.tests - , FreeNames.tests - , Ext1.tests - , Bits.tests - , Builders.tests - ] - -main = do - putStrLn "Running tests for syb..." - counts <- runTestTT tests - if (failures counts > 0) - then exitFailure - else exitSuccess +main = defaultMain $ testGroup "All" + [ testCase "Datatype" Datatype.tests + , testCase "FoldTree" FoldTree.tests + , testCase "GetC" GetC.tests + , testCase "GMapQAssoc" GMapQAssoc.tests + , testCase "GRead" GRead.tests + , testCase "GShow" GShow.tests + , testCase "GShow2" GShow2.tests + , testCase "HList" HList.tests + , testCase "HOPat" HOPat.tests + , testCase "Labels" Labels.tests + , testCase "Newtype" Newtype.tests + , testCase "Perm" Perm.tests + , testCase "Twin" Twin.tests + , testCase "Typecase1" Typecase1.tests + , testCase "Typecase2" Typecase2.tests + , testCase "Where" Where.tests + , testCase "XML" XML.tests + , testCase "Tree" Tree.tests + , testCase "Strings" Strings.tests + , testCase "Reify" Reify.tests + , testCase "Paradise" Paradise.tests + , testCase "GZip" GZip.tests + , testCase "GEq" GEq.tests + , testCase "GenUpTo" GenUpTo.tests + , testCase "FreeNames" FreeNames.tests + , testCase "Ext1" Ext1.tests + , testCase "Ext2" Ext2.tests + , testCase "Bits" Bits.tests + , testCase "Builders" Builders.tests + ] diff --git a/tests/NestedDatatypes.hs b/tests/NestedDatatypes.hs --- a/tests/NestedDatatypes.hs +++ b/tests/NestedDatatypes.hs @@ -1,4 +1,6 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE UndecidableInstances #-} module NestedDatatypes () where @@ -18,19 +20,9 @@ import Data.Dynamic import Data.Generics - --- A nested datatype -data Nest a = Box a | Wrap (Nest [a]) - --- The representation of the type constructor -nestTc = mkTyCon "Nest" - - --- The Typeable instance for the nested datatype -instance Typeable1 Nest - where - typeOf1 n = mkTyConApp nestTc [] +-- A nested datatype +data Nest a = Box a | Wrap (Nest [a]) deriving Typeable -- The Data instance for the nested datatype diff --git a/tests/Newtype.hs b/tests/Newtype.hs --- a/tests/Newtype.hs +++ b/tests/Newtype.hs @@ -1,15 +1,20 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} module Newtype (tests) where -- The type of a newtype should treat the newtype as opaque -import Test.HUnit +import Test.Tasty.HUnit import Data.Generics newtype T = MkT Int deriving( Typeable ) -tests = show (typeOf (undefined :: T)) ~=? output +tests = show (typeOf (undefined :: T)) @?= output +#if __GLASGOW_HASKELL__ >= 701 +output = "T" +#else output = "Newtype.T" +#endif diff --git a/tests/Paradise.hs b/tests/Paradise.hs --- a/tests/Paradise.hs +++ b/tests/Paradise.hs @@ -1,5 +1,3 @@ -{-# OPTIONS -fglasgow-exts #-} - module Paradise (tests) where {- @@ -11,19 +9,19 @@ -} -import Test.HUnit +import Test.Tasty.HUnit import Data.Generics import CompanyDatatypes -- Increase salary by percentage -increase :: Float -> Company -> Company +increase :: Double -> Company -> Company increase k = everywhere (mkT (incS k)) -- "interesting" code for increase -incS :: Float -> Salary -> Salary +incS :: Double -> Salary -> Salary incS k (S s) = S (s * (1+k)) -tests = increase 0.1 genCom ~=? output +tests = increase 0.125 genCom @=? output -output = C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8800.0)) [PU (E (P "Joost" "Amsterdam") (S 1100.0)),PU (E (P "Marlow" "Cambridge") (S 2200.0))],D "Strategy" (E (P "Blair" "London") (S 110000.0)) []] +output = C [D "Research" (E (P "Laemmel" "Amsterdam") (S 9000)) [PU (E (P "Joost" "Amsterdam") (S 1125)),PU (E (P "Marlow" "Cambridge") (S 2250))],D "Strategy" (E (P "Blair" "London") (S 112500)) []] diff --git a/tests/Perm.hs b/tests/Perm.hs --- a/tests/Perm.hs +++ b/tests/Perm.hs @@ -1,4 +1,6 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} module Perm (tests) where @@ -9,8 +11,9 @@ -} -import Test.HUnit +import Test.Tasty.HUnit +import Control.Applicative (Alternative(..)) import Control.Monad import Data.Generics @@ -18,9 +21,9 @@ -- We want to read terms of type T3 regardless of the order T1 and T2. --------------------------------------------------------------------------- -data T1 = T1 deriving (Show, Eq, Typeable, Data) -data T2 = T2 deriving (Show, Eq, Typeable, Data) -data T3 = T3 T1 T2 deriving (Show, Eq, Typeable, Data) +data T1 = T1 deriving (Show, Eq, Data) +data T2 = T2 deriving (Show, Eq, Data) +data T3 = T3 T1 T2 deriving (Show, Eq, Data) --------------------------------------------------------------------------- @@ -33,20 +36,32 @@ -- Run a computation +runReadT :: ReadT a -> [String] -> Maybe a runReadT x y = case unReadT x y of - Just ([],y) -> Just y + Just ([],z) -> Just z _ -> Nothing -- Read one string readT :: ReadT String -readT = ReadT (\x -> if null x - then Nothing - else Just (tail x, head x) +readT = ReadT (\x -> case x of + [] -> Nothing + y : ys -> Just (ys, y) ) +instance Functor ReadT where + fmap = liftM + +instance Applicative ReadT where + pure x = ReadT (\y -> Just (y,x)) + (<*>) = ap + +instance Alternative ReadT where + (<|>) = mplus + empty = mzero + -- ReadT is a monad! instance Monad ReadT where - return x = ReadT (\y -> Just (y,x)) + return = pure c >>= f = ReadT (\x -> case unReadT c x of Nothing -> Nothing Just (x', a) -> unReadT (f a) x' @@ -85,7 +100,7 @@ -- Determine type of data to be constructed myType = myTypeOf result where - myTypeOf :: forall a. ReadT a -> a + myTypeOf :: forall b. ReadT b -> b myTypeOf = undefined -- Turn string into constructor @@ -94,11 +109,11 @@ (readConstr (dataTypeOf myType) str) -- Specialise buildT per kid type - buildT' :: forall a. Data a => a -> GenM - buildT' (_::a) = GenM (const mzero `extM` const (buildT::ReadT a)) + buildT' :: forall b. Data b => b -> GenM + buildT' (_::b) = GenM (const mzero `extM` const (buildT::ReadT b)) -- The permutation exploration function - perm :: forall a. Data a => [GenM] -> [GenM] -> a -> ReadT a + perm :: forall b. Data b => [GenM] -> [GenM] -> b -> ReadT b perm [] [] a = return a perm fs [] a = perm [] fs a perm fs (f:fs') a = ( @@ -116,12 +131,14 @@ -- The main function for testing --------------------------------------------------------------------------- +tests :: Assertion tests = ( runReadT buildT ["T1"] :: Maybe T1 -- should parse fine , ( runReadT buildT ["T2"] :: Maybe T2 -- should parse fine , ( runReadT buildT ["T3","T1","T2"] :: Maybe T3 -- should parse fine , ( runReadT buildT ["T3","T2","T1"] :: Maybe T3 -- should parse fine , ( runReadT buildT ["T3","T2","T2"] :: Maybe T3 -- should fail - ))))) ~=? output + ))))) @=? output +output :: (Maybe T1, (Maybe T2, (Maybe T3, (Maybe T3, Maybe a)))) output = (Just T1,(Just T2,(Just (T3 T1 T2),(Just (T3 T1 T2),Nothing)))) diff --git a/tests/Polymatch.hs b/tests/Polymatch.hs --- a/tests/Polymatch.hs +++ b/tests/Polymatch.hs @@ -1,4 +1,5 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} module Polymatch () where @@ -13,7 +14,7 @@ data Kid = forall k. Typeable k => Kid k --- Build term from a list of kids and the constructor +-- Build term from a list of kids and the constructor fromConstrL :: Data a => Kids -> Constr -> Maybe a fromConstrL l = unIDL . gunfold k z where @@ -42,7 +43,7 @@ f g (Right a) = Right $ g a -- conversion really needed -- f g (Left s) = Left s -- unappreciated conversion --- f g s = s -- doesn't typecheck +-- f g s = s -- doesn't typecheck -- f g s = deep_rebuild s -- too expensive f g s = just (shallow_rebuild s) -- perhaps this is Ok? @@ -58,7 +59,7 @@ -- For the record: it's possible. shallow_rebuild :: (Data a, Data b) => a -> Maybe b -shallow_rebuild a = b +shallow_rebuild a = b where b = fromConstrL (kids a) constr constr = indexConstr (dataTypeOf b) (constrIndex (toConstr a)) diff --git a/tests/Reify.hs b/tests/Reify.hs --- a/tests/Reify.hs +++ b/tests/Reify.hs @@ -1,5 +1,8 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Reify (tests) where {- @@ -10,7 +13,7 @@ -} -import Test.HUnit +import Test.Tasty.HUnit import Data.Maybe import Data.Generics @@ -21,11 +24,11 @@ ------------------------------------------------------------------------------ -- --- Encoding types as values; some other way. +-- Encoding types as values; some other way. -- ------------------------------------------------------------------------------ -{- +{- This group provides a style of encoding types as values and using them. This style is seen as an alternative to the pragmatic style used @@ -92,7 +95,7 @@ -- Generic type functions, -- i.e., functions mapping types to values -- -type GTypeFun r = forall a. Data a => TypeFun a r +type GTypeFun r = forall a. Data a => TypeFun a r @@ -104,7 +107,7 @@ ------------------------------------------------------------------------------ -- --- Mapping operators to map over type structure +-- Mapping operators to map over type structure -- ------------------------------------------------------------------------------ @@ -116,7 +119,7 @@ -> GTypeFun r gmapType (o::[(Constr,r')] -> r) f (t::TypeVal a) - = + = o $ zip cons query where @@ -125,7 +128,7 @@ cons :: [Constr] cons = if isAlgType $ dataTypeOf $ type2val t then dataTypeConstrs $ dataTypeOf $ type2val t - else [] + else [] -- Query constructors query :: [r'] @@ -139,7 +142,7 @@ -> GTypeFun (Constr -> r') gmapConstr (o::[r] -> r') f (t::TypeVal a) c - = + = o $ query where @@ -159,7 +162,7 @@ -- | Query all immediate subterm types of a given type -gmapSubtermTypes :: (Data a, Typeable r) +gmapSubtermTypes :: (Data a, Typeable r) => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r gmapSubtermTypes o (r::r) f (t::TypeVal a) = @@ -204,8 +207,8 @@ gmapSubtermTypesConst :: (Data a, Typeable r) => (r -> r -> r) -> r - -> GTypeFun r - -> TypeVal a + -> GTypeFun r + -> TypeVal a -> r gmapSubtermTypesConst o (r::r) f (t::TypeVal a) = @@ -224,7 +227,7 @@ -- Weakness: no awareness of doubles. -- Strength: easy to comprehend as it uses gmapType and gmapConstr. -_gmapSubtermTypes :: (Data a, Typeable r) +_gmapSubtermTypes :: (Data a, Typeable r) => (r -> r -> r) -> r -> GTypeFun r -> TypeVal a -> r _gmapSubtermTypes o (r::r) f = @@ -241,7 +244,7 @@ ------------------------------------------------------------------------------ -- --- Some reifying relations on types +-- Some reifying relations on types -- ------------------------------------------------------------------------------ @@ -264,11 +267,11 @@ depthOfType :: GTypeFun Bool -> GTypeFun (Maybe (Constr, Maybe Int)) depthOfType p (t::TypeVal a) - = + = gmapType o f t where - + o :: [(Constr, Maybe Int)] -> Maybe (Constr, Maybe Int) o l = if null l then Nothing else Just (foldr1 min' l) @@ -322,7 +325,7 @@ ------------------------------------------------------------------------------ -- --- Build a shallow term +-- Build a shallow term -- ------------------------------------------------------------------------------ @@ -331,30 +334,30 @@ = result where result :: forall b. Data b => b - -- Need a type signature here to bring 'b' into scope + -- Need a type signature here to bring 'b' into scope result = maybe gdefault id cust - where + where - -- The worker, also used for type disambiguation - gdefault :: b - gdefault = case con of - Just (con, Just _) -> fromConstrB (shallowTerm cust) con - _ -> error "no shallow term!" + -- The worker, also used for type disambiguation + gdefault :: b + gdefault = case con of + Just (con, Just _) -> fromConstrB (shallowTerm cust) con + _ -> error "no shallow term!" - -- The type to be constructed - typeVal :: TypeVal b - typeVal = val2type gdefault + -- The type to be constructed + typeVal :: TypeVal b + typeVal = val2type gdefault - -- The most shallow constructor if any - con :: Maybe (Constr, Maybe Int) - con = depthOfType (const True) typeVal + -- The most shallow constructor if any + con :: Maybe (Constr, Maybe Int) + con = depthOfType (const True) typeVal -- For testing shallowTerm shallowTermBase :: GenericR Maybe -shallowTermBase = Nothing - `extR` Just (1.23::Float) +shallowTermBase = Nothing + `extR` Just (1.23::Double) `extR` Just ("foo"::String) @@ -406,7 +409,7 @@ , ( test8 , ( test9 , ( test10 - ))))))))))) ~=? output + ))))))))))) @=? output output = (True,(True,(False,(True,(True,(1,(2,(3,(P "foo" "foo", (E (P "foo" "foo") (S 1.23), diff --git a/tests/Strings.hs b/tests/Strings.hs --- a/tests/Strings.hs +++ b/tests/Strings.hs @@ -1,5 +1,3 @@ -{-# OPTIONS -fglasgow-exts #-} - module Strings (tests) where {- @@ -11,11 +9,11 @@ -} -import Test.HUnit +import Test.Tasty.HUnit import Data.Generics import CompanyDatatypes tests = (case gread (gshow genCom) of [(x,_)] -> geq genCom x - _ -> False) ~=? True + _ -> False) @=? True diff --git a/tests/Tree.hs b/tests/Tree.hs --- a/tests/Tree.hs +++ b/tests/Tree.hs @@ -1,5 +1,7 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-} + module Tree (tests) where {- @@ -9,12 +11,13 @@ -} -import Test.HUnit +import Test.Tasty.HUnit -import Control.Monad.Reader +import Control.Monad (guard) import Data.Generics import Data.Maybe import Data.Tree + import CompanyDatatypes @@ -34,29 +37,31 @@ gdefault (Node x ts) = res where - -- a helper for type capture + -- a helper for type capture res = maybe Nothing (kids . fromConstr) con - -- the type to constructed + -- the type to constructed ta = fromJust res - -- construct constructor + -- construct constructor con = readConstr (dataTypeOf ta) x -- recursion per kid with accumulation - perkid ts = const (tail ts, tree2data (head ts)) + perkid ts = const (tail ts, tree2data (head ts)) -- recurse into kids - kids x = - do guard (glength x == length ts) - snd (gmapAccumM perkid ts x) + kids y = + do guard (glength y == length ts) + snd (gmapAccumM perkid ts y) -- Main function for testing +tests :: Assertion tests = ( genCom - , ( data2tree genCom - , ( (tree2data (data2tree genCom)) :: Maybe Company + , ( data2tree genCom + , ( (tree2data (data2tree genCom)) :: Maybe Company , ( Just genCom == tree2data (data2tree genCom) - )))) ~=? output + )))) @=? output +output :: (Company, (Tree String, (Maybe Company, Bool))) output = (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []],(Node {rootLabel = "C", subForest = [Node {rootLabel = "(:)", subForest = [Node {rootLabel = "D", subForest = [Node {rootLabel = "Research", subForest = []},Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Laemmel", subForest = []},Node {rootLabel = "Amsterdam", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "8000.0", subForest = []}]}]},Node {rootLabel = "(:)", subForest = [Node {rootLabel = "PU", subForest = [Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Joost", subForest = []},Node {rootLabel = "Amsterdam", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "1000.0", subForest = []}]}]}]},Node {rootLabel = "(:)", subForest = [Node {rootLabel = "PU", subForest = [Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Marlow", subForest = []},Node {rootLabel = "Cambridge", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "2000.0", subForest = []}]}]}]},Node {rootLabel = "[]", subForest = []}]}]}]},Node {rootLabel = "(:)", subForest = [Node {rootLabel = "D", subForest = [Node {rootLabel = "Strategy", subForest = []},Node {rootLabel = "E", subForest = [Node {rootLabel = "P", subForest = [Node {rootLabel = "Blair", subForest = []},Node {rootLabel = "London", subForest = []}]},Node {rootLabel = "S", subForest = [Node {rootLabel = "100000.0", subForest = []}]}]},Node {rootLabel = "[]", subForest = []}]},Node {rootLabel = "[]", subForest = []}]}]}]},(Just (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []]),True))) diff --git a/tests/Twin.hs b/tests/Twin.hs --- a/tests/Twin.hs +++ b/tests/Twin.hs @@ -1,5 +1,6 @@ -{-# OPTIONS -fglasgow-exts #-} - +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} + module Twin (tests) where {- @@ -8,13 +9,13 @@ we favour some simplified development of twin traversal. So the full general, stepwise story is in Data.Generics.Twin, but the short version from the paper is turned into a test -case below. +case below. See the paper for an explanation. - + -} -import Test.HUnit +import Test.Tasty.HUnit import Data.Generics hiding (GQ,gzipWithQ,geq) @@ -23,13 +24,13 @@ && and (gzipWithQ geq' x y) geq :: Data a => a -> a -> Bool -geq = geq' +geq a = geq' a newtype GQ r = GQ (GenericQ r) gzipWithQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r]) -gzipWithQ f t1 t2 +gzipWithQ f t1 t2 = gApplyQ (gmapQ (\x -> GQ (f x)) t1) t2 gApplyQ :: Data a => [GQ r] -> a -> [r] @@ -42,7 +43,7 @@ newtype R r x = R { unR :: r } gfoldlQ :: (r -> GenericQ r) - -> r + -> r -> GenericQ r gfoldlQ k z t = unR (gfoldl k' z' t) @@ -85,6 +86,6 @@ , geq [True,True] [True,False] , geq'' [True,True] [True,True] , geq'' [True,True] [True,False] - ) ~=? output + ) @=? output output = (True,False,True,False) diff --git a/tests/Typeable.hs b/tests/Typeable.hs deleted file mode 100644 --- a/tests/Typeable.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - -module Typeable (tests) where - -import Test.HUnit - -import Data.Typeable - -newtype Y e = Y { unY :: (e (Y e)) } - -instance Typeable1 e => Typeable (Y e) where - typeOf _ = mkTyConApp yTc [typeOf1 (undefined :: e ())] - -yTc :: TyCon -yTc = mkTyCon "Typeable.Y" - -tests = show (typeOf (undefined :: Y [])) ~=? output - -output = "Typeable.Y []" diff --git a/tests/Typecase1.hs b/tests/Typecase1.hs --- a/tests/Typecase1.hs +++ b/tests/Typecase1.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} module Typecase1 (tests) where @@ -10,7 +10,7 @@ -} -import Test.HUnit +import Test.Tasty.HUnit import Data.Typeable import Data.Maybe @@ -22,19 +22,19 @@ -- Some function that performs type case. -- f :: (Show a, Typeable a) => a -> String -f a = (maybe (maybe (maybe others - mytys (cast a) ) - float (cast a) ) - int (cast a) ) +f a = (maybe (maybe (maybe others + mytys (cast a) ) + float (cast a) ) + int (cast a) ) where -- do something with ints int :: Int -> String int a = "got an int, incremented: " ++ show (a + 1) - + -- do something with floats - float :: Float -> String + float :: Double -> String float a = "got a float, multiplied by .42: " ++ show (a * 0.42) -- do something with my typeables @@ -49,9 +49,9 @@ -- Test the type case -- tests = ( f (41::Int) - , f (88::Float) + , f (88::Double) , f (MyCons "42") - , f True) ~=? output + , f True) @=? output output = ( "got an int, incremented: 42" , "got a float, multiplied by .42: 36.96" diff --git a/tests/Typecase2.hs b/tests/Typecase2.hs --- a/tests/Typecase2.hs +++ b/tests/Typecase2.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} module Typecase2 (tests) where @@ -11,7 +11,7 @@ -} -import Test.HUnit +import Test.Tasty.HUnit import Data.Generics import Data.Maybe @@ -23,19 +23,19 @@ -- Some function that performs type case. -- f :: Data a => a -> String -f a = (maybe (maybe (maybe others - mytys (cast a) ) - float (cast a) ) - int (cast a) ) +f a = (maybe (maybe (maybe others + mytys (cast a) ) + float (cast a) ) + int (cast a) ) where -- do something with ints int :: Int -> String int a = "got an int, incremented: " ++ show (a + 1) - + -- do something with floats - float :: Float -> String + float :: Double -> String float a = "got a float, multiplied by .42: " ++ show (a * 0.42) -- do something with my data @@ -50,9 +50,9 @@ -- Test the type case -- tests = ( f (41::Int) - , f (88::Float) + , f (88::Double) , f (MyCons "42") - , f True) ~=? output + , f True) @=? output output = ( "got an int, incremented: 42" , "got a float, multiplied by .42: 36.96" diff --git a/tests/Where.hs b/tests/Where.hs --- a/tests/Where.hs +++ b/tests/Where.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} module Where (tests) where @@ -48,11 +48,11 @@ Attempts to reach all nodes where all the sub-traversals are performed in monadic bind-sequence. Failure of the traversal for a given subterm - implies failure of the entire traversal. Hence, the argument of + implies failure of the entire traversal. Hence, the argument of "everywhereM" should be designed in a way that it tends to succeed except for the purpose of propagating a proper error in the sense of violating a pre-/post-condition. For example, "mkM stepfail" should - not be passed to "everywhereM" as it will fail for all but one term + not be passed to "everywhereM" as it will fail for all but one term pattern; see "recovered" for a way to massage "stepfail" accordingly. c) somewhere @@ -71,7 +71,7 @@ -} -import Test.HUnit +import Test.Tasty.HUnit import Data.Generics import Control.Monad @@ -120,6 +120,6 @@ ( result4, ( result5, ( result6, - ( result7 ))))))) ~=? output + ( result7 ))))))) @=? output output = "((,) (T1b (T2 (T1a (88)))) ((,) (T1b (T2 (T1a (37)))) ((,) (Nothing) ((,) (Nothing) ((,) (Just (T1b (T2 (T1a (37))))) ((,) (Just (T1b (T2 (T1a (88))))) (Nothing)))))))" diff --git a/tests/XML.hs b/tests/XML.hs --- a/tests/XML.hs +++ b/tests/XML.hs @@ -1,4 +1,5 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} module XML (tests) where @@ -11,24 +12,24 @@ -} -import Test.HUnit +import Test.Tasty.HUnit +import Control.Applicative (Alternative(..)) import Control.Monad -import Data.Maybe import Data.Generics import CompanyDatatypes -- HaXml-like types for XML elements data Element = Elem Name [Attribute] [Content] - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) data Content = CElem Element | CString Bool CharData -- ^ bool is whether whitespace is significant | CRef Reference | CMisc Misc - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) type CharData = String @@ -43,14 +44,14 @@ data2content :: Data a => a -> [Content] data2content = element `ext1Q` list - `extQ` string + `extQ` string `extQ` float where -- Handle an element element x = [CElem (Elem (tyconUQname (dataTypeName (dataTypeOf x))) - [] -- no attributes + [] -- no attributes (concat (gmapQ data2content x)))] -- A special case for lists @@ -62,7 +63,7 @@ string x = [CString True x] -- A special case for floats - float :: Float -> [Content] + float :: Double -> [Content] float x = [CString True (show x)] @@ -71,7 +72,7 @@ content2data = result where - + -- Case-discriminating worker result = element `ext1R` list @@ -82,7 +83,7 @@ -- Determine type of data to be constructed myType = myTypeOf result where - myTypeOf :: forall a. ReadX a -> a + myTypeOf :: forall b. ReadX b -> b myTypeOf = undefined -- Handle an element @@ -96,7 +97,7 @@ -- A special case for lists - list :: forall a. Data a => ReadX [a] + list :: forall b. Data b => ReadX [b] list = ( do h <- content2data t <- list return (h:t) ) @@ -110,7 +111,7 @@ -- Retrieve all constructors of the requested type consOf = dataTypeConstrs - $ dataTypeOf + $ dataTypeOf $ myType -- Recurse into subterms @@ -126,7 +127,7 @@ _ -> mzero -- A special case for floats - float :: ReadX Float + float :: ReadX Double float = do c <- readX case c of (CString _ x) -> return (read x) @@ -146,20 +147,32 @@ -> Maybe ([Content], a) } -- Run a computation -runReadX x y = case unReadX x y of - Just ([],y) -> Just y +runReadX :: ReadX a -> [Content] -> Maybe a +runReadX x y = case unReadX x y of + Just ([],z) -> Just z _ -> Nothing -- Read one content particle readX :: ReadX Content -readX = ReadX (\x -> if null x - then Nothing - else Just (tail x, head x) +readX = ReadX (\x -> case x of + [] -> Nothing + y : ys -> Just (ys, y) ) +instance Functor ReadX where + fmap = liftM + +instance Applicative ReadX where + pure x = ReadX (\y -> Just (y,x)) + (<*>) = ap + +instance Alternative ReadX where + (<|>) = mplus + empty = mzero + -- ReadX is a monad! instance Monad ReadX where - return x = ReadX (\y -> Just (y,x)) + return = pure c >>= f = ReadX (\x -> case unReadX c x of Nothing -> Nothing Just (x', a) -> unReadX (f a) x' @@ -181,15 +194,17 @@ -- ----------------------------------------------------------------------------- +tests :: Assertion tests = ( genCom , ( data2content genCom , ( zigzag person1 :: Maybe Person , ( zigzag genCom :: Maybe Company , ( zigzag genCom == Just genCom - ))))) ~=? output - where + ))))) @=? output + where -- Trealise back and forth zigzag :: Data a => a -> Maybe a zigzag = runReadX content2data . data2content +output :: (Company, ([Content], (Maybe Person, (Maybe Company, Bool)))) output = (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []],([CElem (Elem "Company" [] [CElem (Elem "Dept" [] [CString True "Research",CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Laemmel",CString True "Amsterdam"]),CElem (Elem "Salary" [] [CString True "8000.0"])]),CElem (Elem "Unit" [] [CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Joost",CString True "Amsterdam"]),CElem (Elem "Salary" [] [CString True "1000.0"])])]),CElem (Elem "Unit" [] [CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Marlow",CString True "Cambridge"]),CElem (Elem "Salary" [] [CString True "2000.0"])])])]),CElem (Elem "Dept" [] [CString True "Strategy",CElem (Elem "Employee" [] [CElem (Elem "Person" [] [CString True "Blair",CString True "London"]),CElem (Elem "Salary" [] [CString True "100000.0"])])])])],(Just (P "Lazy" "Home"),(Just (C [D "Research" (E (P "Laemmel" "Amsterdam") (S 8000.0)) [PU (E (P "Joost" "Amsterdam") (S 1000.0)),PU (E (P "Marlow" "Cambridge") (S 2000.0))],D "Strategy" (E (P "Blair" "London") (S 100000.0)) []]),True))))