Main.hs

{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}

module Main where

import GHC.Generics

-- This module implements a GShow typeclass with a `gshow :: Int -> a -> String`
-- where the first parameter limits recursion depth to the given amount
--
-- This module is mostly copy-pasted from
-- https://hackage.haskell.org/package/generic-deriving-1.14/docs/Generics-Deriving-Show.html
--
-- The main changes are the implementation of GShow' (K1 i c)
-- and the default gshowList implementation of GShow

intersperse :: a -> [a] -> [a]
intersperse _ [] = []
intersperse _ [h] = [h]
intersperse x (h : t) = h : x : intersperse x t

appPrec :: Int
appPrec = 2

data Type = Rec | Tup | Pref | Inf String

class GShow' f where
  gshowsPrec' :: Type -> Int -> Int -> f a -> ShowS
  isNullary :: f a -> Bool
  isNullary = error "generic show (isNullary): unnecessary case"

instance GShow' V1 where
  gshowsPrec' _ _ _ x = case x of

instance GShow' U1 where
  gshowsPrec' _ _ _ U1 = id
  isNullary _ = True

instance (GShow c) => GShow' (K1 i c) where
  -- Don't recurse if the recursion depth parameter is 0
  gshowsPrec' _ _ 0 _ = showDots
  -- Decrease the recursion depth parameter otherwise
  gshowsPrec' _ n k (K1 a) = gshowsPrec n (k - 1) a
  isNullary _ = False

-- No instances for P or Rec because gshow is only applicable to types of kind *

instance (GShow' a, Constructor c) => GShow' (M1 C c a) where
  gshowsPrec' _ n k c@(M1 x) =
    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 k x)
          )
      Infix _ m -> showParen (n > m) (showBraces t (gshowsPrec' t m k x))
    where
      fixity = conFixity c
      t
        | conIsRecord c = Rec
        | conIsTuple c = Tup
        | otherwise = 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

instance (Selector s, GShow' a) => GShow' (M1 S s a) where
  gshowsPrec' t n k s@(M1 x)
    | selName s == "" --showParen (n > appPrec)
      =
      gshowsPrec' t n k x
    | otherwise =
      showString (selName s)
        . showString " = "
        . gshowsPrec' t 0 k x
  isNullary (M1 x) = isNullary x

instance (GShow' a) => GShow' (M1 D d a) where
  gshowsPrec' t n k (M1 x) = gshowsPrec' t n k x

instance (GShow' a, GShow' b) => GShow' (a :+: b) where
  gshowsPrec' t n k (L1 x) = gshowsPrec' t n k x
  gshowsPrec' t n k (R1 x) = gshowsPrec' t n k x

instance (GShow' a, GShow' b) => GShow' (a :*: b) where
  gshowsPrec' t@Rec n k (a :*: b) =
    gshowsPrec' t n k a . showString ", " . gshowsPrec' t n k b
  gshowsPrec' t@(Inf s) n k (a :*: b) =
    gshowsPrec' t n k a . showString s . gshowsPrec' t n k b
  gshowsPrec' t@Tup n k (a :*: b) =
    gshowsPrec' t n k a . showChar ',' . gshowsPrec' t n k b
  gshowsPrec' t@Pref n k (a :*: b) =
    gshowsPrec' t (n + 1) k a . showChar ' ' . gshowsPrec' t (n + 1) k b

  -- If we have a product then it is not a nullary constructor
  isNullary _ = False

class GShow a where
  gshowsPrec :: Int -> Int -> a -> ShowS
  default gshowsPrec ::
    (Generic a, GShow' (Rep a)) =>
    Int ->
    Int ->
    a ->
    ShowS
  gshowsPrec = gshowsPrecdefault

  gshows :: Int -> a -> ShowS
  gshows = gshowsPrec 0

  gshow :: Int -> a -> String
  gshow k x = gshows k x ""

  gshowList :: Int -> [a] -> ShowS
  gshowList k l = showChar '[' . gshowListElems k l

-- Decreases recursion depth with each printed element
gshowListElems :: GShow a => Int -> [a] -> ShowS
gshowListElems _ [] = showChar ']'
gshowListElems 0 _ = showDots . showChar ']'
gshowListElems k (l : ls) = gshowsPrec 0 k l . showChar ',' . gshowListElems (k - 1) ls

showDots :: String -> String
showDots = showChar '.' . showChar '.' . showChar '.'

gshowsPrecdefault ::
  (Generic a, GShow' (Rep a)) =>
  Int ->
  Int ->
  a ->
  ShowS
gshowsPrecdefault n k = gshowsPrec' Pref n k . from



-- Tests

data Tree = Leaf | Node [Tree]
  deriving (Generic, GShow)

instance GShow Int where
  gshowsPrec n _ v = showsPrec n v

instance GShow a => GShow [a] where
  gshowsPrec _ = gshowList

tree :: Tree
tree = Node (repeat tree)

main :: IO ()
main = putStrLn $ gshow 3 tree