th-printf 0.3.1 → 0.4.0

raw patch · 10 files changed

+769/−374 lines, 10 filesdep +ansi-wl-pprintdep +charsetdep +containersdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: ansi-wl-pprint, charset, containers, criterion, trifecta, utf8-string

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• benchmark/benchmark.hs +17/−0
• src/NumericUtils.hs +22/−0
• src/Text/Printf/TH.hs +185/−285
• src/Text/Printf/TH/Parser.hs +51/−0
• src/Text/Printf/TH/Printer.hs +181/−0
• src/Text/Printf/TH/Printer/String.hs +45/−0
• src/Text/Printf/TH/Types.hs +84/−0
• tests/Codegen.hs +114/−0
• tests/format.hs +10/−59
• th-printf.cabal +60/−30

@@ -0,0 +1,17 @@+{-# Language QuasiQuotes #-}++module Main+    ( main+    ) where++import Criterion+import Criterion.Main+import Text.Printf.TH++main :: IO ()+main =+    defaultMain+        [ env (pure ([s|test %50s|], [st|test %50s|])) $ \ ~(fs, ft) ->+              bgroup "string" [bench "s" $ nf fs "foobar", bench "st" $ nf ft "foobar"]+        , bgroup "int" [bench "s" $ nf [s|%010d|] 20, bench "st" $ nf [st|%010d|] 20]+        ]

@@ -0,0 +1,22 @@+{-# Language MagicHash #-}+module NumericUtils (module NumericUtils, intToDigit) where++import Data.Char+import GHC.Base+import Text.Printf.TH.Printer++intToDigitUpper :: Int -> Char+intToDigitUpper (I# i)+    | isTrue# (i >=# 0#)  && isTrue# (i <=#  9#) = unsafeChr (ord '0' + I# i)+    | isTrue# (i >=# 10#) && isTrue# (i <=# 15#) = unsafeChr (ord 'A' + I# i - 10)+    | otherwise =  error ("Char.intToDigit: not a digit " ++ show (I# i))++showIntAtBase :: (Integral i, Monoid b, Printer b) => i -> (Int -> Char) -> i -> b+showIntAtBase base toB n0 = showIt (quotRem n0 base) mempty+  where+    showIt (n, d) r =+        case n of+            0 -> r'+            _ -> showIt (quotRem n base) r'+      where+        r' = cons (toB $ fromIntegral d) r

@@ -1,303 +1,203 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE QuasiQuotes #-}+{-# Language CPP #-}+{-# Language DeriveDataTypeable #-}+{-# Language FlexibleInstances #-}+{-# Language QuasiQuotes #-}+{-# Language RecordWildCards #-}+{-# Language ScopedTypeVariables #-}+{-# Language TemplateHaskell #-}+{-# Language TupleSections #-} -module Text.Printf.TH (s, st, lt, sb, lb, sP, stP, ltP, sbP, lbP) where+module Text.Printf.TH+    ( -- * Formatting strings+      s+    , st+    , sb+      -- * Printing strings+    , hp+    , p+    ) where -import Control.Applicative+import Control.Exception (Exception, throw) import Control.Monad.IO.Class-import Data.Attoparsec.Text hiding (space)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as LB-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Lazy.Char8 as LB8-import Data.Char hiding (Space)-import Data.Data+import Data.ByteString.UTF8 (fromString) import Data.Maybe-import Data.Monoid-import Data.String-import Data.Text (pack, unpack)-import qualified Data.Text as T-import qualified Data.Text.IO as T-import qualified Data.Text.Lazy as LT-import qualified Data.Text.Lazy.IO as LT-import Data.Word+import Data.Proxy (Proxy(..))+import Data.Text (pack) import Language.Haskell.TH import Language.Haskell.TH.Quote-import Numeric-import Prelude hiding (lex)-import Text.ParserCombinators.ReadP (readP_to_S)-import Text.Read.Lex--data Specifier = SignedDec | Octal | UnsignedHex | UnsignedHexUpper-               | FloatS | FloatUpper | Sci | SciUpper | ShorterFloat | ShorterFloatUpper-               | CharS | Str | Percent | Showable deriving (Eq, Show, Data, Typeable)--data Flag = Minus | Plus | Space | Hash | Zero deriving (Eq, Show, Data, Typeable)--data Width = Width Integer | WidthStar deriving (Data, Show, Typeable, Eq)--data Precision = Precision Integer | PrecisionStar deriving (Data, Show, Typeable, Eq)--data Chunk = Chunk-           { flags :: [Flag]-           , width :: Maybe Width-           , precision :: Maybe Precision-           , spec :: Specifier-           } | Plain String-           deriving (Data, Show, Typeable)--quoterOfType :: Name -> Bool -> QuasiQuoter-quoterOfType m b = QuasiQuoter-                 { quoteExp = \s' -> let lexed = readP_to_S lex $ '"' : concatMap escape s' ++ "\""-                                         escape '"' = "\\\""-                                         escape m' = [m']-                                     in case lexed of-                        [(String str,"")] -> case parseOnly formatP (pack str) of-                            Right r -> chunksToFormatter r m b-                            Left m' -> error $ "Error when parsing format string: " ++ show m'-                        _ -> error "Error when parsing format string"-                 , quotePat = error "printf cannot be used in pattern context"-                 , quoteType = error "printf cannot be used in type context"-                 , quoteDec = error "printf cannot be used in declaration context"-                 }--s, st, lt, sb, lb, sP, stP, ltP, sbP, lbP :: QuasiQuoter--s = quoterOfType ''String False-st = quoterOfType ''T.Text False-lt = quoterOfType ''LT.Text False-sb = quoterOfType ''B.ByteString False-lb = quoterOfType ''LB.ByteString False-sP = quoterOfType ''String True-stP = quoterOfType ''T.Text True-ltP = quoterOfType ''LT.Text True-sbP = quoterOfType ''B.ByteString True-lbP = quoterOfType ''LB.ByteString True--formatP :: Parser [Chunk]-formatP = many1 ( char '%' *> chunkP-              <|> fmap (Plain . unpack) (takeWhile1 (/= '%')) )-              <* endOfInput--chunkP :: Parser Chunk-chunkP = do-    f <- many flagP-    w <- option Nothing (Just <$> widthP)-    p <- option Nothing (Just <$> precisionP)-    m <- specP-    return $ Chunk f w p m--flagP :: Parser Flag-flagP = Minus <$ char '-'-    <|> Plus <$ char '+'-    <|> Space <$ char ' '-    <|> Hash <$ char '#'-    <|> Zero <$ char '0'--widthP :: Parser Width-widthP = ( Width <$> decimal-       <|> WidthStar <$ char '*' )--precisionP :: Parser Precision-precisionP = char '.' *> ( Precision <$> decimal-                       <|> PrecisionStar <$ char '*' )--specP :: Parser Specifier-specP = SignedDec <$ (char 'd' <|> char 'i')-    <|> Octal <$ char 'o'-    <|> UnsignedHex <$ char 'x'-    <|> UnsignedHexUpper <$ char 'X'-    <|> FloatS <$ char 'f'-    <|> FloatUpper <$ char 'F'-    <|> Sci <$ char 'e'-    <|> SciUpper <$ char 'E'-    <|> ShorterFloat <$ char 'g'-    <|> ShorterFloatUpper <$ char 'G'-    <|> CharS <$ char 'c'-    <|> Str <$ char 's'-    <|> Percent <$ char '%'-    <|> Showable <$ char '?'--data PrintfArg = PrintfArg-               { paSpec :: Chunk-               , widthArg :: Maybe Name-               , precArg :: Maybe Name-               , valArg :: Maybe Name-               } deriving Show--collectArgs :: PrintfArg -> [PatQ]-collectArgs (PrintfArg _ n1 n2 n3) = map varP $ catMaybes [n1, n2, n3]--chunksToFormatter :: [Chunk] -> Name -> Bool -> ExpQ-chunksToFormatter cs ty pr = do-    ns <- mapM argify cs-    let processor = if pr then [e|output|] else [e|id|]-    lamE (concatMap collectArgs ns) [e|$(processor) (mconcat $(listE $ map arg ns) :: $(conT ty))|]-    where-        argify p@Plain{} = return $ PrintfArg p Nothing Nothing Nothing-        argify c@Chunk{spec = Percent} = return $ PrintfArg c Nothing Nothing Nothing-        argify c@Chunk{width = w, precision = p} = do-            wa <- if w == Just WidthStar-                      then Just <$> newName "a"-                      else return Nothing-            pa <- if p == Just PrecisionStar-                      then Just <$> newName "a"-                      else return Nothing-            q' <- newName "a"-            return $ PrintfArg c wa pa (Just q')--q :: Data a => a -> Q Exp-q = dataToExpQ (const Nothing)--arg :: PrintfArg -> ExpQ-arg PrintfArg{paSpec = Plain str} = stringE str-arg PrintfArg{paSpec = Chunk{spec = Percent}} = stringE "%"-arg c@PrintfArg{valArg = Just v} = (\n -> dispatch n c v) $-    case spec $ paSpec c of-        SignedDec -> 'showIntegral-        Octal -> 'showOctal-        UnsignedHex -> 'showHexP-        UnsignedHexUpper -> 'showUpperHex-        FloatS -> 'showFloatP-        FloatUpper -> 'showUpperFloat-        Sci -> 'showSci-        SciUpper -> 'showUpperSci-        ShorterFloat -> 'showShorter-        ShorterFloatUpper -> 'showUpperShorter-        CharS -> 'showCharP-        Str -> 'showStringP-        Showable -> 'showShowP-        m -> error $ "Unhandled specifier: " ++ show m-arg m = error $ "Unhandled argument: " ++ show m--dispatch :: Name -> PrintfArg -> Name -> ExpQ-dispatch s' n v = appE (varE 'fromString)-    $ foldl1 appE [ varE s'-                  , q $ paSpec n-                  , normalize True (widthArg n)-                  , normalize False (precArg n)-                  , varE v ]-    where-        normalize b v' = case v' of-            Nothing -> litE . integerL $ if b then calcWidth $ paSpec n else calcPrec $ paSpec n-            Just q' -> varE q'--showIntegralBasic :: Chunk -- ^ options-                  -> Integer -- ^ width-                  -> Bool -- ^ less than 0?-                  -> String -- ^ prefix-                  -> String -- ^ value-                  -> String-showIntegralBasic c w b pre n = space c . plus b c . prefix pre c . pad w c $ n--showIntegral :: (Show a, Integral a) => Chunk -> Integer -> Integer -> a -> String-showIntegral pa w _ n = showIntegralBasic pa w (n >= 0) "" $ show n--showOctal :: (Show a, Integral a) => Chunk -> Integer -> Integer -> a -> String-showOctal pa w _ n = showIntegralBasic pa w (n >= 0) "0" $ showOct n ""--showHexP :: (Show a, Integral a) => Chunk -> Integer -> Integer -> a -> String-showHexP pa w _ n = showIntegralBasic pa w (n >= 0) "0x" $ showHex n ""--showUpperHex :: (Show a, Integral a) => Chunk -> Integer -> Integer -> a -> String-showUpperHex pa w _ n = showIntegralBasic pa w (n >= 0) "0X" . map toUpper $ showHex n ""--showFloatP :: RealFloat a => Chunk -> Integer -> Integer -> a -> String-showFloatP pa w pr n = plus (n >= 0) pa-                     . padDelim '.' w pa-                     $ showFFloat (if pr < 0 then Nothing else Just $ fromIntegral pr) n ""--showUpperFloat :: RealFloat a => Chunk -> Integer -> Integer -> a -> String-showUpperFloat pa w pr n = map toUpper $ showFloatP pa w pr n--showSci :: RealFloat a => Chunk -> Integer -> Integer -> a -> String-showSci pa w pr n = plus (n >= 0) pa-                  . padDelim '.' w pa-                  $ showEFloat (if pr < 0 then Nothing else Just $ fromIntegral pr) n ""--showUpperSci :: RealFloat a => Chunk -> Integer -> Integer -> a -> String-showUpperSci pa w pr n = map toUpper $ showSci pa w pr n--showShorter :: RealFloat a => Chunk -> Integer -> Integer -> a -> String-showShorter pa w pr n = if length f > length e then e else f-    where f = showFloatP pa w pr n-          e = showSci pa w pr n--showUpperShorter :: RealFloat a => Chunk -> Integer -> Integer -> a -> String-showUpperShorter pa w pr n = if length f > length e then e else f-    where f = showUpperFloat pa w pr n-          e = showUpperSci pa w pr n--showCharP :: ToChar a => Chunk -> Integer -> Integer -> a -> String-showCharP _ _ _ c = [asChar c]--showStringP :: ToString a => Chunk -> Integer -> Integer -> a -> String-showStringP pa w _ n = space pa . pad w pa $ toString n--showShowP :: Show a => Chunk -> Integer -> Integer -> a -> String-showShowP pa w _ n = space pa . pad w pa $ show n--space :: Chunk -> String -> String-space c = if Space `elem` flags c && Plus `notElem` flags c then (' ':) else id+import Language.Haskell.TH.Syntax+import System.IO+import Text.PrettyPrint.ANSI.Leijen as Pretty hiding ((<$>), (<>), empty, line)+import Text.Trifecta -plus :: Bool -> Chunk -> String -> String-plus b c = if Plus `elem` flags c-               then if b then ('+':) else ('-':)-               else id+import Text.Printf.TH.Parser+import Text.Printf.TH.Printer+import Text.Printf.TH.Printer.String ()+import Text.Printf.TH.Types -prefix :: String -> Chunk -> String -> String-prefix s' p = if Hash `elem` flags p then (s' ++) else id+data ParseError =+    ParseError+    deriving (Show) -padDelim :: Integral a => Char -> a -> Chunk -> String -> String-padDelim c w pa s' = a (replicate (fromIntegral w - len) c') s'-    where len = length $ Prelude.takeWhile (/=c) s'-          a = if Minus `elem` flags pa-                  then flip (++)-                  else (++)-          c' = if Zero `elem` flags pa-                  then '0'-                  else ' '+instance Exception ParseError -pad :: Integral a => a -> Chunk -> String -> String-pad w pa s' = a (replicate (fromIntegral w - length s') c) s'-    where a = if Minus `elem` flags pa-                  then flip (++)-                  else (++)-          c = if Zero `elem` flags pa-                  then '0'-                  else ' '+-- * Formatting strings+-- | @+-- ['s'|Hello, %s! (%d people greeted)|] :: ... -> String+-- @+--+-- This formatter follows the guidelines listed+-- <http://www.cplusplus.com/reference/cstdio/printf/ here>, with some+-- caveats:+--+-- * Hexadecimal floating point isn't supported. I'm not convinced anyone+-- actually uses this and there doesn't appear to be anything in @base@ to+-- produce it.+-- * @%p@ (pointer) and @%n@ (store number of printed characters) are not supported+-- for obvious reasons.+-- * @%.0e@ shows at least one decimal place despite this special case+-- not appearing anywhere in the spec. This is a bug in 'Text.Printf.formatRealFloat'.+-- As a result, @%e@ and @%#e@ have identical behavior.+--+-- @+-- %c     :: 'Char'+-- %s     :: 'String'+--+-- %?     :: 'Show' a => a+--+-- %u     :: 'GHC.Natural.Natural'+--+-- %d, %i :: 'Integral' i => i+-- %o     :: 'Integral' i => i+-- %x, %X :: 'Integral' i => i+--+-- %e, %E :: 'RealFloat' f => f+-- %f, %F :: 'RealFloat' f => f+-- %g, %G :: 'RealFloat' f => f+-- @+s :: QuasiQuoter+s = quoter 'id -calcWidth :: Chunk -> Integer-calcWidth (Chunk _ (Just (Width n)) _ _) = n-calcWidth _ = -1+-- | @+-- ['st'|Hello, %s! (%d people greeted)|] :: ... -> 'Data.Text.Text'+-- @+st :: QuasiQuoter+st = quoter 'pack -calcPrec :: Chunk -> Integer-calcPrec (Chunk _ _ (Just (Precision n)) _) = n-calcPrec _ = -1+-- | @+-- ['sb'|Hello, %s! (%d people greeted)|] :: ... -> 'Data.ByteString.ByteString'+-- @+--+-- The resulting string is UTF8-encoded.+sb :: QuasiQuoter+sb = quoter 'fromString -class ToString a where toString :: a -> String+-- | @+-- ['hp'|Hello, %s! (%d people greeted)|] :: 'MonadIO' m => 'Handle' -> ... -> m ()+-- @+--+-- Prints the produced string to the provided 'Handle'. Like C printf, newline is not+-- appended.+hp :: QuasiQuoter+hp =+    QuasiQuoter+        { quoteExp =+              \s -> do+                  LamE pats body <- parse 'id s+                  arg <- newName "arg"+                  ps <- [|liftIO . hPutStr $(varE arg)|]+                  pure $ LamE ((VarP arg) : pats) $ AppE ps body+        , quotePat = error "printf cannot be used in a pattern context"+        , quoteType = error "printf cannot be used in a type context"+        , quoteDec = error "printf cannot be used in a decl context"+        } -instance ToChar a => ToString [a] where toString = map asChar-instance ToString T.Text where toString = T.unpack-instance ToString LT.Text where toString = LT.unpack-instance ToString B.ByteString where toString = map asChar . B.unpack-instance ToString LB.ByteString where toString = map asChar . LB.unpack+-- | @+-- ['p'|Hello, %s! (%d people greeted)|] :: 'MonadIO' m => ... -> m ()+-- @+--+-- @+-- [p|...|] arg1 arg2...+-- @+--+-- is equivalent to+--+-- @+-- [hp|...|] 'System.IO.stdout' arg1 arg2...+-- @+p :: QuasiQuoter+p =+    QuasiQuoter+        { quoteExp =+              \s -> do+                  LamE pats body <- parse 'id s+                  ps <- [|liftIO . putStr|]+                  pure $ LamE pats $ AppE ps body+        , quotePat = error "printf cannot be used in a pattern context"+        , quoteType = error "printf cannot be used in a type context"+        , quoteDec = error "printf cannot be used in a decl context"+        } -class ToChar m where asChar :: m -> Char+quoter f =+    QuasiQuoter+        { quoteExp = parse f+        , quotePat = error "printf cannot be used in a pattern context"+        , quoteType = error "printf cannot be used in a type context"+        , quoteDec = error "printf cannot be used in a decl context"+        } -instance ToChar Char where asChar = id-instance ToChar Int where asChar = chr-instance ToChar Word8 where asChar = chr . fromIntegral+parse f s =+    case parseString parseFmtStr mempty s of+        Success fmtStr -> build f ''String fmtStr+        Failure xs -> do+            runIO $ displayIO stderr $ renderPretty 0.8 80 $ _errDoc xs+            throw ParseError -class Printable a where output :: MonadIO m => a -> m ()+build f outputType fmtStr = do+    pairs <- mapM mkExpr fmtStr+    let (args, exprs) = unzip pairs+    lamE (map varP $ concat args) $+        appE (varE f) $+        appsE [[|finalize|], [|Proxy :: Proxy $(conT outputType)|], listE exprs] -instance Printable String where output = liftIO . putStrLn-instance Printable T.Text where output = liftIO . T.putStrLn-instance Printable LT.Text where output = liftIO . LT.putStrLn-instance Printable B.ByteString where output = liftIO . B8.putStrLn-instance Printable LB.ByteString where output = liftIO . LB8.putStrLn+mkExpr (Str s) = pure ([] :: [Name], [|valOf (literal $(stringE s))|])+mkExpr (Arg (FormatArg flags width precision spec)) = do+    (warg, wexp) <- extractArgs width+    (parg, pexp) <- extractArgs precision+    varg <- newName "arg"+    pure+        ( catMaybes [warg, parg, Just varg]+        , appE+              formatter+              [|ArgSpec+                    { flagSet = $(lift flags)+                    , width = $(wexp)+                    , prec = $(pexp)+                    , value = $(varE varg)+                    }|])+  where+    extractArgs n =+        case n of+            Just Need -> do+                a <- newName "arg"+                pure (Just a, [|Just $(varE a)|])+            Just (Given n) -> pure (Nothing, [|Just $(litE $ integerL n)|])+            Nothing -> pure (Nothing, [|Nothing|])+    formatter =+        case spec of+            x+                | x `elem` "id" -> [|formatDec|]+            'u' -> [|formatNat|]+            'o' -> [|formatOct|]+            'x' -> [|formatHex|]+            'X' -> [|formatHexUpper|]+            's' -> [|formatStr|]+            'f' -> [|formatFloat|]+            'F' -> [|formatFloat|]+            'e' -> [|formatSci|]+            'E' -> [|formatSciUpper|]+            'g' -> [|formatG|]+            'G' -> [|formatGUpper|]+            'c' -> [|formatChar|]+            '?' -> [|formatShowable|]+            _ -> error "???"

@@ -0,0 +1,51 @@+{-# Language NoMonomorphismRestriction #-}++module Text.Printf.TH.Parser where++import Control.Applicative+import Data.CharSet (fromList)+import Text.Trifecta+import qualified Data.Set as S++import Text.Printf.TH.Types++flagSet = fromList "-+ #0"++specSet = fromList "diuoxXfFeEgGcs?"++parseFmtStr = do+    atoms <-+        many $+        choice [Str "%" <$ string "%%", Arg <$> fmtArg, Str . return <$> noneOf "%"]+    return $ go atoms+  where+    go (Str s:Str s1:as) = go (Str (s ++ s1) : as)+    go (a:as) = a : go as+    go [] = []++fmtArg = do+    char '%'+    flags <-+        do fs <-+               many $ do+                   c <- oneOfSet flagSet <?> "flag"+                   pure $+                       case c of+                           '-' -> FlagLJust+                           '+' -> FlagSigned+                           ' ' -> FlagSpaced+                           '#' -> FlagPrefixed+                           '0' -> FlagZeroPadded+                           _ -> error "???"+           let flagSet = S.fromList fs+           if S.size flagSet < length fs+               then fail "Duplicate flags specified"+               else pure $ toFlagSet flagSet+    width <- optional $ choice [Given <$> natural, Need <$ char '*'] <?> "width"+    precision <-+        optional $+        (do char '.'+            choice [Given <$> natural, Need <$ char '*']) <?>+        "precision"+    spec <- oneOfSet specSet <?> "valid specifier"+    pure $ FormatArg flags width precision spec

@@ -0,0 +1,181 @@+{-# Language RecordWildCards #-}+{-# Language DefaultSignatures #-}+{-# Language OverloadedStrings #-}+{-# Language NamedFieldPuns #-}+{-# Language FlexibleContexts #-}+{-# Language FlexibleInstances #-}+{-# Language TypeSynonymInstances #-}+{-# Language TypeFamilies #-}++module Text.Printf.TH.Printer where++import Control.Monad.Fix+import Data.Monoid+import Data.String+import Numeric.Natural+import Text.ParserCombinators.ReadP (readP_to_S)+import Text.Printf.TH.Types+import Text.Read.Lex++class (IsString a, Monoid a) =>+      Printer a+    where+    type Output a+    string :: String -> a+    cons :: Char -> a -> a+    cons c = (formatChar' c <>)+    rjust :: Char -> Int -> a -> a+    ljust :: Int -> a -> a+    output :: proxy a -> a -> Output a+    formatChar' :: Char -> a+    formatDec' :: Integral i => i -> a+    formatOct' :: Integral i => i -> a+    formatHex' :: Integral i => i -> a+    formatHexUpper' :: Integral i => i -> a+    formatFloat' :: RealFloat f => Maybe Int -> (f -> a, f -> a)+    formatSci' :: RealFloat f => Maybe Int -> f -> a+    formatSciUpper' :: RealFloat f => Maybe Int -> f -> a+    formatG' :: RealFloat f => Maybe Int -> (f -> a, f -> a)+    formatGUpper' :: RealFloat f => Maybe Int -> (f -> a, f -> a)++data ArgSpec v = ArgSpec+    { flagSet :: FlagSet+    , width :: Maybe Int+    , prec :: Maybe Int+    , value :: v+    }++data Direction+    = Leftward+    | Rightward+    deriving (Show)++data Pad+    = Space+    | Zero+    deriving (Eq, Show)++data Val v = Val+    { valLit :: v+    , valWidth :: Maybe Int+    , valPrefix :: Maybe (Int, v)+    , valSign :: Maybe (Int, v)+    , valPad :: Pad+    , valDirection :: Direction+    } deriving (Show)++valOf x =+    Val+        { valLit = x+        , valWidth = Nothing+        , valPrefix = Nothing+        , valSign = Nothing+        , valPad = Space+        , valDirection = Rightward+        }++valSign' = maybe mempty snd . valSign++valPrefix' = maybe mempty snd . valPrefix++setSign x v = v {valSign = Just $ fmap literal x}++setPrefix x v = v {valPrefix = Just $ fmap literal x}++setRightAligned v = v {valDirection = Rightward}++setLeftAligned v = v {valDirection = Leftward}++setWidth n v = v {valWidth = Just n}++setWidth' n v = v {valWidth = n}++setZero v = v {valPad = Zero}++instance Functor ArgSpec where+    fmap f a@(ArgSpec {value}) = a {value = f value}++adjust (ArgSpec flags width _ _) =+    setWidth' width .+    case adjustment flags of+        Nothing -> id+        Just LeftJustified -> setLeftAligned+        Just ZeroPadded -> setZero++helper :: (Num a, Eq a, Printer p) => (a -> p) -> String -> ArgSpec a -> Val p+helper f pref spec = adjustAndSign pref spec $ valOf $ f (abs $ value spec)++adjustAndSign :: (Num n, Printer a, Eq n) => String -> ArgSpec n -> Val a -> Val a+adjustAndSign pref (ArgSpec flags width _ num) =+    adj . setWidth' width . sign flags num . prefix pref flags num+  where+    adj =+        case adjustment flags of+            Nothing -> id+            Just LeftJustified -> setLeftAligned+            Just ZeroPadded -> setZero++prefix _ _ 0 = id+prefix s flags _+    | prefixed flags = setPrefix (length s, s)+    | otherwise = id++sign flags n+    | signum n == -1 = setSign (1, "-")+    | spaced flags = setSign (1, " ")+    | signed flags = setSign (1, "+")+    | otherwise = id++formatDec = helper formatDec' ""++formatOct = helper formatOct' "0"++formatHex = helper formatHex' "0x"++formatHexUpper = helper formatHexUpper' "0X"++helper' spec pair+    | prefixed (flagSet spec) = helper (snd pair) "" spec+    | otherwise = helper (fst pair) "" spec++formatFloat spec = helper' spec (formatFloat' (prec spec))++formatSci spec = helper (formatSci' (prec spec)) "" spec++formatSciUpper spec = helper (formatSciUpper' (prec spec)) "" spec++formatG spec = helper' spec (formatG' (prec spec))++formatGUpper spec = helper' spec (formatGUpper' (prec spec))++formatNat = formatDec . fmap (fromIntegral :: Natural -> Integer)++fOne v@(Val {valWidth = Nothing, ..}) = mconcat [valSign' v, valPrefix' v, valLit]+fOne v@(Val {valWidth = Just n, valDirection = Rightward, ..}) =+    if valPad == Zero+        then mconcat+                 [ maybe mempty snd valSign+                 , maybe mempty snd valPrefix+                 , rjust '0' (n - extra) valLit+                 ]+        else rjust ' ' n $ fOne (v {valWidth = Nothing})+  where+    extra = maybe 0 fst valPrefix + maybe 0 fst valSign+fOne v@(Val {valWidth = Just n, valDirection = Leftward, ..}) =+    ljust n $ fOne (v {valWidth = Nothing})++finalize p = foldMap (output p . fOne)++formatStr spec = adjust spec $ valOf $ literal (value spec)++formatChar spec = adjust spec $ valOf $ formatChar' (value spec)++literal x+    | '\\' `elem` x =+        (`fix` x) $ \f s ->+            case readP_to_S lexChar s of+                ((c, rest):_) -> cons c (f rest)+                [] -> mempty+    | otherwise = string x++formatShowable spec = adjust spec $ valOf $ literal (show $ value spec)

@@ -0,0 +1,45 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# Language FlexibleContexts #-}+{-# Language RecordWildCards #-}+{-# Language TypeSynonymInstances #-}+{-# Language TypeFamilies #-}+{-# Language FlexibleInstances #-}++module Text.Printf.TH.Printer.String where++import Data.Char (toUpper)+import Numeric hiding (showIntAtBase)+import NumericUtils+import Text.Printf.TH.Printer++instance Printer String where+    type Output String = String+    string = id+    formatChar' = pure+    cons = (:)+    output _ = id+    rjust c n s+        | diff <= 0 = s+        | otherwise = replicate diff c ++ s+      where+        diff = fromIntegral n - length s+    ljust n s+        | diff <= 0 = s+        | otherwise = s ++ replicate diff ' '+      where+        diff = fromIntegral n - length s+    formatDec' = showIntAtBase 10 intToDigit+    formatOct' = showIntAtBase 8 intToDigit+    formatHex' = showIntAtBase 16 intToDigit+    formatHexUpper' = showIntAtBase 16 intToDigitUpper+    formatFloat' p =+        ( \n -> showFFloat (fromIntegral <$> p) n ""+        , \n -> showFFloatAlt (fromIntegral <$> p) n "")+    formatSci' p n = showEFloat (fromIntegral <$> p) n ""+    formatSciUpper' p = map toUpper . formatSci' p+    formatG' p =+        ( \n -> showGFloat (fromIntegral <$> p) n ""+        , \n -> showGFloatAlt (fromIntegral <$> p) n "")+    formatGUpper' p = both (map toUpper .) (formatG' p)+      where+        both f (x, y) = (f x, f y)

@@ -0,0 +1,84 @@+{-# Language TemplateHaskell #-}+{-# Language NamedFieldPuns #-}++module Text.Printf.TH.Types where++import qualified Data.Set as S+import Data.Set (Set)+import Language.Haskell.TH.Syntax++data Atom+    = Arg FormatArg+    | Str String+    deriving (Show)++data Flag+    = FlagLJust+    | FlagSigned+    | FlagSpaced+    | FlagPrefixed+    | FlagZeroPadded+    deriving (Show, Eq, Ord)++adjustmentFlags = S.fromList [FlagLJust, FlagZeroPadded]++data Adjustment+    = LeftJustified+    | ZeroPadded+    deriving (Show)++data MaySpecify+    = Given Integer+    | Need+    deriving (Show)++data FormatArg = FormatArg+    { flags :: FlagSet+    , width :: Maybe MaySpecify+    , precision :: Maybe MaySpecify+    , spec :: Char+    } deriving (Show)++type FormatStr = [Atom]++instance Lift FlagSet where+    lift (FlagSet a s b p) =+        [|FlagSet+              { adjustment = $(a')+              , signed = $(lift s)+              , spaced = $(lift b)+              , prefixed = $(lift p)+              }|]+      where+        a' =+            case a of+                Just LeftJustified -> [|Just LeftJustified|]+                Just ZeroPadded -> [|Just ZeroPadded|]+                Nothing -> [|Nothing|]++data FlagSet = FlagSet+    { adjustment :: Maybe Adjustment+    , signed :: Bool+    , spaced :: Bool+    , prefixed :: Bool+    } deriving (Show)++toFlagSet :: Set Flag -> FlagSet+toFlagSet fs+    | S.size (S.intersection fs adjustmentFlags) > 1 =+        error+            "Error: multiple adjustment flags specified; you can only have one of '-', '0', ' '"+    | spaced set && signed set = error "'+' and ' ' specifiers cannot be used together"+    | otherwise = set+  where+    adjustment+        | FlagLJust `S.member` fs = Just LeftJustified+        | FlagZeroPadded `S.member` fs = Just ZeroPadded+        | otherwise = Nothing+    set =+        FlagSet+            { signed = FlagSigned `elem` fs+            , prefixed = FlagPrefixed `elem` fs+            , adjustment+            , spaced = FlagSpaced `elem` fs+            }

@@ -0,0 +1,114 @@+{-# Language TemplateHaskell #-}++module Codegen+    ( gen+    , str+    ) where++import Language.Haskell.TH.Lib+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax (Name)+import Test.HUnit.Base+import Test.Hspec+import Test.QuickCheck++str :: Gen String+str = do+    n <- elements [7 .. 20]+    vectorOf n (elements $ ['A' .. 'Z'] ++ ['a' .. 'z'])++gen :: String -> Name -> QuasiQuoter -> ExpQ+gen name f quoter =+    [|describe $(stringE name) $ do+          describe "string" $ do+              it "basic" $ do+                  $(q "\\1234") @?= "\1234"+                  $(q "\12\&34") @?= "\12\&34"+                  $(q "%s") "foo" @?= "foo"+                  $(q "%10s") "foo" @?= "       foo"+                  $(q "%10s") "fübar" @?= $(varE f) "     fübar"+                  $(q "%-10s") "foo" @?= "foo       "+                  $(q "%010s") "foo" @?= "0000000foo"+              it "precision" $ forAll str $ \n -> $(q "%.10s") n == $(q "%s") n+              it "prefix" $ forAll str $ \n -> $(q "%#s") n == $(q "%s") n+              it "words with format" $ do+                  $(q "This is a string: %10s. It's nice") "foobar" @?=+                      "This is a string:     foobar. It's nice"+          describe "char" $ do+              it "basic" $ do+                  $(q "%c") 'U' @?= "U"+                  $(q "%c") '\65210' @?= $(varE f) "\65210"+                  $(q "%5c") '\65210' @?= $(varE f) "    \65210"+          describe "decimal" $ do+              it "basic" $ do+                  $(q "%d") 20 @?= "20"+                  $(q "%d") (negate 10) @?= "-10"+                  $(q "%10d") 20 @?= "        20"+                  $(q "%10d") (negate 10) @?= "       -10"+                  $(q "%*d") 10 20 @?= "        20"+                  $(q "%*d") 10 (negate 10) @?= "       -10"+                  $(q "%010d") 20 @?= "0000000020"+                  $(q "%010d") (negate 10) @?= "-000000010"+                  $(q "% d") 20 @?= " 20"+                  $(q "% d") (negate 10) @?= "-10"+                  $(q "%+d") 20 @?= "+20"+                  $(q "%+10d") 20 @?= "       +20"+                  $(q "%-10d") 20 @?= "20        "+                  $(q "%-10d") (negate 10) @?= "-10       "+                  $(q "%+-10d") 20 @?= "+20       "+          describe "unsigned" $ do it "basic" $ do $(q "%u") 20 @?= "20"+          describe "octal" $ do+              it "basic" $ do+                  $(q "%o") 1500 @?= "2734"+                  $(q "%o") (negate 1500) @?= "-2734"+              it "prefix" $ do+                  $(q "%#o") 1500 @?= "02734"+                  $(q "%#o") 0 @?= "0"+                  $(q "%#o") (negate 1500) @?= "-02734"+                  $(q "%#010o") 1500 @?= "0000002734"+                  $(q "%#010o") (negate 1500) @?= "-000002734"+                  $(q "%#-10o") (negate 1500) @?= "-02734    "+                  $(q "%#-1o") (negate 1500) @?= "-02734"+          describe "hex" $ do+              it "basic" $ do+                  $(q "%x") 12513024 @?= "beef00"+                  $(q "%X") 12513024 @?= "BEEF00"+              it "prefix" $ do+                  $(q "%#x") 12513024 @?= "0xbeef00"+                  $(q "%#X") 12513024 @?= "0XBEEF00"+                  $(q "%#15x") 12513024 @?= "       0xbeef00"+                  $(q "%#015x") 12513024 @?= "0x0000000beef00"+          describe "float" $ do+              it "basic" $ do+                  $(q "%f") 1234.56 @?= "1234.56"+                  $(q "%f") (negate 1234.56) @?= "-1234.56"+              it "precision" $ do+                  $(q "%.5f") 1234.56 @?= "1234.56000"+                  $(q "%.1f") 1234.56 @?= "1234.6"+                  $(q "%.0f") 1234.56 @?= "1235"+              it "prefix flag" $ do $(q "%#.0f") 1234.56 @?= "1235."+          describe "scientific" $ do+              it "basic" $ do+                  $(q "%e") 1234.56 @?= "1.23456e3"+                  $(q "%e") (negate 1234.56) @?= "-1.23456e3"+                  $(q "%e") 0.00035 @?= "3.5e-4"+                  $(q "%E") 1234.56 @?= "1.23456E3"+              it "precision" $ do+                  $(q "%.5e") 12.34 @?= "1.23400e1"+                  -- GHC's implementation is wrong+                  -- $(q "%.0e") 12.34 @?= "1e1"+                  -- $(q "%#.0e") 12.34 @?= "1.e1"+                  $(q "%15.5e") 12.34 @?= "      1.23400e1"+                  $(q "%+015.5e") 12.34 @?= "+000001.23400e1"+                  $(q "%+-15.5e") 12.34 @?= "+1.23400e1     "+          describe "g-format" $ do+              it "basic" $ do+                  $(q "%g") 1234.56 @?= "1234.56"+                  $(q "%g") 123456789.876 @?= "1.23456789876e8"+                  $(q "%G") 123456789.876 @?= "1.23456789876E8"+                  $(q "%.3g") 1234.56 @?= "1234.560"+                  $(q "%.3g") 123456789.876 @?= "1.235e8"+                  $(q "%.3G") 123456789.876 @?= "1.235E8"+                  $(q "%#g") 1234.56 @?= "1234.56"|]+  where+    q = quoteExp quoter

@@ -1,67 +1,18 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE QuasiQuotes #-}+{-# Language CPP #-}+{-# Language OverloadedStrings #-}+{-# Language TemplateHaskell #-}+{-# Language QuasiQuotes #-} -module Main where+module Main (main) where -import Control.Exception-import Control.Monad+import Codegen import qualified Data.Text as T-import qualified Data.Text.Lazy as LT-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy.Char8 as LB-import Language.Haskell.TH.Quote import Test.Hspec-import Test.HUnit-import Test.QuickCheck import Text.Printf.TH -#if __GLASGOW_HASKELL__ <= 706-instance Eq ErrorCall where-    ErrorCall m == ErrorCall n = m == n-#endif- main :: IO ()-main = hspec $ do-    describe "quoter" $ do-        it "handles escapes properly" $-            [s|\n\STX\\|] @?= "\n\STX\\"--        it "accepts escaped format specifiers" $-            [s|\37\115|] "foo" @?= "foo"--        it "rejects unknown escape sequences" $-            assertException (ErrorCall "Error when parsing format string") . evaluate $ quoteExp s "\\UNKNOWN"--    describe "string substitution" $ do-        it "inserts strings of different types" $-            [s|%s %s %s %s %s %s|] "foo"-                                   (T.pack "foo")-                                   (LT.pack "foo")-                                   (B.pack "foo")-                                   (LB.pack "foo")-                                   [102 :: Int, 111, 111]-              @?= ("foo foo foo foo foo foo" :: String)--        it "pads" $ do-            [s|%10s|] "foo"  @?= "       foo"-            [s|%010s|] "foo" @?= "0000000foo"-            [s|%*s|] 5 "foo" @?= "  foo"--        it "ignores magic hash" $-            forAll str $ \n -> [s|%#s|] n == [s|%s|] n--        it "ignores precision" $-            forAll str $ \n -> [s|%.10s|] n == [s|%s|] n--str :: Gen String-str = do-    n <- elements [7..20]-    vectorOf n (elements ['A'..'z'])--assertException :: (Exception e, Eq e) => e -> IO a -> IO ()-assertException ex action =-    handleJust isWanted (const $ return ()) $ do-        a <- action-        assertFailure $ a `seq` "Expected exception: " ++ show ex-    where isWanted = guard . (==ex)+main =+    hspec $ do+        $(gen "String quoter" 'id s)+        $(gen "Text quoter" 'T.pack st)

@@ -1,34 +1,64 @@-name:                th-printf-version:             0.3.1-synopsis:            Compile-time printf-description:         Quasiquoters for printf: string, bytestring, text.-homepage:            https://github.com/joelteon/th-printf-license:             MIT-license-file:        LICENSE-author:              Joel Taylor-maintainer:          me@joelt.io-category:            Text-build-type:          Simple-cabal-version:       >=1.10--library-  hs-source-dirs:      src-  exposed-modules:     Text.Printf.TH-  build-depends:       base <4.10-                     , attoparsec-                     , bytestring-                     , template-haskell-                     , text-                     , transformers-  default-language:    Haskell2010+name:          th-printf+version:       0.4.0+synopsis:      Compile-time printf+description:   Quasiquoters for printf: string, bytestring, text.+license:       MIT+license-file:  LICENSE+author:        Jude Taylor+maintainer:    me@jude.xyz+category:      Text+homepage:      https://github.com/pikajude/th-printf+build-type:    Simple+cabal-version: >=1.10  source-repository head-  type: git-  location: git://github.com/joelteon/th-printf.git+  type:     git+  location: git://github.com/pikajude/th-printf.git +library+  exposed-modules:    Text.Printf.TH+  other-modules:      NumericUtils+                      Text.Printf.TH.Parser+                      Text.Printf.TH.Printer+                      Text.Printf.TH.Printer.String+                      Text.Printf.TH.Types+  hs-source-dirs:     src+  default-language:   Haskell2010+  default-extensions: NoMonomorphismRestriction+  build-depends:      base             >= 4.8 && < 4.11+                    , ansi-wl-pprint+                    , attoparsec+                    , charset+                    , containers+                    , template-haskell+                    , text+                    , transformers+                    , trifecta+                    , utf8-string+  ghc-options:        -Wall -fno-warn-missing-signatures -fno-warn-name-shadowing+                      -fno-warn-unused-do-bind+ test-suite format-  type: exitcode-stdio-1.0-  main-is: format.hs-  hs-source-dirs: tests-  build-depends: base, bytestring, hspec, HUnit, QuickCheck, template-haskell, text, th-printf-  default-language:    Haskell2010+  type:             exitcode-stdio-1.0+  main-is:          format.hs+  other-modules:    Codegen+  hs-source-dirs:   tests+  default-language: Haskell2010+  build-depends:    base+                  , HUnit+                  , QuickCheck+                  , bytestring+                  , hspec+                  , template-haskell+                  , text+                  , th-printf+  ghc-options:      -Wall -fno-warn-type-defaults++benchmark perf+  type:             exitcode-stdio-1.0+  main-is:          benchmark.hs+  hs-source-dirs:   benchmark+  default-language: Haskell2010+  build-depends:    base, criterion, text, th-printf+  ghc-options:      -O2 -Wall -fno-warn-type-defaults+