From dc63a8f8936ebec7a73d1796c38ed729112e56f2 Mon Sep 17 00:00:00 2001 From: mrkkrp Date: Wed, 4 May 2016 00:53:09 +0700 Subject: [PATCH] Add tests to cover new API for position advancing Close #102. --- tests/Prim.hs | 139 +++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 133 insertions(+), 6 deletions(-) diff --git a/tests/Prim.hs b/tests/Prim.hs index ed21f01..f4d0e5a 100644 --- a/tests/Prim.hs +++ b/tests/Prim.hs @@ -29,6 +29,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS -fno-warn-orphans #-} @@ -41,12 +42,13 @@ import Control.Monad.Identity import Control.Monad.Reader import Data.Char (isLetter, toUpper, chr) import Data.Foldable (asum) -import Data.List (isPrefixOf) +import Data.List (isPrefixOf, foldl') import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (maybeToList, fromMaybe) import Data.Proxy import Data.Set (Set) import Data.Word (Word8) +import Prelude hiding (span) import qualified Control.Monad.State.Lazy as L import qualified Control.Monad.State.Strict as S import qualified Control.Monad.Writer.Lazy as L @@ -85,6 +87,9 @@ tests = testGroup "Primitive parser combinators" , testProperty "Stream lazy text (pos)" prop_textL_pos , testProperty "Stream strict text" prop_textS , testProperty "Stream strict text (pos)" prop_textS_pos + , testProperty "position in custom stream, eof" prop_cst_eof + , testProperty "position in custom stream, token" prop_cst_token + , testProperty "position in custom stream, tokens" prop_cst_tokens , testProperty "ParsecT functor" prop_functor , testProperty "ParsecT applicative (<*>)" prop_applicative_0 , testProperty "ParsecT applicative (<*>) meok-cerr" prop_applicative_1 @@ -164,7 +169,7 @@ tests = testGroup "Primitive parser combinators" , testProperty "StateT notFollowedBy" prop_StateT_notFollowedBy , testProperty "WriterT" prop_WriterT ] -instance Arbitrary (State String) where +instance Arbitrary a => Arbitrary (State a) where arbitrary = State <$> arbitrary <*> arbitrary @@ -217,6 +222,124 @@ prop_textS_pos w pos ch = updatePos (Proxy :: Proxy String) w pos ch === updatePos (Proxy :: Proxy T.Text) w pos ch +-- Custom stream of tokens and position advancing + +-- | This data type will represent tokens in input stream for the purposes +-- of next several tests. + +data Span = Span + { spanStart :: SourcePos + , spanEnd :: SourcePos + , spanBody :: NonEmpty Char + } deriving (Eq, Ord, Show) + +instance Stream [Span] where + type Token [Span] = Span + uncons [] = Nothing + uncons (t:ts) = Just (t, ts) + updatePos _ _ _ (Span start end _) = (start, end) + +instance Arbitrary Span where + arbitrary = do + start <- arbitrary + end <- arbitrary `suchThat` (> start) + Span start end <$> arbitrary + +type CustomParser = Parsec Dec [Span] + +prop_cst_eof :: State [Span] -> Property +prop_cst_eof st = + (not . null . stateInput) st ==> (runParser' p st === r) + where + p = eof :: CustomParser () + h = head (stateInput st) + apos = let (_:|z) = statePos st in spanStart h :| z + r = (st { statePos = apos }, Left ParseError + { errorPos = apos + , errorUnexpected = E.singleton (Tokens (nes h)) + , errorExpected = E.singleton EndOfInput + , errorCustom = E.empty }) + +prop_cst_token :: State [Span] -> Span -> Property +prop_cst_token st@State {..} span = runParser' p st === r + where + p = pSpan span + h = head stateInput + (apos, npos) = + let z = NE.tail statePos + in (spanStart h :| z, spanEnd h :| z) + r | null stateInput = + ( st + , Left ParseError + { errorPos = statePos + , errorUnexpected = E.singleton EndOfInput + , errorExpected = E.singleton (Tokens $ nes span) + , errorCustom = E.empty } ) + | spanBody h == spanBody span = + ( st { statePos = npos + , stateInput = tail stateInput } + , Right span ) + | otherwise = + ( st { statePos = apos } + , Left ParseError + { errorPos = apos + , errorUnexpected = E.singleton (Tokens $ nes h) + , errorExpected = E.singleton (Tokens $ nes span) + , errorCustom = E.empty } ) + +pSpan :: Span -> CustomParser Span +pSpan span = token testToken (Just span) + where + f = E.singleton . Tokens . nes + testToken x = + if spanBody x == spanBody span + then Right span + else Left (f x, f span , E.empty) + +prop_cst_tokens :: State [Span] -> [Span] -> Property +prop_cst_tokens st' ts = + forAll (incCoincidence st' ts) $ \st@State {..} -> + let + p = tokens compareTokens ts :: CustomParser [Span] + compareTokens x y = spanBody x == spanBody y + updatePos' = updatePos (Proxy :: Proxy [Span]) stateTabWidth + ts' = NE.fromList ts + il = length . takeWhile id $ zipWith compareTokens stateInput ts + tl = length ts + consumed = take il stateInput + (apos, npos) = + let (pos:|z) = statePos + in ( spanStart (head stateInput) :| z + , foldl' (\q t -> snd (updatePos' q t)) pos consumed :| z ) + r | null ts = (st, Right []) + | null stateInput = + ( st + , Left ParseError + { errorPos = statePos + , errorUnexpected = E.singleton EndOfInput + , errorExpected = E.singleton (Tokens ts') + , errorCustom = E.empty } ) + | il == tl = + ( st { statePos = npos + , stateInput = drop (length ts) stateInput } + , Right consumed ) + | otherwise = + ( st { statePos = apos } + , Left ParseError + { errorPos = apos + , errorUnexpected = E.singleton + (Tokens . NE.fromList $ take (il + 1) stateInput) + , errorExpected = E.singleton (Tokens ts') + , errorCustom = E.empty } ) + in runParser' p st === r + +incCoincidence :: State [Span] -> [Span] -> Gen (State [Span]) +incCoincidence st ts = do + n <- getSmall <$> arbitrary + let (pre, post) = splitAt n (stateInput st) + pre' = zipWith (\x t -> x { spanBody = spanBody t }) pre ts + return st { stateInput = pre' ++ post } + -- Functor instance prop_functor :: Integer -> Integer -> Property @@ -412,7 +535,7 @@ prop_failure us ps xs = checkParser' p r s where p :: (MonadParsec Dec s m, Token s ~ Char) => m String p = failure us ps xs r = Left ParseError - { errorPos = initialPos "" :| [] + { errorPos = nes (initialPos "") , errorUnexpected = us , errorExpected = ps , errorCustom = xs } @@ -679,7 +802,7 @@ prop_token mtok s = checkParser' p r s p = token testChar mtok testChar x = if isLetter x then Right x - else Left (E.singleton (Tokens (x:|[])), E.empty, E.empty) + else Left (E.singleton (Tokens $ nes x), E.empty, E.empty) h = head s r | null s = posErr 0 s $ ueof : maybeToList (etok <$> mtok) | isLetter h && length s == 1 = Right (head s) @@ -738,7 +861,7 @@ prop_state s1 s2 = checkParser' p r s where p :: MonadParsec Dec String m => m (State String) p = do st <- getParserState - guard (st == State s (initialPos "" :| []) defaultTabWidth) + guard (st == State s (nes $ initialPos "") defaultTabWidth) setParserState s1 updateParserState (f s2) liftM2 const getParserState (setInput "") @@ -808,7 +931,7 @@ prop_stOnFail_3 s = runParser' p (stateFromInput s) === (i, r) p = notFollowedBy (string s) stateFromInput :: s -> State s -stateFromInput s = State s (initialPos "" :| []) defaultTabWidth +stateFromInput s = State s (nes $ initialPos "") defaultTabWidth -- ReaderT instance of MonadParsec @@ -888,3 +1011,7 @@ prop_WriterT pre post = void logged_letter' return cs r = Right ("ab", pre ++ "AB" ++ post ++ "x") + +nes :: a -> NonEmpty a +nes x = x :| [] +{-# INLINE nes #-}