transformers-compat 0.7.1 → 0.7.2
raw patch · 3 files changed
+631/−184 lines, 3 filesdep ~base
Dependency ranges changed: base
Files
- CHANGELOG.markdown +5/−0
- generics/Data/Functor/Classes/Generic/Internal.hs +624/−182
- transformers-compat.cabal +2/−2
CHANGELOG.markdown view
@@ -1,3 +1,8 @@+0.7.2 [2022.06.26]+------------------+* Add `Eq`, `Ord`, `Read`, and `Show` instances for `FunctorClassesDefault` in+ `Data.Functor.Classes.Generic`.+ 0.7.1 [2021.10.30] ------------------ * Backport new instances from GHC 9.2/`base-4.16`
generics/Data/Functor/Classes/Generic/Internal.hs view
@@ -17,6 +17,10 @@ {-# LANGUAGE EmptyCase #-} #endif +#if __GLASGOW_HASKELL__ >= 806+{-# LANGUAGE QuantifiedConstraints #-}+#endif+ {-| Module: Data.Functor.Classes.Generic Copyright: (C) 2015-2016 Edward Kmett, Ryan Scott@@ -77,6 +81,19 @@ , GShow1(..) , GShow1Con(..) , Show1Args(..)+ -- * 'Eq'+ , eqDefault+ , GEq(..)+ -- * 'Ord'+ , compareDefault+ , GOrd(..)+ -- * 'Read'+ , readsPrecDefault+ , GRead(..)+ -- * 'Show'+ , showsPrecDefault+ , showsPrecOptions+ , GShow(..) -- * 'FunctorClassesDefault' , FunctorClassesDefault(..) -- * Miscellaneous types@@ -156,6 +173,74 @@ data NonV4 -------------------------------------------------------------------------------+-- * Eq+-------------------------------------------------------------------------------++-- | A default @('==')@ implementation for 'Generic1' instances that leverages+-- 'Eq1'.+eqDefault :: (GEq (Rep1 f a), Generic1 f) => f a -> f a -> Bool+eqDefault m n = geq (from1 m) (from1 n)++-- | Class of generic representation types that can be checked for equality.+class GEq a where+ geq :: a -> a -> Bool++instance Eq c => GEq (K1 i c p) where+ geq (K1 c) (K1 d) = c == d++instance (GEq (f p), GEq (g p)) => GEq ((f :*: g) p) where+ geq (a :*: b) (c :*: d) = geq a c && geq b d++instance (GEq (f p), GEq (g p)) => GEq ((f :+: g) p) where+ geq (L1 a) (L1 c) = geq a c+ geq (R1 b) (R1 d) = geq b d+ geq _ _ = False++instance GEq (f p) => GEq (M1 i c f p) where+ geq (M1 a) (M1 b) = geq a b++instance GEq (U1 p) where+ geq U1 U1 = True++instance GEq (V1 p) where+ geq _ _ = True++instance Eq p => GEq (Par1 p) where+ geq (Par1 a) (Par1 b) = a == b++instance (Eq1 f, Eq p) => GEq (Rec1 f p) where+ geq (Rec1 a) (Rec1 b) = eq1 a b++#if defined(TRANSFORMERS_FOUR)+instance (Functor f, Eq1 f, GEq (g p)) => GEq ((f :.: g) p) where+ geq (Comp1 m) (Comp1 n) = eq1 (fmap Apply m) (fmap Apply n)+#else+instance (Eq1 f, GEq (g p)) => GEq ((f :.: g) p) where+ geq (Comp1 m) (Comp1 n) = liftEq geq m n+#endif++#if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING)+-- Unboxed types+instance GEq (UAddr p) where+ geq = eqUAddr++instance GEq (UChar p) where+ geq = eqUChar++instance GEq (UDouble p) where+ geq = eqUDouble++instance GEq (UFloat p) where+ geq = eqUFloat++instance GEq (UInt p) where+ geq = eqUInt++instance GEq (UWord p) where+ geq = eqUWord+#endif++------------------------------------------------------------------------------- -- * Eq1 ------------------------------------------------------------------------------- @@ -191,8 +276,13 @@ liftEqOptions _ f m n = gliftEq (NonV4Eq1Args f) (from1 m) (from1 n) #endif --- | Class of generic representation types that can be checked for equality.-class GEq1 v t where+-- | Class of generic representation types that can lift equality through unary+-- type constructors.+class+#if __GLASGOW_HASKELL__ >= 806+ (forall a. Eq a => GEq (t a)) =>+#endif+ GEq1 v t where gliftEq :: Eq1Args v a b -> t a -> t b -> Bool instance Eq c => GEq1 v (K1 i c) where@@ -223,7 +313,7 @@ gliftEq V4Eq1Args (Rec1 a) (Rec1 b) = eq1 a b instance (Functor f, Eq1 f, GEq1 V4 g) => GEq1 V4 (f :.: g) where- gliftEq V4Eq1Args (Comp1 m) (Comp1 n) = eq1 (fmap Apply m) (fmap Apply n)+ gliftEq V4Eq1Args (Comp1 m) (Comp1 n) = eq1 (fmap Apply1 m) (fmap Apply1 n) #else instance GEq1 NonV4 Par1 where gliftEq (NonV4Eq1Args f) (Par1 a) (Par1 b) = f a b@@ -239,25 +329,112 @@ #if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING) -- Unboxed types instance GEq1 v UAddr where- gliftEq _ (UAddr a1) (UAddr a2) = isTrue# (eqAddr# a1 a2)+ gliftEq _ = eqUAddr instance GEq1 v UChar where- gliftEq _ (UChar c1) (UChar c2) = isTrue# (eqChar# c1 c2)+ gliftEq _ = eqUChar instance GEq1 v UDouble where- gliftEq _ (UDouble d1) (UDouble d2) = isTrue# (d1 ==## d2)+ gliftEq _ = eqUDouble instance GEq1 v UFloat where- gliftEq _ (UFloat f1) (UFloat f2) = isTrue# (eqFloat# f1 f2)+ gliftEq _ = eqUFloat instance GEq1 v UInt where- gliftEq _ (UInt i1) (UInt i2) = isTrue# (i1 ==# i2)+ gliftEq _ = eqUInt instance GEq1 v UWord where- gliftEq _ (UWord w1) (UWord w2) = isTrue# (eqWord# w1 w2)+ gliftEq _ = eqUWord++eqUAddr :: UAddr p -> UAddr q -> Bool+eqUAddr (UAddr a1) (UAddr a2) = isTrue# (eqAddr# a1 a2)++eqUChar :: UChar p -> UChar q -> Bool+eqUChar (UChar c1) (UChar c2) = isTrue# (eqChar# c1 c2)++eqUDouble :: UDouble p -> UDouble q -> Bool+eqUDouble (UDouble d1) (UDouble d2) = isTrue# (d1 ==## d2)++eqUFloat :: UFloat p -> UFloat q -> Bool+eqUFloat (UFloat f1) (UFloat f2) = isTrue# (eqFloat# f1 f2)++eqUInt :: UInt p -> UInt q -> Bool+eqUInt (UInt i1) (UInt i2) = isTrue# (i1 ==# i2)++eqUWord :: UWord p -> UWord q -> Bool+eqUWord (UWord w1) (UWord w2) = isTrue# (eqWord# w1 w2) #endif -------------------------------------------------------------------------------+-- * Ord+-------------------------------------------------------------------------------++-- | A default 'compare' implementation for 'Generic1' instances that leverages+-- 'Ord1'.+compareDefault :: (GOrd (Rep1 f a), Generic1 f) => f a -> f a -> Ordering+compareDefault m n = gcompare (from1 m) (from1 n)++-- | Class of generic representation types that can be totally ordered.+class GEq a => GOrd a where+ gcompare :: a -> a -> Ordering++instance Ord c => GOrd (K1 i c p) where+ gcompare (K1 c) (K1 d) = compare c d++instance (GOrd (f p), GOrd (g p)) => GOrd ((f :*: g) p) where+ gcompare (a :*: b) (c :*: d) = gcompare a c `mappend` gcompare b d++instance (GOrd (f p), GOrd (g p)) => GOrd ((f :+: g) p) where+ gcompare (L1 a) (L1 c) = gcompare a c+ gcompare L1{} R1{} = LT+ gcompare R1{} L1{} = GT+ gcompare (R1 b) (R1 d) = gcompare b d++instance GOrd (f p) => GOrd (M1 i c f p) where+ gcompare (M1 a) (M1 b) = gcompare a b++instance GOrd (U1 p) where+ gcompare U1 U1 = EQ++instance GOrd (V1 p) where+ gcompare _ _ = EQ++instance Ord p => GOrd (Par1 p) where+ gcompare (Par1 a) (Par1 b) = compare a b++instance (Ord1 f, Ord p) => GOrd (Rec1 f p) where+ gcompare (Rec1 a) (Rec1 b) = compare1 a b++#if defined(TRANSFORMERS_FOUR)+instance (Functor f, Ord1 f, GOrd (g p)) => GOrd ((f :.: g) p) where+ gcompare (Comp1 m) (Comp1 n) = compare1 (fmap Apply m) (fmap Apply n)+#else+instance (Ord1 f, GOrd (g p)) => GOrd ((f :.: g) p) where+ gcompare (Comp1 m) (Comp1 n) = liftCompare gcompare m n+#endif++#if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING)+-- Unboxed types+instance GOrd (UAddr p) where+ gcompare = compareUAddr++instance GOrd (UChar p) where+ gcompare = compareUChar++instance GOrd (UDouble p) where+ gcompare = compareUDouble++instance GOrd (UFloat p) where+ gcompare = compareUFloat++instance GOrd (UInt p) where+ gcompare = compareUInt++instance GOrd (UWord p) where+ gcompare = compareUWord+#endif++------------------------------------------------------------------------------- -- * Ord1 ------------------------------------------------------------------------------- @@ -293,8 +470,13 @@ liftCompareOptions _ f m n = gliftCompare (NonV4Ord1Args f) (from1 m) (from1 n) #endif --- | Class of generic representation types that can be totally ordered.-class GEq1 v t => GOrd1 v t where+-- | Class of generic representation types that can lift a total order through+-- unary type constructors.+class ( GEq1 v t+#if __GLASGOW_HASKELL__ >= 806+ , forall a. Ord a => GOrd (t a)+#endif+ ) => GOrd1 v t where gliftCompare :: Ord1Args v a b -> t a -> t b -> Ordering instance Ord c => GOrd1 v (K1 i c) where@@ -328,7 +510,7 @@ instance (Functor f, Ord1 f, GOrd1 V4 g) => GOrd1 V4 (f :.: g) where gliftCompare V4Ord1Args (Comp1 m) (Comp1 n) =- compare1 (fmap Apply m) (fmap Apply n)+ compare1 (fmap Apply1 m) (fmap Apply1 n) #else instance GOrd1 NonV4 Par1 where gliftCompare (NonV4Ord1Args f) (Par1 a) (Par1 b) = f a b@@ -344,23 +526,41 @@ #if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING) -- Unboxed types instance GOrd1 v UAddr where- gliftCompare _ (UAddr a1) (UAddr a2) = primCompare (eqAddr# a1 a2) (leAddr# a1 a2)+ gliftCompare _ = compareUAddr instance GOrd1 v UChar where- gliftCompare _ (UChar c1) (UChar c2) = primCompare (eqChar# c1 c2) (leChar# c1 c2)+ gliftCompare _ = compareUChar instance GOrd1 v UDouble where- gliftCompare _ (UDouble d1) (UDouble d2) = primCompare (d1 ==## d2) (d1 <=## d2)+ gliftCompare _ = compareUDouble instance GOrd1 v UFloat where- gliftCompare _ (UFloat f1) (UFloat f2) = primCompare (eqFloat# f1 f2) (leFloat# f1 f2)+ gliftCompare _ = compareUFloat instance GOrd1 v UInt where- gliftCompare _ (UInt i1) (UInt i2) = primCompare (i1 ==# i2) (i1 <=# i2)+ gliftCompare _ = compareUInt instance GOrd1 v UWord where- gliftCompare _ (UWord w1) (UWord w2) = primCompare (eqWord# w1 w2) (leWord# w1 w2)+ gliftCompare _ = compareUWord +compareUAddr :: UAddr p -> UAddr q -> Ordering+compareUAddr (UAddr a1) (UAddr a2) = primCompare (eqAddr# a1 a2) (leAddr# a1 a2)++compareUChar :: UChar p -> UChar q -> Ordering+compareUChar (UChar c1) (UChar c2) = primCompare (eqChar# c1 c2) (leChar# c1 c2)++compareUDouble :: UDouble p -> UDouble q -> Ordering+compareUDouble (UDouble d1) (UDouble d2) = primCompare (d1 ==## d2) (d1 <=## d2)++compareUFloat :: UFloat p -> UFloat q -> Ordering+compareUFloat (UFloat f1) (UFloat f2) = primCompare (eqFloat# f1 f2) (leFloat# f1 f2)++compareUInt :: UInt p -> UInt q -> Ordering+compareUInt (UInt i1) (UInt i2) = primCompare (i1 ==# i2) (i1 <=# i2)++compareUWord :: UWord p -> UWord q -> Ordering+compareUWord (UWord w1) (UWord w2) = primCompare (eqWord# w1 w2) (leWord# w1 w2)+ # if __GLASGOW_HASKELL__ >= 708 primCompare :: Int# -> Int# -> Ordering # else@@ -372,6 +572,74 @@ #endif -------------------------------------------------------------------------------+-- * Read+-------------------------------------------------------------------------------++-- | A default 'readsPrec' implementation for 'Generic1' instances that leverages+-- 'Read1'.+readsPrecDefault :: (GRead (Rep1 f a), Generic1 f) => Int -> ReadS (f a)+readsPrecDefault p = readPrec_to_S (fmap to1 greadPrec) p++-- | Class of generic representation types that can be parsed from a 'String'.+class GRead a where+ greadPrec :: ReadPrec a++instance (GRead (f p), IsNullaryDataType f) => GRead (D1 d f p) where+ greadPrec = d1ReadPrec greadPrec++instance GRead (V1 p) where+ greadPrec = pfail++instance (GRead (f p), GRead (g p)) => GRead ((f :+: g) p) where+ greadPrec = fmap L1 greadPrec +++ fmap R1 greadPrec++instance (Constructor c, GReadCon (f p), IsNullaryCon f) => GRead (C1 c f p) where+ greadPrec = c1ReadPrec greadPrecCon++-- | Class of generic representation types that can be parsed from a 'String',+-- and for which the 'ConType' has been determined.+class GReadCon a where+ greadPrecCon :: ConType -> ReadPrec a++instance GReadCon (U1 p) where+ greadPrecCon _ = return U1++instance Read c => GReadCon (K1 i c p) where+ greadPrecCon _ = coerceK1 readPrec++instance (Selector s, GReadCon (f p)) => GReadCon (S1 s f p) where+ greadPrecCon = s1ReadPrec . greadPrecCon++instance (GReadCon (f p), GReadCon (g p)) => GReadCon ((f :*: g) p) where+ greadPrecCon t = productReadPrec t (greadPrecCon t) (greadPrecCon t)++instance Read p => GReadCon (Par1 p) where+ greadPrecCon _ = coercePar1 readPrec++#if defined(TRANSFORMERS_FOUR)+instance (Read1 f, Read p) => GReadCon (Rec1 f p) where+ greadPrecCon _ = coerceRec1 $ readS_to_Prec readsPrec1++instance (Functor f, Read1 f, GReadCon (g p)) => GReadCon ((f :.: g) p) where+ greadPrecCon _ =+ coerceComp1 $ fmap (fmap getApply) $ readS_to_Prec crp1+ where+ crp1 :: Int -> ReadS (f (Apply g p))+ crp1 = readsPrec1+#else+instance (Read1 f, Read p) => GReadCon (Rec1 f p) where+ greadPrecCon _ = coerceRec1 $ readS_to_Prec $+ liftReadsPrec (readPrec_to_S readPrec) (readPrec_to_S readListPrec 0)++instance (Read1 f, GReadCon (g p)) => GReadCon ((f :.: g) p) where+ greadPrecCon t = coerceComp1 $ readS_to_Prec $+ liftReadsPrec (readPrec_to_S grpc)+ (readPrec_to_S (list grpc) 0)+ where+ grpc = greadPrecCon t+#endif++------------------------------------------------------------------------------- -- * Read1 ------------------------------------------------------------------------------- @@ -433,6 +701,9 @@ coerceComp1 :: ReadPrec (f (g a)) -> ReadPrec ((f :.: g) a) coerceComp1 = coerce +coerceK1 :: ReadPrec c -> ReadPrec (K1 i c p)+coerceK1 = coerce+ isSymVar :: String -> Bool isSymVar "" = False isSymVar (c:_) = startsVarSym c@@ -457,21 +728,30 @@ identHLexemes s | Just (ss, '#') <- snocView s = [Ident ss, Symbol "#"] | otherwise = [Ident s] --- | Class of generic representation types that can be parsed from a 'String'.-class GRead1 v f where+-- | Class of generic representation types for unary type constructors that can+-- be parsed from a 'String'.+class+#if __GLASGOW_HASKELL__ >= 806+ (forall a. Read a => GRead (f a)) =>+#endif+ GRead1 v f where gliftReadPrec :: Read1Args v a -> ReadPrec (f a) instance (GRead1 v f, IsNullaryDataType f) => GRead1 v (D1 d f) where- gliftReadPrec = coerceM1 . parensIfNonNullary . gliftReadPrec- where- x :: f p- x = undefined+ gliftReadPrec = d1ReadPrec . gliftReadPrec - parensIfNonNullary :: ReadPrec a -> ReadPrec a- parensIfNonNullary = if isNullaryDataType x- then id- else parens+d1ReadPrec :: forall d f p. IsNullaryDataType f+ => ReadPrec (f p) -> ReadPrec (D1 d f p)+d1ReadPrec rp = coerceM1 $ parensIfNonNullary rp+ where+ x :: f p+ x = undefined + parensIfNonNullary :: ReadPrec a -> ReadPrec a+ parensIfNonNullary = if isNullaryDataType x+ then id+ else parens+ instance GRead1 v V1 where gliftReadPrec _ = pfail @@ -480,42 +760,47 @@ fmap L1 (gliftReadPrec ras) +++ fmap R1 (gliftReadPrec ras) instance (Constructor c, GRead1Con v f, IsNullaryCon f) => GRead1 v (C1 c f) where- gliftReadPrec ras = coerceM1 $ case fixity of- Prefix -> precIfNonNullary $ do- if conIsTuple c- then return ()- else let cn = conName c- in if isInfixDataCon cn- then readSurround '(' (expectP (Symbol cn)) ')'- else mapM_ expectP $ identHLexemes cn- readBraces t (gliftReadPrecCon t ras)- Infix _ m -> prec m $ gliftReadPrecCon t ras- where- c :: C1 c f p- c = undefined+ gliftReadPrec ras = c1ReadPrec $ \t -> gliftReadPrecCon t ras - x :: f p- x = undefined+c1ReadPrec :: forall c f p. (Constructor c, IsNullaryCon f)+ => (ConType -> ReadPrec (f p)) -> ReadPrec (C1 c f p)+c1ReadPrec rpc =+ coerceM1 $ case fixity of+ Prefix -> precIfNonNullary $ do+ if conIsTuple c+ then return ()+ else let cn = conName c+ in if isInfixDataCon cn+ then readSurround '(' (expectP (Symbol cn)) ')'+ else mapM_ expectP $ identHLexemes cn+ readBraces t (rpc t)+ Infix _ m -> prec m $ rpc t+ where+ c :: C1 c f p+ c = undefined - fixity :: Fixity- fixity = conFixity c+ x :: f p+ x = undefined - precIfNonNullary :: ReadPrec a -> ReadPrec a- precIfNonNullary = if isNullaryCon x- then id- else prec (if conIsRecord c- then appPrec1- else appPrec)+ fixity :: Fixity+ fixity = conFixity c - t :: ConType- t = if conIsRecord c- then Rec- else case conIsTuple c of- True -> Tup- False -> case fixity of- Prefix -> Pref- Infix _ _ -> Inf $ conName c+ precIfNonNullary :: ReadPrec a -> ReadPrec a+ precIfNonNullary = if isNullaryCon x+ then id+ else prec (if conIsRecord c+ then appPrec1+ else appPrec) + t :: ConType+ t = if conIsRecord c+ then Rec+ else case conIsTuple c of+ True -> Tup+ False -> case fixity of+ Prefix -> Pref+ Infix _ _ -> Inf $ conName c+ readBraces :: ConType -> ReadPrec a -> ReadPrec a readBraces Rec r = readSurround '{' r '}' readBraces Tup r = paren r@@ -529,9 +814,14 @@ expectP (Punc [c2]) return r' --- | Class of generic representation types that can be parsed from a 'String', and--- for which the 'ConType' has been determined.-class GRead1Con v f where+-- | Class of generic representation types for unary type constructors that+-- can be parsed from a 'String', and for which the 'ConType' has been+-- determined.+class+#if __GLASGOW_HASKELL__ >= 806+ (forall a. Read a => GReadCon (f a)) =>+#endif+ GRead1Con v f where gliftReadPrecCon :: ConType -> Read1Args v a -> ReadPrec (f a) instance GRead1Con v U1 where@@ -539,44 +829,49 @@ instance Read c => GRead1Con v (K1 i c) where gliftReadPrecCon _ _ = coerceK1 readPrec- where- coerceK1 :: ReadPrec c -> ReadPrec (K1 i c p)- coerceK1 = coerce instance (Selector s, GRead1Con v f) => GRead1Con v (S1 s f) where- gliftReadPrecCon t ras- | selectorName == "" = coerceM1 $ step $ gliftReadPrecCon t ras- | otherwise = coerceM1 $ do- mapM_ expectP $ readLblLexemes selectorName- expectP (Punc "=")- reset $ gliftReadPrecCon t ras- where- selectorName :: String- selectorName = selName (undefined :: S1 s f p)+ gliftReadPrecCon t = s1ReadPrec . gliftReadPrecCon t - readLblLexemes :: String -> [Lexeme]- readLblLexemes lbl | isSymVar lbl- = [Punc "(", Symbol lbl, Punc ")"]- | otherwise- = identHLexemes lbl+s1ReadPrec :: forall s f p. Selector s+ => ReadPrec (f p) -> ReadPrec (S1 s f p)+s1ReadPrec rp+ | selectorName == "" = coerceM1 $ step rp+ | otherwise = coerceM1 $ do+ mapM_ expectP $ readLblLexemes selectorName+ expectP (Punc "=")+ reset rp+ where+ selectorName :: String+ selectorName = selName (undefined :: S1 s f p) + readLblLexemes :: String -> [Lexeme]+ readLblLexemes lbl | isSymVar lbl+ = [Punc "(", Symbol lbl, Punc ")"]+ | otherwise+ = identHLexemes lbl+ instance (GRead1Con v f, GRead1Con v g) => GRead1Con v (f :*: g) where- gliftReadPrecCon t ras = do- l <- gliftReadPrecCon t ras- case t of- Rec -> expectP (Punc ",")- Inf o -> infixPrec o- Tup -> expectP (Punc ",")- Pref -> return ()- r <- gliftReadPrecCon t ras- return (l :*: r)- where- infixPrec :: String -> ReadPrec ()- infixPrec o = if isInfixDataCon o- then expectP (Symbol o)- else mapM_ expectP $- [Punc "`"] ++ identHLexemes o ++ [Punc "`"]+ gliftReadPrecCon t ras =+ productReadPrec t (gliftReadPrecCon t ras) (gliftReadPrecCon t ras) +productReadPrec :: ConType -> ReadPrec (f p) -> ReadPrec (g p) -> ReadPrec ((f :*: g) p)+productReadPrec t rpf rpg = do+ l <- rpf+ case t of+ Rec -> expectP (Punc ",")+ Inf o -> infixPrec o+ Tup -> expectP (Punc ",")+ Pref -> return ()+ r <- rpg+ return (l :*: r)+ where+ infixPrec :: String -> ReadPrec ()+ infixPrec o = if isInfixDataCon o+ then expectP (Symbol o)+ else mapM_ expectP $+ [Punc "`"] ++ identHLexemes o ++ [Punc "`"]+ #if defined(TRANSFORMERS_FOUR) instance GRead1Con V4 Par1 where gliftReadPrecCon _ V4Read1Args = coercePar1 readPrec@@ -585,10 +880,10 @@ gliftReadPrecCon _ V4Read1Args = coerceRec1 $ readS_to_Prec readsPrec1 instance (Functor f, Read1 f, GRead1Con V4 g) => GRead1Con V4 (f :.: g) where- gliftReadPrecCon _ (V4Read1Args :: Read1Args V4 a) =- coerceComp1 $ fmap (fmap getApply) $ readS_to_Prec crp1+ gliftReadPrecCon _ (V4Read1Args :: Read1Args V4 p) =+ coerceComp1 $ fmap (fmap getApply1) $ readS_to_Prec crp1 where- crp1 :: Int -> ReadS (f (Apply g a))+ crp1 :: Int -> ReadS (f (Apply1 g p)) crp1 = readsPrec1 #else instance GRead1Con NonV4 Par1 where@@ -607,6 +902,94 @@ #endif -------------------------------------------------------------------------------+-- * Show+-------------------------------------------------------------------------------++-- | A default 'showsPrec' implementation for 'Generic1' instances that leverages+-- 'Show1'.+showsPrecDefault :: (GShow (Rep1 f a), Generic1 f)+ => Int -> f a -> ShowS+showsPrecDefault = showsPrecOptions defaultOptions++-- | Like 'showsPrecDefault', but with configurable 'Options'.+showsPrecOptions :: (GShow (Rep1 f a), Generic1 f)+ => Options -> Int -> f a -> ShowS+showsPrecOptions opts p = gshowsPrec opts p . from1++-- | Class of generic representation types that can be converted to a 'String'.+class GShow a where+ gshowsPrec :: Options -> Int -> a -> ShowS++instance GShow (f p) => GShow (D1 d f p) where+ gshowsPrec opts p (M1 x) = gshowsPrec opts p x++instance GShow (V1 p) where+ gshowsPrec _ = v1ShowsPrec++instance (GShow (f p), GShow (g p)) => GShow ((f :+: g) p) where+ gshowsPrec opts p (L1 x) = gshowsPrec opts p x+ gshowsPrec opts p (R1 x) = gshowsPrec opts p x++instance (Constructor c, GShowCon (f p), IsNullaryCon f) => GShow (C1 c f p) where+ gshowsPrec opts = c1ShowsPrec $ gshowsPrecCon opts++-- | Class of generic representation types that can be converted to a 'String', and+-- for which the 'ConType' has been determined.+class GShowCon a where+ gshowsPrecCon :: Options -> ConType -> Int -> a -> ShowS++instance GShowCon (U1 p) where+ gshowsPrecCon _ _ _ U1 = id++instance Show c => GShowCon (K1 i c p) where+ gshowsPrecCon _ _ p (K1 x) = showsPrec p x++instance (Selector s, GShowCon (f p)) => GShowCon (S1 s f p) where+ gshowsPrecCon opts = s1ShowsPrec . gshowsPrecCon opts++instance (GShowCon (f p), GShowCon (g p)) => GShowCon ((f :*: g) p) where+ gshowsPrecCon opts t =+ productShowsPrec (gshowsPrecCon opts t)+ (gshowsPrecCon opts t)+ t++instance Show p => GShowCon (Par1 p) where+ gshowsPrecCon _ _ p (Par1 x) = showsPrec p x++#if defined(TRANSFORMERS_FOUR)+instance (Show1 f, Show p) => GShowCon (Rec1 f p) where+ gshowsPrecCon _ _ p (Rec1 x) = showsPrec1 p x++instance (Functor f, Show1 f, GShowCon (g p)) => GShowCon ((f :.: g) p) where+ gshowsPrecCon _ _ p (Comp1 x) = showsPrec1 p (fmap Apply x)+#else+instance (Show1 f, Show p) => GShowCon (Rec1 f p) where+ gshowsPrecCon _ _ p (Rec1 x) = liftShowsPrec showsPrec showList p x++instance (Show1 f, GShowCon (g p)) => GShowCon ((f :.: g) p) where+ gshowsPrecCon opts t p (Comp1 x) =+ let glspc = gshowsPrecCon opts t+ in liftShowsPrec glspc (showListWith (glspc 0)) p x+#endif++#if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING)+instance GShowCon (UChar p) where+ gshowsPrecCon opts _ = uCharShowsPrec opts++instance GShowCon (UDouble p) where+ gshowsPrecCon opts _ = uDoubleShowsPrec opts++instance GShowCon (UFloat p) where+ gshowsPrecCon opts _ = uFloatShowsPrec opts++instance GShowCon (UInt p) where+ gshowsPrecCon opts _ = uIntShowsPrec opts++instance GShowCon (UWord p) where+ gshowsPrecCon opts _ = uWordShowsPrec opts+#endif++------------------------------------------------------------------------------- -- * Show1 ------------------------------------------------------------------------------- @@ -642,18 +1025,26 @@ liftShowsPrecOptions opts sp sl p = gliftShowsPrec opts (NonV4Show1Args sp sl) p . from1 #endif --- | Class of generic representation types that can be converted to a 'String'.-class GShow1 v f where+-- | Class of generic representation types for unary type constructors that can+-- be converted to a 'String'.+class+#if __GLASGOW_HASKELL__ >= 806+ (forall a. Show a => GShow (f a)) =>+#endif+ GShow1 v f where gliftShowsPrec :: Options -> Show1Args v a -> Int -> f a -> ShowS instance GShow1 v f => GShow1 v (D1 d f) where gliftShowsPrec opts sas p (M1 x) = gliftShowsPrec opts sas p x instance GShow1 v V1 where+ gliftShowsPrec _ _ = v1ShowsPrec++v1ShowsPrec :: Int -> V1 p -> ShowS #if __GLASGOW_HASKELL__ >= 708- gliftShowsPrec _ _ _ x = case x of {}+v1ShowsPrec _ _ x = case x of {} #else- gliftShowsPrec _ _ _ !_ = undefined+v1ShowsPrec _ _ !_ = undefined #endif instance (GShow1 v f, GShow1 v g) => GShow1 v (f :+: g) where@@ -661,41 +1052,49 @@ gliftShowsPrec opts sas p (R1 x) = gliftShowsPrec opts sas p x instance (Constructor c, GShow1Con v f, IsNullaryCon f) => GShow1 v (C1 c f) where- gliftShowsPrec opts sas p c@(M1 x) = case fixity of- Prefix -> showParen ( p > appPrec- && not (isNullaryCon x || conIsTuple c)- ) $- (if conIsTuple c- then id- else let cn = conName c- in showParen (isInfixDataCon cn) (showString cn))- . (if isNullaryCon x || conIsTuple c- then id- else showChar ' ')- . showBraces t (gliftShowsPrecCon opts t sas appPrec1 x)- Infix _ m -> showParen (p > m) $ gliftShowsPrecCon opts t sas (m+1) x- where- fixity :: Fixity- fixity = conFixity c+ gliftShowsPrec opts sas = c1ShowsPrec $ \t -> gliftShowsPrecCon opts t sas - t :: ConType- t = if conIsRecord c- then Rec- else case conIsTuple c of- True -> Tup- False -> case fixity of- Prefix -> Pref- Infix _ _ -> Inf $ conName c+c1ShowsPrec :: (Constructor c, IsNullaryCon f)+ => (ConType -> Int -> f p -> ShowS) -> Int -> C1 c f p -> ShowS+c1ShowsPrec sp p c@(M1 x) = case fixity of+ Prefix -> showParen ( p > appPrec+ && not (isNullaryCon x || conIsTuple c)+ ) $+ (if conIsTuple c+ then id+ else let cn = conName c+ in showParen (isInfixDataCon cn) (showString cn))+ . (if isNullaryCon x || conIsTuple c+ then id+ else showChar ' ')+ . showBraces t (sp t appPrec1 x)+ Infix _ m -> showParen (p > m) $ sp t (m+1) x+ where+ fixity :: Fixity+ fixity = conFixity c + t :: ConType+ t = if conIsRecord c+ then Rec+ else case conIsTuple c of+ True -> Tup+ False -> case fixity of+ Prefix -> Pref+ Infix _ _ -> Inf $ conName c+ showBraces :: ConType -> ShowS -> ShowS showBraces Rec b = showChar '{' . b . showChar '}' showBraces Tup b = showChar '(' . b . showChar ')' showBraces Pref b = b showBraces (Inf _) b = b --- | Class of generic representation types that can be converted to a 'String', and--- for which the 'ConType' has been determined.-class GShow1Con v f where+-- | Class of generic representation types for unary type constructors that can+-- be converted to a 'String', and for which the 'ConType' has been determined.+class+#if __GLASGOW_HASKELL__ >= 806+ (forall a. Show a => GShowCon (f a)) =>+#endif+ GShow1Con v f where gliftShowsPrecCon :: Options -> ConType -> Show1Args v a -> Int -> f a -> ShowS @@ -706,47 +1105,57 @@ gliftShowsPrecCon _ _ _ p (K1 x) = showsPrec p x instance (Selector s, GShow1Con v f) => GShow1Con v (S1 s f) where- gliftShowsPrecCon opts t sas p sel@(M1 x)- | selName sel == "" = gliftShowsPrecCon opts t sas p x- | otherwise = infixRec- . showString " = "- . gliftShowsPrecCon opts t sas 0 x- where- infixRec :: ShowS- infixRec | isSymVar selectorName- = showChar '(' . showString selectorName . showChar ')'- | otherwise- = showString selectorName+ gliftShowsPrecCon opts t sas = s1ShowsPrec $ gliftShowsPrecCon opts t sas - selectorName :: String- selectorName = selName sel+s1ShowsPrec :: Selector s => (Int -> f p -> ShowS) -> Int -> S1 s f p -> ShowS+s1ShowsPrec sp p sel@(M1 x)+ | selName sel == "" = sp p x+ | otherwise = infixRec+ . showString " = "+ . sp 0 x+ where+ infixRec :: ShowS+ infixRec | isSymVar selectorName+ = showChar '(' . showString selectorName . showChar ')'+ | otherwise+ = showString selectorName + selectorName :: String+ selectorName = selName sel+ instance (GShow1Con v f, GShow1Con v g) => GShow1Con v (f :*: g) where- gliftShowsPrecCon opts t sas p (a :*: b) =- case t of- Rec -> gliftShowsPrecCon opts t sas 0 a- . showString ", "- . gliftShowsPrecCon opts t sas 0 b+ gliftShowsPrecCon opts t sas =+ productShowsPrec (gliftShowsPrecCon opts t sas)+ (gliftShowsPrecCon opts t sas)+ t - Inf o -> gliftShowsPrecCon opts t sas p a- . showSpace- . infixOp o- . showSpace- . gliftShowsPrecCon opts t sas p b+productShowsPrec :: (Int -> f p -> ShowS) -> (Int -> g p -> ShowS)+ -> ConType -> Int -> (f :*: g) p -> ShowS+productShowsPrec spf spg t p (a :*: b) =+ case t of+ Rec -> spf 0 a+ . showString ", "+ . spg 0 b - Tup -> gliftShowsPrecCon opts t sas 0 a- . showChar ','- . gliftShowsPrecCon opts t sas 0 b+ Inf o -> spf p a+ . showSpace+ . infixOp o+ . showSpace+ . spg p b - Pref -> gliftShowsPrecCon opts t sas p a- . showSpace- . gliftShowsPrecCon opts t sas p b- where- infixOp :: String -> ShowS- infixOp o = if isInfixDataCon o- then showString o- else showChar '`' . showString o . showChar '`'+ Tup -> spf 0 a+ . showChar ','+ . spg 0 b + Pref -> spf p a+ . showSpace+ . spg p b+ where+ infixOp :: String -> ShowS+ infixOp o = if isInfixDataCon o+ then showString o+ else showChar '`' . showString o . showChar '`'+ #if defined(TRANSFORMERS_FOUR) instance GShow1Con V4 Par1 where gliftShowsPrecCon _ _ V4Show1Args p (Par1 x) = showsPrec p x@@ -755,7 +1164,7 @@ gliftShowsPrecCon _ _ V4Show1Args p (Rec1 x) = showsPrec1 p x instance (Functor f, Show1 f, GShow1Con V4 g) => GShow1Con V4 (f :.: g) where- gliftShowsPrecCon _ _ V4Show1Args p (Comp1 x) = showsPrec1 p (fmap Apply x)+ gliftShowsPrecCon _ _ V4Show1Args p (Comp1 x) = showsPrec1 p (fmap Apply1 x) #else instance GShow1Con NonV4 Par1 where gliftShowsPrecCon _ _ (NonV4Show1Args sp _) p (Par1 x) = sp p x@@ -771,25 +1180,40 @@ #if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING) instance GShow1Con v UChar where- gliftShowsPrecCon opts _ _ p (UChar c) =- showsPrec (hashPrec opts p) (C# c) . oneHash opts+ gliftShowsPrecCon opts _ _ = uCharShowsPrec opts instance GShow1Con v UDouble where- gliftShowsPrecCon opts _ _ p (UDouble d) =- showsPrec (hashPrec opts p) (D# d) . twoHash opts+ gliftShowsPrecCon opts _ _ = uDoubleShowsPrec opts instance GShow1Con v UFloat where- gliftShowsPrecCon opts _ _ p (UFloat f) =- showsPrec (hashPrec opts p) (F# f) . oneHash opts+ gliftShowsPrecCon opts _ _ = uFloatShowsPrec opts instance GShow1Con v UInt where- gliftShowsPrecCon opts _ _ p (UInt i) =- showsPrec (hashPrec opts p) (I# i) . oneHash opts+ gliftShowsPrecCon opts _ _ = uIntShowsPrec opts instance GShow1Con v UWord where- gliftShowsPrecCon opts _ _ p (UWord w) =- showsPrec (hashPrec opts p) (W# w) . twoHash opts+ gliftShowsPrecCon opts _ _ = uWordShowsPrec opts +uCharShowsPrec :: Options -> Int -> UChar p -> ShowS+uCharShowsPrec opts p (UChar c) =+ showsPrec (hashPrec opts p) (C# c) . oneHash opts++uDoubleShowsPrec :: Options -> Int -> UDouble p -> ShowS+uDoubleShowsPrec opts p (UDouble d) =+ showsPrec (hashPrec opts p) (D# d) . twoHash opts++uFloatShowsPrec :: Options -> Int -> UFloat p -> ShowS+uFloatShowsPrec opts p (UFloat f) =+ showsPrec (hashPrec opts p) (F# f) . oneHash opts++uIntShowsPrec :: Options -> Int -> UInt p -> ShowS+uIntShowsPrec opts p (UInt i) =+ showsPrec (hashPrec opts p) (I# i) . oneHash opts++uWordShowsPrec :: Options -> Int -> UWord p -> ShowS+uWordShowsPrec opts p (UWord w) =+ showsPrec (hashPrec opts p) (W# w) . twoHash opts+ oneHash, twoHash :: Options -> ShowS hashPrec :: Options -> Int -> Int oneHash opts = if ghc8ShowBehavior opts then showChar '#' else id@@ -826,6 +1250,15 @@ liftShowsPrec sp sl p (FunctorClassesDefault x) = liftShowsPrecDefault sp sl p x #endif +instance (GEq (Rep1 f a), Generic1 f) => Eq (FunctorClassesDefault f a) where+ FunctorClassesDefault x == FunctorClassesDefault y = eqDefault x y+instance (GOrd (Rep1 f a), Generic1 f) => Ord (FunctorClassesDefault f a) where+ compare (FunctorClassesDefault x) (FunctorClassesDefault y) = compareDefault x y+instance (GRead (Rep1 f a), Generic1 f) => Read (FunctorClassesDefault f a) where+ readsPrec p = coerceFCD (readsPrecDefault p)+instance (GShow (Rep1 f a), Generic1 f) => Show (FunctorClassesDefault f a) where+ showsPrec p (FunctorClassesDefault x) = showsPrecDefault p x+ coerceFCD :: ReadS (f a) -> ReadS (FunctorClassesDefault f a) coerceFCD = coerce @@ -834,24 +1267,33 @@ ------------------------------------------------------------------------------- #if defined(TRANSFORMERS_FOUR)-newtype Apply g a = Apply { getApply :: g a }+newtype Apply g a = Apply { getApply :: g a }+newtype Apply1 g a = Apply1 { getApply1 :: g a } -instance (GEq1 V4 g, Eq a) => Eq (Apply g a) where- Apply x == Apply y = gliftEq V4Eq1Args x y+instance GEq (g a) => Eq (Apply g a) where+ Apply x == Apply y = geq x y+instance (GEq1 V4 g, Eq a) => Eq (Apply1 g a) where+ Apply1 x == Apply1 y = gliftEq V4Eq1Args x y -instance (GOrd1 V4 g, Ord a) => Ord (Apply g a) where- compare (Apply x) (Apply y) = gliftCompare V4Ord1Args x y+instance GOrd (g a) => Ord (Apply g a) where+ compare (Apply x) (Apply y) = gcompare x y+instance (GOrd1 V4 g, Ord a) => Ord (Apply1 g a) where+ compare (Apply1 x) (Apply1 y) = gliftCompare V4Ord1Args x y -- Passing defaultOptions and Pref below is OK, since it's guaranteed that the -- Options and ConType won't actually have any effect on how (g a) is shown. -- If we augment Options or ConType with more features in the future, this -- decision will need to be revisited. -instance (GRead1Con V4 g, Read a) => Read (Apply g a) where- readPrec = fmap Apply $ gliftReadPrecCon Pref V4Read1Args+instance GReadCon (g a) => Read (Apply g a) where+ readPrec = fmap Apply $ greadPrecCon Pref+instance (GRead1Con V4 g, Read a) => Read (Apply1 g a) where+ readPrec = fmap Apply1 $ gliftReadPrecCon Pref V4Read1Args -instance (GShow1Con V4 g, Show a) => Show (Apply g a) where- showsPrec d = gliftShowsPrecCon defaultOptions Pref V4Show1Args d . getApply+instance GShowCon (g a) => Show (Apply g a) where+ showsPrec d = gshowsPrecCon defaultOptions Pref d . getApply+instance (GShow1Con V4 g, Show a) => Show (Apply1 g a) where+ showsPrec d = gliftShowsPrecCon defaultOptions Pref V4Show1Args d . getApply1 #endif -- | Whether a constructor is a record ('Rec'), a tuple ('Tup'), is prefix ('Pref'),
transformers-compat.cabal view
@@ -1,6 +1,6 @@ name: transformers-compat category: Compatibility-version: 0.7.1+version: 0.7.2 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE@@ -74,7 +74,7 @@ description: Use transformers 0.5 up until (but not including) 0.5.3. This will be selected by cabal picking the appropriate version. flag five-three- default: False+ default: True manual: False description: Use transformers 0.5.3. This will be selected by cabal picking the appropriate version.