show-combinators-0.1.0.0: test/test.hs

import Text.Show.Combinators

data MyType a
  = C a a                   -- a regular constructor
  | a :+: a                 -- an infix constructor
  | R { f1 :: a, f2 :: a }  -- a record
  deriving Show

infixl 4 :+:

showsMyType :: (a -> PrecShowS) -> MyType a -> PrecShowS
showsMyType showA (C a b) = showCon "C" `showApp` showA a `showApp` showA b
showsMyType showA (c :+: d) = showInfix ":+:" 4 (showA c) (showA d)
showsMyType showA (R {f1 = e, f2 = f}) =
  showRecord "R" ("f1" `showField` showA e &| "f2" `showField` showA f)

-- Just making sure this typechecks
_showsMyType' :: Show a => MyType a -> PrecShowS
_showsMyType' (C a b) = showCon "C" @| a @| b
_showsMyType' (c :+: d) = showInfix' ":+:" 4 c d
_showsMyType' (R {f1 = e, f2 = f}) =
  showRecord "R" ("f1" .=. e &| "f2" .=. f)

check :: Show a => (a -> PrecShowS) -> a -> IO ()
check show' x =
  if s == s' then
    return ()
  else
    fail $ show (s, s')
  where
    s = show x
    s' = show' x 0 ""

main :: IO ()
main = do
  check smt1 (C () ())
  check smt2 (C (C () ()) (() :+: ()))
  check smt2 ((() :+: ()) :+: (() :+: ()))
  check smt2 (R (C () ()) (C () ()))
  where
    smt1 = showsMyType (flip showsPrec)
    smt2 = showsMyType smt1