Move error construction helpers into the library (#224)

.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

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.
 

Text/Megaparsec/Error/Builder.hs

@@ -0,0 +1,208 @@
+-- |
+-- Module      :  Text.Megaparsec.Error.Builder
+-- Copyright   :  © 2015–2017 Megaparsec contributors
+-- License     :  FreeBSD
+--
+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
+-- 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 :| []

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 <markkarpov92@gmail.com>
 -- Stability   :  experimental

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

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)

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)

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" $