{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}

module Text.Megaparsec.ErrorSpec (spec) where

import Control.Exception (Exception (..))
import Data.Functor.Identity
import Data.List (isSuffixOf, isInfixOf, sort)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Void
import Test.Hspec
import Test.Hspec.Megaparsec
import Test.Hspec.Megaparsec.AdHoc ()
import Test.QuickCheck
import Text.Megaparsec
import qualified Data.Semigroup     as S
import qualified Data.Set           as E

#if !MIN_VERSION_base(4,11,0)
import Data.Monoid
#endif

spec :: Spec
spec = do

  describe "Semigroup instance of ParseError" $
    it "associativity" $
      property $ \x y z ->
        (x S.<> y) S.<> z === (x S.<> (y S.<> 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)

  describe "errorOffset" $
    it "returns error position" $
      property $ \e ->
        errorOffset e `shouldBe`
          (case e :: PE of
            TrivialError o _ _ -> o
            FancyError   o _   -> o)

  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 snd $ reachOffsetNoLine (last xs) pst
            rs = f <$> xs
            f x = (x, fst (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' -> do
        let s  = "\tsomething\t" :: String
            pe = err 1 (utok 's' <> etok 'x') :: PE
            bundle = ParseErrorBundle
              { bundleErrors = pe :| []
              , bundlePosState = PosState
                { pstateInput = s
                , pstateOffset = 0
                , pstateSourcePos = initialPos ""
                , pstateTabWidth = w'
                , pstateLinePrefix = ""
                }
              }
            w  = unPos w'
            tabRep = replicate w ' '
        errorBundlePretty bundle `shouldBe`
          ("1:" ++ show (w + 1) ++ ":\n  |\n1 | " ++ tabRep ++
           "something" ++ tabRep ++
           "\n  | " ++ tabRep ++ "^\nunexpected 's'\nexpecting 'x'\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

-- | 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
  :: (Stream 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 = ""
    }
  }