{-# 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,
  )
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 :: forall (f :: * -> *) a. ShowDict (f a) -> ShowDict (Reflected1 f a)
wrapShowDict1 = coerce :: forall a b. Coercible a b => a -> b
coerce

wrapReadDict1 :: ReadDict (f a) -> ReadDict (Reflected1 f a)
wrapReadDict1 :: forall (f :: * -> *) a. ReadDict (f a) -> ReadDict (Reflected1 f a)
wrapReadDict1 = coerce :: forall a b. Coercible a b => a -> b
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 :: forall a.
(Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> Reflected1 f a -> ShowS
liftShowsPrec Int -> a -> ShowS
showsPrecB [a] -> ShowS
showListB =
    let showFB :: ShowDict (Reflected1 f a)
showFB = forall (f :: * -> *) a. ShowDict (f a) -> ShowDict (Reflected1 f a)
wrapShowDict1 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) b.
(forall a. Show a => Show (f a),
 forall x y. Coercible x y => Coercible (f x) (f y)) =>
ShowDict b -> ShowDict (f b)
autoShow1 @f (forall a. (Int -> a -> ShowS) -> ([a] -> ShowS) -> ShowDict a
ShowDict Int -> a -> ShowS
showsPrecB [a] -> ShowS
showListB)
     in forall a. ShowDict a -> Int -> a -> ShowS
_showsPrec ShowDict (Reflected1 f a)
showFB
  liftShowList :: forall a.
(Int -> a -> ShowS) -> ([a] -> ShowS) -> [Reflected1 f a] -> ShowS
liftShowList Int -> a -> ShowS
showsPrecB [a] -> ShowS
showListB =
    let showFB :: ShowDict (Reflected1 f a)
showFB = forall (f :: * -> *) a. ShowDict (f a) -> ShowDict (Reflected1 f a)
wrapShowDict1 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) b.
(forall a. Show a => Show (f a),
 forall x y. Coercible x y => Coercible (f x) (f y)) =>
ShowDict b -> ShowDict (f b)
autoShow1 @f (forall a. (Int -> a -> ShowS) -> ([a] -> ShowS) -> ShowDict a
ShowDict Int -> a -> ShowS
showsPrecB [a] -> ShowS
showListB)
     in forall a. ShowDict a -> [a] -> ShowS
_showList ShowDict (Reflected1 f a)
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 :: forall a. ReadPrec a -> ReadPrec [a] -> ReadPrec (Reflected1 f a)
liftReadPrec ReadPrec a
readPrecB ReadPrec [a]
readListPrecB =
    let readFB :: ReadDict (Reflected1 f a)
readFB = forall (f :: * -> *) a. ReadDict (f a) -> ReadDict (Reflected1 f a)
wrapReadDict1 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) b.
(forall a. Read a => Read (f a),
 forall x y. Coercible x y => Coercible (f x) (f y)) =>
ReadDict b -> ReadDict (f b)
autoRead1 @f (forall a. ReadPrec a -> ReadPrec [a] -> ReadDict a
ReadDict ReadPrec a
readPrecB ReadPrec [a]
readListPrecB)
     in forall a. ReadDict a -> ReadPrec a
_readPrec ReadDict (Reflected1 f a)
readFB

  liftReadListPrec :: forall a. ReadPrec a -> ReadPrec [a] -> ReadPrec [Reflected1 f a]
liftReadListPrec ReadPrec a
readPrecB ReadPrec [a]
readListPrecB =
    let readFB :: ReadDict (Reflected1 f a)
readFB = forall (f :: * -> *) a. ReadDict (f a) -> ReadDict (Reflected1 f a)
wrapReadDict1 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) b.
(forall a. Read a => Read (f a),
 forall x y. Coercible x y => Coercible (f x) (f y)) =>
ReadDict b -> ReadDict (f b)
autoRead1 @f (forall a. ReadPrec a -> ReadPrec [a] -> ReadDict a
ReadDict ReadPrec a
readPrecB ReadPrec [a]
readListPrecB)
     in forall a. ReadDict a -> ReadPrec [a]
_readListPrec ReadDict (Reflected1 f a)
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 :: forall (f :: * -> * -> *) a b.
ShowDict (f a b) -> ShowDict (Reflected2 f a b)
wrapShowDict2 = coerce :: forall a b. Coercible a b => a -> b
coerce

