diff --git a/Data/Generics/SYB/WithClass/Basics.hs b/Data/Generics/SYB/WithClass/Basics.hs --- a/Data/Generics/SYB/WithClass/Basics.hs +++ b/Data/Generics/SYB/WithClass/Basics.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE UndecidableInstances, OverlappingInstances, Rank2Types, +{-# LANGUAGE UndecidableInstances, Rank2Types, CPP, KindSignatures, MultiParamTypeClasses, EmptyDataDecls #-} -{- +{- | (C) 2004--2005 Ralf Laemmel, Simon D. Foster @@ -33,7 +33,7 @@ #endif ------------------------------------------------------------------------------ --- The ingenious Data class +-- * The ingenious Data class class (Typeable a, Sat (ctx a)) => Data ctx a @@ -66,14 +66,22 @@ dataTypeOf _ _ = undefined -- | Mediate types and unary type constructors +#if MIN_VERSION_base(4,11,0) + dataCast1 :: Typeable t +#else dataCast1 :: Typeable1 t +#endif => Proxy ctx -> (forall b. Data ctx b => w (t b)) -> Maybe (w a) dataCast1 _ _ = Nothing -- | Mediate types and binary type constructors +#if MIN_VERSION_base(4,11,0) + dataCast2 :: Typeable t +#else dataCast2 :: Typeable2 t +#endif => Proxy ctx -> (forall b c. (Data ctx b, Data ctx c) => w (t b c)) -> Maybe (w a) @@ -83,12 +91,12 @@ ------------------------------------------------------------------------------ --- Generic transformations +-- * Generic transformations type GenericT ctx = forall a. Data ctx a => a -> a --- Generic map for transformations +-- | Generic map for transformations gmapT :: Proxy ctx -> GenericT ctx -> GenericT ctx @@ -97,18 +105,18 @@ k (ID g) y = ID (g (f y)) --- The identity type constructor +-- | The identity type constructor newtype ID x = ID { unID :: x } ------------------------------------------------------------------------------ --- Generic monadic transformations +-- | Generic monadic transformations type GenericM m ctx = forall a. Data ctx a => a -> m a --- Generic map for monadic transformations +-- | Generic map for monadic transformations gmapM :: Monad m => Proxy ctx -> GenericM m ctx -> GenericM m ctx gmapM ctx f = gfoldl ctx k return @@ -119,12 +127,12 @@ ------------------------------------------------------------------------------ --- Generic queries +-- * Generic queries type GenericQ ctx r = forall a. Data ctx a => a -> r --- Map for queries +-- | Map for queries gmapQ :: Proxy ctx -> GenericQ ctx r -> GenericQ ctx [r] gmapQ ctx f = gmapQr ctx (:) [] f @@ -140,14 +148,14 @@ where k (Qr g) y = Qr (\s -> g (f y `o` s)) --- The type constructor used in definition of gmapQr +-- | The type constructor used in definition of gmapQr newtype Qr r a = Qr { unQr :: r -> r } ------------------------------------------------------------------------------ -- --- Generic unfolding +-- * Generic unfolding -- ------------------------------------------------------------------------------ @@ -185,15 +193,15 @@ ------------------------------------------------------------------------------ -- --- Datatype and constructor representations +-- * Datatype and constructor representations -- ------------------------------------------------------------------------------ -- -- | Representation of datatypes. --- | A package of constructor representations with names of type and module. --- | The list of constructors could be an array, a balanced tree, or others. +-- A package of constructor representations with names of type and module. +-- The list of constructors could be an array, a balanced tree, or others. -- data DataType = DataType { tycon :: String @@ -256,7 +264,7 @@ ------------------------------------------------------------------------------ -- --- Observers for datatype representations +-- * Observers for datatype representations -- ------------------------------------------------------------------------------ @@ -296,7 +304,7 @@ ------------------------------------------------------------------------------ -- --- Representations of algebraic data types +-- * Representations of algebraic data types -- ------------------------------------------------------------------------------ @@ -344,7 +352,7 @@ ------------------------------------------------------------------------------ -- --- From strings to constr's and vice versa: all data types +-- * From strings to constr's and vice versa: all data types -- ------------------------------------------------------------------------------ @@ -381,7 +389,7 @@ ------------------------------------------------------------------------------ -- --- Convenience funtions: algebraic data types +-- * Convenience funtions: algebraic data types -- ------------------------------------------------------------------------------ @@ -417,7 +425,7 @@ ------------------------------------------------------------------------------ -- --- Representation of primitive types +-- * Representation of primitive types -- ------------------------------------------------------------------------------ @@ -445,7 +453,7 @@ } --- Makes a constructor for primitive types +-- | Makes a constructor for primitive types mkPrimCon :: DataType -> String -> ConstrRep -> Constr mkPrimCon dt str cr = Constr { datatype = dt @@ -456,18 +464,21 @@ } +-- | Makes a constructor for an Int mkIntConstr :: DataType -> Integer -> Constr mkIntConstr dt i = case datarep dt of IntRep -> mkPrimCon dt (show i) (IntConstr i) _ -> error "mkIntConstr" +-- | Makes a constructor for a Float mkFloatConstr :: DataType -> Double -> Constr mkFloatConstr dt f = case datarep dt of FloatRep -> mkPrimCon dt (show f) (FloatConstr f) _ -> error "mkFloatConstr" +-- | Makes a constructor for a String mkStringConstr :: DataType -> String -> Constr mkStringConstr dt str = case datarep dt of StringRep -> mkPrimCon dt str (StringConstr str) @@ -476,7 +487,7 @@ ------------------------------------------------------------------------------ -- --- Non-representations for non-presentable types +-- * Non-representations for non-presentable types -- ------------------------------------------------------------------------------ diff --git a/Data/Generics/SYB/WithClass/Context.hs b/Data/Generics/SYB/WithClass/Context.hs --- a/Data/Generics/SYB/WithClass/Context.hs +++ b/Data/Generics/SYB/WithClass/Context.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE UndecidableInstances, OverlappingInstances, EmptyDataDecls #-} +{-# LANGUAGE UndecidableInstances, EmptyDataDecls #-} -{- +{- | (C) 2004 Ralf Laemmel @@ -16,7 +16,7 @@ ------------------------------------------------------------------------------ -- --- The Sat class from John Hughes' "Restricted Data Types in Haskell" +-- | The Sat class from John Hughes' "Restricted Data Types in Haskell" -- class Sat a @@ -26,7 +26,7 @@ ------------------------------------------------------------------------------ --- No context +-- | No context data NoCtx a @@ -38,7 +38,7 @@ ------------------------------------------------------------------------------ --- Pair context +-- | Pair context data PairCtx l r a = PairCtx { leftCtx :: l a diff --git a/Data/Generics/SYB/WithClass/Derive.hs b/Data/Generics/SYB/WithClass/Derive.hs --- a/Data/Generics/SYB/WithClass/Derive.hs +++ b/Data/Generics/SYB/WithClass/Derive.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell, CPP #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} --- We can't warn about missing sigs as we have a group of decls in +-- | We can't warn about missing sigs as we have a group of decls in -- quasi-quotes that we're going to put in a class instance -- @@ -54,15 +54,19 @@ where index [] _ = Nothing index (x:_) 0 = Just x index (_:xs) n = index xs (n - 1) - names = [(''Typeable, 'typeOf), - (''Typeable1, 'typeOf1), - (''Typeable2, 'typeOf2), - (''Typeable3, 'typeOf3), - (''Typeable4, 'typeOf4), - (''Typeable5, 'typeOf5), - (''Typeable6, 'typeOf6), - (''Typeable7, 'typeOf7)] + names = [ (''Typeable, 'typeOf) +#if MIN_VERSION_base(4,11,0) +#else + , (''Typeable1, 'typeOf1) + , (''Typeable2, 'typeOf2) + , (''Typeable3, 'typeOf3) + , (''Typeable4, 'typeOf4) + , (''Typeable5, 'typeOf5) + , (''Typeable6, 'typeOf6) + , (''Typeable7, 'typeOf7) #endif + ] +#endif type Constructor = (Name, -- Name of the constructor Int, -- Number of constructor arguments @@ -232,11 +236,15 @@ |] #endif -{- instance Data NameSet where +{- | + @@ + instance Data NameSet where gunfold _ _ _ = error ("gunfold not implemented") toConstr x = error ("toConstr not implemented for " ++ show (typeOf x)) dataTypeOf x = error ("dataTypeOf not implemented for " ++ show (typeOf x)) - gfoldl f z x = z x -} + gfoldl f z x = z x + @@ +-} typeInfo :: Dec -> Q (Name, -- Name of the datatype @@ -260,9 +268,13 @@ fields = map getField xs types = map getType xs in (c, length xs, Just fields, types) +#if MIN_VERSION_template_haskell(2,17,0) + varName (PlainTV n _) = n + varName (KindedTV n _ _) = n +#else varName (PlainTV n) = n varName (KindedTV n _) = n - +#endif -- -- | Derives the Data and Typeable instances for a single given data type. -- diff --git a/Data/Generics/SYB/WithClass/Instances.hs b/Data/Generics/SYB/WithClass/Instances.hs --- a/Data/Generics/SYB/WithClass/Instances.hs +++ b/Data/Generics/SYB/WithClass/Instances.hs @@ -1,6 +1,12 @@ -{-# LANGUAGE TemplateHaskell, FlexibleInstances, - UndecidableInstances, OverlappingInstances, CPP, - MultiParamTypeClasses #-} +------------------------------------------------------------------------------ +-- +-- | Instances of the Data class for Prelude-like types. +-- We define top-level definitions for representations. +-- +------------------------------------------------------------------------------ + +{-# LANGUAGE TemplateHaskell, FlexibleContexts, FlexibleInstances, + UndecidableInstances, CPP, MultiParamTypeClasses #-} #if MIN_VERSION_base(4,7,0) {-# LANGUAGE StandaloneDeriving, DeriveDataTypeable #-} #endif @@ -27,13 +33,6 @@ import Control.Concurrent.MVar -- So we can give Data instance for MVar & Co. import qualified Data.Map as M import qualified Data.Set as S - ------------------------------------------------------------------------------- --- --- Instances of the Data class for Prelude-like types. --- We define top-level definitions for representations. --- ------------------------------------------------------------------------------- falseConstr :: Constr diff --git a/syb-with-class.cabal b/syb-with-class.cabal --- a/syb-with-class.cabal +++ b/syb-with-class.cabal @@ -1,5 +1,5 @@ Name: syb-with-class -Version: 0.6.1.8 +Version: 0.6.1.14 License: BSD3 License-file: LICENSE Copyright: 2004 - 2008 The University of Glasgow, CWI, @@ -10,30 +10,39 @@ Author: Simon Peyton Jones, Ralf Laemmel Maintainer: sanzhiyan@gmail.com Stability: experimental -Bug-Reports: http://code.google.com/p/syb-with-class/issues/list Synopsis: Scrap Your Boilerplate With Class Description: Classes, and Template Haskell code to generate instances, for the Scrap Your Boilerplate With Class system. Category: Data -Tested-With: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2, GHC==8.0.1, GHC==8.2.1 +Tested-With: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.4, GHC==8.10.7, GHC==9.0.2, GHC==9.2.2 Build-Type: Simple -Cabal-Version: >= 1.6 +Cabal-Version: >= 1.10 source-repository head type: git location: https://github.com/Happstack/syb-with-class Library - Build-Depends: base >= 3 && < 5, template-haskell >= 2.4 && < 2.13, bytestring, array, containers + Default-Language: Haskell2010 + Build-Depends: base >= 3 && < 5, template-haskell >= 2.4 && < 2.19, bytestring, array, containers Exposed-modules: Data.Generics.SYB.WithClass.Basics Data.Generics.SYB.WithClass.Context Data.Generics.SYB.WithClass.Derive Data.Generics.SYB.WithClass.Instances - Extensions: UndecidableInstances, OverlappingInstances, Rank2Types, + Default-Extensions: UndecidableInstances, OverlappingInstances, Rank2Types, EmptyDataDecls, TemplateHaskell, FlexibleInstances, CPP, KindSignatures, MultiParamTypeClasses GHC-Options: -Wall + +test-suite syb-with-class-test + Default-Language: Haskell2010 + Type: exitcode-stdio-1.0 + Hs-Source-Dirs: tests + GHC-Options: -Wall + Main-Is: Test.hs + Build-Depends: base, HUnit, syb-with-class + Default-Extensions: OverlappingInstances diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -0,0 +1,42 @@ +-- Minimal demonstration of syb-with-class. Here we have a class Size +-- with a base instance. Then we override it for lists, and +-- demonstrate how gsize uses the list behavior on lists and the base +-- behavior otherwise. + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS -Wall #-} + +import Data.Generics.SYB.WithClass.Basics (Data, gmapQ, Proxy) +import Data.Generics.SYB.WithClass.Context (Sat(dict)) +import Data.Generics.SYB.WithClass.Instances () +import Test.HUnit (assertEqual, Counts(..), runTestTT, showCounts, Test(TestCase)) + +class Size a where + gsize :: a -> Int + +-- Dictionary type and Sat instance +data SizeD a = SizeD { gsizeD :: a -> Int } + +instance Size t => Sat (SizeD t) where + dict = SizeD { gsizeD = gsize } + +instance {-# OVERLAPPABLE #-} Data SizeD t => Size t where + -- The base behavior of gsize for any instance of Data + gsize t = 1 + sum (gmapQ (error "urk" :: Proxy SizeD) (gsizeD dict) t) + +instance Size a => Size [a] where + -- Override base gsize behavior for lists + gsize [] = 0 + gsize (x:xs) = gsize x + gsize xs + +main :: IO () +main = do + counts <- runTestTT (let expected = (2,1) + actual = (gsize ['a', 'b'], gsize 'x') in + TestCase (assertEqual "sample" expected actual)) + case counts of + Counts {errors = 0, failures = 0} -> return () + _ -> error (showCounts counts)