{-# LANGUAGE CPP              #-}
{-# OPTIONS -fno-warn-orphans #-}

module Text.Megaparsec.ErrorSpec (spec) where

import Data.Char (isControl, isSpace)
import Data.Function (on)
import Data.List (isInfixOf, isSuffixOf)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Monoid
import Data.Set (Set)
import Test.Hspec
import Test.QuickCheck
import Text.Megaparsec.Error
import Text.Megaparsec.Pos
import qualified Data.List.NonEmpty as NE
import qualified Data.Semigroup     as S
import qualified Data.Set           as E

#if !MIN_VERSION_base(4,8,0)
import Data.Foldable (Foldable, all)
import Prelude hiding (all)
#else
import Control.Exception (Exception (..))
#endif

type PE = ParseError Char Dec

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 "Read and Show instances of ParseError" $
    it "printed representation of ParseError can be read back" $
      property $ \x ->
        read (show x) === (x :: PE)

  describe "error merging with (<>)" $ do
    it "selects greater source position" $
      property $ \x y ->
        errorPos (x <> y :: PE) === max (errorPos x) (errorPos y)
    it "merges unexpected items correctly" $
      property (checkMergedItems errorUnexpected)
    it "merges expected items correctly" $
      property (checkMergedItems errorExpected)
    it "merges custom items correctly" $
      property (checkMergedItems errorCustom)

  describe "showTokens (Char instance)" $ do
    let f x y = showTokens (NE.fromList x) `shouldBe` y
    it "shows CRLF newline correctly"
      (f "\r\n" "crlf newline")
    it "shows null byte correctly"
      (f "\NUL" "null (control character)")
    it "shows start of heading correctly"
      (f "\SOH" "start of heading (control character)")
    it "shows start of text correctly"
      (f "\STX" "start of text (control character)")
    it "shows end of text correctly"
      (f "\ETX" "end of text (control character)")
    it "shows end of transmission correctly"
      (f "\EOT" "end of transmission (control character)")
    it "shows enquiry correctly"
      (f "\ENQ" "enquiry (control character)")
    it "shows acknowledge correctly"
      (f "\ACK" "acknowledge (control character)")
    it "shows bell correctly"
      (f "\BEL" "bell (control character)")
    it "shows backspace correctly"
      (f "\BS" "backspace")
    it "shows tab correctly"
      (f "\t" "tab")
    it "shows newline correctly"
      (f "\n" "newline")
    it "shows vertical tab correctly"
      (f "\v" "vertical tab")
    it "shows form feed correctly"
      (f "\f" "form feed (control character)")
    it "shows carriage return correctly"
      (f "\r" "carriage return")
    it "shows shift out correctly"
      (f "\SO" "shift out (control character)")
    it "shows shift in correctly"
      (f "\SI" "shift in (control character)")
    it "shows data link escape correctly"
      (f "\DLE" "data link escape (control character)")
    it "shows device control one correctly"
      (f "\DC1" "device control one (control character)")
    it "shows device control two correctly"
      (f "\DC2" "device control two (control character)")
    it "shows device control three correctly"
      (f "\DC3" "device control three (control character)")
    it "shows device control four correctly"
      (f "\DC4" "device control four (control character)")
    it "shows negative acknowledge correctly"
      (f "\NAK" "negative acknowledge (control character)")
    it "shows synchronous idle correctly"
      (f "\SYN" "synchronous idle (control character)")
    it "shows end of transmission block correctly"
      (f "\ETB" "end of transmission block (control character)")
    it "shows cancel correctly"
      (f "\CAN" "cancel (control character)")
    it "shows end of medium correctly"
      (f "\EM"  "end of medium (control character)")
    it "shows substitute correctly"
      (f "\SUB" "substitute (control character)")
    it "shows escape correctly"
      (f "\ESC" "escape (control character)")
    it "shows file separator correctly"
      (f "\FS"  "file separator (control character)")
    it "shows group separator correctly"
      (f "\GS"  "group separator (control character)")
    it "shows record separator correctly"
      (f "\RS"  "record separator (control character)")
    it "shows unit separator correctly"
      (f "\US"  "unit separator (control character)")
    it "shows delete correctly"
      (f "\DEL" "delete (control character)")
    it "shows space correctly"
      (f " "    "space")
    it "shows non-breaking space correctly"
      (f "\160" "non-breaking space")
    it "shows other single characters in single quotes" $
      property $ \ch ->
        not (isControl ch) && not (isSpace ch) ==>
          showTokens (ch :| []) === ['\'',ch,'\'']
    it "shows strings in double quotes" $
      property $ \str ->
        (length str > 1) && (str /= "\r\n") ==>
          showTokens (NE.fromList str) === ("\"" ++ str ++"\"")

  describe "parseErrorPretty" $ do
    it "shows unknown ParseError correctly" $
      parseErrorPretty (mempty :: PE) `shouldBe` "1:1:\nunknown parse error\n"
    it "result always ends with a newline" $
      property $ \x ->
        parseErrorPretty (x :: PE) `shouldSatisfy` ("\n" `isSuffixOf`)
    it "result contains representation of source pos stack" $
      property (contains errorPos sourcePosPretty)
    it "result contains representation of unexpected items" $
      property (contains errorUnexpected showErrorComponent)
    it "result contains representation of expected items" $
      property (contains errorExpected showErrorComponent)
    it "result contains representation of custom items" $
      property (contains errorCustom showErrorComponent)

  describe "sourcePosStackPretty" $
    it "result never ends with a newline " $
      property $ \x ->
        let pos = errorPos (x :: PE)
        in sourcePosStackPretty pos `shouldNotSatisfy` ("\n" `isSuffixOf`)

  describe "parseErrorTextPretty" $ do
    it "shows unknown ParseError correctly" $
      parseErrorTextPretty (mempty :: PE) `shouldBe` "unknown parse error\n"
    it "result always ends with a newline" $
      property $ \x ->
        parseErrorTextPretty (x :: PE) `shouldSatisfy` ("\n" `isSuffixOf`)

#if MIN_VERSION_base(4,8,0)
  describe "displayException" $
    it "produces the same result as parseErrorPretty" $
      property $ \x ->
        displayException x `shouldBe` parseErrorPretty (x :: PE)
#endif

----------------------------------------------------------------------------
-- Helpers

checkMergedItems :: (Ord a, Show a) => (PE -> Set a) -> PE -> PE -> Property
checkMergedItems f e1 e2 = f (e1 <> e2) === r
  where r = case (compare `on` errorPos) e1 e2 of
              LT -> f e2
              EQ -> (E.union `on` f) e1 e2
              GT -> f e1

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