{-# language GADTs,
             TypeFamilies,
             ConstraintKinds,
             TypeOperators,
             FlexibleContexts,
             ScopedTypeVariables,
             DeriveGeneric #-}
module Generics.Simplistic.Derive.Show where

import Data.Functor.Identity
import Generics.Simplistic
import GHC.Generics

-- An 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

-- Translated from `generic-deriving`
-- https://github.com/dreixel/generic-deriving/blob/master/src/Generics/Deriving/Show.hs

appPrec :: Int
appPrec = 2

data Type = Rec | Tup | Pref | Inf String

gshow :: (GenericSy t, OnLeaves Show (Rep t))
      => t -> String
gshow v = gshowsPrec Pref 0 v ""

gshowsPrec :: (GenericSy t, OnLeaves Show (Rep t))
           => Type -> Int -> t -> ShowS
gshowsPrec t n v = gshowsPrec' t n (fromS v)

gshowsPrec' :: (OnLeaves Show f)
            => Type -> Int -> SRep Identity f -> ShowS
-- "Simple" cases
gshowsPrec' _ _ S_U1       = id
gshowsPrec' t n (S_L1 x)   = gshowsPrec' t n x
gshowsPrec' t n (S_R1 x)   = gshowsPrec' t n x
gshowsPrec' _ n (S_K1 x)   = showsPrec n x
gshowsPrec' t n (S_ST x)   = gshowsPrec' t n x
-- The complex case of tuples
gshowsPrec' t@Rec     n (a :**: b) =
  gshowsPrec' t n     a . showString ", " . gshowsPrec' t n     b
gshowsPrec' t@(Inf s) n (a :**: b) =
  gshowsPrec' t n     a . showString s    . gshowsPrec' t n     b
gshowsPrec' t@Tup     n (a :**: b) =
  gshowsPrec' t n     a . showChar ','    . gshowsPrec' t n     b
gshowsPrec' t@Pref    n (a :**: b) =
  gshowsPrec' t (n+1) a . showChar ' '    . gshowsPrec' t (n+1) b
-- The case of metadata
gshowsPrec' t n (S_M1 (SM_C :: SMeta i c) (x :: SRep Identity f)) = 
  case fixity of
    Prefix    -> showParen (n > appPrec && not (isNullary x))
                  ( showString (conName c)
                  . if (isNullary x) then id else showChar ' '
                  . showBraces t (gshowsPrec' t appPrec x))
    Infix _ m -> showParen (n > m) (showBraces t (gshowsPrec' t m x))
    where c :: M1 C c f () = undefined
          fixity = conFixity c
          t = if (conIsRecord c) then Rec else
                case (conIsTuple c) of
                  True -> Tup
                  False -> case fixity of
                              Prefix    -> Pref
                              Infix _ _ -> Inf (show (conName c))
          showBraces :: Type -> ShowS -> ShowS
          showBraces Rec     p = showChar '{' . p . showChar '}'
          showBraces Tup     p = showChar '(' . p . showChar ')'
          showBraces Pref    p = p
          showBraces (Inf _) p = p
          conIsTuple :: C1 c f p -> Bool
          conIsTuple y = tupleName (conName y) where
            tupleName ('(':',':_) = True
            tupleName _ = False
gshowsPrec' t n (S_M1 (SM_S :: SMeta i c) (x :: SRep Identity f)) 
  | selName s == "" = --showParen (n > appPrec)
                      (gshowsPrec' t n x)
  | otherwise       =   showString (selName s)
                      . showString " = "
                      . gshowsPrec' t 0 x
    where s :: M1 S c f () = undefined
gshowsPrec' t n (S_M1 _ x) = gshowsPrec' t n x

isNullary :: SRep Identity a -> Bool
isNullary S_U1       = True
isNullary (S_L1 x)   = error "unnecessary case"
isNullary (S_R1 x)   = error "unnecessary case"
isNullary (x :**: y) = False
isNullary (S_K1 x)   = False
isNullary (S_M1 t x) = case t of
                         SM_S -> isNullary x
                         _    -> error "unnecessary case"
isNullary (S_ST x)   = isNullary x