th-printf 0.4.0 → 0.5.0
raw patch · 7 files changed
+230/−43 lines, 7 filesnew-uploader
Files
- src/NumericUtils.hs +143/−3
- src/Text/Printf/TH.hs +9/−11
- src/Text/Printf/TH/Parser.hs +1/−1
- src/Text/Printf/TH/Printer.hs +43/−8
- src/Text/Printf/TH/Printer/String.hs +19/−11
- tests/Codegen.hs +13/−7
- th-printf.cabal +2/−2
src/NumericUtils.hs view
@@ -1,15 +1,22 @@ {-# Language MagicHash #-}-module NumericUtils (module NumericUtils, intToDigit) where +module NumericUtils+ ( module NumericUtils+ , intToDigit+ , FFFormat(..)+ ) where+ import Data.Char import GHC.Base+import GHC.Float (FFFormat(..), roundTo)+import Numeric (floatToDigits) import Text.Printf.TH.Printer intToDigitUpper :: Int -> Char intToDigitUpper (I# i)- | isTrue# (i >=# 0#) && isTrue# (i <=# 9#) = unsafeChr (ord '0' + I# i)+ | isTrue# (i >=# 0#) && isTrue# (i <=# 9#) = unsafeChr (ord '0' + I# i) | isTrue# (i >=# 10#) && isTrue# (i <=# 15#) = unsafeChr (ord 'A' + I# i - 10)- | otherwise = error ("Char.intToDigit: not a digit " ++ show (I# i))+ | otherwise = error ("Char.intToDigit: not a digit " ++ show (I# i)) showIntAtBase :: (Integral i, Monoid b, Printer b) => i -> (Int -> Char) -> i -> b showIntAtBase base toB n0 = showIt (quotRem n0 base) mempty@@ -20,3 +27,136 @@ _ -> showIt (quotRem n base) r' where r' = cons (toB $ fromIntegral d) r++-- based on GHC.Float.formatRealFloatAlt, except this adds an uppercasing+-- flag and "fixes" (imo) the (Just 0) precision case+formatRealFloatAlt :: RealFloat a => FFFormat -> Maybe Int -> Bool -> Bool -> a -> String+formatRealFloatAlt fmt decs alt upper x+ | isNaN x = "NaN"+ | isInfinite x =+ if x < 0+ then "-Infinity"+ else "Infinity"+ | x < 0 || isNegativeZero x = '-' : doFmt fmt (floatToDigits (toInteger base) (-x))+ | otherwise = doFmt fmt (floatToDigits (toInteger base) x)+ where+ eChar+ | upper = 'E'+ | otherwise = 'e'+ base = 10+ doFmt format (is, e) =+ let ds = map intToDigit is+ in case format of+ FFGeneric ->+ let alt1 = doFmt FFExponent (is, e)+ alt2 = doFmt FFFixed (is, e)+ in if length alt2 > length alt1+ then alt1+ else alt2+ FFExponent ->+ case decs of+ Nothing ->+ let show_e' = show (e - 1)+ in case ds of+ "0" -> "0.0" ++ (eChar : "0")+ [d] -> d : ".0" ++ [eChar] ++ show_e'+ (d:ds') -> d : '.' : ds' ++ [eChar] ++ show_e'+ [] -> error "formatRealFloat/doFmt/FFExponent: []"+ Just dec ->+ let dec' = max dec 0+ in case is of+ [0] ->+ (if dec' == 0+ then "0"+ else "0.") +++ take dec' (repeat '0') ++ (eChar : "0")+ _ ->+ let (ei, is') = roundTo base (dec' + 1) is+ (d:ds') =+ map+ intToDigit+ (if ei > 0+ then init is'+ else is')+ in (if null ds' && not alt+ then [d]+ else d : ".") +++ ds' ++ eChar : show (e - 1 + ei)+ FFFixed ->+ let mk0 ls =+ case ls of+ "" -> "0"+ _ -> ls+ in case decs of+ Nothing+ | e <= 0 -> "0." ++ replicate (-e) '0' ++ ds+ | otherwise ->+ let f 0 s rs = mk0 (reverse s) ++ '.' : mk0 rs+ f n s "" = f (n - 1) ('0' : s) ""+ f n s (r:rs) = f (n - 1) (r : s) rs+ in f e "" ds+ Just dec ->+ let dec' = max dec 0+ in if e >= 0+ then let (ei, is') = roundTo base (dec' + e) is+ (ls, rs) =+ splitAt (e + ei) (map intToDigit is')+ in mk0 ls +++ (if null rs && not alt+ then ""+ else '.' : rs)+ else let (ei, is') =+ roundTo+ base+ dec'+ (replicate (-e) 0 ++ is)+ d:ds' =+ map+ intToDigit+ (if ei > 0+ then is'+ else 0 : is')+ in d :+ (if null ds' && not alt+ then ""+ else '.' : ds')++-- we don't add 0x here because it's handled by the formatter+formatFloatHex :: RealFloat a => Maybe Int -> Bool -> Bool -> a -> String+formatFloatHex decs alt upper x = doFmt (floatToDigits 2 x)+ where+ pChar+ | upper = 'P'+ | otherwise = 'p'+ round' =+ case decs of+ Just d ->+ \x ->+ let (a, b) = roundTo 16 d x+ in ( intToDigit (a + 1)+ , if a > 0+ then tail b+ else b)+ Nothing -> \x -> ('1', x)+ doFmt ([0], 0) = "0" ++ [pChar] ++ "+0"+ doFmt ((1:bits), exp) =+ first :+ (if null digs && not alt+ then ""+ else ".") +++ map+ (if upper+ then intToDigitUpper+ else intToDigit)+ digs +++ [pChar] +++ (if exp >= 1+ then "+"+ else "") +++ show (exp - 1)+ where+ (first, digs) = round' $ go bits+ go (a:b:c:d:xs) = foldl (\a b -> 2 * a + b) 0 [a, b, c, d] : go xs+ go [] = []+ go ys = go (take 4 $ ys ++ repeat 0)+ doFmt _ = error "nonsense"
src/Text/Printf/TH.hs view
@@ -47,17 +47,9 @@ -- @ -- -- This formatter follows the guidelines listed--- <http://www.cplusplus.com/reference/cstdio/printf/ here>, with some--- caveats:------ * Hexadecimal floating point isn't supported. I'm not convinced anyone--- actually uses this and there doesn't appear to be anything in @base@ to--- produce it.--- * @%p@ (pointer) and @%n@ (store number of printed characters) are not supported--- for obvious reasons.--- * @%.0e@ shows at least one decimal place despite this special case--- not appearing anywhere in the spec. This is a bug in 'Text.Printf.formatRealFloat'.--- As a result, @%e@ and @%#e@ have identical behavior.+-- <http://www.cplusplus.com/reference/cstdio/printf/ here>, except for+-- @%n@ (store number of printed characters) for obvious+-- reasons. -- -- @ -- %c :: 'Char'@@ -71,9 +63,12 @@ -- %o :: 'Integral' i => i -- %x, %X :: 'Integral' i => i --+-- %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 'id@@ -194,10 +189,13 @@ 's' -> [|formatStr|] 'f' -> [|formatFloat|] 'F' -> [|formatFloat|]+ 'a' -> [|formatHexFloat|]+ 'A' -> [|formatHexFloatUpper|] 'e' -> [|formatSci|] 'E' -> [|formatSciUpper|] 'g' -> [|formatG|] 'G' -> [|formatGUpper|]+ 'p' -> [|formatPtr|] 'c' -> [|formatChar|] '?' -> [|formatShowable|] _ -> error "???"
src/Text/Printf/TH/Parser.hs view
@@ -11,7 +11,7 @@ flagSet = fromList "-+ #0" -specSet = fromList "diuoxXfFeEgGcs?"+specSet = fromList "diuoxXfFeEaAgGpcs?" parseFmtStr = do atoms <-
src/Text/Printf/TH/Printer.hs view
@@ -12,9 +12,11 @@ import Control.Monad.Fix import Data.Monoid import Data.String+import Foreign.Ptr+import Foreign.Storable import Numeric.Natural import Text.ParserCombinators.ReadP (readP_to_S)-import Text.Printf.TH.Types+import Text.Printf.TH.Types hiding (width) import Text.Read.Lex class (IsString a, Monoid a) =>@@ -33,8 +35,10 @@ formatHex' :: Integral i => i -> a formatHexUpper' :: Integral i => i -> a formatFloat' :: RealFloat f => Maybe Int -> (f -> a, f -> a)- formatSci' :: RealFloat f => Maybe Int -> f -> a- formatSciUpper' :: RealFloat f => Maybe Int -> f -> a+ formatHexFloat' :: RealFloat f => Maybe Int -> (f -> a, f -> a)+ formatHexFloatUpper' :: RealFloat f => Maybe Int -> (f -> a, f -> a)+ formatSci' :: RealFloat f => Maybe Int -> (f -> a, f -> a)+ formatSciUpper' :: RealFloat f => Maybe Int -> (f -> a, f -> a) formatG' :: RealFloat f => Maybe Int -> (f -> a, f -> a) formatGUpper' :: RealFloat f => Maybe Int -> (f -> a, f -> a) @@ -45,6 +49,17 @@ , value :: v } +forcePrefix a@ArgSpec {flagSet} = a {flagSet = flagSet {prefixed = True}}++forceSize n a@ArgSpec {flagSet} =+ a {width = Just n, flagSet = flagSet {adjustment = Just ZeroPadded}}++forceNoZero a@ArgSpec {flagSet} =+ a {flagSet = flagSet {adjustment = noZero (adjustment flagSet)}}+ where+ noZero (Just ZeroPadded) = Nothing+ noZero x = x+ data Direction = Leftward | Rightward@@ -132,17 +147,37 @@ formatHex = helper formatHex' "0x" +formatPtr =+ helper formatHex' "0x" .+ fmap (`minusPtr` nullPtr) . forcePrefix . forceSize (sizeOf nullPtr * 2)+ formatHexUpper = helper formatHexUpper' "0X" -helper' spec pair- | prefixed (flagSet spec) = helper (snd pair) "" spec- | otherwise = helper (fst pair) "" spec+helper' spec pair = helper'' spec pair "" +helper'' spec pair pref+ | prefixed (flagSet spec) = helper (snd pair) pref spec+ | otherwise = helper (fst pair) pref spec+ formatFloat spec = helper' spec (formatFloat' (prec spec)) -formatSci spec = helper (formatSci' (prec spec)) "" spec+formatSci spec = helper' spec (formatSci' (prec spec)) -formatSciUpper spec = helper (formatSciUpper' (prec spec)) "" spec+formatSciUpper spec = helper' spec (formatSciUpper' (prec spec))++formatHexFloat spec+ | isNaN x = helper (const "NaN") "" $ forceNoZero spec+ | isInfinite x = helper (const "Infinity") "" $ forceNoZero spec+ | otherwise = helper'' (forcePrefix spec) (formatHexFloat' (prec spec)) "0x"+ where+ x = value spec++formatHexFloatUpper spec+ | isNaN x = helper (const "NaN") "" $ forceNoZero spec+ | isInfinite x = helper (const "Infinity") "" $ forceNoZero spec+ | otherwise = helper'' (forcePrefix spec) (formatHexFloatUpper' (prec spec)) "0X"+ where+ x = value spec formatG spec = helper' spec (formatG' (prec spec))
src/Text/Printf/TH/Printer/String.hs view
@@ -7,8 +7,6 @@ module Text.Printf.TH.Printer.String where -import Data.Char (toUpper)-import Numeric hiding (showIntAtBase) import NumericUtils import Text.Printf.TH.Printer @@ -33,13 +31,23 @@ formatHex' = showIntAtBase 16 intToDigit formatHexUpper' = showIntAtBase 16 intToDigitUpper formatFloat' p =- ( \n -> showFFloat (fromIntegral <$> p) n ""- , \n -> showFFloatAlt (fromIntegral <$> p) n "")- formatSci' p n = showEFloat (fromIntegral <$> p) n ""- formatSciUpper' p = map toUpper . formatSci' p+ ( formatRealFloatAlt FFFixed (fromIntegral <$> p) False False+ , formatRealFloatAlt FFFixed (fromIntegral <$> p) True False)+ formatHexFloat' p =+ ( formatFloatHex (fromIntegral <$> p) False False+ , formatFloatHex (fromIntegral <$> p) True False)+ formatHexFloatUpper' p =+ ( formatFloatHex (fromIntegral <$> p) False True+ , formatFloatHex (fromIntegral <$> p) True True)+ formatSci' p =+ ( formatRealFloatAlt FFExponent (fromIntegral <$> p) False False+ , formatRealFloatAlt FFExponent (fromIntegral <$> p) True False)+ formatSciUpper' p =+ ( formatRealFloatAlt FFExponent (fromIntegral <$> p) False True+ , formatRealFloatAlt FFExponent (fromIntegral <$> p) True True) formatG' p =- ( \n -> showGFloat (fromIntegral <$> p) n ""- , \n -> showGFloatAlt (fromIntegral <$> p) n "")- formatGUpper' p = both (map toUpper .) (formatG' p)- where- both f (x, y) = (f x, f y)+ ( formatRealFloatAlt FFGeneric (fromIntegral <$> p) False False+ , formatRealFloatAlt FFGeneric (fromIntegral <$> p) True False)+ formatGUpper' p =+ ( formatRealFloatAlt FFGeneric (fromIntegral <$> p) False True+ , formatRealFloatAlt FFGeneric (fromIntegral <$> p) True True)
tests/Codegen.hs view
@@ -95,20 +95,26 @@ $(q "%E") 1234.56 @?= "1.23456E3" it "precision" $ do $(q "%.5e") 12.34 @?= "1.23400e1"- -- GHC's implementation is wrong- -- $(q "%.0e") 12.34 @?= "1e1"- -- $(q "%#.0e") 12.34 @?= "1.e1"+ $(q "%.0e") 12.34 @?= "1e1"+ $(q "%#.0e") 12.34 @?= "1.e1" $(q "%15.5e") 12.34 @?= " 1.23400e1" $(q "%+015.5e") 12.34 @?= "+000001.23400e1" $(q "%+-15.5e") 12.34 @?= "+1.23400e1 " describe "g-format" $ do it "basic" $ do $(q "%g") 1234.56 @?= "1234.56"- $(q "%g") 123456789.876 @?= "1.23456789876e8"- $(q "%G") 123456789.876 @?= "1.23456789876E8"- $(q "%.3g") 1234.56 @?= "1234.560"+ $(q "%g") 123456789.876 @?= "123456789.876"+ $(q "%G") 123456789.876 @?= "123456789.876"+ $(q "%.3g") 1234.56 @?= "1.235e3" $(q "%.3g") 123456789.876 @?= "1.235e8" $(q "%.3G") 123456789.876 @?= "1.235E8"- $(q "%#g") 1234.56 @?= "1234.56"|]+ $(q "%#g") 1234.56 @?= "1234.56"+ describe "hexadecimal floating point" $ do+ it "basic" $ do+ $(q "%a") 0.857421875 @?= "0x1.b7p-1"+ $(q "%A") 3.1415926 @?= "0X1.921FB4D12D84AP+1"+ $(q "%.3a") 0.7576 @?= "0x1.83ep-1"+ $(q "%.3a") 1.999999999 @?= "0x2.000p+0"+ $(q "%015.3a") 0.7576 @?= "0x000001.83ep-1"|] where q = quoteExp quoter
th-printf.cabal view
@@ -1,11 +1,11 @@ name: th-printf-version: 0.4.0+version: 0.5.0 synopsis: Compile-time printf description: Quasiquoters for printf: string, bytestring, text. license: MIT license-file: LICENSE author: Jude Taylor-maintainer: me@jude.xyz+maintainer: me@jude.xy category: Text homepage: https://github.com/pikajude/th-printf build-type: Simple