wrapReadDict2 :: ReadDict (f a b) -> ReadDict (Reflected2 f a b)
wrapReadDict2 :: forall (f :: * -> * -> *) a b.
ReadDict (f a b) -> ReadDict (Reflected2 f a b)
wrapReadDict2 = coerce :: forall a b. Coercible a b => a -> b
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 :: forall a.
(Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> Reflected2 f a a -> ShowS
liftShowsPrec Int -> a -> ShowS
showsPrecB [a] -> ShowS
showListB =
    let showFAB :: ShowDict (Reflected2 f a a)
showFAB = forall (f :: * -> * -> *) a b.
ShowDict (f a b) -> ShowDict (Reflected2 f a b)
wrapShowDict2 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) b.
(forall a. Show a => Show (f a),
 forall x y. Coercible x y => Coercible (f x) (f y)) =>
ShowDict b -> ShowDict (f b)
autoShow1 @(f a) (forall a. (Int -> a -> ShowS) -> ([a] -> ShowS) -> ShowDict a
ShowDict Int -> a -> ShowS
showsPrecB [a] -> ShowS
showListB)
     in forall a. ShowDict a -> Int -> a -> ShowS
_showsPrec ShowDict (Reflected2 f a a)
showFAB
  
  liftShowList :: forall a.
(Int -> a -> ShowS)
-> ([a] -> ShowS) -> [Reflected2 f a a] -> ShowS
liftShowList Int -> a -> ShowS
showsPrecB [a] -> ShowS
showListB = 
    let showFAB :: ShowDict (Reflected2 f a a)
showFAB = forall (f :: * -> * -> *) a b.
ShowDict (f a b) -> ShowDict (Reflected2 f a b)
wrapShowDict2 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) b.
(forall a. Show a => Show (f a),
 forall x y. Coercible x y => Coercible (f x) (f y)) =>
ShowDict b -> ShowDict (f b)
autoShow1 @(f a) (forall a. (Int -> a -> ShowS) -> ([a] -> ShowS) -> ShowDict a
ShowDict Int -> a -> ShowS
showsPrecB [a] -> ShowS
showListB)
     in forall a. ShowDict a -> [a] -> ShowS
_showList ShowDict (Reflected2 f a a)
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 :: forall a b.
(Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> Int
-> Reflected2 f a b
-> ShowS
liftShowsPrec2 Int -> a -> ShowS
showsPrecC [a] -> ShowS
showListC Int -> b -> ShowS
showsPrecD [b] -> ShowS
showListD =
    let showFCD :: ShowDict (Reflected2 f a b)
showFCD = forall (f :: * -> * -> *) a b.
ShowDict (f a b) -> ShowDict (Reflected2 f a b)
wrapShowDict2 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> * -> *) c d.
(forall a b. (Show a, Show b) => Show (f a b),
 forall x1 x2 y1 y2.
 (Coercible x1 y1, Coercible x2 y2) =>
 Coercible (f x1 x2) (f y1 y2)) =>
ShowDict c -> ShowDict d -> ShowDict (f c d)
autoShow2 @f (forall a. (Int -> a -> ShowS) -> ([a] -> ShowS) -> ShowDict a
ShowDict Int -> a -> ShowS
showsPrecC [a] -> ShowS
showListC) (forall a. (Int -> a -> ShowS) -> ([a] -> ShowS) -> ShowDict a
ShowDict Int -> b -> ShowS
showsPrecD [b] -> ShowS
showListD)
     in forall a. ShowDict a -> Int -> a -> ShowS
_showsPrec ShowDict (Reflected2 f a b)
showFCD
  liftShowList2 :: forall a b.
(Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> [Reflected2 f a b]
-> ShowS
liftShowList2 Int -> a -> ShowS
showsPrecC [a] -> ShowS
showListC Int -> b -> ShowS
showsPrecD [b] -> ShowS
showListD =
    let showFCD :: ShowDict (Reflected2 f a b)
showFCD = forall (f :: * -> * -> *) a b.
ShowDict (f a b) -> ShowDict (Reflected2 f a b)
wrapShowDict2 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> * -> *) c d.
(forall a b. (Show a, Show b) => Show (f a b),
 forall x1 x2 y1 y2.
 (Coercible x1 y1, Coercible x2 y2) =>
 Coercible (f x1 x2) (f y1 y2)) =>
ShowDict c -> ShowDict d -> ShowDict (f c d)
autoShow2 @f (forall a. (Int -> a -> ShowS) -> ([a] -> ShowS) -> ShowDict a
ShowDict Int -> a -> ShowS
showsPrecC [a] -> ShowS
showListC) (forall a. (Int -> a -> ShowS) -> ([a] -> ShowS) -> ShowDict a
ShowDict Int -> b -> ShowS
showsPrecD [b] -> ShowS
showListD)
     in forall a. ShowDict a -> [a] -> ShowS
