{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Safe #-}

-- | Generic implementation of Show
--
-- === Warning
--
-- This is an internal module: it is not subject to any versioning policy,
-- breaking changes can happen at any time.
--
-- If something here seems useful, please report it or create a pull request to
-- export it from an external module.

module Generic.Data.Internal.Show where

import Data.Foldable (foldl')
import Data.Functor.Classes (Show1(..))
import Data.Functor.Identity
import Data.Proxy
import Generic.Data.Internal.Utils (isSymDataCon, isSymVar)
import GHC.Generics
import Text.Show.Combinators

-- | Generic 'showsPrec'.
--
-- @
-- instance 'Show' MyType where
--   'showsPrec' = 'gshowsPrec'
-- @
gshowsPrec :: (Generic a, GShow0 (Rep a)) => Int -> a -> ShowS
gshowsPrec :: forall a. (Generic a, GShow0 (Rep a)) => Int -> a -> ShowS
gshowsPrec = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (Generic a, GShow0 (Rep a)) => a -> PrecShowS
gprecShows

gprecShows :: (Generic a, GShow0 (Rep a)) => a -> PrecShowS
gprecShows :: forall a. (Generic a, GShow0 (Rep a)) => a -> PrecShowS
gprecShows = forall (p :: * -> *) (f :: * -> *) a.
GShow p f =>
p (ShowsPrec a) -> f a -> PrecShowS
gPrecShows forall {k} (t :: k). Proxy t
Proxy forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from

-- | Generic representation of 'Show' types.
type GShow0 = GShow Proxy

-- | Generic 'liftShowsPrec'.
gliftShowsPrec
  :: (Generic1 f, GShow1 (Rep1 f))
  => (Int -> a -> ShowS) -> ([a] -> ShowS)
  -> Int -> f a -> ShowS
gliftShowsPrec :: forall (f :: * -> *) a.
(Generic1 f, GShow1 (Rep1 f)) =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
gliftShowsPrec Int -> a -> ShowS
showsPrec' [a] -> ShowS
showList' =
  forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (f :: * -> *) a.
GShow1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> f a -> PrecShowS
gLiftPrecShows Int -> a -> ShowS
showsPrec' [a] -> ShowS
showList' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1)

gLiftPrecShows
  :: GShow1 f
  => (Int -> a -> ShowS) -> ([a] -> ShowS)
  -> f a -> PrecShowS
gLiftPrecShows :: forall (f :: * -> *) a.
GShow1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> f a -> PrecShowS
gLiftPrecShows = forall a b c. ((a, b) -> c) -> a -> b -> c
curry (forall (p :: * -> *) (f :: * -> *) a.
GShow p f =>
p (ShowsPrec a) -> f a -> PrecShowS
gPrecShows forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Identity a
Identity)

type ShowsPrec a = (Int -> a -> ShowS, [a] -> ShowS)

-- | Generic representation of 'Data.Functor.Classes.Show1' types.
type GShow1 = GShow Identity

class GShow p f where
  gPrecShows :: p (ShowsPrec a) -> f a -> PrecShowS

instance GShow p f => GShow p (M1 D d f) where
  gPrecShows :: forall a. p (ShowsPrec a) -> M1 D d f a -> PrecShowS
gPrecShows p (ShowsPrec a)
p (M1 f a
x) = forall (p :: * -> *) (f :: * -> *) a.
GShow p f =>
p (ShowsPrec a) -> f a -> PrecShowS
gPrecShows p (ShowsPrec a)
p f a
x

instance (GShow p f, GShow p g) => GShow p (f :+: g) where
  gPrecShows :: forall a. p (ShowsPrec a) -> (:+:) f g a -> PrecShowS
gPrecShows p (ShowsPrec a)
p (L1 f a
x) = forall (p :: * -> *) (f :: * -> *) a.
GShow p f =>
p (ShowsPrec a) -> f a -> PrecShowS
gPrecShows p (ShowsPrec a)
p f a
x
  gPrecShows p (ShowsPrec a)
p (R1 g a
y) = forall (p :: * -> *) (f :: * -> *) a.
GShow p f =>
p (ShowsPrec a) -> f a -> PrecShowS
gPrecShows p (ShowsPrec a)
p g a
y

instance (Constructor c, GShowC p c f) => GShow p (M1 C c f) where
  gPrecShows :: forall a. p (ShowsPrec a) -> M1 C c f a -> PrecShowS
gPrecShows p (ShowsPrec a)
p M1 C c f a
x = forall (p :: * -> *) (c :: Meta) (f :: * -> *) a.
GShowC p c f =>
p (ShowsPrec a) -> String -> Fixity -> M1 C c f a -> PrecShowS
gPrecShowsC p (ShowsPrec a)
p (forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName M1 C c f a
x) (forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Fixity
conFixity M1 C c f a
x) M1 C c f a
x

instance GShow p V1 where
  gPrecShows :: forall a. p (ShowsPrec a) -> V1 a -> PrecShowS
gPrecShows p (ShowsPrec a)
_ V1 a
v = case V1 a
v of {}

class GShowC p c f where
  gPrecShowsC :: p (ShowsPrec a) -> String -> Fixity -> M1 C c f a -> PrecShowS

instance GShowFields p f => GShowC p ('MetaCons s y 'False) f where
  gPrecShowsC :: forall a.
p (ShowsPrec a)
-> String -> Fixity -> M1 C ('MetaCons s y 'False) f a -> PrecShowS
gPrecShowsC p (ShowsPrec a)
p String
name Fixity
fixity (M1 f a
x)
    | Infix Associativity
_ Int
fy <- Fixity
fixity, PrecShowS
k1 : PrecShowS
k2 : [PrecShowS]
ks <- [PrecShowS]
fields =
      forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' PrecShowS -> PrecShowS -> PrecShowS
showApp (String -> Int -> PrecShowS -> PrecShowS -> PrecShowS
showInfix String
cname Int
fy PrecShowS
k1 PrecShowS
k2) [PrecShowS]
ks
    | Bool
otherwise = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' PrecShowS -> PrecShowS -> PrecShowS
showApp (String -> PrecShowS
showCon String
cname) [PrecShowS]
fields
    where
      cname :: String
cname = Fixity -> ShowS
surroundConName Fixity
fixity String
name
      fields :: [PrecShowS]
fields = forall (p :: * -> *) (f :: * -> *) a.
GShowFields p f =>
p (ShowsPrec a) -> f a -> [PrecShowS]
gPrecShowsFields p (ShowsPrec a)
p f a
x

instance GShowNamed p f => GShowC p ('MetaCons s y 'True) f where
  gPrecShowsC :: forall a.
p (ShowsPrec a)
-> String -> Fixity -> M1 C ('MetaCons s y 'True) f a -> PrecShowS
gPrecShowsC p (ShowsPrec a)
p String
name Fixity
fixity (M1 f a
x) = String -> ShowS -> PrecShowS
showRecord String
cname ShowS
fields
    where
      cname :: String
cname = Fixity -> ShowS
surroundConName Fixity
fixity String
name
      fields :: ShowS
fields = forall (p :: * -> *) (f :: * -> *) a.
GShowNamed p f =>
p (ShowsPrec a) -> f a -> ShowS
gPrecShowsNamed p (ShowsPrec a)
p f a
x

class GShowFields p f where
  gPrecShowsFields :: p (ShowsPrec a) -> f a -> [PrecShowS]

instance (GShowFields p f, GShowFields p g) => GShowFields p (f :*: g) where
  gPrecShowsFields :: forall a. p (ShowsPrec a) -> (:*:) f g a -> [PrecShowS]
gPrecShowsFields p (ShowsPrec a)
p (f a
x :*: g a
y) = forall (p :: * -> *) (f :: * -> *) a.
GShowFields p f =>
p (ShowsPrec a) -> f a -> [PrecShowS]
gPrecShowsFields p (ShowsPrec a)
p f a
x forall a. [a] -> [a] -> [a]
++ forall (p :: * -> *) (f :: * -> *) a.
GShowFields p f =>
p (ShowsPrec a) -> f a -> [PrecShowS]
gPrecShowsFields p (ShowsPrec a)
p g a
y

instance GShowSingle p f => GShowFields p (M1 S c f) where
  gPrecShowsFields :: forall a. p (ShowsPrec a) -> M1 S c f a -> [PrecShowS]
gPrecShowsFields p (ShowsPrec a)
p (M1 f a
x) = [forall (p :: * -> *) (f :: * -> *) a.
GShowSingle p f =>
p (ShowsPrec a) -> f a -> PrecShowS
gPrecShowsSingle p (ShowsPrec a)
p f a
x]

instance GShowFields p U1 where
  gPrecShowsFields :: forall a. p (ShowsPrec a) -> U1 a -> [PrecShowS]
gPrecShowsFields p (ShowsPrec a)
_ U1 a
U1 = []

class GShowNamed p f where
  gPrecShowsNamed :: p (ShowsPrec a) -> f a -> ShowFields

instance (GShowNamed p f, GShowNamed p g) => GShowNamed p (f :*: g) where
  gPrecShowsNamed :: forall a. p (ShowsPrec a) -> (:*:) f g a -> ShowS
gPrecShowsNamed p (ShowsPrec a)
p (f a
x :*: g a
y) = forall (p :: * -> *) (f :: * -> *) a.
GShowNamed p f =>
p (ShowsPrec a) -> f a -> ShowS
gPrecShowsNamed p (ShowsPrec a)
p f a
x ShowS -> ShowS -> ShowS
&| forall (p :: * -> *) (f :: * -> *) a.
GShowNamed p f =>
p (ShowsPrec a) -> f a -> ShowS
gPrecShowsNamed p (ShowsPrec a)
p g a
y

instance (Selector c, GShowSingle p f) => GShowNamed p (M1 S c f) where
  gPrecShowsNamed :: forall a. p (ShowsPrec a) -> M1 S c f a -> ShowS
gPrecShowsNamed p (ShowsPrec a)
p x' :: M1 S c f a
x'@(M1 f a
x) = String
snameParen String -> PrecShowS -> ShowS
`showField` forall (p :: * -> *) (f :: * -> *) a.
GShowSingle p f =>
p (ShowsPrec a) -> f a -> PrecShowS
gPrecShowsSingle p (ShowsPrec a)
p f a
x
    where
      sname :: String
sname = forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName M1 S c f a
x'
      snameParen :: String
snameParen | String -> Bool
isSymVar String
sname = String
"(" forall a. [a] -> [a] -> [a]
++ String
sname forall a. [a] -> [a] -> [a]
++ String
")"
                 | Bool
otherwise      = String
sname

instance GShowNamed p U1 where
  gPrecShowsNamed :: forall a. p (ShowsPrec a) -> U1 a -> ShowS
gPrecShowsNamed p (ShowsPrec a)
_ U1 a
U1 = ShowS
noFields

class GShowSingle p f where
  gPrecShowsSingle :: p (ShowsPrec a) -> f a -> PrecShowS

instance Show a => GShowSingle p (K1 i a) where
  gPrecShowsSingle :: forall a. p (ShowsPrec a) -> K1 i a a -> PrecShowS
gPrecShowsSingle p (ShowsPrec a)
_ (K1 a
x) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Show a => Int -> a -> ShowS
showsPrec a
x

instance Show1 f => GShowSingle Identity (Rec1 f) where
  gPrecShowsSingle :: forall a. Identity (ShowsPrec a) -> Rec1 f a -> PrecShowS
gPrecShowsSingle (Identity ShowsPrec a
sp) (Rec1 f a
r) =
    forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec ShowsPrec a
sp) f a
r

