{-# 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 qualified Data.List.NonEmpty as NE
import Test.Hspec.Expectations
import Text.Megaparsec
import Text.Megaparsec.Error.Builder
shouldParse ::
( HasCallStack,
ShowErrorComponent e,
Stream s,
VisualStream s,
TraversableStream 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,
VisualStream s,
TraversableStream 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,
VisualStream s,
TraversableStream s,
Show a
) =>
(s -> Either (ParseErrorBundle s e) a) ->
s ->
Expectation
p `shouldSucceedOn` s = shouldSucceed (p s)
shouldFailWith ::
( HasCallStack,
ShowErrorComponent e,
Stream s,
VisualStream s,
TraversableStream 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,
VisualStream s,
TraversableStream 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 e, 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,
VisualStream s,
TraversableStream s
) =>
(State s e, Either (ParseErrorBundle s e) a) ->
s ->
Expectation
(st, r) `succeedsLeaving` s = do
shouldSucceed r
checkUnconsumed s (stateInput st)
initialState :: s -> State s e
initialState s =
State
{ stateInput = s,
stateOffset = 0,
statePosState = initialPosState s,
stateParseErrors = []
}
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,
VisualStream s,
TraversableStream 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,
VisualStream s,
TraversableStream s
) =>
ParseErrorBundle s e ->
String
showBundle = unlines . fmap indent . lines . errorBundlePretty
where
indent x =
if null x
then x
else " " ++ x