From bda5fc822a843c1070a7b2716bc64fbf8bae594f Mon Sep 17 00:00:00 2001 From: Mark Karpov Date: Thu, 29 Jun 2017 18:33:47 +0700 Subject: [PATCH] Move error construction helpers into the library (#224) --- .travis.yml | 2 +- CHANGELOG.md | 5 + Text/Megaparsec/Error/Builder.hs | 208 +++++++++++++++++++++++++++++ Text/Megaparsec/Stream.hs | 4 +- megaparsec.cabal | 1 + tests/Test/Hspec/Megaparsec.hs | 194 +-------------------------- tests/Text/Megaparsec/LexerSpec.hs | 26 ++-- tests/Text/MegaparsecSpec.hs | 4 +- 8 files changed, 236 insertions(+), 208 deletions(-) create mode 100644 Text/Megaparsec/Error/Builder.hs diff --git a/.travis.yml b/.travis.yml index 2158707..abcde52 100644 --- a/.travis.yml +++ b/.travis.yml @@ -33,7 +33,7 @@ script: - travis_wait 60 cabal build - cabal test --show-details=always --test-option=--qc-max-success=1000 - cabal sdist - - cabal haddock | grep "100%" | wc -l | grep "8" + - cabal haddock | grep "100%" | wc -l | grep "9" after_script: - export PATH=~/.cabal/bin:$PATH diff --git a/CHANGELOG.md b/CHANGELOG.md index 8c5033f..31723b7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -49,6 +49,11 @@ * `defaultUpdatePos` has been moved from `Text.Megaparsec.Pos` to `Text.Megaparsec.Stream`. +* Added `Text.Megaparsec.Error.Builder` module to help construct + `ParseError`s easily. Useful for testing and debugging, previously we had + something like that in the `hspec-megaparsec` package, but it does not + hurt to ship it with the library. + * More lightweight dependency tree, dropped `exceptions` and `QuickCheck` dependencies. diff --git a/Text/Megaparsec/Error/Builder.hs b/Text/Megaparsec/Error/Builder.hs new file mode 100644 index 0000000..3b9fd33 --- /dev/null +++ b/Text/Megaparsec/Error/Builder.hs @@ -0,0 +1,208 @@ +-- | +-- Module : Text.Megaparsec.Error.Builder +-- Copyright : © 2015–2017 Megaparsec contributors +-- License : FreeBSD +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- A set of helpers that should make construction of 'ParseError's more +-- concise. This is primarily useful in test suites and for debugging, you +-- most certainly don't need it for normal usage. +-- +-- @since 6.0.0 + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Text.Megaparsec.Error.Builder + ( -- * Top-level helpers + err + , errFancy + -- * Error position + , posI + , posN + -- * Error components + , utok + , utoks + , ulabel + , ueof + , etok + , etoks + , elabel + , eeof + , fancy + -- * Data types + , ET + , EF ) +where + +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 Text.Megaparsec.Error +import Text.Megaparsec.Pos +import Text.Megaparsec.Stream +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as E + +---------------------------------------------------------------------------- +-- Data types + +-- | Auxiliary type for construction of trivial parse errors. + +data ET t = ET (Set (ErrorItem t)) (Set (ErrorItem t)) + deriving (Eq, Ord, Data, Typeable, Generic) + +instance Ord t => Semigroup (ET t) where + ET us0 ps0 <> ET us1 ps1 = ET (E.union us0 us1) (E.union ps0 ps1) + +instance Ord t => Monoid (ET t) where + mempty = ET E.empty E.empty + mappend = (<>) + +-- | Auxiliary type for construction of fancyc parse errors. + +data EF e = EF (Set (ErrorFancy e)) + deriving (Eq, Ord, Data, Typeable, Generic) + +instance Ord e => Semigroup (EF e) where + EF xs0 <> EF xs1 = EF (E.union xs0 xs1) + +instance Ord e => Monoid (EF e) where + mempty = EF E.empty + mappend = (<>) + +---------------------------------------------------------------------------- +-- Top-level helpers + +-- | Assemble a 'ParseError' from source position and @'ET' t@ value. To +-- create source position, two helpers are available: 'posI' and 'posN'. +-- @'ET' t@ is a monoid and can be built from primitives provided by this +-- module, see below. + +err + :: NonEmpty SourcePos -- ^ 'ParseError' position + -> ET t -- ^ Error components + -> ParseError t e -- ^ Resulting 'ParseError' +err pos (ET us ps) = TrivialError pos us ps + +-- | Much like 'err', but constructs a “fancy” 'ParseError'. + +errFancy + :: NonEmpty SourcePos -- ^ 'ParseError' position + -> EF e -- ^ Error components + -> ParseError t e -- ^ Resulting 'ParseError' +errFancy pos (EF xs) = FancyError pos xs + +---------------------------------------------------------------------------- +-- Error position + +-- | Initial source position with empty file name. + +posI :: NonEmpty SourcePos +posI = initialPos "" :| [] + +-- | @posN n s@ returns source position achieved by applying 'updatePos' +-- method corresponding to type of stream @s@ @n@ times. + +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 + +---------------------------------------------------------------------------- +-- Error components + +-- | Construct an “unexpected token” error component. + +utok :: Ord t => t -> ET t +utok = unexp . Tokens . nes + +-- | Construct an “unexpected tokens” error component. Empty string produces +-- 'EndOfInput'. + +utoks :: Ord t => [t] -> ET t +utoks = unexp . canonicalizeTokens + +-- | Construct an “unexpected label” error component. Do not use with empty +-- strings (for empty strings it's bottom). + +ulabel :: Ord t => String -> ET t +ulabel = unexp . Label . NE.fromList + +-- | Construct an “unexpected end of input” error component. + +ueof :: Ord t => ET t +ueof = unexp EndOfInput + +-- | Construct an “expected token” error component. + +etok :: Ord t => t -> ET t +etok = expe . Tokens . nes + +-- | Construct an “expected tokens” error component. Empty string produces +-- 'EndOfInput'. + +etoks :: Ord t => [t] -> ET t +etoks = expe . canonicalizeTokens + +-- | Construct an “expected label” error component. Do not use with empty +-- strings. + +elabel :: Ord t => String -> ET t +elabel = expe . Label . NE.fromList + +-- | Construct an “expected end of input” error component. + +eeof :: Ord t => ET t +eeof = expe EndOfInput + +-- | Construct a custom error component. + +fancy :: ErrorFancy e -> EF e +fancy = EF . E.singleton + +---------------------------------------------------------------------------- +-- Helpers + +-- | 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 + +-- | Lift an unexpected item into 'ET'. + +unexp :: ErrorItem t -> ET t +unexp u = ET (E.singleton u) E.empty + +-- | Lift an expected item into 'ET'. + +expe :: ErrorItem t -> ET t +expe p = ET E.empty (E.singleton p) + +-- | Make a singleton non-empty list from a value. + +nes :: a -> NonEmpty a +nes x = x :| [] diff --git a/Text/Megaparsec/Stream.hs b/Text/Megaparsec/Stream.hs index f28a942..4e26730 100644 --- a/Text/Megaparsec/Stream.hs +++ b/Text/Megaparsec/Stream.hs @@ -1,7 +1,7 @@ -- | -- Module : Text.Megaparsec.Stream --- Copyright : © 2017 Mark Karpov --- License : BSD 3 clause +-- Copyright : © 2015–2017 Megaparsec contributors +-- License : FreeBSD -- -- Maintainer : Mark Karpov -- Stability : experimental diff --git a/megaparsec.cabal b/megaparsec.cabal index caedf19..d5548ef 100644 --- a/megaparsec.cabal +++ b/megaparsec.cabal @@ -50,6 +50,7 @@ library exposed-modules: Text.Megaparsec , Text.Megaparsec.Char , Text.Megaparsec.Error + , Text.Megaparsec.Error.Builder , Text.Megaparsec.Expr , Text.Megaparsec.Lexer , Text.Megaparsec.Perm diff --git a/tests/Test/Hspec/Megaparsec.hs b/tests/Test/Hspec/Megaparsec.hs index 9f9a8fe..084fa25 100644 --- a/tests/Test/Hspec/Megaparsec.hs +++ b/tests/Test/Hspec/Megaparsec.hs @@ -9,10 +9,7 @@ -- -- Utility functions for testing Megaparsec parsers with Hspec. -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -26,39 +23,19 @@ module Test.Hspec.Megaparsec , shouldFailOn -- * Testing of error messages , shouldFailWith - -- * Error message construction - -- $errmsg - , err - , posI - , posN - , EC - , utok - , utoks - , ulabel - , ueof - , etok - , etoks - , elabel - , eeof - , fancy -- * 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 qualified Data.List.NonEmpty as NE -import qualified Data.Set as E +import Text.Megaparsec.Error.Builder ---------------------------------------------------------------------------- -- Basic expectations @@ -137,144 +114,6 @@ r `shouldFailWith` e = case r of Right v -> expectationFailure $ "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 (ETrivial us ps) = TrivialError pos us ps -err pos (EFancy xs) = FancyError pos xs - --- | 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 - = ETrivial (Set (ErrorItem t)) (Set (ErrorItem t)) - | EFancy (Set (ErrorFancy e)) - deriving (Eq, Data, Typeable, Generic) - -instance (Ord t, Ord e) => Semigroup (EC t e) where - (ETrivial u0 e0) <> (ETrivial u1 e1) = - ETrivial (E.union u0 u1) (E.union e0 e1) - (EFancy x0) <> (ETrivial _ _) = EFancy x0 - (ETrivial _ _) <> (EFancy x0) = EFancy x0 - (EFancy x0) <> (EFancy x1) = EFancy (E.union x0 x1) - -instance (Ord t, Ord e) => Monoid (EC t e) where - mempty = ETrivial E.empty E.empty - mappend = (<>) - --- | Construct an “unexpected token” error component. --- --- @since 0.3.0 - -utok :: (Ord t, Ord e) => t -> EC t e -utok = unexp . Tokens . nes - --- | Construct an “unexpected tokens” error component. Empty string produces --- 'EndOfInput'. --- --- @since 0.3.0 - -utoks :: (Ord t, Ord e) => [t] -> EC t e -utoks = unexp . canonicalizeTokens - --- | Construct an “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 = unexp . Label . NE.fromList - --- | Construct an “unexpected end of input” error component. --- --- @since 0.3.0 - -ueof :: (Ord t, Ord e) => EC t e -ueof = unexp EndOfInput - --- | Construct an “expected token” error component. --- --- @since 0.3.0 - -etok :: (Ord t, Ord e) => t -> EC t e -etok = expe . Tokens . nes - --- | Construct an “expected tokens” error component. Empty string produces --- 'EndOfInput'. --- --- @since 0.3.0 - -etoks :: (Ord t, Ord e) => [t] -> EC t e -etoks = expe . canonicalizeTokens - --- | Construct an “expected label” error component. Do not use with empty --- strings. --- --- @since 0.3.0 - -elabel :: (Ord t, Ord e) => String -> EC t e -elabel = expe . Label . NE.fromList - --- | Construct an “expected end of input” error component. --- --- @since 0.3.0 - -eeof :: (Ord t, Ord e) => EC t e -eeof = expe EndOfInput - --- | Construct a custom error component. --- --- @since 0.3.0 - -fancy :: ErrorFancy e -> EC t e -fancy = EFancy . E.singleton - ---------------------------------------------------------------------------- -- Incremental parsing @@ -373,28 +212,3 @@ showParseError :: (Ord t, ShowToken t, ShowErrorComponent e) => 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 - --- | Lift an unexpected item into 'EC'. - -unexp :: ErrorItem t -> EC t e -unexp u = ETrivial (E.singleton u) E.empty - --- | Lift an expected item into 'EC'. - -expe :: ErrorItem t -> EC t e -expe p = ETrivial E.empty (E.singleton p) diff --git a/tests/Text/Megaparsec/LexerSpec.hs b/tests/Text/Megaparsec/LexerSpec.hs index b465cab..0b1d691 100644 --- a/tests/Text/Megaparsec/LexerSpec.hs +++ b/tests/Text/Megaparsec/LexerSpec.hs @@ -78,7 +78,7 @@ spec = do property $ \ord ref actual -> do let p :: Parser () p = incorrectIndent ord ref actual - prs p "" `shouldFailWith` err posI (ii ord ref actual) + prs p "" `shouldFailWith` errFancy posI (ii ord ref actual) describe "indentGuard" $ it "works as intended" $ @@ -94,11 +94,11 @@ spec = do ip = indentGuard scn sp = void (symbol sc sbla <* C.eol) if | col0 <= pos1 -> - prs p s `shouldFailWith` err posI (ii GT pos1 col0) + prs p s `shouldFailWith` errFancy posI (ii GT pos1 col0) | col1 /= col0 -> - prs p s `shouldFailWith` err (posN (getIndent l1 + g 1) s) (ii EQ col0 col1) + prs p s `shouldFailWith` errFancy (posN (getIndent l1 + g 1) s) (ii EQ col0 col1) | col2 <= col0 -> - prs p s `shouldFailWith` err (posN (getIndent l2 + g 2) s) (ii GT col0 col2) + prs p s `shouldFailWith` errFancy (posN (getIndent l2 + g 2) s) (ii GT col0 col2) | otherwise -> prs p s `shouldParse` () @@ -109,7 +109,7 @@ spec = do i = getIndent s if i == 0 then prs p s `shouldParse` sbla - else prs p s `shouldFailWith` err (posN i s) (ii EQ pos1 (getCol s)) + else prs p s `shouldFailWith` errFancy (posN i s) (ii EQ pos1 (getCol s)) describe "indentBlock" $ do it "works as indented" $ @@ -140,19 +140,19 @@ spec = do if | col1 <= col0 -> prs p s `shouldFailWith` err (posN (getIndent l1 + g 1) s) (utok (head sblb) <> eeof) | isJust mn && col1 /= ib' -> prs p s `shouldFailWith` - err (posN (getIndent l1 + g 1) s) (ii EQ ib' col1) + errFancy (posN (getIndent l1 + g 1) s) (ii EQ ib' col1) | col2 <= col1 -> prs p s `shouldFailWith` - err (posN (getIndent l2 + g 2) s) (ii GT col1 col2) + errFancy (posN (getIndent l2 + g 2) s) (ii GT col1 col2) | col3 == col2 -> prs p s `shouldFailWith` err (posN (getIndent l3 + g 3) s) (utok (head sblb) <> etoks sblc <> eeof) | col3 <= col0 -> prs p s `shouldFailWith` err (posN (getIndent l3 + g 3) s) (utok (head sblb) <> eeof) | col3 < col1 -> prs p s `shouldFailWith` - err (posN (getIndent l3 + g 3) s) (ii EQ col1 col3) + errFancy (posN (getIndent l3 + g 3) s) (ii EQ col1 col3) | col3 > col1 -> prs p s `shouldFailWith` - err (posN (getIndent l3 + g 3) s) (ii EQ col2 col3) + errFancy (posN (getIndent l3 + g 3) s) (ii EQ col2 col3) | col4 <= col3 -> prs p s `shouldFailWith` - err (posN (getIndent l4 + g 4) s) (ii GT col3 col4) + errFancy (posN (getIndent l4 + g 4) s) (ii GT col3 col4) | otherwise -> prs p s `shouldParse` (sbla, [(sblb, [sblc]), (sblb, [sblc])]) it "IndentMany works as intended (newline at the end)" $ @@ -215,9 +215,9 @@ spec = do (col0, col1, col2) = (getCol l0, getCol l1, getCol l2) (end0, end1) = (getEnd l0, getEnd l1) if | end0 && col1 <= col0 -> prs p s `shouldFailWith` - err (posN (getIndent l1 + g 1) s) (ii GT col0 col1) + errFancy (posN (getIndent l1 + g 1) s) (ii GT col0 col1) | end1 && col2 <= col0 -> prs p s `shouldFailWith` - err (posN (getIndent l2 + g 2) s) (ii GT col0 col2) + errFancy (posN (getIndent l2 + g 2) s) (ii GT col0 col2) | otherwise -> prs p s `shouldParse` (sbla, sblb, sblc) describe "charLiteral" $ do @@ -484,5 +484,5 @@ sbla = "aaa" sblb = "bbb" sblc = "ccc" -ii :: Ordering -> Pos -> Pos -> EC Char Void +ii :: Ordering -> Pos -> Pos -> EF Void ii ord ref actual = fancy (ErrorIndentation ord ref actual) diff --git a/tests/Text/MegaparsecSpec.hs b/tests/Text/MegaparsecSpec.hs index 5501321..aecbbad 100644 --- a/tests/Text/MegaparsecSpec.hs +++ b/tests/Text/MegaparsecSpec.hs @@ -429,7 +429,7 @@ spec = do it "fails signals correct parse error" $ property $ \msg -> do let p = fail msg :: Parsec Void String () - prs p "" `shouldFailWith` err posI (fancy $ ErrorFail msg) + prs p "" `shouldFailWith` errFancy posI (fancy $ ErrorFail msg) it "pure is the same as return" $ property $ \n -> prs (pure (n :: Int)) "" `shouldBe` prs (return n) "" @@ -444,7 +444,7 @@ spec = do it "signals correct parse error" $ property $ \s msg -> do let p = void (fail msg) - prs p s `shouldFailWith` err posI (fancy $ ErrorFail msg) + prs p s `shouldFailWith` errFancy posI (fancy $ ErrorFail msg) prs' p s `failsLeaving` s describe "ParsecT MonadIO instance" $