content: {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  
  module Text.Megaparsec.StreamSpec (spec) where
  
  import Control.Monad
  import qualified Data.ByteString as B
  import qualified Data.ByteString.Lazy as BL
  import Data.Char (chr, isControl, isLetter, isSpace)
  import Data.List (foldl')
  import Data.List.NonEmpty (NonEmpty (..))
  import qualified Data.List.NonEmpty as NE
  import Data.Proxy
  import Data.String (IsString)
  import qualified Data.Text as T
  import qualified Data.Text.Lazy as TL
  import Data.Word (Word8)
  import Test.Hspec
  import Test.Hspec.Megaparsec.AdHoc
  import Test.QuickCheck
  import Text.Megaparsec
  
  spec :: Spec
  spec = do
    describe "String instance of Stream" $ do
      describe "tokenToChunk" $
        it "produces the same result as singleton with tokensToChunk" $
          property $ \ch ->
            tokenToChunk sproxy ch === tokensToChunk sproxy [ch]
      describe "tokensToChunk" $
        it "list of tokens is isomorphic to chunk" $
          property $ \ts ->
            chunkToTokens sproxy (tokensToChunk sproxy ts) === ts
      describe "chunkToTokens" $
        it "chunk is isomorphic to list of tokens" $
          property $ \chk ->
            tokensToChunk sproxy (chunkToTokens sproxy chk) === chk
      describe "chunkLength" $
        it "returns correct length of given chunk" $
          property $ \chk ->
            chunkLength sproxy chk === length chk
      describe "chunkEmpty" $
        it "only true when chunkLength returns 0" $
          property $ \chk ->
            chunkEmpty sproxy chk === (chunkLength sproxy chk <= 0)
      describe "take1_" $ do
        context "when input in empty" $
          it "returns Nothing" $
            take1_ ("" :: String) === Nothing
        context "when input is not empty" $
          it "unconses a token" $
            property $ \s ->
              not (null s) ==>
                take1_ (s :: String) === Just (head s, tail s)
      describe "takeN_" $ do
        context "requested length is 0" $
          it "returns Just empty chunk and original stream" $
            property $ \s ->
              takeN_ 0 (s :: String) === Just ("", s)
        context "requested length is greater than 0" $ do
          context "stream is empty" $
            it "returns Nothing" $
              property $ \(Positive n) ->
                takeN_ n ("" :: String) === Nothing
          context "stream is not empty" $
            it "returns a chunk of correct length and rest of the stream" $
              property $ \(Positive n) s ->
                not (null s) ==>
                  takeN_ n (s :: String) === Just (splitAt n s)
      describe "takeWhile_" $
        it "extracts a chunk that is a prefix consisting of matching tokens" $
          property $ \s ->
            takeWhile_ isLetter s === span isLetter s
      describeShowTokens sproxy quotedCharGen
      describeReachOffset sproxy
      describeReachOffsetNoLine sproxy
  
    describe "ByteString instance of Stream" $ do
      describe "tokenToChunk" $
        it "produces the same result as singleton with tokensToChunk" $
          property $ \ch ->
            tokenToChunk bproxy ch === tokensToChunk bproxy [ch]
      describe "tokensToChunk" $
        it "list of tokens is isomorphic to chunk" $
          property $ \ts ->
            chunkToTokens bproxy (tokensToChunk bproxy ts) === ts
      describe "chunkToTokens" $
        it "chunk is isomorphic to list of tokens" $
          property $ \chk ->
            tokensToChunk bproxy (chunkToTokens bproxy chk) === chk
      describe "chunkLength" $
        it "returns correct length of given chunk" $
          property $ \chk ->
            chunkLength bproxy chk === B.length chk
      describe "chunkEmpty" $
        it "only true when chunkLength returns 0" $
          property $ \chk ->
            chunkEmpty bproxy chk === (chunkLength bproxy chk <= 0)
      describe "take1_" $ do
        context "when input in empty" $
          it "returns Nothing" $
            take1_ ("" :: B.ByteString) === Nothing
        context "when input is not empty" $
          it "unconses a token" $
            property $ \s ->
              not (B.null s) ==>
                take1_ (s :: B.ByteString) === B.uncons s
      describe "takeN_" $ do
        context "requested length is 0" $
          it "returns Just empty chunk and original stream" $
            property $ \s ->
              takeN_ 0 (s :: B.ByteString) === Just ("", s)
        context "requested length is greater than 0" $ do
          context "stream is empty" $
            it "returns Nothing" $
              property $ \(Positive n) ->
                takeN_ n ("" :: B.ByteString) === Nothing
          context "stream is not empty" $
            it "returns a chunk of correct length and rest of the stream" $
              property $ \(Positive n) s ->
                not (B.null s) ==>
                  takeN_ n (s :: B.ByteString) === Just (B.splitAt n s)
      describe "takeWhile_" $
        it "extracts a chunk that is a prefix consisting of matching tokens" $
          property $ \s ->
            let f = isLetter . chr . fromIntegral
             in takeWhile_ f s === B.span f s
      describeShowTokens bproxy quotedWordGen
      describeReachOffset bproxy
      describeReachOffsetNoLine bproxy
  
    describe "Lazy ByteString instance of Stream" $ do
      describe "tokenToChunk" $
        it "produces the same result as singleton with tokensToChunk" $
          property $ \ch ->
            tokenToChunk blproxy ch === tokensToChunk blproxy [ch]
      describe "tokensToChunk" $
        it "list of tokens is isomorphic to chunk" $
          property $ \ts ->
            chunkToTokens blproxy (tokensToChunk blproxy ts) === ts
      describe "chunkToTokens" $
        it "chunk is isomorphic to list of tokens" $
          property $ \chk ->
            tokensToChunk blproxy (chunkToTokens blproxy chk) === chk
      describe "chunkLength" $
        it "returns correct length of given chunk" $
          property $ \chk ->
            chunkLength blproxy chk === fromIntegral (BL.length chk)
      describe "chunkEmpty" $
        it "only true when chunkLength returns 0" $
          property $ \chk ->
            chunkEmpty blproxy chk === (chunkLength blproxy chk <= 0)
      describe "take1_" $ do
        context "when input in empty" $
          it "returns Nothing" $
            take1_ ("" :: BL.ByteString) === Nothing
        context "when input is not empty" $
          it "unconses a token" $
            property $ \s ->
              not (BL.null s) ==>
                take1_ (s :: BL.ByteString) === BL.uncons s
      describe "takeN_" $ do
        context "requested length is 0" $
          it "returns Just empty chunk and original stream" $
            property $ \s ->
              takeN_ 0 (s :: BL.ByteString) === Just ("", s)
        context "requested length is greater than 0" $ do
          context "stream is empty" $
            it "returns Nothing" $
              property $ \(Positive n) ->
                takeN_ n ("" :: BL.ByteString) === Nothing
          context "stream is not empty" $
            it "returns a chunk of correct length and rest of the stream" $
              property $ \(Positive n) s ->
                not (BL.null s) ==>
                  takeN_ n (s :: BL.ByteString) === Just (BL.splitAt (fromIntegral n) s)
      describe "takeWhile_" $
        it "extracts a chunk that is a prefix consisting of matching tokens" $
          property $ \s ->
            let f = isLetter . chr . fromIntegral
             in takeWhile_ f s === BL.span f s
      describeShowTokens blproxy quotedWordGen
      describeReachOffset blproxy
      describeReachOffsetNoLine blproxy
  
    describe "Text instance of Stream" $ do
      describe "tokenToChunk" $
        it "produces the same result as singleton with tokensToChunk" $
          property $ \ch ->
            tokenToChunk tproxy ch === tokensToChunk tproxy [ch]
      describe "tokensToChunk" $
        it "list of tokens is isomorphic to chunk" $
          property $ \ts ->
            chunkToTokens tproxy (tokensToChunk tproxy ts) === ts
      describe "chunkToTokens" $
        it "chunk is isomorphic to list of tokens" $
          property $ \chk ->
            tokensToChunk tproxy (chunkToTokens tproxy chk) === chk
      describe "chunkLength" $
        it "returns correct length of given chunk" $
          property $ \chk ->
            chunkLength tproxy chk === T.length chk
      describe "chunkEmpty" $
        it "only true when chunkLength returns 0" $
          property $ \chk ->
            chunkEmpty tproxy chk === (chunkLength tproxy chk <= 0)
      describe "take1_" $ do
        context "when input in empty" $
          it "returns Nothing" $
            take1_ ("" :: T.Text) === Nothing
        context "when input is not empty" $
          it "unconses a token" $
            property $ \s ->
              not (T.null s) ==>
                take1_ (s :: T.Text) === T.uncons s
      describe "takeN_" $ do
        context "requested length is 0" $
          it "returns Just empty chunk and original stream" $
            property $ \s ->
              takeN_ 0 (s :: T.Text) === Just ("", s)
        context "requested length is greater than 0" $ do
          context "stream is empty" $
            it "returns Nothing" $
              property $ \(Positive n) ->
                takeN_ n ("" :: T.Text) === Nothing
          context "stream is not empty" $
            it "returns a chunk of correct length and rest of the stream" $
              property $ \(Positive n) s ->
                not (T.null s) ==>
                  takeN_ n (s :: T.Text) === Just (T.splitAt n s)
      describe "takeWhile_" $
        it "extracts a chunk that is a prefix consisting of matching tokens" $
          property $ \s ->
            takeWhile_ isLetter s === T.span isLetter s
      describeShowTokens tproxy quotedCharGen
      describeReachOffset tproxy
      describeReachOffsetNoLine tproxy
  
    describe "Lazy Text instance of Stream" $ do
      describe "tokenToChunk" $
        it "produces the same result as singleton with tokensToChunk" $
          property $ \ch ->
            tokenToChunk tlproxy ch === tokensToChunk tlproxy [ch]
      describe "tokensToChunk" $
        it "list of tokens is isomorphic to chunk" $
          property $ \ts ->
            chunkToTokens tlproxy (tokensToChunk tlproxy ts) === ts
      describe "chunkToTokens" $
        it "chunk is isomorphic to list of tokens" $
          property $ \chk ->
            tokensToChunk tlproxy (chunkToTokens tlproxy chk) === chk
      describe "chunkLength" $
        it "returns correct length of given chunk" $
          property $ \chk ->
            chunkLength tlproxy chk === fromIntegral (TL.length chk)
      describe "chunkEmpty" $
        it "only true when chunkLength returns 0" $
          property $ \chk ->
            chunkEmpty tlproxy chk === (chunkLength tlproxy chk <= 0)
      describe "take1_" $ do
        context "when input in empty" $
          it "returns Nothing" $
            take1_ ("" :: TL.Text) === Nothing
        context "when input is not empty" $
          it "unconses a token" $
            property $ \s ->
              not (TL.null s) ==>
                take1_ (s :: TL.Text) === TL.uncons s
      describe "takeN_" $ do
        context "requested length is 0" $
          it "returns Just empty chunk and original stream" $
            property $ \s ->
              takeN_ 0 (s :: TL.Text) === Just ("", s)
        context "requested length is greater than 0" $ do
          context "stream is empty" $
            it "returns Nothing" $
              property $ \(Positive n) ->
                takeN_ n ("" :: TL.Text) === Nothing
          context "stream is not empty" $
            it "returns a chunk of correct length and rest of the stream" $
              property $ \(Positive n) s ->
                not (TL.null s) ==>
                  takeN_ n (s :: TL.Text) === Just (TL.splitAt (fromIntegral n) s)
      describe "takeWhile_" $
        it "extracts a chunk that is a prefix consisting of matching tokens" $
          property $ \s ->
            takeWhile_ isLetter s === TL.span isLetter s
      describeShowTokens tlproxy quotedCharGen
      describeReachOffset tlproxy
      describeReachOffsetNoLine tlproxy
  
  ----------------------------------------------------------------------------
  -- Helpers
  
  -- | Generic block of tests for the 'showTokens' method.
  describeShowTokens ::
    forall s.
    ( VisualStream s,
      IsString (Tokens s),
      Show (Token s),
      Arbitrary (Token s)
    ) =>
    -- | 'Proxy' that clarifies the type of stream
    Proxy s ->
    -- | Generator of tokens that should be simply quoted
    Gen (Token s) ->
    Spec
  describeShowTokens pxy quotedTokGen =
    describe "showTokens" $ do
      let f :: Tokens s -> String -> Expectation
          f x y = showTokens pxy (NE.fromList $ chunkToTokens pxy x) `shouldBe` y
      it
        "shows CRLF newline correctly"
        (f "\r\n" "crlf newline")
      it
        "shows null byte correctly"
        (f "\NUL" "null")
      it
        "shows start of heading correctly"
        (f "\SOH" "start of heading")
      it
        "shows start of text correctly"
        (f "\STX" "start of text")
      it
        "shows end of text correctly"
        (f "\ETX" "end of text")
      it
        "shows end of transmission correctly"
        (f "\EOT" "end of transmission")
      it
        "shows enquiry correctly"
        (f "\ENQ" "enquiry")
      it
        "shows acknowledge correctly"
        (f "\ACK" "acknowledge")
      it
        "shows bell correctly"
        (f "\BEL" "bell")
      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")
      it
        "shows carriage return correctly"
        (f "\r" "carriage return")
      it
        "shows shift out correctly"
        (f "\SO" "shift out")
      it
        "shows shift in correctly"
        (f "\SI" "shift in")
      it
        "shows data link escape correctly"
        (f "\DLE" "data link escape")
      it
        "shows device control one correctly"
        (f "\DC1" "device control one")
      it
        "shows device control two correctly"
        (f "\DC2" "device control two")
      it
        "shows device control three correctly"
        (f "\DC3" "device control three")
      it
        "shows device control four correctly"
        (f "\DC4" "device control four")
      it
        "shows negative acknowledge correctly"
        (f "\NAK" "negative acknowledge")
      it
        "shows synchronous idle correctly"
        (f "\SYN" "synchronous idle")
      it
        "shows end of transmission block correctly"
        (f "\ETB" "end of transmission block")
      it
        "shows cancel correctly"
        (f "\CAN" "cancel")
      it
        "shows end of medium correctly"
        (f "\EM" "end of medium")
      it
        "shows substitute correctly"
        (f "\SUB" "substitute")
      it
        "shows escape correctly"
        (f "\ESC" "escape")
      it
        "shows file separator correctly"
        (f "\FS" "file separator")
      it
        "shows group separator correctly"
        (f "\GS" "group separator")
      it
        "shows record separator correctly"
        (f "\RS" "record separator")
      it
        "shows unit separator correctly"
        (f "\US" "unit separator")
      it
        "shows delete correctly"
        (f "\DEL" "delete")
      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 $
          forAll quotedTokGen $ \x -> do
            let r = showTokens pxy (x :| [])
            head r `shouldBe` '\''
            last r `shouldBe` '\''
      it "shows strings in double quotes" $
        property $ \x (NonEmpty xs) -> do
          let r = showTokens pxy (x :| xs)
          when (r == "crlf newline") discard
          head r `shouldBe` '\"'
          last r `shouldBe` '\"'
      it
        "shows control characters in long strings property"
        (f "{\n" "\"{<newline>\"")
  
  -- | Generic block of tests for the 'reachOffset' method.
  describeReachOffset ::
    forall s.
    ( TraversableStream s,
      IsString s,
      Show s,
      Arbitrary s
    ) =>
    -- | 'Proxy' that clarifies the type of stream
    Proxy s ->
    Spec
  describeReachOffset Proxy =
    describe "reachOffset" $ do
      it "returns correct SourcePos (newline)" $
        property $ \pst' -> do
          let pst =
                (pst' :: PosState s)
                  { pstateInput = "\n" :: s
                  }
              o = pstateOffset pst + 1
              r = pstateSourcePos . snd $ reachOffset o pst
              SourcePos n l _ = pstateSourcePos pst
          r `shouldBe` SourcePos n (l <> pos1) pos1
      it "returns correct SourcePos (tab)" $
        property $ \pst' -> do
          let pst =
                (pst' :: PosState s)
                  { pstateInput = "\t" :: s
                  }
              o = pstateOffset pst + 1
              r = pstateSourcePos . snd $ reachOffset o pst
              SourcePos n l c = pstateSourcePos pst
              w = pstateTabWidth pst
          r `shouldBe` SourcePos n l (toNextTab w c)
      it "returns correct SourcePos (other)" $
        property $ \pst' -> do
          let pst =
                (pst' :: PosState s)
                  { pstateInput = "a" :: s
                  }
              o = pstateOffset pst + 1
              r = pstateSourcePos . snd $ reachOffset o pst
              SourcePos n l c = pstateSourcePos pst
          r `shouldBe` SourcePos n l (c <> pos1)
      it "replaces empty line with <empty line>" $
        property $ \o pst' -> do
          let pst =
                (pst' :: PosState s)
                  { pstateInput = "" :: s,
                    pstateLinePrefix = ""
                  }
              (r, _) = reachOffset o pst
          r `shouldBe` Just "<empty line>"
      it "replaces tabs with spaces in returned line" $
        property $ \pst' -> do
          let pst =
                (pst' :: PosState s)
                  { pstateInput = "\ta\t" :: s,
                    pstateLinePrefix = "\t"
                  }
              (r, _) = reachOffset 2 pst
              w = unPos (pstateTabWidth pst)
              r' = replicate (w * 2) ' ' ++ "a" ++ replicate (max 1 (w - 1)) ' '
          r `shouldBe` Just r'
      it "returns correct line (with line prefix)" $
        property $ \pst' -> do
          let pst =
                (pst' :: PosState s)
                  { pstateInput = "foo\nbar\nbaz" :: s,
                    pstateLinePrefix = "123"
                  }
              (r, _) = reachOffset 0 pst
          r `shouldBe` Just "123foo"
      it "returns correct line (without line prefix)" $
        property $ \pst' -> do
          let pst =
                (pst' :: PosState s)
                  { pstateInput = "foo\nbar\nbaz" :: s,
                    pstateOffset = 0
                  }
              (r, _) = reachOffset 4 pst
          r `shouldBe` Just "bar"
      it "works incrementally" $
        property $ \os' (NonNegative d) s -> do
          let os = getNonNegative <$> os'
              s' :: PosState String
              s' = foldl' f s os
              o' = case os of
                [] -> d
                xs -> maximum xs + d
              f pst o =
                let (_, pst') = reachOffset o pst
                 in pst'
          reachOffset o' s `shouldBe` reachOffset o' s'
  
  -- | Generic block of tests for the 'reachOffsetNoLine' method.
  describeReachOffsetNoLine ::
    forall s.
    ( TraversableStream s,
      IsString s,
      Show s,
      Arbitrary s
    ) =>
    -- | 'Proxy' that clarifies the type of stream
    Proxy s ->
    Spec
  describeReachOffsetNoLine Proxy =
    describe "reachOffsetNoLine" $ do
      it "returns correct SourcePos (newline)" $
        property $ \pst' -> do
          let pst =
                (pst' :: PosState s)
                  { pstateInput = "\n" :: s
                  }
              o = pstateOffset pst + 1
              r = pstateSourcePos (reachOffsetNoLine o pst)
              SourcePos n l _ = pstateSourcePos pst
          r `shouldBe` SourcePos n (l <> pos1) pos1
      it "returns correct SourcePos (tab)" $
        property $ \pst' -> do
          let pst =
                (pst' :: PosState s)
                  { pstateInput = "\t" :: s
                  }
              o = pstateOffset pst + 1
              r = pstateSourcePos (reachOffsetNoLine o pst)
              SourcePos n l c = pstateSourcePos pst
              w = pstateTabWidth pst
          r `shouldBe` SourcePos n l (toNextTab w c)
      it "returns correct SourcePos (other)" $
        property $ \pst' -> do
          let pst =
                (pst' :: PosState s)
                  { pstateInput = "a" :: s
                  }
              o = pstateOffset pst + 1
              r = pstateSourcePos (reachOffsetNoLine o pst)
              SourcePos n l c = pstateSourcePos pst
          r `shouldBe` SourcePos n l (c <> pos1)
      it "works incrementally" $
        property $ \os' (NonNegative d) s -> do
          let os = getNonNegative <$> os'
              s' :: PosState String
              s' = foldl' f s os
              o' = case os of
                [] -> d
                xs -> maximum xs + d
              f pst o =
                let pst' = reachOffsetNoLine o pst
                 in pst'
          reachOffsetNoLine o' s `shouldBe` reachOffsetNoLine o' s'
  
  -- | Get the next tab position given the tab width and the current column.
  toNextTab ::
    -- | Tab width
    Pos ->
    -- | Current column
    Pos ->
    -- | Column of next tab position
    Pos
  toNextTab w' c' = mkPos $ c + w - ((c - 1) `rem` w)
    where
      w = unPos w'
      c = unPos c'
  
  quotedCharGen :: Gen Char
  quotedCharGen = arbitrary `suchThat` isQuotedChar
  
  quotedWordGen :: Gen Word8
  quotedWordGen = arbitrary `suchThat` (isQuotedChar . toChar)
  
  -- | Return 'True' if the 'Char' should be simply quoted by the 'showTokens'
  -- method, i.e. it's not a character with a special representation.
  isQuotedChar :: Char -> Bool
  isQuotedChar x = not (isControl x) && not (isSpace x)
  