{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveGeneric #-}
module Generics.Simplistic.Derive.Show (gshow , gshowsPrec) where
import Generics.Simplistic
import GHC.Generics
appPrec :: Int
appPrec :: Int
appPrec = 2
data Type = Rec | Tup | Pref | Inf String
gshow :: (Generic t, GShallow (Rep t), OnLeaves Show (Rep t))
=> t -> String
gshow :: t -> String
gshow v :: t
v = Type -> Int -> t -> ShowS
forall t.
(Generic t, GShallow (Rep t), OnLeaves Show (Rep t)) =>
Type -> Int -> t -> ShowS
gshowsPrec Type
Pref 0 t
v ""
gshowsPrec :: (Generic t, GShallow (Rep t), OnLeaves Show (Rep t))
=> Type -> Int -> t -> ShowS
gshowsPrec :: Type -> Int -> t -> ShowS
gshowsPrec t :: Type
t n :: Int
n v :: t
v = Type -> Int -> SRep I (Rep t) -> ShowS
forall (f :: * -> *).
OnLeaves Show f =>
Type -> Int -> SRep I f -> ShowS
gshowsPrec' Type
t Int
n (t -> SRep I (Rep t)
forall a. Simplistic a => a -> SRep I (Rep a)
fromS t
v)
gshowsPrec' :: (OnLeaves Show f)
=> Type -> Int -> SRep I f -> ShowS
gshowsPrec' :: Type -> Int -> SRep I f -> ShowS
gshowsPrec' _ _ S_U1 = ShowS
forall a. a -> a
id
gshowsPrec' t :: Type
t n :: Int
n (S_L1 x :: SRep I f
x) = Type -> Int -> SRep I f -> ShowS
forall (f :: * -> *).
OnLeaves Show f =>
Type -> Int -> SRep I f -> ShowS
gshowsPrec' Type
t Int
n SRep I f
x
gshowsPrec' t :: Type
t n :: Int
n (S_R1 x :: SRep I g
x) = Type -> Int -> SRep I g -> ShowS
forall (f :: * -> *).
OnLeaves Show f =>
Type -> Int -> SRep I f -> ShowS
gshowsPrec' Type
t Int
n SRep I g
x
gshowsPrec' _ n :: Int
n (S_K1 x :: I a
x) = Int -> I a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
n I a
x
gshowsPrec' t :: Type
t n :: Int
n (S_ST x :: SRep I f
x) = Type -> Int -> SRep I f -> ShowS
forall (f :: * -> *).
OnLeaves Show f =>
Type -> Int -> SRep I f -> ShowS
gshowsPrec' Type
t Int
n SRep I f
x
gshowsPrec' t :: Type
t@Type
Rec n :: Int
n (a :: SRep I f
a :**: b :: SRep I g
b) =
Type -> Int -> SRep I f -> ShowS
forall (f :: * -> *).
OnLeaves Show f =>
Type -> Int -> SRep I f -> ShowS
gshowsPrec' Type
t Int
n SRep I f
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString ", " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Int -> SRep I g -> ShowS
forall (f :: * -> *).
OnLeaves Show f =>
Type -> Int -> SRep I f -> ShowS
gshowsPrec' Type
t Int
n SRep I g
b
gshowsPrec' t :: Type
t@(Inf s :: String
s) n :: Int
n (a :: SRep I f
a :**: b :: SRep I g
b) =
Type -> Int -> SRep I f -> ShowS
forall (f :: * -> *).
OnLeaves Show f =>
Type -> Int -> SRep I f -> ShowS
gshowsPrec' Type
t Int
n SRep I f
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Int -> SRep I g -> ShowS
forall (f :: * -> *).
OnLeaves Show f =>
Type -> Int -> SRep I f -> ShowS
gshowsPrec' Type
t Int
n SRep I g
b
gshowsPrec' t :: Type
t@Type
Tup n :: Int
n (a :: SRep I f
a :**: b :: SRep I g
b) =
Type -> Int -> SRep I f -> ShowS
forall (f :: * -> *).
OnLeaves Show f =>
Type -> Int -> SRep I f -> ShowS
gshowsPrec' Type
t Int
n SRep I f
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar ',' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Int -> SRep I g -> ShowS
forall (f :: * -> *).
OnLeaves Show f =>
Type -> Int -> SRep I f -> ShowS
gshowsPrec' Type
t Int
n SRep I g
b
gshowsPrec' t :: Type
t@Type
Pref n :: Int
n (a :: SRep I f
a :**: b :: SRep I g
b) =
Type -> Int -> SRep I f -> ShowS
forall (f :: * -> *).
OnLeaves Show f =>
Type -> Int -> SRep I f -> ShowS
gshowsPrec' Type
t (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) SRep I f
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar ' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Int -> SRep I g -> ShowS
forall (f :: * -> *).
OnLeaves Show f =>
Type -> Int -> SRep I f -> ShowS
gshowsPrec' Type
t (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) SRep I g
b
gshowsPrec' _ n :: Int
n (S_M1 (SMeta i t
SM_C :: SMeta i c) (SRep I f
x :: SRep I f)) =
case Fixity
fixity of
Prefix -> Bool -> ShowS -> ShowS
showParen (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
appPrec Bool -> Bool -> Bool
&& Bool -> Bool
not (SRep I f -> Bool
forall (a :: * -> *). SRep I a -> Bool
isNullary SRep I f
x))
( String -> ShowS
showString (M1 C t f () -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName M1 C t f ()
c)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. if (SRep I f -> Bool
forall (a :: * -> *). SRep I a -> Bool
isNullary SRep I f
x) then ShowS
forall a. a -> a
id else Char -> ShowS
showChar ' '
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ShowS -> ShowS
showBraces Type
t (Type -> Int -> SRep I f -> ShowS
forall (f :: * -> *).
OnLeaves Show f =>
Type -> Int -> SRep I f -> ShowS
gshowsPrec' Type
t Int
appPrec SRep I f
x))
Infix _ m :: Int
m -> Bool -> ShowS -> ShowS
showParen (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
m) (Type -> ShowS -> ShowS
showBraces Type
t (Type -> Int -> SRep I f -> ShowS
forall (f :: * -> *).
OnLeaves Show f =>
Type -> Int -> SRep I f -> ShowS
gshowsPrec' Type
t Int
m SRep I f
x))
where M1 C t f ()
c :: M1 C c f () = M1 C t f ()
forall a. HasCallStack => a
undefined
fixity :: Fixity
fixity = M1 C t f () -> Fixity
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Fixity
conFixity M1 C t f ()
c
t :: Type
t = if (M1 C t f () -> Bool
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Bool
conIsRecord M1 C t f ()
c) then Type
Rec else
case (M1 C t f () -> Bool
forall p. C1 t f p -> Bool
conIsTuple M1 C t f ()
c) of
True -> Type
Tup
False -> case Fixity
fixity of
Prefix -> Type
Pref
Infix _ _ -> String -> Type
Inf (ShowS
forall a. Show a => a -> String
show (M1 C t f () -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName M1 C t f ()
c))
showBraces :: Type -> ShowS -> ShowS
showBraces :: Type -> ShowS -> ShowS
showBraces Rec p :: ShowS
p = Char -> ShowS
showChar '{' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
p ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar '}'
showBraces Tup p :: ShowS
p = Char -> ShowS
showChar '(' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
p ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar ')'
showBraces Pref p :: ShowS
p = ShowS
p
showBraces (Inf _) p :: ShowS
p = ShowS
p
conIsTuple :: C1 c f p -> Bool
conIsTuple :: C1 t f p -> Bool
conIsTuple y :: C1 t f p
y = String -> Bool
tupleName (C1 t f p -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName C1 t f p
y) where
tupleName :: String -> Bool
tupleName ('(':',':_) = Bool
True
tupleName _ = Bool
False
gshowsPrec' t :: Type
t n :: Int
n (S_M1 (SMeta i t
SM_S :: SMeta i c) (SRep I f
x :: SRep I f))
| M1 S t f () -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName M1 S t f ()
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "" =
(Type -> Int -> SRep I f -> ShowS
forall (f :: * -> *).
OnLeaves Show f =>
Type -> Int -> SRep I f -> ShowS
gshowsPrec' Type
t Int
n SRep I f
x)
| Bool
otherwise = String -> ShowS
showString (M1 S t f () -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName M1 S t f ()
s)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " = "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Int -> SRep I f -> ShowS
forall (f :: * -> *).
OnLeaves Show f =>
Type -> Int -> SRep I f -> ShowS
gshowsPrec' Type
t 0 SRep I f
x
where M1 S t f ()
s :: M1 S c f () = M1 S t f ()
forall a. HasCallStack => a
undefined
gshowsPrec' t :: Type
t n :: Int
n (S_M1 _ x :: SRep I f
x) = Type -> Int -> SRep I f -> ShowS
forall (f :: * -> *).
OnLeaves Show f =>
Type -> Int -> SRep I f -> ShowS
gshowsPrec' Type
t Int
n SRep I f
x
isNullary :: SRep I a -> Bool
isNullary :: SRep I a -> Bool
isNullary S_U1 = Bool
True
isNullary (S_L1 _) = String -> Bool
forall a. HasCallStack => String -> a
error "unnecessary case"
isNullary (S_R1 _) = String -> Bool
forall a. HasCallStack => String -> a
error "unnecessary case"
isNullary (_ :**: _) = Bool
False
isNullary (S_K1 _) = Bool
False
isNullary (S_M1 t :: SMeta i t
t x :: SRep I f
x) = case SMeta i t
t of
SM_S -> SRep I f -> Bool
forall (a :: * -> *). SRep I a -> Bool
isNullary SRep I f
x
_ -> String -> Bool
forall a. HasCallStack => String -> a
error "unnecessary case"
isNullary (S_ST x :: SRep I f
x) = SRep I f -> Bool
forall (a :: * -> *). SRep I a -> Bool
isNullary SRep I f
x