GHC’s DataKinds pretty printing leaves a bit to be desired

Data.Record.TL.hs

-- WIP


{-# LANGUAGE DataKinds, GADTs, KindSignatures, TemplateHaskell,
             ScopedTypeVariables, FlexibleContexts, FlexibleInstances,
             UndecidableInstances, QuasiQuotes, RecordWildCards,
             TypeOperators #-}
module Data.Record.TL (
    type Label(..), l, label, labels,
    type Record(..), type (:=), type Field(..), (&),
  ) where

import GHC.TypeLits
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Control.Applicative

data Label (s :: Symbol) = L

instance SingRep s String => Show (Label s) where
  show (L :: Label s) = fromSing (sing :: Sing s)

l :: QuasiQuoter
l = QuasiQuoter {..} where
  quoteExp s  = [|L :: Label $(sym s)|]
  quotePat s  = sigP [p|L|] [t|Label $(varT $ mkName s)|]
  quoteType s = [t|Label $(sym s)|]
  quoteDec _  = fail "can't use [l|...|] as a declaration"

sym :: String -> TypeQ
sym s = litT $ strTyLit s

label :: String -> DecsQ
label s = sequence [sigD n t, valD (varP n) (normalB [|L|]) []] where
  n = mkName s
  t = [t|Label $(sym s)|]

labels :: [String] -> DecsQ
labels = fmap concat . mapM label

type (name :: Symbol) := (ty :: *) = '(name, ty)

data Record :: [(Symbol, *)] -> * where
  N    :: Record '[]
  (:&) :: Field s a -> Record sas -> Record ('(s, a) ': sas)

(&) = (:&)

data Field :: Symbol -> * -> * where
    (:=) :: Label s -> a -> Field s a

infixr 0 :&, &
infix  1 :=

instance (Show a, SingRep s String) => Show (Field s a) where
  showsPrec d ((L :: Label s) := val) =
    showParen (d > 1) $
      showString (fromSing (sing :: Sing s)) .
      showString " := " .
      showsPrec 2 val

instance Show (Record '[]) where
  show N = "N"

instance (Show (Record sas), Show a, SingRep s String)
    => Show (Record ('(s, a) ': sas)) where
  showsPrec d (f :& fs) =
    showParen (d > 0) $
      showsPrec 1 f .
      showString " & " .
      showsPrec 0 fs

Example.hs

{-# LANGUAGE TemplateHaskell, TypeOperators #-}
module Example where

import Data.Record.TL

label "hello"
label "goodbye"

test :: Record ["hello" := Int, "goodbye" := String]
test = hello := 6 & goodbye := "boo" & N

{-
λ» :t test
 test
   :: Record
        ((':)
           ((,) GHC.TypeLits.Symbol *)
           ("hello" := Int)
           ((':)
              ((,) GHC.TypeLits.Symbol *)
              ("goodbye" := String)
              ('[] ((,) GHC.TypeLits.Symbol *))))
-}