syb-with-class-0.6.1.7/0000755000000000000000000000000012732553535012734 5ustar0000000000000000syb-with-class-0.6.1.7/LICENSE0000644000000000000000000000320412732553535013740 0ustar0000000000000000Copyright (c) 2004 - 2008 The University of Glasgow, CWI, Simon Peyton Jones, Ralf Laemmel, Ulf Norell, Sean Seefried, Simon D. Foster, HAppS LLC All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. syb-with-class-0.6.1.7/Setup.hs0000644000000000000000000000013112732553535014363 0ustar0000000000000000 module Main (main) where import Distribution.Simple main :: IO () main = defaultMain syb-with-class-0.6.1.7/syb-with-class.cabal0000644000000000000000000000302412732553535016570 0ustar0000000000000000Name: syb-with-class Version: 0.6.1.7 License: BSD3 License-file: LICENSE Copyright: 2004 - 2008 The University of Glasgow, CWI, Simon Peyton Jones, Ralf Laemmel, Ulf Norell, Sean Seefried, Simon D. Foster, HAppS LLC 2009 Andrea Vezzosi 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 Build-Type: Simple Cabal-Version: >= 1.6 source-repository head type: git location: https://github.com/Happstack/syb-with-class Library Build-Depends: base >= 3 && < 5, template-haskell >= 2.4 && < 2.12, 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, EmptyDataDecls, TemplateHaskell, FlexibleInstances, CPP, KindSignatures, MultiParamTypeClasses GHC-Options: -Wall syb-with-class-0.6.1.7/Data/0000755000000000000000000000000012732553535013605 5ustar0000000000000000syb-with-class-0.6.1.7/Data/Generics/0000755000000000000000000000000012732553535015344 5ustar0000000000000000syb-with-class-0.6.1.7/Data/Generics/SYB/0000755000000000000000000000000012732553535016001 5ustar0000000000000000syb-with-class-0.6.1.7/Data/Generics/SYB/WithClass/0000755000000000000000000000000012732553535017702 5ustar0000000000000000syb-with-class-0.6.1.7/Data/Generics/SYB/WithClass/Basics.hs0000644000000000000000000003120412732553535021442 0ustar0000000000000000{-# LANGUAGE UndecidableInstances, OverlappingInstances, Rank2Types, CPP, KindSignatures, MultiParamTypeClasses, EmptyDataDecls #-} {- (C) 2004--2005 Ralf Laemmel, Simon D. Foster This module approximates Data.Generics.Basics. -} module Data.Generics.SYB.WithClass.Basics ( module Data.Typeable, module Data.Generics.SYB.WithClass.Context, module Data.Generics.SYB.WithClass.Basics ) where #if MIN_VERSION_base(4,7,0) import Data.Typeable hiding (Proxy) #else import Data.Typeable #endif import Data.Generics.SYB.WithClass.Context #ifdef __HADDOCK__ data Proxy #else data Proxy (a :: * -> *) #endif ------------------------------------------------------------------------------ -- The ingenious Data class class (Typeable a, Sat (ctx a)) => Data ctx a where gfoldl :: Proxy ctx -> (forall b c. Data ctx b => w (b -> c) -> b -> w c) -> (forall g. g -> w g) -> a -> w a -- Default definition for gfoldl -- which copes immediately with basic datatypes -- gfoldl _ _ z = z gunfold :: Proxy ctx -> (forall b r. Data ctx b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c a toConstr :: Proxy ctx -> a -> Constr dataTypeOf :: Proxy ctx -> a -> DataType -- incomplete implementation gunfold _ _ _ _ = undefined dataTypeOf _ _ = undefined -- | Mediate types and unary type constructors dataCast1 :: Typeable1 t => Proxy ctx -> (forall b. Data ctx b => w (t b)) -> Maybe (w a) dataCast1 _ _ = Nothing -- | Mediate types and binary type constructors dataCast2 :: Typeable2 t => Proxy ctx -> (forall b c. (Data ctx b, Data ctx c) => w (t b c)) -> Maybe (w a) dataCast2 _ _ = Nothing ------------------------------------------------------------------------------ -- Generic transformations type GenericT ctx = forall a. Data ctx a => a -> a -- Generic map for transformations gmapT :: Proxy ctx -> GenericT ctx -> GenericT ctx gmapT ctx f x = unID (gfoldl ctx k ID x) where k (ID g) y = ID (g (f y)) -- The identity type constructor newtype ID x = ID { unID :: x } ------------------------------------------------------------------------------ -- Generic monadic transformations type GenericM m ctx = forall a. Data ctx a => a -> m a -- Generic map for monadic transformations gmapM :: Monad m => Proxy ctx -> GenericM m ctx -> GenericM m ctx gmapM ctx f = gfoldl ctx k return where k c x = do c' <- c x' <- f x return (c' x') ------------------------------------------------------------------------------ -- Generic queries type GenericQ ctx r = forall a. Data ctx a => a -> r -- Map for queries gmapQ :: Proxy ctx -> GenericQ ctx r -> GenericQ ctx [r] gmapQ ctx f = gmapQr ctx (:) [] f gmapQr :: Data ctx a => Proxy ctx -> (r' -> r -> r) -> r -> GenericQ ctx r' -> a -> r gmapQr ctx o r f x = unQr (gfoldl ctx k (const (Qr id)) x) r where k (Qr g) y = Qr (\s -> g (f y `o` s)) -- The type constructor used in definition of gmapQr newtype Qr r a = Qr { unQr :: r -> r } ------------------------------------------------------------------------------ -- -- Generic unfolding -- ------------------------------------------------------------------------------ -- | Build a term skeleton fromConstr :: Data ctx a => Proxy ctx -> Constr -> a fromConstr ctx = fromConstrB ctx undefined -- | Build a term and use a generic function for subterms fromConstrB :: Data ctx a => Proxy ctx -> (forall b. Data ctx b => b) -> Constr -> a fromConstrB ctx f = unID . gunfold ctx k z where k c = ID (unID c f) z = ID -- | Monadic variation on \"fromConstrB\" fromConstrM :: (Monad m, Data ctx a) => Proxy ctx -> (forall b. Data ctx b => m b) -> Constr -> m a fromConstrM ctx f = gunfold ctx k z where k c = do { c' <- c; b <- f; return (c' b) } z = return ------------------------------------------------------------------------------ -- -- 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. -- data DataType = DataType { tycon :: String , datarep :: DataRep } deriving Show -- | Representation of constructors data Constr = Constr { conrep :: ConstrRep , constring :: String , confields :: [String] -- for AlgRep only , confixity :: Fixity -- for AlgRep only , datatype :: DataType } instance Show Constr where show = constring -- | Equality of constructors instance Eq Constr where c == c' = constrRep c == constrRep c' -- | Public representation of datatypes data DataRep = AlgRep [Constr] | IntRep | FloatRep | StringRep | NoRep deriving (Eq,Show) -- | Public representation of constructors data ConstrRep = AlgConstr ConIndex | IntConstr Integer | FloatConstr Double | StringConstr String deriving (Eq,Show) -- -- | Unique index for datatype constructors. -- | Textual order is respected. Starts at 1. -- type ConIndex = Int -- | Fixity of constructors data Fixity = Prefix | Infix -- Later: add associativity and precedence deriving (Eq,Show) ------------------------------------------------------------------------------ -- -- Observers for datatype representations -- ------------------------------------------------------------------------------ -- | Gets the type constructor including the module dataTypeName :: DataType -> String dataTypeName = tycon -- | Gets the public presentation of datatypes dataTypeRep :: DataType -> DataRep dataTypeRep = datarep -- | Gets the datatype of a constructor constrType :: Constr -> DataType constrType = datatype -- | Gets the public presentation of constructors constrRep :: Constr -> ConstrRep constrRep = conrep -- | Look up a constructor by its representation repConstr :: DataType -> ConstrRep -> Constr repConstr dt cr = case (dataTypeRep dt, cr) of (AlgRep cs, AlgConstr i) -> cs !! (i-1) (IntRep, IntConstr i) -> mkIntConstr dt i (FloatRep, FloatConstr f) -> mkFloatConstr dt f (StringRep, StringConstr str) -> mkStringConstr dt str _ -> error "repConstr" ------------------------------------------------------------------------------ -- -- Representations of algebraic data types -- ------------------------------------------------------------------------------ -- | Constructs an algebraic datatype mkDataType :: String -> [Constr] -> DataType mkDataType str cs = DataType { tycon = str , datarep = AlgRep cs } -- | Constructs a constructor mkConstr :: DataType -> String -> [String] -> Fixity -> Constr mkConstr dt str fields fix = Constr { conrep = AlgConstr idx , constring = str , confields = fields , confixity = fix , datatype = dt } where idx = head [ i | (c,i) <- dataTypeConstrs dt `zip` [1..], showConstr c == str ] -- | Gets the constructors dataTypeConstrs :: DataType -> [Constr] dataTypeConstrs dt = case datarep dt of (AlgRep cons) -> cons _ -> error "dataTypeConstrs" -- | Gets the field labels of a constructor constrFields :: Constr -> [String] constrFields = confields -- | Gets the fixity of a constructor constrFixity :: Constr -> Fixity constrFixity = confixity ------------------------------------------------------------------------------ -- -- From strings to constr's and vice versa: all data types -- ------------------------------------------------------------------------------ -- | Gets the string for a constructor showConstr :: Constr -> String showConstr = constring -- | Lookup a constructor via a string readConstr :: DataType -> String -> Maybe Constr readConstr dt str = case dataTypeRep dt of AlgRep cons -> idx cons IntRep -> mkReadCon (\i -> (mkPrimCon dt str (IntConstr i))) FloatRep -> mkReadCon (\f -> (mkPrimCon dt str (FloatConstr f))) StringRep -> Just (mkStringConstr dt str) NoRep -> Nothing where -- Read a value and build a constructor mkReadCon :: Read t => (t -> Constr) -> Maybe Constr mkReadCon f = case (reads str) of [(t,"")] -> Just (f t) _ -> Nothing -- Traverse list of algebraic datatype constructors idx :: [Constr] -> Maybe Constr idx cons = let fit = filter ((==) str . showConstr) cons in if fit == [] then Nothing else Just (head fit) ------------------------------------------------------------------------------ -- -- Convenience funtions: algebraic data types -- ------------------------------------------------------------------------------ -- | Test for an algebraic type isAlgType :: DataType -> Bool isAlgType dt = case datarep dt of (AlgRep _) -> True _ -> False -- | Gets the constructor for an index indexConstr :: DataType -> ConIndex -> Constr indexConstr dt idx = case datarep dt of (AlgRep cs) -> cs !! (idx-1) _ -> error "indexConstr" -- | Gets the index of a constructor constrIndex :: Constr -> ConIndex constrIndex con = case constrRep con of (AlgConstr idx) -> idx _ -> error "constrIndex" -- | Gets the maximum constructor index maxConstrIndex :: DataType -> ConIndex maxConstrIndex dt = case dataTypeRep dt of AlgRep cs -> length cs _ -> error "maxConstrIndex" ------------------------------------------------------------------------------ -- -- Representation of primitive types -- ------------------------------------------------------------------------------ -- | Constructs the Int type mkIntType :: String -> DataType mkIntType = mkPrimType IntRep -- | Constructs the Float type mkFloatType :: String -> DataType mkFloatType = mkPrimType FloatRep -- | Constructs the String type mkStringType :: String -> DataType mkStringType = mkPrimType StringRep -- | Helper for mkIntType, mkFloatType, mkStringType mkPrimType :: DataRep -> String -> DataType mkPrimType dr str = DataType { tycon = str , datarep = dr } -- Makes a constructor for primitive types mkPrimCon :: DataType -> String -> ConstrRep -> Constr mkPrimCon dt str cr = Constr { datatype = dt , conrep = cr , constring = str , confields = error $ concat ["constrFields : ", (tycon dt), " is primative"] , confixity = error "constrFixity" } mkIntConstr :: DataType -> Integer -> Constr mkIntConstr dt i = case datarep dt of IntRep -> mkPrimCon dt (show i) (IntConstr i) _ -> error "mkIntConstr" mkFloatConstr :: DataType -> Double -> Constr mkFloatConstr dt f = case datarep dt of FloatRep -> mkPrimCon dt (show f) (FloatConstr f) _ -> error "mkFloatConstr" mkStringConstr :: DataType -> String -> Constr mkStringConstr dt str = case datarep dt of StringRep -> mkPrimCon dt str (StringConstr str) _ -> error "mkStringConstr" ------------------------------------------------------------------------------ -- -- Non-representations for non-presentable types -- ------------------------------------------------------------------------------ -- | Constructs a non-representation mkNorepType :: String -> DataType mkNorepType str = DataType { tycon = str , datarep = NoRep } -- | Test for a non-representable type isNorepType :: DataType -> Bool isNorepType dt = case datarep dt of NoRep -> True _ -> False syb-with-class-0.6.1.7/Data/Generics/SYB/WithClass/Context.hs0000644000000000000000000000205412732553535021663 0ustar0000000000000000{-# LANGUAGE UndecidableInstances, OverlappingInstances, EmptyDataDecls #-} {- (C) 2004 Ralf Laemmel Context parameterisation and context passing. -} module Data.Generics.SYB.WithClass.Context where ------------------------------------------------------------------------------ -- -- The Sat class from John Hughes' "Restricted Data Types in Haskell" -- class Sat a where dict :: a ------------------------------------------------------------------------------ -- No context data NoCtx a noCtx :: NoCtx () noCtx = undefined instance Sat (NoCtx a) where dict = undefined ------------------------------------------------------------------------------ -- Pair context data PairCtx l r a = PairCtx { leftCtx :: l a , rightCtx :: r a } pairCtx :: l () -> r () -> PairCtx l r () pairCtx _ _ = undefined instance (Sat (l a), Sat (r a)) => Sat (PairCtx l r a) where dict = PairCtx { leftCtx = dict , rightCtx = dict } ------------------------------------------------------------------------------ syb-with-class-0.6.1.7/Data/Generics/SYB/WithClass/Derive.hs0000644000000000000000000003463312732553535021465 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, CPP #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -- 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 -- -- Ulf Norell, 2004 -- Started this module. -- -- Sean Seefried, 2004 -- Extension for data definitions with type variables; comments added. -- http://www.haskell.org/pipermail/template-haskell/2005-January/000393.html -- -- Simon D. Foster, 2004--2005 -- Extended to work with SYB3. -- -- Ralf Lammel, 2005 -- Integrated with SYB3 source distribution. -- module Data.Generics.SYB.WithClass.Derive where import Language.Haskell.TH import Data.List import Control.Monad import Data.Generics.SYB.WithClass.Basics -- -- | Takes the name of an algebraic data type, the number of type parameters -- it has and creates a Typeable instance for it. deriveTypeablePrim :: Name -> Int -> Q [Dec] deriveTypeablePrim name nParam #ifdef __HADDOCK__ = undefined #else = case index names nParam of Just (className, methodName) -> let moduleString = case nameModule name of Just m -> m ++ "." Nothing -> "" typeString = moduleString ++ nameBase name #if MIN_VERSION_base(4,7,0) body = [| mkTyConApp (mkTyCon3 $(litE $ stringL typeString)) [] |] #else body = [| mkTyConApp (mkTyCon $(litE $ stringL typeString)) [] |] #endif method = funD methodName [clause [wildP] (normalB body) []] in sequence [ instanceD (return []) (conT className `appT` conT name) [ method ] ] Nothing -> error ("Typeable classes can only have a maximum of " ++ show (length names + 1) ++ " parameters") 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)] #endif type Constructor = (Name, -- Name of the constructor Int, -- Number of constructor arguments Maybe [Name], -- Name of the field selector, if any [Type]) -- Type of the constructor argument escape :: String -> String escape "" = "" escape ('.' : more) = '_' : escape more escape (c : more) = c : escape more -- | Takes a name of a algebraic data type, the number of parameters it -- has and a list of constructor pairs. Each one of these constructor -- pairs consists of a constructor name and the number of type -- parameters it has. The function returns an automatically generated -- instance declaration for the Data class. -- -- Doesn't do gunfold, dataCast1 or dataCast2 deriveDataPrim :: Name -> [Type] -> [Constructor] -> Q [Dec] deriveDataPrim name typeParams cons = #ifdef __HADDOCK__ undefined #else do theDataTypeName <- newName $ "dataType_sybwc_" ++ escape (show name) constrNames <- mapM (\(conName,_,_,_) -> newName $ "constr_sybwc_" ++ escape (show conName)) cons let constrExps = map varE constrNames let mkConstrDec :: Name -> Constructor -> Q [Dec] mkConstrDec decNm (constrName, _, mfs, _) = do let constrString = nameBase constrName fieldNames = case mfs of Nothing -> [] Just fs -> map nameBase fs fixity (':':_) = [| Infix |] fixity _ = [| Prefix |] body = [| mkConstr $(varE theDataTypeName) constrString fieldNames $(fixity constrString) |] sequence [ sigD decNm [t| Constr |], funD decNm [clause [] (normalB body) []] ] conDecss <- zipWithM mkConstrDec constrNames cons let conDecs = concat conDecss sequence ( -- Creates -- constr :: Constr -- constr = mkConstr dataType "DataTypeName" [] Prefix map return conDecs ++ [ -- Creates -- dataType :: DataType sigD theDataTypeName [t| DataType |] , -- Creates -- dataType = mkDataType [ Data ctx DataType instanceD context (dataCxt myType) [ -- Define the gfoldl method do f <- newName "_f" z <- newName "z" x <- newName "x" let -- Takes a pair (constructor name, number of type -- arguments) and creates the correct definition for -- gfoldl. It is of the form -- z `f` arg1 `f` ... `f` argn mkMatch (c, n, _, _) = do args <- replicateM n (newName "arg") let applyF e arg = [| $(varE f) $e $(varE arg) |] body = foldl applyF [| $(varE z) $(conE c) |] args match (conP c $ map varP args) (normalB body) [] matches = map mkMatch cons funD 'gfoldl [ clause (wildP : map varP [f, z, x]) (normalB $ caseE (varE x) matches) [] ] , -- Define the gunfold method do k <- newName "_k" z <- newName "z" c <- newName "c" let body = if null cons then [| error "gunfold : Type has no constructors" |] else caseE [| constrIndex $(varE c) |] matches mkMatch n (cn, i, _, _) = match (litP $ integerL n) (normalB $ reapply (appE (varE k)) i [| $(varE z) $(conE cn) |] ) [] where reapply _ 0 f = f reapply x j f = x (reapply x (j-1) f) fallThroughMatch = match wildP (normalB [| error "gunfold: fallthrough" |]) [] matches = zipWith mkMatch [1..] cons ++ [fallThroughMatch] funD 'gunfold [clause (wildP : map varP [k, z, c]) (normalB body) [] ] , -- Define the toConstr method do x <- newName "x" let mkSel (c, n, _, _) e = match (conP c $ replicate n wildP) (normalB e) [] body = caseE (varE x) (zipWith mkSel cons constrExps) funD 'toConstr [ clause [wildP, varP x] (normalB body) [] ] , -- Define the dataTypeOf method funD 'dataTypeOf [ clause [wildP, wildP] (normalB $ varE theDataTypeName) [] ] ] ]) where notTyVar (VarT _) = False notTyVar _ = True applied (AppT f _) = applied f applied x = x types = [ t | (_, _, _, ts) <- cons, t <- ts, notTyVar t ] myType = foldl AppT (ConT name) typeParams dataCxt typ = conT ''Data `appT` varT (mkName "ctx") `appT` return typ #if MIN_VERSION_template_haskell(2,10,0) dataCxt' typ = (conT ''Data `appT` varT (mkName "ctx")) `appT` return typ satCxt typ = conT ''Sat `appT` (varT (mkName "ctx") `appT` return typ) #else dataCxt' typ = return $ ClassP ''Data [VarT (mkName "ctx"), typ] satCxt typ = return $ ClassP ''Sat [VarT (mkName "ctx") `AppT` typ] #endif dataCxtTypes = filter (\x -> applied x /= ConT name) $ nub (typeParams ++ types) satCxtTypes = nub (myType : types) context = cxt (map dataCxt' dataCxtTypes ++ map satCxt satCxtTypes) #endif deriveMinimalData :: Name -> Int -> Q [Dec] deriveMinimalData name nParam = do #ifdef __HADDOCK__ undefined #else decs <- qOfDecs params <- replicateM nParam (newName "a") let typeQParams = map varT params #if MIN_VERSION_template_haskell(2,10,0) context = cxt (map (appT (conT ''Data)) typeQParams) #else context = cxt (map (\typ -> classP ''Data [typ]) typeQParams) #endif instanceType = foldl appT (conT name) typeQParams inst <-instanceD context (conT ''Data `appT` instanceType) (map return decs) return [inst] where qOfDecs = [d| gunfold _ _ _ = error "gunfold not defined" toConstr x = error ("toConstr not defined for " ++ show (typeOf x)) dataTypeOf x = error ("dataTypeOf not implemented for " ++ show (typeOf x)) gfoldl _ z x = z x |] #endif {- 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 -} typeInfo :: Dec -> Q (Name, -- Name of the datatype [Name], -- Names of the type parameters [Constructor]) -- The constructors typeInfo d = case d of #if MIN_VERSION_template_haskell(2,11,0) DataD _ n ps _ cs _ -> return (n, map varName ps, map conA cs) NewtypeD _ n ps _ c _ -> return (n, map varName ps, [conA c]) #else DataD _ n ps cs _ -> return (n, map varName ps, map conA cs) NewtypeD _ n ps c _ -> return (n, map varName ps, [conA c]) #endif _ -> error ("derive: not a data type declaration: " ++ show d) where conA (NormalC c xs) = (c, length xs, Nothing, map snd xs) conA (InfixC x1 c x2) = conA (NormalC c [x1, x2]) conA (ForallC _ _ c) = conA c conA (RecC c xs) = let getField (n, _, _) = n getType (_, _, t) = t fields = map getField xs types = map getType xs in (c, length xs, Just fields, types) varName (PlainTV n) = n varName (KindedTV n _) = n -- -- | Derives the Data and Typeable instances for a single given data type. -- deriveOne :: Name -> Q [Dec] deriveOne n = do info <- reify n case info of TyConI d -> deriveOneDec d _ -> error ("derive: can't be used on anything but a type " ++ "constructor of an algebraic data type") deriveOneDec :: Dec -> Q [Dec] deriveOneDec dec = do (name, param, cs) <- typeInfo dec t <- deriveTypeablePrim name (length param) d <- deriveDataPrim name (map VarT param) cs return (t ++ d) deriveOneData :: Name -> Q [Dec] deriveOneData n = do info <- reify n case info of TyConI i -> do (name, param, cs) <- typeInfo i deriveDataPrim name (map VarT param) cs _ -> error ("derive: can't be used on anything but a type " ++ "constructor of an algebraic data type") -- -- | Derives Data and Typeable instances for a list of data -- types. Order is irrelevant. This should be used in favour of -- deriveOne since Data and Typeable instances can often depend on -- other Data and Typeable instances - e.g. if you are deriving a -- large, mutually recursive data type. If you splice the derived -- instances in one by one you will need to do it in depedency order -- which is difficult in most cases and impossible in the mutually -- recursive case. It is better to bring all the instances into -- scope at once. -- -- e.g. if -- data Foo = Foo Int -- is declared in an imported module then -- $(derive [''Foo]) -- will derive the instances for it derive :: [Name] -> Q [Dec] derive names = do decss <- mapM deriveOne names return (concat decss) deriveDec :: [Dec] -> Q [Dec] deriveDec decs = do decss <- mapM deriveOneDec decs return (concat decss) deriveData :: [Name] -> Q [Dec] deriveData names = do decss <- mapM deriveOneData names return (concat decss) deriveTypeable :: [Name] -> Q [Dec] deriveTypeable names = do decss <- mapM deriveOneTypeable names return (concat decss) deriveOneTypeable :: Name -> Q [Dec] deriveOneTypeable n = do info <- reify n case info of TyConI i -> do (name, param, _) <- typeInfo i deriveTypeablePrim name (length param) _ -> error ("derive: can't be used on anything but a type " ++ "constructor of an algebraic data type") -- -- | This function is much like deriveOne except that it brings into -- scope an instance of Data with minimal definitions. gfoldl will -- essentially leave a data structure untouched while gunfoldl, -- toConstr and dataTypeOf will yield errors. -- -- This function is useful when you are certain that you will never -- wish to transform a particular data type. For instance you may -- be transforming another data type that contains other data types, -- some of which you wish to transform (perhaps recursively) and -- some which you just wish to return unchanged. -- -- Sometimes you will be forced to use deriveMinimalOne because you -- do not have access to the contructors of the data type (perhaps -- because it is an Abstract Data Type). However, should the -- interface to the ADT be sufficiently rich it is possible to -- define you're own Data and Typeable instances. deriveMinimalOne :: Name -> Q [Dec] deriveMinimalOne n = do info <- reify n case info of TyConI i -> do (name, param, _) <- typeInfo i t <- deriveTypeablePrim name (length param) d <- deriveMinimalData name (length param) return (t ++ d) _ -> error ("deriveMinimal: can't be used on anything but a " ++ "type constructor of an algebraic data type") deriveMinimal :: [Name] -> Q [Dec] deriveMinimal names = do decss <- mapM deriveMinimalOne names return (concat decss) syb-with-class-0.6.1.7/Data/Generics/SYB/WithClass/Instances.hs0000644000000000000000000005572512732553535022203 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, FlexibleInstances, UndecidableInstances, OverlappingInstances, CPP, MultiParamTypeClasses #-} #if MIN_VERSION_base(4,7,0) {-# LANGUAGE StandaloneDeriving, DeriveDataTypeable #-} #endif {-# OPTIONS_GHC -fno-warn-orphans #-} -- This is a module full of orphans, so don't warn about them module Data.Generics.SYB.WithClass.Instances () where import Data.Generics.SYB.WithClass.Basics import Data.Generics.SYB.WithClass.Derive import Data.Array import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy as L (ByteString) import Data.Int -- So we can give Data instance for Int8, ... import Data.Word -- So we can give Data instance for Word8, ... import GHC.Real( Ratio(..) ) -- So we can give Data instance for Ratio import System.IO -- So we can give Data instance for IO, Handle import GHC.Ptr -- So we can give Data instance for Ptr import GHC.ForeignPtr -- So we can give Data instance for ForeignPtr import GHC.Stable -- So we can give Data instance for StablePtr import GHC.ST -- So we can give Data instance for ST import Data.IORef -- So we can give Data instance for IORef 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 falseConstr = mkConstr boolDataType "False" [] Prefix trueConstr :: Constr trueConstr = mkConstr boolDataType "True" [] Prefix boolDataType :: DataType boolDataType = mkDataType "Prelude.Bool" [falseConstr,trueConstr] instance Sat (ctx Bool) => Data ctx Bool where toConstr _ False = falseConstr toConstr _ True = trueConstr gunfold _ _ z c = case constrIndex c of 1 -> z False 2 -> z True _ -> error "gunfold Bool" dataTypeOf _ _ = boolDataType ------------------------------------------------------------------------------ charType :: DataType charType = mkStringType "Prelude.Char" instance Sat (ctx Char) => Data ctx Char where toConstr _ x = mkStringConstr charType [x] gunfold _ _ z c = case constrRep c of (StringConstr [x]) -> z x _ -> error "gunfold Char" dataTypeOf _ _ = charType ------------------------------------------------------------------------------ floatType :: DataType floatType = mkFloatType "Prelude.Float" instance Sat (ctx Float) => Data ctx Float where toConstr _ x = mkFloatConstr floatType (realToFrac x) gunfold _ _ z c = case constrRep c of (FloatConstr x) -> z (realToFrac x) _ -> error "gunfold Float" dataTypeOf _ _ = floatType ------------------------------------------------------------------------------ doubleType :: DataType doubleType = mkFloatType "Prelude.Double" instance Sat (ctx Double) => Data ctx Double where toConstr _ = mkFloatConstr floatType gunfold _ _ z c = case constrRep c of (FloatConstr x) -> z x _ -> error "gunfold Double" dataTypeOf _ _ = doubleType ------------------------------------------------------------------------------ intType :: DataType intType = mkIntType "Prelude.Int" instance Sat (ctx Int) => Data ctx Int where toConstr _ x = mkIntConstr intType (fromIntegral x) gunfold _ _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) _ -> error "gunfold Int" dataTypeOf _ _ = intType ------------------------------------------------------------------------------ integerType :: DataType integerType = mkIntType "Prelude.Integer" instance Sat (ctx Integer) => Data ctx Integer where toConstr _ = mkIntConstr integerType gunfold _ _ z c = case constrRep c of (IntConstr x) -> z x _ -> error "gunfold Integer" dataTypeOf _ _ = integerType ------------------------------------------------------------------------------ int8Type :: DataType int8Type = mkIntType "Data.Int.Int8" instance Sat (ctx Int8) => Data ctx Int8 where toConstr _ x = mkIntConstr int8Type (fromIntegral x) gunfold _ _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) _ -> error "gunfold Int8" dataTypeOf _ _ = int8Type ------------------------------------------------------------------------------ int16Type :: DataType int16Type = mkIntType "Data.Int.Int16" instance Sat (ctx Int16) => Data ctx Int16 where toConstr _ x = mkIntConstr int16Type (fromIntegral x) gunfold _ _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) _ -> error "gunfold Int16" dataTypeOf _ _ = int16Type ------------------------------------------------------------------------------ int32Type :: DataType int32Type = mkIntType "Data.Int.Int32" instance Sat (ctx Int32) => Data ctx Int32 where toConstr _ x = mkIntConstr int32Type (fromIntegral x) gunfold _ _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) _ -> error "gunfold Int32" dataTypeOf _ _ = int32Type ------------------------------------------------------------------------------ int64Type :: DataType int64Type = mkIntType "Data.Int.Int64" instance Sat (ctx Int64) => Data ctx Int64 where toConstr _ x = mkIntConstr int64Type (fromIntegral x) gunfold _ _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) _ -> error "gunfold Int64" dataTypeOf _ _ = int64Type ------------------------------------------------------------------------------ wordType :: DataType wordType = mkIntType "Data.Word.Word" instance Sat (ctx Word) => Data ctx Word where toConstr _ x = mkIntConstr wordType (fromIntegral x) gunfold _ _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) _ -> error "gunfold Word" dataTypeOf _ _ = wordType ------------------------------------------------------------------------------ word8Type :: DataType word8Type = mkIntType "Data.Word.Word8" instance Sat (ctx Word8) => Data ctx Word8 where toConstr _ x = mkIntConstr word8Type (fromIntegral x) gunfold _ _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) _ -> error "gunfold Word8" dataTypeOf _ _ = word8Type ------------------------------------------------------------------------------ word16Type :: DataType word16Type = mkIntType "Data.Word.Word16" instance Sat (ctx Word16) => Data ctx Word16 where toConstr _ x = mkIntConstr word16Type (fromIntegral x) gunfold _ _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) _ -> error "gunfold Word16" dataTypeOf _ _ = word16Type ------------------------------------------------------------------------------ word32Type :: DataType word32Type = mkIntType "Data.Word.Word32" instance Sat (ctx Word32) => Data ctx Word32 where toConstr _ x = mkIntConstr word32Type (fromIntegral x) gunfold _ _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) _ -> error "gunfold Word32" dataTypeOf _ _ = word32Type ------------------------------------------------------------------------------ word64Type :: DataType word64Type = mkIntType "Data.Word.Word64" instance Sat (ctx Word64) => Data ctx Word64 where toConstr _ x = mkIntConstr word64Type (fromIntegral x) gunfold _ _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) _ -> error "gunfold Word64" dataTypeOf _ _ = word64Type ------------------------------------------------------------------------------ ratioConstr :: Constr ratioConstr = mkConstr ratioDataType ":%" [] Infix ratioDataType :: DataType ratioDataType = mkDataType "GHC.Real.Ratio" [ratioConstr] instance (Sat (ctx (Ratio a)), Data ctx a, Integral a) => Data ctx (Ratio a) where toConstr _ _ = ratioConstr gunfold _ k z c | constrIndex c == 1 = k (k (z (:%))) gunfold _ _ _ _ = error "gunfold Ratio" dataTypeOf _ _ = ratioDataType ------------------------------------------------------------------------------ nilConstr :: Constr nilConstr = mkConstr listDataType "[]" [] Prefix consConstr :: Constr consConstr = mkConstr listDataType "(:)" [] Infix listDataType :: DataType listDataType = mkDataType "Prelude.[]" [nilConstr,consConstr] instance (Sat (ctx [a]), Data ctx a) => Data ctx [a] where gfoldl _ _ z [] = z [] gfoldl _ f z (x:xs) = z (:) `f` x `f` xs toConstr _ [] = nilConstr toConstr _ (_:_) = consConstr gunfold _ k z c = case constrIndex c of 1 -> z [] 2 -> k (k (z (:))) _ -> error "gunfold List" dataTypeOf _ _ = listDataType dataCast1 _ f = gcast1 f ------------------------------------------------------------------------------ nothingConstr :: Constr nothingConstr = mkConstr maybeDataType "Nothing" [] Prefix justConstr :: Constr justConstr = mkConstr maybeDataType "Just" [] Prefix maybeDataType :: DataType maybeDataType = mkDataType "Prelude.Maybe" [nothingConstr,justConstr] instance (Sat (ctx (Maybe a)), Data ctx a) => Data ctx (Maybe a) where gfoldl _ _ z Nothing = z Nothing gfoldl _ f z (Just x) = z Just `f` x toConstr _ Nothing = nothingConstr toConstr _ (Just _) = justConstr gunfold _ k z c = case constrIndex c of 1 -> z Nothing 2 -> k (z Just) _ -> error "gunfold Maybe" dataTypeOf _ _ = maybeDataType dataCast1 _ f = gcast1 f ------------------------------------------------------------------------------ ltConstr :: Constr ltConstr = mkConstr orderingDataType "LT" [] Prefix eqConstr :: Constr eqConstr = mkConstr orderingDataType "EQ" [] Prefix gtConstr :: Constr gtConstr = mkConstr orderingDataType "GT" [] Prefix orderingDataType :: DataType orderingDataType = mkDataType "Prelude.Ordering" [ltConstr,eqConstr,gtConstr] instance Sat (ctx Ordering) => Data ctx Ordering where gfoldl _ _ z LT = z LT gfoldl _ _ z EQ = z EQ gfoldl _ _ z GT = z GT toConstr _ LT = ltConstr toConstr _ EQ = eqConstr toConstr _ GT = gtConstr gunfold _ _ z c = case constrIndex c of 1 -> z LT 2 -> z EQ 3 -> z GT _ -> error "gunfold Ordering" dataTypeOf _ _ = orderingDataType ------------------------------------------------------------------------------ leftConstr :: Constr leftConstr = mkConstr eitherDataType "Left" [] Prefix rightConstr :: Constr rightConstr = mkConstr eitherDataType "Right" [] Prefix eitherDataType :: DataType eitherDataType = mkDataType "Prelude.Either" [leftConstr,rightConstr] instance (Sat (ctx (Either a b)), Data ctx a, Data ctx b) => Data ctx (Either a b) where gfoldl _ f z (Left a) = z Left `f` a gfoldl _ f z (Right a) = z Right `f` a toConstr _ (Left _) = leftConstr toConstr _ (Right _) = rightConstr gunfold _ k z c = case constrIndex c of 1 -> k (z Left) 2 -> k (z Right) _ -> error "gunfold Either" dataTypeOf _ _ = eitherDataType dataCast2 _ f = gcast2 f ------------------------------------------------------------------------------ -- -- A last resort for functions -- instance (Sat (ctx (a -> b)), Data ctx a, Data ctx b) => Data ctx (a -> b) where toConstr _ _ = error "toConstr" gunfold _ _ _ = error "gunfold (->)" dataTypeOf _ _ = mkNorepType "Prelude.(->)" dataCast2 _ f = gcast2 f ------------------------------------------------------------------------------ tuple0Constr :: Constr tuple0Constr = mkConstr tuple0DataType "()" [] Prefix tuple0DataType :: DataType tuple0DataType = mkDataType "Prelude.()" [tuple0Constr] instance (Sat (ctx ())) => Data ctx () where toConstr _ _ = tuple0Constr gunfold _ _ z c | constrIndex c == 1 = z () gunfold _ _ _ _ = error "gunfold ()" dataTypeOf _ _ = tuple0DataType ------------------------------------------------------------------------------ tuple2Constr :: Constr tuple2Constr = mkConstr tuple2DataType "(,)" [] Infix tuple2DataType :: DataType tuple2DataType = mkDataType "Prelude.(,)" [tuple2Constr] instance (Sat (ctx (a,b)), Data ctx a, Data ctx b) => Data ctx (a,b) where gfoldl _ f z (a,b) = z (,) `f` a `f` b toConstr _ _ = tuple2Constr gunfold _ k z c | constrIndex c == 1 = k (k (z (,))) gunfold _ _ _ _ = error "gunfold (,)" dataTypeOf _ _ = tuple2DataType dataCast2 _ f = gcast2 f ------------------------------------------------------------------------------ tuple3Constr :: Constr tuple3Constr = mkConstr tuple3DataType "(,,)" [] Infix tuple3DataType :: DataType tuple3DataType = mkDataType "Prelude.(,)" [tuple3Constr] instance (Sat (ctx (a,b,c)), Data ctx a, Data ctx b, Data ctx c) => Data ctx (a,b,c) where gfoldl _ f z (a,b,c) = z (,,) `f` a `f` b `f` c toConstr _ _ = tuple3Constr gunfold _ k z c | constrIndex c == 1 = k (k (k (z (,,)))) gunfold _ _ _ _ = error "gunfold (,,)" dataTypeOf _ _ = tuple3DataType ------------------------------------------------------------------------------ tuple4Constr :: Constr tuple4Constr = mkConstr tuple4DataType "(,,,)" [] Infix tuple4DataType :: DataType tuple4DataType = mkDataType "Prelude.(,,,)" [tuple4Constr] instance (Sat (ctx (a,b,c,d)), Data ctx a, Data ctx b, Data ctx c, Data ctx d) => Data ctx (a,b,c,d) where gfoldl _ f z (a,b,c,d) = z (,,,) `f` a `f` b `f` c `f` d toConstr _ _ = tuple4Constr gunfold _ k z c = case constrIndex c of 1 -> k (k (k (k (z (,,,))))) _ -> error "gunfold (,,,)" dataTypeOf _ _ = tuple4DataType ------------------------------------------------------------------------------ tuple5Constr :: Constr tuple5Constr = mkConstr tuple5DataType "(,,,,)" [] Infix tuple5DataType :: DataType tuple5DataType = mkDataType "Prelude.(,,,,)" [tuple5Constr] instance (Sat (ctx (a,b,c,d,e)), Data ctx a, Data ctx b, Data ctx c, Data ctx d, Data ctx e) => Data ctx (a,b,c,d,e) where gfoldl _ f z (a,b,c,d,e) = z (,,,,) `f` a `f` b `f` c `f` d `f` e toConstr _ _ = tuple5Constr gunfold _ k z c = case constrIndex c of 1 -> k (k (k (k (k (z (,,,,)))))) _ -> error "gunfold (,,,,)" dataTypeOf _ _ = tuple5DataType ------------------------------------------------------------------------------ tuple6Constr :: Constr tuple6Constr = mkConstr tuple6DataType "(,,,,,)" [] Infix tuple6DataType :: DataType tuple6DataType = mkDataType "Prelude.(,,,,,)" [tuple6Constr] instance (Sat (ctx (a,b,c,d,e,f)), Data ctx a, Data ctx b, Data ctx c, Data ctx d, Data ctx e, Data ctx f) => Data ctx (a,b,c,d,e,f) where gfoldl _ f z (a,b,c,d,e,f') = z (,,,,,) `f` a `f` b `f` c `f` d `f` e `f` f' toConstr _ _ = tuple6Constr gunfold _ k z c = case constrIndex c of 1 -> k (k (k (k (k (k (z (,,,,,))))))) _ -> error "gunfold (,,,,,)" dataTypeOf _ _ = tuple6DataType ------------------------------------------------------------------------------ tuple7Constr :: Constr tuple7Constr = mkConstr tuple7DataType "(,,,,,,)" [] Infix tuple7DataType :: DataType tuple7DataType = mkDataType "Prelude.(,,,,,,)" [tuple7Constr] instance (Sat (ctx (a,b,c,d,e,f,g)), Data ctx a, Data ctx b, Data ctx c, Data ctx d, Data ctx e, Data ctx f, Data ctx g) => Data ctx (a,b,c,d,e,f,g) where gfoldl _ f z (a,b,c,d,e,f',g) = z (,,,,,,) `f` a `f` b `f` c `f` d `f` e `f` f' `f` g toConstr _ _ = tuple7Constr gunfold _ k z c = case constrIndex c of 1 -> k (k (k (k (k (k (k (z (,,,,,,)))))))) _ -> error "gunfold (,,,,,,)" dataTypeOf _ _ = tuple7DataType ------------------------------------------------------------------------------ instance Sat (ctx TypeRep) => Data ctx TypeRep where toConstr _ _ = error "toConstr" gunfold _ _ _ = error "gunfold TypeRep" dataTypeOf _ _ = mkNorepType "Data.Typeable.TypeRep" ------------------------------------------------------------------------------ instance Sat (ctx TyCon) => Data ctx TyCon where toConstr _ _ = error "toConstr" gunfold _ _ _ = error "gunfold TyCon" dataTypeOf _ _ = mkNorepType "Data.Typeable.TyCon" ------------------------------------------------------------------------------ -- INSTANCE_TYPEABLE0(DataType,dataTypeTc,"DataType") #if MIN_VERSION_base(4,7,0) deriving instance Typeable DataType #else #ifndef __HADDOCK__ $(deriveTypeable [''DataType]) #endif #endif instance Sat (ctx DataType) => Data ctx DataType where toConstr _ _ = error "toConstr" gunfold _ _ _ = error "gunfold DataType" dataTypeOf _ _ = mkNorepType "Data.Generics.Basics.DataType" ------------------------------------------------------------------------------ instance (Sat (ctx (IO a)), Typeable a) => Data ctx (IO a) where toConstr _ _ = error "toConstr" gunfold _ _ _ = error "gunfold IO" dataTypeOf _ _ = mkNorepType "GHC.IOBase.IO" ------------------------------------------------------------------------------ instance Sat (ctx Handle) => Data ctx Handle where toConstr _ _ = error "toConstr" gunfold _ _ _ = error "gunfold Handle" dataTypeOf _ _ = mkNorepType "GHC.IOBase.Handle" ------------------------------------------------------------------------------ instance (Sat (ctx (Ptr a)), Typeable a) => Data ctx (Ptr a) where toConstr _ _ = error "toConstr" gunfold _ _ _ = error "gunfold Ptr" dataTypeOf _ _ = mkNorepType "GHC.Ptr.Ptr" ------------------------------------------------------------------------------ instance (Sat (ctx (StablePtr a)), Typeable a) => Data ctx (StablePtr a) where toConstr _ _ = error "toConstr" gunfold _ _ _ = error "gunfold StablePtr" dataTypeOf _ _ = mkNorepType "GHC.Stable.StablePtr" ------------------------------------------------------------------------------ instance (Sat (ctx (IORef a)), Typeable a) => Data ctx (IORef a) where toConstr _ _ = error "toConstr" gunfold _ _ _ = error "gunfold IORef" dataTypeOf _ _ = mkNorepType "GHC.IOBase.IORef" ------------------------------------------------------------------------------ instance (Sat (ctx (ForeignPtr a)), Typeable a) => Data ctx (ForeignPtr a) where toConstr _ _ = error "toConstr" gunfold _ _ _ = error "gunfold ForeignPtr" dataTypeOf _ _ = mkNorepType "GHC.ForeignPtr.ForeignPtr" ------------------------------------------------------------------------------ instance (Sat (ctx (ST s a)), Typeable s, Typeable a) => Data ctx (ST s a) where toConstr _ _ = error "toConstr" gunfold _ _ _ = error "gunfold ST" dataTypeOf _ _ = mkNorepType "GHC.ST.ST" ------------------------------------------------------------------------------ {- instance Sat (ctx ThreadId) => Data ctx ThreadId where toConstr _ _ = error "toConstr" gunfold _ _ _ = error "gunfold ThreadId" dataTypeOf _ _ = mkNorepType "GHC.Conc.ThreadId" ------------------------------------------------------------------------------ instance (Sat (ctx (TVar a)), Typeable a) => Data ctx (TVar a) where toConstr _ _ = error "toConstr" gunfold _ _ _ = error "gunfold TVar" dataTypeOf _ _ = mkNorepType "GHC.Conc.TVar"-} ------------------------------------------------------------------------------ instance (Sat (ctx (MVar a)), Typeable a) => Data ctx (MVar a) where toConstr _ _ = error "toConstr" gunfold _ _ _ = error "gunfold MVar" dataTypeOf _ _ = mkNorepType "GHC.Conc.MVar" ------------------------------------------------------------------------------ {-instance (Sat (ctx (STM a)), Typeable a) => Data ctx (STM a) where toConstr _ _ = error "toConstr" gunfold _ _ _ = error "gunfold STM" dataTypeOf _ _ = mkNorepType "GHC.Conc.STM"-} ------------------------------------------------------------------------------ -- The following instances were adapted from various modules within the Data -- namespace. Until GHC takes onboard SYB3, they'll have to stay in here. ------------------------------------------------------------------------------ instance (Sat (ctx [b]), Sat (ctx (Array a b)), Typeable a, Data ctx b, Data ctx [b], Ix a) => Data ctx (Array a b) where gfoldl _ f z a = z (listArray (bounds a)) `f` (elems a) toConstr _ _ = error "toConstr" gunfold _ _ _ = error "gunfold Array" dataTypeOf _ _ = mkNorepType "Data.Array.Array" ------------------------------------------------------------------------------ emptyMapConstr :: Constr emptyMapConstr = mkConstr mapDataType "empty" [] Prefix insertMapConstr :: Constr insertMapConstr = mkConstr mapDataType "insert" [] Prefix mapDataType :: DataType mapDataType = mkDataType "Data.Map.Map" [emptyMapConstr,insertMapConstr] instance (Sat (ctx (M.Map a b)), Data ctx a, Data ctx b, Ord a) => Data ctx (M.Map a b) where gfoldl _ f z m = case M.minViewWithKey m of Nothing -> z M.empty Just ((k,a),m') -> z M.insert `f` k `f` a `f` m' toConstr _ m | M.size m == 0 = emptyMapConstr | otherwise = insertMapConstr gunfold _ k z c = case constrIndex c of 1 -> z M.empty 2 -> k (k (k (z M.insert))) _ -> error "gunfold Map" dataTypeOf _ _ = mapDataType dataCast2 _ f = gcast2 f ------------------------------------------------------------------------------ emptySetConstr :: Constr emptySetConstr = mkConstr mapDataType "empty" [] Prefix insertSetConstr :: Constr insertSetConstr = mkConstr mapDataType "insert" [] Prefix setDataType :: DataType setDataType = mkDataType "Data.Set.Set" [emptySetConstr,insertSetConstr] instance (Sat (ctx (S.Set a)), Data ctx a, Ord a) => Data ctx (S.Set a ) where gfoldl _ f z s = case S.minView s of Nothing -> z S.empty Just (a,s') -> z S.insert `f` a `f` s' toConstr _ m | S.size m == 0 = emptySetConstr | otherwise = insertSetConstr gunfold _ k z c = case constrIndex c of 1 -> z S.empty 2 -> k (k (z S.insert)) _ -> error "gunfold Set" dataTypeOf _ _ = setDataType dataCast1 _ f = gcast1 f ------------------------------------------------------------------------------ $( deriveData [''ByteString] ) $( deriveData [''L.ByteString] )