Full generic show using generics-sop

GShow.hs

{-# LANGUAGE FlexibleContexts, TypeApplications, PolyKinds, ScopedTypeVariables, GADTs #-}
{-# LANGUAGE DeriveGeneric #-}
module GShow where

import Data.List (intersperse)
import Generics.SOP
import qualified GHC.Generics as GHC

gshow ::
  (Generic a, HasDatatypeInfo a, All2 Show (Code a)) => a -> String
gshow x =
  gshowsPrec 0 x ""

gshowsPrec ::
  (Generic a, HasDatatypeInfo a, All2 Show (Code a)) => Int -> a -> ShowS
gshowsPrec d x =
    hcollapse
  $ hczipWith (Proxy @(All Show)) (gshowsConstructor d)
      (constructorInfo (datatypeInfo (I x)))
      (unSOP (from x))

gshowsConstructor ::
  forall xs . (All Show xs) => Int -> ConstructorInfo xs -> NP I xs -> K ShowS xs
gshowsConstructor d i =
  case i of
    Constructor n -> \ x -> K
      $ showParen (d > app_prec)
      $ showString n . showString " " . gshowsConstructorArgs (app_prec + 1) x
    Infix n _ prec -> \ (I l :* I r :* Nil) -> K
      $ showParen (d > prec)
      $ showsPrec (prec + 1) l
      . showString " " . showString n . showString " "
      . showsPrec (prec + 1) r
    Record n fi -> \ x -> K
      $ showParen (d > app_prec) -- could be even higher, but seems to match GHC behaviour
      $ showString n . showString " {" . gshowsRecordArgs fi x . showString "}"

gshowsConstructorArgs ::
  (All Show xs) => Int -> NP I xs -> ShowS
gshowsConstructorArgs d x =
  foldr (.) id $ hcollapse $ hcmap (Proxy @Show) (K . showsPrec d . unI) x

gshowsRecordArgs ::
  (All Show xs) => NP FieldInfo xs -> NP I xs -> ShowS
gshowsRecordArgs fi x =
    foldr (.) id
  $ intersperse (showString ", ")
  $ hcollapse
  $ hczipWith (Proxy @Show)
      (\ (FieldInfo l) (I y) -> K (showString l . showString " = " . showsPrec 0 y))
      fi x

app_prec :: Int
app_prec = 10

data Tree a = Leaf a | Tree a :^: Tree a
  deriving (GHC.Generic)
           
infixr 5 :^:

instance Generic (Tree a)
instance HasDatatypeInfo (Tree a)

data MyRec = MkRec { foo :: Int, bar :: Bool, tree :: Tree Char }
  deriving (GHC.Generic)

instance Generic MyRec
instance HasDatatypeInfo MyRec

instance Show a => Show (Tree a) where
  showsPrec = gshowsPrec

instance Show MyRec where
  showsPrec = gshowsPrec