th-printf 0.7 → 0.8
raw patch · 16 files changed
+745/−683 lines, 16 filesdep −hspec-coredep −primitivedep ~basedep ~mtlsetup-changed
Dependencies removed: hspec-core, primitive
Dependency ranges changed: base, mtl
Files
- CHANGELOG.md +16/−11
- Setup.hs +0/−2
- include/compat-defs.h +0/−5
- parser/Parser.hs +77/−87
- parser/Parser/Types.hs +98/−76
- src/Buf.hs +76/−0
- src/Buildable.hs +0/−76
- src/Language/Haskell/Printf.hs +83/−79
- src/Language/Haskell/Printf/Geometry.hs +48/−40
- src/Language/Haskell/Printf/Lib.hs +63/−59
- src/Language/Haskell/Printf/Printers.hs +138/−109
- src/Language/Haskell/PrintfArg.hs +16/−11
- src/NumUtils.hs +98/−88
- src/StrUtils.hs +14/−11
- tests/printf/format.hs +8/−8
- th-printf.cabal +10/−21
CHANGELOG.md view
@@ -1,21 +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+- 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+- 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 + - 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.+- 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+- 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
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− include/compat-defs.h
@@ -1,5 +0,0 @@-#if __GLASGOW_HASKELL__ >= 840-#define MONOID_HEAD Monoid a-#else-#define MONOID_HEAD (Semigroup a, Monoid a)-#endif
parser/Parser.hs view
@@ -1,35 +1,36 @@-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE NoMonomorphismRestriction #-} module Parser where -import Control.Applicative-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 )+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"+ 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, [])@@ -38,16 +39,16 @@ (_, 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 ()+ 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@@ -55,32 +56,33 @@ flags_ . lens' .= good tell [ "`"- ++ [flagName]- ++ "` flag has no effect on `"- ++ [c]- ++ "` specifier"+ ++ [flagName]+ ++ "` flag has no effect on `"+ ++ [c]+ ++ "` specifier" ]- warnSign = warnFlag signed_ True False '+'+ warnSign = warnFlag signed_ True False '+' warnPrefix = warnFlag prefixed_ True False '#'- warnSpace = warnFlag spaced_ True False ' '- warnZero = warnFlag adjustment_ (Just ZeroPadded) Nothing '0'+ 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"- ]+ 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@@ -91,32 +93,29 @@ lengthSpecifiers :: [(String, LengthSpecifier)] lengthSpecifiers =- [ ("hh", DoubleH)- , ("h" , H)- , ("ll", DoubleL)- , ("l" , L)- , ("j" , J)- , ("z" , Z)- , ("t" , T)- , ("L" , BigL)+ [ ("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 = do- atoms <- many $ choice- [Str "%" <$ try (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 [] = []+printfStr =+ many $+ Str "%" <$ try (string "%%")+ <|> Arg <$> fmtArg+ <|> Str <$> some (satisfy (/= '%')) fmtArg :: Stream s m Char => ParsecT s u m FormatArg fmtArg = do- char '%'+ _ <- char '%' flags <- do fs <- many $ do c <- oneOfSet flagSet <?> "flag"@@ -126,28 +125,19 @@ ' ' -> FlagSpaced '#' -> FlagPrefixed '0' -> FlagZeroPadded- _ -> error "???"+ _ -> error "unreachable" let flagSet' = S.fromList fs if S.size flagSet' < length fs then fail "Duplicate flags specified" else pure $ toFlagSet flagSet'- width <- optionMaybe (choice [Given <$> nat, Need <$ char '*']) <?> "width"- precision <-- optionMaybe- (do- char '.'- optionMaybe $ choice [Given <$> nat, Need <$ char '*']- )- <?> "precision"- lengthSpec <- optionMaybe $ choice $ Prelude.map (\(a, b) -> b <$ string a)- lengthSpecifiers+ 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+ 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
@@ -1,82 +1,104 @@-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TemplateHaskell #-} -module Parser.Types where+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 qualified Data.Set as S-import Data.Set ( Set )-import Language.Haskell.TH.Lift-import Lens.Micro.Platform-import Prelude hiding ( elem- , notElem- )+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)+ = Arg FormatArg+ | Str String+ deriving (Show) data LengthSpecifier- = DoubleH- | H- | DoubleL- | BigL- | L- | J- | Z- | T- deriving (Eq)+ = HH+ | H+ | BigL+ | LL+ | L+ | J+ | Z+ | T+ deriving (Eq) instance Show LengthSpecifier where- show DoubleH = "hh"- show H = "h"- show DoubleL = "ll"- show BigL = "L"- show L = "l"- show J = "j"- show Z = "z"- show T = "t"+ 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)+ = FlagLJust+ | FlagSigned+ | FlagSpaced+ | FlagPrefixed+ | FlagZeroPadded+ deriving (Show, Eq, Ord) adjustmentFlags :: Set Flag adjustmentFlags = S.fromList [FlagLJust, FlagZeroPadded] data Adjustment- = LeftJustified- | ZeroPadded- deriving (Show, Eq)+ = LeftJustified+ | ZeroPadded+ deriving (Show, Eq) data MaySpecify- = Given Integer- | Need- deriving (Show)+ = Given Integer+ | Need+ deriving (Show) data FormatArg = FormatArg- { flags :: FlagSet- , width :: Maybe MaySpecify- , precision :: Maybe MaySpecify- , spec :: Char- , lengthSpec :: Maybe LengthSpecifier- } deriving (Show)+ { 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)+ { adjustment :: Maybe Adjustment+ , signed :: Bool+ , spaced :: Bool+ , prefixed :: Bool+ }+ deriving (Show) emptyFlagSet :: FlagSet emptyFlagSet = FlagSet Nothing False False False@@ -84,30 +106,30 @@ 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- }+ 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+ [ ("adjustment", "adjustment_")+ , ("signed", "signed_")+ , ("spaced", "spaced_")+ , ("prefixed", "prefixed_")+ ]+ ''FlagSet makeLensesFor- [ ("flags", "flags_")- , ("width", "width_")- , ("precision", "precision_")- , ("spec", "spec_")- , ("lengthSpec", "lengthSpec_")- ]- ''FormatArg+ [ ("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/Buildable.hs
@@ -1,76 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}--module Buildable where--import Data.String-import qualified Data.DList as D-import Data.Char ( intToDigit )-import Data.Text.Lazy ( Text )-import qualified Data.Text.Lazy.Builder as T-import qualified Data.Text.Lazy.Builder.Int as T-import Data.Semigroup ( Semigroup(..) )-import qualified Data.Text.Lazy as L-import qualified Data.Text as S--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_HEAD => Monoid (Sized a) where- mempty = Sized (mempty, 0)- mappend = (<>)- {-# INLINE mappend #-}--class MONOID_HEAD => Buildable a where- type Output a :: *-- 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 Buildable 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 Buildable 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
@@ -1,70 +1,71 @@-{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE QuasiQuotes #-} --- | "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)--- "4294967295"------ 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+{- | "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. -import Control.Applicative ( pure )-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 )+Note that, to maintain consistency with other printf implementations, negative ints+that are printed as unsigned will \"underflow\". (Text.Printf does this too.) --- | @--- ['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|%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@@ -76,31 +77,34 @@ (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 ()--- @+{- | 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 ()--- @+{- | 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"+ 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"- }+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
@@ -1,59 +1,67 @@-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} -module Language.Haskell.Printf.Geometry where+module Language.Haskell.Printf.Geometry (+ sign',+ padDecimal,+ prefix,+ fromPrintfArg,+ formatOne,+ Value (..),+) where -import Control.Applicative ( (<$>) )-import Control.Monad-import Data.Maybe-import Data.Monoid ( mempty )-import Data.Semigroup ( (<>) )-import Language.Haskell.PrintfArg-import Parser.Types ( Adjustment(..) )+import Control.Monad+import Data.Maybe+import Language.Haskell.PrintfArg+import Parser.Types (Adjustment (..)) -import qualified Buildable as B-import StrUtils+import Buf+import StrUtils data Value buf = Value- { valArg :: PrintfArg buf- , valPrefix :: Maybe buf- , valSign :: Maybe buf- } deriving (Show)+ { valArg :: PrintfArg buf+ , valPrefix :: Maybe buf+ , valSign :: Maybe buf+ }+ deriving (Show) -sign' :: (Num n, Ord n, B.Buildable buf) => PrintfArg n -> Maybe buf-sign' pf | value pf < 0 = Just (B.singleton '-')- | spaced pf = Just (B.singleton ' ')- | signed pf = Just (B.singleton '+')- | otherwise = Nothing+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 :: (B.Buildable 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)+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, B.Buildable buf) => buf -> PrintfArg n -> Maybe buf+prefix :: (Num n, Eq n, Buf buf) => buf -> PrintfArg n -> Maybe buf prefix s pf = guard (prefixed pf && value pf /= 0) >> Just s -fromPrintfArg- :: B.Buildable buf- => (n -> buf)- -> (PrintfArg n -> Maybe buf)- -> (PrintfArg n -> Maybe buf)- -> PrintfArg n- -> Value buf+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 :: B.Buildable buf => Value buf -> buf-formatOne Value {..}+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 - B.size prefix') '0' text+ Just ZeroPadded+ | isn'tDecimal || isNothing (prec valArg) ->+ prefix' <> justifyRight (w - size prefix') '0' text Just LeftJustified -> justifyLeft w ' ' (prefix' <> text)- _ -> justify' w (prefix' <> text)- | otherwise = error "unreachable"+ _ -> justify' w (prefix' <> text) where isn'tDecimal = fieldSpec valArg `notElem` ("diouxX" :: String)- justify' n | n < 0 = justifyLeft (abs n) ' '- | otherwise = justifyRight n ' '+ justify' n+ | n < 0 = justifyLeft (abs n) ' '+ | otherwise = justifyRight n ' ' prefix' = fromMaybe mempty valSign <> fromMaybe mempty valPrefix- text = value valArg+ text = value valArg
src/Language/Haskell/Printf/Lib.hs view
@@ -1,82 +1,86 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-} -module Language.Haskell.Printf.Lib- ( toSplices- , OutputType (..)- )-where+module Language.Haskell.Printf.Lib (+ toSplices,+ OutputType (..),+) where -import Control.Applicative ( (<$>)- , pure- )-import Data.Maybe-import Data.Semigroup ( (<>) )-import Data.String ( fromString )-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 GHC.Generics ( Generic )+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 Parser ( parseStr )-import Parser.Types hiding ( lengthSpec- , width- )-import Buildable ( finalize- , SizedStr- , SizedBuilder- )+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.+{- | 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+ Left x -> fail $ show x Right (y, warns) -> do mapM_ (qReport False) (concat warns)- (lhss, rhss) <- unzip <$> mapM extractExpr y- rhss' <- appE- [|finalize|]- (sigE (foldr1 (\x y' -> infixApp x [|(<>)|] y') rhss) otype)+ (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|]+ 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"+ 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') }|]- )+ [|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@@ -84,7 +88,7 @@ a <- newName "arg" pure (Just a, [|Just (fromInteger (fromIntegral $(varE a)))|]) Just (Given n') -> pure (Nothing, [|Just $(litE $ integerL n')|])- Nothing -> pure (Nothing, [|Nothing|])+ Nothing -> pure (Nothing, [|Nothing|]) formatter = case spec' of 's' -> [|Printers.printfString|] 'q' -> [|Printers.printfLazyText|]@@ -106,4 +110,4 @@ 'G' -> [|Printers.printfGeneric True|] 'a' -> [|Printers.printfFloatHex False|] 'A' -> [|Printers.printfFloatHex True|]- _ -> undefined+ _ -> undefined
src/Language/Haskell/Printf/Printers.hs view
@@ -1,100 +1,111 @@-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-} module Language.Haskell.Printf.Printers where -import Control.Applicative ( (<$>) )-import Data.Char-import Data.String ( fromString )-import Data.Maybe ( fromMaybe )-import Foreign.Ptr-import GHC.Float ( FFFormat(..) )-import Language.Haskell.Printf.Geometry-import Language.Haskell.PrintfArg-import qualified Data.Text.Lazy as L-import qualified Data.Text as S-import Math.NumberTheory.Logarithms+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 NumUtils-import qualified Parser.Types as P-import qualified Buildable as B+import Buf+import NumUtils+import qualified Parser.Types as P type Printer n buf = PrintfArg n -> Value buf -printfString :: B.Buildable buf => Printer String buf-printfString spec = Value- { valArg = case prec spec of- Nothing -> B.str <$> spec- Just c -> B.str . take c <$> spec- , valPrefix = Nothing- , valSign = Nothing- }+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 :: B.Buildable buf => Printer S.Text buf-printfStrictText spec = Value- { valArg = case prec spec of- Nothing -> B.sText <$> spec- Just c -> B.sText . S.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 :: B.Buildable buf => Printer L.Text buf-printfLazyText spec = Value- { valArg = case prec spec of- Nothing -> B.lText <$> spec- Just c -> B.lText . L.take (fromIntegral 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 :: (B.Buildable buf, Show a) => Printer a buf+printfShow :: (Buf buf, Show a) => Printer a buf printfShow spec = printfString (fromString . show <$> spec) -printfChar :: B.Buildable buf => Printer Char buf-printfChar spec = Value { valArg = B.singleton <$> spec- , valPrefix = Nothing- , valSign = Nothing- }+printfChar :: (Buf buf) => Printer Char buf+printfChar spec =+ Value+ { valArg = singleton <$> spec+ , valPrefix = Nothing+ , valSign = Nothing+ } {-# ANN printfPtr ("HLint: ignore Use showHex" :: String) #-}-printfPtr :: B.Buildable 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 (B.str "0x")- , valSign = Nothing- }+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 spec = Value- { valArg = padDecimal spec . showIntAtBase 10 intToDigit . abs <$> spec- , valPrefix = Nothing- , valSign = sign' spec- }+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, B.Buildable 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- }+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)+ 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@@ -118,54 +129,72 @@ -- in octal, when combining prefix and padding, the prefix -- must eat the first padding char {-# ANN printfOctal ("HLint: ignore Use showOct" :: String) #-}-printfOctal spec = fmtUnsigned- (showIntAtBase 8 intToDigit)- (\y -> if shouldUnpad then Nothing else prefix "0" y)- spec+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+ shouldUnpad = prefixed spec && fromMaybe 0 (prec spec) > expectedWidth -printfFloating upperFlag spec = Value { valArg = showFloat . abs <$> spec- , valPrefix = Nothing- , valSign = sign' spec- }+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+ _ -> Nothing showFloat = formatRealFloatAlt FFFixed precision (prefixed spec) upperFlag -printfScientific upperFlag spec = Value { valArg = showSci . abs <$> spec- , valPrefix = Nothing- , valSign = sign' spec- }+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+ showSci =+ formatRealFloatAlt+ FFExponent+ (fromIntegral <$> prec spec)+ (prefixed spec)+ upperFlag -printfGeneric upperFlag spec = Value { valArg = showSci . abs <$> spec- , valPrefix = Nothing- , valSign = sign' spec- }+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+ showSci =+ formatRealFloatAlt+ FFGeneric+ (fromIntegral <$> prec spec)+ (prefixed spec)+ upperFlag -printfFloatHex upperFlag spec = Value- { valArg = showHexFloat . abs <$> spec- , valPrefix = Just (if upperFlag then "0X" else "0x")- , valSign = sign' spec- }+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+clampUnsigned x+ | x < 0 = toInteger x + (-2 * toInteger (minBound `asTypeOf` x))+ | otherwise = toInteger x
src/Language/Haskell/PrintfArg.hs view
@@ -1,24 +1,29 @@ {-# LANGUAGE DeriveFunctor #-} -module Language.Haskell.PrintfArg where+module Language.Haskell.PrintfArg (+ PrintfArg (..),+ adjustment,+ signed,+ spaced,+ prefixed,+) where -import qualified Parser.Types as P+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)+ { 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
@@ -1,134 +1,144 @@-{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} {-# LANGUAGE NoMonomorphismRestriction #-} -module NumUtils where+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 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 qualified Buildable as B-import StrUtils+import Buf+import StrUtils -showIntAtBase- :: (B.Buildable 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+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' = B.cons (toChr (fromIntegral d)) r+ where+ r' = cons (toChr (fromIntegral d)) r -formatRealFloatAlt- :: (B.Buildable buf, RealFloat a)- => FFFormat- -> Maybe Int- -> Bool- -> Bool- -> a- -> buf+formatRealFloatAlt ::+ (Buf buf, RealFloat a) =>+ FFFormat ->+ Maybe Int ->+ Bool ->+ Bool ->+ a ->+ buf formatRealFloatAlt fmt decs forceDot upper x- | isNaN x = B.str "NaN"- | isInfinite x = B.str $ if x < 0 then "-Infinity" else "Infinity"- | x < 0 || isNegativeZero x = B.cons- '-'- (doFmt fmt (floatToDigits 10 (-x)) False)+ | 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'+ 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 B.singleton '.' else mempty)- | null whole- = B.str "0." <> fromDigits False part- | otherwise- = fromDigits False whole <> B.singleton '.' <> fromDigits False part+ | 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 = B.str "0.e+00"- | otherwise = B.str "0e+00"+ doFmt FFExponent ([0], _) _+ | forceDot = str "0.e+00"+ | otherwise = str "0e+00" doFmt FFExponent (digs, exp) fullRounding =- shownDigs <> B.cons eChar shownExponent+ shownDigs <> cons eChar shownExponent where shownDigs = case digs' of [] -> undefined [x'] ->- B.cons (intToDigit x') (if forceDot then B.singleton '.' else mempty)- (x' : xs) -> B.cons (intToDigit x') (B.cons '.' (fromDigits False xs))+ 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+ 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 =- B.cons (if exp' < 0 then '-' else '+')- $ justifyRight 2 '0'- $ showIntAtBase 10 intToDigit- $ abs exp'+ cons (if exp' < 0 then '-' else '+') $+ justifyRight 2 '0' $+ showIntAtBase 10 intToDigit $+ abs exp' doFmt FFGeneric d _ =- minimumBy (comparing B.size) [doFmt FFFixed d True, doFmt FFExponent d True]+ 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 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+ (overflow, digs') =+ roundTo+ 10+ (if fullRounding && prec > exp then min (length digs) prec else prec + exp)+ digs -fromDigits :: B.Buildable buf => Bool -> [Int] -> buf+fromDigits :: (Buf buf) => Bool -> [Int] -> buf fromDigits upper =- foldr (B.cons . (if upper then toUpper else id) . intToDigit) mempty+ foldr (cons . (if upper then toUpper else id) . intToDigit) mempty -formatHexFloat- :: (B.Buildable buf, RealFloat a) => Maybe Int -> Bool -> Bool -> a -> buf+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) = B.cons '0' (B.cons pChar (B.str "+0"))+ 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) =- B.str "1"- <> (if not (null hexDigits) || alt then B.singleton '.' else mempty)- <> fromDigits upper hexDigits- <> B.singleton pChar- <> (if exp > 0 then B.singleton '+' else mempty)- <> B.str (show (exp - 1 + overflow))+ 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+ hexDigits' = go bits (overflow, hexDigits) = case decs of Just n -> case roundTo 16 n hexDigits' of (1, _ : digs) -> (1, digs)- x' -> x'+ 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 [] = []+ go [a, b] = go [a, b, 0, 0]+ go [a] = go [a, 0, 0, 0]+ go [] = []
src/StrUtils.hs view
@@ -1,14 +1,17 @@-module StrUtils where+module StrUtils (justifyLeft, justifyRight) where -import Data.Semigroup ( (<>) )-import Buildable+import Buf -justifyLeft :: Buildable a => Int -> Char -> a -> a-justifyLeft n c s | diff <= 0 = s- | otherwise = s <> repeatN diff c- where diff = n - size s+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 :: Buildable a => Int -> Char -> a -> a-justifyRight n c s | diff <= 0 = s- | otherwise = repeatN diff c <> s- 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
tests/printf/format.hs view
@@ -1,15 +1,15 @@-{-# OPTIONS_GHC -Wwarn #-} {-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -Wwarn #-} module Main where -import Foreign.Ptr-import GeneratedSpec-import Language.Haskell.Printf-import Test.HUnit-import Test.Hspec-import qualified Data.Text as S-import qualified Data.Text.Lazy as L+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
th-printf.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.32.0.+-- This file has been generated from package.yaml by hpack version 0.35.3. -- -- see: https://github.com/sol/hpack ----- hash: 62c8df7d3174235654f8edabd47054d66b3551339b9b409b40da4d405dd12733+-- hash: 7e86d199e67bceb4c613b25421b603adc41dcb4508283966e741b036d0075e3d name: th-printf-version: 0.7+version: 0.8 synopsis: Quasiquoters for printf description: Quasiquoters for string and text printf category: Text@@ -17,11 +17,11 @@ maintainer: me@jude.xyz license: MIT license-file: LICENSE-tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.1+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- include/compat-defs.h source-repository head type: git@@ -37,7 +37,7 @@ Language.Haskell.Printf Language.Haskell.Printf.Lib other-modules:- Buildable+ Buf Language.Haskell.Printf.Geometry Language.Haskell.Printf.Printers Language.Haskell.PrintfArg@@ -49,11 +49,9 @@ hs-source-dirs: src parser- default-extensions: CPP ghc-options: -Wall- cpp-options: -include include/compat-defs.h build-depends:- base ==4.*+ base >=4.12 && <5 , charset , containers , dlist@@ -66,12 +64,9 @@ , text , th-lift , transformers- if impl(ghcjs)- build-depends:- primitive ==0.6.3.0+ default-language: Haskell2010 if flag(werror) ghc-options: -Werror- default-language: Haskell2010 test-suite format type: exitcode-stdio-1.0@@ -85,17 +80,11 @@ build-depends: HUnit , QuickCheck- , base ==4.*+ , base >=4.12 && <5 , hspec , template-haskell , text , th-printf- if impl(ghcjs)- build-depends:- primitive ==0.6.3.0+ default-language: Haskell2010 if flag(werror) ghc-options: -Werror- if impl(ghcjs)- build-depends:- hspec-core ==2.4.8- default-language: Haskell2010