More type-safe, class-free and user friendly variadic printf in Haskell (inspired by myoun http://myuon-myon.hatenablog.com/entry/2014/02/21/001448).

Examples.hs

{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
module Main where
import PrintfRevised
  -- ^ Printf core
import PrintfQQ
  -- ^ QuasiQuotes

main :: IO ()
main = do
  let x = 42
  putStrLn $ printf ("If x = " %d >< ", then x == 41 is " %b >< ".") x (x == 41)
  putStrLn $ printf [fmt|89%% of the population answers that negation of True is: %{show . not}|] True

PrintfQQ.hs

{-# LANGUAGE RecordWildCards, TemplateHaskell #-}
module PrintfQQ where
import Control.Applicative
import Data.Char
import Data.List
import Data.Maybe
import Language.Haskell.Meta
import Language.Haskell.TH
import Language.Haskell.TH.Lift
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Numeric
import PrintfRevised

fmt :: QuasiQuoter
fmt = QuasiQuoter { quoteDec = error "not implemented"
                  , quoteType = error "not implemented"
                  , quotePat  = error "not implemented"
                  , quoteExp  = parse
                  }

data Fragment = StrF  String
              | ResF  Formatter
              | AntiF String
                deriving (Read, Show, Eq, Ord)

data Formatter = Float
               | Integral { base :: Integer, padding :: Maybe Char, digits :: Maybe Int }
               | String
               | Show
                 deriving (Read, Show, Eq, Ord)

liftT :: Lift a => a -> Q (TExp a)
liftT a = TExp <$> lift a

parse :: String -> ExpQ
parse = foldr cat [|EOS|] . parse'
  where
    cat (StrF s)      r = [| $(lift s) :<> $r |]
    cat (ResF Float)  r = [| (show :: Real a => a -> String) :% $r |]
    cat (ResF String) r = [| (id :: String -> String) :% $r |]
    cat (ResF Show)   r = [| (show :: Show a => a -> String) :% $r |]
    cat (ResF Integral{..}) r = do
      let pad = lift $ fromMaybe ' ' padding
          wid = lift digits
      [| ((\str -> replicate (maybe 0 (subtract (length str)) $wid) $pad ++ str) . flip $([| showIntAtBase $(lift base) intToDigit |]) "")  :% $r |]
    cat (AntiF code) r = [| $(return $ either error id $ parseExp code) :% $r |]

parse' str = case break (=='%') str of
  ("", "") -> []
  (as, "") -> [StrF as]
  (as, '%':'%':bs) -> StrF as : StrF "%" : parse' bs
  (as, '%':rest)   -> StrF as : parseFormat rest

parseFormat "" = [StrF "%"]
parseFormat ('{':r) = go (1 :: Int) "" r
  where
    go 0 c k       = AntiF (init c) : parse' k
    go p c ('{':k) = go (p+1) (c ++ "{") k
    go p c ('}':k) = go (p-1) (c ++ "}") k
    go p c (u:k)   = go p (c ++ [u]) k
    go _ _ [] = StrF "{" : parse' r
parseFormat str =
  case span isDigit str of
    ("", 's':rest) -> ResF String : parse' rest
    ("", 'S':rest) -> ResF Show : parse' rest
    ("", 'f':rest) -> ResF Float : parse' rest
    ("", r:rest) | Just base <- getBase r -> ResF (Integral base Nothing Nothing) : parse' rest
    ('0':ds, r:rest) | Just base <- getBase r ->
      ResF (Integral base (Just '0') (Just $ read ds)) : parse' rest
    (ds, r:rest) | Just base <- getBase r ->
      ResF (Integral base (Just ' ') (Just $ read ds)) : parse' rest
    _ -> parse' str

getBase :: Char -> Maybe Integer
getBase 'd' = Just 10
getBase 'b' = Just 2
getBase 'o' = Just 8
getBase 'h' = Just 16
getBase _ = Nothing

PrintfRevised.hs

{-# LANGUAGE OverloadedStrings, ConstraintKinds #-}
{-# LANGUAGE DataKinds, FlexibleInstances, GADTs, PolyKinds        #-}
{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, TypeFamilies #-}
{-# LANGUAGE TypeOperators, UndecidableInstances                   #-}
{-# OPTIONS_GHC -fwarn-unused-binds #-}
module PrintfRevised where
import Data.String        (IsString (..))
import Data.Type.Equality

main :: IO ()
main = do
  let x = 42
  putStrLn $ printf ("If x = " %d >< ", then x == 41 is " %b >< ".") x (x == 41)

data Printf xs where
  EOS   :: Printf '[]
  (:<>) :: String -> Printf xs -> Printf xs
  (:%)  :: (x -> String) -> Printf xs -> Printf (x ': xs)

data HList ts where
  HNil :: HList '[]
  (:-) :: a -> HList xs -> HList (a ': xs)

infixr 9 :-, :<>

-- | HList version.
printf' :: Printf ts -> HList ts -> String
printf' ps0 ts0 = go ps0 ts0 ""
  where
    go :: Printf us -> HList us -> ShowS
    go EOS          HNil      = id
    go (str :<> fs) xs        = showString str . go fs xs
    go (fm  :% fs)  (x :- ds) = showString (fm x) . go fs ds
    go _ _ = error "bug in GHC!"

-- | Variadic version.
printf :: Printf xs -> xs ~> String
printf p = go p ""
  where
    go :: Printf xs -> String -> xs ~> String
    go EOS a          = a
    go (str :<> xs) a = go xs (a ++ str)
    go (fmt :% xs)  a = \x -> go xs (a ++ fmt x)

-- * Smart constructors
type family (<>) xs ys where
  (<>) '[] xs = xs
  (<>) (x ': xs) ys = x ': (xs <> ys)

type family (~>) as b where
  (~>) '[] a = a
  (~>) (x ': xs) a = x -> xs ~> a

appPrf :: Printf ts -> Printf ps -> Printf (ts <> ps)
appPrf EOS ps = ps
appPrf (str :<> ts) ps = str :<> appPrf ts ps
appPrf (f :% ts) ps    = f :% appPrf ts ps

appNil :: Printf ts -> (ts <> '[]) :~: ts
appNil EOS = Refl
appNil (_ :<> a) = appNil a
appNil (_ :% bs) = case appNil bs of Refl -> Refl

instance (xs ~ '[]) => IsString (Printf xs) where
  fromString str = str :<> EOS

(><) :: Printf ts -> String -> Printf ts
xs >< str = gcastWith (appNil xs) $ appPrf xs (str :<> EOS)

(%) :: Printf ts -> (a -> String) -> Printf (ts <> '[a])
(%) xs p = appPrf xs (p :% EOS)

infixl 5 ><, %

s :: Show a => a -> String
s = show

d :: (Show a, Integral a) => a -> String
d = show

b :: Bool -> String
b = show