instance GShowSingle Identity Par1 where
  gPrecShowsSingle :: forall a. Identity (ShowsPrec a) -> Par1 a -> PrecShowS
gPrecShowsSingle (Identity (Int -> a -> ShowS
showsPrec', [a] -> ShowS
_)) (Par1 a
a) = forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> a -> ShowS
showsPrec' a
a

instance (Show1 f, GShowSingle p g)
  => GShowSingle p (f :.: g) where
  gPrecShowsSingle :: forall a. p (ShowsPrec a) -> (:.:) f g a -> PrecShowS
gPrecShowsSingle p (ShowsPrec a)
p (Comp1 f (g a)
c) =
      forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> g a -> ShowS
showsPrec_ [g a] -> ShowS
showList_) f (g a)
c
    where
      showsPrec_ :: Int -> g a -> ShowS
showsPrec_ = forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (p :: * -> *) (f :: * -> *) a.
GShowSingle p f =>
p (ShowsPrec a) -> f a -> PrecShowS
gPrecShowsSingle p (ShowsPrec a)
p)
      showList_ :: [g a] -> ShowS
showList_ = forall a. (a -> ShowS) -> [a] -> ShowS
showListWith (Int -> g a -> ShowS
showsPrec_ Int
0)

-- Helpers

surroundConName :: Fixity -> String -> String
surroundConName :: Fixity -> ShowS
surroundConName Fixity
fixity String
name =
  case Fixity
fixity of
    Fixity
Prefix
      | Bool
isSymName -> String
"(" forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
")"
      | Bool
otherwise -> String
name
    Infix Associativity
_ Int
_
      | Bool
isSymName -> String
name
      | Bool
otherwise -> String
"`" forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"`"
  where
    isSymName :: Bool
isSymName = String -> Bool
isSymDataCon String
name