Skip to content

Commit

Permalink
Run fusion property test with arbitrary layouters
Browse files Browse the repository at this point in the history
Context: quchen#95
  • Loading branch information
sjakobi committed Nov 6, 2019
1 parent 7da3b1d commit 92dd87b
Showing 1 changed file with 48 additions and 6 deletions.
54 changes: 48 additions & 6 deletions prettyprinter/test/Testsuite/Main.hs
Original file line number Diff line number Diff line change
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-}

#include "version-compatibility-macros.h"

Expand All @@ -13,9 +14,11 @@ import qualified Data.Text as T
import Data.Text.PgpWordlist
import Data.Word
import System.Timeout (timeout)
import Text.Show.Functions ()

import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.Text
import Data.Text.Prettyprint.Doc
import qualified Data.Text.Prettyprint.Doc.Internal as Internal
import Data.Text.Prettyprint.Doc.Render.Text

import Test.Tasty
import Test.Tasty.HUnit
Expand Down Expand Up @@ -86,20 +89,59 @@ tests = testGroup "Tests"
fusionDoesNotChangeRendering :: FusionDepth -> Property
fusionDoesNotChangeRendering depth
= forAll document (\doc ->
let rendered = render doc
forAll (layouter :: Gen (LayoutOptions -> Doc Int -> SimpleDocStream Int)) (\layouter_ ->
forAll arbitrary (\layoutOptions ->
let render = renderStrict . layouter_ layoutOptions
rendered = render doc
renderedFused = render (fuse depth doc)
in counterexample (mkCounterexample rendered renderedFused)
(render doc == render (fuse depth doc)) )
(render doc == render (fuse depth doc)) )))
where
render = renderStrict . layoutPretty defaultLayoutOptions
mkCounterexample rendered renderedFused
= (T.unpack . render . vsep)
= (T.unpack . renderStrict . layoutPretty defaultLayoutOptions . vsep)
[ "Unfused and fused documents render differently!"
, "Unfused:"
, indent 4 (pretty rendered)
, "Fused:"
, indent 4 (pretty renderedFused) ]

layouter :: CoArbitrary ann => Gen (LayoutOptions -> Doc ann -> SimpleDocStream ann)
layouter = oneof
[ pure layoutPretty
, pure layoutSmart
, pure (const layoutCompact)
-- , Internal.layoutWadlerLeijen <$> arbitrary -- too inconsistent for fusionDoesNotChangeRendering
]

instance Arbitrary LayoutOptions where
arbitrary = LayoutOptions <$> oneof
[ AvailablePerLine <$> arbitrary <*> arbitrary
-- , pure Unbounded -- https://github.com/quchen/prettyprinter/issues/91
]

instance CoArbitrary ann => Arbitrary (Internal.FittingPredicate ann) where
arbitrary = Internal.FittingPredicate <$> arbitrary

instance CoArbitrary ann => CoArbitrary (SimpleDocStream ann) where
-- TODO: It might be more realistic to ignore the 'Char', 'Text' and 'ann'
-- values in the fitting predicate
coarbitrary s0 = case s0 of
SFail -> variant' 0
SEmpty -> variant' 1
SChar c s -> variant' 2 . coarbitrary (c, s)
SText l t s -> variant' 3 . coarbitrary (l, T.unpack t, s)
SLine i s -> variant' 4 . coarbitrary (i, s)
SAnnPush a s -> variant' 5 . coarbitrary (a, 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

newtype RandomDoc ann = RandomDoc (Doc ann)

instance Arbitrary (RandomDoc ann) where
Expand Down

0 comments on commit 92dd87b

Please sign in to comment.