content: {-# 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           Prettyprinter
  import           Prettyprinter.Internal.Debug
  import           Prettyprinter.Render.Text
  import           Prettyprinter.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
  