{-# 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 _ = "" 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