_showList ShowDict (Reflected2 f a b)
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 :: forall a. ReadPrec a -> ReadPrec [a] -> ReadPrec (Reflected2 f a a)
liftReadPrec ReadPrec a
readPrecB ReadPrec [a]
readListB =
    let readFAB :: ReadDict (Reflected2 f a a)
readFAB = forall (f :: * -> * -> *) a b.
ReadDict (f a b) -> ReadDict (Reflected2 f a b)
wrapReadDict2 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) b.
(forall a. Read a => Read (f a),
 forall x y. Coercible x y => Coercible (f x) (f y)) =>
ReadDict b -> ReadDict (f b)
autoRead1 @(f a) (forall a. ReadPrec a -> ReadPrec [a] -> ReadDict a
ReadDict ReadPrec a
readPrecB ReadPrec [a]
readListB)
     in forall a. ReadDict a -> ReadPrec a
_readPrec ReadDict (Reflected2 f a a)
readFAB
  
  liftReadListPrec :: forall a. ReadPrec a -> ReadPrec [a] -> ReadPrec [Reflected2 f a a]
liftReadListPrec ReadPrec a
readPrecB ReadPrec [a]
readListB =
    let readFAB :: ReadDict (Reflected2 f a a)
readFAB = forall (f :: * -> * -> *) a b.
ReadDict (f a b) -> ReadDict (Reflected2 f a b)
wrapReadDict2 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) b.
(forall a. Read a => Read (f a),
 forall x y. Coercible x y => Coercible (f x) (f y)) =>
ReadDict b -> ReadDict (f b)
autoRead1 @(f a) (forall a. ReadPrec a -> ReadPrec [a] -> ReadDict a
ReadDict ReadPrec a
readPrecB ReadPrec [a]
readListB)
     in forall a. ReadDict a -> ReadPrec [a]
_readListPrec ReadDict (Reflected2 f a a)
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 :: forall a b.
ReadPrec a
-> ReadPrec [a]
-> ReadPrec b
-> ReadPrec [b]
-> ReadPrec (Reflected2 f a b)
liftReadPrec2 ReadPrec a
readPrecC ReadPrec [a]
readListPrecC ReadPrec b
readPrecD ReadPrec [b]
readListPrecD =
    let readFCD :: ReadDict (Reflected2 f a b)
readFCD = forall (f :: * -> * -> *) a b.
ReadDict (f a b) -> ReadDict (Reflected2 f a b)
wrapReadDict2 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> * -> *) c d.
(forall a b. (Read a, Read b) => Read (f a b),
 forall x1 x2 y1 y2.
 (Coercible x1 y1, Coercible x2 y2) =>
 Coercible (f x1 x2) (f y1 y2)) =>
ReadDict c -> ReadDict d -> ReadDict (f c d)
autoRead2 @f (forall a. ReadPrec a -> ReadPrec [a] -> ReadDict a
ReadDict ReadPrec a
readPrecC ReadPrec [a]
readListPrecC) (forall a. ReadPrec a -> ReadPrec [a] -> ReadDict a
ReadDict ReadPrec b
readPrecD ReadPrec [b]
readListPrecD)
     in forall a. ReadDict a -> ReadPrec a
_readPrec ReadDict (Reflected2 f a b)
readFCD

  liftReadListPrec2 :: forall a b.
ReadPrec a
-> ReadPrec [a]
-> ReadPrec b
-> ReadPrec [b]
-> ReadPrec [Reflected2 f a b]
liftReadListPrec2 ReadPrec a
readPrecC ReadPrec [a]
readListPrecC ReadPrec b
readPrecD ReadPrec [b]
readListPrecD =
    let readFCD :: ReadDict (Reflected2 f a b)
readFCD = forall (f :: * -> * -> *) a b.
ReadDict (f a b) -> ReadDict (Reflected2 f a b)
wrapReadDict2 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> * -> *) c d.
(forall a b. (Read a, Read b) => Read (f a b),
 forall x1 x2 y1 y2.
 (Coercible x1 y1, Coercible x2 y2) =>
 Coercible (f x1 x2) (f y1 y2)) =>
ReadDict c -> ReadDict d -> ReadDict (f c d)
autoRead2 @f (forall a. ReadPrec a -> ReadPrec [a] -> ReadDict a
ReadDict ReadPrec a
readPrecC ReadPrec [a]
readListPrecC) (forall a. ReadPrec a -> ReadPrec [a] -> ReadDict a
ReadDict ReadPrec b
readPrecD ReadPrec [b]
readListPrecD)
     in forall a. ReadDict a -> ReadPrec [a]
_readListPrec ReadDict (Reflected2 f a b)
readFCD