auto-lift-classes 1.0.1 → 1.1

raw patch · 6 files changed

+481/−193 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• auto-lift-classes.cabal +10/−5
• src/AutoLift.hs +2/−185
• src/AutoLift/Coercible.hs +189/−0
• src/AutoLift/Functor.hs +200/−0
• src/AutoLift/Machinery.hs +72/−3

@@ -1,5 +1,13 @@ # Revision history for auto-lift-classes +## 1.1 -- 2023-12-08++* Rename `AutoLift` module as `AutoLift.Coercible` and+  `AutoLift` module is now alias of `AutoLift.Coercible`.+* Add `AutoLift.Functor` module, which is almost drop-in replacement of `AutoLift.Coercible`,+  which uses `Functor f` instead of `(forall x y. Coercibe x y => Coercible (f x) (f y))`.+  Same for `Bifunctor f`.+ ## 1.0.1 -- 2023-04-06  * Fix the build failure on GHC 9.6 (#2)

@@ -1,6 +1,6 @@ cabal-version:       2.0 name:                auto-lift-classes-version:             1.0.1+version:             1.1 synopsis:            Deriving (Show|Read)(1|2) description:         Deriving (Show|Read)(1|2) from the usual, stock deriveable                      instances like @Show a => Show (f a)@.@@ -12,7 +12,7 @@ category:            Data, Reflection build-type:          Simple extra-doc-files:     CHANGELOG.md-tested-with:         GHC ==8.6.5, GHC ==8.8.4, GHC ==8.10.7, GHC ==9.0.2, GHC ==9.2.7, GHC ==9.4.4, GHC ==9.6.1+tested-with:         GHC ==8.6.5, GHC ==8.8.4, GHC ==8.10.7, GHC ==9.0.2, GHC ==9.2.7, GHC ==9.4.4, GHC ==9.6.3, GHC ==9.8.1  source-repository head   type:     git@@ -20,9 +20,14 @@   branch:   main  library-  exposed-modules:    AutoLift, AutoLift.Machinery-  build-depends:      base >= 4.12 && < 5.0,-                      reflection >= 1.0+  exposed-modules:+    AutoLift,+    AutoLift.Coercible,+    AutoLift.Functor,+    AutoLift.Machinery+  build-depends:+    base >= 4.12 && < 5.0,+    reflection >= 1.0   hs-source-dirs:     src   default-language:   Haskell2010   ghc-options:        -Wall -Wcompat

