{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Safe #-}
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
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
type GShow0 = GShow Proxy
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)
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)
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