{-# LANGUAGE TemplateHaskell, FlexibleInstances, UndecidableInstances, OverlappingInstances, CPP, MultiParamTypeClasses #-} {-# 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 Data.Typeable 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 GHC.IOBase -- 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 GHC.Conc -- So we can give Data instance for MVar & Co. ------------------------------------------------------------------------------ -- -- 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") #ifndef __HADDOCK__ $(deriveTypeable [''DataType]) #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" ------------------------------------------------------------------------------ $( deriveData [''ByteString] )