-- |
-- Module      :  Test.Hspec.Megaparsec
-- Copyright   :  © 2016–2018 Mark Karpov
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- Utility functions for testing Megaparsec parsers with Hspec.
--
-- This version of the library should be used with Megaparsec 7.

{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}

module Test.Hspec.Megaparsec
  ( -- * Basic expectations
    shouldParse
  , parseSatisfies
  , shouldSucceedOn
  , shouldFailOn
    -- * Testing of error messages
  , shouldFailWith
  , shouldFailWithM
    -- * Incremental parsing
  , failsLeaving
  , succeedsLeaving
  , initialState
  , initialPosState
    -- * Re-exports
  , module Text.Megaparsec.Error.Builder )
where

import Control.Monad (unless)
import Test.Hspec.Expectations
import Text.Megaparsec
import Text.Megaparsec.Error.Builder
import qualified Data.List.NonEmpty as NE

----------------------------------------------------------------------------
-- Basic expectations

-- | Create an expectation by saying what the result should be.
--
-- > parse letterChar "" "x" `shouldParse` 'x'

shouldParse
  :: ( HasCallStack
     , ShowErrorComponent e
     , Stream s
     , Show a
     , Eq a
     )
  => Either (ParseErrorBundle s e) a
     -- ^ Result of parsing as returned by function like 'parse'
  -> a                 -- ^ Desired result
  -> Expectation
r `shouldParse` v = case r of
  Left e -> expectationFailure $ "expected: " ++ show v ++
    "\nbut parsing failed with error:\n" ++ showBundle e
  Right x -> unless (x == v) . expectationFailure $
    "expected: " ++ show v ++ "\nbut got: " ++ show x

-- | Create an expectation by saying that the parser should successfully
-- parse a value and that the value should satisfy some predicate.
--
-- > parse (many punctuationChar) "" "?!!" `parseSatisfies` ((== 3) . length)

parseSatisfies
  :: ( HasCallStack
     , ShowErrorComponent e
     , Stream s
     , Show a
     , Eq a
     )
  => Either (ParseErrorBundle s e) a
     -- ^ Result of parsing as returned by function like 'parse'
  -> (a -> Bool)       -- ^ Predicate
  -> Expectation
r `parseSatisfies` p = case r of
  Left e -> expectationFailure $
    "expected a parsed value to check against the predicate" ++
    "\nbut parsing failed with error:\n" ++ showBundle e
  Right x -> unless (p x) . expectationFailure $
    "the value did not satisfy the predicate: " ++ show x

-- | Check that a parser fails on a given input.
--
-- > parse (char 'x') "" `shouldFailOn` "a"

shouldFailOn
  :: (HasCallStack, Show a)
  => (s -> Either (ParseErrorBundle s e) a)
     -- ^ Parser that takes stream and produces result or error message
  -> s                 -- ^ Input that the parser should fail on
  -> Expectation
p `shouldFailOn` s = shouldFail (p s)

-- | Check that a parser succeeds on a given input.
--
-- > parse (char 'x') "" `shouldSucceedOn` "x"

shouldSucceedOn
  :: ( HasCallStack
     , ShowErrorComponent e
     , Stream s
     , Show a
     )
  => (s -> Either (ParseErrorBundle s e) a)
     -- ^ Parser that takes stream and produces result or error message
  -> s                 -- ^ Input that the parser should succeed on
  -> Expectation
p `shouldSucceedOn` s = shouldSucceed (p s)

----------------------------------------------------------------------------
-- Testing of error messages

-- | Create an expectation that parser should fail producing certain
-- 'ParseError'. Use the 'err' function from this module to construct a
-- 'ParseError' to compare with.
--
-- > parse (char 'x') "" "b" `shouldFailWith` err posI (utok 'b' <> etok 'x')

shouldFailWith
  :: ( HasCallStack
     , ShowErrorComponent e
     , Stream s
     , Show a
     , Eq e
     )
  => Either (ParseErrorBundle s e) a -- ^ The result of parsing
  -> ParseError s e    -- ^ Expected parse errors
  -> Expectation
r `shouldFailWith` perr1 = r `shouldFailWithM` [perr1]

-- | Similar to 'shouldFailWith', but allows to check parsers that can
-- report more than one parse error at a time.
--
-- @since 2.0.0

