Show.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
module SOPBench.Show where

import Data.List (intersperse)
import Generics.SOP

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 pallshow (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 pshow (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 pshow
      (\ (FieldInfo l) (I y) -> K (showString l . showString " = " . showsPrec 0 y))
      fi x

pallshow :: Proxy (All Show)
pallshow = Proxy

pshow :: Proxy Show
pshow = Proxy

app_prec :: Int
app_prec = 10