diff --git a/src/NumericUtils.hs b/src/NumericUtils.hs --- a/src/NumericUtils.hs +++ b/src/NumericUtils.hs @@ -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" diff --git a/src/Text/Printf/TH.hs b/src/Text/Printf/TH.hs --- a/src/Text/Printf/TH.hs +++ b/src/Text/Printf/TH.hs @@ -47,17 +47,9 @@ -- @ -- -- This formatter follows the guidelines listed --- , with some --- caveats: --- --- * Hexadecimal floating point isn't supported. I'm not convinced anyone --- actually uses this and there doesn't appear to be anything in @base@ to --- produce it. --- * @%p@ (pointer) and @%n@ (store number of printed characters) are not supported --- for obvious reasons. --- * @%.0e@ shows at least one decimal place despite this special case --- not appearing anywhere in the spec. This is a bug in 'Text.Printf.formatRealFloat'. --- As a result, @%e@ and @%#e@ have identical behavior. +-- , 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 "???" diff --git a/src/Text/Printf/TH/Parser.hs b/src/Text/Printf/TH/Parser.hs --- a/src/Text/Printf/TH/Parser.hs +++ b/src/Text/Printf/TH/Parser.hs @@ -11,7 +11,7 @@ flagSet = fromList "-+ #0" -specSet = fromList "diuoxXfFeEgGcs?" +specSet = fromList "diuoxXfFeEaAgGpcs?" parseFmtStr = do atoms <- diff --git a/src/Text/Printf/TH/Printer.hs b/src/Text/Printf/TH/Printer.hs --- a/src/Text/Printf/TH/Printer.hs +++ b/src/Text/Printf/TH/Printer.hs @@ -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)) diff --git a/src/Text/Printf/TH/Printer/String.hs b/src/Text/Printf/TH/Printer/String.hs --- a/src/Text/Printf/TH/Printer/String.hs +++ b/src/Text/Printf/TH/Printer/String.hs @@ -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) diff --git a/tests/Codegen.hs b/tests/Codegen.hs --- a/tests/Codegen.hs +++ b/tests/Codegen.hs @@ -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 diff --git a/th-printf.cabal b/th-printf.cabal --- a/th-printf.cabal +++ b/th-printf.cabal @@ -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