diff --git a/benchmark/benchmark.hs b/benchmark/benchmark.hs new file mode 100644 --- /dev/null +++ b/benchmark/benchmark.hs @@ -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] + ] diff --git a/src/NumericUtils.hs b/src/NumericUtils.hs new file mode 100644 --- /dev/null +++ b/src/NumericUtils.hs @@ -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 diff --git a/src/Text/Printf/TH.hs b/src/Text/Printf/TH.hs --- a/src/Text/Printf/TH.hs +++ b/src/Text/Printf/TH.hs @@ -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 +-- , 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 "???" diff --git a/src/Text/Printf/TH/Parser.hs b/src/Text/Printf/TH/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Text/Printf/TH/Parser.hs @@ -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 diff --git a/src/Text/Printf/TH/Printer.hs b/src/Text/Printf/TH/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Text/Printf/TH/Printer.hs @@ -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) diff --git a/src/Text/Printf/TH/Printer/String.hs b/src/Text/Printf/TH/Printer/String.hs new file mode 100644 --- /dev/null +++ b/src/Text/Printf/TH/Printer/String.hs @@ -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) diff --git a/src/Text/Printf/TH/Types.hs b/src/Text/Printf/TH/Types.hs new file mode 100644 --- /dev/null +++ b/src/Text/Printf/TH/Types.hs @@ -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 + } diff --git a/tests/Codegen.hs b/tests/Codegen.hs new file mode 100644 --- /dev/null +++ b/tests/Codegen.hs @@ -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 diff --git a/tests/format.hs b/tests/format.hs --- a/tests/format.hs +++ b/tests/format.hs @@ -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) diff --git a/th-printf.cabal b/th-printf.cabal --- a/th-printf.cabal +++ b/th-printf.cabal @@ -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 +