th-printf 0.3.1 → 0.8
raw patch · 18 files changed
Files
- CHANGELOG.md +26/−0
- LICENSE +17/−18
- Setup.hs +0/−2
- parser/Parser.hs +143/−0
- parser/Parser/Types.hs +135/−0
- src/Buf.hs +76/−0
- src/Language/Haskell/Printf.hs +110/−0
- src/Language/Haskell/Printf/Geometry.hs +67/−0
- src/Language/Haskell/Printf/Lib.hs +113/−0
- src/Language/Haskell/Printf/Printers.hs +200/−0
- src/Language/Haskell/PrintfArg.hs +29/−0
- src/NumUtils.hs +144/−0
- src/StrUtils.hs +17/−0
- src/Text/Printf/TH.hs +0/−303
- tests/format.hs +0/−67
- tests/printf/GeneratedSpec.hs +450/−0
- tests/printf/format.hs +47/−0
- th-printf.cabal +82/−26
+ CHANGELOG.md view
@@ -0,0 +1,26 @@+## 0.8.0 (2023-07-16)++- Support for base >= 4.15 / GHC 9.+- Dropped support for GHC versions that have no corresponding HLS version.++## 0.7.0 (2019-09-12)++- New `%Q` and `%q` format specifiers accept strict and lazy Text as input+ respectively. Otherwise they function identically to the `%s` specifier.+- th-printf can now produce lazy Text as well as String, and the improved+ internal representation of format strings should slightly increase performance.+ - Directly producing Text should now be significantly faster than using the+ string formatter and `pack`ing the result, especially with Text format arguments.+- Dropped support for GHC < 8.++## 0.6.0 (2018-08-18)++Backported new backpack-based code to pre GHC-8.4 versions.++- Rename of public modules+- Parser rewrite+- th-printf now prints a warning when given an erroneous format string+- Several printf behaviors have been updated to comply with spec:+ - `x`, `u`, etc. specifiers now only apply to positive integers+ - Length specifiers are allowed+- Generated testsuite covers more cases
LICENSE view
@@ -1,21 +1,20 @@-The MIT License (MIT)--Copyright (c) 2013 Joel Taylor+Copyright (c) 2018 Jude Taylor -Permission is hereby granted, free of charge, to any person obtaining a copy-of this software and associated documentation files (the "Software"), to deal-in the Software without restriction, including without limitation the rights-to use, copy, modify, merge, publish, distribute, sublicense, and/or sell-copies of the Software, and to permit persons to whom the Software is-furnished to do so, subject to the following conditions:+Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions: -The above copyright notice and this permission notice shall be included in-all copies or substantial portions of the Software.+The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software. -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR-IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,-FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE-AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER-LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,-OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN-THE SOFTWARE.+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ parser/Parser.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++module Parser where++import Control.Applicative hiding ((<|>))+import Control.Monad (when)+import Control.Monad.Fix+import Control.Monad.RWS+import Data.Char+import Data.CharSet hiding (map)+import Data.Maybe+import qualified Data.Set as S+import Lens.Micro.Platform+import Parser.Types+import Text.Parsec hiding (many)+import Text.ParserCombinators.ReadP (readP_to_S)+import Text.Read.Lex (lexChar)++type Warning = String++parseStr :: String -> Either ParseError ([Atom], [[Warning]])+parseStr = fmap (unzip . map normalizeAndWarn) . parse printfStr "" . lexChars+ where+ lexChars x = (`fix` x) $ \f s ->+ if Prelude.null s+ then []+ else case readP_to_S lexChar s of+ ((c, rest) : _) -> c : f rest+ [] -> error "malformed input"++normalizeAndWarn :: Atom -> (Atom, [Warning])+normalizeAndWarn s@Str{} = (s, [])+normalizeAndWarn (Arg f) = (Arg a, b)+ where+ (_, a, b) = runRWS (warnLength f >> go (spec f)) () f+ go c | c `elem` "aAeEfFgGxXo" = return ()+ go c | c `elem` "csqQ?" = warnSign >> warnPrefix >> warnZero >> warnSpace+ go c | c `elem` "diu" = warnPrefix+ go 'p' = warnSign >> warnPrefix >> warnZero+ go _ = undefined+ warnFlag ::+ (Eq a, MonadWriter [String] m, MonadState FormatArg m) =>+ Lens' FlagSet a ->+ a ->+ a ->+ Char ->+ m ()+ warnFlag lens' bad good flagName = do+ oldVal <- use (flags_ . lens')+ when (oldVal == bad) $ do+ c <- use spec_+ flags_ . lens' .= good+ tell+ [ "`"+ ++ [flagName]+ ++ "` flag has no effect on `"+ ++ [c]+ ++ "` specifier"+ ]+ warnSign = warnFlag signed_ True False '+'+ warnPrefix = warnFlag prefixed_ True False '#'+ warnSpace = warnFlag spaced_ True False ' '+ warnZero = warnFlag adjustment_ (Just ZeroPadded) Nothing '0'+ phonyLengthSpec =+ S.fromList $+ [(x, y) | x <- "diuoxX", y <- ["L"]]+ ++ [ (x, y)+ | x <- "fFeEgGaA"+ , y <- ["hh", "h", "l", "ll", "j", "z", "t"]+ ]+ ++ [(x, y) | x <- "csqQ", y <- ["hh", "h", "ll", "j", "z", "t", "L"]]+ ++ map ('p',) ["hh", "h", "l", "ll", "j", "z", "t", "L"]+ warnLength FormatArg{spec, lengthSpec = Just l}+ | (spec, show l) `S.member` phonyLengthSpec =+ tell+ [ "`"+ ++ show l+ ++ "` length modifier has no effect when combined with `"+ ++ [spec]+ ++ "` specifier"+ ]+ warnLength _ = return ()++flagSet :: CharSet+flagSet = fromList "-+ #0"++specSet :: CharSet+specSet = fromList "diuoxXfFeEaAgGpcsQq?"++lengthSpecifiers :: [(String, LengthSpecifier)]+lengthSpecifiers =+ [ ("hh", HH)+ , ("h", H)+ , ("ll", LL)+ , ("l", L)+ , ("j", J)+ , ("z", Z)+ , ("t", T)+ , ("L", BigL)+ ]++oneOfSet :: Stream s m Char => CharSet -> ParsecT s u m Char+oneOfSet s = satisfy (`member` s)++printfStr :: Stream s m Char => ParsecT s u m [Atom]+printfStr =+ many $+ Str "%" <$ try (string "%%")+ <|> Arg <$> fmtArg+ <|> Str <$> some (satisfy (/= '%'))++fmtArg :: Stream s m Char => ParsecT s u m FormatArg+fmtArg = do+ _ <- char '%'+ flags <- do+ fs <- many $ do+ c <- oneOfSet flagSet <?> "flag"+ pure $ case c of+ '-' -> FlagLJust+ '+' -> FlagSigned+ ' ' -> FlagSpaced+ '#' -> FlagPrefixed+ '0' -> FlagZeroPadded+ _ -> error "unreachable"+ let flagSet' = S.fromList fs+ if S.size flagSet' < length fs+ then fail "Duplicate flags specified"+ else pure $ toFlagSet flagSet'+ width <- numArg <?> "width"+ precision <- optionMaybe (char '.' *> numArg) <?> "precision"+ lengthSpec <-+ optionMaybe $ choice $ Prelude.map (\(a, b) -> b <$ string a) lengthSpecifiers+ spec <- oneOfSet specSet <?> "valid specifier"+ pure $ FormatArg flags width (fromMaybe (Given 0) <$> precision) spec lengthSpec+ where+ nat = do+ c <- many1 $ satisfy isDigit+ return (read c :: Integer)+ numArg = optionMaybe (Given <$> nat <|> Need <$ char '*')
+ parser/Parser/Types.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TemplateHaskell #-}++module Parser.Types (+ Atom (..),+ FormatArg (..),+ Flag (..),+ adjustmentFlags,+ Adjustment (..),+ FormatStr,+ MaySpecify (..),+ emptyFlagSet,+ toFlagSet,+ FlagSet (..),+ LengthSpecifier (..),+ flags_,+ spec_,+ signed_,+ prefixed_,+ spaced_,+ adjustment_,+) where++import Data.Foldable (+ elem,+ notElem,+ )+import Data.Set (Set)+import qualified Data.Set as S+import Language.Haskell.TH.Lift+import Lens.Micro.Platform+import Prelude hiding (+ elem,+ notElem,+ )++data Atom+ = Arg FormatArg+ | Str String+ deriving (Show)++data LengthSpecifier+ = HH+ | H+ | BigL+ | LL+ | L+ | J+ | Z+ | T+ deriving (Eq)++instance Show LengthSpecifier where+ show HH = "hh"+ show H = "h"+ show BigL = "L"+ show LL = "ll"+ show L = "l"+ show J = "j"+ show Z = "z"+ show T = "t"++data Flag+ = FlagLJust+ | FlagSigned+ | FlagSpaced+ | FlagPrefixed+ | FlagZeroPadded+ deriving (Show, Eq, Ord)++adjustmentFlags :: Set Flag+adjustmentFlags = S.fromList [FlagLJust, FlagZeroPadded]++data Adjustment+ = LeftJustified+ | ZeroPadded+ deriving (Show, Eq)++data MaySpecify+ = Given Integer+ | Need+ deriving (Show)++data FormatArg = FormatArg+ { flags :: FlagSet+ , width :: Maybe MaySpecify+ , precision :: Maybe MaySpecify+ , spec :: Char+ , lengthSpec :: Maybe LengthSpecifier+ }+ deriving (Show)++type FormatStr = [Atom]++data FlagSet = FlagSet+ { adjustment :: Maybe Adjustment+ , signed :: Bool+ , spaced :: Bool+ , prefixed :: Bool+ }+ deriving (Show)++emptyFlagSet :: FlagSet+emptyFlagSet = FlagSet Nothing False False False++toFlagSet :: Set Flag -> FlagSet+toFlagSet fs = 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 && FlagSigned `notElem` fs+ }++makeLensesFor+ [ ("adjustment", "adjustment_")+ , ("signed", "signed_")+ , ("spaced", "spaced_")+ , ("prefixed", "prefixed_")+ ]+ ''FlagSet++makeLensesFor+ [ ("flags", "flags_")+ , ("spec", "spec_")+ ]+ ''FormatArg++deriveLiftMany [''Adjustment, ''FlagSet, ''LengthSpecifier]
+ src/Buf.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}++module Buf (Buf (..), SizedStr, SizedBuilder) where++import Data.Char (intToDigit)+import qualified Data.DList as D+import Data.Kind (Type)+import Data.String+import qualified Data.Text as S+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.Builder as T+import qualified Data.Text.Lazy.Builder.Int as T++newtype Sized a = Sized {unSized :: (a, Int)} deriving (Show, Ord, Eq)++type SizedStr = Sized (D.DList Char)+type SizedBuilder = Sized T.Builder++instance (IsString a) => IsString (Sized a) where+ fromString s = Sized (fromString s, length s)++instance (Semigroup a) => Semigroup (Sized a) where+ Sized (a, b) <> Sized (c, d) = Sized (a <> c, b + d)+ {-# INLINE (<>) #-}++instance (Monoid a) => Monoid (Sized a) where+ mempty = Sized (mempty, 0)+ mappend = (<>)+ {-# INLINE mappend #-}++class (Monoid a) => Buf a where+ type Output a :: Type++ str :: String -> a++ sText :: S.Text -> a+ sText = str . S.unpack+ lText :: L.Text -> a+ lText = str . L.unpack++ singleton :: Char -> a+ digit :: Int -> a+ digit = singleton . intToDigit+ {-# INLINE digit #-}++ cons :: Char -> a -> a+ cons c s = singleton c <> s+ {-# INLINE cons #-}++ repeatN :: Int -> Char -> a+ repeatN n = str . replicate n++ size :: a -> Int++ finalize :: a -> Output a++instance Buf SizedStr where+ type Output SizedStr = String+ str a = Sized (D.fromList a, length a)+ singleton c = Sized (D.singleton c, 1)+ finalize = D.toList . fst . unSized+ cons c (Sized (r, m)) = Sized (D.cons c r, m + 1)+ repeatN n c = Sized (D.replicate n c, n)+ size = snd . unSized++instance Buf SizedBuilder where+ type Output SizedBuilder = Text+ str a = Sized (fromString a, length a)+ sText a = Sized (T.fromText a, S.length a)+ lText a = Sized (T.fromLazyText a, fromIntegral (L.length a))+ singleton c = Sized (T.singleton c, 1)+ digit c = Sized (T.hexadecimal c, 1)+ finalize = T.toLazyText . fst . unSized+ size = snd . unSized
+ src/Language/Haskell/Printf.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}++{- | "Text.Printf" is a useful module, but due to the typeclass hacks it uses, it can+be hard to tell if the format string you wrote is well-formed or not.+This package provides a mechanism to create formatting functions at compile time.++Note that, to maintain consistency with other printf implementations, negative ints+that are printed as unsigned will \"underflow\". (Text.Printf does this too.)++>>> [s|%u|] (-1 :: Int32)+WAS "4294967295"+NOW Not in scope: type constructor or class `Int32'++Thus, any time you want to print a number using the unsigned, octal, or hex specifiers,+your input must be an instance of "Bounded".+-}+module Language.Haskell.Printf (+ s,+ t,+ p,+ hp,+) where++import Control.Monad.IO.Class+import Language.Haskell.Printf.Lib+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import System.IO (hPutStr)++{- | @+['s'|Hello, %s! (%d people greeted)|] :: ... -> 'String'+@++This formatter follows the guidelines listed+<http://www.cplusplus.com/reference/cstdio/printf/ here>, except for+@%n@ (store number of printed characters) for obvious+reasons.++@+%c :: 'Char'+%s :: 'String'+%q :: 'Data.Text.Lazy.Text' -- lazy text+%Q :: 'Data.Text.Text' -- strict text++-- datatypes with Show instances+%? :: 'Show' a => a++-- signed integer types+%d, %i :: 'Integral' i => i++-- unsigned integer types+%u :: ('Bounded' i, 'Integral' i) => i+%o :: ('Bounded' i, 'Integral' i) => i+%x, %X :: ('Bounded' i, 'Integral' i) => i++-- floats+%a, %A :: 'RealFloat' f => f+%e, %E :: 'RealFloat' f => f+%f, %F :: 'RealFloat' f => f+%g, %G :: 'RealFloat' f => f++%p :: 'Foreign.Ptr.Ptr' a+@+-}+s :: QuasiQuoter+s = quoter $ \s' -> do+ (lhss, rhs) <- toSplices s' OutputString+ return $ LamE lhss rhs++-- | Behaves identically to 's', but produces lazy 'Data.Text.Lazy.Text'.+t :: QuasiQuoter+t = quoter $ \s' -> do+ (lhss, rhs) <- toSplices s' OutputText+ return $ LamE lhss rhs++{- | Like 's', but prints the resulting string to @stdout@.++@+[p|Hello, %s! (%d people greeted)|] :: 'MonadIO' m => ... -> m ()+@+-}+p :: QuasiQuoter+p = quoter $ \s' -> do+ (lhss, rhs) <- toSplices s' OutputString+ lamE (map pure lhss) [|liftIO (putStr $(pure rhs))|]++{- | Like 'p', but takes as its first argument the 'System.IO.Handle' to print to.++@+[hp|Hello, %s! (%d people greeted)|] :: 'MonadIO' m => 'System.IO.Handle' -> ... -> m ()+@+-}+hp :: QuasiQuoter+hp = quoter $ \s' -> do+ (lhss, rhs) <- toSplices s' OutputString+ h <- newName "h"+ lamE (varP h : map pure lhss) [|liftIO (hPutStr $(varE h) $(pure rhs))|]++quoter :: (String -> ExpQ) -> QuasiQuoter+quoter e =+ QuasiQuoter+ { quoteExp = e+ , quotePat = error "this quoter cannot be used in a pattern context"+ , quoteType = error "this quoter cannot be used in a type context"+ , quoteDec = error "this quoter cannot be used in a declaration context"+ }
+ src/Language/Haskell/Printf/Geometry.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Language.Haskell.Printf.Geometry (+ sign',+ padDecimal,+ prefix,+ fromPrintfArg,+ formatOne,+ Value (..),+) where++import Control.Monad+import Data.Maybe+import Language.Haskell.PrintfArg+import Parser.Types (Adjustment (..))++import Buf+import StrUtils++data Value buf = Value+ { valArg :: PrintfArg buf+ , valPrefix :: Maybe buf+ , valSign :: Maybe buf+ }+ deriving (Show)++sign' :: (Num n, Ord n, Buf buf) => PrintfArg n -> Maybe buf+sign' pf+ | value pf < 0 = Just (singleton '-')+ | spaced pf = Just (singleton ' ')+ | signed pf = Just (singleton '+')+ | otherwise = Nothing++padDecimal :: (Buf buf, Eq v, Num v) => PrintfArg v -> buf -> buf+padDecimal spec+ | prec spec == Just 0 && value spec == 0 = const mempty+ | otherwise = maybe id (`justifyRight` '0') (prec spec)++prefix :: (Num n, Eq n, Buf buf) => buf -> PrintfArg n -> Maybe buf+prefix s pf = guard (prefixed pf && value pf /= 0) >> Just s++fromPrintfArg ::+ (Buf buf) =>+ (n -> buf) ->+ (PrintfArg n -> Maybe buf) ->+ (PrintfArg n -> Maybe buf) ->+ PrintfArg n ->+ Value buf+fromPrintfArg f b c a = Value (f <$> a) (b a) (c a)++formatOne :: (Buf buf) => Value buf -> buf+formatOne Value{..}+ | Nothing <- width valArg = prefix' <> text+ | Just w <- width valArg = case adjustment valArg of+ Just ZeroPadded+ | isn'tDecimal || isNothing (prec valArg) ->+ prefix' <> justifyRight (w - size prefix') '0' text+ Just LeftJustified -> justifyLeft w ' ' (prefix' <> text)+ _ -> justify' w (prefix' <> text)+ where+ isn'tDecimal = fieldSpec valArg `notElem` ("diouxX" :: String)+ justify' n+ | n < 0 = justifyLeft (abs n) ' '+ | otherwise = justifyRight n ' '+ prefix' = fromMaybe mempty valSign <> fromMaybe mempty valPrefix+ text = value valArg
+ src/Language/Haskell/Printf/Lib.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Language.Haskell.Printf.Lib (+ toSplices,+ OutputType (..),+) where++import Data.Maybe+import Data.String (fromString)+import GHC.Generics (Generic)+import Language.Haskell.Printf.Geometry (+ formatOne,+ )+import qualified Language.Haskell.Printf.Printers as Printers+import Language.Haskell.PrintfArg+import Language.Haskell.TH+import Language.Haskell.TH.Syntax++import Buf (+ SizedBuilder,+ SizedStr,+ finalize,+ )+import Control.Monad (mapAndUnzipM)+import Parser (parseStr)+import Parser.Types hiding (+ lengthSpec,+ width,+ )++data OutputType = OutputString | OutputText+ deriving (Show, Eq, Ord, Generic, Enum, Bounded)++{- | Takes a format string as input and produces a tuple @(args, outputExpr)@.++This function processes character escapes as they would appear in Haskell source code.+It will emit warnings (or throw an error, as appropriate) when given an invalid format+string.++Use if you wish to leverage @th-printf@ in conjunction with, for example, an existing+logging library.+-}+toSplices :: String -> OutputType -> Q ([Pat], Exp)+toSplices s' ot = case parseStr s' of+ Left x -> fail $ show x+ Right (y, warns) -> do+ mapM_ (qReport False) (concat warns)+ (lhss, rhss) <- mapAndUnzipM extractExpr y+ rhss' <-+ appE+ [|finalize|]+ (sigE (foldr1 (\x y' -> infixApp x [|(<>)|] y') rhss) otype)+ return (map VarP $ concat lhss, rhss')+ where+ otype = case ot of+ OutputString -> [t|SizedStr|]+ OutputText -> [t|SizedBuilder|]++extractExpr :: Atom -> Q ([Name], ExpQ)+extractExpr (Str s') = return ([], [|fromString $(stringE s')|])+extractExpr (Arg (FormatArg flags' width' precision' spec' lengthSpec')) = do+ (warg, wexp) <- extractArgs width'+ (parg, pexp) <- extractArgs precision'+ varg <- newName "arg"+ return+ ( catMaybes [warg, parg, Just varg]+ , appE+ [|formatOne|]+ ( appE+ formatter+ [|+ PrintfArg+ { flagSet = $(lift flags')+ , width = $(wexp)+ , prec = $(pexp)+ , value = $(varE varg)+ , lengthSpec = $(lift lengthSpec')+ , fieldSpec = $(lift spec')+ }+ |]+ )+ )+ where+ extractArgs n = case n of+ Just Need -> do+ a <- newName "arg"+ pure (Just a, [|Just (fromInteger (fromIntegral $(varE a)))|])+ Just (Given n') -> pure (Nothing, [|Just $(litE $ integerL n')|])+ Nothing -> pure (Nothing, [|Nothing|])+ formatter = case spec' of+ 's' -> [|Printers.printfString|]+ 'q' -> [|Printers.printfLazyText|]+ 'Q' -> [|Printers.printfStrictText|]+ '?' -> [|Printers.printfShow|]+ 'd' -> [|Printers.printfDecimal|]+ 'i' -> [|Printers.printfDecimal|]+ 'p' -> [|Printers.printfPtr|]+ 'c' -> [|Printers.printfChar|]+ 'u' -> [|Printers.printfUnsigned|]+ 'x' -> [|Printers.printfHex False|]+ 'X' -> [|Printers.printfHex True|]+ 'o' -> [|Printers.printfOctal|]+ 'f' -> [|Printers.printfFloating False|]+ 'F' -> [|Printers.printfFloating True|]+ 'e' -> [|Printers.printfScientific False|]+ 'E' -> [|Printers.printfScientific True|]+ 'g' -> [|Printers.printfGeneric False|]+ 'G' -> [|Printers.printfGeneric True|]+ 'a' -> [|Printers.printfFloatHex False|]+ 'A' -> [|Printers.printfFloatHex True|]+ _ -> undefined
+ src/Language/Haskell/Printf/Printers.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++module Language.Haskell.Printf.Printers where++import Data.Char+import Data.Maybe (fromMaybe)+import Data.String (IsString, fromString)+import qualified Data.Text as S+import qualified Data.Text.Lazy as L+import Foreign.Ptr+import GHC.Float (FFFormat (..))+import Language.Haskell.Printf.Geometry+import Language.Haskell.PrintfArg+import Math.NumberTheory.Logarithms++import Buf+import NumUtils+import qualified Parser.Types as P++type Printer n buf = PrintfArg n -> Value buf++printfString :: (Buf buf) => Printer String buf+printfString spec =+ Value+ { valArg = case prec spec of+ Nothing -> str <$> spec+ Just c -> str . take c <$> spec+ , valPrefix = Nothing+ , valSign = Nothing+ }++printfStrictText :: (Buf buf) => Printer S.Text buf+printfStrictText spec =+ Value+ { valArg = case prec spec of+ Nothing -> sText <$> spec+ Just c -> sText . S.take c <$> spec+ , valPrefix = Nothing+ , valSign = Nothing+ }++printfLazyText :: (Buf buf) => Printer L.Text buf+printfLazyText spec =+ Value+ { valArg = case prec spec of+ Nothing -> lText <$> spec+ Just c -> lText . L.take (fromIntegral c) <$> spec+ , valPrefix = Nothing+ , valSign = Nothing+ }++printfShow :: (Buf buf, Show a) => Printer a buf+printfShow spec = printfString (fromString . show <$> spec)++printfChar :: (Buf buf) => Printer Char buf+printfChar spec =+ Value+ { valArg = singleton <$> spec+ , valPrefix = Nothing+ , valSign = Nothing+ }++{-# ANN printfPtr ("HLint: ignore Use showHex" :: String) #-}+printfPtr :: (Buf buf) => Printer (Ptr a) buf+printfPtr spec =+ Value+ { valArg =+ PrintfArg+ { width = width spec+ , prec = Nothing+ , flagSet = P.emptyFlagSet{P.prefixed = True}+ , lengthSpec = Nothing+ , fieldSpec = 'p'+ , value = showIntAtBase 16 intToDigit (ptrToWordPtr $ value spec)+ }+ , valPrefix = Just (str "0x")+ , valSign = Nothing+ }++printfDecimal :: (Buf buf, Show n, Integral n) => PrintfArg n -> Value buf+printfDecimal spec =+ Value+ { valArg = padDecimal spec . showIntAtBase 10 intToDigit . abs <$> spec+ , valPrefix = Nothing+ , valSign = sign' spec+ }++fmtUnsigned ::+ (Bounded a, Integral a, Buf buf) =>+ (Integer -> buf) ->+ (PrintfArg a -> Maybe buf) ->+ Printer a buf+fmtUnsigned shower p spec =+ Value+ { valArg = padDecimal spec . shower . clampUnsigned <$> spec+ , valPrefix = p spec+ , valSign = Nothing+ }++printfHex :: (Bounded a, Integral a, Buf buf, IsString buf) => Bool -> Printer a buf+printfHex b = fmtUnsigned showHex (prefix (if b then "0X" else "0x"))+ where+ showHex = showIntAtBase 16 ((if b then toUpper else id) . intToDigit)++printfUnsigned :: (Bounded a, Integral a, Buf buf) => Printer a buf+printfUnsigned = fmtUnsigned (showIntAtBase 10 intToDigit) (const Nothing)++-- printing octal is really annoying. consider+--+-- printf "%#-8.5x" 1234+--+-- "0x004d2 "+-- ^~~~~~~^ width (8)+-- ^~~~^ precision (5)+-- ^^ prefix (2)+-- ^^ padding (2)+--+-- printf "%#-8.5o" 1234+--+-- "02322 "+-- ^~~~~~~^ width (8)+-- ^~~~^ precision (5)+-- ^ prefix (1)+-- ^ padding (1, same character)+--+-- in octal, when combining prefix and padding, the prefix+-- must eat the first padding char+{-# ANN printfOctal ("HLint: ignore Use showOct" :: String) #-}+printfOctal :: (Buf buf, IsString buf, Bounded n, Integral n) => PrintfArg n -> Value buf+printfOctal spec =+ fmtUnsigned+ (showIntAtBase 8 intToDigit)+ (\y -> if shouldUnpad then Nothing else prefix "0" y)+ spec+ where+ expectedWidth = integerLogBase 8 (max 1 $ clampUnsigned $ value spec) + 1+ shouldUnpad = prefixed spec && fromMaybe 0 (prec spec) > expectedWidth++printfFloating :: (Buf buf, RealFloat n) => Bool -> PrintfArg n -> Value buf+printfFloating upperFlag spec =+ Value+ { valArg = showFloat . abs <$> spec+ , valPrefix = Nothing+ , valSign = sign' spec+ }+ where+ precision = case prec spec of+ Just n -> Just (fromIntegral n)+ Nothing | Just P.ZeroPadded <- adjustment spec -> Just 6+ _ -> Nothing+ showFloat = formatRealFloatAlt FFFixed precision (prefixed spec) upperFlag++printfScientific :: (Buf buf, RealFloat n) => Bool -> PrintfArg n -> Value buf+printfScientific upperFlag spec =+ Value+ { valArg = showSci . abs <$> spec+ , valPrefix = Nothing+ , valSign = sign' spec+ }+ where+ showSci =+ formatRealFloatAlt+ FFExponent+ (fromIntegral <$> prec spec)+ (prefixed spec)+ upperFlag++printfGeneric :: (Buf buf, RealFloat n) => Bool -> PrintfArg n -> Value buf+printfGeneric upperFlag spec =+ Value+ { valArg = showSci . abs <$> spec+ , valPrefix = Nothing+ , valSign = sign' spec+ }+ where+ showSci =+ formatRealFloatAlt+ FFGeneric+ (fromIntegral <$> prec spec)+ (prefixed spec)+ upperFlag++printfFloatHex :: (Buf buf, RealFloat n, IsString buf) => Bool -> PrintfArg n -> Value buf+printfFloatHex upperFlag spec =+ Value+ { valArg = showHexFloat . abs <$> spec+ , valPrefix = Just (if upperFlag then "0X" else "0x")+ , valSign = sign' spec+ }+ where+ showHexFloat =+ formatHexFloat (fromIntegral <$> prec spec) (prefixed spec) upperFlag++clampUnsigned :: (Bounded a, Integral a) => a -> Integer+clampUnsigned x+ | x < 0 = toInteger x + (-2 * toInteger (minBound `asTypeOf` x))+ | otherwise = toInteger x
+ src/Language/Haskell/PrintfArg.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE DeriveFunctor #-}++module Language.Haskell.PrintfArg (+ PrintfArg (..),+ adjustment,+ signed,+ spaced,+ prefixed,+) where++import qualified Parser.Types as P++data PrintfArg v = PrintfArg+ { flagSet :: P.FlagSet+ , width :: Maybe Int+ , prec :: Maybe Int+ , lengthSpec :: Maybe P.LengthSpecifier+ , fieldSpec :: Char+ , value :: v+ }+ deriving (Show, Functor)++adjustment :: PrintfArg v -> Maybe P.Adjustment+adjustment = P.adjustment . flagSet++signed, spaced, prefixed :: PrintfArg v -> Bool+signed = P.signed . flagSet+spaced = P.spaced . flagSet+prefixed = P.prefixed . flagSet
+ src/NumUtils.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE NoMonomorphismRestriction #-}++module NumUtils (showIntAtBase, formatRealFloatAlt, formatHexFloat) where++import Data.Bits+import Data.Char+import Data.Foldable+import Data.Ord+import Data.Semigroup ((<>))+import Data.Tuple+import GHC.Float (+ FFFormat (..),+ roundTo,+ )+import Numeric (floatToDigits)+import Prelude hiding (+ exp,+ foldr,+ (<>),+ )++import Buf+import StrUtils++showIntAtBase ::+ (Buf buf, Show a, Integral a) => a -> (Int -> Char) -> a -> buf+showIntAtBase base toChr n0+ | base <= 1 = error "unsupported base"+ | n0 < 0 = error $ "negative number " ++ show n0+ | otherwise = showIt (quotRem n0 base) mempty+ where+ showIt (n, d) r = case n of+ 0 -> r'+ _ -> showIt (quotRem n base) r'+ where+ r' = cons (toChr (fromIntegral d)) r++formatRealFloatAlt ::+ (Buf buf, RealFloat a) =>+ FFFormat ->+ Maybe Int ->+ Bool ->+ Bool ->+ a ->+ buf+formatRealFloatAlt fmt decs forceDot upper x+ | isNaN x = str "NaN"+ | isInfinite x = str $ if x < 0 then "-Infinity" else "Infinity"+ | x < 0 || isNegativeZero x =+ cons+ '-'+ (doFmt fmt (floatToDigits 10 (- x)) False)+ | otherwise = doFmt fmt (floatToDigits 10 x) False+ where+ eChar+ | upper = 'E'+ | otherwise = 'e'+ doFmt FFFixed (digs, exp) fullRounding+ | exp < 0 =+ doFmt FFFixed (replicate (negate exp) 0 ++ digs, 0) fullRounding+ | null part =+ fromDigits False whole <> (if forceDot then singleton '.' else mempty)+ | null whole =+ str "0." <> fromDigits False part+ | otherwise =+ fromDigits False whole <> singleton '.' <> fromDigits False part+ where+ (whole, part) =+ uncurry (flip splitAt) (toRoundedDigits decs (digs, exp) fullRounding)+ doFmt FFExponent ([0], _) _+ | forceDot = str "0.e+00"+ | otherwise = str "0e+00"+ doFmt FFExponent (digs, exp) fullRounding =+ shownDigs <> cons eChar shownExponent+ where+ shownDigs = case digs' of+ [] -> undefined+ [x'] ->+ cons (intToDigit x') (if forceDot then singleton '.' else mempty)+ (x' : xs) -> cons (intToDigit x') (cons '.' (fromDigits False xs))+ digs' = case decs of+ Just n ->+ case roundTo+ 10+ (if fullRounding then min (length digs) n else n + 1)+ digs of+ (1, xs) -> 1 : xs+ (_, ys) -> ys+ Nothing -> digs+ exp' = exp - 1+ shownExponent =+ cons (if exp' < 0 then '-' else '+') $+ justifyRight 2 '0' $+ showIntAtBase 10 intToDigit $+ abs exp'+ doFmt FFGeneric d _ =+ minimumBy (comparing size) [doFmt FFFixed d True, doFmt FFExponent d True]++toRoundedDigits :: Maybe Int -> ([Int], Int) -> Bool -> ([Int], Int)+toRoundedDigits Nothing (digs, exp) _ = (digs, exp)+toRoundedDigits (Just prec) (digs, exp) fullRounding = (digs', exp + overflow)+ where+ (overflow, digs') =+ roundTo+ 10+ (if fullRounding && prec > exp then min (length digs) prec else prec + exp)+ digs++fromDigits :: (Buf buf) => Bool -> [Int] -> buf+fromDigits upper =+ foldr (cons . (if upper then toUpper else id) . intToDigit) mempty++formatHexFloat ::+ (Buf buf, RealFloat a) => Maybe Int -> Bool -> Bool -> a -> buf+formatHexFloat decs alt upper x = doFmt (floatToDigits 2 x)+ where+ pChar+ | upper = 'P'+ | otherwise = 'p'+ doFmt ([], _) = undefined+ doFmt ([0], 0) = cons '0' (cons pChar (str "+0"))+ -- possible ghcjs bug - some floats are encoded as ([0,...], exp + 1)+ -- but the first digit should never be 0 unless the input is 0.0+ doFmt (0 : bits, exp) = doFmt (bits, exp - 1)+ doFmt (_ : bits, exp) =+ cons '1' $+ (if not (null hexDigits) || alt then singleton '.' else mempty)+ <> fromDigits upper hexDigits+ <> singleton pChar+ <> (if exp > 0 then singleton '+' else mempty)+ <> str (show (exp - 1 + overflow))+ where+ hexDigits' = go bits+ (overflow, hexDigits) = case decs of+ Just n -> case roundTo 16 n hexDigits' of+ (1, _ : digs) -> (1, digs)+ x' -> x'+ Nothing -> (0, hexDigits')+ go (a : b : c : d : xs) =+ ((a `shiftL` 3) .|. (b `shiftL` 2) .|. (c `shiftL` 1) .|. d) : go xs+ go [a, b, c] = go [a, b, c, 0]+ go [a, b] = go [a, b, 0, 0]+ go [a] = go [a, 0, 0, 0]+ go [] = []
+ src/StrUtils.hs view
@@ -0,0 +1,17 @@+module StrUtils (justifyLeft, justifyRight) where++import Buf++justifyLeft :: (Buf a) => Int -> Char -> a -> a+justifyLeft n c s+ | diff <= 0 = s+ | otherwise = s <> repeatN diff c+ where+ diff = n - size s++justifyRight :: (Buf a) => Int -> Char -> a -> a+justifyRight n c s+ | diff <= 0 = s+ | otherwise = repeatN diff c <> s+ where+ diff = n - size s
− src/Text/Printf/TH.hs
@@ -1,303 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE QuasiQuotes #-}--module Text.Printf.TH (s, st, lt, sb, lb, sP, stP, ltP, sbP, lbP) where--import Control.Applicative-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.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 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--plus :: Bool -> Chunk -> String -> String-plus b c = if Plus `elem` flags c- then if b then ('+':) else ('-':)- else id--prefix :: String -> Chunk -> String -> String-prefix s' p = if Hash `elem` flags p then (s' ++) else id--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 ' '--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 ' '--calcWidth :: Chunk -> Integer-calcWidth (Chunk _ (Just (Width n)) _ _) = n-calcWidth _ = -1--calcPrec :: Chunk -> Integer-calcPrec (Chunk _ _ (Just (Precision n)) _) = n-calcPrec _ = -1--class ToString a where toString :: a -> String--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--class ToChar m where asChar :: m -> Char--instance ToChar Char where asChar = id-instance ToChar Int where asChar = chr-instance ToChar Word8 where asChar = chr . fromIntegral--class Printable a where output :: MonadIO m => a -> m ()--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
− tests/format.hs
@@ -1,67 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE QuasiQuotes #-}--module Main where--import Control.Exception-import Control.Monad-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)
+ tests/printf/GeneratedSpec.hs view
@@ -0,0 +1,450 @@+-- This file contains autogenerated erroneous printf strings, which th-printf+-- will warn about, but they shouldn't break a -Werror build+{-# OPTIONS_GHC -Wwarn #-}+{-# LANGUAGE QuasiQuotes #-}++module GeneratedSpec where++import Data.Int+import Data.Word+import Language.Haskell.Printf+import Test.HUnit+import Test.Hspec++spec :: Spec+spec = do+ it "test-case #1" $ [s|%.*f|] (2 :: Int32) (0.33333333 :: Double) @?= "0.33"+ it "test-case #2" $ [s|%.3s|] "foobar" @?= "foo"+ it "test-case #3" $ [s|%10.5d|] (4 :: Int32) @?= " 00004"+ it "test-case #4" $ [s|% d|] (42 :: Int32) @?= " 42"+ it "test-case #5" $ [s|% d|] (-42 :: Int32) @?= "-42"+ it "test-case #6" $ [s|% 5d|] (42 :: Int32) @?= " 42"+ it "test-case #7" $ [s|% 5d|] (-42 :: Int32) @?= " -42"+ it "test-case #8" $ [s|% 15d|] (42 :: Int32) @?= " 42"+ it "test-case #9" $ [s|% 15d|] (-42 :: Int32) @?= " -42"+ it "test-case #10" $ [s|%+d|] (42 :: Int32) @?= "+42"+ it "test-case #11" $ [s|%+d|] (-42 :: Int32) @?= "-42"+ it "test-case #12" $ [s|%+5d|] (42 :: Int32) @?= " +42"+ it "test-case #13" $ [s|%+5d|] (-42 :: Int32) @?= " -42"+ it "test-case #14" $ [s|%+15d|] (42 :: Int32) @?= " +42"+ it "test-case #15" $ [s|%+15d|] (-42 :: Int32) @?= " -42"+ it "test-case #16" $ [s|%0d|] (42 :: Int32) @?= "42"+ it "test-case #17" $ [s|%0d|] (-42 :: Int32) @?= "-42"+ it "test-case #18" $ [s|%05d|] (42 :: Int32) @?= "00042"+ it "test-case #19" $ [s|%05d|] (-42 :: Int32) @?= "-0042"+ it "test-case #20" $ [s|%015d|] (42 :: Int32) @?= "000000000000042"+ it "test-case #21" $ [s|%015d|] (-42 :: Int32) @?= "-00000000000042"+ it "test-case #22" $ [s|%-d|] (42 :: Int32) @?= "42"+ it "test-case #23" $ [s|%-d|] (-42 :: Int32) @?= "-42"+ it "test-case #24" $ [s|%-5d|] (42 :: Int32) @?= "42 "+ it "test-case #25" $ [s|%-5d|] (-42 :: Int32) @?= "-42 "+ it "test-case #26" $ [s|%-15d|] (42 :: Int32) @?= "42 "+ it "test-case #27" $ [s|%-15d|] (-42 :: Int32) @?= "-42 "+ it "test-case #28" $ [s|%-0d|] (42 :: Int32) @?= "42"+ it "test-case #29" $ [s|%-0d|] (-42 :: Int32) @?= "-42"+ it "test-case #30" $ [s|%-05d|] (42 :: Int32) @?= "42 "+ it "test-case #31" $ [s|%-05d|] (-42 :: Int32) @?= "-42 "+ it "test-case #32" $ [s|%-015d|] (42 :: Int32) @?= "42 "+ it "test-case #33" $ [s|%-015d|] (-42 :: Int32) @?= "-42 "+ it "test-case #34" $ [s|%0-d|] (42 :: Int32) @?= "42"+ it "test-case #35" $ [s|%0-d|] (-42 :: Int32) @?= "-42"+ it "test-case #36" $ [s|%0-5d|] (42 :: Int32) @?= "42 "+ it "test-case #37" $ [s|%0-5d|] (-42 :: Int32) @?= "-42 "+ it "test-case #38" $ [s|%0-15d|] (42 :: Int32) @?= "42 "+ it "test-case #39" $ [s|%0-15d|] (-42 :: Int32) @?= "-42 "+ it "test-case #43" $ [s|%.2f|] (42.8952 :: Double) @?= "42.90"+ it "test-case #44" $ [s|%.2F|] (42.8952 :: Double) @?= "42.90"+ it "test-case #45" $ [s|%.10f|] (42.8952 :: Double) @?= "42.8952000000"+ it "test-case #46" $ [s|%1.2f|] (42.8952 :: Double) @?= "42.90"+ it "test-case #47" $ [s|%6.2f|] (42.8952 :: Double) @?= " 42.90"+ it "test-case #49" $ [s|%+6.2f|] (42.8952 :: Double) @?= "+42.90"+ it "test-case #50" $ [s|%5.10f|] (42.8952 :: Double) @?= "42.8952000000"+ -- 51: anti-test+ -- 52: anti-test+ -- 53: excluded for Haskell+ -- 55: excluded for Haskell+ -- 56: excluded for Haskell+ -- 58: excluded for Haskell+ -- 59: excluded for Haskell+ it "test-case #60" $ [s|%*s|] (4 :: Int32) "foo" @?= " foo"+ it "test-case #61" $+ [s|%*.*f|] (10 :: Int32) (2 :: Int32) (3.14159265 :: Double) @?= " 3.14"+ it "test-case #63" $+ [s|%-*.*f|] (10 :: Int32) (2 :: Int32) (3.14159265 :: Double) @?= "3.14 "+ -- 64: anti-test+ -- 65: anti-test+ it "test-case #66" $ [s|+%s+|] "hello" @?= "+hello+"+ it "test-case #67" $ [s|+%d+|] (10 :: Int32) @?= "+10+"+ it "test-case #68" $ [s|%c|] 'a' @?= "a"+ -- unsound test: it "test-case #69" $ [s|%c|] (32 :: Int32) @?= " "+ -- unsound test: it "test-case #70" $ [s|%c|] (36 :: Int32) @?= "$"+ it "test-case #71" $ [s|%d|] (10 :: Int32) @?= "10"+ -- 72: anti-test+ -- 73: anti-test+ -- 74: excluded for Haskell+ -- 75: excluded for Haskell+ it "test-case #76" $+ [s|%+#22.15e|] (7.89456123e8 :: Double) @?= "+7.894561230000000e+08"+ it "test-case #77" $+ [s|%-#22.15e|] (7.89456123e8 :: Double) @?= "7.894561230000000e+08 "+ it "test-case #78" $+ [s|%#22.15e|] (7.89456123e8 :: Double) @?= " 7.894561230000000e+08"+ it "test-case #79" $ [s|%#1.1g|] (7.89456123e8 :: Double) @?= "8.e+08"+ it "test-case #81" $ [s|%+8lld|] (100 :: Int64) @?= " +100"+ it "test-case #82" $ [s|%+.8lld|] (100 :: Int64) @?= "+00000100"+ it "test-case #83" $ [s|%+10.8lld|] (100 :: Int64) @?= " +00000100"+ -- 84: excluded for Haskell+ it "test-case #85" $ [s|%-1.5lld|] (-100 :: Int64) @?= "-00100"+ it "test-case #86" $ [s|%5lld|] (100 :: Int64) @?= " 100"+ it "test-case #87" $ [s|%5lld|] (-100 :: Int64) @?= " -100"+ it "test-case #88" $ [s|%-5lld|] (100 :: Int64) @?= "100 "+ it "test-case #89" $ [s|%-5lld|] (-100 :: Int64) @?= "-100 "+ it "test-case #90" $ [s|%-.5lld|] (100 :: Int64) @?= "00100"+ it "test-case #91" $ [s|%-.5lld|] (-100 :: Int64) @?= "-00100"+ it "test-case #92" $ [s|%-8.5lld|] (100 :: Int64) @?= "00100 "+ it "test-case #93" $ [s|%-8.5lld|] (-100 :: Int64) @?= "-00100 "+ it "test-case #94" $ [s|%05lld|] (100 :: Int64) @?= "00100"+ it "test-case #95" $ [s|%05lld|] (-100 :: Int64) @?= "-0100"+ it "test-case #96" $ [s|% lld|] (100 :: Int64) @?= " 100"+ it "test-case #97" $ [s|% lld|] (-100 :: Int64) @?= "-100"+ it "test-case #98" $ [s|% 5lld|] (100 :: Int64) @?= " 100"+ it "test-case #99" $ [s|% 5lld|] (-100 :: Int64) @?= " -100"+ it "test-case #100" $ [s|% .5lld|] (100 :: Int64) @?= " 00100"+ it "test-case #101" $ [s|% .5lld|] (-100 :: Int64) @?= "-00100"+ it "test-case #102" $ [s|% 8.5lld|] (100 :: Int64) @?= " 00100"+ it "test-case #103" $ [s|% 8.5lld|] (-100 :: Int64) @?= " -00100"+ it "test-case #104" $ [s|%.0lld|] (0 :: Int64) @?= ""+ it "test-case #105" $ [s|%#+21.18llx|] (-100 :: Int64) @?= " 0x00ffffffffffffff9c"+ it "test-case #106" $ [s|%#.25llo|] (-100 :: Int64) @?= "0001777777777777777777634"+ it "test-case #107" $ [s|%#+24.20llo|] (-100 :: Int64) @?= " 01777777777777777777634"+ it "test-case #108" $ [s|%#+18.21llX|] (-100 :: Int64) @?= "0X00000FFFFFFFFFFFFFF9C"+ it "test-case #109" $ [s|%#+20.24llo|] (-100 :: Int64) @?= "001777777777777777777634"+ it "test-case #110" $ [s|%#+25.22llu|] (-1 :: Int64) @?= " 0018446744073709551615"+ it "test-case #111" $ [s|%#+25.22llu|] (-1 :: Int64) @?= " 0018446744073709551615"+ it "test-case #112" $+ [s|%#+30.25llu|] (-1 :: Int64) @?= " 0000018446744073709551615"+ it "test-case #113" $ [s|%+#25.22lld|] (-1 :: Int64) @?= " -0000000000000000000001"+ it "test-case #114" $ [s|%#-8.5llo|] (100 :: Int64) @?= "00144 "+ it "test-case #115" $ [s|%#-+ 08.5lld|] (100 :: Int64) @?= "+00100 "+ it "test-case #116" $ [s|%#-+ 08.5lld|] (100 :: Int64) @?= "+00100 "+ it "test-case #117" $+ [s|%.40lld|] (1 :: Int64) @?= "0000000000000000000000000000000000000001"+ it "test-case #118" $+ [s|% .40lld|] (1 :: Int64) @?= " 0000000000000000000000000000000000000001"+ it "test-case #119" $+ [s|% .40d|] (1 :: Int32) @?= " 0000000000000000000000000000000000000001"+ -- 121: excluded for Haskell+ -- 124: excluded for Haskell+ it "test-case #125" $ [s|% d|] (1 :: Int32) @?= " 1"+ it "test-case #126" $ [s|%+ d|] (1 :: Int32) @?= "+1"+ it "test-case #129" $ [s|%#012x|] (1 :: Int32) @?= "0x0000000001"+ it "test-case #130" $ [s|%#04.8x|] (1 :: Int32) @?= "0x00000001"+ it "test-case #131" $ [s|%#-08.2x|] (1 :: Int32) @?= "0x01 "+ it "test-case #132" $ [s|%#08o|] (1 :: Int32) @?= "00000001"+ -- 133: excluded for Haskell+ -- 137: excluded for Haskell+ it "test-case #142" $ [s|%.1s|] "foo" @?= "f"+ it "test-case #143" $ [s|%.*s|] (1 :: Int32) "foo" @?= "f"+ it "test-case #144" $ [s|%*s|] (-5 :: Int32) "foo" @?= "foo "+ it "test-case #145" $ [s|hello|] @?= "hello"+ -- 147: excluded for Haskell+ it "test-case #148" $ [s|%3c|] 'a' @?= " a"+ it "test-case #149" $ [s|%3d|] (1234 :: Int32) @?= "1234"+ -- 150: excluded for Haskell+ it "test-case #152" $ [s|%-1d|] (2 :: Int32) @?= "2"+ it "test-case #153" $ [s|%2.4f|] (8.6 :: Double) @?= "8.6000"+ it "test-case #154" $ [s|%0f|] (0.6 :: Double) @?= "0.600000"+ it "test-case #155" $ [s|%.0f|] (0.6 :: Double) @?= "1"+ it "test-case #156" $ [s|%2.4e|] (8.6 :: Double) @?= "8.6000e+00"+ it "test-case #157" $ [s|% 2.4e|] (8.6 :: Double) @?= " 8.6000e+00"+ it "test-case #159" $ [s|% 2.4e|] (-8.6 :: Double) @?= "-8.6000e+00"+ it "test-case #160" $ [s|%+2.4e|] (8.6 :: Double) @?= "+8.6000e+00"+ it "test-case #161" $ [s|%2.4g|] (8.6 :: Double) @?= "8.6"+ it "test-case #162" $ [s|%-i|] (-1 :: Int32) @?= "-1"+ it "test-case #163" $ [s|%-i|] (1 :: Int32) @?= "1"+ it "test-case #164" $ [s|%+i|] (1 :: Int32) @?= "+1"+ it "test-case #165" $ [s|%o|] (10 :: Int32) @?= "12"+ -- 166: excluded for Haskell+ -- 167: excluded for Haskell+ it "test-case #169" $ [s|%s|] "%%%%" @?= "%%%%"+ it "test-case #170" $ [s|%u|] (-1 :: Int32) @?= "4294967295"+ -- 171: excluded for Haskell+ -- 172: excluded for Haskell+ -- 173: excluded for Haskell+ -- 174: excluded for Haskell+ -- 176: excluded for Haskell+ it "test-case #177" $ [s|%%0|] @?= "%0"+ -- 178: excluded for Haskell+ -- unsound test: it "test-case #179" $ [s|%hhx|] 'a' @?= "61"+ it "test-case #181" $ [s|Hallo heimur|] @?= "Hallo heimur"+ it "test-case #182" $ [s|%s|] "Hallo heimur" @?= "Hallo heimur"+ it "test-case #183" $ [s|%d|] (1024 :: Int32) @?= "1024"+ it "test-case #184" $ [s|%d|] (-1024 :: Int32) @?= "-1024"+ it "test-case #185" $ [s|%i|] (1024 :: Int32) @?= "1024"+ it "test-case #186" $ [s|%i|] (-1024 :: Int32) @?= "-1024"+ it "test-case #187" $ [s|%u|] (1024 :: Int32) @?= "1024"+ it "test-case #188" $ [s|%u|] (4294966272 :: Word32) @?= "4294966272"+ it "test-case #189" $ [s|%o|] (511 :: Int32) @?= "777"+ it "test-case #190" $ [s|%o|] (4294966785 :: Word32) @?= "37777777001"+ it "test-case #191" $ [s|%x|] (305441741 :: Int32) @?= "1234abcd"+ it "test-case #192" $ [s|%x|] (3989525555 :: Word32) @?= "edcb5433"+ it "test-case #193" $ [s|%X|] (305441741 :: Int32) @?= "1234ABCD"+ it "test-case #194" $ [s|%X|] (3989525555 :: Word32) @?= "EDCB5433"+ it "test-case #195" $ [s|%c|] 'x' @?= "x"+ it "test-case #196" $ [s|%%|] @?= "%"+ it "test-case #197" $ [s|%+s|] "Hallo heimur" @?= "Hallo heimur"+ it "test-case #198" $ [s|%+d|] (1024 :: Int32) @?= "+1024"+ it "test-case #199" $ [s|%+d|] (-1024 :: Int32) @?= "-1024"+ it "test-case #200" $ [s|%+i|] (1024 :: Int32) @?= "+1024"+ it "test-case #201" $ [s|%+i|] (-1024 :: Int32) @?= "-1024"+ it "test-case #202" $ [s|%+u|] (1024 :: Int32) @?= "1024"+ it "test-case #203" $ [s|%+u|] (4294966272 :: Word32) @?= "4294966272"+ it "test-case #204" $ [s|%+o|] (511 :: Int32) @?= "777"+ it "test-case #205" $ [s|%+o|] (4294966785 :: Word32) @?= "37777777001"+ it "test-case #206" $ [s|%+x|] (305441741 :: Int32) @?= "1234abcd"+ it "test-case #207" $ [s|%+x|] (3989525555 :: Word32) @?= "edcb5433"+ it "test-case #208" $ [s|%+X|] (305441741 :: Int32) @?= "1234ABCD"+ it "test-case #209" $ [s|%+X|] (3989525555 :: Word32) @?= "EDCB5433"+ it "test-case #210" $ [s|%+c|] 'x' @?= "x"+ it "test-case #211" $ [s|% s|] "Hallo heimur" @?= "Hallo heimur"+ it "test-case #212" $ [s|% d|] (1024 :: Int32) @?= " 1024"+ it "test-case #213" $ [s|% d|] (-1024 :: Int32) @?= "-1024"+ it "test-case #214" $ [s|% i|] (1024 :: Int32) @?= " 1024"+ it "test-case #215" $ [s|% i|] (-1024 :: Int32) @?= "-1024"+ it "test-case #216" $ [s|% u|] (1024 :: Int32) @?= "1024"+ it "test-case #217" $ [s|% u|] (4294966272 :: Word32) @?= "4294966272"+ it "test-case #218" $ [s|% o|] (511 :: Int32) @?= "777"+ it "test-case #219" $ [s|% o|] (4294966785 :: Word32) @?= "37777777001"+ it "test-case #220" $ [s|% x|] (305441741 :: Int32) @?= "1234abcd"+ it "test-case #221" $ [s|% x|] (3989525555 :: Word32) @?= "edcb5433"+ it "test-case #222" $ [s|% X|] (305441741 :: Int32) @?= "1234ABCD"+ it "test-case #223" $ [s|% X|] (3989525555 :: Word32) @?= "EDCB5433"+ it "test-case #224" $ [s|% c|] 'x' @?= "x"+ it "test-case #225" $ [s|%+ s|] "Hallo heimur" @?= "Hallo heimur"+ it "test-case #226" $ [s|%+ d|] (1024 :: Int32) @?= "+1024"+ it "test-case #227" $ [s|%+ d|] (-1024 :: Int32) @?= "-1024"+ it "test-case #228" $ [s|%+ i|] (1024 :: Int32) @?= "+1024"+ it "test-case #229" $ [s|%+ i|] (-1024 :: Int32) @?= "-1024"+ it "test-case #230" $ [s|%+ u|] (1024 :: Int32) @?= "1024"+ it "test-case #231" $ [s|%+ u|] (4294966272 :: Word32) @?= "4294966272"+ it "test-case #232" $ [s|%+ o|] (511 :: Int32) @?= "777"+ it "test-case #233" $ [s|%+ o|] (4294966785 :: Word32) @?= "37777777001"+ it "test-case #234" $ [s|%+ x|] (305441741 :: Int32) @?= "1234abcd"+ it "test-case #235" $ [s|%+ x|] (3989525555 :: Word32) @?= "edcb5433"+ it "test-case #236" $ [s|%+ X|] (305441741 :: Int32) @?= "1234ABCD"+ it "test-case #237" $ [s|%+ X|] (3989525555 :: Word32) @?= "EDCB5433"+ it "test-case #238" $ [s|%+ c|] 'x' @?= "x"+ it "test-case #239" $ [s|%#o|] (511 :: Int32) @?= "0777"+ it "test-case #240" $ [s|%#o|] (4294966785 :: Word32) @?= "037777777001"+ it "test-case #241" $ [s|%#x|] (305441741 :: Int32) @?= "0x1234abcd"+ it "test-case #242" $ [s|%#x|] (3989525555 :: Word32) @?= "0xedcb5433"+ it "test-case #243" $ [s|%#X|] (305441741 :: Int32) @?= "0X1234ABCD"+ it "test-case #244" $ [s|%#X|] (3989525555 :: Word32) @?= "0XEDCB5433"+ it "test-case #245" $ [s|%#o|] (0 :: Word32) @?= "0"+ it "test-case #246" $ [s|%#x|] (0 :: Word32) @?= "0"+ it "test-case #247" $ [s|%#X|] (0 :: Word32) @?= "0"+ it "test-case #248" $ [s|%1s|] "Hallo heimur" @?= "Hallo heimur"+ it "test-case #249" $ [s|%1d|] (1024 :: Int32) @?= "1024"+ it "test-case #250" $ [s|%1d|] (-1024 :: Int32) @?= "-1024"+ it "test-case #251" $ [s|%1i|] (1024 :: Int32) @?= "1024"+ it "test-case #252" $ [s|%1i|] (-1024 :: Int32) @?= "-1024"+ it "test-case #253" $ [s|%1u|] (1024 :: Int32) @?= "1024"+ it "test-case #254" $ [s|%1u|] (4294966272 :: Word32) @?= "4294966272"+ it "test-case #255" $ [s|%1o|] (511 :: Int32) @?= "777"+ it "test-case #256" $ [s|%1o|] (4294966785 :: Word32) @?= "37777777001"+ it "test-case #257" $ [s|%1x|] (305441741 :: Int32) @?= "1234abcd"+ it "test-case #258" $ [s|%1x|] (3989525555 :: Word32) @?= "edcb5433"+ it "test-case #259" $ [s|%1X|] (305441741 :: Int32) @?= "1234ABCD"+ it "test-case #260" $ [s|%1X|] (3989525555 :: Word32) @?= "EDCB5433"+ it "test-case #261" $ [s|%1c|] 'x' @?= "x"+ it "test-case #262" $ [s|%20s|] "Hallo" @?= " Hallo"+ it "test-case #263" $ [s|%20d|] (1024 :: Int32) @?= " 1024"+ it "test-case #264" $ [s|%20d|] (-1024 :: Int32) @?= " -1024"+ it "test-case #265" $ [s|%20i|] (1024 :: Int32) @?= " 1024"+ it "test-case #266" $ [s|%20i|] (-1024 :: Int32) @?= " -1024"+ it "test-case #267" $ [s|%20u|] (1024 :: Int32) @?= " 1024"+ it "test-case #268" $ [s|%20u|] (4294966272 :: Word32) @?= " 4294966272"+ it "test-case #269" $ [s|%20o|] (511 :: Int32) @?= " 777"+ it "test-case #270" $ [s|%20o|] (4294966785 :: Word32) @?= " 37777777001"+ it "test-case #271" $ [s|%20x|] (305441741 :: Int32) @?= " 1234abcd"+ it "test-case #272" $ [s|%20x|] (3989525555 :: Word32) @?= " edcb5433"+ it "test-case #273" $ [s|%20X|] (305441741 :: Int32) @?= " 1234ABCD"+ it "test-case #274" $ [s|%20X|] (3989525555 :: Word32) @?= " EDCB5433"+ it "test-case #275" $ [s|%20c|] 'x' @?= " x"+ it "test-case #276" $ [s|%-20s|] "Hallo" @?= "Hallo "+ it "test-case #277" $ [s|%-20d|] (1024 :: Int32) @?= "1024 "+ it "test-case #278" $ [s|%-20d|] (-1024 :: Int32) @?= "-1024 "+ it "test-case #279" $ [s|%-20i|] (1024 :: Int32) @?= "1024 "+ it "test-case #280" $ [s|%-20i|] (-1024 :: Int32) @?= "-1024 "+ it "test-case #281" $ [s|%-20u|] (1024 :: Int32) @?= "1024 "+ it "test-case #282" $ [s|%-20u|] (4294966272 :: Word32) @?= "4294966272 "+ it "test-case #283" $ [s|%-20o|] (511 :: Int32) @?= "777 "+ it "test-case #284" $ [s|%-20o|] (4294966785 :: Word32) @?= "37777777001 "+ it "test-case #285" $ [s|%-20x|] (305441741 :: Int32) @?= "1234abcd "+ it "test-case #286" $ [s|%-20x|] (3989525555 :: Word32) @?= "edcb5433 "+ it "test-case #287" $ [s|%-20X|] (305441741 :: Int32) @?= "1234ABCD "+ it "test-case #288" $ [s|%-20X|] (3989525555 :: Word32) @?= "EDCB5433 "+ it "test-case #289" $ [s|%-20c|] 'x' @?= "x "+ it "test-case #290" $ [s|%020d|] (1024 :: Int32) @?= "00000000000000001024"+ it "test-case #291" $ [s|%020d|] (-1024 :: Int32) @?= "-0000000000000001024"+ it "test-case #292" $ [s|%020i|] (1024 :: Int32) @?= "00000000000000001024"+ it "test-case #293" $ [s|%020i|] (-1024 :: Int32) @?= "-0000000000000001024"+ it "test-case #294" $ [s|%020u|] (1024 :: Int32) @?= "00000000000000001024"+ it "test-case #295" $ [s|%020u|] (4294966272 :: Word32) @?= "00000000004294966272"+ it "test-case #296" $ [s|%020o|] (511 :: Int32) @?= "00000000000000000777"+ it "test-case #297" $ [s|%020o|] (4294966785 :: Word32) @?= "00000000037777777001"+ it "test-case #298" $ [s|%020x|] (305441741 :: Int32) @?= "0000000000001234abcd"+ it "test-case #299" $ [s|%020x|] (3989525555 :: Word32) @?= "000000000000edcb5433"+ it "test-case #300" $ [s|%020X|] (305441741 :: Int32) @?= "0000000000001234ABCD"+ it "test-case #301" $ [s|%020X|] (3989525555 :: Word32) @?= "000000000000EDCB5433"+ it "test-case #302" $ [s|%#20o|] (511 :: Int32) @?= " 0777"+ it "test-case #303" $ [s|%#20o|] (4294966785 :: Word32) @?= " 037777777001"+ it "test-case #304" $ [s|%#20x|] (305441741 :: Int32) @?= " 0x1234abcd"+ it "test-case #305" $ [s|%#20x|] (3989525555 :: Word32) @?= " 0xedcb5433"+ it "test-case #306" $ [s|%#20X|] (305441741 :: Int32) @?= " 0X1234ABCD"+ it "test-case #307" $ [s|%#20X|] (3989525555 :: Word32) @?= " 0XEDCB5433"+ it "test-case #308" $ [s|%#020o|] (511 :: Int32) @?= "00000000000000000777"+ it "test-case #309" $ [s|%#020o|] (4294966785 :: Word32) @?= "00000000037777777001"+ it "test-case #310" $ [s|%#020x|] (305441741 :: Int32) @?= "0x00000000001234abcd"+ it "test-case #311" $ [s|%#020x|] (3989525555 :: Word32) @?= "0x0000000000edcb5433"+ it "test-case #312" $ [s|%#020X|] (305441741 :: Int32) @?= "0X00000000001234ABCD"+ it "test-case #313" $ [s|%#020X|] (3989525555 :: Word32) @?= "0X0000000000EDCB5433"+ it "test-case #314" $ [s|%0-20s|] "Hallo" @?= "Hallo "+ it "test-case #315" $ [s|%0-20d|] (1024 :: Int32) @?= "1024 "+ it "test-case #316" $ [s|%0-20d|] (-1024 :: Int32) @?= "-1024 "+ it "test-case #317" $ [s|%0-20i|] (1024 :: Int32) @?= "1024 "+ it "test-case #318" $ [s|%0-20i|] (-1024 :: Int32) @?= "-1024 "+ it "test-case #319" $ [s|%0-20u|] (1024 :: Int32) @?= "1024 "+ it "test-case #320" $ [s|%0-20u|] (4294966272 :: Word32) @?= "4294966272 "+ it "test-case #321" $ [s|%-020o|] (511 :: Int32) @?= "777 "+ it "test-case #322" $ [s|%-020o|] (4294966785 :: Word32) @?= "37777777001 "+ it "test-case #323" $ [s|%-020x|] (305441741 :: Int32) @?= "1234abcd "+ it "test-case #324" $ [s|%-020x|] (3989525555 :: Word32) @?= "edcb5433 "+ it "test-case #325" $ [s|%-020X|] (305441741 :: Int32) @?= "1234ABCD "+ it "test-case #326" $ [s|%-020X|] (3989525555 :: Word32) @?= "EDCB5433 "+ it "test-case #327" $ [s|%-020c|] 'x' @?= "x "+ it "test-case #328" $ [s|%*s|] (20 :: Int32) "Hallo" @?= " Hallo"+ it "test-case #329" $+ [s|%*d|] (20 :: Int32) (1024 :: Int32) @?= " 1024"+ it "test-case #330" $+ [s|%*d|] (20 :: Int32) (-1024 :: Int32) @?= " -1024"+ it "test-case #331" $+ [s|%*i|] (20 :: Int32) (1024 :: Int32) @?= " 1024"+ it "test-case #332" $+ [s|%*i|] (20 :: Int32) (-1024 :: Int32) @?= " -1024"+ it "test-case #333" $+ [s|%*u|] (20 :: Int32) (1024 :: Int32) @?= " 1024"+ it "test-case #334" $+ [s|%*u|] (20 :: Int32) (4294966272 :: Word32) @?= " 4294966272"+ it "test-case #335" $ [s|%*o|] (20 :: Int32) (511 :: Int32) @?= " 777"+ it "test-case #336" $+ [s|%*o|] (20 :: Int32) (4294966785 :: Word32) @?= " 37777777001"+ it "test-case #337" $+ [s|%*x|] (20 :: Int32) (305441741 :: Int32) @?= " 1234abcd"+ it "test-case #338" $+ [s|%*x|] (20 :: Int32) (3989525555 :: Word32) @?= " edcb5433"+ it "test-case #339" $+ [s|%*X|] (20 :: Int32) (305441741 :: Int32) @?= " 1234ABCD"+ it "test-case #340" $+ [s|%*X|] (20 :: Int32) (3989525555 :: Word32) @?= " EDCB5433"+ it "test-case #341" $ [s|%*c|] (20 :: Int32) 'x' @?= " x"+ it "test-case #342" $ [s|%.20s|] "Hallo heimur" @?= "Hallo heimur"+ it "test-case #343" $ [s|%.20d|] (1024 :: Int32) @?= "00000000000000001024"+ it "test-case #344" $ [s|%.20d|] (-1024 :: Int32) @?= "-00000000000000001024"+ it "test-case #345" $ [s|%.20i|] (1024 :: Int32) @?= "00000000000000001024"+ it "test-case #346" $ [s|%.20i|] (-1024 :: Int32) @?= "-00000000000000001024"+ it "test-case #347" $ [s|%.20u|] (1024 :: Int32) @?= "00000000000000001024"+ it "test-case #348" $ [s|%.20u|] (4294966272 :: Word32) @?= "00000000004294966272"+ it "test-case #349" $ [s|%.20o|] (511 :: Int32) @?= "00000000000000000777"+ it "test-case #350" $ [s|%.20o|] (4294966785 :: Word32) @?= "00000000037777777001"+ it "test-case #351" $ [s|%.20x|] (305441741 :: Int32) @?= "0000000000001234abcd"+ it "test-case #352" $ [s|%.20x|] (3989525555 :: Word32) @?= "000000000000edcb5433"+ it "test-case #353" $ [s|%.20X|] (305441741 :: Int32) @?= "0000000000001234ABCD"+ it "test-case #354" $ [s|%.20X|] (3989525555 :: Word32) @?= "000000000000EDCB5433"+ it "test-case #355" $ [s|%20.5s|] "Hallo heimur" @?= " Hallo"+ it "test-case #356" $ [s|%20.5d|] (1024 :: Int32) @?= " 01024"+ it "test-case #357" $ [s|%20.5d|] (-1024 :: Int32) @?= " -01024"+ it "test-case #358" $ [s|%20.5i|] (1024 :: Int32) @?= " 01024"+ it "test-case #359" $ [s|%20.5i|] (-1024 :: Int32) @?= " -01024"+ it "test-case #360" $ [s|%20.5u|] (1024 :: Int32) @?= " 01024"+ it "test-case #361" $ [s|%20.5u|] (4294966272 :: Word32) @?= " 4294966272"+ it "test-case #362" $ [s|%20.5o|] (511 :: Int32) @?= " 00777"+ it "test-case #363" $ [s|%20.5o|] (4294966785 :: Word32) @?= " 37777777001"+ it "test-case #364" $ [s|%20.5x|] (305441741 :: Int32) @?= " 1234abcd"+ it "test-case #365" $ [s|%20.10x|] (3989525555 :: Word32) @?= " 00edcb5433"+ it "test-case #366" $ [s|%20.5X|] (305441741 :: Int32) @?= " 1234ABCD"+ it "test-case #367" $ [s|%20.10X|] (3989525555 :: Word32) @?= " 00EDCB5433"+ it "test-case #369" $ [s|%020.5d|] (1024 :: Int32) @?= " 01024"+ it "test-case #370" $ [s|%020.5d|] (-1024 :: Int32) @?= " -01024"+ it "test-case #371" $ [s|%020.5i|] (1024 :: Int32) @?= " 01024"+ it "test-case #372" $ [s|%020.5i|] (-1024 :: Int32) @?= " -01024"+ it "test-case #373" $ [s|%020.5u|] (1024 :: Int32) @?= " 01024"+ it "test-case #374" $ [s|%020.5u|] (4294966272 :: Word32) @?= " 4294966272"+ it "test-case #375" $ [s|%020.5o|] (511 :: Int32) @?= " 00777"+ it "test-case #376" $ [s|%020.5o|] (4294966785 :: Word32) @?= " 37777777001"+ it "test-case #377" $ [s|%020.5x|] (305441741 :: Int32) @?= " 1234abcd"+ it "test-case #378" $ [s|%020.10x|] (3989525555 :: Word32) @?= " 00edcb5433"+ it "test-case #379" $ [s|%020.5X|] (305441741 :: Int32) @?= " 1234ABCD"+ it "test-case #380" $ [s|%020.10X|] (3989525555 :: Word32) @?= " 00EDCB5433"+ it "test-case #381" $ [s|%.0s|] "Hallo heimur" @?= ""+ it "test-case #382" $ [s|%20.0s|] "Hallo heimur" @?= " "+ it "test-case #383" $ [s|%.s|] "Hallo heimur" @?= ""+ it "test-case #384" $ [s|%20.s|] "Hallo heimur" @?= " "+ it "test-case #385" $ [s|%20.0d|] (1024 :: Int32) @?= " 1024"+ it "test-case #386" $ [s|%20.d|] (-1024 :: Int32) @?= " -1024"+ it "test-case #387" $ [s|%20.d|] (0 :: Int32) @?= " "+ it "test-case #388" $ [s|%20.0i|] (1024 :: Int32) @?= " 1024"+ it "test-case #389" $ [s|%20.i|] (-1024 :: Int32) @?= " -1024"+ it "test-case #390" $ [s|%20.i|] (0 :: Int32) @?= " "+ it "test-case #391" $ [s|%20.u|] (1024 :: Int32) @?= " 1024"+ it "test-case #392" $ [s|%20.0u|] (4294966272 :: Word32) @?= " 4294966272"+ it "test-case #393" $ [s|%20.u|] (0 :: Word32) @?= " "+ it "test-case #394" $ [s|%20.o|] (511 :: Int32) @?= " 777"+ it "test-case #395" $ [s|%20.0o|] (4294966785 :: Word32) @?= " 37777777001"+ it "test-case #396" $ [s|%20.o|] (0 :: Word32) @?= " "+ it "test-case #397" $ [s|%20.x|] (305441741 :: Int32) @?= " 1234abcd"+ it "test-case #398" $ [s|%20.0x|] (3989525555 :: Word32) @?= " edcb5433"+ it "test-case #399" $ [s|%20.x|] (0 :: Word32) @?= " "+ it "test-case #400" $ [s|%20.X|] (305441741 :: Int32) @?= " 1234ABCD"+ it "test-case #401" $ [s|%20.0X|] (3989525555 :: Word32) @?= " EDCB5433"+ it "test-case #402" $ [s|%20.X|] (0 :: Word32) @?= " "+ it "test-case #403" $+ [s|% -0+*.*s|] (20 :: Int32) (5 :: Int32) "Hallo heimur" @?=+ "Hallo "+ it "test-case #404" $+ [s|% -0+*.*d|] (20 :: Int32) (5 :: Int32) (1024 :: Int32) @?=+ "+01024 "+ it "test-case #405" $+ [s|% -0+*.*d|] (20 :: Int32) (5 :: Int32) (-1024 :: Int32) @?=+ "-01024 "+ it "test-case #406" $+ [s|% -0+*.*i|] (20 :: Int32) (5 :: Int32) (1024 :: Int32) @?=+ "+01024 "+ it "test-case #407" $+ [s|% 0-+*.*i|] (20 :: Int32) (5 :: Int32) (-1024 :: Int32) @?=+ "-01024 "+ it "test-case #408" $+ [s|% 0-+*.*u|] (20 :: Int32) (5 :: Int32) (1024 :: Int32) @?=+ "01024 "+ it "test-case #409" $+ [s|% 0-+*.*u|] (20 :: Int32) (5 :: Int32) (4294966272 :: Word32) @?=+ "4294966272 "+ it "test-case #410" $+ [s|%+ -0*.*o|] (20 :: Int32) (5 :: Int32) (511 :: Int32) @?=+ "00777 "+ it "test-case #411" $+ [s|%+ -0*.*o|] (20 :: Int32) (5 :: Int32) (4294966785 :: Word32) @?=+ "37777777001 "+ it "test-case #412" $+ [s|%+ -0*.*x|] (20 :: Int32) (5 :: Int32) (305441741 :: Int32) @?=+ "1234abcd "+ it "test-case #413" $+ [s|%+ -0*.*x|] (20 :: Int32) (10 :: Int32) (3989525555 :: Word32) @?=+ "00edcb5433 "+ it "test-case #414" $+ [s|% -+0*.*X|] (20 :: Int32) (5 :: Int32) (305441741 :: Int32) @?=+ "1234ABCD "+ it "test-case #415" $+ [s|% -+0*.*X|] (20 :: Int32) (10 :: Int32) (3989525555 :: Word32) @?=+ "00EDCB5433 "+ it "test-case #416" $ [s|%*sx|] (-3 :: Int32) "hi" @?= "hi x"
+ tests/printf/format.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -Wwarn #-}++module Main where++import qualified Data.Text as S+import qualified Data.Text.Lazy as L+import Foreign.Ptr+import GeneratedSpec+import Language.Haskell.Printf+import Test.HUnit+import Test.Hspec++main :: IO ()+main = hspec $ describe "th-printf" $ do+ GeneratedSpec.spec+ it "text" $ do+ -- sanity checking that text can be rendered+ -- all the actual string formatting is in GeneratedSpec+ [s|Hello, %Q!|] (S.pack "world") @?= "Hello, world!"+ [s|Hello, %q!|] (L.pack "world") @?= "Hello, world!"+ it "hexadecimal float" $ do+ [s|%a|] 0.857421875 @?= "0x1.b7p-1"+ [s|%A|] 3.1415926 @?= "0X1.921FB4D12D84AP+1"+ [s|%.3a|] 1.999999999 @?= "0x1.000p+1"+ [s|%.0a|] 1.999999999 @?= "0x1p+1"+ [s|%#.0a|] 1.999999999 @?= "0x1.p+1"+ [s|%.3a|] 0.7576 @?= "0x1.83ep-1"+ [s|%015.3a|] 0.7576 @?= "0x000001.83ep-1"+ [s|% 15.3a|] 0.7576 @?= " 0x1.83ep-1"+ it "Show instances" $ do+ [s|%?|] () @?= "()"+ [s|%10?|] () @?= " ()"+ it "pointer" $ do+ [s|%p|] nullPtr @?= "0x0"+ [s|%15p|] fakePtr @?= " 0xdeadbeef"+ -- sign flag does nothing+ [s|%+p|] fakePtr @?= "0xdeadbeef"+ -- prefix flag does nothing+ [s|%#p|] fakePtr @?= "0xdeadbeef"+ -- zero flag does nothing+ [s|%015p|] fakePtr @?= " 0xdeadbeef"+ -- left-pad flag does nothing+ [s|%-15p|] fakePtr @?= " 0xdeadbeef"++fakePtr :: Ptr ()+fakePtr = nullPtr `plusPtr` 0xdeadbeef
th-printf.cabal view
@@ -1,34 +1,90 @@-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+cabal-version: 1.12 -library- hs-source-dirs: src- exposed-modules: Text.Printf.TH- build-depends: base <4.10- , attoparsec- , bytestring- , template-haskell- , text- , transformers- default-language: Haskell2010+-- This file has been generated from package.yaml by hpack version 0.35.3.+--+-- see: https://github.com/sol/hpack+--+-- hash: 7e86d199e67bceb4c613b25421b603adc41dcb4508283966e741b036d0075e3d +name: th-printf+version: 0.8+synopsis: Quasiquoters for printf+description: Quasiquoters for string and text printf+category: Text+homepage: https://github.com/pikajude/th-printf#readme+bug-reports: https://github.com/pikajude/th-printf/issues+author: Jude Taylor+maintainer: me@jude.xyz+license: MIT+license-file: LICENSE+tested-with:+ GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.7, GHC == 9.4.5, GHC == 9.6.2+build-type: Simple+extra-source-files:+ CHANGELOG.md+ source-repository head type: git- location: git://github.com/joelteon/th-printf.git+ location: https://github.com/pikajude/th-printf +flag werror+ description: Build with -Werror+ manual: True+ default: False++library+ exposed-modules:+ Language.Haskell.Printf+ Language.Haskell.Printf.Lib+ other-modules:+ Buf+ Language.Haskell.Printf.Geometry+ Language.Haskell.Printf.Printers+ Language.Haskell.PrintfArg+ NumUtils+ StrUtils+ Parser+ Parser.Types+ Paths_th_printf+ hs-source-dirs:+ src+ parser+ ghc-options: -Wall+ build-depends:+ base >=4.12 && <5+ , charset+ , containers+ , dlist+ , integer-logarithms+ , microlens-platform+ , mtl+ , parsec+ , semigroups+ , template-haskell+ , text+ , th-lift+ , transformers+ default-language: Haskell2010+ if flag(werror)+ ghc-options: -Werror+ 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+ other-modules:+ GeneratedSpec+ Paths_th_printf+ hs-source-dirs:+ tests/printf+ ghc-options: -Wall -fno-warn-type-defaults+ build-depends:+ HUnit+ , QuickCheck+ , base >=4.12 && <5+ , hspec+ , template-haskell+ , text+ , th-printf+ default-language: Haskell2010+ if flag(werror)+ ghc-options: -Werror