{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Test.Hspec.Megaparsec.AdHoc
(
Parser,
prs,
prs',
prs_,
grs,
grs',
nes,
abcRow,
rightOrder,
scaleDown,
getTabWidth,
setTabWidth,
strSourcePos,
toChar,
fromChar,
sproxy,
bproxy,
blproxy,
tproxy,
tlproxy,
)
where
import qualified Control.Monad.RWS.Lazy as L
import qualified Control.Monad.RWS.Strict as S
import Control.Monad.Reader
import qualified Control.Monad.State.Lazy as L
import qualified Control.Monad.State.Strict as S
import Control.Monad.Trans.Identity
import qualified Control.Monad.Writer.Lazy as L
import qualified Control.Monad.Writer.Strict as S
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Char (chr, ord)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Proxy
import qualified Data.Set as E
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Void
import Data.Word (Word8)
import Test.Hspec
import Test.Hspec.Megaparsec
import Test.QuickCheck
import Text.Megaparsec
type Parser = Parsec Void String
prs ::
Parser a ->
String ->
Either (ParseErrorBundle String Void) a
prs p = parse p ""
prs' ::
Parser a ->
String ->
(State String Void, Either (ParseErrorBundle String Void) a)
prs' p s = runParser' p (initialState s)
prs_ ::
Parser a ->
String ->
Either (ParseErrorBundle String Void) a
prs_ p = parse (p <* eof) ""
grs ::
(forall m. MonadParsec Void String m => m a) ->
String ->
(Either (ParseErrorBundle String Void) a -> Expectation) ->
Expectation
grs p s r = do
r (prs p s)
r (prs (runIdentityT p) s)
r (prs (runReaderT p ()) s)
r (prs (L.evalStateT p ()) s)
r (prs (S.evalStateT p ()) s)
r (prs (evalWriterTL p) s)
r (prs (evalWriterTS p) s)
r (prs (evalRWSTL p) s)
r (prs (evalRWSTS p) s)
grs' ::
(forall m. MonadParsec Void String m => m a) ->
String ->
((State String Void, Either (ParseErrorBundle String Void) a) -> Expectation) ->
Expectation
grs' p s r = do
r (prs' p s)
r (prs' (runIdentityT p) s)
r (prs' (runReaderT p ()) s)
r (prs' (L.evalStateT p ()) s)
r (prs' (S.evalStateT p ()) s)
r (prs' (evalWriterTL p) s)
r (prs' (evalWriterTS p) s)
r (prs' (evalRWSTL p) s)
r (prs' (evalRWSTS p) s)
evalWriterTL :: Monad m => L.WriterT [Int] m a -> m a
evalWriterTL = fmap fst . L.runWriterT
evalWriterTS :: Monad m => S.WriterT [Int] m a -> m a
evalWriterTS = fmap fst . S.runWriterT
evalRWSTL :: Monad m => L.RWST () [Int] () m a -> m a
evalRWSTL m = do
(a, _, _) <- L.runRWST m () ()
return a
evalRWSTS :: Monad m => S.RWST () [Int] () m a -> m a
evalRWSTS m = do
(a, _, _) <- S.runRWST m () ()
return a
nes :: a -> NonEmpty a
nes x = x :| []
abcRow :: Int -> Int -> Int -> String
abcRow a b c = replicate a 'a' ++ replicate b 'b' ++ replicate c 'c'
rightOrder ::
Parser String ->
String ->
String ->
Spec
rightOrder p s s' =
it "produces the list in the right order" $
prs_ p s `shouldParse` s'
getTabWidth :: MonadParsec e s m => m Pos
getTabWidth = pstateTabWidth . statePosState <$> getParserState
setTabWidth :: MonadParsec e s m => Pos -> m ()
setTabWidth w = updateParserState $ \st ->
let pst = statePosState st
in st {statePosState = pst {pstateTabWidth = w}}
scaleDown :: Gen a -> Gen a
scaleDown = scale (`div` 4)
strSourcePos :: Pos -> SourcePos -> String -> SourcePos
strSourcePos tabWidth ipos input =
let (_, pst') = reachOffset maxBound pstate in pstateSourcePos pst'
where
pstate =
PosState
{ pstateInput = input,
pstateOffset = 0,
pstateSourcePos = ipos,
pstateTabWidth = tabWidth,
pstateLinePrefix = ""
}
toChar :: Word8 -> Char
toChar = chr . fromIntegral
fromChar :: Char -> Maybe Word8
fromChar x =
let p = ord x
in if p > 0xff
then Nothing
else Just (fromIntegral p)
sproxy :: Proxy String
sproxy = Proxy
bproxy :: Proxy B.ByteString
bproxy = Proxy
blproxy :: Proxy BL.ByteString
blproxy = Proxy
tproxy :: Proxy T.Text
tproxy = Proxy
tlproxy :: Proxy TL.Text
tlproxy = Proxy
instance Arbitrary Void where
arbitrary = error "Arbitrary Void"
instance Arbitrary Pos where
arbitrary = mkPos <$> (getSmall . getPositive <$> arbitrary)
instance Arbitrary SourcePos where
arbitrary =
SourcePos
<$> scaleDown arbitrary
<*> arbitrary
<*> arbitrary
instance Arbitrary t => Arbitrary (ErrorItem t) where
arbitrary =
oneof
[ Tokens <$> (NE.fromList . getNonEmpty <$> arbitrary),
Label <$> (NE.fromList . getNonEmpty <$> arbitrary),
return EndOfInput
]
instance Arbitrary (ErrorFancy a) where
arbitrary =
oneof
[ ErrorFail <$> scaleDown arbitrary,
ErrorIndentation <$> arbitrary <*> arbitrary <*> arbitrary
]
instance
(Arbitrary (Token s), Ord (Token s), Arbitrary e, Ord e) =>
Arbitrary (ParseError s e)
where
arbitrary =
oneof
[ TrivialError
<$> (getNonNegative <$> arbitrary)
<*> arbitrary
<*> (E.fromList <$> scaleDown arbitrary),
FancyError
<$> (getNonNegative <$> arbitrary)
<*> (E.fromList <$> scaleDown arbitrary)
]
instance Arbitrary s => Arbitrary (State s e) where
arbitrary = do
input <- scaleDown arbitrary
offset <- choose (1, 10000)
pstate :: PosState s <- arbitrary
return
State
{ stateInput = input,
stateOffset = offset,
statePosState =
pstate
{ pstateInput = input,
pstateOffset = offset
},
stateParseErrors = []
}
instance Arbitrary s => Arbitrary (PosState s) where
arbitrary =
PosState
<$> arbitrary
<*> choose (1, 10000)
<*> arbitrary
<*> (mkPos <$> choose (1, 20))
<*> scaleDown arbitrary
instance Arbitrary T.Text where
arbitrary = T.pack <$> arbitrary
instance Arbitrary TL.Text where
arbitrary = TL.pack <$> arbitrary
instance Arbitrary B.ByteString where
arbitrary = B.pack <$> arbitrary
instance Arbitrary BL.ByteString where
arbitrary = BL.pack <$> arbitrary
instance Arbitrary a => Arbitrary (NonEmpty a) where
arbitrary = NE.fromList <$> (arbitrary `suchThat` (not . null))