diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Revision history for gigaparsec -## 0.1.0.0 -- YYYY-mm-dd +## 0.1.0.0 -- 2023-10-17 * First version. Released on an unsuspecting world. + +## 0.2.0.0 -- 2023-11-09 + +* Added error system. +* `parse` now has a type parameter, `parse @String` restores old behaviour +* for convenience `parseRepl` will print a parse to the terminal with the `String` error messages. diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Main.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE StandaloneDeriving, DeriveAnyClass, DeriveGeneric #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Main (main) where + +import Gauge (defaultMain, bench, nf) +import Text.Gigaparsec (Parsec, Result(Success, Failure), parse, atomic, (<|>)) +import Text.Gigaparsec.Char (string) +import Control.DeepSeq (NFData) +import GHC.Generics (Generic) + +p :: Parsec String +p = atomic (string "hello wold") <|> atomic (string "hi") <|> string "hello world" + +deriving stock instance Generic (Result e a) +deriving anyclass instance (NFData a, NFData e) => NFData (Result e a) + +main :: IO () +main = defaultMain [ + bench "consumption" $ nf (parse @String p) "hello world" + ] diff --git a/gigaparsec.cabal b/gigaparsec.cabal --- a/gigaparsec.cabal +++ b/gigaparsec.cabal @@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.0.0 +version: 0.2.0.0 -- A short (one-line) description of the package. synopsis: @@ -84,6 +84,8 @@ Text.Gigaparsec.Combinator, Text.Gigaparsec.Combinator.NonEmpty, Text.Gigaparsec.Errors.Combinator, + Text.Gigaparsec.Errors.DefaultErrorBuilder, + Text.Gigaparsec.Errors.ErrorBuilder, Text.Gigaparsec.Expr, Text.Gigaparsec.Expr.Chain, Text.Gigaparsec.Expr.Infix, @@ -92,6 +94,7 @@ -- Internals Text.Gigaparsec.Internal, + Text.Gigaparsec.Internal.Errors, Text.Gigaparsec.Internal.RT, Text.Gigaparsec.Internal.Require @@ -107,6 +110,8 @@ -- Directories containing source files. hs-source-dirs: src + include-dirs: includes + install-includes: includes/portable-unlifted.h -- Base language which the package is written in. default-language: Haskell2010 @@ -124,9 +129,11 @@ Text.Gigaparsec.CharTests, Text.Gigaparsec.CombinatorTests, Text.Gigaparsec.ExprTests, + Text.Gigaparsec.ErrorsTests, Text.Gigaparsec.Expr.ChainTests, Text.Gigaparsec.Expr.InfixTests, Text.Gigaparsec.Internal.Test, + Text.Gigaparsec.Internal.TestError, Text.Gigaparsec.Internal.PlainString ghc-options: -Wno-missing-export-lists -Wno-missing-safe-haskell-mode -Wno-safe @@ -146,11 +153,32 @@ build-depends: gigaparsec, containers >= 0.6 && < 0.7, + --deriving-compat >= 0.6 && < 0.7, tasty >=1.1 && <1.6, - --tasty-expected-failure, - tasty-hunit >=0.9 && <0.11 + tasty-expected-failure >=0.11 && <0.13, + tasty-hunit >=0.9 && <0.11, --TODO: property based testing will be useful when we optimise combinators -- to test against their base implementations --tasty-quickcheck --TODO: performance testing with tasty-bench? + --tasty-bench -- we'd need to keep the basefile files somewhere, cache in CI or keep in repo? + +benchmark perf-test + import: warnings, extensions, base + + type: exitcode-stdio-1.0 + + default-extensions: OverloadedStrings, TypeOperators, BlockArguments, GADTs + + -- Base language which the package is written in. + default-language: Haskell2010 + + hs-source-dirs: benchmarks + build-depends: + gigaparsec, + --containers >= 0.6 && < 0.7, + gauge >= 0.1 && < 0.3, + deepseq >= 1.4 && < 1.6 + + main-is: Main.hs diff --git a/includes/portable-unlifted.h b/includes/portable-unlifted.h new file mode 100644 --- /dev/null +++ b/includes/portable-unlifted.h @@ -0,0 +1,25 @@ +#ifdef false +/* + * Copyright 2023 Gigaparsec Contributors + * + * SPDX-License-Identifier: BSD-3-Clause + */ + +// This file enables the use of `UnliftedDatatypes` from 9.2 in a portable way +// include this file at the top underneath the requisite `CPP` extension, then +// have a `CPP_import_PortableUnlifted` import; `UnliftedDatatype` is now a kind +// that can be freely used. +#endif + +#if __GLASGOW_HASKELL__ >= 902 +{-# LANGUAGE UnliftedDatatypes #-} + +#define CPP_import_PortableUnlifted import GHC.Exts (TYPE, RuntimeRep(BoxedRep), Levity(Unlifted)) +#define UnliftedDatatype (TYPE ('BoxedRep 'Unlifted)) + +#else + +#define CPP_import_PortableUnlifted +#define UnliftedDatatype * + +#endif diff --git a/src/Text/Gigaparsec.hs b/src/Text/Gigaparsec.hs --- a/src/Text/Gigaparsec.hs +++ b/src/Text/Gigaparsec.hs @@ -15,7 +15,7 @@ @since 0.1.0.0 -} module Text.Gigaparsec ( - Parsec, Result(..), parse, + Parsec, Result(..), result, parse, parseRepl, -- * Primitive Combinators -- | These combinators are specific to parser combinators. In one way or another, they influence -- how a parser consumes input, or under what conditions a parser does or does not fail. These are @@ -83,26 +83,43 @@ -- `Internal`: when they are in the public API, we are locked into them! import Text.Gigaparsec.Internal (Parsec(Parsec), emptyState, manyr, somer) -import Text.Gigaparsec.Internal qualified as Internal.State (State(..)) -import Text.Gigaparsec.Internal.RT (runRT) +import Text.Gigaparsec.Internal qualified as Internal (State(..), useHints, expectedErr) +import Text.Gigaparsec.Internal.RT qualified as Internal (RT, runRT) +import Text.Gigaparsec.Internal.Errors qualified as Internal (ParseError, ExpectItem(ExpectEndOfInput), fromParseError) +import Text.Gigaparsec.Errors.ErrorBuilder (ErrorBuilder) + import Data.Functor (void) import Control.Applicative (liftA2, (<|>), empty, many, some, (<**>)) -- liftA2 required until 9.6 import Control.Selective (select, branch) +import Data.Set qualified as Set (singleton, empty) + -- Hiding the Internal module seems like the better bet: nobody needs to see it anyway :) -- re-expose like this to prevent hlint suggesting import refinement into internal --type Parsec :: * -> * --type Parsec = Internal.Parsec -type Result :: * -> * -data Result a = Success a | Failure deriving stock (Show, Eq) +type Result :: * -> * -> * +data Result e a = Success a | Failure e deriving stock (Show, Eq) -parse :: Parsec a -> String -> Result a -parse (Parsec p) inp = runRT $ p (emptyState inp) good bad - where good x _ = return (Success x) - bad _ = return Failure +result :: (e -> b) -> (a -> b) -> Result e a -> b +result _ success (Success x) = success x +result failure _ (Failure err) = failure err +{-# SPECIALISE parse :: Parsec a -> String -> Result String a #-} +{-# INLINABLE parse #-} +parse :: forall err a. ErrorBuilder err => Parsec a -> String -> Result err a +parse (Parsec p) inp = Internal.runRT $ p (emptyState inp) good bad + where good :: a -> Internal.State -> Internal.RT (Result err a) + good x _ = return (Success x) + bad :: Internal.ParseError -> Internal.State -> Internal.RT (Result err a) + bad err _ = return (Failure (Internal.fromParseError Nothing inp err)) + +-- TODO: documentation +parseRepl :: Show a => Parsec a -> String -> IO () +parseRepl p inp = result putStrLn print (parse p inp) + {-| This combinator parses its argument @p@, but rolls back any consumed input on failure. @@ -122,8 +139,7 @@ -} atomic :: Parsec a -- ^ the parser, @p@, to execute, if it fails, it will not have consumed input. -> Parsec a -- ^ a parser that tries @p@, but never consumes input if it fails. -atomic (Parsec p) = Parsec $ \st ok err -> - p st ok (const $ err st) +atomic (Parsec p) = Parsec $ \st ok bad -> p st ok (\err _ -> bad err st) {-| This combinator parses its argument @p@, but does not consume input if it succeeds. @@ -142,8 +158,7 @@ -} lookAhead :: Parsec a -- ^ the parser, @p@, to execute -> Parsec a -- ^ a parser that parses @p@ and never consumes input if it succeeds. -lookAhead (Parsec p) = Parsec $ \st ok err -> - p st (\x _ -> ok x st) err +lookAhead (Parsec p) = Parsec $ \st ok err -> p st (\x _ -> ok x st) err {-| This combinator parses its argument @p@, and succeeds when @p@ fails and vice-versa, never consuming @@ -168,8 +183,10 @@ -} notFollowedBy :: Parsec a -- ^ the parser, @p@, to execute, it must fail in order for this combinator to succeed. -> Parsec () -- ^ a parser which fails when @p@ succeeds and succeeds otherwise, never consuming input. -notFollowedBy (Parsec p) = Parsec $ \st ok err -> - p st (\_ _ -> err st) (\_ -> ok () st) +notFollowedBy (Parsec p) = Parsec $ \st ok bad -> + p st (\_ st' -> let !width = Internal.consumed st' - Internal.consumed st + in Internal.useHints bad (Internal.expectedErr st Set.empty width) st) + (\_ _ -> ok () st) -- eof is usually `notFollowedBy item`, but this requires annoying cyclic dependencies on Char {- This parser only succeeds at the end of the input. @@ -185,8 +202,9 @@ @since 0.1.0.0 -} eof :: Parsec () -eof = Parsec $ \st good bad -> case Internal.State.input st of - (:){} -> bad st +eof = Parsec $ \st good bad -> case Internal.input st of + (:){} -> Internal.useHints bad + (Internal.expectedErr st (Set.singleton Internal.ExpectEndOfInput) 1) st [] -> good () st {-| diff --git a/src/Text/Gigaparsec/Char.hs b/src/Text/Gigaparsec/Char.hs --- a/src/Text/Gigaparsec/Char.hs +++ b/src/Text/Gigaparsec/Char.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Safe #-} {-# LANGUAGE OverloadedLists #-} -{-# OPTIONS_GHC -Wno-all-missed-specialisations #-} +{-# OPTIONS_GHC -Wno-all-missed-specialisations -Wno-overflowed-literals #-} {-| Module : Text.Gigaparsec.Char Description : Contains the combinators needed to read characters and strings, as well as combinators @@ -49,7 +49,8 @@ import Text.Gigaparsec.Combinator (skipMany) import Text.Gigaparsec.Errors.Combinator (()) -- We want to use this to make the docs point to the right definition for users. -import Text.Gigaparsec.Internal qualified as Internal (Parsec(Parsec), State(..)) +import Text.Gigaparsec.Internal qualified as Internal (Parsec(Parsec, unParsec), State(..), expectedErr, useHints) +import Text.Gigaparsec.Internal.Errors qualified as Internal (ExpectItem(ExpectRaw), ParseError) import Text.Gigaparsec.Internal.Require (require) import Data.Bits (Bits((.&.), (.|.))) @@ -59,7 +60,7 @@ import Data.Maybe (isJust, fromJust) import Data.Monoid (Alt(Alt, getAlt)) import Data.Set (Set) -import Data.Set qualified as Set (member, size, findMin, findMax, mapMonotonic) +import Data.Set qualified as Set (empty, member, size, findMin, findMax, mapMonotonic, singleton) import Data.Map (Map) import Data.Map qualified as Map (fromSet, toAscList, member) @@ -67,6 +68,24 @@ -- Primitives ------------------------------------------------- +_satisfy :: Set Internal.ExpectItem -> (Char -> Bool) -> Parsec Char +_satisfy expecteds test = Internal.Parsec $ \st ok bad -> + case Internal.input st of + c:cs | test c -> ok c (updateState st c cs) + _ -> Internal.useHints bad (Internal.expectedErr st expecteds 1) st + where + -- The duplicated input & consumed update avoids double allocation + -- that occurs if they were done separately to the line and col updates. + updateState st '\n' cs = st + { Internal.line = Internal.line st + 1, Internal.col = 1, + Internal.input = cs, Internal.consumed = Internal.consumed st + 1 } + updateState st '\t' cs = st + { Internal.col = ((Internal.col st + 3) .&. (-4)) .|. 1, + Internal.input = cs, Internal.consumed = Internal.consumed st + 1 } + updateState st _ cs = st + { Internal.col = Internal.col st + 1, + Internal.input = cs, Internal.consumed = Internal.consumed st + 1 } + {-| This combinator tries to parse a single character from the input that matches the given predicate. @@ -75,11 +94,11 @@ consumed and this combinator will fail. ==== __Examples__ ->>> parse (satisfy Data.Char.isDigit) "" +>>> parse @String (satisfy Data.Char.isDigit) "" Failure .. ->>> parse (satisfy Data.Char.isDigit) "7" +>>> parse @String (satisfy Data.Char.isDigit) "7" Success '7' ->>> parse (satisfy Data.Char.isDigit) "a5" +>>> parse @String (satisfy Data.Char.isDigit) "a5" Failure .. Roughly speaking: @@ -94,23 +113,7 @@ -- exist. -> Parsec Char -- ^ a parser that tries to read a single character @c@, such that @pred c@ -- is true, or fails. -satisfy test = Internal.Parsec $ \st ok err -> - case Internal.input st of - c: cs | test c -> - ok c (updateState st c cs) - _ -> err st - where - -- The duplicated input & consumed update avoids double allocation - -- that occurs if they were done separately to the line and col updates. - updateState st '\n' cs = st - { Internal.line = Internal.line st + 1, Internal.col = 1, - Internal.input = cs, Internal.consumed = True } - updateState st '\t' cs = st - { Internal.col = ((Internal.col st + 3) .&. (-4)) .|. 1, - Internal.input = cs, Internal.consumed = True } - updateState st _ cs = st - { Internal.col = Internal.col st + 1, - Internal.input = cs, Internal.consumed = True } +satisfy = _satisfy Set.empty -- Needs to be primitive for the raw expected item down the line {-| @@ -121,18 +124,18 @@ combinator will fail. ==== __Examples__ ->>> parse (char 'a') "" +>>> parse @String (char 'a') "" Failure .. ->>> parse (char 'a') "a" +>>> parse @String (char 'a') "a" Success 'a' ->>> parse (char 'a') "ba" +>>> parse @String (char 'a') "ba" Failure .. @since 0.1.0.0 -} char :: Char -- ^ the character to parse, @c@. -> Parsec Char -- ^ a parser that tries to read a single @c@, or fails. -char c = satisfy (== c) +char c = _satisfy (Set.singleton (Internal.ExpectRaw (pure c))) (== c) -- Needs to be primitive for the raw expected item and wide caret down the line {-| @@ -145,11 +148,11 @@ matched are consumed from the input. ==== __Examples__ ->>> parse (string "abc") "" +>>> parse @String (string "abc") "" Failure .. ->>> parse (string "abc") "abcd" +>>> parse @String (string "abc") "abcd" Success "abc" ->>> parse (string "abc") "xabc" +>>> parse @String (string "abc") "xabc" Failure .. ==== Notes @@ -163,7 +166,12 @@ -> Parsec String -- ^ a parser that either parses the string @s@ or fails at the first -- mismatched character. string s = require (not (null s)) "Text.Gigaparsec.Char.string" "cannot pass empty string" $ - traverse char s + --TODO: this could be much improved + Internal.Parsec $ \st ok bad -> + let bad' (_ :: Internal.ParseError) = + Internal.useHints bad (Internal.expectedErr st [Internal.ExpectRaw s] + (fromIntegral (length s))) + in Internal.unParsec (traverse char s) st ok bad' ------------------------------------------------- -- Composite Combinators @@ -179,11 +187,11 @@ ==== __Examples__ >>> let digit = satisfyMap (\c -> if isDigit c then Just (digitToInt c) else Nothing) ->>> parse digit "" +>>> parse @String digit "" Failure .. ->>> parse digit "7" +>>> parse @String digit "7" Success 7 ->>> parse digit "a5" +>>> parse @String digit "a5" Failure .. @since 0.1.0.0 @@ -204,11 +212,11 @@ ==== __Examples__ >>> let p = oneOf (Set.fromList ['a'..'c']) ->>> parse p "a" +>>> parse @String p "a" Success 'a' ->>> parse p "c" +>>> parse @String p "c" Success 'c' ->>> parse p "xb" +>>> parse @String p "xb" Failure .. @since 0.1.0.0 @@ -220,14 +228,14 @@ | sz == 1 = char c1 -- if the smallest and largest characters are as far apart -- as the size of the set, it must be contiguous - | sz == (ord c2 - ord c1 + 1) = satisfy (\c -> c1 <= c && c <= c2) Set.mapMonotonic show cs - | otherwise = satisfy (`Set.member` cs) [rangeLabel] + | sz == (ord c2 - ord c1 + 1) = satisfy (\c -> c1 <= c && c <= c2) [rangeLabel] + | otherwise = satisfy (`Set.member` cs) Set.mapMonotonic (show . (: [])) cs where !sz = Set.size cs -- must be left lazy until sz known not to be 0 c1 = Set.findMin cs c2 = Set.findMax cs --FIXME: control character safe show (and for the map above!) - rangeLabel = "one of " ++ show c1 ++ " to " ++ show c2 + rangeLabel = "one of " ++ show @String [c1] ++ " to " ++ show @String [c2] {-| This combinator tries to parse any character __not__ from supplied set of characters @cs@, @@ -238,13 +246,13 @@ ==== __Examples__ >>> let p = noneOf (Set.from ['a'..'c']) ->>> parse p "a" +>>> parse @String p "a" Failure .. ->>> parse p "c" +>>> parse @String p "c" Failure .. ->>> parse p "xb" +>>> parse @String p "xb" Success 'x' ->>> parse p "" +>>> parse @String p "" Failure .. @since 0.1.0.0 @@ -261,7 +269,7 @@ c1 = Set.findMin cs c2 = Set.findMax cs --FIXME: control character safe show - rangeLabel = "anything outside of " ++ show c1 ++ " to " ++ show c2 + rangeLabel = "anything outside of " ++ show @String [c1] ++ " to " ++ show @String [c2] {-| This combinator parses characters matching the given predicate __zero__ or more times, collecting @@ -273,11 +281,11 @@ ==== __Examples__ >>> let ident = letter <:> stringOfMany isAlphaNum ->>> parse ident "abdc9d" +>>> parse @String ident "abdc9d" Success "abdc9d" ->>> parse ident "a" +>>> parse @String ident "a" Success "a" ->>> parser ident "9" +>>> parse @Stringr ident "9" Failure .. ==== Notes @@ -301,11 +309,11 @@ ==== __Examples__ >>> let ident = stringOfSome isAlpha ->>> parse ident "abdc9d" +>>> parse @String ident "abdc9d" Success "abdc" ->>> parse ident "a" +>>> parse @String ident "a" Success "a" ->>> parser ident "9" +>>> parse @Stringr ident "9" Failure .. ==== Notes @@ -329,15 +337,15 @@ ==== __Examples__ >>> let p = strings (Set.fromList ["hell", "hello", "goodbye", "g", "abc"]) ->>> parse p "hell" +>>> parse @String p "hell" Success "hell" ->>> parse p "hello" +>>> parse @String p "hello" Success "hello" ->>> parse p "good" +>>> parse @String p "good" Success "g" ->>> parse p "goodbye" +>>> parse @String p "goodbye" Success "goodbye" ->>> parse p "a" +>>> parse @String p "a" Failure .. @since 0.1.0.0 @@ -363,15 +371,15 @@ , ("g", pure 1) , ("abc", pure 3) ] ->>> parse p "hell" +>>> parse @String p "hell" Success 4 ->>> parse p "hello" +>>> parse @String p "hello" Success 5 ->>> parse p "good" +>>> parse @String p "good" Success 1 ->>> parse p "goodbye" +>>> parse @String p "goodbye" Success 7 ->>> parse p "a" +>>> parse @String p "a" Failure .. ==== Notes @@ -496,8 +504,9 @@ An uppercase letter is any character whose Unicode /Category Type/ is Uppercase Letter (@Lu@). Examples of characters within this category include: - * the Latin letters @'A'@ through @'Z'@ - * Latin special character such as @'Å'@, @'Ç'@, @'Õ'@ + + * the Latin letters @\'A\'@ through @\'Z\'@ + * Latin special character such as @\'Å\'@, @\'Ç\'@, @\'Õ\'@ * Cryillic letters * Greek letters * Coptic letters @@ -514,8 +523,9 @@ Letter (@Ll@). Examples of characters within this category include: - * the Latin letters @'a'@ through @'z'@ - * Latin special character such as @'é'@, @'ß'@, @'ð'@ + + * the Latin letters @\'a\'@ through @\'z\'@ + * Latin special character such as @\'é\'@, @\'ß\'@, @\'ð\'@ * Cryillic letters * Greek letters * Coptic letters diff --git a/src/Text/Gigaparsec/Combinator.hs b/src/Text/Gigaparsec/Combinator.hs --- a/src/Text/Gigaparsec/Combinator.hs +++ b/src/Text/Gigaparsec/Combinator.hs @@ -1,6 +1,4 @@ {-# LANGUAGE Safe #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Use optional" #-} {-| Module : Text.Gigaparsec.Combinator Description : This module contains a huge number of pre-made combinators that are @@ -67,13 +65,13 @@ ==== __Examples__ >>> let p = choice [string "abc", string "ab", string "bc", string "d"] ->>> parse p "abc" +>>> parse @String p "abc" Success "abc" ->>> parse p "ab" +>>> parse @String p "ab" Failure .. ->>> parse p "bc" +>>> parse @String p "bc" Success "bc" ->>> parse p "x" +>>> parse @String p "x" Failure .. @since 0.1.0.0 @@ -91,9 +89,9 @@ ==== __Examples__ >>> let p = skip [char'a', item, char 'c'] ->>> parse p "abc" +>>> parse @String p "abc" Success () ->>> parse p "ab" +>>> parse @String p "ab" Failure .. @since 0.1.0.0 @@ -110,11 +108,11 @@ ==== __Examples__ >>> let p = option (string "abc") ->>> parse p "" +>>> parse @String p "" Success Nothing ->>> parse p "abc" +>>> parse @String p "abc" Success (Just "abc") ->>> parse p "ab" +>>> parse @String p "ab" Failure .. @since 0.1.0.0 @@ -131,11 +129,11 @@ ==== __Examples__ >>> let p = optional (string "abc") ->>> parse p "" +>>> parse @String p "" Success () ->>> parse p "abc" +>>> parse @String p "abc" Success () ->>> parse p "ab" +>>> parse @String p "ab" Failure .. @since 0.1.0.0 @@ -152,11 +150,11 @@ ==== __Examples__ >>> let p = optionalAs 7 (string "abc") ->>> parse p "" +>>> parse @String p "" Success 7 ->>> parse p "abc" +>>> parse @String p "abc" Success 7 ->>> parse p "ab" +>>> parse @String p "ab" Failure .. @since 0.1.0.0 @@ -208,13 +206,13 @@ ==== __Examples__ >>> let p = manyN 2 (string "ab") ->>> parse p "" +>>> parse @String p "" Failure .. ->>> parse p "ab" +>>> parse @String p "ab" Failure .. ->>> parse p "abababab" +>>> parse @String p "abababab" Success ["ab", "ab", "ab", "ab"] ->>> parse p "aba" +>>> parse @String p "aba" Failure .. ==== Notes @@ -238,13 +236,13 @@ ==== __Examples__ >>> let p = skipMany (string "ab") ->>> parse p "" +>>> parse @String p "" Success () ->>> parse p "ab" +>>> parse @String p "ab" Success () ->>> parse p "abababab" +>>> parse @String p "abababab" Success () ->>> parse p "aba" +>>> parse @String p "aba" Failure .. @since 0.1.0.0 @@ -262,13 +260,13 @@ ==== __Examples__ >>> let p = skipSome (string "ab") ->>> parse p "" +>>> parse @String p "" Failure .. ->>> parse p "ab" +>>> parse @String p "ab" Success () ->>> parse p "abababab" +>>> parse @String p "abababab" Success () ->>> parse p "aba" +>>> parse @String p "aba" Failure .. @since 0.1.0.0 @@ -286,13 +284,13 @@ ==== __Examples__ >>> let p = skipManyN 2 (string "ab") ->>> parse p "" +>>> parse @String p "" Failure .. ->>> parse p "ab" +>>> parse @String p "ab" Failure .. ->>> parse p "abababab" +>>> parse @String p "abababab" Success () ->>> parse p "aba" +>>> parse @String p "aba" Failure .. @since 0.1.0.0 @@ -313,13 +311,13 @@ ==== __Examples__ >>> let p = count (string "ab") ->>> parse p "" +>>> parse @String p "" Success 0 ->>> parse p "ab" +>>> parse @String p "ab" Success 1 ->>> parse p "abababab" +>>> parse @String p "abababab" Success 4 ->>> parse p "aba" +>>> parse @String p "aba" Failure .. @since 0.1.0.0 @@ -337,13 +335,13 @@ ==== __Examples__ >>> let p = count1 (string "ab") ->>> parse p "" +>>> parse @String p "" Failure .. ->>> parse p "ab" +>>> parse @String p "ab" Success 1 ->>> parse p "abababab" +>>> parse @String p "abababab" Success 4 ->>> parse p "aba" +>>> parse @String p "aba" Failure .. @since 0.1.0.0 @@ -360,13 +358,13 @@ ==== __Examples__ >>> ... >>> let args = sepBy int (string ", ") ->>> parse args "7, 3, 2" +>>> parse @String args "7, 3, 2" Success [7, 3, 2] ->>> parse args "" +>>> parse @String args "" Success [] ->>> parse args "1" +>>> parse @String args "1" Success [1] ->>> parse args "1, 2, " +>>> parse @String args "1, 2, " Failure .. @since 0.1.0.0 @@ -387,13 +385,13 @@ ==== __Examples__ >>> ... >>> let args = sepBy1 int (string ", ") ->>> parse args "7, 3, 2" +>>> parse @String args "7, 3, 2" Success [7, 3, 2] ->>> parse args "" +>>> parse @String args "" Failure .. ->>> parse args "1" +>>> parse @String args "1" Success [1] ->>> parse args "1, 2, " +>>> parse @String args "1, 2, " Failure .. @since 0.1.0.0 @@ -411,13 +409,13 @@ ==== __Examples__ >>> ... >>> let args = sepEndBy int (string ";\n") ->>> parse args "7;\n3;\n2" +>>> parse @String args "7;\n3;\n2" Success [7, 3, 2] ->>> parse args "" +>>> parse @String args "" Success Nil ->>> parse args "1" +>>> parse @String args "1" Success [1] ->>> parse args "1;\n2;\n" +>>> parse @String args "1;\n2;\n" Success [1, 2] @since 0.1.0.0 @@ -438,13 +436,13 @@ ==== __Examples__ >>> ... >>> let args = sepEndBy1 int (string ";\n") ->>> parse args "7;\n3;\n2" +>>> parse @String args "7;\n3;\n2" Success [7, 3, 2] ->>> parse args "" +>>> parse @String args "" Failure .. ->>> parse args "1" +>>> parse @String args "1" Success [1] ->>> parse args "1;\n2;\n" +>>> parse @String args "1;\n2;\n" Success [1, 2] @since 0.1.0.0 @@ -462,13 +460,13 @@ ==== __Examples__ >>> ... >>> let args = endBy int (string ";\n") ->>> parse args "7;\n3;\n2" +>>> parse @String args "7;\n3;\n2" Failure .. ->>> parse args "" +>>> parse @String args "" Success Nil ->>> parse args "1;\n" +>>> parse @String args "1;\n" Success [1] ->>> parse args "1;\n2;\n" +>>> parse @String args "1;\n2;\n" Success [1, 2] @since 0.1.0.0 @@ -488,13 +486,13 @@ ==== __Examples__ >>> ... >>> let args = endBy1 int (string ";\n") ->>> parse args "7;\n3;\n2" +>>> parse @String args "7;\n3;\n2" Failure .. ->>> parse args "" +>>> parse @String args "" Failure .. ->>> parse args "1;\n" +>>> parse @String args "1;\n" Success [1] ->>> parse args "1;\n2;\n" +>>> parse @String args "1;\n2;\n" Success [1, 2] @since 0.1.0.0 @@ -513,12 +511,13 @@ ==== __Examples__ This can be useful for scanning comments: + >>> let comment = string "--" *> manyUntil item endOfLine ->>> parse p "--hello world" +>>> parse @String p "--hello world" Failure .. ->>> parse p "--hello world\n" +>>> parse @String p "--hello world\n" Success ['h', 'e', 'l', 'l', 'o', ' ', 'w', 'o', 'r', 'l', 'd'] ->>> parse p "--\n" +>>> parse @String p "--\n" Success Nil @since 0.1.0.0 @@ -538,14 +537,15 @@ ==== __Examples__ This can be useful for scanning comments: + >>> let comment = string "--" *> someUntil item endOfLine ->>> parse p "--hello world" +>>> parse @String p "--hello world" Failure .. ->>> parse p "--hello world\n" +>>> parse @String p "--hello world\n" Success ['h', 'e', 'l', 'l', 'o', ' ', 'w', 'o', 'r', 'l', 'd'] ->>> parse p "--\n" +>>> parse @String p "--\n" Failure .. ->>> parse p "--a\n" +>>> parse @String p "--a\n" Success ['a'] @since 0.1.0.0 @@ -646,11 +646,11 @@ ==== __Examples__ >>> let p = exactly 3 item ->>> parse p "ab" +>>> parse @String p "ab" Failure .. ->>> parse p "abc" +>>> parse @String p "abc" Success ['a', 'b', 'c'] ->>> parse p "abcd" +>>> parse @String p "abcd" Success ['a', 'b', 'c'] @since 0.1.0.0 @@ -669,15 +669,15 @@ ==== __Examples__ >>> let p = range 3 5 item ->>> parse p "ab" +>>> parse @String p "ab" Failure .. ->>> parse p "abc" +>>> parse @String p "abc" Success ['a', 'b', 'c'] ->>> parse p "abcd" +>>> parse @String p "abcd" Success ['a', 'b', 'c', 'd'] ->>> parse p "abcde" +>>> parse @String p "abcde" Success ['a', 'b', 'c', 'd', 'e'] ->>> parse p "abcdef" +>>> parse @String p "abcdef" Success ['a', 'b', 'c', 'd', 'e'] @since 0.1.0.0 @@ -703,15 +703,15 @@ ==== __Examples__ >>> let p = range_ 3 5 item ->>> parse p "ab" +>>> parse @String p "ab" Failure .. ->>> parse p "abc" +>>> parse @String p "abc" Success () ->>> parse p "abcd" +>>> parse @String p "abcd" Success () ->>> parse p "abcde" +>>> parse @String p "abcde" Success () ->>> parse p "abcdef" +>>> parse @String p "abcdef" Success () @since 0.1.0.0 @@ -739,15 +739,15 @@ ==== __Examples__ >>> let p = count 3 5 item ->>> parse p "ab" +>>> parse @String p "ab" Failure .. ->>> parse p "abc" +>>> parse @String p "abc" Success 3 ->>> parse p "abcd" +>>> parse @String p "abcd" Success 4 ->>> parse p "abcde" +>>> parse @String p "abcde" Success 5 ->>> parse p "abcdef" +>>> parse @String p "abcdef" Success 5 @since 0.1.0.0 diff --git a/src/Text/Gigaparsec/Errors/Combinator.hs b/src/Text/Gigaparsec/Errors/Combinator.hs --- a/src/Text/Gigaparsec/Errors/Combinator.hs +++ b/src/Text/Gigaparsec/Errors/Combinator.hs @@ -1,18 +1,354 @@ {-# LANGUAGE Safe #-} -module Text.Gigaparsec.Errors.Combinator (module Text.Gigaparsec.Errors.Combinator) where +{-# OPTIONS_GHC -Wno-missing-import-lists #-} +{-| +Module : Text.Gigaparsec.Errors.Combinator +Description : This module contains combinators that can be used to directly influence error + messages of parsers. +License : BSD-3-Clause +Maintainer : Jamie Willis, Gigaparsec Maintainers +Stability : stable +Error messages are, by default, not /particularly/ descriptive. However, the combinators in this +module can be used to improve the generation of error messages by providing labels for expected +items, explanations for why things went wrong, custom error messages, custom unexpected error messages, +as well as correcting the offsets that error messages actually occurred at. + +==== Terminology + +__Observably consumes input__: a parser is said to /observably/ consume input when error messages generated by a parser @p@ occur at a deeper +offset than @p@ originally started at. While this sounds like it is the same as "having consumed input" for the +purposes of backtracking, they are disjoint concepts: + + 1. in @atomic p@, @p@ can /observably/ consume input even though the wider parser does not consume input due to the @atomic@. + 2. in @amend p@, @p@ can consume input and may not backtrack even though the consumption is not /observable/ in the error + message due to the @amend@. + +@since 0.2.0.0 +-} +module Text.Gigaparsec.Errors.Combinator ( + -- * Error Enrichment Combinators + -- | These combinators add additional information - or refine the existing information within - to + -- an error message that has been generated within the scope of the parser they have been called on. + -- These are a very basic, but effective, way of improving the quality of error messages generated + -- by gigaparsec. + label, (), hide, explain, + -- * Failure Combinators + -- | These combinators immediately fail the parser, with a more bespoke message. + emptyWide, + fail, failWide, + unexpected, unexpectedWide, + -- * Error Adjustment Combinators + -- | These combinators can affect at what position an error is caused at. They are + -- opposites: where 'amend' will ensure an error message is said to have generated + -- at the position on entry to the combinator, 'entrench' will resist these changes. + amend, partialAmend, entrench, dislodge, dislodgeBy, + amendThenDislodge, amendThenDislodgeBy, partialAmendThenDislodge, partialAmendThenDislodgeBy, + markAsToken + ) where + +{- +Future doc headings: + +Filtering Combinators +===================== +These combinators perform filtering on a parser, with particular emphasis on generating meaningful +error messages if the filtering fails. This is particularly useful for data validation within the +parser, as very instructive error messages describing what went wrong can be generated. These combinators +often filter using a `PartialFunction`: this may be because they combine filtering with mapping (in which +case, the error message is provided separately), or the function may produce a `String`. + +In these cases, the partial function is producing the error messages: if the input to the function is +defined, this means that it is invalid and the filtering will fail using the message obtained from the +successful partial function invocation. + +Generic Filtering Combinators +============================= +This combinators generalise the combinators from above, which are all special cases of them. Each of these +takes the characteristic predicate or function of the regular variants, but takes an `errGen` object that +can be used to fine-tune the error messages. These offer some flexiblity not offered by the specialised +filtering combinators, but are a little more verbose to use. +-} + +import Prelude hiding (fail) + import Text.Gigaparsec (Parsec) -- We want to use this to make the docs point to the right definition for users. ---import Text.Gigaparsec.Internal qualified as Internal (Parsec(Parsec)) +import Text.Gigaparsec.Internal qualified as Internal (Parsec(Parsec), line, col, emptyErr, specialisedErr, raise, unexpectedErr, hints, consumed, useHints, adjustErr, hints, hintsValidOffset) +import Text.Gigaparsec.Internal.Errors (ParseError, CaretWidth(FlexibleCaret, RigidCaret), ExpectItem(ExpectNamed)) +import Text.Gigaparsec.Internal.Errors qualified as Internal (setLexical, amendErr, entrenchErr, dislodgeErr, partialAmendErr, labelErr, explainErr) import Text.Gigaparsec.Internal.Require (require) import Data.Set (Set) +import Data.Set qualified as Set (empty, map) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NonEmpty (toList) --- the empty set is weird here, do we require non-empty or just make it id? -label :: Set String -> Parsec a -> Parsec a -label ls = - require (not (any null ls)) "Text.Gigaparsec.Errors.Combinator.label" "labels cannot be empty" id --TODO: +{-| +This combinator changes the expected component of any errors generated by this parser. +When this parser fails having not /observably/ consumed input, the expected component of the generated +error message is set to be the given items. +-} +label :: Set String -- ^ the names to give to the expected component of any qualifying errors. + -> Parsec a -- ^ the parser to apply the labels to + -> Parsec a +label ls (Internal.Parsec p) = + require (not (null ls) && not (any null ls)) "Text.Gigaparsec.Errors.Combinator.label" + "labels cannot be empty" $ + Internal.Parsec $ \st good bad -> + let !origConsumed = Internal.consumed st + good' x st' + | Internal.consumed st' /= origConsumed = good x st' + | otherwise = good x st' { Internal.hints = Set.map ExpectNamed ls } + bad' err = Internal.useHints bad (Internal.labelErr origConsumed ls err) + in p st good' bad' + +{-| +This combinator suppresses the entire error message generated by a given parser. + +When this parser fails having not /observably/ consumed input, this combinator +replaces any error generated by the given parser to match the 'Text.Gigaparsec.empty' combinator. + +This can be useful, say, for hiding whitespace labels, which are not normally useful +information to include in an error message for whitespace insensitive grammars. +-} +hide :: Parsec a -> Parsec a +hide (Internal.Parsec p) = + Internal.Parsec $ \st good bad -> + let !origConsumed = Internal.consumed st + good' x st' = good x st' { Internal.hints = Set.empty } + bad' err st' + | Internal.consumed st' /= origConsumed = bad err st' + | otherwise = Internal.useHints bad (Internal.emptyErr st' 0) st' + in p st good' bad' + +{-| +This combinator adds a reason to error messages generated by this parser. + +When this parser fails having not /observably/ consumed input, this combinator adds +a reason to the error message, which should justify why the error occured. Unlike error +labels, which may persist if more progress is made having not consumed input, reasons +are not carried forward in the error message, and are lost. +-} +explain :: String -- ^ reason the reason why a parser failed. + -> Parsec a -- ^ the parser to apply the reason to + -> Parsec a +explain reason (Internal.Parsec p) = + Internal.Parsec $ \st good bad -> + let !origConsumed = Internal.consumed st + bad' err = Internal.useHints bad (Internal.explainErr origConsumed reason err) + in p st good bad' + +{-| +This combinator fails immediately, with a caret of the given width and no other information. + +By producing basically no information, this combinator is principally for adjusting the +caret-width of another error, rather than the value 'Text.Gigaparsec.empty', which is used to fail with +no effect on error content. +-} +emptyWide :: Word -- ^ the width of the caret for the error produced by this combinator. + -> Parsec a +emptyWide width = Internal.raise (`Internal.emptyErr` width) + +{-| +This combinator consumes no input and fails immediately with the given error messages. + +Produces a /specialised/ error message where all the lines of the error are the +given @msgs@ in order of appearance. + +==== __Examples__ +>>> let failing = fail ["hello,", "this is an error message", "broken across multiple lines"] + +-} +fail :: NonEmpty String -- ^ the messages that will make up the error message. + -> Parsec a +fail = _fail (FlexibleCaret 1) + +{-| +This combinator consumes no input and fails immediately with the given error messages. + +Produces a /specialised/ error message where all the lines of the error are the +given @msgs@ in order of appearance. The caret width of the message is set to the +given value. + +==== __Examples__ +>>> let failing = fail 3 ["hello,", "this is an error message", "broken across multiple lines"] + +-} +failWide :: Word -- ^ the width of the caret for the error produced by this combinator. + -> NonEmpty String -- ^ the messages that will make up the error message. + -> Parsec a +failWide width = _fail (RigidCaret width) + +{-# INLINE _fail #-} +_fail :: CaretWidth -> NonEmpty String -> Parsec a +_fail width msgs = Internal.raise (\st -> Internal.specialisedErr st (NonEmpty.toList msgs) width) + +{-| +This combinator consumes no input and fails immediately, setting the unexpected component +to the given item. + +Produces a /trivial/ error message where the unexpected component of the error is +replaced with the given item. +-} +unexpected :: String -- ^ the unexpected message for the error generated. + -> Parsec a +unexpected = _unexpected (FlexibleCaret 1) + +{-| +This combinator consumes no input and fails immediately, setting the unexpected component +to the given item. + +Produces a /trivial/ error message where the unexpected component of the error is +replaced with the given item. The caret width of the message is set to the +given value. +-} +unexpectedWide :: Word -- ^ the width of the caret for the error produced by this combinator. + -> String -- ^ the unexpected message for the error generated. + -> Parsec a +unexpectedWide width = _unexpected (RigidCaret width) + +{-# INLINE _unexpected #-} +_unexpected :: CaretWidth -> String -> Parsec a +_unexpected width name = Internal.raise $ \st -> Internal.unexpectedErr st Set.empty name width + +{-| +This combinator adjusts any error messages generated by the given parser so that they +occur at the position recorded on entry to this combinator (effectively as if no +input were consumed). + +This is useful if validation work is done +on the output of a parser that may render it invalid, but the error should point to the +beginning of the structure. This combinators effect can be cancelled with [[entrench `entrench`]]. + +==== __Examples__ +>>> let greeting = string "hello world" <* char '!' +>>> parseRepl (greeting ["greeting"]) "hello world." +(line 1, column 12): + unexpected "." + expected "!" + >hello world. + ^ +>>> parseRepl (amend greeting ["greeting"]) "hello world." +(line 1, column 1): + unexpected "h" + expected greeting + >hello world. + ^ +-} +amend :: Parsec a -> Parsec a +amend = _amend Internal.amendErr + +--TODO: examples +{-| +This combinator adjusts any error messages generated by the given parser so that they +occur at the position recorded on entry to this combinator, but retains the original offset. + +Similar to 'amend', but retains the original offset the error occurred at. This is known +as its /underlying offset/ as opposed to the visual /presentation offset/. To the reader, the +error messages appears as if no input was consumed, but for the purposes of error message merging +the error is still deeper. A key thing to note is that two errors can only merge if they are at +the same presentation /and/ underlying offsets: if they are not the deeper of the two /dominates/. + +The ability for an error to still dominate others after partial amendment can be useful for allowing +it to avoid being lost when merging with errors that are deeper than the presentation offset but +shallower than the underlying. +-} +partialAmend :: Parsec a -> Parsec a +partialAmend = _amend Internal.partialAmendErr + +{-# INLINE _amend #-} +_amend :: (Word -> Word -> Word -> ParseError -> ParseError) -> Parsec a -> Parsec a +_amend f (Internal.Parsec p) = + Internal.Parsec $ \st good bad -> + let !origConsumed = Internal.consumed st + !origLine = Internal.line st + !origCol = Internal.col st + !origHints = Internal.hints st + !origHintsValidOffset = Internal.hintsValidOffset st + in p st good $ \err st' -> bad (f origConsumed origLine origCol err) + st' { Internal.hints = origHints + , Internal.hintsValidOffset = origHintsValidOffset } + +--TODO: examples +{-| +This combinator prevents the action of any enclosing 'amend' on the errors generated by the given +parser. + +Sometimes, the error adjustments performed by 'amend' should only affect errors generated +within a certain part of a parser and not the whole thing; in this case, 'entrench' can be used +to protect sub-parsers from having their errors adjusted, providing a much more fine-grained +scope for error adjustment. +-} +entrench :: Parsec a -> Parsec a +entrench = Internal.adjustErr Internal.entrenchErr + +{-| +This combinator undoes the action of any 'entrench' combinators on the given parser. + +Entrenchment is important for preventing the incorrect amendment of certain parts of sub-errors +for a parser, but it may be then undesireable to block further amendments from elsewhere in the +parser. This combinator can be used to cancel all entrenchment after the critical section has +passed. +-} +dislodge :: Parsec a -> Parsec a +dislodge = dislodgeBy maxBound + +{-| +This combinator undoes the action of the given number of 'entrench' combinators on the given parser. + +Entrenchment is important for preventing the incorrect amendment of certain parts of sub-errors +for a parser, but it may be then undesireable to block further amendments from elsewhere in the +parser. This combinator can be used to cancel all entrenchment after the critical section has +passed. +-} +dislodgeBy :: Word -> Parsec a -> Parsec a +dislodgeBy by = Internal.adjustErr (Internal.dislodgeErr by) + +{-| +This combinator first tries to amend the position of any error generated by the given parser, +and if the error was entrenched will dislodge it instead. +-} +amendThenDislodge :: Parsec a -> Parsec a +amendThenDislodge = dislodge . amend + +{-| +This combinator first tries to amend the position of any error generated by the given parser, +and if the error was entrenched will dislodge it the given number of times instead. +-} +amendThenDislodgeBy :: Word -> Parsec a -> Parsec a +amendThenDislodgeBy n = dislodgeBy n . amend + +{-| +This combinator first tries to partially amend the position of any error generated by the given parser, +and if the error was entrenched will dislodge it instead. +-} +partialAmendThenDislodge :: Parsec a -> Parsec a +partialAmendThenDislodge = dislodge . partialAmend + +{-| +This combinator first tries to partially amend the position of any error generated by the given parser, +and if the error was entrenched will dislodge it the given number of times instead. +-} +partialAmendThenDislodgeBy :: Word -> Parsec a -> Parsec a +partialAmendThenDislodgeBy n = dislodgeBy n . partialAmend + +{-| +This combinator marks any errors within the given parser as being /lexical errors/. + +When an error is marked as a /lexical error/, it sets a flag within the error that is +passed to 'Text.Gigaparsec.Errors.ErrorBuilder.unexpectedToken': this +should be used to prevent @Lexer@-based token extraction from being performed on an error, +since lexing errors cannot be the result of unexpected tokens. +-} +markAsToken :: Parsec a -> Parsec a +markAsToken = Internal.adjustErr Internal.setLexical + +{-| +This combinator changes the expected component of any errors generated by this parser. + +This is just an alias for the 'label' combinator. +-} {-# INLINE () #-} infix 0 () :: Parsec a -> Set String -> Parsec a diff --git a/src/Text/Gigaparsec/Errors/DefaultErrorBuilder.hs b/src/Text/Gigaparsec/Errors/DefaultErrorBuilder.hs new file mode 100644 --- /dev/null +++ b/src/Text/Gigaparsec/Errors/DefaultErrorBuilder.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE DerivingVia, OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} +module Text.Gigaparsec.Errors.DefaultErrorBuilder (module Text.Gigaparsec.Errors.DefaultErrorBuilder) where + +import Prelude hiding (lines) + +import Data.Monoid (Endo(Endo)) +import Data.String (IsString(fromString)) +import Data.List (intersperse, sortBy) +import Data.Maybe (mapMaybe) +import Data.Foldable (toList) +import Data.Ord (comparing, Down (Down)) + +-- For now, this is the home of the default formatting functions + +type StringBuilder :: * +newtype StringBuilder = StringBuilder (String -> String) + deriving (Semigroup, Monoid) via Endo String + +instance IsString StringBuilder where + {-# INLINE fromString #-} + fromString :: String -> StringBuilder + fromString str = StringBuilder (str ++) + +{-# INLINE toString #-} +toString :: StringBuilder -> String +toString (StringBuilder build) = build mempty + +{-# INLINE from #-} +from :: Show a => a -> StringBuilder +from = StringBuilder . shows + +{-# INLINABLE formatDefault #-} +formatDefault :: StringBuilder -> Maybe StringBuilder -> [StringBuilder] -> String +formatDefault pos source lines = toString (blockError header lines 2) + where header = maybe mempty (\src -> "In " <> src <> " ") source <> pos + +{-# INLINABLE vanillaErrorDefault #-} +vanillaErrorDefault :: Foldable t => Maybe StringBuilder -> Maybe StringBuilder -> t StringBuilder -> [StringBuilder] -> [StringBuilder] +vanillaErrorDefault unexpected expected reasons = + combineInfoWithLines (maybe id (:) unexpected (maybe id (:) expected (toList reasons))) + +{-# INLINABLE specialisedErrorDefault #-} +specialisedErrorDefault :: [StringBuilder] -> [StringBuilder] -> [StringBuilder] +specialisedErrorDefault = combineInfoWithLines + +{-# INLINABLE combineInfoWithLines #-} +combineInfoWithLines :: [StringBuilder] -> [StringBuilder] -> [StringBuilder] +combineInfoWithLines [] lines = "unknown parse error" : lines +combineInfoWithLines info lines = info ++ lines + +--TODO: this needs to deal with whitespace and unprintables +{-# INLINABLE rawDefault #-} +rawDefault :: String -> String +rawDefault n = "\"" <> n <> "\"" + +{-# INLINABLE namedDefault #-} +namedDefault :: String -> String +namedDefault = id + +{-# INLINABLE endOfInputDefault #-} +endOfInputDefault :: String +endOfInputDefault = "end of input" + +{-# INLINABLE messageDefault #-} +messageDefault :: String -> String +messageDefault = id + +{-# INLINABLE expectedDefault #-} +expectedDefault :: Maybe StringBuilder -> Maybe StringBuilder +expectedDefault = fmap ("expected " <>) + +{-# INLINABLE unexpectedDefault #-} +unexpectedDefault :: Maybe String -> Maybe StringBuilder +unexpectedDefault = fmap (("unexpected " <>) . fromString) + +{-# INLINABLE disjunct #-} +disjunct :: Bool -> [String] -> Maybe StringBuilder +disjunct oxford elems = junct oxford elems "or" + +{-# INLINABLE junct #-} +junct :: Bool -> [String] -> String -> Maybe StringBuilder +junct oxford elems junction = junct' (sortBy (comparing Down) elems) + where + j :: StringBuilder + j = fromString junction + + junct' [] = Nothing + junct' [alt] = Just (fromString alt) + junct' [alt1, alt2] = Just (fromString alt2 <> " " <> fromString junction <> " " <> fromString alt1) + junct' as@(alt:alts) + -- use a semi-colon here, it is more correct + | any (elem ',') as = Just (junct'' (reverse alts) alt "; ") + | otherwise = Just (junct'' (reverse alts) alt ", ") + + junct'' is l delim = front <> back + where front = intercalate (fromString delim) (map fromString is) :: StringBuilder + back + | oxford = fromString delim <> j <> " " <> fromString l + | otherwise = " " <> j <> " " <> fromString l + +{-# INLINABLE combineMessagesDefault #-} +combineMessagesDefault :: Foldable t => t String -> [StringBuilder] +combineMessagesDefault = mapMaybe (\msg -> if null msg then Nothing else Just (fromString msg)) . toList + +{-# INLINABLE blockError #-} +blockError :: StringBuilder -> [StringBuilder] -> Int -> StringBuilder +blockError header lines indent = header <> ":\n" <> indentAndUnlines lines indent + +{-# INLINABLE indentAndUnlines #-} +indentAndUnlines :: [StringBuilder] -> Int -> StringBuilder +indentAndUnlines lines indent = fromString pre <> intercalate (fromString ('\n' : pre)) lines + where pre = replicate indent ' ' + +{-# INLINABLE lineInfoDefault #-} +lineInfoDefault :: String -> [String] -> [String] -> Word -> Word -> [StringBuilder] +lineInfoDefault curLine beforeLines afterLines pointsAt width = + concat [map inputLine beforeLines, [inputLine curLine, caretLine], map inputLine afterLines] + where inputLine :: String -> StringBuilder + inputLine = fromString . ('>' :) + caretLine :: StringBuilder + caretLine = fromString (replicate (fromIntegral (pointsAt + 1)) ' ') <> fromString (replicate (fromIntegral width) '^') + +{-# INLINABLE formatPosDefault #-} +formatPosDefault :: Word -> Word -> StringBuilder +formatPosDefault line col = "(line " + <> from line + <> ", column " + <> from col + <> ")" + +{-# INLINABLE intercalate #-} +intercalate :: Monoid m => m -> [m] -> m +intercalate x xs = mconcat (intersperse x xs) diff --git a/src/Text/Gigaparsec/Errors/ErrorBuilder.hs b/src/Text/Gigaparsec/Errors/ErrorBuilder.hs new file mode 100644 --- /dev/null +++ b/src/Text/Gigaparsec/Errors/ErrorBuilder.hs @@ -0,0 +1,379 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE TypeFamilies, AllowAmbiguousTypes, FlexibleInstances, FlexibleContexts #-} +{-| +Module : Text.Gigaparsec.Errors.ErrorBuilder +Description : This typeclass specifies how to format an error from a parser as a specified type. +License : BSD-3-Clause +Maintainer : Jamie Willis, Gigaparsec Maintainers +Stability : stable + +This typeclass specifies how to format an error from a parser +as a specified type. + +An instance of this typeclass is required when calling 'Text.Gigaparsec.parse' +(or similar). By default, @gigaparsec@ defines its own instance for +@ErrorBuilder String@ found in this module. + +To implement @ErrorBuilder@, a number of methods must be defined, +as well the representation types for a variety of different components; +the relation between the various methods is closely linked +to the types that they both produce and consume. To only change +the basics of formatting without having to define the entire instance, +use the methods found in "Text.Gigaparsec.Errors.DefaultErrorBuilder". + += How an Error is Structured +There are two kinds of error messages that are generated by @gigaparsec@: +/Specialised/ and /Vanilla/. These are produced by different combinators +and can be merged with other errors of the same type if both errors appear +at the same offset. However, /Specialised/ errors will take precedence +over /Vanilla/ errors if they appear at the same offset. The most +common form of error is the /Vanilla/ variant, which is generated by +most combinators, except for some in "Text.Gigaparsec.Errors.Combinator". + +Both types of error share some common structure, namely: + + - The error preamble, which has the file and the position. + - The content lines, the specifics of which differ between the two types of error. + - The context lines, which has the surrounding lines of input for contextualisation. + +== /Vanilla/ Errors +There are three kinds of content line found in a /Vanilla/ error: + + 1. Unexpected info: this contains information about the kind of token that caused the error. + 2. Expected info: this contains the information about what kinds of token could have avoided the error. + 3. Reasons: these are the bespoke reasons that an error has occurred (as generated by 'Text.Gigaparsec.Errors.Combinator.explain'). + +There can be at most one unexpected line, at most one expected line, and zero or more reasons. +Both of the unexpected and expected info are built up of /error items/, which are either: +the end of input, a named token, raw input taken from the parser definition. These can all be +formatted separately. + +The overall structure of a /Vanilla/ error is given in the following diagram: + +> ┌───────────────────────────────────────────────────────────────────────┐ +> │ Vanilla Error │ +> │ ┌────────────────┐◄──────── position │ +> │ source │ │ │ +> │ │ │ line col│ │ +> │ ▼ │ │ ││ │ +> │ ┌─────┐ │ ▼ ▼│ end of input │ +> │ In foo.txt (line 1, column 5): │ │ +> │ ┌─────────────────────┐ │ │ +> │unexpected ─────►│ │ │ ┌───── expected │ +> │ │ ┌──────────┐ ◄──────────┘ │ │ +> │ unexpected end of input ▼ │ +> │ ┌──────────────────────────────────────┐ │ +> │ expected "(", "negate", digit, or letter │ +> │ │ └──────┘ └───┘ └────┘ ◄────── named│ +> │ │ ▲ └──────────┘ │ │ +> │ │ │ │ │ +> │ │ raw │ │ +> │ └─────────────────┬───────────┘ │ +> │ '-' is a binary operator │ │ +> │ └──────────────────────┘ │ │ +> │ ┌──────┐ ▲ │ │ +> │ │>3+4- │ │ expected items │ +> │ │ ^│ │ │ +> │ └──────┘ └───────────────── reason │ +> │ ▲ │ +> │ │ │ +> │ line info │ +> └───────────────────────────────────────────────────────────────────────┘ + + +== /Specialised/ Errors +There is only one kind of content found in a /Specialised/ error: +a message. These are completely free-form, and are generated by the +'Text.Gigaparsec.Errors.Combinator.failWide' combinator, as well as its derived combinators. +There can be one or more messages in a /Specialised/ error. + +The overall structure of a /Specialised/ error is given in the following diagram: + +> ┌───────────────────────────────────────────────────────────────────────┐ +> │ Specialised Error │ +> │ ┌────────────────┐◄──────── position │ +> │ source │ │ │ +> │ │ │ line col │ +> │ ▼ │ │ │ │ +> │ ┌─────┐ │ ▼ ▼ │ +> │ In foo.txt (line 1, column 5): │ +> │ │ +> │ ┌───► something went wrong │ +> │ │ │ +> │ message ──┼───► it looks like a binary operator has no argument │ +> │ │ │ +> │ └───► '-' is a binary operator │ +> │ ┌──────┐ │ +> │ │>3+4- │ │ +> │ │ ^│ │ +> │ └──────┘ │ +> │ ▲ │ +> │ │ │ +> │ line info │ +> └───────────────────────────────────────────────────────────────────────┘ + +@since 0.2.0.0 +-} +module Text.Gigaparsec.Errors.ErrorBuilder (ErrorBuilder(..), Token(..)) where + +import Text.Gigaparsec.Errors.DefaultErrorBuilder ( StringBuilder, formatDefault + , vanillaErrorDefault, specialisedErrorDefault + , rawDefault, namedDefault, endOfInputDefault + , expectedDefault, unexpectedDefault + , disjunct, combineMessagesDefault + , formatPosDefault, lineInfoDefault + ) + +import Data.Char (isSpace, generalCategory, ord, GeneralCategory(Format, Surrogate, PrivateUse, NotAssigned, Control)) +import Data.Kind (Constraint) +import Data.List.NonEmpty (NonEmpty((:|))) +import Data.Set (Set) +import Data.Set qualified as Set (toList) +import Data.String (IsString(fromString)) +import Numeric (showHex) + +{-| +This class describes how to format an error message generated by a parser into +a form the parser writer desires. +-} +type ErrorBuilder :: * -> Constraint +class (Ord (Item err)) => ErrorBuilder err where + {-| + This is the top level function, which finally compiles all the formatted + sub-parts into a finished value of type @err@. + -} + format :: Position err -- ^ the representation of the position of the error in the input (see the 'pos' method). + -> Source err -- ^ the representation of the filename, if it exists (see the 'source' method). + -> ErrorInfoLines err -- ^ the main body of the error message (see 'vanillaError' or 'specialisedError' methods). + -> err -- ^ the final error message + + -- | The representation type of position information within the generated message. + type Position err + -- | The representation of the file information. + type Source err + {-| + Formats a position into the representation type given by 'Position'. + -} + pos :: Word -- ^ the line the error occurred at. + -> Word -- ^ the column the error occurred at. + -> Position err -- ^ a representation of the position. + {-| + Formats the name of the file parsed from, if it exists, into the type given by 'Source'. + -} + source :: Maybe FilePath -- ^ the source name of the file, if any. + -> Source err + + -- | The representation type of the main body within the error message. + type ErrorInfoLines err + {-| + Vanilla errors are those produced such that they have information about + both @expected@ and @unexpected@ tokens. These are usually the default, + and are not produced by @fail@ (or any derivative) combinators. + -} + vanillaError :: UnexpectedLine err -- ^ information about which token(s) caused the error (see the 'unexpected' method). + -> ExpectedLine err -- ^ information about which token(s) would have avoided the error (see the 'expected' method). + -> Messages err -- ^ additional information about why the error occured (see the 'combineMessages' method). + -> LineInfo err -- ^ representation of the line of input that this error occured on (see the 'lineInfo' method). + -> ErrorInfoLines err + {-| + Specialised errors are triggered by @fail@ and any combinators that are + implemented in terms of @fail@. These errors take precedence over + the vanilla errors, and contain less, more specialised, information. + -} + specialisedError :: Messages err -- ^ information detailing the error (see the 'combineMessages' method). + -> LineInfo err -- ^ representation of the line of input that this error occured on (see the 'lineInfo' method). + -> ErrorInfoLines err + + -- | The representation of all the different possible tokens that could have prevented an error. + type ExpectedItems err + -- | The representation of the combined reasons or failure messages from the parser. + type Messages err + + {-| + Details how to combine the various expected items into a single representation. + -} + combineExpectedItems :: Set (Item err) -- ^ the possible items that fix the error. + -> ExpectedItems err + {-| + Details how to combine any reasons or messages generated within a + single error. Reasons are used by @vanilla@ messages and messages + are used by @specialised@ messages. + -} + combineMessages :: [Message err] -- ^ the messages to combine (see the 'message' or 'reason' methods). + -> Messages err + + -- | The representation of the information regarding the problematic token. + type UnexpectedLine err + -- | The representation of the information regarding the solving tokens. + type ExpectedLine err + -- | The representation of a reason or a message generated by the parser. + type Message err + -- | The representation of the line of input where the error occurred. + type LineInfo err + + {-| + Describes how to handle the (potentially missing) information + about what token(s) caused the error. + -} + unexpected :: Maybe (Item err) -- ^ the @Item@ that caused this error. + -> UnexpectedLine err + {-| + Describes how to handle the information about the tokens that + could have avoided the error. + -} + expected :: ExpectedItems err -- ^ the tokens that could have prevented the error (see 'combineExpectedItems'). + -> ExpectedLine err + {-| + Describes how to represent the reasons behind a parser fail. + These reasons originate from the 'Text.Gigaparsec.Errors.Combinator.explain' combinator. + -} + reason :: String -- ^ the reason produced by the parser. + -> Message err + {-| + Describes how to represent the messages produced by the + 'Text.Gigaparsec.Errors.Combinator.fail' combinator (or any that are implemented using it). + -} + message :: String -- ^ the message produced by the parser. + -> Message err + + {-| + Describes how to format the information about the line that the error occured on, + and its surrounding context. + -} + lineInfo :: String -- ^ the full line of input that produced this error message. + -> [String] -- ^ the lines of input from just before the one that produced this message (up to 'numLinesBefore'). + -> [String] -- ^ the lines of input from just after the one that produced this message (up to 'numLinesAfter'). + -> Word -- ^ the offset into the line that the error points at. + -> Word -- ^ how wide the caret in the message should be. + -> LineInfo err + + -- | The number of lines of input to request before an error occured. + numLinesBefore :: Int + -- | The number of lines of input to request after an error occured. + numLinesAfter :: Int + + -- | The type that represents the individual items within the error. It must be + -- orderable, as it is used within @Set@. + type Item err + + {-| + Formats a raw item generated by either the input string or a input + reading combinator without a label. + -} + raw :: String -- ^ the raw, unprocessed input. + -> Item err + -- | Formats a named item generated by a label. + named :: String -- ^ the name given to the label. + -> Item err + -- | Value that represents the end of the input in the error message. + endOfInput :: Item err + + {-| + Extracts an unexpected token from the remaining input. + + When a parser fails, by default an error reports an unexpected token of a specific width. + This works well for some parsers, but often it is nice to have the illusion of a dedicated + lexing pass: instead of reporting the next few characters as unexpected, an unexpected token + can be reported instead. This can take many forms, for instance trimming the token to the + next whitespace, only taking one character, or even trying to lex a token out of the stream. + + TODO: talk about the token extractors when they are added. + -} + unexpectedToken :: NonEmpty Char -- ^ the remaining input, @cs@, at point of failure. + -> Word -- ^ the input the parser tried to read when it failed + -- (this is __not__ guaranteed to be smaller than the length of + -- @cs@, but is __guaranteed to be greater than 0__). + -> Bool -- ^ was this error generated as part of \"lexing\", or in a wider parser (see 'Text.Gigaparsec.Errors.Combinator.markAsToken'). + -> Token -- ^ a token extracted from @cs@ that will be used as part of the unexpected message. + +{-| +This type represents an extracted token returned by 'unexpectedToken' in 'ErrorBuilder'. + +There is deliberately no analogue for @EndOfInput@ because we guarantee that non-empty +residual input is provided to token extraction. +-} +type Token :: * +data Token = Raw -- ^ This is a token that is directly extracted from the residual input itself. + !String -- ^ the input extracted. + | Named -- ^ This is a token that has been given a name, and is treated like a labelled item. + !String -- ^ the description of the token. + {-# UNPACK #-} !Word -- ^ the amount of residual input this token ate. + +{-| +Formats error messages as a string, using the functions found in +"Text.Gigaparsec.Errors.DefaultErrorBuilder". +-} +instance ErrorBuilder String where + {-# INLINE format #-} + format = formatDefault + + type Position String = StringBuilder + type Source String = Maybe StringBuilder + + {-# INLINE pos #-} + pos = formatPosDefault + {-# INLINE source #-} + source = fmap fromString + + type ErrorInfoLines String = [StringBuilder] + {-# INLINE vanillaError #-} + vanillaError = vanillaErrorDefault + {-# INLINE specialisedError #-} + specialisedError = specialisedErrorDefault + + type ExpectedItems String = Maybe StringBuilder + type Messages String = [StringBuilder] + + {-# INLINE combineExpectedItems #-} + combineExpectedItems = disjunct True . Set.toList + {-# INLINE combineMessages #-} + combineMessages = combineMessagesDefault + + type UnexpectedLine String = Maybe StringBuilder + type ExpectedLine String = Maybe StringBuilder + type Message String = String + type LineInfo String = [StringBuilder] + + {-# INLINE unexpected #-} + unexpected = unexpectedDefault + {-# INLINE expected #-} + expected = expectedDefault + {-# INLINE reason #-} + reason = id + {-# INLINE message #-} + message = id + + {-# INLINE lineInfo #-} + lineInfo = lineInfoDefault + + {-# INLINE numLinesBefore #-} + numLinesBefore = 1 + {-# INLINE numLinesAfter #-} + numLinesAfter = 1 + + type Item String = String + + {-# INLINE raw #-} + raw = rawDefault + {-# INLINE named #-} + named = namedDefault + {-# INLINE endOfInput #-} + endOfInput = endOfInputDefault + + {-# INLINABLE unexpectedToken #-} + -- TillNextWhitespace with matches parser demand + unexpectedToken ('\n' :| _) _ _ = Named "newline" 1 + unexpectedToken ('\r' :| _) _ _ = Named "carriage return" 1 + unexpectedToken ('\t' :| _) _ _ = Named "tab" 1 + unexpectedToken (' ' :| _) _ _ = Named "space" 1 + unexpectedToken (c :| cs) parserDemanded _ + | isSpace c = Named "whitespace character" 1 + | otherwise = case generalCategory c of + Format -> unprintable + Surrogate -> unprintable + PrivateUse -> unprintable + NotAssigned -> unprintable + Control -> unprintable + _ -> Raw (take (fromIntegral parserDemanded) (tillNextWhitespace (c:cs))) + where unprintable = Named ("non-printable character (\\x" ++ showHex (ord c) ")") 1 + tillNextWhitespace = takeWhile (not . isSpace) diff --git a/src/Text/Gigaparsec/Internal.hs b/src/Text/Gigaparsec/Internal.hs --- a/src/Text/Gigaparsec/Internal.hs +++ b/src/Text/Gigaparsec/Internal.hs @@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE DeriveFunctor, StandaloneDeriving #-} +{-# LANGUAGE DeriveFunctor, StandaloneDeriving, RecordWildCards, NamedFieldPuns, CPP #-} +#include "portable-unlifted.h" {-# OPTIONS_HADDOCK hide #-} {-| Module : Text.Gigaparsec.Internal @@ -17,10 +18,20 @@ module Text.Gigaparsec.Internal (module Text.Gigaparsec.Internal) where import Text.Gigaparsec.Internal.RT (RT) +import Text.Gigaparsec.Internal.Errors (ParseError, ExpectItem, CaretWidth) +import Text.Gigaparsec.Internal.Errors qualified as Errors ( + emptyErr, expectedErr, specialisedErr, mergeErr, unexpectedErr, + expecteds, isExpectedEmpty, presentationOffset, useHints + ) import Control.Applicative (Applicative(liftA2), Alternative(empty, (<|>), many, some)) -- liftA2 required until 9.6 import Control.Selective (Selective(select)) +import Data.Set (Set) +import Data.Set qualified as Set (empty, union) + +CPP_import_PortableUnlifted + {- Notes: @@ -38,7 +49,7 @@ newtype Parsec a = Parsec { unParsec :: forall r. State -> (a -> State -> RT r) -- the good continuation - -> (State -> RT r) -- the bad continuation + -> (ParseError -> State -> RT r) -- the bad continuation -> RT r } @@ -106,21 +117,23 @@ {-# INLINE return #-} {-# INLINE (>>=) #-} +raise :: (State -> ParseError) -> Parsec a +raise mkErr = Parsec $ \st _ bad -> useHints bad (mkErr st) st + instance Alternative Parsec where empty :: Parsec a - empty = Parsec $ \st _ err -> err st + empty = raise (`emptyErr` 0) + -- FIXME: I feel like there is something missing here with hint merging from ctx.mergeHints + -- if the hint stack is not real then it lives in the continuation trace, but I don't know... which (<|>) :: Parsec a -> Parsec a -> Parsec a - Parsec p <|> Parsec q = Parsec $ \st ok err -> - let !initConsumed = consumed st - ok' x st' = ok x (st' { consumed = initConsumed || consumed st' }) - -- ^ revert to old st.consumed if p didn't consume - err' st' - | consumed st' = err st' + Parsec p <|> Parsec q = Parsec $ \st ok bad -> + let bad' err st' + | consumed st' > consumed st = bad err st' -- ^ fail if p failed *and* consumed - | otherwise = q (st' { consumed = initConsumed }) ok err - - in p (st { consumed = False }) ok' err' + | otherwise = q st' (\x st'' -> ok x (errorToHints st'' err)) + (\err' -> bad (Errors.mergeErr err err')) + in p st ok bad' many :: Parsec a -> Parsec [a] many = manyr (:) [] @@ -153,21 +166,56 @@ {-# INLINE mempty #-} -type State :: * +type State :: UnliftedDatatype data State = State { -- | the input string, in future this may be generalised input :: !String, -- | has the parser consumed input since the last relevant handler? - consumed :: !Bool, -- this could be an Int offset instead, perhaps? + consumed :: {-# UNPACK #-} !Word, -- | the current line number (incremented by \n) - line :: {-# UNPACK #-} !Int, + line :: {-# UNPACK #-} !Word, -- | the current column number (have to settle on a tab handling scheme) - col :: {-# UNPACK #-} !Int + col :: {-# UNPACK #-} !Word, + -- | the valid for which hints can be used + hintsValidOffset :: {-# UNPACK #-} !Word, + -- | the hints at this point in time + hints :: !(Set ExpectItem) } emptyState :: String -> State emptyState !str = State { input = str - , consumed = False + , consumed = 0 , line = 1 , col = 1 + , hintsValidOffset = 0 + , hints = Set.empty } + +emptyErr :: State -> Word -> ParseError +emptyErr State{..} = Errors.emptyErr consumed line col + +expectedErr :: State -> Set ExpectItem -> Word -> ParseError +expectedErr State{..} = Errors.expectedErr input consumed line col + +specialisedErr :: State -> [String] -> CaretWidth -> ParseError +specialisedErr State{..} = Errors.specialisedErr consumed line col + +unexpectedErr :: State -> Set ExpectItem -> String -> CaretWidth -> ParseError +unexpectedErr State{..} = Errors.unexpectedErr consumed line col + +errorToHints :: State -> ParseError -> State +errorToHints st@State{..} err + | consumed == Errors.presentationOffset err + , not (Errors.isExpectedEmpty err) = + if hintsValidOffset < consumed then st { hints = Errors.expecteds err, hintsValidOffset = consumed } + else st { hints = Set.union hints (Errors.expecteds err) } +errorToHints st _ = st + +useHints :: (ParseError -> State -> RT r) -> (ParseError -> State -> RT r) +useHints bad err st@State{hintsValidOffset, hints} + | presentationOffset == hintsValidOffset = bad (Errors.useHints hints err) st + | otherwise = bad err st{ hintsValidOffset = presentationOffset, hints = Set.empty } + where !presentationOffset = Errors.presentationOffset err + +adjustErr :: (ParseError -> ParseError) -> Parsec a -> Parsec a +adjustErr f (Parsec p) = Parsec $ \st good bad -> p st good $ \err -> bad (f err) diff --git a/src/Text/Gigaparsec/Internal/Errors.hs b/src/Text/Gigaparsec/Internal/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Text/Gigaparsec/Internal/Errors.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE RecordWildCards, BangPatterns, NamedFieldPuns, CPP #-} +#include "portable-unlifted.h" +{-# OPTIONS_GHC -Wno-partial-fields -Wno-all-missed-specialisations #-} +{-# OPTIONS_HADDOCK hide #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} +module Text.Gigaparsec.Internal.Errors (module Text.Gigaparsec.Internal.Errors) where + +import Prelude hiding (lines) + +import Data.List.NonEmpty (NonEmpty((:|)), nonEmpty, (<|)) +import Data.Set (Set) +import Data.Set qualified as Set (empty, map, union, null, foldr, insert) + +import Text.Gigaparsec.Errors.ErrorBuilder (ErrorBuilder, Token) +import Text.Gigaparsec.Errors.ErrorBuilder qualified as Builder (ErrorBuilder(..)) +import Text.Gigaparsec.Errors.ErrorBuilder qualified as Token (Token(..)) + +CPP_import_PortableUnlifted + +type Span :: * +type Span = Word + +type CaretWidth :: UnliftedDatatype +data CaretWidth = FlexibleCaret { width :: {-# UNPACK #-} !Span } + | RigidCaret { width :: {-# UNPACK #-} !Span } + +isFlexible :: CaretWidth -> Bool +isFlexible FlexibleCaret{} = True +isFlexible _ = False + +type ParseError :: UnliftedDatatype +data ParseError = VanillaError { presentationOffset :: {-# UNPACK #-} !Word + , line :: {-# UNPACK #-} !Word + , col :: {-# UNPACK #-} !Word + , unexpected :: !(Either Word UnexpectItem) -- TODO: unlift this! + -- sadly, this prevents unlifting of ExpectItem + -- perhaps we should make an unlifted+levity polymorphic Set? + , expecteds :: !(Set ExpectItem) + , reasons :: !(Set String) + , lexicalError :: !Bool -- TODO: strict bools + -- TODO: remove: + , underlyingOffset :: {-# UNPACK #-} !Word + , entrenchment :: {-# UNPACK #-} !Word + } + | SpecialisedError { presentationOffset :: {-# UNPACK #-} !Word + , line :: {-# UNPACK #-} !Word + , col :: {-# UNPACK #-} !Word + , msgs :: ![String] + --, caretWidth :: {-# UNPACK #-} !Span --FIXME: need defunc before this goes away + , caretWidth :: CaretWidth + -- TODO: remove: + , underlyingOffset :: {-# UNPACK #-} !Word + , entrenchment :: {-# UNPACK #-} !Word + } + +type Input :: * +type Input = NonEmpty Char +type UnexpectItem :: * +data UnexpectItem = UnexpectRaw !Input {-# UNPACK #-} !Word + | UnexpectNamed !String CaretWidth + | UnexpectEndOfInput +type ExpectItem :: * +data ExpectItem = ExpectRaw !String + | ExpectNamed !String + | ExpectEndOfInput + deriving stock (Eq, Ord, Show) + +entrenched :: ParseError -> Bool +entrenched err = entrenchment err /= 0 + +emptyErr :: Word -> Word -> Word -> Word -> ParseError +emptyErr !presentationOffset !line !col !width = VanillaError { + presentationOffset = presentationOffset, + line = line, + col = col, + unexpected = Left width, + expecteds = Set.empty, + reasons = Set.empty, + lexicalError = False, + underlyingOffset = presentationOffset, + entrenchment = 0 + } + +expectedErr :: String -> Word -> Word -> Word -> Set ExpectItem -> Word -> ParseError +expectedErr !input !presentationOffset !line !col !expecteds !width = VanillaError { + presentationOffset = presentationOffset, + line = line, + col = col, + unexpected = case nonEmpty input of + Nothing -> Right UnexpectEndOfInput + Just cs -> Right (UnexpectRaw cs width), + expecteds = expecteds, + reasons = Set.empty, + lexicalError = False, + underlyingOffset = presentationOffset, + entrenchment = 0 +} + +specialisedErr :: Word -> Word -> Word -> [String] -> CaretWidth -> ParseError +specialisedErr !presentationOffset !line !col !msgs caretWidth = SpecialisedError {..} + where !underlyingOffset = presentationOffset + !entrenchment = 0 :: Word + +unexpectedErr :: Word -> Word -> Word -> Set ExpectItem -> String -> CaretWidth -> ParseError +unexpectedErr !presentationOffset !line !col !expecteds !name caretWidth = VanillaError { + presentationOffset = presentationOffset, + line = line, + col = col, + expecteds = expecteds, + unexpected = Right (UnexpectNamed name caretWidth), + reasons = Set.empty, + lexicalError = False, + underlyingOffset = presentationOffset, + entrenchment = 0 + } + +labelErr :: Word -> Set String -> ParseError -> ParseError +labelErr !offset expecteds err@VanillaError{} + | offset == presentationOffset err = err { expecteds = Set.map ExpectNamed expecteds } +labelErr _ _ err = err + +explainErr :: Word -> String -> ParseError -> ParseError +explainErr !offset reason err@VanillaError{} + | offset == presentationOffset err = err { reasons = Set.insert reason (reasons err) } +explainErr _ _ err = err + +amendErr :: Word -> Word -> Word -> ParseError -> ParseError +amendErr !offset !line !col err + | not (entrenched err) = err { + presentationOffset = offset, + underlyingOffset = offset, + line = line, + col = col + } +amendErr _ _ _ err = err + +partialAmendErr :: Word -> Word -> Word -> ParseError -> ParseError +partialAmendErr !offset !line !col err + | not (entrenched err) = err { + presentationOffset = offset, + line = line, + col = col + } +partialAmendErr _ _ _ err = err + +entrenchErr :: ParseError -> ParseError +entrenchErr err = err { entrenchment = entrenchment err + 1 } + +dislodgeErr :: Word -> ParseError -> ParseError +dislodgeErr by err + | entrenchment err == 0 = err + -- this case is important to avoid underflow on the unsigned Word + | by >= entrenchment err = err { entrenchment = 0 } + | otherwise = err { entrenchment = entrenchment err - by } + +setLexical :: ParseError -> ParseError +setLexical err@VanillaError{} = err { lexicalError = True } +setLexical err = err + +useHints :: Set ExpectItem -> ParseError -> ParseError +useHints !hints err@VanillaError{expecteds} = err { expecteds = Set.union hints expecteds } +useHints _ err = err + +mergeErr :: ParseError -> ParseError -> ParseError +mergeErr err1 err2 + | underlyingOffset err1 > underlyingOffset err2 = err1 + | underlyingOffset err1 < underlyingOffset err2 = err2 + | presentationOffset err1 > presentationOffset err2 = err1 + | presentationOffset err1 < presentationOffset err2 = err2 +-- offsets are all equal, kinds must match +mergeErr err1@SpecialisedError{caretWidth} _err2@VanillaError{} + | isFlexible caretWidth = err1 -- TODO: flexible caret merging from err2 + | otherwise = err1 +mergeErr _err1@VanillaError{} err2@SpecialisedError{caretWidth} + | isFlexible caretWidth = err2 -- TODO: flexible caret merging from err1 + | otherwise = err2 +mergeErr err1@VanillaError{} err2@VanillaError{} = + err1 { unexpected = mergeUnexpect (unexpected err1) (unexpected err2) + , expecteds = Set.union (expecteds err1) (expecteds err2) + , reasons = Set.union (reasons err1) (reasons err2) + , lexicalError = lexicalError err1 || lexicalError err2 + } +mergeErr err1@SpecialisedError{} err2@SpecialisedError{} = + err1 { msgs = msgs err1 ++ msgs err2 + , caretWidth = mergeCaret (caretWidth err1) (caretWidth err2) + } + +mergeCaret :: CaretWidth -> CaretWidth -> CaretWidth +mergeCaret caret@RigidCaret{} FlexibleCaret{} = caret +mergeCaret FlexibleCaret{} caret@RigidCaret{} = caret +mergeCaret caret1 caret2 = caret1 { width = max (width caret1) (width caret2) } + +mergeUnexpect :: Either Word UnexpectItem -> Either Word UnexpectItem -> Either Word UnexpectItem +mergeUnexpect (Left w1) (Left w2) = Left (max w1 w2) +-- TODO: widening can occur with flexible or raw tokens +mergeUnexpect Left{} w@Right{} = w +mergeUnexpect w@Right{} Left{} = w +-- finally, two others will merge independently +mergeUnexpect (Right item1) (Right item2) = Right (mergeItem item1 item2) + where mergeItem UnexpectEndOfInput _ = UnexpectEndOfInput + mergeItem _ UnexpectEndOfInput = UnexpectEndOfInput + mergeItem it1@(UnexpectNamed _ cw1) it2@(UnexpectNamed _ cw2) + | isFlexible cw1, not (isFlexible cw2) = it2 + | not (isFlexible cw1), isFlexible cw2 = it1 + | width cw1 < width cw2 = it2 + | otherwise = it1 + mergeItem item@UnexpectNamed{} _ = item + mergeItem _ item@UnexpectNamed{} = item + mergeItem (UnexpectRaw cs w1) (UnexpectRaw _ w2) = UnexpectRaw cs (max w1 w2) + +isExpectedEmpty :: ParseError -> Bool +isExpectedEmpty VanillaError{expecteds} = Set.null expecteds +isExpectedEmpty _ = True + +{-# INLINABLE fromParseError #-} +fromParseError :: forall err. ErrorBuilder err => Maybe FilePath -> String -> ParseError -> err +fromParseError srcFile input err = + Builder.format (Builder.pos @err (line err) (col err)) (Builder.source @err srcFile) + (formatErr err) + where formatErr :: ParseError -> Builder.ErrorInfoLines err + formatErr VanillaError{..} = + Builder.vanillaError @err + (Builder.unexpected @err (either (const Nothing) (Just . fst) unexpectedTok)) + (Builder.expected @err (Builder.combineExpectedItems @err (Set.map expectItem expecteds))) + (Builder.combineMessages @err (Set.foldr (\r -> (Builder.reason @err r :)) [] reasons)) + (Builder.lineInfo @err curLine linesBefore linesAfter caret (trimToLine caretSize)) + where unexpectedTok = unexpectItem lexicalError <$> unexpected + caretSize = either id snd unexpectedTok + + formatErr SpecialisedError{..} = + Builder.specialisedError @err + (Builder.combineMessages @err (map (Builder.message @err) msgs)) + (Builder.lineInfo @err curLine linesBefore linesAfter caret (trimToLine (width caretWidth))) + + expectItem :: ExpectItem -> Builder.Item err + expectItem (ExpectRaw t) = Builder.raw @err t + expectItem (ExpectNamed n) = Builder.named @err n + expectItem ExpectEndOfInput = Builder.endOfInput @err + + unexpectItem :: Bool -> UnexpectItem -> (Builder.Item err, Span) + unexpectItem lexical (UnexpectRaw cs demanded) = + case Builder.unexpectedToken @err cs demanded lexical of + t@(Token.Raw tok) -> (Builder.raw @err tok, tokenSpan t) + Token.Named name w -> (Builder.named @err name, w) + unexpectItem _ (UnexpectNamed name caretWidth) = (Builder.named @err name, width caretWidth) + unexpectItem _ UnexpectEndOfInput = (Builder.endOfInput @err, 1) + + -- it is definitely the case that there are at least `line` lines + (allLinesBefore, curLine, allLinesAfter) = breakLines (line err - 1) (lines input) + linesBefore = drop (length allLinesBefore - Builder.numLinesBefore @err) allLinesBefore + linesAfter = take (Builder.numLinesAfter @err) allLinesAfter + + caret = col err - 1 + trimToLine width = min width (fromIntegral (length curLine) - caret + 1) + + lines :: String -> NonEmpty String + lines [] = "" :| [] + lines ('\n':cs) = "" <| lines cs + lines (c:cs) = let l :| ls = lines cs in (c:l) :| ls + + breakLines :: Word -> NonEmpty String -> ([String], String, [String]) + breakLines 0 (l :| ls) = ([], l, ls) + breakLines n (l :| ls) = case nonEmpty ls of + Nothing -> error "the focus line is guaranteed to exist" + Just ls' -> let (before, focus, after) = breakLines (n - 1) ls' + in (l : before, focus, after) + + tokenSpan :: Token -> Word + tokenSpan (Token.Raw cs) = fromIntegral (length cs) + tokenSpan (Token.Named _ w) = w diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -6,6 +6,7 @@ import Text.Gigaparsec.CharTests qualified as Char import Text.Gigaparsec.CombinatorTests qualified as Combinator import Text.Gigaparsec.ExprTests qualified as Expr +import Text.Gigaparsec.ErrorsTests qualified as Errors main :: IO () main = defaultMain $ testGroup "gigaparsec" @@ -13,4 +14,5 @@ , Char.tests , Combinator.tests , Expr.tests + , Errors.tests ] diff --git a/test/Text/Gigaparsec/CharTests.hs b/test/Text/Gigaparsec/CharTests.hs --- a/test/Text/Gigaparsec/CharTests.hs +++ b/test/Text/Gigaparsec/CharTests.hs @@ -33,9 +33,9 @@ pureParseWith (satisfy (== 'a')) "b" , testCase "be impure otherwise" do impureParseWith (satisfy (== 'a')) "a" , testCase "return the parsed character" do - parse item "a" @?= Success 'a' - parse item "ba" @?= Success 'b' - parse item "\NUL" @?= Success '\NUL' + testParse item "a" @?= Success 'a' + testParse item "ba" @?= Success 'b' + testParse item "\NUL" @?= Success '\NUL' , testCase "fail otherwise" do ensureFails (satisfy (== 'b')) "" ensureFails item "" @@ -48,7 +48,7 @@ pureParseWith (char 'a') "" pureParseWith (char 'a') "b" , testCase "be impure otherwise" do impureParseWith (char 'a') "a" - , testCase "return the parsed character" do parse (char 'a') "a" @?= Success 'a' + , testCase "return the parsed character" do testParse (char 'a') "a" @?= Success 'a' , testCase "fail otherwise" do ensureFails (char 'a') "" ensureFails (char 'a') "b" @@ -56,13 +56,13 @@ stringTests :: TestTree stringTests = testGroup "string should" - [ testCase "reject the empty string" (throws @RequirementUnsatisfied (parse (string "") "")) -- don't ask why `string ""` doesn't work all the time + [ testCase "reject the empty string" (throws @RequirementUnsatisfied (testParse (string "") "")) -- don't ask why `string ""` doesn't work all the time , testCase "be pure if it cannot read at all" do pureParseWith (string "abc") "" pureParseWith (string "abc") "123" , testCase "be impure if there is a partial read" do impureParseWith (string "abc") "abd" , testCase "be impure if full read" do impureParseWith (string "abc") "abc" - , testCase "return the parsed string" do parse (string "123") "123" @?= Success "123" + , testCase "return the parsed string" do testParse (string "123") "123" @?= Success "123" , testCase "fail otherwise" do ensureFails (string "123") "124" ensureFails (string "123") "12" @@ -74,8 +74,8 @@ ensureFails p "" ensureFails p "a" , testCase "succeed performing the mapping otherwise" do - parse p "4" @?= Success 4 - parse p "9" @?= Success 9 + testParse p "4" @?= Success 4 + testParse p "9" @?= Success 9 ] where p = satisfyMap (\c -> digitToInt c <$ guard (isDigit c)) @@ -89,7 +89,7 @@ pureParseWith q "" pureParseWith q "b" impureParseWith q "a" - parse q "a" @?= Success 'a' + testParse q "a" @?= Success 'a' ensureFails q "" ensureFails q "b" , testCase "parse within a contiguous range" do @@ -97,7 +97,7 @@ pureParseWith r "a" forM_ @[] ['0'..'9'] $ \c -> do impureParseWith r (pure c) - parse r (pure c) @?= Success c + testParse r (pure c) @?= Success c ensureFails r "a" ensureFails r "\NUL" ensureFails r ":" @@ -107,7 +107,7 @@ pureParseWith s "a" forM_ @[] ['.', ';', ',', ':'] $ \c -> do impureParseWith s (pure c) - parse s (pure c) @?= Success c + testParse s (pure c) @?= Success c ensureFails s "a" ensureFails s "\NUL" ] @@ -121,13 +121,13 @@ [ testCase "act like item when given no characters" do pureParseWith p "" ensureFails p "" - parse p "a" @?= Success 'a' - parse p "\ACK" @?= Success '\ACK' + testParse p "a" @?= Success 'a' + testParse p "\ACK" @?= Success '\ACK' , testCase "accept all but a specific character" do pureParseWith q "" pureParseWith q "a" impureParseWith q "b" - parse q "5" @?= Success '5' + testParse q "5" @?= Success '5' ensureFails q "" ensureFails q "a" , testCase "parse within a contiguous range" do @@ -136,18 +136,18 @@ forM_ @[] ['0'..'9'] $ \c -> do pureParseWith r (pure c) ensureFails r (pure c) - parse r "a" @?= Success 'a' - parse r "\NUL" @?= Success '\NUL' - parse r ":" @?= Success ':' - parse r "/" @?= Success '/' + testParse r "a" @?= Success 'a' + testParse r "\NUL" @?= Success '\NUL' + testParse r ":" @?= Success ':' + testParse r "/" @?= Success '/' , testCase "parse any other sets" do pureParseWith s "" impureParseWith s "a" forM_ @[] ['.', ';', ',', ':'] $ \c -> do pureParseWith s (pure c) ensureFails s (pure c) - parse s "a" @?= Success 'a' - parse s "\NUL" @?= Success '\NUL' + testParse s "a" @?= Success 'a' + testParse s "\NUL" @?= Success '\NUL' ] where p = noneOf [] q = noneOf ['a'] @@ -158,11 +158,11 @@ stringsTests = testGroup "strings should" [ testCase "reject any empty strings" do throws @RequirementUnsatisfied (strings ["abc", "323", ""]) , testCase "have longest match behaviour" do - parse p "hello" @?= Success "hello" - parse p "hell" @?= Success "hell" - parse p "he" @?= Success "h" - parse p "123" @?= Success "123" - parse p "124" @?= Success "1" + testParse p "hello" @?= Success "hello" + testParse p "hell" @?= Success "hell" + testParse p "he" @?= Success "h" + testParse p "123" @?= Success "123" + testParse p "124" @?= Success "1" , testCase "reject anything outside of the set" do ensureFails p "543" ensureFails p "good" @@ -173,14 +173,14 @@ trieTests = testGroup "trie should" [ testCase "reject any empty strings" do throws @RequirementUnsatisfied (trie' ["" --> unit]) , testCase "have longest match behaviour" do - parse p "hello" @?= Success "hello" - parse p "hell" @?= Success "hell" - parse p "h" @?= Success "h" - parse p "he" @?= Success "h" - parse p "hi" @?= Success "hi" - parse p "good" @?= Success "good" - parse p "goodby" @?= Success "good" - parse p "goodbye" @?= Success "goodbye" + testParse p "hello" @?= Success "hello" + testParse p "hell" @?= Success "hell" + testParse p "h" @?= Success "h" + testParse p "he" @?= Success "h" + testParse p "hi" @?= Success "hi" + testParse p "good" @?= Success "good" + testParse p "goodby" @?= Success "good" + testParse p "goodbye" @?= Success "goodbye" , testCase "reject anything outside of the set" do ensureFails p "543" ensureFails p "god" diff --git a/test/Text/Gigaparsec/CombinatorTests.hs b/test/Text/Gigaparsec/CombinatorTests.hs --- a/test/Text/Gigaparsec/CombinatorTests.hs +++ b/test/Text/Gigaparsec/CombinatorTests.hs @@ -40,7 +40,7 @@ , testCase "behave like p for [p]" do (choice [char 'a'] ~~ char 'a') ["", "a", "b"] , testCase "parse in order" do - parse (choice [string "a", string "b", string "bc"]) "bcd" @?= Success "b" + testParse (choice [string "a", string "b", string "bc"]) "bcd" @?= Success "b" , testCase "fail if none of the parsers succeed" do ensureFails (choice [string "a", string "b", string "bc"]) "c" ] @@ -48,9 +48,9 @@ optionTests :: TestTree optionTests = testGroup "option should" [ testCase "succeed with Just if p succeeds" do - parse (option (char 'a')) "a" @?= Success (Just 'a') + testParse (option (char 'a')) "a" @?= Success (Just 'a') , testCase "succeed with Nothing if p fails withot consumption" do - parse (option (char 'a')) "b" @?= Success Nothing + testParse (option (char 'a')) "b" @?= Success Nothing , testCase "fail if p fails with consumption" do ensureFails (option (string "ab")) "a" ] @@ -58,7 +58,7 @@ decideTests :: TestTree decideTests = testGroup "decide should" [ testCase "succeed for Just" do - parse (decide (Just <$> char 'a')) "a" @?= Success 'a' + testParse (decide (Just <$> char 'a')) "a" @?= Success 'a' , testCase "fail for Nothing" do ensureFails @() (decide (pure Nothing)) "" , testCase "compose with option to become identity" do let id' = decide . option @@ -70,17 +70,17 @@ fromMaybeSTests :: TestTree fromMaybeSTests = testGroup "fromMaybeS should" [ testCase "succeed for Just" do - parse (fromMaybeS (pure 'b') (Just <$> char 'a')) "a" @?= Success 'a' + testParse (fromMaybeS (pure 'b') (Just <$> char 'a')) "a" @?= Success 'a' , testCase "succeed for None" do - parse (fromMaybeS (pure 'b') (Nothing <$ char 'a')) "a" @?= Success 'b' + testParse (fromMaybeS (pure 'b') (Nothing <$ char 'a')) "a" @?= Success 'b' ] optionalTests :: TestTree optionalTests = testGroup "optional should" [ testCase "succeed if p succeeds" do - parse (optional (char 'a')) "a" @?= Success () + testParse (optional (char 'a')) "a" @?= Success () , testCase "also succeed if p fails without consumption" do - parse (optional (char 'a')) "b" @?= Success () + testParse (optional (char 'a')) "b" @?= Success () , testCase "fail if p failed with consumption" do ensureFails (optional (string "ab")) "a" ] @@ -89,64 +89,64 @@ manyNTests = testGroup "manyN should" [ testCase "ensure that n are parsed" do forM_ [0..10] \n -> do - parse (manyN n item) (replicate n 'a') @?= Success (replicate n 'a') + testParse (manyN n item) (replicate n 'a') @?= Success (replicate n 'a') ensureFails (manyN (n + 1) item) (replicate n 'a') , testCase "not care if more are present" do forM_ [0..10] \n -> - parse (manyN n item) (replicate (n + 1) 'a') @?= Success (replicate (n + 1) 'a') + testParse (manyN n item) (replicate (n + 1) 'a') @?= Success (replicate (n + 1) 'a') ] skipManyNTests :: TestTree skipManyNTests = testGroup "skipManyN should" [ testCase "ensure that n are parsed" do forM_ [0..10] \n -> do - parse (skipManyN n item) (replicate n 'a') @?= Success () + testParse (skipManyN n item) (replicate n 'a') @?= Success () ensureFails (skipManyN (n + 1) item) (replicate n 'a') , testCase "not care if more are present" do forM_ [0..10] \n -> - parse (skipManyN n item) (replicate (n + 1) 'a') @?= Success () + testParse (skipManyN n item) (replicate (n + 1) 'a') @?= Success () ] sepByTests :: TestTree sepByTests = testGroup "sepBy should" [ testCase "accept empty input" do - parse (sepBy (char 'a') (char 'b')) "" @?= Success [] + testParse (sepBy (char 'a') (char 'b')) "" @?= Success [] , testCase "parse more than 1" do - parse (sepBy (char 'a') (char 'b')) "aba" @?= Success ['a', 'a'] + testParse (sepBy (char 'a') (char 'b')) "aba" @?= Success ['a', 'a'] ] sepBy1Tests :: TestTree sepBy1Tests = testGroup "sepBy1 should" [ testCase "not allow sep at the end of chain" do ensureFails p "ab" - , testCase "be able to parse 2 or more p" do - parse p "aba" @?= Success ['a', 'a'] - parse p "ababa" @?= Success ['a', 'a', 'a'] - parse p "abababa" @?= Success ['a', 'a', 'a', 'a'] + , testCase "be able to testParse 2 or more p" do + testParse p "aba" @?= Success ['a', 'a'] + testParse p "ababa" @?= Success ['a', 'a', 'a'] + testParse p "abababa" @?= Success ['a', 'a', 'a', 'a'] , testCase "require a p" do ensureFails p "" - parse p "a" @?= Success ['a'] + testParse p "a" @?= Success ['a'] ] where p = sepBy1 (char 'a') (char 'b') sepEndByTests :: TestTree sepEndByTests = testGroup "sepEndBy should" [ testCase "accept empty input" do - parse (sepEndBy (char 'a') (char 'b')) "" @?= Success [] + testParse (sepEndBy (char 'a') (char 'b')) "" @?= Success [] , testCase "parse more than 1" do - parse (sepEndBy (char 'a') (char 'b')) "aba" @?= Success ['a', 'a'] + testParse (sepEndBy (char 'a') (char 'b')) "aba" @?= Success ['a', 'a'] ] sepEndBy1Tests :: TestTree sepEndBy1Tests = testGroup "sepEndBy1 should" [ testCase "require a p" do ensureFails p "" - , testCase "not require sep at end of chain" do parse p "aa" @?= Success ["aa"] - , testCase "be able to parse 2 or more p" do - parse p "aabbaa" @?= Success ["aa", "aa"] - parse p "aabbaabbaa" @?= Success ["aa", "aa", "aa"] - , testCase "be able to parse a final sep" do - parse p "aabb" @?= Success ["aa"] - parse p "aabbaabb" @?= Success ["aa", "aa"] - parse p "aabbaabbaabb" @?= Success ["aa", "aa", "aa"] + , testCase "not require sep at end of chain" do testParse p "aa" @?= Success ["aa"] + , testCase "be able to testParse 2 or more p" do + testParse p "aabbaa" @?= Success ["aa", "aa"] + testParse p "aabbaabbaa" @?= Success ["aa", "aa", "aa"] + , testCase "be able to testParse a final sep" do + testParse p "aabb" @?= Success ["aa"] + testParse p "aabbaabb" @?= Success ["aa", "aa"] + testParse p "aabbaabbaabb" @?= Success ["aa", "aa", "aa"] , testCase "fail if p fails after consuming input" do ensureFails p "aabab" , testCase "fail if sep fails after consuming input" do @@ -157,9 +157,9 @@ endByTests :: TestTree endByTests = testGroup "endBy should" [ testCase "accept empty input" do - parse (endBy (char 'a') (char 'b')) "" @?= Success [] + testParse (endBy (char 'a') (char 'b')) "" @?= Success [] , testCase "parse more than 1" do - parse (endBy (char 'a') (char 'b')) "abab" @?= Success ['a', 'a'] + testParse (endBy (char 'a') (char 'b')) "abab" @?= Success ['a', 'a'] ] endBy1Tests :: TestTree @@ -167,10 +167,10 @@ [ testCase "require a p" do ensureFails p "" , testCase "require a sep at the end of chain" do ensureFails p "aa" - parse p "aabb" @?= Success ["aa"] - , testCase "be able to parse 2 or more p" do - parse p "aabbaabb" @?= Success ["aa", "aa"] - parse p "aabbaabbaabb" @?= Success ["aa", "aa", "aa"] + testParse p "aabb" @?= Success ["aa"] + , testCase "be able to testParse 2 or more p" do + testParse p "aabbaabb" @?= Success ["aa", "aa"] + testParse p "aabbaabbaabb" @?= Success ["aa", "aa", "aa"] , testCase "fail if p fails after consuming input" do ensureFails p "aaba" ] @@ -180,10 +180,10 @@ manyTillTests = testGroup "manyTill should" [ testCase "require an end" do ensureFails p "aa" - parse p "ab" @?= Success ['a'] - , testCase "parse the end without result" do parse p "b" @?= Success [] + testParse p "ab" @?= Success ['a'] + , testCase "parse the end without result" do testParse p "b" @?= Success [] , testCase "parse p until the end is found" do - parse p "aaaaaaaaaab" @?= Success (replicate 10 'a') + testParse p "aaaaaaaaaab" @?= Success (replicate 10 'a') ensureFails (manyTill (string "aa") (char 'b')) "aaab" ] where p = manyTill (char 'a') (char 'b') @@ -191,7 +191,7 @@ someTillTests :: TestTree someTillTests = testGroup "someTill should" [ testCase "parse at least 1 p" do - parse p "ab" @?= Success ['a'] + testParse p "ab" @?= Success ['a'] ensureFails p "a" ensureFails p "b" ] @@ -200,12 +200,12 @@ countTests :: TestTree countTests = testGroup "count should" [ testCase "report how many successful parses occurred" do - parse p "" @?= Success 0 + testParse p "" @?= Success 0 ensureFails q "" - parse p "ab" @?= Success 1 - parse q "ab" @?= Success 1 - parse p "ababab" @?= Success 3 - parse q "ababab" @?= Success 3 + testParse p "ab" @?= Success 1 + testParse q "ab" @?= Success 1 + testParse p "ababab" @?= Success 3 + testParse q "ababab" @?= Success 3 , testCase "not allow partial results" do ensureFails p "aba" ] @@ -217,9 +217,9 @@ [ testCase "should be pure [] for n <= 0" do (exactly 0 (char 'a') ~~ pure []) ["", "a"] (exactly (-1) (char 'a') ~~ pure []) ["", "a"] - , testCase "should parse n times for n > 0" do + , testCase "should testParse n times for n > 0" do forM_ [0..100] \n -> - parse (exactly n (char 'a')) (replicate n 'a') @?= Success (replicate n 'a') + testParse (exactly n (char 'a')) (replicate n 'a') @?= Success (replicate n 'a') , testCase "fail if n inputs are not present" do ensureFails (exactly 2 (char 'a')) "a" ] @@ -228,11 +228,11 @@ rangeTests = testGroup "range should" [ testCase "collect results up instead of count" do ensureFails p "a" - parse p "ab" @?= Success ['a', 'b'] - parse p "abc" @?= Success ['a', 'b', 'c'] - parse p "abcd" @?= Success ['a', 'b', 'c', 'd'] - parse p "abcde" @?= Success ['a', 'b', 'c', 'd', 'e'] - parse q "abcdef" @?= Success ['a', 'b', 'c', 'd', 'e'] + testParse p "ab" @?= Success ['a', 'b'] + testParse p "abc" @?= Success ['a', 'b', 'c'] + testParse p "abcd" @?= Success ['a', 'b', 'c', 'd'] + testParse p "abcde" @?= Success ['a', 'b', 'c', 'd', 'e'] + testParse q "abcdef" @?= Success ['a', 'b', 'c', 'd', 'e'] , testCase "should act as pure [] when range is bad" do (range (-1) 3 item ~~ pure []) ["", "a"] (range 2 1 item ~~ pure []) ["", "a"] @@ -244,11 +244,11 @@ range_Tests = testGroup "range_ should" [ testCase "perform a range with no results" do ensureFails p "a" - parse p "ab" @?= Success () - parse p "abc" @?= Success () - parse p "abcd" @?= Success () - parse p "abcde" @?= Success () - parse q "abcdef" @?= Success () + testParse p "ab" @?= Success () + testParse p "abc" @?= Success () + testParse p "abcd" @?= Success () + testParse p "abcde" @?= Success () + testParse q "abcdef" @?= Success () , testCase "should act as unit when range is bad" do (range_ (-1) 3 item ~~ unit) ["", "a"] (range_ 2 1 item ~~ unit) ["", "a"] @@ -260,19 +260,19 @@ countRangeTests = testGroup "countRange should" [ testCase "count the parses within the range" do ensureFails p "ab" - parse p "abab" @?= Success 2 - parse p "ababab" @?= Success 3 - parse p "abababab" @?= Success 4 - parse p "ababababab" @?= Success 5 - parse p "abababababab" @?= Success 5 + testParse p "abab" @?= Success 2 + testParse p "ababab" @?= Success 3 + testParse p "abababab" @?= Success 4 + testParse p "ababababab" @?= Success 5 + testParse p "abababababab" @?= Success 5 ensureFails p "ababababa" ensureFails q "ab" - parse q "abab" @?= Success 2 - parse q "ababab" @?= Success 3 - parse q "abababab" @?= Success 4 - parse q "ababababab" @?= Success 5 - parse q "abababababab" @?= Success 5 - parse q "ababababa" @?= Success 4 + testParse q "abab" @?= Success 2 + testParse q "ababab" @?= Success 3 + testParse q "abababab" @?= Success 4 + testParse q "ababababab" @?= Success 5 + testParse q "abababababab" @?= Success 5 + testParse q "ababababa" @?= Success 4 , testCase "should act as unit when range is bad" do (countRange (-1) 3 item ~~ pure 0) ["", "a"] (countRange 2 1 item ~~ pure 0) ["", "a"] diff --git a/test/Text/Gigaparsec/ErrorsTests.hs b/test/Text/Gigaparsec/ErrorsTests.hs new file mode 100644 --- /dev/null +++ b/test/Text/Gigaparsec/ErrorsTests.hs @@ -0,0 +1,384 @@ +{-# LANGUAGE OverloadedLists #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Alternative law, right identity" #-} +module Text.Gigaparsec.ErrorsTests where + +import Prelude hiding (fail) + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.ExpectedFailure + +import Text.Gigaparsec +import Text.Gigaparsec.Char +import Text.Gigaparsec.Combinator +import Text.Gigaparsec.Errors.Combinator +import Text.Gigaparsec.Internal.Test +import Text.Gigaparsec.Internal.TestError + +import Data.Set qualified as Set (map) + +tests :: TestTree +tests = testGroup "Errors" [ labelTests + , hideTests + , explainTests + , emptyTests + , failTests + , unexpectedTests + , lookAheadTests + , notFollowedByTests + , amendTests + , entrenchTests + , dislodgeTests + , amendThenDislodgeTests + , partialAmendTests + , oneOfTests + , noneOfTests + , regressionTests + ] + +labelTests :: TestTree +labelTests = testGroup "label should" + [ testCase "affect base error messages" do + testParse (char 'a' ["ay!"]) "b" @?= + Failure (TestError (1, 1) (VanillaError (Just (Raw "b")) [Named "ay!"] [] 1)) + testParse (char 'a' ["ay!", "see!"]) "b" @?= + Failure (TestError (1, 1) (VanillaError (Just (Raw "b")) [Named "ay!", Named "see!"] [] 1)) + , testCase "work across a recursion boundary" do + let r = string "correct error message" <:> r + let p = r ["nothing but this :)"] + testParse p "" @?= + Failure (TestError (1, 1) (VanillaError (Just EndOfInput) [Named "nothing but this :)"] [] 1)) + testParse p "correct error message" @?= + Failure (TestError (1, 22) (VanillaError (Just EndOfInput) [Raw "correct error message"] [] 1)) + , testCase "replace everything under the label" do + let s = label ["hi"] (optional (char 'a') *> optional (char 'b')) *> char 'c' + testParse s "e" @?= + Failure (TestError (1, 1) (VanillaError (Just (Raw "e")) [Named "hi", Raw "c"] [] 1)) + let t = label ["hi"] (optional (char 'a') *> label ["bee"] (optional (char 'b'))) *> char 'c' + testParse t "e" @?= + Failure (TestError (1, 1) (VanillaError (Just (Raw "e")) [Named "hi", Raw "c"] [] 1)) + testParse t "ae" @?= + Failure (TestError (1, 2) (VanillaError (Just (Raw "e")) [Named "bee", Raw "c"] [] 1)) + let v = label ["hi"] (hide (optional (char 'a')) *> label ["bee"] (optional (char 'b'))) *> char 'c' + testParse v "e" @?= + Failure (TestError (1, 1) (VanillaError (Just (Raw "e")) [Named "hi", Raw "c"] [] 1)) + testParse v "ae" @?= + Failure (TestError (1, 2) (VanillaError (Just (Raw "e")) [Named "bee", Raw "c"] [] 1)) + , testCase "should not replace hints if input is consumed" do + testParse ((many digit ["number"]) <* eof) "1e" @?= + Failure (TestError (1, 2) (VanillaError (Just (Raw "e")) [Named "digit", EndOfInput] [] 1)) + ] + +hideTests :: TestTree +hideTests = testGroup "hide should" + [ testCase "not produce any visible output" do + testParse (hide (char 'a')) "" @?= + Failure (TestError (1, 1) (VanillaError Nothing [] [] 0)) + testParse (hide (string "a")) "" @?= + Failure (TestError (1, 1) (VanillaError Nothing [] [] 0)) + testParse (hide digit) "" @?= + Failure (TestError (1, 1) (VanillaError Nothing [] [] 0)) + , testCase "suppress hints even if input is consumed" do + testParse (hide (many digit) <* eof) "1e" @?= + Failure (TestError (1, 2) (VanillaError (Just (Raw "e")) [EndOfInput] [] 1)) + , testCase "not allow hints to be unsuppressed by another label" do + testParse (label ["hey"] (hide (many digit)) <* eof) "1e" @?= + Failure (TestError (1, 2) (VanillaError (Just (Raw "e")) [EndOfInput] [] 1)) + ] + +emptyTests :: TestTree +emptyTests = testGroup "empty should" + [ testCase "produce unknown error messages" do + testParse @() empty "b" @?= Failure (TestError (1, 1) (VanillaError Nothing [] [] 0)) + , testCase "produce no unknown message under influence of label" do + testParse @() (empty ["something, at least"]) "b" @?= + Failure (TestError (1, 1) (VanillaError Nothing [Named "something, at least"] [] 0)) + , testCase "not produce an error message at end of <|> chain" do + testParse (char 'a' <|> empty) "b" @?= + Failure (TestError (1, 1) (VanillaError (Just (Raw "b")) [Raw "a"] [] 1)) + , testCase "produce an expected error under the influence of label in <|> chain" do + testParse (char 'a' <|> label ["something, at least"] empty) "b" @?= + Failure (TestError (1, 1) (VanillaError (Just (Raw "b")) [Raw "a", Named "something, at least"] [] 1)) + , expectFailBecause "no widening for carets in vanilla" $ testCase "have an effect if its caret is wider" do + testParse (char 'a' <|> emptyWide 3) "bcd" @?= + Failure (TestError (1, 1) (VanillaError (Just (Raw "bcd")) [Raw "a"] [] 3)) + ] + +explainTests :: TestTree +explainTests = testGroup "explain should" + [ testCase "provide a message but only on failure" do + testParse @Int (explain "oops!" empty) "" @?= + Failure (TestError (1, 1) (VanillaError Nothing [] ["oops!"] 0)) + testParse (explain "requires an a" (char 'a')) "b" @?= + Failure (TestError (1, 1) (VanillaError (Just (Raw "b")) [Raw "a"] ["requires an a"] 1)) + testParse (explain "an a" (char 'a') <|> explain "a b" (char 'b')) "c" @?= + Failure (TestError (1, 1) (VanillaError (Just (Raw "c")) [Raw "a", Raw "b"] ["an a", "a b"] 1)) + , testCase "not have any effect when more input has been consumed since it was added" do + testParse (explain "should be absent" (char 'a') *> char 'b') "a" @?= + Failure (TestError (1, 2) (VanillaError (Just EndOfInput) [Raw "b"] [] 1)) + testParse (explain "should be absent" (char 'a') <|> (char 'b' *> digit)) "b" @?= + Failure (TestError (1, 2) (VanillaError (Just EndOfInput) [Named "digit"] [] 1)) + ] + +failTests :: TestTree +failTests = testGroup "fail should" + [ testCase "yield a raw message" do + testParse @Int (fail ["hi"]) "b" @?= + Failure (TestError (1, 1) (SpecialisedError ["hi"] 1)) + , expectFailBecause "no cross-error width merging" $ testCase "be flexible when the width is unspecified" do + testParse (string "abc" <|> fail ["hi"]) "xyz" @?= + Failure (TestError (1, 1) (SpecialisedError ["hi"] 3)) + , testCase "dominate otherwise" do + testParse (string "abc" <|> failWide 2 ["hi"]) "xyz" @?= + Failure (TestError (1, 1) (SpecialisedError ["hi"] 2)) + ] + +unexpectedTests :: TestTree +unexpectedTests = testGroup "unexpected should" + [ testCase "yield changes to unexpected messages" do + testParse @() (unexpected "bee") "b" @?= + Failure (TestError (1, 1) (VanillaError (Just (Named "bee")) [] [] 1)) + , testCase "produce expected message under influence of label, along with original message" do + testParse (char 'a' <|> label ["something less cute"] (unexpected "bee")) "b" @?= + Failure (TestError (1, 1) (VanillaError (Just (Named "bee")) [Raw "a", Named "something less cute"] [] 1)) + , expectFailBecause "no widening for carets in vanilla" $ testCase "be flexible when the width is unspecified" do + testParse (string "abc" <|> unexpected "bee") "xyz" @?= + Failure (TestError (1, 1) (VanillaError (Just (Named "bee")) [Raw "abc"] [] 3)) + , testCase "dominate otherwise" do + testParse (string "abc" <|> unexpectedWide 2 "bee") "xyz" @?= + Failure (TestError (1, 1) (VanillaError (Just (Named "bee")) [Raw "abc"] [] 2)) + ] + +lookAheadTests :: TestTree +lookAheadTests = testGroup "lookAhead should" + [ testCase "produce no hints following it" do + let p = char 'a' <|> lookAhead (optional digit *> char 'c') <|> char 'b' + testParse p "d" @?= + Failure (TestError (1, 1) (VanillaError (Just (Raw "d")) [Raw "a", Raw "b", Raw "c", Named "digit"] [] 1)) + let q = char 'a' <|> lookAhead (optional digit) *> char 'c' <|> char 'b' + testParse q "d" @?= + Failure (TestError (1, 1) (VanillaError (Just (Raw "d")) [Raw "a", Raw "b", Raw "c"] [] 1)) + let r = char 'a' <|> lookAhead digit *> char 'c' <|> char 'b' + testParse r "d" @?= + Failure (TestError (1, 1) (VanillaError (Just (Raw "d")) [Raw "a", Raw "b", Named "digit"] [] 1)) + ] + +notFollowedByTests :: TestTree +notFollowedByTests = testGroup "notFollowedBy should" + [ testCase "produce no hints" do + let p = char 'a' <|> notFollowedBy (optional digit) *> char 'c' <|> char 'b' + testParse p "d" @?= + Failure (TestError (1, 1) (VanillaError (Just (Raw "d")) [Raw "a", Raw "b"] [] 1)) + let q = char 'a' <|> notFollowedBy digit *> char 'c' <|> char 'b' + testParse q "d" @?= + Failure (TestError (1, 1) (VanillaError (Just (Raw "d")) [Raw "a", Raw "b", Raw "c"] [] 1)) + ] + +eofTests :: TestTree +eofTests = testGroup "eof should" + [ testCase "produce expected end of input" do + testParse eof "a" @?= + Failure (TestError (1, 1) (VanillaError (Just (Raw "a")) [EndOfInput] [] 1)) + , testCase "change message under the influence of label" do + testParse (label ["something more"] eof) "a" @?= + Failure (TestError (1, 1) (VanillaError (Just (Raw "a")) [Named "something more"] [] 1)) + ] + +amendTests :: TestTree +amendTests = testGroup "amend should" + [ testCase "change error messages under it" do + let p = char 'a' *> amend (char 'b' *> char 'c' *> char 'd') + case testParse p "ab" of + Failure (TestError pos _) -> pos @?= (1, 2) + _ -> assertFailure "parser must fail" + case testParse p "abc" of + Failure (TestError pos _) -> pos @?= (1, 2) + _ -> assertFailure "parser must fail" + , testCase "not affect input consumption" do + ensureFails (amend (char 'a' *> char 'b') <|> char 'a') "a" + ] + +entrenchTests :: TestTree +entrenchTests = testGroup "entrench should" + [ testCase "prevent the change of error messages under it" do + let p = char 'a' *> amend (char 'b' *> entrench (char 'c') *> char 'd') + case testParse p "ab" of + Failure (TestError pos _) -> pos @?= (1, 3) + _ -> assertFailure "parser must fail" + case testParse p "abc" of + Failure (TestError pos _) -> pos @?= (1, 2) + _ -> assertFailure "parser must fail" + let q = char 'a' *> amend (char 'b' *> char 'c' *> entrench (char 'd')) + case testParse q "ab" of + Failure (TestError pos _) -> pos @?= (1, 2) + _ -> assertFailure "parser must fail" + case testParse q "abc" of + Failure (TestError pos _) -> pos @?= (1, 4) + _ -> assertFailure "parser must fail" + , testCase "not prevent the action of amend inside it" do + let p = char 'a' *> amend (char 'b' *> entrench (amend (char 'c' *> char 'd' *> entrench (char 'e'))) *> char 'f') + case testParse p "ab" of + Failure (TestError pos _) -> pos @?= (1, 3) + _ -> assertFailure "parser must fail" + case testParse p "abc" of + Failure (TestError pos _) -> pos @?= (1, 3) + _ -> assertFailure "parser must fail" + case testParse p "abcd" of + Failure (TestError pos _) -> pos @?= (1, 5) + _ -> assertFailure "parser must fail" + case testParse p "abcde" of + Failure (TestError pos _) -> pos @?= (1, 2) + _ -> assertFailure "parser must fail" + ] + +dislodgeTests :: TestTree +dislodgeTests = testGroup "dislodge should" + [ testCase "undo an entrench so that amend works again" do + let p = char 'a' *> amend (char 'b' *> dislodge (entrench (entrench (char 'c'))) *> char 'd') + case testParse p "ab" of + Failure (TestError pos _) -> pos @?= (1, 2) + _ -> assertFailure "parser must fail" + case testParse p "abc" of + Failure (TestError pos _) -> pos @?= (1, 2) + _ -> assertFailure "parser must fail" + , testCase "not prevent another entrench from occurring" do + let p = char 'a' *> amend (char 'b' *> entrench (dislodge (entrench (char 'c'))) *> char 'd') + case testParse p "ab" of + Failure (TestError pos _) -> pos @?= (1, 3) + _ -> assertFailure "parser must fail" + case testParse p "abc" of + Failure (TestError pos _) -> pos @?= (1, 2) + _ -> assertFailure "parser must fail" + , testCase "only unwind as many as instructed if applicable" do + let p = char 'a' *> amend (char 'b' *> dislodgeBy 1 (entrench (entrench (char 'c'))) *> char 'd') + let q = char 'a' *> amend (char 'b' *> dislodgeBy 2 (entrench (entrench (char 'c'))) *> char 'd') + case testParse p "ab" of + Failure (TestError pos _) -> pos @?= (1, 3) + _ -> assertFailure "parser must fail" + case testParse p "abc" of + Failure (TestError pos _) -> pos @?= (1, 2) + _ -> assertFailure "parser must fail" + case testParse q "ab" of + Failure (TestError pos _) -> pos @?= (1, 2) + _ -> assertFailure "parser must fail" + case testParse q "abc" of + Failure (TestError pos _) -> pos @?= (1, 2) + _ -> assertFailure "parser must fail" + ] + +amendThenDislodgeTests :: TestTree +amendThenDislodgeTests = testGroup "amendThenDislodge should" + [ testCase "amend only non-entrenched messages and dislodge those that are" do + let p = char 'a' *> amendThenDislodge (char 'b' *> entrench (entrench (char 'c')) *> char 'd') + let q = amend p + case testParse p "ab" of + Failure (TestError pos _) -> pos @?= (1, 3) + _ -> assertFailure "parser must fail" + case testParse p "abc" of + Failure (TestError pos _) -> pos @?= (1, 2) + _ -> assertFailure "parser must fail" + case testParse q "ab" of + Failure (TestError pos _) -> pos @?= (1, 1) + _ -> assertFailure "parser must fail" + case testParse q "abc" of + Failure (TestError pos _) -> pos @?= (1, 1) + _ -> assertFailure "parser must fail" + , testCase "only unwind as many as instructed if applicable" do + let p = char 'a' *> amendThenDislodgeBy 1 (char 'b' *> entrench (entrench (char 'c')) *> char 'd') + let q = amend p + let r = char 'a' *> amendThenDislodgeBy 2 (char 'b' *> entrench (entrench (char 'c')) *> char 'd') + let s = amend r + case testParse p "ab" of + Failure (TestError pos _) -> pos @?= (1, 3) + _ -> assertFailure "parser must fail" + case testParse p "abc" of + Failure (TestError pos _) -> pos @?= (1, 2) + _ -> assertFailure "parser must fail" + case testParse q "ab" of + Failure (TestError pos _) -> pos @?= (1, 3) + _ -> assertFailure "parser must fail" + case testParse q "abc" of + Failure (TestError pos _) -> pos @?= (1, 1) + _ -> assertFailure "parser must fail" + case testParse r "ab" of + Failure (TestError pos _) -> pos @?= (1, 3) + _ -> assertFailure "parser must fail" + case testParse r "abc" of + Failure (TestError pos _) -> pos @?= (1, 2) + _ -> assertFailure "parser must fail" + case testParse s "ab" of + Failure (TestError pos _) -> pos @?= (1, 1) + _ -> assertFailure "parser must fail" + case testParse s "abc" of + Failure (TestError pos _) -> pos @?= (1, 1) + _ -> assertFailure "parser must fail" + ] + +partialAmendTests :: TestTree +partialAmendTests = testGroup "partialAmend should" + [ testCaseSteps "perform visual amendment but allow for domination" \step -> do + let errorMaker n msg = atomic (exactly n (char 'a') *> (char 'b' <|> fail [msg])) + + step "a regular amend should lose against an even shallower error" + let p = errorMaker 2 "small" <|> amend (errorMaker 3 "big") + testParse p (replicate 4 'a') @?= Failure (TestError (1, 3) (SpecialisedError ["small"] 1)) + + step "a partial amend can win against an error at a lesser offset but greater presentation" + let q = errorMaker 2 "small" <|> partialAmend (errorMaker 3 "big") + testParse q (replicate 4 'a') @?= Failure (TestError (1, 1) (SpecialisedError ["big"] 1)) + + step "however, they do not win at equal underlying offset" + let r = errorMaker 3 "first" <|> partialAmend (errorMaker 3 "second") + testParse r (replicate 4 'a') @?= Failure (TestError (1, 4) (SpecialisedError ["first"] 1)) + ] + +--TODO: filter tests + +oneOfTests :: TestTree +oneOfTests = testGroup "oneOf should" + [ testCase "incorporate range notation into the error" do + testParse (oneOf ['0' .. '9']) "a" @?= + Failure (TestError (1, 1) (VanillaError (Just (Raw "a")) [Named "one of \"0\" to \"9\""] [] 1)) + , testCase "incorporate sets of characters into error" do + testParse (oneOf ['0', '2' .. '9']) "a" @?= + Failure (TestError (1, 1) (VanillaError (Just (Raw "a")) (Set.map (Named . show . (: [])) ['0', '2' .. '9']) [] 1)) + ] + +noneOfTests :: TestTree +noneOfTests = testGroup "noneOf should" + [ testCase "incorporate range notation into the error" do + testParse (noneOf ['0' .. '9']) "8" @?= + Failure (TestError (1, 1) (VanillaError (Just (Raw "8")) [Named "anything outside of \"0\" to \"9\""] [] 1)) + , expectFailBecause "no label applied yet" $ testCase "incorporate sets of characters into error" do + testParse (noneOf ['0', '2' .. '9']) "8" @?= + Failure (TestError (1, 1) (VanillaError (Just (Raw "8")) [Named "anything except \"0\", \"1\", \"2\", \"3\", \"4\", \"5\", \"6\", \"7\", \"8\", or \"9\""] [] 1)) + ] + +--TODO: patterns tests + +regressionTests :: TestTree +regressionTests = testGroup "thou shalt not regress" + [ testGroup "hints should" + [ testCase "incorporate only with errors at the same offset depth" do + let p = atomic (char 'a' *> digit) + let parser = optional (char 'b' ["b"]) *> label ["foo"] p + case testParse parser "aa" of + Failure (TestError (1, 2) (VanillaError _ expecteds _ 1)) -> do + expecteds @?= [Named "digit"] + err -> assertFailure $ "error message " ++ show err ++ " did not match" + let q = amend (char 'a' *> digit) + let qarser = optional (char 'b' ["b"]) *> label ["foo"] q + case testParse qarser "aa" of + Failure (TestError (1, 1) (VanillaError _ expecteds _ 1)) -> do + expecteds @?= [Named "foo", Named "b"] + err -> assertFailure $ "error message " ++ show err ++ " did not match" + ] + , testGroup "amend should" + -- FIXME: unclear why this would be the case + [ expectFail $ testCase "ensure that errors pick up a new unexpected token" do + let greeting = string "hello world" <* char '!' + testParse (amend greeting ["greeting"]) "hello world." @?= + Failure (TestError (1, 1) (VanillaError (Just (Raw "h")) [Named "greeting"] [] 1)) + ] + ] diff --git a/test/Text/Gigaparsec/Expr/ChainTests.hs b/test/Text/Gigaparsec/Expr/ChainTests.hs --- a/test/Text/Gigaparsec/Expr/ChainTests.hs +++ b/test/Text/Gigaparsec/Expr/ChainTests.hs @@ -7,7 +7,7 @@ import Text.Gigaparsec.Char (digit) import Text.Gigaparsec.Expr.Chain -import Text.Gigaparsec.Internal.Test (parseAll, ensureFails) +import Text.Gigaparsec.Internal.Test (testParseAll, ensureFails, testParse) import Text.Gigaparsec.Internal.PlainString () import Data.Char (digitToInt) @@ -27,9 +27,9 @@ postfixTests :: TestTree postfixTests = testGroup "postfix should" [ testCase "require an initial value" do - parseAll (postfix ("1" $> 1) ("+" $> succ)) "1" @?= Success 1 + testParseAll (postfix ("1" $> 1) ("+" $> succ)) "1" @?= Success 1 , testCase "parse all operators that follow" do - parseAll (postfix ("1" $> 1) ("+" $> succ)) "1++++++++++++++" @?= Success 15 + testParseAll (postfix ("1" $> 1) ("+" $> succ)) "1++++++++++++++" @?= Success 15 , testCase "fail if an operator fails after consuming input" do ensureFails (postfix ("1" $> 1) ("++" $> succ)) "1+++++++++++++++" ] @@ -38,9 +38,9 @@ postfix1Tests = testGroup "postfix1 should" [ testCase "require an initial value" do ensureFails (postfix1 id ("1" $> 1) ("+" $> succ)) "1" - parseAll (postfix1 id ("1" $> 1) ("+" $> succ)) "1+" @?= Success 2 + testParseAll (postfix1 id ("1" $> 1) ("+" $> succ)) "1+" @?= Success 2 , testCase "parse all operators that follow" do - parseAll (postfix1 id ("1" $> 1) ("+" $> succ)) "1++++++++++++++" @?= Success 15 + testParseAll (postfix1 id ("1" $> 1) ("+" $> succ)) "1++++++++++++++" @?= Success 15 , testCase "fail if an operator fails after consuming input" do ensureFails (postfix1 id ("1" $> 1) ("++" $> succ)) "1+++++++++++++++" ] @@ -48,9 +48,9 @@ prefixTests :: TestTree prefixTests = testGroup "prefix should" [ testCase "require an initial value" do - parseAll (prefix ("+" $> succ) ("1" $> 1)) "1" @?= Success 1 + testParseAll (prefix ("+" $> succ) ("1" $> 1)) "1" @?= Success 1 , testCase "parse all operators that follow" do - parseAll (prefix ("+" $> succ) ("1" $> 1)) "++++++++++++++1" @?= Success 15 + testParseAll (prefix ("+" $> succ) ("1" $> 1)) "++++++++++++++1" @?= Success 15 , testCase "fail if an operator fails after consuming input" do ensureFails (prefix ("++" $> succ) ("1" $> 1)) "+++++++++++++++1" ] @@ -59,9 +59,9 @@ prefix1Tests = testGroup "prefix1 should" [ testCase "require an initial value" do ensureFails (prefix1 id ("+" $> succ) ("1" $> 1)) "1" - parseAll (prefix1 id ("+" $> succ) ("1" $> 1)) "+1" @?= Success 2 + testParseAll (prefix1 id ("+" $> succ) ("1" $> 1)) "+1" @?= Success 2 , testCase "parse all operators that follow" do - parseAll (prefix1 id ("+" $> succ) ("1" $> 1)) "++++++++++++++1" @?= Success 15 + testParseAll (prefix1 id ("+" $> succ) ("1" $> 1)) "++++++++++++++1" @?= Success 15 , testCase "fail if an operator fails after consuming input" do ensureFails (prefix1 id ("++" $> succ) ("1" $> 1)) "+++++++++++++++1" ] @@ -70,13 +70,13 @@ chainr1Tests = testGroup "chainr1 should" [ testCase "require an initial value" do let p = chainr1 ("11" $> 1) ("+" $> (+)) - parseAll p "11" @?= Success 1 + testParseAll p "11" @?= Success 1 ensureFails p "1" ensureFails p "2" , testCase "parse all operators and values that follow" do - parseAll (chainr1 ("11" $> 1) ("+" $> (+))) "11+11+11+11+11" @?= Success 5 + testParseAll (chainr1 ("11" $> 1) ("+" $> (+))) "11+11+11+11+11" @?= Success 5 , testCase "apply the functions with the correct associativity" do - parseAll (chainr1 (digitToInt <$> digit) ("%" $> mod)) "6%5%2%7" @?= Success 0 + testParseAll (chainr1 (digitToInt <$> digit) ("%" $> mod)) "6%5%2%7" @?= Success 0 , testCase "fail if an operator or p fails after consuming input" do let p = chainr1 ("11" $> 1) ("++" $> (+)) ensureFails p "11+11+11+11+11" @@ -87,7 +87,7 @@ chainrTests = testGroup "chainr should" [ testCase "allow for no initial value" do let p = chainr ("11" $> 1) ("+" $> (+)) 0 - parseAll p "" @?= Success 0 + testParseAll p "" @?= Success 0 ensureFails p "1" ] @@ -95,13 +95,13 @@ chainl1Tests = testGroup "chainl1 should" [ testCase "require an initial value" do let p = chainl1 ("11" $> 1) ("+" $> (+)) - parseAll p "11" @?= Success 1 + testParseAll p "11" @?= Success 1 ensureFails p "1" ensureFails p "2" , testCase "parse all operators and values that follow" do - parseAll (chainl1 ("11" $> 1) ("+" $> (+))) "11+11+11+11+11" @?= Success 5 + testParseAll (chainl1 ("11" $> 1) ("+" $> (+))) "11+11+11+11+11" @?= Success 5 , testCase "apply the functions with the correct associativity" do - parseAll (chainl1 (digitToInt <$> digit) ("%" $> mod)) "6%5%2%7" @?= Success 1 + testParseAll (chainl1 (digitToInt <$> digit) ("%" $> mod)) "6%5%2%7" @?= Success 1 , testCase "fail if an operator or p fails after consuming input" do let p = chainl1 ("11" $> 1) ("++" $> (+)) ensureFails p "11+11+11+11+11" @@ -112,7 +112,7 @@ chainlTests = testGroup "chainl should" [ testCase "allow for no initial value" do let p = chainl ("11" $> 1) ("+" $> (+)) 0 - parseAll p "" @?= Success 0 + testParseAll p "" @?= Success 0 ensureFails p "1" - parse p "2" @?= Success 0 + testParse p "2" @?= Success 0 ] diff --git a/test/Text/Gigaparsec/Expr/InfixTests.hs b/test/Text/Gigaparsec/Expr/InfixTests.hs --- a/test/Text/Gigaparsec/Expr/InfixTests.hs +++ b/test/Text/Gigaparsec/Expr/InfixTests.hs @@ -6,7 +6,7 @@ import Text.Gigaparsec import Text.Gigaparsec.Expr.Infix -import Text.Gigaparsec.Internal.Test (parseAll) +import Text.Gigaparsec.Internal.Test (testParseAll) import Text.Gigaparsec.Internal.PlainString () data Expr = Add Int Expr | Sub Expr Int | Num Int deriving stock (Eq, Show) @@ -21,14 +21,14 @@ infixr1Tests = testGroup "infixr1 should" [ testCase "correctly accept the use of a wrapping function" do let p = infixr1 Num ("1" $> 1) ("+" $> Add) - parseAll p "1+1+1" @?= Success (Add 1 (Add 1 (Num 1))) - parseAll p "1" @?= Success (Num 1) + testParseAll p "1+1+1" @?= Success (Add 1 (Add 1 (Num 1))) + testParseAll p "1" @?= Success (Num 1) ] infixl1Tests :: TestTree infixl1Tests = testGroup "infixl1 should" [ testCase "correctly accept the use of a wrapping function" do let p = infixl1 Num ("1" $> 1) ("-" $> Sub) - parseAll p "1-1-1" @?= Success (Sub (Sub (Num 1) 1) 1) - parseAll p "1" @?= Success (Num 1) + testParseAll p "1-1-1" @?= Success (Sub (Sub (Num 1) 1) 1) + testParseAll p "1" @?= Success (Num 1) ] diff --git a/test/Text/Gigaparsec/ExprTests.hs b/test/Text/Gigaparsec/ExprTests.hs --- a/test/Text/Gigaparsec/ExprTests.hs +++ b/test/Text/Gigaparsec/ExprTests.hs @@ -9,7 +9,7 @@ import Text.Gigaparsec.Expr import Text.Gigaparsec.Expr.Subtype -import Text.Gigaparsec.Internal.Test (parseAll) +import Text.Gigaparsec.Internal.Test (testParseAll) import Text.Gigaparsec.Internal.PlainString () import Data.Char (digitToInt) @@ -46,47 +46,47 @@ [ testCase "result in correct precedence" do let expr = precedence' (digitToInt <$> digit) [ ops InfixL ["*" $> (*)] , ops InfixL ["+" $> (+)]] - parseAll expr "1+2*3+4" @?= Success 11 - parseAll expr "1*2+3*4" @?= Success 14 + testParseAll expr "1+2*3+4" @?= Success 11 + testParseAll expr "1*2+3*4" @?= Success 14 , testCase "work for multiple operators at the same level" do let expr = precedence' (digitToInt <$> digit) [ops InfixL ["+" $> (+), "-" $> (-)]] - parseAll expr "1+2-3+4" @?= Success 4 - parseAll expr "1-2+3-4" @?= Success (-2) + testParseAll expr "1+2-3+4" @?= Success 4 + testParseAll expr "1-2+3-4" @?= Success (-2) , testCase "work for mixed associativity operators" do let expr = precedence' (digitToInt <$> digit) [ ops InfixL ["*" $> (*)] , ops InfixR ["+" $> (+)]] - parseAll expr "1+2*3+4" @?= Success 11 - parseAll expr "1*2+3*4" @?= Success 14 + testParseAll expr "1+2*3+4" @?= Success 11 + testParseAll expr "1*2+3*4" @?= Success 14 , testCase "parse mathematical expressions" do let expr = precedence' (digitToInt <$> digit <|> "(" *> expr <* ")") [ ops Prefix ["-" $> negate] , ops InfixL ["/" $> div] , ops InfixR ["*" $> (*)] , ops InfixL ["+" $> (+), "-" $> (-)]] - parseAll expr "(2+3)*8" @?= Success 40 - parseAll expr "-3+4" @?= Success 1 - parseAll expr "-(3+4)" @?= Success (-7) - parseAll expr "(3+-7)*(-2--4)/2" @?= Success (-4) + testParseAll expr "(2+3)*8" @?= Success 40 + testParseAll expr "-3+4" @?= Success 1 + testParseAll expr "-(3+4)" @?= Success (-7) + testParseAll expr "(3+-7)*(-2--4)/2" @?= Success (-4) , testCase "parse prefix operators mixed with infix operators" do let expr = precedence' (digitToInt <$> digit <|> "(" *> expr <* ")") [ ops Prefix ["-" $> negate] , ops InfixL ["-" $> (-)]] - parseAll expr "-1" @?= Success (-1) - parseAll expr "2-1" @?= Success 1 - parseAll expr "-2-1" @?= Success (-3) - parseAll expr "-(2-1)" @?= Success (-1) - parseAll expr "(-0)-1" @?= Success (-1) + testParseAll expr "-1" @?= Success (-1) + testParseAll expr "2-1" @?= Success 1 + testParseAll expr "-2-1" @?= Success (-3) + testParseAll expr "-(2-1)" @?= Success (-1) + testParseAll expr "(-0)-1" @?= Success (-1) , testCase "be able to parse prefix operators weaker than an infix" do let expr = precedence' ("." $> Unit) [ ops InfixL [";" $> Bin] , ops Prefix ["~" $> Un]] - parseAll expr "~.;." @?= Success (Un (Bin Unit Unit)) + testParseAll expr "~.;." @?= Success (Un (Bin Unit Unit)) , testCase "generalise to sub-typed structures" do let expr = precedence $ sops InfixN ["<" $> Less] +< sops InfixL ["+" $> Add] +< sops InfixR ["*" $> Mul] +< sops Prefix ["-" $> Neg] +< Atom (Num . digitToInt <$> digit <|> "(" *> (Parens <$> expr) <* ")") - parseAll expr "(7+8)*2+3+6*2" @?= + testParseAll expr "(7+8)*2+3+6*2" @?= Success (upcast (Add (Add (upcast (Mul (upcast (Parens (upcast (Add (upcast (Num 7)) (upcast (Num 8)))))) (upcast (Num 2)))) @@ -98,7 +98,7 @@ +< gops InfixR OfFactor ["*" $> Mul] +< gops Prefix OfAtom ["-" $> Neg] +< Atom (Num . digitToInt <$> digit <|> "(" *> (Parens <$> expr) <* ")") - parseAll expr "(7+8)*2+3+6*2<4" @?= + testParseAll expr "(7+8)*2+3+6*2<4" @?= Success (Less (Add (Add (upcast (Mul (upcast (Parens (upcast (Add (upcast (Num 7)) (upcast (Num 8)))))) (upcast (Num 2)))) @@ -111,7 +111,7 @@ >+ gops InfixL OfFactor ["*" $> Mul'] >+ gops InfixL OfTerm ["+" $> Add] >+ gops InfixN OfExpr ["<" $> Less] - parseAll expr "1*(2+3)" @?= + testParseAll expr "1*(2+3)" @?= Success (upcast (Mul' (upcast (Num 1)) (upcast (Parens (upcast (Add (upcast (Num 2)) (upcast (Num 3)))))))) diff --git a/test/Text/Gigaparsec/Internal/Test.hs b/test/Text/Gigaparsec/Internal/Test.hs --- a/test/Text/Gigaparsec/Internal/Test.hs +++ b/test/Text/Gigaparsec/Internal/Test.hs @@ -1,9 +1,13 @@ -- A collection of test helpers -{-# LANGUAGE StandaloneDeriving, AllowAmbiguousTypes #-} +{-# LANGUAGE AllowAmbiguousTypes, RecordWildCards #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use newtype instead of data" #-} module Text.Gigaparsec.Internal.Test where import Test.Tasty.HUnit +import Text.Gigaparsec.Internal.TestError + import Text.Gigaparsec import Text.Gigaparsec.Internal import Text.Gigaparsec.Internal.RT @@ -12,28 +16,29 @@ import Control.Monad (unless, forM_) import Type.Reflection (typeOf, typeRep) --- don't @ me -deriving stock instance Eq State -deriving stock instance Show State +data LiftedState = Lifted State -parseAll :: Parsec a -> String -> Result a -parseAll p inp = parse (p <* eof) inp +testParse :: Parsec a -> String -> Result TestError a +testParse = parse @TestError +testParseAll :: Parsec a -> String -> Result TestError a +testParseAll p = testParse (p <* eof) + -- TODO: could we use quick-check to generate states? -- | Tests to ensure that running the parser on the given string does nothing to the state pureParseWith :: HasCallStack => Parsec a -> String -> Assertion pureParseWith (Parsec p) inp = do run initSt - run (initSt { consumed = True }) + run (initSt { consumed = 1 }) run (initSt { line = 10, col = 20 }) - run (initSt { consumed = True, line = 10, col = 20 }) + run (initSt { consumed = 200, line = 10, col = 20 }) where initSt = emptyState inp run :: State -> Assertion run st = do - let st' = runRT (p st (\ !_ -> return) return) - unless (st == st') $ + let st' = runRT (p st (\ !_ s -> return (Lifted s)) (\ _ s -> return (Lifted s))) + unless (Lifted st == st') $ assertFailure ("expected no change to internal state\n" - ++ "initial state: " ++ show st ++ "\n became: " ++ show st') + ++ "initial state: " ++ show (Lifted st) ++ "\n became: " ++ show st') -- TODO: could we use quick-check to generate inputs? -- | Tests to ensure that running the parser does nothing to the state @@ -55,7 +60,7 @@ run :: State -> Assertion run st = do let st' = parseState p st - assertBool (show st ++ " should be altered") (st' /= st) + assertBool (show (Lifted st) ++ " should be altered") (st' /= Lifted st) -- TODO: could we use quick-check to generate inputs? -- | Tests to ensure that running the parser does something to the state @@ -66,10 +71,10 @@ impureParseWith p ":@279" consume :: a -> Parsec a -consume x = Parsec $ \st good _ -> good x (st { consumed = True}) +consume x = Parsec $ \st good _ -> good x (st { consumed = consumed st + 1}) ensureFails :: (Show a, HasCallStack) => Parsec a -> String -> Assertion -ensureFails p inp = case parse p inp of +ensureFails p inp = case testParse p inp of Failure{} -> return () Success x -> assertFailure ("parser must fail, but produced: " ++ show x) @@ -91,9 +96,33 @@ qSt = parseState q st unless (pSt == qSt) $ assertFailure ("expected both parsers have the same effect on the state" - ++ "\ninitial state: " ++ show st + ++ "\ninitial state: " ++ show (Lifted st) ++ "\n got: " ++ show pSt ++ "\n expected: " ++ show qSt) -parseState :: Parsec a -> State -> State -parseState (Parsec p) st = runRT (p st (\ !_ -> return) return) +parseState :: Parsec a -> State -> LiftedState +parseState (Parsec p) st = runRT (p st (\ !_ st' -> return (Lifted st')) (\ _ st' -> return (Lifted st'))) + +-- don't @ me +instance Eq LiftedState where + (==) :: LiftedState -> LiftedState -> Bool + Lifted (State input1 consumed1 line1 col1 _hintValidOffset1 _hints1) == + Lifted (State input2 consumed2 line2 col2 _hintValidOffset2 _hints2) = + consumed1 == consumed2 && line1 == line2 && col1 == col2 && input1 == input2 + -- this throws off a whole bunch of tests, understandably + -- && hintValidOffset1 == hintValidOffset2 && hints1 == hints2 +instance Show LiftedState where + showsPrec :: Int -> LiftedState -> ShowS + showsPrec p (Lifted State{..}) = showParen (p > 10) $ showString "State { input = " + . shows input + . showString ", consumed = " + . shows consumed + . showString ", line = " + . shows line + . showString ", col = " + . shows col + . showString ", hintsValidOffset = " + . shows hintsValidOffset + . showString ", hints = " + . shows hints + . showChar '}' diff --git a/test/Text/Gigaparsec/Internal/TestError.hs b/test/Text/Gigaparsec/Internal/TestError.hs new file mode 100644 --- /dev/null +++ b/test/Text/Gigaparsec/Internal/TestError.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE TypeFamilies #-} +module Text.Gigaparsec.Internal.TestError ( + TestError(..), TestErrorLines(..), TestErrorItem(..) + ) where + +import Text.Gigaparsec.Errors.ErrorBuilder hiding (Token(..)) +import Text.Gigaparsec.Errors.ErrorBuilder qualified as Token + +import Data.Set (Set) +import Data.List.NonEmpty (NonEmpty) +import Data.Set qualified as Set (fromList) +import Data.List.NonEmpty qualified as NonEmpty (take) + +data TestError = TestError !(Word, Word) !TestErrorLines deriving stock (Eq, Show, Ord) +data TestErrorLines = VanillaError !(Maybe TestErrorItem) !(Set TestErrorItem) !(Set String) !Word + | SpecialisedError !(Set String) !Word deriving stock (Eq, Show, Ord) +data TestErrorItem = Raw !String | Named !String | EndOfInput deriving stock (Eq, Show, Ord) + +instance ErrorBuilder TestError where + format p _ = TestError p + + type Position TestError = (Word, Word) + pos = (,) + + type Source TestError = () + source = const () + + type ErrorInfoLines TestError = TestErrorLines + vanillaError = VanillaError + specialisedError = SpecialisedError + + type ExpectedItems TestError = Set TestErrorItem + combineExpectedItems = id + + type Messages TestError = Set String + combineMessages = Set.fromList + + type UnexpectedLine TestError = Maybe TestErrorItem + unexpected = id + type ExpectedLine TestError = Set TestErrorItem + expected = id + + type Message TestError = String + reason = id + message = id + + type LineInfo TestError = Word + lineInfo _ _ _ _ width = width + + numLinesBefore = 2 + numLinesAfter = 2 + + type Item TestError = TestErrorItem + raw = Raw + named = Named + endOfInput = EndOfInput + + unexpectedToken :: NonEmpty Char -> Word -> Bool -> Token.Token + unexpectedToken cs demanded _ = Token.Raw (NonEmpty.take (fromIntegral demanded) cs) diff --git a/test/Text/Gigaparsec/PrimitiveTests.hs b/test/Text/Gigaparsec/PrimitiveTests.hs --- a/test/Text/Gigaparsec/PrimitiveTests.hs +++ b/test/Text/Gigaparsec/PrimitiveTests.hs @@ -33,14 +33,14 @@ eofTests :: TestTree eofTests = testGroup "eof should" [ testCase "fail if input available" do ensureFails eof "a" - , testCase "succeed if input ended" do parse eof "" @?= Success () + , testCase "succeed if input ended" do testParse eof "" @?= Success () , testCase "be pure" do pureParse eof ] pureTests :: TestTree pureTests = testGroup "pure should" [ testCase "be pure" do pureParse unit - , testCase "produce the given result" do parse unit "" @?= Success () + , testCase "produce the given result" do testParse unit "" @?= Success () ] emptyTests :: TestTree @@ -71,8 +71,8 @@ , testCase "be impure if the left-hand side is impure and succeeds" do impureParse (consume () <|> empty) , testCase "succeed if the left-hand side succeeds" do - parse (unit <|> empty) "" @?= Success () - parse (consume () <|> empty) "" @?= Success () + testParse (unit <|> empty) "" @?= Success () + testParse (consume () <|> empty) "" @?= Success () , testCase "be pure if the right-hand side succeeds purely" do pureParse (empty <|> unit) , testCase "be impure if the right-hand side succeeds impurely" do @@ -95,8 +95,8 @@ , testCase "be pure if the argument fails, even if impure" do pureParse (atomic (consume () <**> empty)) , testCase "not alter failure characteristics of argument" do - parse (atomic (consume ())) "" @?= Success () - parse (atomic unit) "" @?= Success () + testParse (atomic (consume ())) "" @?= Success () + testParse (atomic unit) "" @?= Success () ensureFails @Void (atomic empty) "" ensureFails (atomic (consume () <* empty)) "" ] @@ -112,8 +112,8 @@ , testCase "be impure if the argument is impure and fails" do impureParse (lookAhead (consume () <* empty)) , testCase "not alter failure characteristics of argument" do - parse (lookAhead (pure 7)) "" @?= Success 7 - parse (lookAhead (consume 14)) "" @?= Success 14 + testParse (lookAhead (pure 7)) "" @?= Success 7 + testParse (lookAhead (consume 14)) "" @?= Success 14 ensureFails @Void (lookAhead empty) "" ensureFails (lookAhead (consume () <* empty)) "" ] @@ -127,8 +127,8 @@ pureParse (notFollowedBy (consume ())) pureParse (notFollowedBy (consume () *> empty)) , testCase "should succeed if the argument fails" do - parse (notFollowedBy empty) "" @?= Success () - parse (notFollowedBy (consume () *> empty)) "" @?= Success () + testParse (notFollowedBy empty) "" @?= Success () + testParse (notFollowedBy (consume () *> empty)) "" @?= Success () , testCase "should fail if the argument succeeds" do ensureFails (notFollowedBy unit) "" ensureFails (notFollowedBy (consume ())) ""