{-# LANGUAGE GADTs               #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE TypeOperators       #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveGeneric       #-}
-- |Derives a generic show, for example
--
-- > data MyList a = MyNil | MyCons { hd :: a, tl :: MyList a } deriving Generic
-- > 
-- > myListValue :: MyList Integer
-- > myListValue = MyCons 1 (MyCons 2 (MyCons 3 MyNil))
-- > 
-- > instance Show a => Show (MyList a) where
-- >   show = gshow
--
-- The code here was adapted from `generic-deriving`
-- https://github.com/dreixel/generic-deriving/blob/master/src/Generics/Deriving/Show.hs
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
-- "Simple" cases
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
-- The complex case of tuples
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
-- The case of metadata
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
== "" = --showParen (n > appPrec)
                      (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