diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/include/compat-defs.h b/include/compat-defs.h deleted file mode 100644 --- a/include/compat-defs.h +++ /dev/null @@ -1,5 +0,0 @@ -#if __GLASGOW_HASKELL__ >= 840 -#define MONOID_HEAD Monoid a -#else -#define MONOID_HEAD (Semigroup a, Monoid a) -#endif diff --git a/parser/Parser.hs b/parser/Parser.hs --- a/parser/Parser.hs +++ b/parser/Parser.hs @@ -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 '*') diff --git a/parser/Parser/Types.hs b/parser/Parser/Types.hs --- a/parser/Parser/Types.hs +++ b/parser/Parser/Types.hs @@ -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] diff --git a/src/Buf.hs b/src/Buf.hs new file mode 100644 --- /dev/null +++ b/src/Buf.hs @@ -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 diff --git a/src/Buildable.hs b/src/Buildable.hs deleted file mode 100644 --- a/src/Buildable.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Printf.hs b/src/Language/Haskell/Printf.hs --- a/src/Language/Haskell/Printf.hs +++ b/src/Language/Haskell/Printf.hs @@ -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 --- , 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 +, 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" + } diff --git a/src/Language/Haskell/Printf/Geometry.hs b/src/Language/Haskell/Printf/Geometry.hs --- a/src/Language/Haskell/Printf/Geometry.hs +++ b/src/Language/Haskell/Printf/Geometry.hs @@ -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 diff --git a/src/Language/Haskell/Printf/Lib.hs b/src/Language/Haskell/Printf/Lib.hs --- a/src/Language/Haskell/Printf/Lib.hs +++ b/src/Language/Haskell/Printf/Lib.hs @@ -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 diff --git a/src/Language/Haskell/Printf/Printers.hs b/src/Language/Haskell/Printf/Printers.hs --- a/src/Language/Haskell/Printf/Printers.hs +++ b/src/Language/Haskell/Printf/Printers.hs @@ -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 diff --git a/src/Language/Haskell/PrintfArg.hs b/src/Language/Haskell/PrintfArg.hs --- a/src/Language/Haskell/PrintfArg.hs +++ b/src/Language/Haskell/PrintfArg.hs @@ -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 diff --git a/src/NumUtils.hs b/src/NumUtils.hs --- a/src/NumUtils.hs +++ b/src/NumUtils.hs @@ -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 [] = [] diff --git a/src/StrUtils.hs b/src/StrUtils.hs --- a/src/StrUtils.hs +++ b/src/StrUtils.hs @@ -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 diff --git a/tests/printf/format.hs b/tests/printf/format.hs --- a/tests/printf/format.hs +++ b/tests/printf/format.hs @@ -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 diff --git a/th-printf.cabal b/th-printf.cabal --- a/th-printf.cabal +++ b/th-printf.cabal @@ -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