@@ -1,189 +1,6 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DerivingStrategies #-}---- | Derive lifted version of 'Show' or 'Read' classes, like @'Show1' f@ or @'Read1' f@,---   from derivable instance @forall a. Show a => Show (f a)@. module AutoLift-  ( Reflected1 (..),-    Reflected2 (..),--    -- * Reexports-    Show1 (..),-    Read (..),-    Read1 (..),-    ReadPrec,+  ( module AutoLift.Coercible   ) where -import AutoLift.Machinery-import Data.Coerce-import Data.Functor.Classes-import Text.Read---- | A newtype wrapper to derive @'Show1' f@ and @'Read1' f@ from the following,---   often derivable instance.------   > instance Show a => Show (f a)---   > instance Read a => Read (f a)------ ==== Example------ Suppose you define a new type constructor @Foo@, and--- derived its @Show@ instance.------ >>> data Foo a = Foo [a] Int a deriving Show------ The derived @Show (Foo a)@ instance is defined for all @a@ with @Show a@ instance.------ > instance Show a => Show (Foo a)------ @Reflected1@ allows you to derive @'Show1' Foo@ instance from the above instance.------ >>> :set -XStandaloneDeriving -XDerivingVia--- >>> deriving via (Reflected1 Foo) instance Show1 Foo------ Let's try the derived @Show1@ instance, by showing @Foo Bool@, where--- @True@ is shown as @yes@ and @False@ as @no@, instead of the normal @Show Bool@ instance.------ >>> import Text.Show (showListWith)--- >>> let yesno b = (++) (if b then "yes" else "no")--- >>> liftShowsPrec (const yesno) (showListWith yesno) 0 (Foo [True, False] 5 False) ""--- "Foo [yes,no] 5 no"-newtype Reflected1 f a = Reflected1 (f a)--wrapShowDict1 :: ShowDict (f a) -> ShowDict (Reflected1 f a)-wrapShowDict1 = coerce--wrapReadDict1 :: ReadDict (f a) -> ReadDict (Reflected1 f a)-wrapReadDict1 = coerce--deriving newtype instance Show (f a) => Show (Reflected1 f a)--instance-  ( forall a. Show a => Show (f a),-    forall xx yy. Coercible xx yy => Coercible (f xx) (f yy)-  ) =>-  Show1 (Reflected1 f)-  where-  liftShowsPrec showsPrecB showListB =-    let showFB = wrapShowDict1 $ autoShow1 @f (ShowDict showsPrecB showListB)-     in _showsPrec showFB-  liftShowList showsPrecB showListB =-    let showFB = wrapShowDict1 $ autoShow1 @f (ShowDict showsPrecB showListB)-     in _showList showFB--deriving newtype instance Read (f a) => Read (Reflected1 f a)--instance-  ( forall a. Read a => Read (f a),-    forall xx yy. Coercible xx yy => Coercible (f xx) (f yy)-  ) =>-  Read1 (Reflected1 f)-  where-  liftReadPrec readPrecB readListPrecB =-    let readFB = wrapReadDict1 $ autoRead1 @f (ReadDict readPrecB readListPrecB)-     in _readPrec readFB--  liftReadListPrec readPrecB readListPrecB =-    let readFB = wrapReadDict1 $ autoRead1 @f (ReadDict readPrecB readListPrecB)-     in _readListPrec readFB---- | A newtype wrapper to derive @'Show2' f@ and @'Read2' f@ from the following,---   often derivable instance.------   > instance (Show a, Show b) => Show (f a b)---   > instance (Read a, Read b) => Read (f a b)------ ==== Example------ Suppose you define a new type constructor @Bar@, and--- derived its @Show@ instance.------ >>> data Bar a b = Bar [(Int,a,b)] deriving Show------ The derived @Show (Bar a b)@ instance is defined for all @a@ and @b@ with @Show@ instances.------ > instance (Show a, Show b) => Show (Bar a b)------ @Reflected2@ allows you to derive @'Show2' Bar@ instance from the above instance.------ >>> :set -XStandaloneDeriving -XDerivingVia--- >>> deriving via (Reflected2 Bar) instance Show2 Bar------ Let's try the derived @Show2@ instance by showing @Bar Bool Char@, where--- @True@ is shown as @yes@ and @False@ as @no@, instead of the normal @Show Bool@ instance.------ >>> import Text.Show (showListWith)--- >>> let yesno b = (++) (if b then "yes" else "no")--- >>> liftShowsPrec2 (const yesno) (showListWith yesno) showsPrec showList 0 (Bar [(1, True, 'A'), (2, False, 'B')]) ""--- "Bar [(1,yes,'A'),(2,no,'B')]"-newtype Reflected2 f a b = Reflected2 (f a b)--wrapShowDict2 :: ShowDict (f a b) -> ShowDict (Reflected2 f a b)-wrapShowDict2 = coerce--wrapReadDict2 :: ReadDict (f a b) -> ReadDict (Reflected2 f a b)-wrapReadDict2 = coerce--deriving newtype instance Show (f a b) => Show (Reflected2 f a b)--instance (forall y. Show y => Show (f a y),-          forall x y. Coercible x y => Coercible (f a x) (f a y)) => Show1 (Reflected2 f a) where-  liftShowsPrec showsPrecB showListB =-    let showFAB = wrapShowDict2 $ autoShow1 @(f a) (ShowDict showsPrecB showListB)-     in _showsPrec showFAB-  -  liftShowList showsPrecB showListB = -    let showFAB = wrapShowDict2 $ autoShow1 @(f a) (ShowDict showsPrecB showListB)-     in _showList showFAB--instance-  ( forall a b. (Show a, Show b) => Show (f a b),-    forall x1 y1 x2 y2.-    (Coercible x1 y1, Coercible x2 y2) =>-    Coercible (f x1 x2) (f y1 y2)-  ) =>-  Show2 (Reflected2 f)-  where-  liftShowsPrec2 showsPrecC showListC showsPrecD showListD =-    let showFCD = wrapShowDict2 $ autoShow2 @f (ShowDict showsPrecC showListC) (ShowDict showsPrecD showListD)-     in _showsPrec showFCD-  liftShowList2 showsPrecC showListC showsPrecD showListD =-    let showFCD = wrapShowDict2 $ autoShow2 @f (ShowDict showsPrecC showListC) (ShowDict showsPrecD showListD)-     in _showList showFCD--deriving newtype instance Read (f a b) => Read (Reflected2 f a b)--instance (forall y. Read y => Read (f a y),-          forall x y. Coercible x y => Coercible (f a x) (f a y)) => Read1 (Reflected2 f a) where-  liftReadPrec readPrecB readListB =-    let readFAB = wrapReadDict2 $ autoRead1 @(f a) (ReadDict readPrecB readListB)-     in _readPrec readFAB-  -  liftReadListPrec readPrecB readListB =-    let readFAB = wrapReadDict2 $ autoRead1 @(f a) (ReadDict readPrecB readListB)-     in _readListPrec readFAB--instance-  ( forall a b. (Read a, Read b) => Read (f a b),-    forall x1 y1 x2 y2.-    (Coercible x1 y1, Coercible x2 y2) =>-    Coercible (f x1 x2) (f y1 y2)-  ) =>-  Read2 (Reflected2 f)-  where-  liftReadPrec2 readPrecC readListPrecC readPrecD readListPrecD =-    let readFCD = wrapReadDict2 $ autoRead2 @f (ReadDict readPrecC readListPrecC) (ReadDict readPrecD readListPrecD)-     in _readPrec readFCD--  liftReadListPrec2 readPrecC readListPrecC readPrecD readListPrecD =-    let readFCD = wrapReadDict2 $ autoRead2 @f (ReadDict readPrecC readListPrecC) (ReadDict readPrecD readListPrecD)-     in _readListPrec readFCD+import AutoLift.Coercible

