{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Deriving.Show.Simple (showsPrecSimple, WrapSimple(..)) where

import Data.Proxy
import Data.List (intersperse)
import GHC.Generics
import GHC.TypeLits

-- | Like 'showsPrec', but shows it as if their record fields are stripped
showsPrecSimple :: (Generic a, GShowSimple (Rep a)) => Int -> a -> ShowS
showsPrecSimple :: Int -> a -> ShowS
showsPrecSimple Int
p a
a = case Rep a Any -> [ShowS]
forall k (f :: k -> *) (x :: k). GShowSimple f => f x -> [ShowS]
shows' (a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
a) of
  [ShowS
x] -> ShowS
x
  [ShowS]
xs -> Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id
    ([ShowS] -> ShowS) -> [ShowS] -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
intersperse (Char -> ShowS
showChar Char
' ') [ShowS]
xs

class GShowSimple f where
  shows' :: f x -> [ShowS]

instance GShowSimple V1 where
  shows' :: V1 x -> [ShowS]
shows' V1 x
_ = [Char] -> [ShowS]
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible"

instance GShowSimple U1 where
  shows' :: U1 x -> [ShowS]
shows' U1 x
_ = []

instance Show a => GShowSimple (K1 c a) where
  shows' :: K1 c a x -> [ShowS]
shows' (K1 a
a) = [Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 a
a]

instance (GShowSimple f, GShowSimple g) => GShowSimple (f :*: g) where
  shows' :: (:*:) f g x -> [ShowS]
shows' (f x
f :*: g x
g) = f x -> [ShowS]
forall k (f :: k -> *) (x :: k). GShowSimple f => f x -> [ShowS]
shows' f x
f [ShowS] -> [ShowS] -> [ShowS]
forall a. [a] -> [a] -> [a]
++ g x -> [ShowS]
forall k (f :: k -> *) (x :: k). GShowSimple f => f x -> [ShowS]
shows' g x
g

instance (GShowSimple f, GShowSimple g) => GShowSimple (f :+: g) where
  shows' :: (:+:) f g x -> [ShowS]
shows' (L1 f x
a) = f x -> [ShowS]
forall k (f :: k -> *) (x :: k). GShowSimple f => f x -> [ShowS]
shows' f x
a
  shows' (R1 g x
a) = g x -> [ShowS]
forall k (f :: k -> *) (x :: k). GShowSimple f => f x -> [ShowS]
shows' g x
a

instance (KnownSymbol name, GShowSimple f, c ~ 'MetaCons name fix rec) => GShowSimple (C1 c f) where
  shows' :: C1 c f x -> [ShowS]
shows' (M1 f x
a) = [Char] -> ShowS
showString (Proxy name -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (Proxy name
forall k (t :: k). Proxy t
Proxy :: Proxy name)) ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
: f x -> [ShowS]
forall k (f :: k -> *) (x :: k). GShowSimple f => f x -> [ShowS]
shows' f x
a

instance (GShowSimple f) => GShowSimple (D1 meta f) where
  shows' :: D1 meta f x -> [ShowS]
shows' (M1 f x
a) = f x -> [ShowS]
forall k (f :: k -> *) (x :: k). GShowSimple f => f x -> [ShowS]
shows' f x
a

instance (GShowSimple f) => GShowSimple (S1 meta f) where
  shows' :: S1 meta f x -> [ShowS]
shows' (M1 f x
a) = f x -> [ShowS]
forall k (f :: k -> *) (x :: k). GShowSimple f => f x -> [ShowS]
shows' f x
a

-- | The 'Show' instance uses 'showsPrecSimple'. Useful in combination with DerivingVia
newtype WrapSimple a = WrapSimple { WrapSimple a -> a
unwrapSimple :: a }

instance (Generic a, GShowSimple (Rep a)) => Show (WrapSimple a) where
  showsPrec :: Int -> WrapSimple a -> ShowS
showsPrec Int
d = Int -> a -> ShowS
forall a. (Generic a, GShowSimple (Rep a)) => Int -> a -> ShowS
showsPrecSimple Int
d (a -> ShowS) -> (WrapSimple a -> a) -> WrapSimple a -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapSimple a -> a
forall a. WrapSimple a -> a
unwrapSimple