diff --git a/Text/Show/Pragmatic.hs b/Text/Show/Pragmatic.hs --- a/Text/Show/Pragmatic.hs +++ b/Text/Show/Pragmatic.hs @@ -8,16 +8,30 @@ -- Portability : portable -- -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -module Text.Show.Pragmatic where +module Text.Show.Pragmatic ( + -- * Replacement for the standard class + Show(..), print + -- * Utility (unstable) + , ltdPrecShowsPrec + , showsPrecWithSharedPrecision + , ShowMagnitudeRangeLimited(..) + ) where -import Prelude hiding (Show(..), shows) +import Prelude hiding (Show(..), shows, print) import qualified Prelude +import Data.Foldable (toList) +import Data.List (intersperse, minimumBy) +import Data.Ord (comparing) import Data.Int (Int8, Int16, Int32, Int64) import Data.Word (Word8, Word16, Word32, Word64) import Data.Ratio +import Data.Complex (Complex((:+)), magnitude) #if MIN_VERSION_base(4,8,0) import Numeric.Natural (Natural) #endif @@ -133,8 +147,15 @@ import Data.Void #endif +import qualified Data.Set as Set +import qualified Data.IntSet as ℤSet +import qualified Data.Map as Map +import qualified Data.IntMap as ℤMap +import qualified Data.Sequence as Seq +import qualified Data.Tree as Tree + -- | A drop-in replacement for 'Prelude.Show'. The behaviour is mostly the same: -- the result of 'show' should be valid Haskell code, and 'read'ing back such a -- value should give the original value – but, unlike in 'Prelude.Show', we don't @@ -155,9 +176,12 @@ show :: a -> String show = (`shows`"") showList :: [a] -> ShowS - showList [] = ("[]"++) - showList (x:xs) = ('[':) . shows x . flip (foldr (\y -> (',':) . shows y)) xs . (']':) + showList = defaultShowList +defaultShowList :: Show a => [a] -> ShowS +defaultShowList [] = ("[]"++) +defaultShowList (x:xs) = ('[':) . shows x . flip (foldr (\y -> (',':) . shows y)) xs . (']':) + shows :: Show a => a -> ShowS shows = showsPrec 0 @@ -450,27 +474,99 @@ (r,"'") -> (r++) +class Show a => ShowMagnitudeRangeLimited a where + showsPrecMagnitudeRangeLimited :: Int -> Int -> a -> ShowS + instance Show Float where showsPrec = ltdPrecShowsPrec 7 + showList = ltdPrecShowList id 7 +instance ShowMagnitudeRangeLimited Float where + showsPrecMagnitudeRangeLimited = ltdPrecShowsPrec instance Show Double where showsPrec = ltdPrecShowsPrec 10 + showList = ltdPrecShowList id 10 +instance ShowMagnitudeRangeLimited Double where + showsPrecMagnitudeRangeLimited = ltdPrecShowsPrec instance Show CFloat where showsPrec = ltdPrecShowsPrec 5 + showList = ltdPrecShowList id 5 +instance ShowMagnitudeRangeLimited CFloat where + showsPrecMagnitudeRangeLimited = ltdPrecShowsPrec instance Show CDouble where showsPrec = ltdPrecShowsPrec 10 + showList = ltdPrecShowList id 10 +instance ShowMagnitudeRangeLimited CDouble where + showsPrecMagnitudeRangeLimited = ltdPrecShowsPrec +ltdPrecShowList :: (ShowMagnitudeRangeLimited n, RealFloat sn) + => (n -> sn) -> Int -> [n] -> ShowS +ltdPrecShowList realise precision vals + = ('[':) . flip (foldr id) + (intersperse (',':) + $ showsPrecWithSharedPrecision realise precision 0 vals) + . (']':) + +showsPrecWithSharedPrecision :: (ShowMagnitudeRangeLimited n, RealFloat sn, Traversable list) + => (n -> sn) -- ^ Magnitude-function. Should be a norm. + -> Int -- ^ Precision of the type, in significant decimals. This will + -- be used to trim the length of all entries to match the + -- expected numerical uncertainty of the biggest one. + -> Int -- ^ Precedence of the enclosing context in which the values + -- are to be shown. + -> list n -- ^ Values to show + -> list ShowS -- ^ Individual values' string representation. +showsPrecWithSharedPrecision realise precision p vals + = fmap (\val -> + let uMagn = usableMagnitude $ realise val + in showsPrecMagnitudeRangeLimited + (max 0 $ precision - floor (maxUMag - uMagn)) p val + ) vals + where usableMagnitude n + | n<0 = usableMagnitude (-n) + | n==n, 2*n>n = logBase 10 n + | otherwise = -1/0 + maxUMag = maximum $ usableMagnitude . realise <$> vals + -- | @'ltdPrecShowsPrec' prcn@ displays floating-point values with a precision -- of at least @prcn@ digits. That does not mean it will necessarily display -- that many digits, rather it tries to always choose the shortest representation -- with the required precision. ltdPrecShowsPrec :: (RealFloat n) => Int -> Int -> n -> ShowS -ltdPrecShowsPrec _ _ 0 = ("0"++) -ltdPrecShowsPrec precision p n +ltdPrecShowsPrec precision p n cont + = minimumBy (comparing length) + [ postProc $ ltdPrecShowsPrecDecimal precision p' (preProc n) "" + | (preProc, p', postProc) + <- [ (id, p, id) ] + ++[ ( (/μ) + , 7, \s -> case s of + "1" -> sμ "" + "(-1)"-> showParen (p>=6) (('-':) . sμ) "" + _ -> showParen (p>7) ((s++) . ('*':) . sμ) "" + ) + | (μ,sμ) <- (pi, ("pi"++)) + :[ (pi / fromIntegral m, ("pi/"++) . shows m) + | m<-[2,3,4 :: Int] ] + ++[ (sqrt $ fromIntegral n, ("sqrt "++) . shows n) + | n<-[2,3,5 :: Int] ] + ++[ ( sqrt (fromIntegral n)/fromIntegral m + , ("sqrt "++) . shows n . ('/':) . shows m) + | n<-[2,3 :: Int] + , m<-[2,3 :: Int] ] + ] + ++[ ( (*fromIntegral n) + , 7, \s -> showParen (p>7) ((s++) . ('/':) . shows n) "" ) + | n<-[3,7,9 :: Int] ] + ] ++ cont + +ltdPrecShowsPrecDecimal :: (RealFloat n) => Int -> Int -> n -> ShowS +ltdPrecShowsPrecDecimal _ _ 0 = ("0"++) +ltdPrecShowsPrecDecimal precision p n | not (n==n) = ("NaN"++) - | n<0 = showParen (p>5) $ ('-':) . ltdPrecShowsPrec precision 0 (negate n) + | n<0 = showParen (p>5) + $ ('-':) . ltdPrecShowsPrecDecimal precision 0 (negate n) | n==n*2 = ("Infinity"++) | e₁₀<7 && lrDigs <= e₁₀ = (rDigits++) . (replicate (e₁₀-lrDigs) '0' ++) @@ -494,6 +590,20 @@ instance (Show a) => Show [a] where showsPrec _ = showList +instance (Show a, Ord a) => Show (Seq.Seq a) where + showsPrec _ = defaultShowList . toList +instance (Show a, Ord a) => Show (Set.Set a) where + showsPrec _ = defaultShowList . Set.toList +instance Show ℤSet.IntSet where + showsPrec _ = defaultShowList . ℤSet.toList +instance (Show a, Ord a, Show b) => Show (Map.Map a b) where + showsPrec _ = defaultShowList . Map.toList +instance (Show b) => Show (ℤMap.IntMap b) where + showsPrec _ = defaultShowList . ℤMap.toList +instance (Show a) => Show (Tree.Tree a) where + showsPrec p (Tree.Node a st) = showParen (p>9) + $ ("Node "++) . showsPrec 11 a . (' ':) . shows st + instance (Show a, Show b) => Show (a,b) where showsPrec _ (a,b) = ('(':) . shows a . (',':) . shows b . (')':) instance (Show a, Show b, Show c) => Show (a,b,c) where @@ -509,6 +619,26 @@ | denominator n == 1 = shows $ numerator n | otherwise = showParen (p>6) $ shows (numerator n) . ('/':) . shows (denominator n) + +instance Show (Complex Double) where + showsPrec = ltdPrecShowsPrecComplex 10 + showList = ltdPrecShowList magnitude 10 +instance Show (Complex Float) where + showsPrec = ltdPrecShowsPrecComplex 7 + showList = ltdPrecShowList magnitude 7 +instance (RealFloat a, Show (Complex a), ShowMagnitudeRangeLimited a) + => ShowMagnitudeRangeLimited (Complex a) where + showsPrecMagnitudeRangeLimited = ltdPrecShowsPrecComplex + +ltdPrecShowsPrecComplex :: (RealFloat r, ShowMagnitudeRangeLimited r) + => Int -> Int -> Complex r -> ShowS +ltdPrecShowsPrecComplex precision p (r:+i) + | abs r > abs i * 10^precision + = ltdPrecShowsPrec precision p r + | otherwise + = case ($"")<$>showsPrecWithSharedPrecision id precision 6 [r,i] of + [sr,"0"] -> showParen (p>7) $ (sr++) + [sr,si] -> showParen (p>6) $ (sr++) . (":+"++) . (si++) -- | Drop-in for the standard screen-displaying function. This is useful as a GHCi -- evaluation action; invoke with diff --git a/pragmatic-show.cabal b/pragmatic-show.cabal --- a/pragmatic-show.cabal +++ b/pragmatic-show.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: pragmatic-show -version: 0.1.1.0 +version: 0.1.2.0 synopsis: Alternative Show class that gives shorter view if possible. description: The standard 'Show' class is handy for quickly viewing any Haskell values without having to think about formatting. However, it often @@ -25,6 +25,7 @@ -- other-modules: other-extensions: FlexibleInstances build-depends: base >=4.8 && <5 + , containers >=0.5 && <0.6 -- hs-source-dirs: default-language: Haskell2010 diff --git a/test/tasty/test.hs b/test/tasty/test.hs --- a/test/tasty/test.hs +++ b/test/tasty/test.hs @@ -20,6 +20,7 @@ import Prelude hiding (Show(..)) import Text.Show.Pragmatic +import Data.Complex (Complex((:+))) import Data.VectorSpace @@ -43,9 +44,10 @@ [ floatTest 1 "1" , floatTest 10 "10" , floatTest 0.1 "0.1" + , floatTest (1/3) "1/3" , floatTest 1e9 "1e9" , floatTest 1e90 "1e90" - , floatTest pi "3.14159265359" + , floatTest pi "pi" , floatTest 32 "32" , floatTest (89.524 - 9.004) "80.52" , floatTest (0.3 + 0.3 + 0.3) "0.9" @@ -62,14 +64,10 @@ , floatTest 7e35 "7e35" , floatTest (1/0) "Infinity" , floatTest (sqrt $ -1) "NaN" - ] - , testGroup "Re-Reading of approximate types" - [ testProperty "Double" $ readBackApproxEq ([]::[Double]) 1e-10 - , testProperty "Double with higher-than-supported precision" - . QC.expectFailure - $ readBackApproxEq ([]::[Double]) 1e-14 - , testProperty "Double²" $ readBackApproxEq ([]::[(Double,Double)]) 1e-10 - , testProperty "Float" $ readBackApproxEq ([]::[Float]) 1e-5 + , floatsTest [1,2,3] "[1,2,3]" + , floatsTest (take 10 $ iterate (/16) 1) + "[1,0.0625,3.90625e-3,2.44140625e-4,1.5258789e-5,9.53674e-7,5.9605e-8,3.725e-9,2.33e-10,1.5e-11]" + , floatsTest [1, -sqrt 2, sqrt (-2)] "[1,-sqrt 2,NaN]" ] , testGroup "Showing rational numbers" [ rationalTest 0 "0" @@ -79,6 +77,13 @@ , rationalTest (-268/19) "-268/19" , rationalTest (3/3) "1" ] + , testGroup "Showing complex numbers" + [ complexTest 1 "1" + , complexTest (sqrt $ -1) "0:+1" + , complexTest (exp $ 0:+pi) "-1" + , complexTest (exp $ 0:+pi/4) "sqrt 2/2:+sqrt 2/2" + , complexTest (exp $ 0:+5*pi/4) "(-sqrt 2/2):+(-sqrt 2/2)" + ] ] -- | Check that showing and reading again yields the original value. @@ -99,6 +104,12 @@ floatTest :: Double -> String -> TestTree floatTest n s = testCase s $ show n @?= s + +complexTest :: Complex Double -> String -> TestTree +complexTest n s = testCase s $ show n @?= s + +floatsTest :: [Double] -> String -> TestTree +floatsTest n s = testCase s $ show n @?= s rationalTest :: Rational -> String -> TestTree rationalTest n s = testCase s $ show n @?= s