{-# 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 :: Int -> a -> ShowS
gshowsPrec = (a -> Int -> ShowS) -> Int -> a -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Int -> ShowS
forall a. (Generic a, GShow0 (Rep a)) => a -> Int -> ShowS
gprecShows

gprecShows :: (Generic a, GShow0 (Rep a)) => a -> PrecShowS
gprecShows :: a -> Int -> ShowS
gprecShows = Proxy (ShowsPrec Any) -> Rep a Any -> Int -> ShowS
forall (p :: * -> *) (f :: * -> *) a.
GShow p f =>
p (ShowsPrec a) -> f a -> Int -> ShowS
gPrecShows Proxy (ShowsPrec Any)
forall k (t :: k). Proxy t
Proxy (Rep a Any -> Int -> ShowS)
-> (a -> Rep a Any) -> a -> Int -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
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 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
gliftShowsPrec Int -> a -> ShowS
showsPrec' [a] -> ShowS
showList' =
  (f a -> Int -> ShowS) -> Int -> f a -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Int -> a -> ShowS) -> ([a] -> ShowS) -> Rep1 f a -> Int -> ShowS
forall (f :: * -> *) a.
GShow1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> f a -> Int -> ShowS
gLiftPrecShows Int -> a -> ShowS
showsPrec' [a] -> ShowS
showList' (Rep1 f a -> Int -> ShowS)
-> (f a -> Rep1 f a) -> f a -> Int -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> Rep1 f a
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 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> f a -> Int -> ShowS
gLiftPrecShows = ((Int -> a -> ShowS, [a] -> ShowS) -> f a -> Int -> ShowS)
-> (Int -> a -> ShowS) -> ([a] -> ShowS) -> f a -> Int -> ShowS
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (Identity (Int -> a -> ShowS, [a] -> ShowS) -> f a -> Int -> ShowS
forall (p :: * -> *) (f :: * -> *) a.
GShow p f =>
p (ShowsPrec a) -> f a -> Int -> ShowS
gPrecShows (Identity (Int -> a -> ShowS, [a] -> ShowS) -> f a -> Int -> ShowS)
-> ((Int -> a -> ShowS, [a] -> ShowS)
    -> Identity (Int -> a -> ShowS, [a] -> ShowS))
-> (Int -> a -> ShowS, [a] -> ShowS)
-> f a
-> Int
-> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> a -> ShowS, [a] -> ShowS)
-> Identity (Int -> a -> ShowS, [a] -> ShowS)
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 :: p (ShowsPrec a) -> M1 D d f a -> Int -> ShowS
gPrecShows p (ShowsPrec a)
p (M1 f a
x) = p (ShowsPrec a) -> f a -> Int -> ShowS
forall (p :: * -> *) (f :: * -> *) a.
GShow p f =>
p (ShowsPrec a) -> f a -> Int -> ShowS
gPrecShows p (ShowsPrec a)
p f a
x

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

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

instance GShowNamed p f => GShowC p ('MetaCons s y 'True) f where
  gPrecShowsC :: p (ShowsPrec a)
-> String
-> Fixity
-> M1 C ('MetaCons s y 'True) f a
-> Int
-> ShowS
gPrecShowsC p (ShowsPrec a)
p String
name Fixity
fixity (M1 f a
x) = String -> ShowS -> Int -> ShowS
showRecord String
cname ShowS
fields
    where
      cname :: String
cname = Fixity -> ShowS
surroundConName Fixity
fixity String
name
      fields :: ShowS
