diff --git a/Text/Show/Pragmatic.hs b/Text/Show/Pragmatic.hs --- a/Text/Show/Pragmatic.hs +++ b/Text/Show/Pragmatic.hs @@ -12,6 +12,12 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} #include "HsBaseConfig.h" @@ -22,6 +28,7 @@ , ltdPrecShowsPrec , showsPrecWithSharedPrecision , ShowMagnitudeRangeLimited(..) + , PaddingMode(..) ) where import Prelude hiding (Show(..), shows, print) @@ -161,8 +168,13 @@ import qualified Data.IntMap as ℤMap import qualified Data.Sequence as Seq import qualified Data.Tree as Tree +import Data.Functor.Identity (Identity(..)) +data PaddingMode = NoPadding + | PadLeftToAlign + | PadRightToAlign + | PadToConstantWidth -- | 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 @@ -178,20 +190,37 @@ -- it depends on the type and the order of magnitude which amount of rounding is -- appropriate. See for some examples. class Show a where - {-# MINIMAL showsPrec | show #-} + {-# MINIMAL showsPrec | show | showEach #-} showsPrec :: Int -> a -> ShowS showsPrec _ x = (show x++) show :: a -> String show = (`shows`"") + showEach :: Traversable t + => PaddingMode -- ^ Whether / how to ensure that e.g. decimal points line up. + -> Int -- ^ Precedence to use for showing each individual element + -> t a -- ^ List or other container of elements + -> t ShowS -- ^ Every element in the container shown, possibly with + -- shared processing like trimmed insignificant decimals + showEach = defaultShowEach showList :: [a] -> ShowS showList = defaultShowList +defaultAssembleListShow :: [ShowS] -> ShowS +defaultAssembleListShow [] = ("[]"++) +defaultAssembleListShow (x:xs) = ('[':) . x . flip (foldr (\y -> (',':) . y)) xs . (']':) + defaultShowList :: Show a => [a] -> ShowS -defaultShowList [] = ("[]"++) -defaultShowList (x:xs) = ('[':) . shows x . flip (foldr (\y -> (',':) . shows y)) xs . (']':) +defaultShowList = defaultAssembleListShow . showEach NoPadding 0 +defaultShowEach :: (Show a, Traversable t) => PaddingMode -> Int -> t a -> t ShowS +defaultShowEach PadToConstantWidth p l + = fmap (\r c -> r <> replicate (totalWidth - length r) ' ' <> c) shown + where totalWidth = maximum $ length<$>shown + shown = fmap (($ "") . showsPrec p) l +defaultShowEach _ p l = fmap (showsPrec p) l + shows :: Show a => a -> ShowS -shows = showsPrec 0 +shows = runIdentity . showEach NoPadding 0 . Identity #define StdShow(A) \ instance Show (A) where { \ @@ -487,66 +516,97 @@ class Show a => ShowMagnitudeRangeLimited a where - showsPrecMagnitudeRangeLimited :: Int -> Int -> a -> ShowS + showsPrecMagnitudeRangeLimited + :: Int -- ^ Precision of the data type + -> Int -- ^ Precedence of the showing context + -> a -- ^ Numerical value to show + -> ShowS instance Show Float where showsPrec = ltdPrecShowsPrec 7 - showList = ltdPrecShowList id 7 + showEach = showsPrecWithSharedPrecision id 7 instance ShowMagnitudeRangeLimited Float where showsPrecMagnitudeRangeLimited = ltdPrecShowsPrec instance Show Double where showsPrec = ltdPrecShowsPrec 10 - showList = ltdPrecShowList id 10 + showEach = showsPrecWithSharedPrecision id 10 instance ShowMagnitudeRangeLimited Double where showsPrecMagnitudeRangeLimited = ltdPrecShowsPrec instance Show CFloat where showsPrec = ltdPrecShowsPrec 5 - showList = ltdPrecShowList id 5 + showEach = showsPrecWithSharedPrecision id 5 instance ShowMagnitudeRangeLimited CFloat where showsPrecMagnitudeRangeLimited = ltdPrecShowsPrec instance Show CDouble where showsPrec = ltdPrecShowsPrec 10 - showList = ltdPrecShowList id 10 + showEach = showsPrecWithSharedPrecision 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) +showsPrecWithSharedPrecision :: ∀ n list sn . (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. + -> PaddingMode -- ^ What to do to align decimal points -> 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 +showsPrecWithSharedPrecision magnitudeFn precision padMode p vals + = (case padMode of + PadToConstantWidth -> \strn -> + let lenStrn = length strn + in (replicate (longestPaddedValLength - lenStrn) ' '++) . (strn++) + _ -> (++) + ) <$> paddedShownVals + where shownVals :: list (n, String) + shownVals = fmap (\val -> + let uMagn = usableMagnitude $ magnitudeFn val + in (val, showsPrecMagnitudeRangeLimited + (max 0 $ precision - floor (maxUMag - uMagn)) p val "") ) vals - where usableMagnitude n + usableMagnitude n | n<0 = usableMagnitude (-n) | n==n, 2*n>n = logBase 10 n - | otherwise = -1/0 - maxUMag = maximum $ usableMagnitude . realise <$> vals + | otherwise = -1/0 -- NaN or infinite values are disregarded + maxUMag = maximum $ usableMagnitude . magnitudeFn <$> vals + leftmostCharacterMagnitude :: (n, String) -> Int + leftmostCharacterMagnitude (_, "0") = 0 + leftmostCharacterMagnitude (n, ('-':strn)) + = 1 + leftmostCharacterMagnitude (n, dropWhile (=='-') strn) + leftmostCharacterMagnitude (n, '.':strn) + = leftmostCharacterMagnitude (n, strn) + leftmostCharacterMagnitude (n, '0':strn) + = 1 + leftmostCharacterMagnitude (n, strn) + leftmostCharacterMagnitude (n, strn) = floor (usableMagnitude $ magnitudeFn n) + leftmostColumnMagnitude, rightmostColumnMagnitude :: Int + leftmostColumnMagnitude = maximum $ leftmostCharacterMagnitude <$> shownVals + rightmostColumnMagnitude = leftmostColumnMagnitude - maximum (length . snd <$> shownVals) + administerPadding :: (n, String) -> String + administerPadding (n,strn) = case padMode of + NoPadding -> strn + PadLeftToAlign -> replicate (leftmostColumnMagnitude - lchm) ' ' ++ strn + _ -> strn ++ replicate (rchm - rightmostColumnMagnitude) ' ' + where lchm, rchm :: Int + lchm = leftmostCharacterMagnitude (n, strn) + rchm = lchm - length strn + paddedShownVals :: list String + paddedShownVals = administerPadding <$> shownVals + longestPaddedValLength = maximum $ length <$>paddedShownVals -- | @'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 :: (RealFloat n) + => Int -- ^ Precision of the data type + -> Int -- ^ Precedence of the showing context + -> n -- ^ Numerical value to show + -> ShowS ltdPrecShowsPrec precision p n cont = minimumBy (comparing length) [ postProc $ ltdPrecShowsPrecDecimal precision p' (preProc n) "" @@ -581,7 +641,7 @@ $ ('-':) . ltdPrecShowsPrecDecimal precision 0 (negate n) | n==n*2 = ("Infinity"++) | e₁₀<7 && lrDigs <= e₁₀ - = (rDigits++) . (replicate (e₁₀-lrDigs) '0' ++) + = shows (round n :: Int) | e₁₀>0 && e₁₀<3 = (take e₁₀ rDigits++) . ('.':) . (drop e₁₀ rDigits++) | e₁₀> -2 && e₁₀<=0 @@ -599,6 +659,13 @@ rDigits = reverse rDigits' lrDigs = length rDigits +instance (Show a) => Show (Identity a) where + showsPrec p (Identity x) = showParen (p>9) $ ("Identity "++) . showsPrec 11 x + +instance (Show a) => Show (Maybe a) where + showsPrec _ Nothing = ("Nothing"++) + showsPrec p (Just x) = showParen (p>9) $ ("Just "++) . showsPrec 11 x + instance (Show a) => Show [a] where showsPrec _ = showList @@ -616,14 +683,62 @@ showsPrec p (Tree.Node a st) = showParen (p>9) $ ("Node "++) . showsPrec 11 a . (' ':) . shows st +data TraverseFirst t b a where + TraverseFirst :: { firstTraversed :: t (a,b) } -> TraverseFirst t b a + deriving (Functor, Foldable, Traversable) + +data TraverseSecond t a b where + TraverseSecond :: { secondTraversed :: t (a,b) } -> TraverseSecond t a b + deriving (Functor, Foldable, Traversable) + instance (Show a, Show b) => Show (a,b) where - showsPrec _ (a,b) = ('(':) . shows a . (',':) . shows b . (')':) + showEach padMode _ + = fmap (\(sa,sb) -> ('(':) . sa . (',':) . sb . (')':)) + . firstTraversed . showEach padMode 0 . TraverseFirst + . secondTraversed . showEach padMode 0 . TraverseSecond + +data TraverseFirstOf3 t b c a where + TraverseFirstOf3 :: { firstOf3Traversed :: t (a,b,c) } -> TraverseFirstOf3 t b c a + deriving (Functor, Foldable, Traversable) + +data TraverseSecondOf3 t a c b where + TraverseSecondOf3 :: { secondOf3Traversed :: t (a,b,c) } -> TraverseSecondOf3 t a c b + deriving (Functor, Foldable, Traversable) + +data TraverseThird t a b c where + TraverseThird :: { thirdTraversed :: t (a,b,c) } -> TraverseThird t a b c + deriving (Functor, Foldable, Traversable) + instance (Show a, Show b, Show c) => Show (a,b,c) where - showsPrec _ (a,b,c) = ('(':) . shows a . (',':) . shows b . (',':) . shows c . (')':) + showEach padMode _ + = fmap (\(sa,sb,sc) -> ('(':) . sa . (',':) . sb . (',':) . sc . (')':)) + . firstOf3Traversed . showEach padMode 0 . TraverseFirstOf3 + . secondOf3Traversed . showEach padMode 0 . TraverseSecondOf3 + . thirdTraversed . showEach padMode 0 . TraverseThird + +data TraverseFirstOf4 t b c d a where + TraverseFirstOf4 :: { firstOf4Traversed :: t (a,b,c,d) } -> TraverseFirstOf4 t b c d a + deriving (Functor, Foldable, Traversable) + +data TraverseSecondOf4 t a c d b where + TraverseSecondOf4 :: { secondOf4Traversed :: t (a,b,c,d) } -> TraverseSecondOf4 t a c d b + deriving (Functor, Foldable, Traversable) + +data TraverseThirdOf4 t a b d c where + TraverseThirdOf4 :: { thirdOf4Traversed :: t (a,b,c,d) } -> TraverseThirdOf4 t a b d c + deriving (Functor, Foldable, Traversable) + +data TraverseFourth t a b c d where + TraverseFourth :: { fourthTraversed :: t (a,b,c,d) } -> TraverseFourth t a b c d + deriving (Functor, Foldable, Traversable) + instance (Show a, Show b, Show c, Show d) => Show (a,b,c,d) where - showsPrec _ (a,b,c,d) = ('(':) - . shows a . (',':) . shows b . (',':) . shows c . (',':) . shows d - . (')':) + showEach padMode _ + = fmap (\(sa,sb,sc,sd) -> ('(':).sa.(',':).sb.(',':).sc.(',':).sd.(')':)) + . firstOf4Traversed . showEach padMode 0 . TraverseFirstOf4 + . secondOf4Traversed . showEach padMode 0 . TraverseSecondOf4 + . thirdOf4Traversed . showEach padMode 0 . TraverseThirdOf4 + . fourthTraversed . showEach padMode 0 . TraverseFourth instance (Integral i, Show i) => Show (Ratio i) where showsPrec p n @@ -634,10 +749,10 @@ instance Show (Complex Double) where showsPrec = ltdPrecShowsPrecComplex 10 - showList = ltdPrecShowList magnitude 10 + showEach = showsPrecWithSharedPrecision magnitude 10 instance Show (Complex Float) where showsPrec = ltdPrecShowsPrecComplex 7 - showList = ltdPrecShowList magnitude 7 + showEach = showsPrecWithSharedPrecision magnitude 7 instance (RealFloat a, Show (Complex a), ShowMagnitudeRangeLimited a) => ShowMagnitudeRangeLimited (Complex a) where showsPrecMagnitudeRangeLimited = ltdPrecShowsPrecComplex @@ -648,7 +763,7 @@ | abs r > abs i * 10^precision = ltdPrecShowsPrec precision p r | otherwise - = case ($"")<$>showsPrecWithSharedPrecision id precision 6 [r,i] of + = case ($ "")<$>showsPrecWithSharedPrecision id precision NoPadding 6 [r,i] of [sr,"0"] -> showParen (p>7) $ (sr++) [sr,si] -> showParen (p>6) $ (sr++) . (":+"++) . (si++) diff --git a/pragmatic-show.cabal b/pragmatic-show.cabal --- a/pragmatic-show.cabal +++ b/pragmatic-show.cabal @@ -2,18 +2,21 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: pragmatic-show -version: 0.1.2.1 +version: 0.2.0.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 produces needlessly clunky string representations, which are difficult to parse by eye. This package offers a drop-in replacement which - attempts to keep the representation as short as possible. + attempts to keep the representation as readable as possible. + It does this through more graphical layout, omission of redundant + information, and (still quite conservative) trimming of low-significance + digits. license: GPL-3 license-file: LICENSE author: Justus Sagemüller homepage: https://github.com/leftaroundabout/pragmatic-show -maintainer: (@) jsag $ hvl.no +maintainer: (@) jsag $ kth.se -- copyright: category: Text build-type: Simple @@ -25,11 +28,11 @@ -- other-modules: other-extensions: FlexibleInstances build-depends: base >=4.8 && <5 - , containers >=0.5 && <0.7 + , containers >=0.5 && <0.9 -- hs-source-dirs: default-language: Haskell2010 -test-suite test +test-suite pragmatic-show-test default-language: Haskell2010 type: diff --git a/test/tasty/test.hs b/test/tasty/test.hs --- a/test/tasty/test.hs +++ b/test/tasty/test.hs @@ -39,6 +39,9 @@ , testProperty "(Int,Integer)" $ readBackEq ([]::[(Int,Integer)]) , testProperty "(Int,Integer,(Char,[Int]),String)" $ readBackEq ([]::[(Int,Integer,(Char,[Int]),String)]) + , testProperty "[(Int,Bool)]" $ readBackEq ([]::[ [(Int,Bool)] ]) + , testProperty "([(Char,Int,Char)],[(Int,Char,Int,Char)])" + $ readBackEq ([]::[ ([(Char,Int,Char)],[(Int,Char,Int,Char)]) ]) ] , testGroup "Showing double-precision floats" [ floatTest 1 "1" @@ -68,6 +71,8 @@ , 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]" + , floatsTest [pi**k | k <- [1, 4 .. 30]] + "[pi,97,3020,93648,2.904e6,9.0032e7,2.791564e9,8.6556004e10,2.683779414e12,8.3214007069e13,2.58015652686e15]" ] , testGroup "Showing rational numbers" [ rationalTest 0 "0" @@ -84,6 +89,11 @@ , complexTest (exp $ 0:+pi/4) "sqrt 2/2:+sqrt 2/2" , complexTest (exp $ 0:+5*pi/4) "(-sqrt 2/2):+(-sqrt 2/2)" ] + , testGroup "Showing tuples and lists of tuples" + [ floatTupleTest (1.001e-3, 1e40) "(1.001e-3,1e40)" + , floatTuplesTest [ (1.001e-3,1e40),(3e-3,1.001) ] + "[(1.001e-3,1e40),(3e-3,1)]" + ] ] -- | Check that showing and reading again yields the original value. @@ -110,6 +120,12 @@ floatsTest :: [Double] -> String -> TestTree floatsTest n s = testCase s $ show n @?= s + +floatTupleTest :: (Double,Double) -> String -> TestTree +floatTupleTest n s = testCase s $ show n @?= s + +floatTuplesTest :: [(Double,Double)] -> String -> TestTree +floatTuplesTest n s = testCase s $ show n @?= s rationalTest :: Rational -> String -> TestTree rationalTest n s = testCase s $ show n @?= s