From aa119685144a9b4fdd4198810a9f499618334bab Mon Sep 17 00:00:00 2001 From: mrkkrp Date: Wed, 28 Oct 2015 17:51:35 +0600 Subject: [PATCH] tests: various improvements and corrections Some cosmetic whims as well as new tests. --- tests/Char.hs | 4 +- tests/Error.hs | 28 ++++++------- tests/Lexer.hs | 51 +++++++++++++---------- tests/Perm.hs | 2 +- tests/Pos.hs | 22 +++++----- tests/Prim.hs | 109 +++++++++++++++++++++++++------------------------ 6 files changed, 112 insertions(+), 104 deletions(-) diff --git a/tests/Char.hs b/tests/Char.hs index 92baa32..3806426 100644 --- a/tests/Char.hs +++ b/tests/Char.hs @@ -245,9 +245,7 @@ prop_string'_0 a = checkString (string' a) a casei (showToken a) -- | Randomly change the case in the given string. fuzzyCase :: String -> Gen String -fuzzyCase s = do - b <- vector (length s) - return $ zipWith f s b +fuzzyCase s = zipWith f s <$> vector (length s) where f k True = if isLower k then toUpper k else toLower k f k False = k diff --git a/tests/Error.hs b/tests/Error.hs index 139a554..50d9c8f 100644 --- a/tests/Error.hs +++ b/tests/Error.hs @@ -49,20 +49,20 @@ import Data.Monoid (mempty) tests :: Test tests = testGroup "Parse errors" - [ testProperty "monoid left identity" prop_monoid_left_id - , testProperty "monoid right identity" prop_monoid_right_id - , testProperty "monoid associativity" prop_monoid_assoc - , testProperty "extraction of message string" prop_messageString - , testProperty "creation of new error messages" prop_newErrorMessage + [ testProperty "monoid left identity" prop_monoid_left_id + , testProperty "monoid right identity" prop_monoid_right_id + , testProperty "monoid associativity" prop_monoid_assoc + , testProperty "extraction of message string" prop_messageString + , testProperty "creation of new error messages" prop_newErrorMessage , testProperty "messages are always well-formed" prop_wellFormedMessages - , testProperty "copying of error positions" prop_parseErrorCopy - , testProperty "setting of error position" prop_setErrorPos - , testProperty "addition of error message" prop_addErrorMessage - , testProperty "setting of error message" prop_setErrorMessage - , testProperty "position of merged error" prop_mergeErrorPos - , testProperty "messages of merged error" prop_mergeErrorMsgs - , testProperty "position of error is visible" prop_visiblePos - , testProperty "message components are visible" prop_visibleMsgs ] + , testProperty "copying of error positions" prop_parseErrorCopy + , testProperty "setting of error position" prop_setErrorPos + , testProperty "addition of error message" prop_addErrorMessage + , testProperty "setting of error message" prop_setErrorMessage + , testProperty "position of merged error" prop_mergeErrorPos + , testProperty "messages of merged error" prop_mergeErrorMsgs + , testProperty "position of error is visible" prop_visiblePos + , testProperty "message components are visible" prop_visibleMsgs ] instance Arbitrary Message where arbitrary = ($) <$> elements constructors <*> arbitrary @@ -143,7 +143,7 @@ prop_visibleMsgs err = if null msgs where shown = show err msgs = errorMessages err f (Unexpected s) = ["unexpected", s] - f (Expected s) = ["expecting", s] + f (Expected s) = ["expecting", s] f (Message s) = [s] -- | @wellFormed xs@ checks that list @xs@ is sorted and contains no diff --git a/tests/Lexer.hs b/tests/Lexer.hs index c2ff8bd..6bccb2f 100644 --- a/tests/Lexer.hs +++ b/tests/Lexer.hs @@ -61,19 +61,21 @@ import Control.Applicative ((<$>), (<*), (<*>)) tests :: Test tests = testGroup "Lexer" - [ testProperty "space combinator" prop_space - , testProperty "symbol combinator" prop_symbol - , testProperty "symbol' combinator" prop_symbol' - , testProperty "indentGuard combinator" prop_indentGuard - , testProperty "charLiteral" prop_charLiteral - , testProperty "integer" prop_integer - , testProperty "decimal" prop_decimal - , testProperty "hexadecimal" prop_hexadecimal - , testProperty "octal" prop_octal - , testProperty "float 0" prop_float_0 - , testProperty "float 1" prop_float_1 - , testProperty "number" prop_number - , testProperty "signed" prop_signed ] + [ testProperty "space combinator" prop_space + , testProperty "symbol combinator" prop_symbol + , testProperty "symbol' combinator" prop_symbol' + , testProperty "indentGuard combinator" prop_indentGuard + , testProperty "charLiteral" prop_charLiteral + , testProperty "integer" prop_integer + , testProperty "decimal" prop_decimal + , testProperty "hexadecimal" prop_hexadecimal + , testProperty "octal" prop_octal + , testProperty "float 0" prop_float_0 + , testProperty "float 1" prop_float_1 + , testProperty "number 0" prop_number_0 + , testProperty "number 1" prop_number_1 + , testProperty "number 2 (signed)" prop_number_2 + , testProperty "signed" prop_signed ] newtype WhiteSpace = WhiteSpace { getWhiteSpace :: String } @@ -203,17 +205,22 @@ prop_float_1 n' = checkParser float r s , exCh 'e', exSpec "digit" ] s = maybe "" (show . getNonNegative) n' -prop_number :: Either (NonNegative Integer) (NonNegative Double) - -> Integer -> Property -prop_number n' i = checkParser number r s - where r | null s = posErr 0 s [uneEof, exSpec "number"] - | otherwise = - Right $ case n' of +prop_number_0 :: Either (NonNegative Integer) (NonNegative Double) -> Property +prop_number_0 n' = checkParser number r s + where r = Right $ case n' of Left x -> Left $ getNonNegative x Right x -> Right $ getNonNegative x - s = if i < 5 - then "" - else either (show . getNonNegative) (show . getNonNegative) n' + s = either (show . getNonNegative) (show . getNonNegative) n' + +prop_number_1 :: Property +prop_number_1 = checkParser number r s + where r = posErr 0 s [uneEof, exSpec "number"] + s = "" + +prop_number_2 :: Either Integer Double -> Property +prop_number_2 n = checkParser p (Right n) s + where p = signed (hidden C.space) number + s = either show show n prop_signed :: Integer -> Int -> Bool -> Property prop_signed n i plus = checkParser p r s diff --git a/tests/Perm.hs b/tests/Perm.hs index 432e5ef..1125215 100644 --- a/tests/Perm.hs +++ b/tests/Perm.hs @@ -44,7 +44,7 @@ import Util tests :: Test tests = testGroup "Permutation phrases parsers" [ testProperty "permutation parser pure" prop_pure - , testProperty "permutation test 0" prop_perm_0 ] + , testProperty "permutation test 0" prop_perm_0 ] data CharRows = CharRows { getChars :: (Char, Char, Char) diff --git a/tests/Pos.hs b/tests/Pos.hs index 7f706ec..cc1677b 100644 --- a/tests/Pos.hs +++ b/tests/Pos.hs @@ -46,18 +46,18 @@ import Control.Applicative ((<$>), (<*>), pure) tests :: Test tests = testGroup "Textual source positions" - [ testProperty "components" prop_components - , testProperty "positive coordinates" prop_positive + [ testProperty "components" prop_components + , testProperty "positive coordinates" prop_positive , testProperty "show file name in source positions" prop_showFileName - , testProperty "show line in source positions" prop_showLine - , testProperty "show column in source positions" prop_showColumn - , testProperty "initial position" prop_initialPos - , testProperty "increment source line" prop_incSourceLine - , testProperty "increment source column" prop_incSourceColumn - , testProperty "set source name" prop_setSourceName - , testProperty "set source line" prop_setSourceLine - , testProperty "set source column" prop_setSourceColumn - , testProperty "position updating" prop_updating ] + , testProperty "show line in source positions" prop_showLine + , testProperty "show column in source positions" prop_showColumn + , testProperty "initial position" prop_initialPos + , testProperty "increment source line" prop_incSourceLine + , testProperty "increment source column" prop_incSourceColumn + , testProperty "set source name" prop_setSourceName + , testProperty "set source line" prop_setSourceLine + , testProperty "set source column" prop_setSourceColumn + , testProperty "position updating" prop_updating ] instance Arbitrary SourcePos where arbitrary = newPos <$> fileName <*> choose (-10, 1000) <*> choose (-10, 100) diff --git a/tests/Prim.hs b/tests/Prim.hs index 75bbc61..da716f0 100644 --- a/tests/Prim.hs +++ b/tests/Prim.hs @@ -63,59 +63,59 @@ import Util tests :: Test tests = testGroup "Primitive parser combinators" - [ testProperty "ParsecT functor" prop_functor - , testProperty "ParsecT applicative (<*>)" prop_applicative_0 - , testProperty "ParsecT applicative (*>)" prop_applicative_1 - , testProperty "ParsecT applicative (<*)" prop_applicative_2 + [ testProperty "ParsecT functor" prop_functor + , testProperty "ParsecT applicative (<*>)" prop_applicative_0 + , testProperty "ParsecT applicative (*>)" prop_applicative_1 + , testProperty "ParsecT applicative (<*)" prop_applicative_2 , testProperty "ParsecT alternative empty and (<|>)" prop_alternative_0 - , testProperty "ParsecT alternative (<|>)" prop_alternative_1 - , testProperty "ParsecT alternative (<|>) pos" prop_alternative_2 - , testProperty "ParsecT alternative (<|>) hints" prop_alternative_3 - , testProperty "ParsecT alternative many" prop_alternative_4 - , testProperty "ParsecT alternative some" prop_alternative_5 - , testProperty "ParsecT alternative optional" prop_alternative_6 - , testProperty "ParsecT monad return" prop_monad_0 - , testProperty "ParsecT monad (>>)" prop_monad_1 - , testProperty "ParsecT monad (>>=)" prop_monad_2 - , testProperty "ParsecT monad fail" prop_monad_3 - , testProperty "ParsecT monad laws: left identity" prop_monad_left_id - , testProperty "ParsecT monad laws: right identity" prop_monad_right_id - , testProperty "ParsecT monad laws: associativity" prop_monad_assoc - , testProperty "ParsecT monad reader ask" prop_monad_reader_ask + , testProperty "ParsecT alternative (<|>)" prop_alternative_1 + , testProperty "ParsecT alternative (<|>) pos" prop_alternative_2 + , testProperty "ParsecT alternative (<|>) hints" prop_alternative_3 + , testProperty "ParsecT alternative many" prop_alternative_4 + , testProperty "ParsecT alternative some" prop_alternative_5 + , testProperty "ParsecT alternative optional" prop_alternative_6 + , testProperty "ParsecT monad return" prop_monad_0 + , testProperty "ParsecT monad (>>)" prop_monad_1 + , testProperty "ParsecT monad (>>=)" prop_monad_2 + , testProperty "ParsecT monad fail" prop_monad_3 + , testProperty "ParsecT monad laws: left identity" prop_monad_left_id + , testProperty "ParsecT monad laws: right identity" prop_monad_right_id + , testProperty "ParsecT monad laws: associativity" prop_monad_assoc + , testProperty "ParsecT monad reader ask" prop_monad_reader_ask , testProperty "ParsecT monad reader local" prop_monad_reader_local - , testProperty "ParsecT monad state get" prop_monad_state_get - , testProperty "ParsecT monad state put" prop_monad_state_put - , testProperty "ParsecT monad cont" prop_monad_cont + , testProperty "ParsecT monad state get" prop_monad_state_get + , testProperty "ParsecT monad state put" prop_monad_state_put + , testProperty "ParsecT monad cont" prop_monad_cont , testProperty "ParsecT monad error: throw" prop_monad_error_throw , testProperty "ParsecT monad error: catch" prop_monad_error_catch - , testProperty "combinator unexpected" prop_unexpected - , testProperty "combinator failure" prop_failure - , testProperty "combinator label" prop_label - , testProperty "combinator hidden hints" prop_hidden_0 - , testProperty "combinator hidden error" prop_hidden_1 - , testProperty "combinator try" prop_try - , testProperty "combinator lookAhead" prop_lookAhead_0 - , testProperty "combinator lookAhead hints" prop_lookAhead_1 - , testProperty "combinator lookAhead messages" prop_lookAhead_2 - , testProperty "combinator notFollowedBy" prop_notFollowedBy_0 + , testProperty "combinator unexpected" prop_unexpected + , testProperty "combinator failure" prop_failure + , testProperty "combinator label" prop_label + , testProperty "combinator hidden hints" prop_hidden_0 + , testProperty "combinator hidden error" prop_hidden_1 + , testProperty "combinator try" prop_try + , testProperty "combinator lookAhead" prop_lookAhead_0 + , testProperty "combinator lookAhead hints" prop_lookAhead_1 + , testProperty "combinator lookAhead messages" prop_lookAhead_2 + , testProperty "combinator notFollowedBy" prop_notFollowedBy_0 , testProperty "combinator notFollowedBy twice" prop_notFollowedBy_1 - , testProperty "combinator notFollowedBy eof" prop_notFollowedBy_2 - , testProperty "combinator token" prop_token - , testProperty "combinator tokens" prop_tokens - , testProperty "parser state position" prop_state_pos - , testProperty "parser state input" prop_state_input - , testProperty "parser state tab width" prop_state_tab - , testProperty "parser state general" prop_state - , testProperty "custom state parsing" prop_runParser' - , testProperty "custom state parsing (transformer)" prop_runParserT' - , testProperty "IdentityT try" prop_IdentityT_try - , testProperty "IdentityT notFollowedBy" prop_IdentityT_notFollowedBy - , testProperty "ReaderT try" prop_ReaderT_try - , testProperty "ReaderT notFollowedBy" prop_ReaderT_notFollowedBy + , testProperty "combinator notFollowedBy eof" prop_notFollowedBy_2 + , testProperty "combinator token" prop_token + , testProperty "combinator tokens" prop_tokens + , testProperty "parser state position" prop_state_pos + , testProperty "parser state input" prop_state_input + , testProperty "parser state tab width" prop_state_tab + , testProperty "parser state general" prop_state + , testProperty "custom state parsing" prop_runParser' + , testProperty "custom state parsing (transformer)" prop_runParserT' + , testProperty "IdentityT try" prop_IdentityT_try + , testProperty "IdentityT notFollowedBy" prop_IdentityT_notFollowedBy + , testProperty "ReaderT try" prop_ReaderT_try + , testProperty "ReaderT notFollowedBy" prop_ReaderT_notFollowedBy , testProperty "StateT alternative (<|>)" prop_StateT_alternative - , testProperty "StateT lookAhead" prop_StateT_lookAhead - , testProperty "StateT notFollowedBy" prop_StateT_notFollowedBy - , testProperty "WriterT" prop_WriterT ] + , testProperty "StateT lookAhead" prop_StateT_lookAhead + , testProperty "StateT notFollowedBy" prop_StateT_notFollowedBy + , testProperty "WriterT" prop_WriterT ] instance Arbitrary (State String) where arbitrary = State <$> arbitrary <*> arbitrary <*> choose (1, 20) @@ -527,16 +527,18 @@ prop_ReaderT_notFollowedBy a' b' c' = checkParser (runReaderT p 'a') r s -- StateT instance of MonadParsec prop_StateT_alternative :: Integer -> Property -prop_StateT_alternative n = checkParser (L.evalStateT p 0) (Right n) "" .&&. - checkParser (S.evalStateT p' 0) (Right n) "" +prop_StateT_alternative n = + checkParser (L.evalStateT p 0) (Right n) "" .&&. + checkParser (S.evalStateT p' 0) (Right n) "" where p = L.put n >> ((L.modify (* 2) >> void (string "xxx")) <|> return ()) >> L.get p' = S.put n >> ((S.modify (* 2) >> void (string "xxx")) <|> return ()) >> S.get prop_StateT_lookAhead :: Integer -> Property -prop_StateT_lookAhead n = checkParser (L.evalStateT p 0) (Right n) "" .&&. - checkParser (S.evalStateT p' 0) (Right n) "" +prop_StateT_lookAhead n = + checkParser (L.evalStateT p 0) (Right n) "" .&&. + checkParser (S.evalStateT p' 0) (Right n) "" where p = L.put n >> lookAhead (L.modify (* 2) >> eof) >> L.get p' = S.put n >> lookAhead (S.modify (* 2) >> eof) >> S.get @@ -556,8 +558,9 @@ prop_StateT_notFollowedBy n = checkParser (L.runStateT p 0) r "abx" .&&. -- WriterT instance of MonadParsec prop_WriterT :: String -> String -> Property -prop_WriterT pre post = checkParser (L.runWriterT p) r "abx" .&&. - checkParser (S.runWriterT p') r "abx" +prop_WriterT pre post = + checkParser (L.runWriterT p) r "abx" .&&. + checkParser (S.runWriterT p') r "abx" where logged_letter = letterChar >>= \x -> L.tell [x] >> return x logged_letter' = letterChar >>= \x -> L.tell [x] >> return x logged_eof = eof >> L.tell "EOF"