fields = p (ShowsPrec a) -> f a -> ShowS
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 :: p (ShowsPrec a) -> (:*:) f g a -> [Int -> ShowS]
gPrecShowsFields p (ShowsPrec a)
p (f a
x :*: g a
y) = p (ShowsPrec a) -> f a -> [Int -> ShowS]
forall (p :: * -> *) (f :: * -> *) a.
GShowFields p f =>
p (ShowsPrec a) -> f a -> [Int -> ShowS]
gPrecShowsFields p (ShowsPrec a)
p f a
x [Int -> ShowS] -> [Int -> ShowS] -> [Int -> ShowS]
forall a. [a] -> [a] -> [a]
++ p (ShowsPrec a) -> g a -> [Int -> ShowS]
forall (p :: * -> *) (f :: * -> *) a.
GShowFields p f =>
p (ShowsPrec a) -> f a -> [Int -> ShowS]
gPrecShowsFields p (ShowsPrec a)
p g a
y

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

instance GShowFields p U1 where
  gPrecShowsFields :: p (ShowsPrec a) -> U1 a -> [Int -> ShowS]
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 :: p (ShowsPrec a) -> (:*:) f g a -> ShowS
gPrecShowsNamed p (ShowsPrec a)
p (f a
x :*: g a
y) = p (ShowsPrec a) -> f a -> ShowS
forall (p :: * -> *) (f :: * -> *) a.
GShowNamed p f =>
p (ShowsPrec a) -> f a -> ShowS
gPrecShowsNamed p (ShowsPrec a)
p f a
x ShowS -> ShowS -> ShowS
&| p (ShowsPrec a) -> g a -> 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 :: 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 -> (Int -> ShowS) -> ShowS
`showField` p (ShowsPrec a) -> f a -> Int -> ShowS
forall (p :: * -> *) (f :: * -> *) a.
GShowSingle p f =>
p (ShowsPrec a) -> f a -> Int -> ShowS
gPrecShowsSingle p (ShowsPrec a)
p f a
x
    where
      sname :: String
sname = M1 S c f a -> String
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
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
sname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
                 | Bool
otherwise      = String
sname

instance GShowNamed p U1 where
  gPrecShowsNamed :: 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 :: p (ShowsPrec a) -> K1 i a a -> Int -> ShowS
gPrecShowsSingle p (ShowsPrec a)
_ (K1 a
x) = (Int -> a -> ShowS) -> a -> Int -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec a
x

instance Show1 f => GShowSingle Identity (Rec1 f) where
  gPrecShowsSingle :: Identity (ShowsPrec a) -> Rec1 f a -> Int -> ShowS
gPrecShowsSingle (Identity ShowsPrec a
sp) (Rec1 f a
r) =
    (Int -> f a -> ShowS) -> f a -> Int -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS)
-> ShowsPrec a -> Int -> f a -> ShowS
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
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 :: Identity (ShowsPrec a) -> Par1 a -> Int -> ShowS
gPrecShowsSingle (Identity (Int -> a -> ShowS
showsPrec', [a] -> ShowS
_)) (Par1 a
a) = (Int -> a -> ShowS) -> a -> Int -> ShowS
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 :: p (ShowsPrec a) -> (:.:) f g a -> Int -> ShowS
gPrecShowsSingle p (ShowsPrec a)
p (Comp1 f (g a)
c) =
      (Int -> f (g a) -> ShowS) -> f (g a) -> Int -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Int -> g a -> ShowS)
-> ([g a] -> ShowS) -> Int -> f (g a) -> ShowS
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_ = (g a -> Int -> ShowS) -> Int -> g a -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip (p (ShowsPrec a) -> g a -> Int -> ShowS
forall (p :: * -> *) (f :: * -> *) a.
GShowSingle p f =>
p (ShowsPrec a) -> f a -> Int -> ShowS
gPrecShowsSingle p (ShowsPrec a)
p)
      showList_ :: [g a] -> ShowS
showList_ = (g a -> ShowS) -> [g a] -> ShowS
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
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
      | Bool
otherwise -> String
name
    Infix Associativity
_ Int
_
      | Bool
isSymName -> String
name
      | Bool
otherwise -> String
"`" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"`"
  where
    isSymName :: Bool
isSymName = String -> Bool
isSymDataCon String
name