Вот один подход, который пытается позволить существующему Text.Printf
выполнить как можно большую часть работы.Во-первых, нам понадобятся некоторые расширения:
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
-- To avoid having to write some type signatures.
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ExtendedDefaultRules #-}
import Control.Monad.State
import Text.Printf
Идея состоит в том, чтобы вводить аргументы по одному в printf
, чтобы получить отформатированный String
, затем взять его и передать егодействие, которое нам дали в начале.
gprint :: GPrintType a => (String -> EndResult a) -> String -> a
gprint f s = gprint' f (printf s)
class PrintfType (Printf a) => GPrintType a where
type Printf a :: *
type EndResult a :: *
gprint' :: (String -> EndResult a) -> Printf a -> a
Рекурсивный шаг принимает аргумент и передает его на вызов printf
, который мы строим в g
.
instance (PrintfArg a, GPrintType b) => GPrintType (a -> b) where
type Printf (a -> b) = a -> Printf b
type EndResult (a -> b) = EndResult b
gprint' f g x = gprint' f (g x)
Базовые случаи просто передают полученную строку в f
:
instance GPrintType (IO a) where
type Printf (IO a) = String
type EndResult (IO a) = IO a
gprint' f x = f x
instance GPrintType (StateT s m a) where
type Printf (StateT s m a) = String
type EndResult (StateT s m a) = StateT s m a
gprint' f x = f x
Вот тестовая программа, которую я использовал:
put_debug, put_err :: String -> IO ()
put_foo :: Monad m => String -> StateT [String] m ()
put_debug = putStrLn . ("DEBUG: " ++)
put_err = putStrLn . ("ERR: " ++)
put_foo x = modify (++ [x])
pdebug = gprint put_debug
perr = gprint put_err
pfoo = gprint put_foo
main = do
pdebug "Hi"
pdebug "my value: %d" 1
pdebug "two values: %d, %d" 1 2
perr "ouch"
execStateT (pfoo "one value: %d" 42) [] >>= print
И вывод:
DEBUG: Hi
DEBUG: my value: 1
DEBUG: two values: 1, 2
ERR: ouch
["one value: 42"]