module Text.Printf.Mauke.TH (printf) where
import Text.Printf.Mauke.Internal
import Data.Char
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BL
import Language.Haskell.TH
printf :: String -> ExpQ
printf fmt = do
ps <- params fmt
gen [| vprintf fmt |] ps id
data PType = I | C | S | F | X
deriving (Eq, Ord, Show, Read)
params :: String -> Q [PType]
params "" = return []
params ('%' : cs) = case dropWhile (`elem` " +-0#") cs of
'*' : 'v' : cs' -> fmap (S :) $ step1 True cs'
'v' : cs' -> step1 True cs'
cs' -> step1 False cs'
where
step1 mt xs = case xs of
'*' : xs' -> fmap (I :) $ step2 mt xs'
xs' -> step2 mt (dropWhile isDigit xs')
step2 mt xs = case xs of
'.' : '*' : xs' -> fmap (I :) $ step3 mt xs'
'.' : xs' -> step3 mt (dropWhile isDigit xs')
_ -> step3 mt xs
step3 mt xs = case xs of
"" -> fail "unterminated formatting directive"
'%' : xs' -> params xs'
x : xs'
| x == 'c' -> fmap ((if mt then S else C) :) $ params xs'
| x `elem` "duoOxXbB" -> fmap ((if mt then S else I) :) $ params xs'
| x == '_' -> fmap ((if mt then S else X) :) $ params xs'
| x == 's' ->
if mt
then fail "v flag invalid for %s"
else fmap (S :) $ params xs'
| x `elem` "eEfFgG" ->
if mt
then fail $ "v flag invalid for %" ++ [x]
else fmap (F :) $ params xs'
| otherwise -> fail $ "invalid format specifier: " ++ show x
params (_ : xs) = params xs
gen :: ExpQ -> [PType] -> (ExpQ -> ExpQ) -> ExpQ
gen z [] = \f -> [| $z $(f [| [] |]) |]
gen z (x : xs) = let g = gen z xs in \f -> [| \a -> $(g (\as -> f [| $(tembed x) a : $as |])) |]
tembed :: PType -> ExpQ
tembed t = case t of
I -> [| AInt . toInteger |]
C -> [| AChar |]
S -> [| AStr . toString |]
F -> [| AFloat . realToFrac |]
X -> [| embed |]
class ToString a where
toString :: a -> String
instance (ToChar a) => ToString [a] where
toString = map toChar
instance ToString BS.ByteString where
toString = BS.unpack
instance ToString BL.ByteString where
toString = BL.unpack