prettyprinter-1.7.0: test/Testsuite/Main.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
#include "version-compatibility-macros.h"
module Main (main) where
import Control.Exception (evaluate)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as T
import Data.Text.PgpWordlist
import Data.Word
import System.Timeout (timeout)
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Internal.Debug
import Data.Text.Prettyprint.Doc.Render.Text
import Data.Text.Prettyprint.Doc.Render.Util.StackMachine (renderSimplyDecorated)
import Test.QuickCheck.Instances.Text ()
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
import StripTrailingSpace
#if !(APPLICATIVE_MONAD)
import Control.Applicative
#endif
#if !(MONOID_IN_PRELUDE)
import Data.Monoid (mconcat)
#endif
main :: IO ()
main = defaultMain tests
tests :: TestTree
tests = testGroup "Tests"
[ testGroup "Fusion"
[ testProperty "Shallow fusion does not change rendering"
(fusionDoesNotChangeRendering Shallow)
, testProperty "Deep fusion does not change rendering"
(fusionDoesNotChangeRendering Deep)
]
, testStripTrailingSpace
, testGroup "Performance tests"
[ testCase "Grouping performance"
groupingPerformance
, testCase "fillSep performance"
fillSepPerformance
]
, testGroup "Regression tests"
[ testCase "layoutSmart: softline behaves like a newline (#49)"
regressionLayoutSmartSoftline
, testCase "alterAnnotationsS causes panic when removing annotations (#50)"
regressionAlterAnnotationsS
, testCase "Bad fallback handling with align (#83)" badFallbackAlign
, testGroup "removeTrailingWhitespace removes leading whitespace (#84)"
[ testCase "Text node"
doNotRemoveLeadingWhitespaceText
, testCase "Char node"
doNotRemoveLeadingWhitespaceChar
, testCase "Text+Char nodes"
doNotRemoveLeadingWhitespaceTextChar
]
, testGroup "removeTrailingWhitespace removes trailing line breaks (#86)"
[ testCase "Keep lonely single trailing newline"
removeTrailingWhitespaceKeepLonelyTrailingNewline
, testCase "Trailing newline with spaces"
removeTrailingNewlineWithSpaces
, testCase "Keep single trailing newline"
removeTrailingWhitespaceKeepTrailingNewline
, testCase "Reduce to single trailing newline"
removeTrailingWhitespaceInTrailingNewlines
]
, testGroup "removeTrailingWhitespace restores indentation in the wrong spot (#93)"
[ testCase "Don't restore indentation in the wrong spot"
removeTrailingWhitespaceDontRestoreIndentationInTheWrongSpot
, testCase "Preserve leading indentation"
removeTrailingWhitespacePreserveIndentation
]
, testGroup "Unbounded layout of hard linebreak within `group` fails (#91)"
[ testCase "Line" regressionUnboundedGroupedLine
, testCase "Line within align" regressionUnboundedGroupedLineWithinAlign
]
, testCase "Indentation on otherwise empty lines results in trailing whitespace (#139)"
indentationShouldntCauseTrailingWhitespaceOnOtherwiseEmptyLines
, testCase "Ribbon width should be computed with `floor` instead of `round` (#157)"
computeRibbonWidthWithFloor
]
]
fusionDoesNotChangeRendering :: FusionDepth -> Property
fusionDoesNotChangeRendering depth
= forAllShow (arbitrary :: Gen (Doc Int)) (show . diag) (\doc ->
forAll arbitrary (\layouter ->
let tShow = T.pack . show
render = renderSimplyDecorated id tShow tShow . layout layouter
rendered = render doc
renderedFused = render (fuse depth doc)
in counterexample (mkCounterexample rendered renderedFused)
(render doc == render (fuse depth doc)) ))
where
mkCounterexample rendered renderedFused
= (T.unpack . renderStrict . layoutPretty defaultLayoutOptions . vsep)
[ "Unfused and fused documents render differently!"
, "Unfused:"
, indent 4 (pretty rendered)
, "Fused:"
, indent 4 (pretty renderedFused) ]
instance Arbitrary ann => Arbitrary (Doc ann) where
arbitrary = document
shrink = genericShrink -- Possibly not a good idea, may break invariants
document :: Arbitrary ann => Gen (Doc ann)
document = (dampen . frequency)
[ (20, content)
, (1, newlines)
, (1, nestingAndAlignment)
, (1, grouping)
, (20, concatenationOfTwo)
, (5, concatenationOfMany)
, (1, enclosingOfOne)
, (1, enclosingOfMany)
, (1, annotated) ]
annotated :: Arbitrary ann => Gen (Doc ann)
annotated = annotate <$> arbitrary <*> document
content :: Gen (Doc ann)
content = frequency
[ (1, pure emptyDoc)
, (10, do word <- choose (minBound, maxBound :: Word8)
let pgp8Word = toText (BSL.singleton word)
pure (pretty pgp8Word) )
, (1, (fmap pretty . elements . mconcat)
[ ['a'..'z']
, ['A'..'Z']
, ['0'..'9']
, "…_[]^!<>=&@:-()?*}{/\\#$|~`+%\"';" ] )
]
newlines :: Gen (Doc ann)
newlines = frequency
[ (1, pure line)
, (1, pure line')
, (1, pure softline)
, (1, pure softline')
, (1, pure hardline) ]
nestingAndAlignment :: Arbitrary ann => Gen (Doc ann)
nestingAndAlignment = frequency
[ (1, nest <$> arbitrary <*> concatenationOfMany)
, (1, group <$> document)
, (1, hang <$> arbitrary <*> concatenationOfMany)
, (1, indent <$> arbitrary <*> concatenationOfMany) ]
grouping :: Arbitrary ann => Gen (Doc ann)
grouping = frequency
[ (1, align <$> document)
, (1, flatAlt <$> document <*> document) ]
concatenationOfTwo :: Arbitrary ann => Gen (Doc ann)
concatenationOfTwo = frequency
[ (1, (<>) <$> document <*> document)
, (1, (<+>) <$> document <*> document) ]
concatenationOfMany :: Arbitrary ann => Gen (Doc ann)
concatenationOfMany = frequency
[ (1, hsep <$> listOf document)
, (1, vsep <$> listOf document)
, (1, fillSep <$> listOf document)
, (1, sep <$> listOf document)
, (1, hcat <$> listOf document)
, (1, vcat <$> listOf document)
, (1, fillCat <$> listOf document)
, (1, cat <$> listOf document) ]
enclosingOfOne :: Arbitrary ann => Gen (Doc ann)
enclosingOfOne = frequency
[ (1, squotes <$> document)
, (1, dquotes <$> document)
, (1, parens <$> document)
, (1, angles <$> document)
, (1, brackets <$> document)
, (1, braces <$> document) ]
enclosingOfMany :: Arbitrary ann => Gen (Doc ann)
enclosingOfMany = frequency
[ (1, encloseSep <$> document <*> document <*> pure ", " <*> listOf document)
, (1, list <$> listOf document)
, (1, tupled <$> listOf document) ]
-- A 'show'able type representing a layout algorithm.
data Layouter ann
= LayoutPretty LayoutOptions
| LayoutSmart LayoutOptions
| LayoutCompact
-- LayoutWadlerLeijen (FittingPredicate ann) LayoutOptions
deriving Show
instance Arbitrary (Layouter ann) where
arbitrary = oneof
[ LayoutPretty <$> arbitrary
, LayoutSmart <$> arbitrary
, pure LayoutCompact
-- This produces inconsistent layouts that break the fusionDoesNotChangeRendering test
-- , LayoutWadlerLeijen <$> arbitrary <*> arbitrary
]
{-
instance Show (FittingPredicate ann) where
show _ = "<fitting predicate>"
instance Arbitrary (FittingPredicate ann) where
arbitrary = FittingPredicate <$> arbitrary
-}
layout :: Layouter ann -> Doc ann -> SimpleDocStream ann
layout (LayoutPretty opts) = layoutPretty opts
layout (LayoutSmart opts) = layoutSmart opts
layout LayoutCompact = layoutCompact
-- layout (LayoutWadlerLeijen fp opts) = layoutWadlerLeijen fp opts
instance Arbitrary LayoutOptions where
arbitrary = LayoutOptions <$> oneof
[ AvailablePerLine <$> arbitrary <*> arbitrary
, pure Unbounded
]
instance CoArbitrary (SimpleDocStream ann) where
coarbitrary s0 = case s0 of
SFail -> variant' 0
SEmpty -> variant' 1
SChar _c s -> variant' 2 . coarbitrary s
SText l _t s -> variant' 3 . coarbitrary (l, s)
SLine i s -> variant' 4 . coarbitrary (i, s)
SAnnPush _a s -> variant' 5 . coarbitrary s
SAnnPop s -> variant' 6 . coarbitrary s
instance CoArbitrary PageWidth where
coarbitrary (AvailablePerLine a b) = variant' 0 . coarbitrary (a, b)
coarbitrary Unbounded = variant' 1
-- | Silences type defaulting warnings for 'variant'
variant' :: Int -> Gen a -> Gen a
variant' = variant
-- QuickCheck 2.8 does not have 'scale' yet, so for compatibility with older
-- releases we hand-code it here
dampen :: Gen a -> Gen a
dampen gen = sized (\n -> resize ((n*2) `quot` 3) gen)
docPerformanceTest :: Doc ann -> Assertion
docPerformanceTest doc
= timeout 10000000 (forceDoc doc) >>= \doc' -> case doc' of
Nothing -> assertFailure "Timeout!"
Just _success -> pure ()
where
forceDoc :: Doc ann -> IO ()
forceDoc = evaluate . foldr seq () . show
-- Deeply nested group/flatten calls can result in exponential performance.
--
-- See https://github.com/quchen/prettyprinter/issues/22
groupingPerformance :: Assertion
groupingPerformance = docPerformanceTest (pathological 1000)
where
pathological :: Int -> Doc ann
pathological n = iterate (\x -> hsep [x, sep []] ) "foobar" !! n
-- This test case was written because the `pretty` package had an issue with
-- this specific example.
--
-- See https://github.com/haskell/pretty/issues/32
fillSepPerformance :: Assertion
fillSepPerformance = docPerformanceTest (pathological 1000)
where
pathological :: Int -> Doc ann
pathological n = iterate (\x -> fillSep ["a", x <+> "b"] ) "foobar" !! n
regressionLayoutSmartSoftline :: Assertion
regressionLayoutSmartSoftline
= let doc = "a" <> softline <> "b"
layouted :: SimpleDocStream ()
layouted = layoutSmart (defaultLayoutOptions { layoutPageWidth = Unbounded }) doc
in assertEqual "softline should be rendered as space page width is unbounded"
(SChar 'a' (SChar ' ' (SChar 'b' SEmpty)))
layouted
-- Removing annotations with alterAnnotationsS used to remove pushes, but not
-- pops, leading to imbalanced SimpleDocStreams.
regressionAlterAnnotationsS :: Assertion
regressionAlterAnnotationsS
= let sdoc, sdoc' :: SimpleDocStream Int
sdoc = layoutSmart defaultLayoutOptions (annotate 1 (annotate 2 (annotate 3 "a")))
sdoc' = alterAnnotationsS (\ann -> case ann of 2 -> Just 2; _ -> Nothing) sdoc
in assertEqual "" (SAnnPush 2 (SChar 'a' (SAnnPop SEmpty))) sdoc'
doNotRemoveLeadingWhitespaceText :: Assertion
doNotRemoveLeadingWhitespaceText
= let sdoc :: SimpleDocStream ()
sdoc = SLine 0 (SText 2 " " (SChar 'x' SEmpty))
sdoc' = SLine 2 (SChar 'x' SEmpty)
in assertEqual "" sdoc' (removeTrailingWhitespace sdoc)
doNotRemoveLeadingWhitespaceChar :: Assertion
doNotRemoveLeadingWhitespaceChar
= let sdoc :: SimpleDocStream ()
sdoc = SLine 0 (SChar ' ' (SChar 'x' SEmpty))
sdoc' = SLine 1 (SChar 'x' SEmpty)
in assertEqual "" sdoc' (removeTrailingWhitespace sdoc)
doNotRemoveLeadingWhitespaceTextChar :: Assertion
doNotRemoveLeadingWhitespaceTextChar
= let sdoc :: SimpleDocStream ()
sdoc = SLine 0 (SChar ' ' (SText 2 " " (SChar 'x' SEmpty)))
sdoc' = SLine 3 (SChar 'x' SEmpty)
in assertEqual "" sdoc' (removeTrailingWhitespace sdoc)
removeTrailingWhitespaceKeepTrailingNewline :: Assertion
removeTrailingWhitespaceKeepTrailingNewline
= let sdoc :: SimpleDocStream ()
sdoc = SLine 0 SEmpty
in assertEqual "" sdoc (removeTrailingWhitespace sdoc)
removeTrailingNewlineWithSpaces :: Assertion
removeTrailingNewlineWithSpaces
= let sdoc :: SimpleDocStream ()
sdoc = SChar 'x' (SLine 2 (SText 2 " " SEmpty))
sdoc' = SChar 'x' (SLine 0 SEmpty)
in assertEqual "" sdoc' (removeTrailingWhitespace sdoc)
removeTrailingWhitespaceKeepLonelyTrailingNewline :: Assertion
removeTrailingWhitespaceKeepLonelyTrailingNewline
= let sdoc :: SimpleDocStream ()
sdoc = SChar 'x' (SLine 0 SEmpty)
in assertEqual "" sdoc (removeTrailingWhitespace sdoc)
removeTrailingWhitespaceInTrailingNewlines :: Assertion
removeTrailingWhitespaceInTrailingNewlines
= let sdoc :: SimpleDocStream ()
sdoc = SChar 'x' (SLine 2 (SLine 2 SEmpty))
sdoc' = SChar 'x' (SLine 0 (SLine 0 SEmpty))
in assertEqual "" sdoc' (removeTrailingWhitespace sdoc)
badFallbackAlign :: Assertion
badFallbackAlign
= let x = group (flatAlt "Default" "Fallback")
doc = "/" <> align (cat [x, x, "Too wide!!!!!"])
actual = renderStrict (layoutSmart (LayoutOptions (AvailablePerLine 12 1)) doc)
expected = "/Fallback\n Fallback\n Too wide!!!!!"
in assertEqual "" expected actual
removeTrailingWhitespaceDontRestoreIndentationInTheWrongSpot :: Assertion
removeTrailingWhitespaceDontRestoreIndentationInTheWrongSpot
= let sdoc :: SimpleDocStream ()
sdoc = SLine 2 (SLine 0 (SChar 'x' SEmpty))
sdoc' = SLine 0 (SLine 0 (SChar 'x' SEmpty))
in assertEqual "" sdoc' (removeTrailingWhitespace sdoc)
removeTrailingWhitespacePreserveIndentation :: Assertion
removeTrailingWhitespacePreserveIndentation
= let sdoc :: SimpleDocStream ()
sdoc = SLine 2 (SChar 'x' SEmpty)
in assertEqual "" sdoc (removeTrailingWhitespace sdoc)
regressionUnboundedGroupedLine :: Assertion
regressionUnboundedGroupedLine
= let sdoc :: SimpleDocStream ()
sdoc = layoutPretty (LayoutOptions Unbounded) (group hardline)
in assertEqual "" (SLine 0 SEmpty) sdoc
regressionUnboundedGroupedLineWithinAlign :: Assertion
regressionUnboundedGroupedLineWithinAlign
= let doc :: Doc ()
doc = group (align ("x" <> hardline <> "y"))
sdoc = layoutPretty (LayoutOptions Unbounded) doc
expected = SChar 'x' (SLine 0 (SChar 'y' SEmpty))
in assertEqual "" expected sdoc
indentationShouldntCauseTrailingWhitespaceOnOtherwiseEmptyLines :: Assertion
indentationShouldntCauseTrailingWhitespaceOnOtherwiseEmptyLines
= let doc :: Doc ()
doc = indent 1 ("x" <> hardline <> hardline <> "y" <> hardline)
sdoc = layoutPretty (LayoutOptions Unbounded) doc
expected = SChar ' ' (SChar 'x' (SLine 0 (SLine 1 (SChar 'y' (SLine 0 SEmpty)))))
in assertEqual "" expected sdoc
computeRibbonWidthWithFloor :: Assertion
computeRibbonWidthWithFloor
= let doc :: Doc ()
doc = "a" <> softline' <> "b"
sdoc = layoutPretty (LayoutOptions (AvailablePerLine 3 0.5)) doc
expected = SChar 'a' (SLine 0 (SChar 'b' SEmpty))
in assertEqual "" expected sdoc