@@ -0,0 +1,189 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Derive lifted version of 'Show' or 'Read' classes, like @'Show1' f@ or @'Read1' f@,+--   from derivable instance @forall a. Show a => Show (f a)@.+module AutoLift.Coercible+  ( Reflected1 (..),+    Reflected2 (..),++    -- * Reexports+    Show1 (..),+    Read (..),+    Read1 (..),+    ReadPrec,+  )+where++import AutoLift.Machinery+import Data.Coerce+import Data.Functor.Classes+import Text.Read++-- | A newtype wrapper to derive @'Show1' f@ and @'Read1' f@ from the following,+--   often derivable instance.+--+--   > instance Show a => Show (f a)+--   > instance Read a => Read (f a)+--+-- ==== Example+--+-- Suppose you define a new type constructor @Foo@, and+-- derived its @Show@ instance.+--+-- >>> data Foo a = Foo [a] Int a deriving Show+--+-- The derived @Show (Foo a)@ instance is defined for all @a@ with @Show a@ instance.+--+-- > instance Show a => Show (Foo a)+--+-- @Reflected1@ allows you to derive @'Show1' Foo@ instance from the above instance.+--+-- >>> :set -XStandaloneDeriving -XDerivingVia+-- >>> deriving via (Reflected1 Foo) instance Show1 Foo+--+-- Let's try the derived @Show1@ instance, by showing @Foo Bool@, where+-- @True@ is shown as @yes@ and @False@ as @no@, instead of the normal @Show Bool@ instance.+--+-- >>> import Text.Show (showListWith)+-- >>> let yesno b = (++) (if b then "yes" else "no")+-- >>> liftShowsPrec (const yesno) (showListWith yesno) 0 (Foo [True, False] 5 False) ""+-- "Foo [yes,no] 5 no"+newtype Reflected1 f a = Reflected1 (f a)++wrapShowDict1 :: ShowDict (f a) -> ShowDict (Reflected1 f a)+wrapShowDict1 = coerce++wrapReadDict1 :: ReadDict (f a) -> ReadDict (Reflected1 f a)+wrapReadDict1 = coerce++deriving newtype instance Show (f a) => Show (Reflected1 f a)++instance+  ( forall a. Show a => Show (f a),+    forall xx yy. Coercible xx yy => Coercible (f xx) (f yy)+  ) =>+  Show1 (Reflected1 f)+  where+  liftShowsPrec showsPrecB showListB =+    let showFB = wrapShowDict1 $ autoShow1 @f (ShowDict showsPrecB showListB)+     in _showsPrec showFB+  liftShowList showsPrecB showListB =+    let showFB = wrapShowDict1 $ autoShow1 @f (ShowDict showsPrecB showListB)+     in _showList showFB++deriving newtype instance Read (f a) => Read (Reflected1 f a)++instance+  ( forall a. Read a => Read (f a),+    forall xx yy. Coercible xx yy => Coercible (f xx) (f yy)+  ) =>+  Read1 (Reflected1 f)+  where+  liftReadPrec readPrecB readListPrecB =+    let readFB = wrapReadDict1 $ autoRead1 @f (ReadDict readPrecB readListPrecB)+     in _readPrec readFB++  liftReadListPrec readPrecB readListPrecB =+    let readFB = wrapReadDict1 $ autoRead1 @f (ReadDict readPrecB readListPrecB)+     in _readListPrec readFB++-- | A newtype wrapper to derive @'Show2' f@ and @'Read2' f@ from the following,+--   often derivable instance.+--+--   > instance (Show a, Show b) => Show (f a b)+--   > instance (Read a, Read b) => Read (f a b)+--+-- ==== Example+--+-- Suppose you define a new type constructor @Bar@, and+-- derived its @Show@ instance.+--+-- >>> data Bar a b = Bar [(Int,a,b)] deriving Show+--+-- The derived @Show (Bar a b)@ instance is defined for all @a@ and @b@ with @Show@ instances.+--+-- > instance (Show a, Show b) => Show (Bar a b)+--+-- @Reflected2@ allows you to derive @'Show2' Bar@ instance from the above instance.+--+-- >>> :set -XStandaloneDeriving -XDerivingVia+-- >>> deriving via (Reflected2 Bar) instance Show2 Bar+--+-- Let's try the derived @Show2@ instance by showing @Bar Bool Char@, where+-- @True@ is shown as @yes@ and @False@ as @no@, instead of the normal @Show Bool@ instance.+--+-- >>> import Text.Show (showListWith)+-- >>> let yesno b = (++) (if b then "yes" else "no")+-- >>> liftShowsPrec2 (const yesno) (showListWith yesno) showsPrec showList 0 (Bar [(1, True, 'A'), (2, False, 'B')]) ""+-- "Bar [(1,yes,'A'),(2,no,'B')]"+newtype Reflected2 f a b = Reflected2 (f a b)++wrapShowDict2 :: ShowDict (f a b) -> ShowDict (Reflected2 f a b)+wrapShowDict2 = coerce++wrapReadDict2 :: ReadDict (f a b) -> ReadDict (Reflected2 f a b)+wrapReadDict2 = coerce++deriving newtype instance Show (f a b) => Show (Reflected2 f a b)++instance (forall y. Show y => Show (f a y),+          forall x y. Coercible x y => Coercible (f a x) (f a y)) => Show1 (Reflected2 f a) where+  liftShowsPrec showsPrecB showListB =+    let showFAB = wrapShowDict2 $ autoShow1 @(f a) (ShowDict showsPrecB showListB)+     in _showsPrec showFAB+  +  liftShowList showsPrecB showListB = +    let showFAB = wrapShowDict2 $ autoShow1 @(f a) (ShowDict showsPrecB showListB)+     in _showList showFAB++instance+  ( forall a b. (Show a, Show b) => Show (f a b),+    forall x1 y1 x2 y2.+    (Coercible x1 y1, Coercible x2 y2) =>+    Coercible (f x1 x2) (f y1 y2)+  ) =>+  Show2 (Reflected2 f)+  where+  liftShowsPrec2 showsPrecC showListC showsPrecD showListD =+    let showFCD = wrapShowDict2 $ autoShow2 @f (ShowDict showsPrecC showListC) (ShowDict showsPrecD showListD)+     in _showsPrec showFCD+  liftShowList2 showsPrecC showListC showsPrecD showListD =+    let showFCD = wrapShowDict2 $ autoShow2 @f (ShowDict showsPrecC showListC) (ShowDict showsPrecD showListD)+     in _showList showFCD++deriving newtype instance Read (f a b) => Read (Reflected2 f a b)++instance (forall y. Read y => Read (f a y),+          forall x y. Coercible x y => Coercible (f a x) (f a y)) => Read1 (Reflected2 f a) where+  liftReadPrec readPrecB readListB =+    let readFAB = wrapReadDict2 $ autoRead1 @(f a) (ReadDict readPrecB readListB)+     in _readPrec readFAB+  +  liftReadListPrec readPrecB readListB =+    let readFAB = wrapReadDict2 $ autoRead1 @(f a) (ReadDict readPrecB readListB)+     in _readListPrec readFAB++instance+  ( forall a b. (Read a, Read b) => Read (f a b),+    forall x1 y1 x2 y2.+    (Coercible x1 y1, Coercible x2 y2) =>+    Coercible (f x1 x2) (f y1 y2)+  ) =>+  Read2 (Reflected2 f)+  where+  liftReadPrec2 readPrecC readListPrecC readPrecD readListPrecD =+    let readFCD = wrapReadDict2 $ autoRead2 @f (ReadDict readPrecC readListPrecC) (ReadDict readPrecD readListPrecD)+     in _readPrec readFCD++  liftReadListPrec2 readPrecC readListPrecC readPrecD readListPrecD =+    let readFCD = wrapReadDict2 $ autoRead2 @f (ReadDict readPrecC readListPrecC) (ReadDict readPrecD readListPrecD)+     in _readListPrec readFCD

