content: {-# LANGUAGE OverloadedStrings #-}
  
  module Text.Megaparsec.ErrorSpec (spec) where
  
  import Control.Exception (Exception (..))
  import Data.Functor.Identity
  import Data.List (isInfixOf, isSuffixOf, sort)
  import Data.List.NonEmpty (NonEmpty (..))
  import qualified Data.Set as E
  import Data.Void
  import Test.Hspec
  import Test.Hspec.Megaparsec
  import Test.Hspec.Megaparsec.AdHoc ()
  import Test.QuickCheck
  import Text.Megaparsec
  
  spec :: Spec
  spec = do
    describe "Semigroup instance of ParseError" $
      it "associativity" $
        property $ \x y z ->
          (x <> y) <> z === (x <> (y <> z) :: PE)
  
    describe "Monoid instance of ParseError" $ do
      it "left identity" $
        property $ \x ->
          mempty <> x === (x :: PE)
      it "right identity" $
        property $ \x ->
          x <> mempty === (x :: PE)
      it "associativity" $
        property $ \x y z ->
          (x <> y) <> z === (x <> (y <> z) :: PE)
  
    describe "error merging with (<>)" $ do
      it "selects greater offset" $
        property $ \x y ->
          errorOffset (x <> y :: PE) === max (errorOffset x) (errorOffset y)
      context "when combining two trivial parse errors at the same position" $
        it "merges their unexpected and expected items" $
          do
            let n Nothing Nothing = Nothing
                n (Just x) Nothing = Just x
                n Nothing (Just y) = Just y
                n (Just x) (Just y) = Just (max x y)
            property $ \pos us0 ps0 us1 ps1 ->
              TrivialError pos us0 ps0 <> TrivialError pos us1 ps1
                `shouldBe` (TrivialError pos (n us0 us1) (E.union ps0 ps1) :: PE)
      context "when combining two fancy parse errors at the same position" $
        it "merges their custom items" $
          property $ \pos xs0 xs1 ->
            FancyError pos xs0 <> FancyError pos xs1
              `shouldBe` (FancyError pos (E.union xs0 xs1) :: PE)
      context "when combining trivial error with fancy error" $ do
        it "fancy has precedence (left)" $
          property $ \pos us ps xs ->
            FancyError pos xs <> TrivialError pos us ps
              `shouldBe` (FancyError pos xs :: PE)
        it "fancy has precedence (right)" $
          property $ \pos us ps xs ->
            TrivialError pos us ps <> FancyError pos xs
              `shouldBe` (FancyError pos xs :: PE)
  
    -- NOTE 'errorOffset' and 'setErrorOffset' are trivial.
  
    describe "attachSourcePos" $
      it "attaches the positions correctly" $
        property $ \xs' s -> do
          let xs = sort $ getSmall . getPositive <$> xs'
              pst = initialPosState (s :: String)
              pst' =
                if null xs
                  then pst
                  else reachOffsetNoLine (last xs) pst
              rs = f <$> xs
              f x = (x, pstateSourcePos (reachOffsetNoLine x pst))
          attachSourcePos id (xs :: [Int]) pst `shouldBe` (rs, pst')
  
    describe "errorBundlePretty" $ do
      it "shows empty line correctly" $ do
        let s = "" :: String
        mkBundlePE s (mempty :: PE)
          `shouldBe` "1:1:\n  |\n1 | <empty line>\n  | ^\nunknown parse error\n"
      it "shows position on first line correctly" $ do
        let s = "abc" :: String
            pe = err 1 (utok 'b' <> etok 'd') :: PE
        mkBundlePE s pe
          `shouldBe` "1:2:\n  |\n1 | abc\n  |  ^\nunexpected 'b'\nexpecting 'd'\n"
      it "skips to second line correctly" $ do
        let s = "one\ntwo\n" :: String
            pe = err 4 (utok 't' <> etok 'x') :: PE
        mkBundlePE s pe
          `shouldBe` "2:1:\n  |\n2 | two\n  | ^\nunexpected 't'\nexpecting 'x'\n"
      it "shows position on 1000 line correctly" $ do
        let s = replicate 999 '\n' ++ "abc"
            pe = err 999 (utok 'a' <> etok 'd') :: PE
        mkBundlePE s pe
          `shouldBe` "1000:1:\n     |\n1000 | abc\n     | ^\nunexpected 'a'\nexpecting 'd'\n"
      it "shows offending line in the presence of tabs correctly" $ do
        let s = "\tsomething" :: String
            pe = err 1 (utok 's' <> etok 'x') :: PE
        mkBundlePE s pe
          `shouldBe` "1:9:\n  |\n1 |         something\n  |         ^\nunexpected 's'\nexpecting 'x'\n"
      it "uses continuous highlighting properly (trivial)" $ do
        let s = "\tfoobar" :: String
            pe = err 1 (utoks "foo" <> utoks "rar") :: PE
        mkBundlePE s pe
          `shouldBe` "1:9:\n  |\n1 |         foobar\n  |         ^^^\nunexpected \"rar\"\n"
      it "uses continuous highlighting properly (fancy)" $ do
        let s = "\tfoobar" :: String
            pe =
              errFancy
                1
                (fancy $ ErrorCustom (CustomErr 5)) ::
                ParseError String CustomErr
        mkBundlePE s pe
          `shouldBe` "1:9:\n  |\n1 |         foobar\n  |         ^^^^^\ncustom thing\n"
      it "adjusts continuous highlighting so it doesn't get too long" $ do
        let s = "foobar\n" :: String
            pe = err 4 (utoks "foobar" <> etoks "foobar") :: PE
        mkBundlePE s pe
          `shouldBe` "1:5:\n  |\n1 | foobar\n  |     ^^^\nunexpected \"foobar\"\nexpecting \"foobar\"\n"
      context "stream of insufficient size is provided in the bundle" $
        it "handles the situation reasonably" $
          do
            let s = "" :: String
                pe = err 3 (ueof <> etok 'x') :: PE
            mkBundlePE s pe
              `shouldBe` "1:1:\n  |\n1 | <empty line>\n  | ^\nunexpected end of input\nexpecting 'x'\n"
      context "starting column in bundle is greater than 1" $ do
        context "and less than parse error column" $
          it "is rendered correctly" $
            do
              let s = "foo" :: String
                  pe = err 5 (utok 'o' <> etok 'x') :: PE
                  bundle =
                    ParseErrorBundle
                      { bundleErrors = pe :| [],
                        bundlePosState =
                          PosState
                            { pstateInput = s,
                              pstateOffset = 4,
                              pstateSourcePos = SourcePos "" pos1 (mkPos 5),
                              pstateTabWidth = defaultTabWidth,
                              pstateLinePrefix = ""
                            }
                      }
              errorBundlePretty bundle
                `shouldBe` "1:6:\n  |\n1 | foo\n  | \nunexpected 'o'\nexpecting 'x'\n"
        context "and greater than parse error column" $
          it "is rendered correctly" $
            do
              let s = "foo" :: String
                  pe = err 5 (utok 'o' <> etok 'x') :: PE
                  bundle =
                    ParseErrorBundle
                      { bundleErrors = pe :| [],
                        bundlePosState =
                          PosState
                            { pstateInput = s,
                              pstateOffset = 9,
                              pstateSourcePos = SourcePos "" pos1 (mkPos 10),
                              pstateTabWidth = defaultTabWidth,
                              pstateLinePrefix = ""
                            }
                      }
              errorBundlePretty bundle
                `shouldBe` "1:10:\n  |\n1 | foo\n  | \nunexpected 'o'\nexpecting 'x'\n"
      it "takes tab width into account correctly" $
        property $ \w' i' -> do
          let w = unPos w'
              i = unPos i' `rem` (w * 2)
              as = replicate i 'a'
              s = "\t" ++ as ++ "\tb" :: String
              pe = err (2 + i) (utok 'b' <> etok 'x') :: PE
              bundle =
                ParseErrorBundle
                  { bundleErrors = pe :| [],
                    bundlePosState =
                      PosState
                        { pstateInput = s,
                          pstateOffset = 0,
                          pstateSourcePos = initialPos "",
                          pstateTabWidth = w',
                          pstateLinePrefix = ""
                        }
                  }
              secondTabApparentWidth = w - (i `rem` w)
              errColumn = w + i + secondTabApparentWidth
          errorBundlePretty bundle
            `shouldBe` ( "1:"
                           ++ show (errColumn + 1)
                           ++ ":\n  |\n1 | "
                           ++ replicate w ' '
                           ++ as
                           ++ replicate secondTabApparentWidth ' '
                           ++ "b"
                           ++ "\n  | "
                           ++ replicate errColumn ' '
                           ++ "^\nunexpected 'b'\nexpecting 'x'\n"
                       )
      context "in the presence of wide characters" $ do
        it "calculates column positions correctly" $ do
          let s = "구구 이면" :: String
              pe = err 2 (ulabel "space" <> etok '이') :: PE
              bundle =
                ParseErrorBundle
                  { bundleErrors = pe :| [],
                    bundlePosState =
                      PosState
                        { pstateInput = s,
                          pstateOffset = 0,
                          pstateSourcePos = initialPos "",
                          pstateTabWidth = defaultTabWidth,
                          pstateLinePrefix = ""
                        }
                  }
          errorBundlePretty bundle
            `shouldBe` "1:5:\n  |\n1 | 구구 이면\n  |     ^\nunexpected space\nexpecting '이'\n"
        it "uses continuous highlighting" $ do
          let s = "구구 이면" :: String
              pe = err 3 (utok '이' <> etok '구') :: PE
              bundle =
                ParseErrorBundle
                  { bundleErrors = pe :| [],
                    bundlePosState =
                      PosState
                        { pstateInput = s,
                          pstateOffset = 0,
                          pstateSourcePos = initialPos "",
                          pstateTabWidth = defaultTabWidth,
                          pstateLinePrefix = ""
                        }
                  }
          errorBundlePretty bundle
            `shouldBe` "1:6:\n  |\n1 | 구구 이면\n  |      ^^\nunexpected '이'\nexpecting '구'\n"
      it "displays multi-error bundle correctly" $ do
        let s = "something\ngood\n" :: String
            pe0 = err 2 (utok 'm' <> etok 'x') :: PE
            pe1 = err 10 (utok 'g' <> etok 'y') :: PE
            bundle =
              ParseErrorBundle
                { bundleErrors = pe0 :| [pe1],
                  bundlePosState =
                    PosState
                      { pstateInput = s,
                        pstateOffset = 0,
                        pstateSourcePos = initialPos "",
                        pstateTabWidth = defaultTabWidth,
                        pstateLinePrefix = ""
                      }
                }
        errorBundlePretty bundle
          `shouldBe` "1:3:\n  |\n1 | something\n  |   ^\nunexpected 'm'\nexpecting 'x'\n\n2:1:\n  |\n2 | good\n  | ^\nunexpected 'g'\nexpecting 'y'\n"
  
    describe "parseErrorPretty" $ do
      it "shows unknown ParseError correctly" $
        parseErrorPretty (mempty :: PE) `shouldBe` "offset=0:\nunknown parse error\n"
      it "result always ends with a newline" $
        property $ \x ->
          parseErrorPretty (x :: PE) `shouldSatisfy` ("\n" `isSuffixOf`)
      it "result contains representation of offset" $
        property (contains (Identity . errorOffset) show)
      it "result contains unexpected/expected items" $ do
        let e = err 0 (utoks "foo" <> etoks "bar" <> etoks "baz") :: PE
        parseErrorPretty e `shouldBe` "offset=0:\nunexpected \"foo\"\nexpecting \"bar\" or \"baz\"\n"
      it "result contains representation of custom items" $ do
        let e = errFancy 0 (fancy (ErrorFail "Ooops!")) :: PE
        parseErrorPretty e `shouldBe` "offset=0:\nOoops!\n"
      it "several fancy errors look not so bad" $ do
        let pe :: PE
            pe =
              errFancy 0 $
                mempty <> fancy (ErrorFail "foo") <> fancy (ErrorFail "bar")
        parseErrorPretty pe `shouldBe` "offset=0:\nbar\nfoo\n"
  
    describe "parseErrorTextPretty" $ do
      it "shows trivial unknown ParseError correctly" $
        parseErrorTextPretty (mempty :: PE)
          `shouldBe` "unknown parse error\n"
      it "shows fancy unknown ParseError correctly" $
        parseErrorTextPretty (FancyError 0 E.empty :: PE)
          `shouldBe` "unknown fancy parse error\n"
      it "result always ends with a newline" $
        property $ \x ->
          parseErrorTextPretty (x :: PE)
            `shouldSatisfy` ("\n" `isSuffixOf`)
  
    describe "displayException" $
      it "produces the same result as parseErrorPretty" $
        property $ \x ->
          displayException x `shouldBe` parseErrorPretty (x :: PE)
  
  ----------------------------------------------------------------------------
  -- Helpers
  
  -- | A custom error component to test continuous highlighting for custom
  -- components.
  newtype CustomErr = CustomErr Int
    deriving (Eq, Ord, Show)
  
  instance ShowErrorComponent CustomErr where
    showErrorComponent _ = "custom thing"
    errorComponentLen (CustomErr n) = n
  
  type PE = ParseError String Void
  
  contains :: (Foldable t) => (PE -> t a) -> (a -> String) -> PE -> Property
  contains g r e = property (all f (g e))
    where
      rendered = parseErrorPretty e
      f x = r x `isInfixOf` rendered
  
  mkBundlePE ::
    ( VisualStream s,
      TraversableStream s,
      ShowErrorComponent e
    ) =>
    s ->
    ParseError s e ->
    String
  mkBundlePE s e =
    errorBundlePretty $
      ParseErrorBundle
        { bundleErrors = e :| [],
          bundlePosState =
            PosState
              { pstateInput = s,
                pstateOffset = 0,
                pstateSourcePos = initialPos "",
                pstateTabWidth = defaultTabWidth,
                pstateLinePrefix = ""
              }
        }
  