{-# LANGUAGE TemplateHaskell #-}

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

-- | A static checking layer on top of 'Text.Printf.Mauke.printf'. It hasn't
-- been tested much, but static argument checking is always a good idea. To use
-- it, add
-- 
-- > {-# LANGUAGE TemplateHaskell #-}
-- >
-- > import Text.Printf.Mauke.TH
-- 
-- at the top of your code and call @$('printf' \"%d %d\") x y@ instead of
-- @'Text.Printf.Mauke.printf' \"%d %d\" x y@.
    
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