@@ -0,0 +1,200 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Derive lifted version of 'Show' or 'Read' classes, like @'Show1' f@ or @'Read1' f@,+--   from derivable instance @forall a. Show a => Show (f a)@.+module AutoLift.Functor+  ( Reflected1 (..),+    Reflected2 (..),++    -- * Reexports+    Show1 (..),+    Read (..),+    Read1 (..),+    ReadPrec,+  )+where++import AutoLift.Machinery+import Data.Coerce+import Data.Functor.Classes+import Text.Read+import Data.Bifunctor ( Bifunctor )++-- | A newtype wrapper to derive @'Show1' f@ and @'Read1' f@ from the following,+--   often derivable instance.+--+--   > instance Functor f+--   > instance Show a => Show (f a)+--   > instance Read a => Read (f a)+--+--   Unlike 'AutoLift.Coercible.Reflected1' from "AutoLift.Coercible" module, this wrapper+--   requires 'Functor' instance too.+--+-- ==== Example+--+-- Suppose you define a new type constructor @Foo@, and+-- derived its @Show@ and @Functor@ instance.+--+-- >>> :set -XDeriveFunctor+-- >>> data Foo a = Foo [a] Int a deriving (Show, Functor)+--+-- The derived @Show (Foo a)@ instance is defined for all @a@ with @Show a@ instance.+--+-- > instance Show a => Show (Foo a)+--+-- @Reflected1@ allows you to derive @'Show1' Foo@ instance from the above instance.+--+-- >>> :set -XStandaloneDeriving -XDerivingVia+-- >>> deriving via (Reflected1 Foo) instance Show1 Foo+--+-- Let's try the derived @Show1@ instance, by showing @Foo Bool@, where+-- @True@ is shown as @yes@ and @False@ as @no@, instead of the normal @Show Bool@ instance.+--+-- >>> import Text.Show (showListWith)+-- >>> let yesno b = (++) (if b then "yes" else "no")+-- >>> liftShowsPrec (const yesno) (showListWith yesno) 0 (Foo [True, False] 5 False) ""+-- "Foo [yes,no] 5 no"+newtype Reflected1 f a = Reflected1 (f a)++wrapShowDict1 :: ShowDict (f a) -> ShowDict (Reflected1 f a)+wrapShowDict1 = coerce++wrapReadDict1 :: ReadDict (f a) -> ReadDict (Reflected1 f a)+wrapReadDict1 = coerce++deriving newtype instance Show (f a) => Show (Reflected1 f a)++instance+  ( forall a. Show a => Show (f a),+    Functor f+  ) =>+  Show1 (Reflected1 f)+  where+  liftShowsPrec showsPrecB showListB =+    let showFB = wrapShowDict1 $ autoShow1Functor @f (ShowDict showsPrecB showListB)+     in _showsPrec showFB+  liftShowList showsPrecB showListB =+    let showFB = wrapShowDict1 $ autoShow1Functor @f (ShowDict showsPrecB showListB)+     in _showList showFB++deriving newtype instance Read (f a) => Read (Reflected1 f a)++instance+  ( forall a. Read a => Read (f a),+    Functor f+  ) =>+  Read1 (Reflected1 f)+  where+  liftReadPrec readPrecB readListPrecB =+    let readFB = wrapReadDict1 $ autoRead1Functor @f (ReadDict readPrecB readListPrecB)+     in _readPrec readFB++  liftReadListPrec readPrecB readListPrecB =+    let readFB = wrapReadDict1 $ autoRead1Functor @f (ReadDict readPrecB readListPrecB)+     in _readListPrec readFB++-- | A newtype wrapper to derive @'Show2' f@ and @'Read2' f@ from the following,+--   often derivable instance.+--+--   > instance (Show a, Show b) => Show (f a b)+--   > instance (Read a, Read b) => Read (f a b)+--+--   Unlike 'AutoLift.Coercible.Reflected2' from "AutoLift.Coercible" module, this wrapper+--   requires 'Data.Bifunctor.Bifunctor' instance too.+--+--   > instance Bifunctor f+--  +-- ==== Example+--+-- Suppose you define a new type constructor @Bar@, and+-- derived its @Show@ instance.+--+-- >>> data Bar a b = Bar [(Int,a,b)] deriving Show+--+-- The derived @Show (Bar a b)@ instance is defined for all @a@ and @b@ with @Show@ instances.+--+-- > instance (Show a, Show b) => Show (Bar a b)+--+-- By providing @Bifunctor@ instance, @Reflected2@ allows you to derive @'Show2' Bar@ instance+-- from the above instance.+--+-- >>> import Data.Bifunctor+-- >>> :set -XStandaloneDeriving -XDeriveFunctor -XDerivingVia+-- >>> deriving instance Functor (Bar a)+-- >>> instance Bifunctor Bar where bimap f g (Bar content) = Bar [ (i, f a, g b) | (i,a,b) <- content ]+-- >>> deriving via (Reflected2 Bar a) instance (Show a) => Show1 (Bar a)+-- >>> deriving via (Reflected2 Bar) instance Show2 Bar+--+-- Let's try the derived @Show2@ instance by showing @Bar Bool Char@, where+-- @True@ is shown as @yes@ and @False@ as @no@, instead of the normal @Show Bool@ instance.+--+-- >>> import Text.Show (showListWith)+-- >>> let yesno b = (++) (if b then "yes" else "no")+-- >>> liftShowsPrec2 (const yesno) (showListWith yesno) showsPrec showList 0 (Bar [(1, True, 'A'), (2, False, 'B')]) ""+-- "Bar [(1,yes,'A'),(2,no,'B')]"+newtype Reflected2 f a b = Reflected2 (f a b)++wrapShowDict2 :: ShowDict (f a b) -> ShowDict (Reflected2 f a b)+wrapShowDict2 = coerce++wrapReadDict2 :: ReadDict (f a b) -> ReadDict (Reflected2 f a b)+wrapReadDict2 = coerce++deriving newtype instance Show (f a b) => Show (Reflected2 f a b)++instance (forall y. Show y => Show (f a y), Functor (f a)) => Show1 (Reflected2 f a) where+  liftShowsPrec showsPrecB showListB =+    let showFAB = wrapShowDict2 $ autoShow1Functor @(f a) (ShowDict showsPrecB showListB)+     in _showsPrec showFAB+  +  liftShowList showsPrecB showListB = +    let showFAB = wrapShowDict2 $ autoShow1Functor @(f a) (ShowDict showsPrecB showListB)+     in _showList showFAB++instance+  ( forall a b. (Show a, Show b) => Show (f a b),+    Bifunctor f+  ) =>+  Show2 (Reflected2 f)+  where+  liftShowsPrec2 showsPrecC showListC showsPrecD showListD =+    let showFCD = wrapShowDict2 $ autoShow2Bifunctor @f (ShowDict showsPrecC showListC) (ShowDict showsPrecD showListD)+     in _showsPrec showFCD+  liftShowList2 showsPrecC showListC showsPrecD showListD =+    let showFCD = wrapShowDict2 $ autoShow2Bifunctor @f (ShowDict showsPrecC showListC) (ShowDict showsPrecD showListD)+     in _showList showFCD++deriving newtype instance Read (f a b) => Read (Reflected2 f a b)++instance (forall y. Read y => Read (f a y),+          Functor (f a)) => Read1 (Reflected2 f a) where+  liftReadPrec readPrecB readListB =+    let readFAB = wrapReadDict2 $ autoRead1Functor @(f a) (ReadDict readPrecB readListB)+     in _readPrec readFAB+  +  liftReadListPrec readPrecB readListB =+    let readFAB = wrapReadDict2 $ autoRead1Functor @(f a) (ReadDict readPrecB readListB)+     in _readListPrec readFAB++instance+  ( forall a b. (Read a, Read b) => Read (f a b),+    Bifunctor f+  ) =>+  Read2 (Reflected2 f)+  where+  liftReadPrec2 readPrecC readListPrecC readPrecD readListPrecD =+    let readFCD = wrapReadDict2 $ autoRead2Bifunctor @f (ReadDict readPrecC readListPrecC) (ReadDict readPrecD readListPrecD)+     in _readPrec readFCD++  liftReadListPrec2 readPrecC readListPrecC readPrecD readListPrecD =+    let readFCD = wrapReadDict2 $ autoRead2Bifunctor @f (ReadDict readPrecC readListPrecC) (ReadDict readPrecD readListPrecD)+     in _readListPrec readFCD

