{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# 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,
    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 { forall s a. AdHoc s a -> a
unAdHoc :: a }

-- * Show

-- | Injected dictionary of Show
data ShowDict a = ShowDict
  { forall a. ShowDict a -> Int -> a -> ShowS
_showsPrec :: Int -> a -> ShowS
  , forall a. ShowDict a -> [a] -> ShowS
_showList :: [a] -> ShowS
  }

showDict :: forall a. Show a => ShowDict a
showDict :: forall a. Show a => ShowDict a
showDict = ShowDict { _showsPrec :: Int -> a -> ShowS
_showsPrec = forall a. Show a => Int -> a -> ShowS
showsPrec, _showList :: [a] -> ShowS
_showList = forall a. Show a => [a] -> ShowS
showList }
{-# INLINE showDict #-}

contramapShowDict :: (a -> b) -> ShowDict b -> ShowDict a
contramapShowDict :: forall a b. (a -> b) -> ShowDict b -> ShowDict a
contramapShowDict a -> b
f ShowDict b
sd = ShowDict{ _showsPrec :: Int -> a -> ShowS
_showsPrec = Int -> a -> ShowS
showsPrec', _showList :: [a] -> ShowS
_showList = [a] -> ShowS
showList' }
  where
    showsPrec' :: Int -> a -> ShowS
showsPrec' Int
p a
a = forall a. ShowDict a -> Int -> a -> ShowS
_showsPrec ShowDict b
sd Int
p (a -> b
f a
a)
    showList' :: [a] -> ShowS
showList' [a]
as = forall a. ShowDict a -> [a] -> ShowS
_showList ShowDict b
sd (a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
as)

instance (Reifies s (ShowDict a)) => Show (AdHoc s a) where
  showsPrec :: Int -> AdHoc s a -> ShowS
showsPrec = coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall a. ShowDict a -> Int -> a -> ShowS
_showsPrec (forall {k} (s :: k) a (proxy :: k -> *).
Reifies s a =>
proxy s -> a
reflect (forall {k} (t :: k). Proxy t
Proxy @s))
  {-# INLINABLE showsPrec #-}

  showList :: [AdHoc s a] -> ShowS
showList = coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall a. ShowDict a -> [a] -> ShowS
_showList (forall {k} (s :: k) a (proxy :: k -> *).
Reifies s a =>
proxy s -> a
reflect (forall {k} (t :: k). Proxy t
Proxy @s))
  {-# INLINABLE showList #-}

{-

u/Iceland_jack taught me the technique to use QuantifiedConstraint on Coercible constraint. Thanks!

https://www.reddit.com/r/haskell_jp/comments/a75z0s/blog_reflection%E3%82%92%E4%BD%BF%E3%81%A3%E3%81%9F%E3%83%86%E3%82%AF%E3%83%8B%E3%83%83%E3%82%AF/ed3efcv/

-}

-- | Automatic Show1
autoShow1 :: 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 :: 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 ShowDict b
showB = forall a r. a -> (forall s. Reifies s a => Proxy s -> r) -> r
reify ShowDict b
showB forall name.
Reifies name (ShowDict b) =>
Proxy name -> ShowDict (f b)
body
  where
    body :: forall name. Reifies name (ShowDict b) => Proxy name -> ShowDict (f b)
    body :: forall name.
Reifies name (ShowDict b) =>
Proxy name -> ShowDict (f b)
body Proxy name
_ = coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall a. Show a => ShowDict a
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 :: forall (f :: * -> *) b.
(forall a. Show a => Show (f a), Functor f) =>
ShowDict b -> ShowDict (f b)
autoShow1Functor ShowDict b
showB = forall a r. a -> (forall s. Reifies s a => Proxy s -> r) -> r
reify ShowDict b
showB forall name.
Reifies name (ShowDict b) =>
Proxy name -> ShowDict (f b)
body
  where
    body :: forall name. Reifies name (ShowDict b) => Proxy name -> ShowDict (f b)
    body :: forall name.
Reifies name (ShowDict b) =>
Proxy name -> ShowDict (f b)
body Proxy name
_ = forall a b. (a -> b) -> ShowDict b -> ShowDict a
contramapShowDict (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall s a. a -> AdHoc s a
AdHoc) forall a b. (a -> b) -> a -> b
$ forall a. Show a => ShowDict a
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))
  => (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 :: 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 ShowDict c
showC ShowDict d
showD =
  forall a r. a -> (forall s. Reifies s a => Proxy s -> r) -> r
reify ShowDict c
showC forall a b. (a -> b) -> a -> b
$ \Proxy s
proxyC ->
    forall a r. a -> (forall s. Reifies s a => Proxy s -> r) -> r
reify ShowDict d
showD forall a b. (a -> b) -> a -> b
$ \Proxy s
proxyD ->
      forall name1 name2.
(Reifies name1 (ShowDict c), Reifies name2 (ShowDict d)) =>
Proxy name1 -> Proxy name2 -> ShowDict (f c d)
body Proxy s
proxyC Proxy s
proxyD
  where
    body :: forall name1 name2. (Reifies name1 (ShowDict c), Reifies name2 (ShowDict d))
         => Proxy name1 -> Proxy name2 -> ShowDict (f c d)
    body :: forall name1 name2.
(Reifies name1 (ShowDict c), Reifies name2 (ShowDict d)) =>
Proxy name1 -> Proxy name2 -> ShowDict (f c d)
body Proxy name1
_ Proxy name2
_ = coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall a. Show a => ShowDict a
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 :: 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 ShowDict c
showC ShowDict d
showD =
  forall a r. a -> (forall s. Reifies s a => Proxy s -> r) -> r
reify ShowDict c
showC forall a b. (a -> b) -> a -> b
$ \Proxy s
proxyC ->
    forall a r. a -> (forall s. Reifies s a => Proxy s -> r) -> r
reify ShowDict d
showD forall a b. (a -> b) -> a -> b
$ \Proxy s
proxyD ->
      forall name1 name2.
(Reifies name1 (ShowDict c), Reifies name2 (ShowDict d)) =>
Proxy name1 -> Proxy name2 -> ShowDict (f c d)
body Proxy s
proxyC Proxy s
proxyD
  where
    body :: forall name1 name2. (Reifies name1 (ShowDict c), Reifies name2 (ShowDict d))
         => Proxy name1 -> Proxy name2 -> ShowDict (f c d)
    body :: forall name1 name2.
(Reifies name1 (ShowDict c), Reifies name2 (ShowDict d)) =>
Proxy name1 -> Proxy name2 -> ShowDict (f c d)
body Proxy name1
_ Proxy name2
_ = forall a b. (a -> b) -> ShowDict b -> ShowDict a
contramapShowDict (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall s a. a -> AdHoc s a
AdHoc forall s a. a -> AdHoc s a
AdHoc) forall a b. (a -> b) -> a -> b
$ forall a. Show a => ShowDict a
showDict @(f (AdHoc name1 c) (AdHoc name2 d))
{-# INLINABLE autoShow2Bifunctor #-}

-- * Read

-- | Injected dictionary of 'Read'
data ReadDict a = ReadDict
  { forall a. ReadDict a -> ReadPrec a
_readPrec :: ReadPrec a
  , forall a. ReadDict a -> ReadPrec [a]
_readListPrec :: ReadPrec [a]
  }
  deriving forall a b. a -> ReadDict b -> ReadDict a
forall a b. (a -> b) -> ReadDict a -> ReadDict b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ReadDict b -> ReadDict a
$c<$ :: forall a b. a -> ReadDict b -> ReadDict a
fmap :: forall a b. (a -> b) -> ReadDict a -> ReadDict b
$cfmap :: forall a b. (a -> b) -> ReadDict a -> ReadDict b
Functor

readDict :: forall a. Read a => ReadDict a
readDict :: forall a. Read a => ReadDict a
readDict = ReadDict{ _readPrec :: ReadPrec a
_readPrec = forall a. Read a => ReadPrec a
readPrec, _readListPrec :: ReadPrec [a]
_readListPrec = forall a. Read a => ReadPrec [a]
readListPrec }
{-# INLINE readDict #-}

instance (Reifies s (ReadDict a)) => Read (AdHoc s a) where
  readPrec :: ReadPrec (AdHoc s a)
readPrec = coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall a. ReadDict a -> ReadPrec a
_readPrec (forall {k} (s :: k) a (proxy :: k -> *).
Reifies s a =>
proxy s -> a
reflect (forall {k} (t :: k). Proxy t
Proxy @s))
  {-# INLINABLE readPrec #-}
  readListPrec :: ReadPrec [AdHoc s a]
readListPrec = coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall a. ReadDict a -> ReadPrec [a]
_readListPrec (forall {k} (s :: k) a (proxy :: k -> *).
Reifies s a =>
proxy s -> a
reflect (forall {k} (t :: k). Proxy t
Proxy @s))
  {-# INLINABLE readListPrec #-}

-- | Automatic Read1
autoRead1 :: 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 :: 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 ReadDict b
readB =
  forall a r. a -> (forall s. Reifies s a => Proxy s -> r) -> r
reify ReadDict b
readB forall name.
Reifies name (ReadDict b) =>
Proxy name -> ReadDict (f b)
body
  where
    body :: forall name. (Reifies name (ReadDict b)) => Proxy name -> ReadDict (f b)
    body :: forall name.
Reifies name (ReadDict b) =>
Proxy name -> ReadDict (f b)
body Proxy name
_ = coerce :: forall a b. Coercible a b => a -> b
coerce (forall a. Read a => ReadDict a
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 :: forall (f :: * -> *) b.
(forall a. Read a => Read (f a), Functor f) =>
ReadDict b -> ReadDict (f b)
autoRead1Functor ReadDict b
readB =
  forall a r. a -> (forall s. Reifies s a => Proxy s -> r) -> r
reify ReadDict b
readB forall name.
Reifies name (ReadDict b) =>
Proxy name -> ReadDict (f b)
body
  where
    body :: forall name. (Reifies name (ReadDict b)) => Proxy name -> ReadDict (f b)
    body :: forall name.
Reifies name (ReadDict b) =>
Proxy name -> ReadDict (f b)
body Proxy name
_ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall s a. AdHoc s a -> a
unAdHoc) forall a b. (a -> b) -> a -> b
$ forall a. Read a => ReadDict a
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.
         (Coercible x1 y1, Coercible x2 y2) => Coercible (f x1 x2) (f y1 y2)
       )
  => ReadDict c
  -> ReadDict d
  -> ReadDict (f c d)
autoRead2 :: 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 ReadDict c
readC ReadDict d
readD =
  forall a r. a -> (forall s. Reifies s a => Proxy s -> r) -> r
reify ReadDict c
readC forall a b. (a -> b) -> a -> b
$ \Proxy s
proxyC ->
    forall a r. a -> (forall s. Reifies s a => Proxy s -> r) -> r
reify ReadDict d
readD forall a b. (a -> b) -> a -> b
$ \Proxy s
proxyD ->
      forall name1 name2.
(Reifies name1 (ReadDict c), Reifies name2 (ReadDict d)) =>
Proxy name1 -> Proxy name2 -> ReadDict (f c d)
body Proxy s
proxyC Proxy s
proxyD
  where
    body :: forall name1 name2. (Reifies name1 (ReadDict c), Reifies name2 (ReadDict d))
         => Proxy name1 -> Proxy name2 -> ReadDict (f c d)
    body :: forall name1 name2.
(Reifies name1 (ReadDict c), Reifies name2 (ReadDict d)) =>
Proxy name1 -> Proxy name2 -> ReadDict (f c d)
body Proxy name1
_ Proxy name2
_ = coerce :: forall a b. Coercible a b => a -> b
coerce (forall a. Read a => ReadDict a
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 :: 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 ReadDict c
readC ReadDict d
readD =
  forall a r. a -> (forall s. Reifies s a => Proxy s -> r) -> r
reify ReadDict c
readC forall a b. (a -> b) -> a -> b
$ \Proxy s
proxyC ->
    forall a r. a -> (forall s. Reifies s a => Proxy s -> r) -> r
reify ReadDict d
readD forall a b. (a -> b) -> a -> b
$ \Proxy s
proxyD ->
      forall name1 name2.
(Reifies name1 (ReadDict c), Reifies name2 (ReadDict d)) =>
Proxy name1 -> Proxy name2 -> ReadDict (f c d)
body Proxy s
proxyC Proxy s
proxyD
  where
    body :: forall name1 name2. (Reifies name1 (ReadDict c), Reifies name2 (ReadDict d))
         => Proxy name1 -> Proxy name2 -> ReadDict (f c d)
    body :: forall name1 name2.
(Reifies name1 (ReadDict c), Reifies name2 (ReadDict d)) =>
Proxy name1 -> Proxy name2 -> ReadDict (f c d)
body Proxy name1
_ Proxy name2
_ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall s a. AdHoc s a -> a
unAdHoc forall s a. AdHoc s a -> a
unAdHoc) forall a b. (a -> b) -> a -> b
$ forall a. Read a => ReadDict a
readDict @(f (AdHoc name1 c) (AdHoc name2 d))
{-# INLINABLE autoRead2Bifunctor #-}