diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +## Hspec Megaparsec 1.0.0 + +* To be used with Megaparsec 6. + ## Hspec Megaparsec 0.3.1 * Support for Megaparsec 5.2.0. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -13,8 +13,9 @@ of Megaparsec 5.1.0, its test suite is re-written with Hspec and this package with a few ad-hoc helpers. -Consult Haddocks for usage, which should be trivial. Also see test suite of -this package or [Megaparsec test suite](https://github.com/mrkkrp/megaparsec/tree/master/tests). +Consult the Haddocks for usage, which should be trivial. Also see test suite +of this package or +[Megaparsec test suite](https://github.com/mrkkrp/megaparsec/tree/master/tests). ## License diff --git a/Test/Hspec/Megaparsec.hs b/Test/Hspec/Megaparsec.hs --- a/Test/Hspec/Megaparsec.hs +++ b/Test/Hspec/Megaparsec.hs @@ -3,16 +3,13 @@ -- Copyright : © 2016–2017 Mark Karpov -- License : BSD 3 clause -- --- Maintainer : Mark Karpov +-- Maintainer : Mark Karpov -- Stability : experimental -- Portability : portable -- -- Utility functions for testing Megaparsec parsers with Hspec. -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -26,40 +23,19 @@ , shouldFailOn -- * Testing of error messages , shouldFailWith - -- * Error message construction - -- $errmsg - , err - , posI - , posN - , EC - , utok - , utoks - , ulabel - , ueof - , etok - , etoks - , elabel - , eeof - , cstm -- * Incremental parsing , failsLeaving , succeedsLeaving - , initialState ) + , initialState + -- * Re-exports + , module Text.Megaparsec.Error.Builder ) where import Control.Monad (unless) -import Data.Data (Data) import Data.List.NonEmpty (NonEmpty (..)) -import Data.Proxy -import Data.Semigroup -import Data.Set (Set) -import Data.Typeable (Typeable) -import GHC.Generics import Test.Hspec.Expectations import Text.Megaparsec -import Text.Megaparsec.Pos (defaultTabWidth) -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as E +import Text.Megaparsec.Error.Builder ---------------------------------------------------------------------------- -- Basic expectations @@ -96,7 +72,7 @@ Right x -> unless (p x) . expectationFailure $ "the value did not satisfy the predicate: " ++ show x --- | Check that a parser fails on some given input. +-- | Check that a parser fails on a given input. -- -- > parse (char 'x') "" `shouldFailOn` "a" @@ -107,7 +83,7 @@ -> Expectation p `shouldFailOn` s = shouldFail (p s) --- | Check that a parser succeeds on some given input. +-- | Check that a parser succeeds on a given input. -- -- > parse (char 'x') "" `shouldSucceedOn` "x" @@ -139,142 +115,9 @@ "the parser is expected to fail, but it parsed: " ++ show v ---------------------------------------------------------------------------- --- Error message construction - --- $errmsg When you wish to test error message on failure, the need to --- construct a error message for comparison arises. These helpers allow to --- construct virtually any sort of error message easily. - --- | Assemble a 'ParseErorr' from source position and @'EC' t e@ value. To --- create source position, two helpers are available: 'posI' and 'posN'. --- @'EC' t e@ is a monoid and can be built from primitives provided by this --- module, see below. --- --- @since 0.3.0 - -err - :: NonEmpty SourcePos -- ^ 'ParseError' position - -> EC t e -- ^ Error components - -> ParseError t e -- ^ Resulting 'ParseError' -err pos (EC u e c) = ParseError pos u e c - --- | Initial source position with empty file name. --- --- @since 0.3.0 - -posI :: NonEmpty SourcePos -posI = initialPos "" :| [] - --- | @posN n s@ returns source position achieved by applying 'updatePos' --- method corresponding to type of stream @s@ @n@ times. --- --- @since 0.3.0 - -posN :: forall s n. (Stream s, Integral n) - => n - -> s - -> NonEmpty SourcePos -posN n see = f (initialPos "") see n :| [] - where - f p s !i = - if i > 0 - then case uncons s of - Nothing -> p - Just (t,s') -> - let p' = snd $ updatePos (Proxy :: Proxy s) defaultTabWidth p t - in f p' s' (i - 1) - else p - --- | Auxiliary type for construction of 'ParseError's. Note that it's a --- monoid. --- --- @since 0.3.0 - -data EC t e = EC - { ecUnexpected :: Set (ErrorItem t) -- ^ Unexpected items - , ecExpected :: Set (ErrorItem t) -- ^ Expected items - , _ecCustom :: Set e -- ^ Custom items - } deriving (Eq, Data, Typeable, Generic) - -instance (Ord t, Ord e) => Semigroup (EC t e) where - (EC u0 e0 c0) <> (EC u1 e1 c1) = - EC (E.union u0 u1) (E.union e0 e1) (E.union c0 c1) - -instance (Ord t, Ord e) => Monoid (EC t e) where - mempty = EC E.empty E.empty E.empty - mappend = (<>) - --- | Construct “unexpected token” error component. --- --- @since 0.3.0 - -utok :: (Ord t, Ord e) => t -> EC t e -utok t = mempty { ecUnexpected = (E.singleton . Tokens . nes) t } - --- | Construct “unexpected tokens” error component. Empty string produces --- 'EndOfInput'. --- --- @since 0.3.0 - -utoks :: (Ord t, Ord e) => [t] -> EC t e -utoks t = mempty { ecUnexpected = (E.singleton . canonicalizeTokens) t } - --- | Construct “unexpected label” error component. Do not use with empty --- strings (for empty strings it's bottom). --- --- @since 0.3.0 - -ulabel :: (Ord t, Ord e) => String -> EC t e -ulabel l = mempty { ecUnexpected = (E.singleton . Label . NE.fromList) l } - --- | Construct “unexpected end of input” error component. --- --- @since 0.3.0 - -ueof :: (Ord t, Ord e) => EC t e -ueof = mempty { ecUnexpected = E.singleton EndOfInput } - --- | Construct “expected token” error component. --- --- @since 0.3.0 - -etok :: (Ord t, Ord e) => t -> EC t e -etok t = mempty { ecExpected = (E.singleton . Tokens . nes) t } - --- | Construct “expected tokens” error component. Empty string produces --- 'EndOfInput'. --- --- @since 0.3.0 - -etoks :: (Ord t, Ord e) => [t] -> EC t e -etoks t = mempty { ecExpected = (E.singleton . canonicalizeTokens) t } - --- | Construct “expected label” error component. Do not use with empty --- strings. --- --- @since 0.3.0 - -elabel :: (Ord t, Ord e) => String -> EC t e -elabel l = mempty { ecExpected = (E.singleton . Label . NE.fromList) l } - --- | Construct “expected end of input” error component. --- --- @since 0.3.0 - -eeof :: (Ord t, Ord e) => EC t e -eeof = mempty { ecExpected = E.singleton EndOfInput } - --- | Construct custom error component. --- --- @since 0.3.0 - -cstm :: e -> EC t e -cstm e = EC E.empty E.empty (E.singleton e) - ----------------------------------------------------------------------------- -- Incremental parsing --- | Check that a parser fails and leaves certain part of input +-- | Check that a parser fails and leaves a certain part of input -- unconsumed. Use it with functions like 'runParser'' and 'runParserT'' -- that support incremental parsing. -- @@ -333,7 +176,9 @@ -- | Expectation that argument is result of a failed parser. -shouldFail :: Show a => Either (ParseError t e) a -> Expectation +shouldFail :: Show a + => Either (ParseError t e) a + -> Expectation shouldFail r = case r of Left _ -> return () Right v -> expectationFailure $ @@ -342,7 +187,8 @@ -- | Expectation that argument is result of a succeeded parser. shouldSucceed :: (Ord t, ShowToken t, ShowErrorComponent e, Show a) - => Either (ParseError t e) a -> Expectation + => Either (ParseError t e) a + -> Expectation shouldSucceed r = case r of Left e -> expectationFailure $ "the parser is expected to succeed, but it failed with:\n" ++ @@ -359,24 +205,10 @@ "the parser is expected to leave unconsumed input: " ++ show e ++ "\nbut it left this: " ++ show a --- | Render parse error in a way that is suitable for inserting it in test +-- | Render parse error in a way that is suitable for inserting it in a test -- suite report. showParseError :: (Ord t, ShowToken t, ShowErrorComponent e) - => ParseError t e -> String + => ParseError t e + -> String showParseError = unlines . fmap (" " ++) . lines . parseErrorPretty - --- | Make a singleton non-empty list from a value. - -nes :: a -> NonEmpty a -nes x = x :| [] -{-# INLINE nes #-} - --- | Construct appropriate 'ErrorItem' representation for given token --- stream. Empty string produces 'EndOfInput'. - -canonicalizeTokens :: [t] -> ErrorItem t -canonicalizeTokens ts = - case NE.nonEmpty ts of - Nothing -> EndOfInput - Just xs -> Tokens xs diff --git a/hspec-megaparsec.cabal b/hspec-megaparsec.cabal --- a/hspec-megaparsec.cabal +++ b/hspec-megaparsec.cabal @@ -1,42 +1,11 @@ --- --- Cabal configuration for ‘hspec-megaparsec’. --- --- Copyright © 2016–2017 Mark Karpov --- --- 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. --- --- * Neither the name Mark Karpov nor the names of contributors may be used --- to endorse or promote products derived from this software without --- specific prior written permission. --- --- 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. - name: hspec-megaparsec -version: 0.3.1 -cabal-version: >= 1.10 +version: 1.0.0 +cabal-version: >= 1.18 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.1 license: BSD3 license-file: LICENSE.md -author: Mark Karpov -maintainer: Mark Karpov +author: Mark Karpov +maintainer: Mark Karpov homepage: https://github.com/mrkkrp/hspec-megaparsec bug-reports: https://github.com/mrkkrp/hspec-megaparsec/issues category: Testing, Parsing @@ -55,12 +24,11 @@ build-depends: base >= 4.7 && < 5.0 , containers >= 0.5 && < 0.6 , hspec-expectations >= 0.5 && < 0.9 - , megaparsec >= 5.0 && < 6.0 - - if !impl(ghc >= 8.0) - build-depends: semigroups == 0.18.* + , megaparsec >= 6.0 && < 7.0 if !impl(ghc >= 7.8) build-depends: tagged == 0.8.* + if !impl(ghc >= 8.0) + build-depends: semigroups == 0.18.* exposed-modules: Test.Hspec.Megaparsec if flag(dev) @@ -78,15 +46,16 @@ else ghc-options: -Wall build-depends: base >= 4.7 && < 5.0 - , containers >= 0.5 && < 0.6 , hspec >= 2.0 && < 3.0 , hspec-expectations >= 0.5 && < 0.9 - , hspec-megaparsec >= 0.3.1 - , megaparsec >= 5.0 && < 6.0 - if !impl(ghc >= 8.0) - build-depends: semigroups == 0.18.* + , hspec-megaparsec + , megaparsec >= 6.0 && < 7.0 if !impl(ghc >= 7.8) build-depends: tagged == 0.8.* + if !impl(ghc >= 7.10) + build-depends: void == 0.7.* + if !impl(ghc >= 8.0) + build-depends: semigroups == 0.18.* default-language: Haskell2010 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,50 +1,20 @@ --- --- Hspec Megaparsec tests. --- --- Copyright © 2016–2017 Mark Karpov --- --- 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. --- --- * Neither the name Mark Karpov nor the names of contributors may be used --- to endorse or promote products derived from this software without --- specific prior written permission. --- --- 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 #-} module Main (main) where -import Data.List.NonEmpty (NonEmpty (..)) +import Data.Semigroup ((<>)) +import Data.Void import Test.Hspec import Test.Hspec.Megaparsec import Text.Megaparsec -import Text.Megaparsec.String -import qualified Data.Set as E +import Text.Megaparsec.Char #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<*)) #endif +type Parser = Parsec Void String + -- | Toy tests, just an example of usage. main :: IO () @@ -65,11 +35,7 @@ describe "shouldFailWith" $ it "works" $ parse (char 'x' :: Parser Char) "" "b" `shouldFailWith` - ParseError - { errorPos = initialPos "" :| [] - , errorUnexpected = E.singleton (Tokens $ 'b' :| []) - , errorExpected = E.singleton (Tokens $ 'x' :| []) - , errorCustom = E.empty } + err posI (utok 'b' <> etok 'x') describe "failsLeaving" $ it "works" $ runParser' (many (char 'x') <* eof :: Parser String) (initialState "xxa")