{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Test.Hspec.Megaparsec
(
shouldParse
, parseSatisfies
, shouldSucceedOn
, shouldFailOn
, shouldFailWith
, shouldFailWithM
, failsLeaving
, succeedsLeaving
, initialState
, initialPosState
, 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
shouldParse
:: ( HasCallStack
, ShowErrorComponent e
, Stream s
, Show a
, Eq a
)
=> Either (ParseErrorBundle s e) a
-> a
-> Expectation
r `shouldParse` v = case r of
Left e -> expectationFailure $ "expected: " ++ show v ++
"\nbut parsing failed with error:\n" ++ showBundle e
Right x -> x `shouldBe` v
parseSatisfies
:: ( HasCallStack
, ShowErrorComponent e
, Stream s
, Show a
, Eq a
)
=> Either (ParseErrorBundle s e) a
-> (a -> Bool)
-> 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
shouldFailOn
:: (HasCallStack, Show a)
=> (s -> Either (ParseErrorBundle s e) a)
-> s
-> Expectation
p `shouldFailOn` s = shouldFail (p s)
shouldSucceedOn
:: ( HasCallStack
, ShowErrorComponent e
, Stream s
, Show a
)
=> (s -> Either (ParseErrorBundle s e) a)
-> s
-> Expectation
p `shouldSucceedOn` s = shouldSucceed (p s)
shouldFailWith
:: ( HasCallStack
, ShowErrorComponent e
, Stream s
, Show a
, Eq e
)
=> Either (ParseErrorBundle s e) a
-> ParseError s e
-> Expectation
r `shouldFailWith` perr1 = r `shouldFailWithM` [perr1]
shouldFailWithM
:: ( HasCallStack
, ShowErrorComponent e
, Stream s
, Show a
, Eq e
)
=> Either (ParseErrorBundle s e) a
-> [ParseError s e]
-> 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
failsLeaving
:: ( HasCallStack
, Show a
, Eq s
, Show s
)
=> (State s, Either (ParseErrorBundle s e) a)
-> s
-> Expectation
(st,r) `failsLeaving` s = do
shouldFail r
checkUnconsumed s (stateInput st)
succeedsLeaving
:: ( HasCallStack
, Show a
, Eq s
, Show s
, ShowErrorComponent e
, Stream s
)
=> (State s, Either (ParseErrorBundle s e) a)
-> s
-> Expectation
(st,r) `succeedsLeaving` s = do
shouldSucceed r
checkUnconsumed s (stateInput st)
initialState :: s -> State s
initialState s = State
{ stateInput = s
, stateOffset = 0
, statePosState = initialPosState s
}
initialPosState :: s -> PosState s
initialPosState s = PosState
{ pstateInput = s
, pstateOffset = 0
, pstateSourcePos = initialPos ""
, pstateTabWidth = defaultTabWidth
, pstateLinePrefix = ""
}
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
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 ()
checkUnconsumed
:: ( HasCallStack
, Eq s
, Show s
)
=> s
-> s
-> Expectation
checkUnconsumed e a = unless (e == a) . expectationFailure $
"the parser is expected to leave unconsumed input: " ++ show e ++
"\nbut it left this: " ++ show a
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