typesafe polymorphic printf in haskell (using Text.PrettyPrinter as a backend)

printf.hs

-- TODO: add some comments
-- TODO: add more formatting options
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
module Printf where

import GHC.TypeLits
import Data.Proxy
import Text.PrettyPrint.ANSI.Leijen
import Data.Maybe (fromJust)
import Data.Time.Clock (getCurrentTime, utctDay)
import Data.Time.Calendar ()

data Format
  = Lit Symbol
  | forall (k :: *). Specifier k
  | CustomSpecifier FormatSpec

------ formatting options -----
data FormatSpec
  = Hex
  | Binary

data Template (f :: [Format]) = Template

type family ToFormat (s :: k) :: Format where
    ToFormat (s :: Symbol)     = 'Lit s
    ToFormat (c :: *)          = 'Specifier c
    ToFormat (c :: FormatSpec) = 'CustomSpecifier c

class Formatter a b | a -> b where
    doFormat :: Proxy a -> b -> Doc

instance Formatter 'Hex Int where
    doFormat _ n = n `toBase` 16

instance Formatter 'Binary Int where
    doFormat _ n = n `toBase` 2

-- aux function to display arbitrary bases
toBase :: Int -> Int -> Doc
toBase 0 _ = text "0"
toBase num base
    = pretty (reverse $ conv num)
    where hexDig a = fromJust $ lookup a (zip [0..base + 1] digits)
          conv 0   = ""
          conv n'  = hexDig (n' `mod` base) : conv (n' `div` base)
          digits   = ['0'..'9'] ++ ['a'..]

------ format list -----
infixr 5 %
type family (e :: k) % (ls :: k') :: [Format] where
    e % (ls :: [Format])
      = (ToFormat e) ': ls

    e % ls
      = (ToFormat e) ': '[ToFormat ls]

class Formattable (a :: k) t | a -> t where
    format :: Proxy a -> Doc -> t

instance (Formattable (Template fs) t', KnownSymbol s) =>
    Formattable (Template (('Lit s) ': fs)) t' where
    format _ acc = format rep (acc <> pretty (symbolVal (Proxy :: Proxy s)))
        where rep = Proxy :: Proxy (Template fs)

instance (Formattable (Template fs) t', Pretty c) =>
    Formattable (Template ('Specifier c ': fs)) (c -> t') where
    format _ acc s = format rep (acc <> pretty s)
        where rep = Proxy :: Proxy (Template fs)

instance (Formattable (Template fs) t', Formatter spec c, Pretty c) =>
    Formattable (Template ('CustomSpecifier spec ': fs)) (c -> t') where
    format _ acc s = format rep (acc <> doFormat rep' s)
        where rep  = Proxy :: Proxy (Template fs)
              rep' = Proxy :: Proxy spec

instance Formattable (Template '[]) String where
    format _ = show

------ printf -----------------
printf :: forall f t. (Formattable f t) => f -> t
printf _ = format (Proxy :: Proxy f) mempty

------ EXAMPLES ---------------
greeter :: Show a => Template ("Hello, " % String % "! Today is " % a)
greeter = Template

four :: Show a => Template (a % ", " % a % ", " % a % ", " % a)
four = Template

-- pass arbitrary format specifier
base :: Proxy a -> Template ("Your number: " % Int % ", formatted (arbitrary): " % a)
base _ = Template

hex :: Template ("Your number: " % Int % ", in hex: " % 'Hex)
hex = Template

main :: IO ()
main = do
  t <- fmap utctDay getCurrentTime
  putStrLn $ printf greeter "world" (show t)

  putStrLn $ printf hex 512 512
  putStrLn $ printf (base (Proxy :: Proxy 'Hex)) 512 512
  putStrLn $ printf (base (Proxy :: Proxy 'Binary)) 242 242

  putStrLn $ printf four (1 :: Double) 2 3 4
  putStrLn $ printf four (1 :: Int) 2 3 4
  putStrLn $ printf four "polymorphic" "typesafe" "printf" "at the type-level"