Statically-checked printf using Template Haskell

main.hs

{-# LANGUAGE QuasiQuotes, ScopedTypeVariables #-}

import PrintF

main = do
	putStrLn "What is your name?"
	name <- getLine
	putStrLn $ [printf|Hello, %s, how old are you?|] name
	age <- read `fmap` getLine
	putStrLn $ [printf|You are at least %d days old!|] (365 * age)

PrintF.hs

{-# LANGUAGE DeriveDataTypeable #-}

module PrintF
where

import Data.Generics
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Quote

data Format = FInt Format         -- %d
            | FString Format      -- %s
            | FOther Char Format  -- anything else
            | FEnd
            deriving (Show, Typeable, Data)

format :: String -> Format
format ('%':'d':cs) = FInt (format cs)
format ('%':'s':cs) = FString (format cs)
format (c:cs) = FOther c (format cs)
format [] = FEnd

printf = QuasiQuoter { quoteExp = quotePrintf }

quotePrintf :: String -> TH.ExpQ
quotePrintf = formatToExp . format

formatToExp :: Format -> TH.ExpQ
formatToExp = mkLam
    where
    mkLam f = do
        (p,e) <- pats f
        return $ TH.LamE p e
    pats (FString rest) = do 
        name <- TH.newName "s"
        let pat = TH.SigP (TH.VarP name) (TH.ConT $ TH.mkName "String")
        rest <- pats rest
        return (pat : fst rest, concatE (TH.VarE name) (snd rest))
    pats (FInt rest) = do 
        name <- TH.newName "d"
        let pat = TH.SigP (TH.VarP name) (TH.ConT $ TH.mkName "Int")
        rest <- pats rest
        return (pat : fst rest, concatE (showE (TH.VarE name)) (snd rest))
    pats (FOther c rest) = do
        rest <- pats rest
        return (fst rest, TH.ConE (TH.mkName ":") `TH.AppE` (TH.LitE $ TH.CharL c) `TH.AppE` snd rest)
    pats FEnd = return ([], TH.ListE [])

    showE x = (TH.VarE $ TH.mkName "show") `TH.AppE` x
    concatE x y = (TH.VarE $ TH.mkName "++") `TH.AppE` x `TH.AppE` y