{-# 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 = 2

data Type = Rec | Tup | Pref | Inf String

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

gshowsPrec :: (Generic t, GShallow (Rep 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 I 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' _ n (S_M1 (SM_C :: SMeta i c) (x :: SRep I 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 I 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 I a -> Bool
isNullary S_U1       = True
isNullary (S_L1 _)   = error "unnecessary case"
isNullary (S_R1 _)   = error "unnecessary case"
isNullary (_ :**: _) = False
isNullary (S_K1 _)   = False
isNullary (S_M1 t x) = case t of
                         SM_S -> isNullary x
                         _    -> error "unnecessary case"
isNullary (S_ST x)   = isNullary x