Haskellで文字列フォーマット

Haskellで文字列フォーマットがしたくなる時があります。
例えばPythonでは、 "{0},{1}".format(a,b) のようにして、タプルのn番目を {n} と書くと文字列中で展開されるというフォーマット用のメソッドがあります。
これがHaskellにも欲しくなったので実装しました。

使い方としては、
[format| フォーマット |] の形で書くと、整形された文字列を返してくれます。

例は以下のような感じです。

-- 要： TemplateHaskell拡張, import Control.Lens
>>> [format|{_1}, {_2}!|] $ ("hello", "world")
"hello, world!"

ただし、 [format| {f} |] $ tuple としたとき、 show $ tuple ^. f で展開されます。よって、Control.Lensをインポートしていれば、

[format| {_2} |] $ (a,b) == 
" " ++ show $ (a,b) ^. _2 ++ " " == 
" " ++ show b ++ " "

となります。
(タプルの先頭の要素が_1から始まっているのが気持ち悪い？はい、私も気持ち悪いと思いますが何故かControl.Lensだとそうなっているので文句がある方はライブラリの方に言ってください）

また、 [format| <f> |] $ tuple などとすれば、 show $ f tuple と展開されるので、以下のような使い方も可能です。

-- 要： TemplateHaskell拡張
>>> [format|<fst>, <snd>!|] $ ("hello", "world")
"hello, world!"

今のところタプルは1つしか受け取れませんが、とりあえずHaskellでも文字列フォーマットができるようになったので、これで文字列をいい感じに整形できますね！

---

以下にソースを示します。

strformat.hs

{-# LANGUAGE TemplateHaskell #-}
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Text.Parsec hiding ((<|>))
import Control.Lens

import Control.Applicative hiding (many)

-- [format| {_1}, {_2}! |] $ ("hello","world") --> hello, world!

type FString = String
data Format = Normal String
            | Getter String
            | Func String
            deriving (Show)

isFunc :: Format -> Bool
isFunc (Func _) = True
isFunc (Getter _) = True
isFunc _ = False

skipSpace :: Parsec String () a -> Parsec String () a
skipSpace p = skipMany space *> p

elimEsc :: String -> String
elimEsc = elim "\"'"
  where
    elim :: (Eq a) => [a] -> [a] -> [a]
    elim cs = filter (\x -> not $ x `elem` cs)

formatExpr :: Parsec String () [Format]
formatExpr = many1 (try fmGetter <|> try fmFunc <|> fmString)

symbol :: String -> Parsec String () String
symbol = skipSpace . string

fmGetter :: Parsec String () Format
fmGetter = Getter <$> between (symbol "{") (symbol "}") (many1 $ noneOf "}")

fmFunc :: Parsec String () Format
fmFunc = Func <$> between (symbol "<") (symbol ">") (many1 $ noneOf ">")

fmString :: Parsec String () Format
fmString = Normal <$> (many1 $ noneOf "{}<>")

toExpQ :: Format -> Name -> ExpQ
toExpQ format name =
  case format of
    Func f -> [| (++) $ elimEsc . show $ $(varE $ mkName f) $(varE name) |]
    Getter f -> [| (++) $ elimEsc . show $ $(varE name) ^. $(varE $ mkName f) |]
    Normal f -> [| (++) $(litE $ stringL f) |]
    
parseExp :: String -> ExpQ
parseExp s = case parse formatExpr "" s of
  Left err -> [| putStrLn $(litE $ stringL (show err)) |]
  Right x ->
    case any isFunc x of
      True -> do
        name <- newName "x"
        let fm = foldr appE [| "" |] $ map (flip toExpQ name) $ x
        lamE [varP name] fm
      False -> [| print $(litE $ stringL s) |]

format :: QuasiQuoter
format = QuasiQuoter { quoteExp = parseExp
                     , quotePat = undefined
                     , quoteType = undefined
                     , quoteDec = undefined}

(QuasiQuote, __TemplateHaskell__を用いています。)