@@ -5,21 +5,28 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor #-} -- | Internal workings of "AutoLift". You usually don't need to import --   this module. module AutoLift.Machinery (     AdHoc(..),-    ShowDict(..), showDict, autoShow1, autoShow2,-    ReadDict(..), readDict, autoRead1, autoRead2+    ShowDict(..), showDict,+    autoShow1, autoShow2,+    autoShow1Functor, autoShow2Bifunctor,++    ReadDict(..), readDict,+    autoRead1, autoRead2,+    autoRead1Functor, autoRead2Bifunctor ) where  import Data.Reflection import Data.Proxy import Data.Coerce import Text.Read+import Data.Bifunctor  -- | Apply ad hoc instances on type @a@.-newtype AdHoc s a = AdHoc a+newtype AdHoc s a = AdHoc { unAdHoc :: a }  -- * Show @@ -33,6 +40,12 @@ showDict = ShowDict { _showsPrec = showsPrec, _showList = showList } {-# INLINE showDict #-} +contramapShowDict :: (a -> b) -> ShowDict b -> ShowDict a+contramapShowDict f sd = ShowDict{ _showsPrec = showsPrec', _showList = showList' }+  where+    showsPrec' p a = _showsPrec sd p (f a)+    showList' as = _showList sd (f <$> as)+ instance (Reifies s (ShowDict a)) => Show (AdHoc s a) where   showsPrec = coerce $ _showsPrec (reflect (Proxy @s))   {-# INLINABLE showsPrec #-}@@ -60,6 +73,17 @@     body _ = coerce $ showDict @(f (AdHoc name b)) {-# INLINABLE autoShow1 #-} +autoShow1Functor :: forall f b.+     (forall a. Show a => Show (f a))+  => Functor f+  => ShowDict b+  -> ShowDict (f b)+autoShow1Functor showB = reify showB body+  where+    body :: forall name. Reifies name (ShowDict b) => Proxy name -> ShowDict (f b)+    body _ = contramapShowDict (fmap AdHoc) $ showDict @(f (AdHoc name b))+{-# INLINABLE autoShow1Functor #-}+ -- | Automatic Show2 autoShow2 :: forall f c d.      (forall a b. (Show a, Show b) => Show (f a b))@@ -79,6 +103,22 @@     body _ _ = coerce $ showDict @(f (AdHoc name1 c) (AdHoc name2 d)) {-# INLINABLE autoShow2 #-} +autoShow2Bifunctor :: forall f c d.+     (forall a b. (Show a, Show b) => Show (f a b))+  => Bifunctor f+  => ShowDict c+  -> ShowDict d+  -> ShowDict (f c d)+autoShow2Bifunctor showC showD =+  reify showC $ \proxyC ->+    reify showD $ \proxyD ->+      body proxyC proxyD+  where+    body :: forall name1 name2. (Reifies name1 (ShowDict c), Reifies name2 (ShowDict d))+         => Proxy name1 -> Proxy name2 -> ShowDict (f c d)+    body _ _ = contramapShowDict (bimap AdHoc AdHoc) $ showDict @(f (AdHoc name1 c) (AdHoc name2 d))+{-# INLINABLE autoShow2Bifunctor #-}+ -- * Read  -- | Injected dictionary of 'Read'@@ -86,6 +126,7 @@   { _readPrec :: ReadPrec a   , _readListPrec :: ReadPrec [a]   }+  deriving Functor  readDict :: forall a. Read a => ReadDict a readDict = ReadDict{ _readPrec = readPrec, _readListPrec = readListPrec }@@ -110,6 +151,18 @@     body _ = coerce (readDict @(f (AdHoc name b))) {-# INLINABLE autoRead1 #-} +autoRead1Functor :: forall f b.+     (forall a. Read a => Read (f a))+  => Functor f+  => ReadDict b+  -> ReadDict (f b)+autoRead1Functor readB =+  reify readB body+  where+    body :: forall name. (Reifies name (ReadDict b)) => Proxy name -> ReadDict (f b)+    body _ = fmap (fmap unAdHoc) $ readDict @(f (AdHoc name b))+{-# INLINABLE autoRead1Functor #-}+ autoRead2 :: forall f c d.      (forall a b. (Read a, Read b) => Read (f a b))   => (forall x1 x2 y1 y2.@@ -127,3 +180,19 @@          => Proxy name1 -> Proxy name2 -> ReadDict (f c d)     body _ _ = coerce (readDict @(f (AdHoc name1 c) (AdHoc name2 d))) {-# INLINABLE autoRead2 #-}++autoRead2Bifunctor :: forall f c d.+     (forall a b. (Read a, Read b) => Read (f a b))+  => Bifunctor f+  => ReadDict c+  -> ReadDict d+  -> ReadDict (f c d)+autoRead2Bifunctor readC readD =+  reify readC $ \proxyC ->+    reify readD $ \proxyD ->+      body proxyC proxyD+  where+    body :: forall name1 name2. (Reifies name1 (ReadDict c), Reifies name2 (ReadDict d))+         => Proxy name1 -> Proxy name2 -> ReadDict (f c d)+    body _ _ = fmap (bimap unAdHoc unAdHoc) $ readDict @(f (AdHoc name1 c) (AdHoc name2 d))+{-# INLINABLE autoRead2Bifunctor #-}