Printf.hs

module Jacinda.Backend.Printf ( sprintf ) where

import           A
import qualified Data.ByteString                   as BS
import           Data.ByteString.Builder           (toLazyByteString)
import           Data.ByteString.Builder.RealFloat (doubleDec)
import qualified Data.ByteString.Lazy              as BSL
import           Data.Char                         (isDigit)
import qualified Data.Text                         as T
import           Data.Text.Encoding                (decodeUtf8, encodeUtf8)

sprintf :: BS.ByteString -- ^ Format string
        -> E a
        -> BS.ByteString
sprintf fmt e = encodeUtf8 (sprintf' (decodeUtf8 fmt) e)

pf :: Double -> T.Text
pf = decodeUtf8 . BSL.toStrict . toLazyByteString . doubleDec

pd n x = let (l,r) = T.break (=='.') (pf x) in l <> T.take (n+1) r

data PF = D !(Maybe Int) | I | B | S

{-# SCC next #-}
next :: T.Text -> (T.Text, Maybe (PF, T.Text))
next inp = case T.break (=='%') inp of
    (p, mfmt) | "%i" `T.isPrefixOf` mfmt -> (p, Just (I, T.drop 2 mfmt))
              | "%s" `T.isPrefixOf` mfmt -> (p, Just (S, T.drop 2 mfmt))
              | "%b" `T.isPrefixOf` mfmt -> (p, Just (B, T.drop 2 mfmt))
              | "%f." `T.isPrefixOf` mfmt -> let s=T.drop 3 mfmt in
                    case precision s of
                        Nothing    -> error "Missing digit in format specifier."
                        Just (n,f) -> (p, Just (D (Just n), f))
              | "%f" `T.isPrefixOf` mfmt -> (p, Just (D Nothing, T.drop 2 mfmt))
              | otherwise -> (p, Nothing)

precision :: T.Text -> Maybe (Int, T.Text)
precision t =
    let (n,f) = T.span isDigit t  in
    if T.null n then Nothing else Just (read (T.unpack n), f)

{-# SCC sp #-}
sp :: T.Text -> [E a] -> T.Text
sp t [] = t
sp t (e:es) =
    case (next t, e) of
        ((_, Nothing), _)                             -> error "Argument to sprintf has more values than expected by format string."
        ((p, Just (D Nothing, fmt)), Lit _ (FLit f))  -> p <> pf f <> sp fmt es
        ((p, Just (D (Just n), fmt)), Lit _ (FLit f)) -> p <> pd n f <> sp fmt es
        ((p, Just (B, fmt)), Lit _ (BLit b))          -> p <> showBool b <> sp fmt es
        ((p, Just (I, fmt)), Lit _ (ILit i))          -> p <> T.pack (show i) <> sp fmt es
        ((p, Just (S, fmt)), Lit _ (StrLit bs))       -> p <> decodeUtf8 bs <> sp fmt es
        ((_, Just{}), _)                              -> error "Argument type does not match sprintf format string."

  where
    showBool True = "#t"; showBool False = "#f"

sprintf' :: T.Text -> E a -> T.Text
sprintf' fmt e@Lit{}    = sp fmt [e]
sprintf' fmt (Tup _ es) = sp fmt es