mirror of
https://github.com/mrkkrp/megaparsec.git
synced 2024-12-18 13:51:58 +03:00
120 lines
4.5 KiB
Haskell
120 lines
4.5 KiB
Haskell
--
|
||
-- QuickCheck tests for Megaparsec's parse errors.
|
||
--
|
||
-- Copyright © 2015–2016 Megaparsec contributors
|
||
--
|
||
-- Redistribution and use in source and binary forms, with or without
|
||
-- modification, are permitted provided that the following conditions are
|
||
-- met:
|
||
--
|
||
-- * Redistributions of source code must retain the above copyright notice,
|
||
-- this list of conditions and the following disclaimer.
|
||
--
|
||
-- * Redistributions in binary form must reproduce the above copyright
|
||
-- notice, this list of conditions and the following disclaimer in the
|
||
-- documentation and/or other materials provided with the distribution.
|
||
--
|
||
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
|
||
-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
|
||
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
|
||
-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||
-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||
-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
|
||
-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
|
||
-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||
-- POSSIBILITY OF SUCH DAMAGE.
|
||
|
||
{-# LANGUAGE CPP #-}
|
||
{-# OPTIONS -fno-warn-orphans #-}
|
||
|
||
module Error (tests) where
|
||
|
||
import Data.Function (on)
|
||
import Data.List (isInfixOf)
|
||
import Data.Monoid ((<>))
|
||
import Data.Set (Set)
|
||
import qualified Data.Set as E
|
||
|
||
import Test.Framework
|
||
import Test.Framework.Providers.QuickCheck2 (testProperty)
|
||
import Test.QuickCheck
|
||
|
||
import Text.Megaparsec.Error
|
||
import Text.Megaparsec.Pos
|
||
|
||
import Util ()
|
||
|
||
#if !MIN_VERSION_base(4,8,0)
|
||
import Data.Monoid (mempty)
|
||
#endif
|
||
|
||
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 "consistency of Show/Read" prop_showReadConsistency
|
||
, testProperty "position of merged error" prop_mergeErrorPos
|
||
, testProperty "unexpected items in merged error" prop_mergeErrorUnexpected
|
||
, testProperty "expected items in merged error" prop_mergeErrorExpected
|
||
, testProperty "custom items in merged error" prop_mergeErrorCustom
|
||
, testProperty "source position in rendered error" prop_ppSourcePos
|
||
, testProperty "unexpected items in rendered error" prop_ppUnexpected
|
||
, testProperty "expected items in rendered error" prop_ppExpected
|
||
, testProperty "custom data in rendered error" prop_ppCustom ]
|
||
|
||
type PE = ParseError Char Dec
|
||
|
||
prop_monoid_left_id :: PE -> Property
|
||
prop_monoid_left_id x = mempty <> x === x .&&.
|
||
mempty { errorPos = errorPos x } <> x === x
|
||
|
||
prop_monoid_right_id :: PE -> Property
|
||
prop_monoid_right_id x = x <> mempty === x .&&.
|
||
mempty { errorPos = errorPos x } <> x === x
|
||
|
||
prop_monoid_assoc :: PE -> PE -> PE -> Property
|
||
prop_monoid_assoc x y z = (x <> y) <> z === x <> (y <> z)
|
||
|
||
prop_showReadConsistency :: PE -> Property
|
||
prop_showReadConsistency x = read (show x) === x
|
||
|
||
prop_mergeErrorPos :: PE -> PE -> Property
|
||
prop_mergeErrorPos e1 e2 =
|
||
errorPos (e1 <> e2) === max (errorPos e1) (errorPos e2)
|
||
|
||
prop_mergeErrorUnexpected :: PE -> PE -> Property
|
||
prop_mergeErrorUnexpected = checkMergedItems errorUnexpected
|
||
|
||
prop_mergeErrorExpected :: PE -> PE -> Property
|
||
prop_mergeErrorExpected = checkMergedItems errorExpected
|
||
|
||
prop_mergeErrorCustom :: PE -> PE -> Property
|
||
prop_mergeErrorCustom = checkMergedItems errorData
|
||
|
||
checkMergedItems :: (Ord a, Show a) => (PE -> Set a) -> PE -> PE -> Property
|
||
checkMergedItems f e1 e2 = f (e1 <> e2) === r
|
||
where r = case (compare `on` errorPos) e1 e2 of
|
||
LT -> f e2
|
||
EQ -> (E.union `on` f) e1 e2
|
||
GT -> f e1
|
||
|
||
prop_ppSourcePos :: PE -> Property
|
||
prop_ppSourcePos = checkPresence errorPos sourcePosPretty
|
||
|
||
prop_ppUnexpected :: PE -> Property
|
||
prop_ppUnexpected = checkPresence errorUnexpected showErrorComponent
|
||
|
||
prop_ppExpected :: PE -> Property
|
||
prop_ppExpected = checkPresence errorExpected showErrorComponent
|
||
|
||
prop_ppCustom :: PE -> Property
|
||
prop_ppCustom = checkPresence errorData showErrorComponent
|
||
|
||
checkPresence :: (Foldable t) => (PE -> t a) -> (a -> String) -> PE -> Property
|
||
checkPresence g r e = property (all f (g e))
|
||
where rendered = parseErrorPretty e
|
||
f x = r x `isInfixOf` rendered
|