shouldFailWithM
  :: ( HasCallStack
     , ShowErrorComponent e
     , Stream s
     , Show a
     , Eq e
     )
  => Either (ParseErrorBundle s e) a -- ^ The result of parsing
  -> [ParseError s e]
     -- ^ Expected parse errors, the argument is a normal linked list (as
     -- opposed to the more correct 'NonEmpty' list) as a syntactical
     -- convenience for the user, passing empty list here will result in an
     -- error
  -> Expectation
r `shouldFailWithM` perrs1' = case r of
  Left e0 ->
    let e1 = e0 { bundleErrors = perrs1 }
        perrs0 = bundleErrors e0
        perrs1 = NE.fromList perrs1'
    in unless (perrs0 == perrs1) . expectationFailure $
       "the parser is expected to fail with:\n" ++ showBundle e1 ++
       "but it failed with:\n" ++ showBundle e0
  Right v -> expectationFailure $
    "the parser is expected to fail, but it parsed: " ++ show v

----------------------------------------------------------------------------
-- Incremental parsing

-- | Check that a parser fails and leaves a certain part of input
-- unconsumed. Use it with functions like 'runParser'' and 'runParserT''
-- that support incremental parsing.
--
-- > runParser' (many (char 'x') <* eof) (initialState "xxa")
-- >   `failsLeaving` "a"
--
-- See also: 'initialState'.

failsLeaving
  :: ( HasCallStack
     , Show a
     , Eq s
     , Show s
     )
  => (State s, Either (ParseErrorBundle s e) a)
     -- ^ Parser that takes stream and produces result along with actual
     -- state information
  -> s                 -- ^ Part of input that should be left unconsumed
  -> Expectation
(st,r) `failsLeaving` s = do
  shouldFail r
  checkUnconsumed s (stateInput st)

-- | Check that a parser succeeds and leaves certain part of input
-- unconsumed. Use it with functions like 'runParser'' and 'runParserT''
-- that support incremental parsing.
--
-- > runParser' (many (char 'x')) (initialState "xxa")
-- >   `succeedsLeaving` "a"
--
-- See also: 'initialState'.

succeedsLeaving
  :: ( HasCallStack
     , Show a
     , Eq s
     , Show s
     , ShowErrorComponent e
     , Stream s
     )
  => (State s, Either (ParseErrorBundle s e) a)
     -- ^ Parser that takes stream and produces result along with actual
     -- state information
  -> s                 -- ^ Part of input that should be left unconsumed
  -> Expectation
(st,r) `succeedsLeaving` s = do
  shouldSucceed r
  checkUnconsumed s (stateInput st)

-- | Given input for parsing, construct initial state for parser.

initialState :: s -> State s
initialState s = State
  { stateInput  = s
  , stateOffset = 0
  , statePosState = initialPosState s
  }

-- | Given input for parsing, construct initial positional state.
--
-- @since 2.0.0

initialPosState :: s -> PosState s
initialPosState s = PosState
  { pstateInput = s
  , pstateOffset = 0
  , pstateSourcePos = initialPos ""
  , pstateTabWidth = defaultTabWidth
  , pstateLinePrefix = ""
  }

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

-- | Expect that the argument is a result of a failed parser.

shouldFail
  :: (HasCallStack, Show a)
  => Either (ParseErrorBundle s e) a
  -> Expectation
shouldFail r = case r of
  Left _ -> return ()
  Right v -> expectationFailure $
    "the parser is expected to fail, but it parsed: " ++ show v

-- | Expectation that argument is result of a succeeded parser.

shouldSucceed
  :: ( HasCallStack
     , ShowErrorComponent e
     , Stream s
     , Show a
     )
  => Either (ParseErrorBundle s e) a
  -> Expectation
shouldSucceed r = case r of
  Left e -> expectationFailure $
    "the parser is expected to succeed, but it failed with:\n" ++
    showBundle e
  Right _ -> return ()

-- | Compare two streams for equality and in the case of mismatch report it.

checkUnconsumed
  :: ( HasCallStack
     , Eq s
     , Show s
     )
  => s                 -- ^ Expected unconsumed input
  -> s                 -- ^ Actual unconsumed input
  -> Expectation
checkUnconsumed e a = unless (e == a) . expectationFailure $
  "the parser is expected to leave unconsumed input: " ++ show e ++
  "\nbut it left this: " ++ show a

-- | Render a parse error bundle in a way that is suitable for inserting it
-- in a test suite report.

showBundle
  :: ( ShowErrorComponent e
     , Stream s
     )
  => ParseErrorBundle s e
  -> String
showBundle = unlines . fmap indent . lines . errorBundlePretty
  where
    indent x = if null x
      then x
      else "  " ++ x