diff --git a/simple-parser.cabal b/simple-parser.cabal --- a/simple-parser.cabal +++ b/simple-parser.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 1d43d6b4332cdf22af4c6c459935317446659f1e7a3e9e1ff035e8447b877d50 +-- hash: 9f3603d415ba39bde869cc248fafc793d22852c365bfe638986552697a10c988 name: simple-parser -version: 0.3.0 +version: 0.5.0 synopsis: Simple parser combinators description: Please see the README on GitHub at category: Parsing @@ -44,18 +44,32 @@ Paths_simple_parser hs-source-dirs: src - default-extensions: BangPatterns ConstraintKinds DeriveFunctor DeriveFoldable DeriveTraversable DerivingStrategies FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving KindSignatures MultiParamTypeClasses TypeFamilies + default-extensions: + BangPatterns + ConstraintKinds + DeriveFunctor + DeriveFoldable + DeriveTraversable + DerivingStrategies + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GeneralizedNewtypeDeriving + KindSignatures + MultiParamTypeClasses + StandaloneDeriving + TypeFamilies ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds build-depends: base >=4.12 && <5 - , containers >=0.6 && <0.7 - , list-t >=1.0 && <1.1 - , mmorph >=1.1 && <1.2 - , mtl >=2.2 && <2.3 - , nonempty-containers >=0.3 && <0.4 - , scientific >=0.3 && <0.4 - , text >=1.2 && <1.3 - , text-builder >=0.6 && <0.7 + , containers ==0.6.* + , list-t ==1.0.* + , mmorph ==1.1.* + , mtl ==2.2.* + , nonempty-containers ==0.3.* + , scientific ==0.3.* + , text ==1.2.* + , text-builder ==0.6.* default-language: Haskell2010 test-suite simple-parser-test @@ -65,20 +79,34 @@ Paths_simple_parser hs-source-dirs: test - default-extensions: BangPatterns ConstraintKinds DeriveFunctor DeriveFoldable DeriveTraversable DerivingStrategies FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving KindSignatures MultiParamTypeClasses TypeFamilies + default-extensions: + BangPatterns + ConstraintKinds + DeriveFunctor + DeriveFoldable + DeriveTraversable + DerivingStrategies + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GeneralizedNewtypeDeriving + KindSignatures + MultiParamTypeClasses + StandaloneDeriving + TypeFamilies ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.12 && <5 - , containers >=0.6 && <0.7 - , list-t >=1.0 && <1.1 - , mmorph >=1.1 && <1.2 - , mtl >=2.2 && <2.3 - , nonempty-containers >=0.3 && <0.4 - , scientific >=0.3 && <0.4 + , containers ==0.6.* + , list-t ==1.0.* + , mmorph ==1.1.* + , mtl ==2.2.* + , nonempty-containers ==0.3.* + , scientific ==0.3.* , simple-parser , tasty , tasty-hunit , tasty-th - , text >=1.2 && <1.3 - , text-builder >=0.6 && <0.7 + , text ==1.2.* + , text-builder ==0.6.* default-language: Haskell2010 diff --git a/src/SimpleParser/Examples/Json.hs b/src/SimpleParser/Examples/Json.hs --- a/src/SimpleParser/Examples/Json.hs +++ b/src/SimpleParser/Examples/Json.hs @@ -15,12 +15,9 @@ import Data.Sequence (Seq) import Data.Text (Text) import Data.Void (Void) -import SimpleParser.Chunked (TextualChunked (..)) -import SimpleParser.Common (TextLabel, betweenParser, escapedStringParser, lexemeParser, scientificParser, sepByParser, - signedNumStartPred, spaceParser) -import SimpleParser.Input (matchChunk, matchToken, satisfyToken) -import SimpleParser.Parser (Parser, commitParser, onEmptyParser, orParser) -import SimpleParser.Stream (Stream (..), TextualStream) +import SimpleParser (Parser, Stream (..), TextLabel, TextualChunked (..), TextualStream, betweenParser, commitParser, + escapedStringParser, lexemeParser, matchChunk, matchToken, onEmptyParser, orParser, satisfyToken, + scientificParser, sepByParser, signedNumStartPred, spaceParser) data JsonF a = JsonObject !(Seq (Text, a)) diff --git a/src/SimpleParser/Examples/Sexp.hs b/src/SimpleParser/Examples/Sexp.hs --- a/src/SimpleParser/Examples/Sexp.hs +++ b/src/SimpleParser/Examples/Sexp.hs @@ -18,13 +18,10 @@ import Data.Sequence (Seq) import Data.Text (Text) import Data.Void (Void) -import SimpleParser.Chunked (Chunked (..), packChunk) -import SimpleParser.Common (EmbedTextLabel (..), TextLabel, betweenParser, decimalParser, escapedStringParser, - lexemeParser, scientificParser, sepByParser, signedNumStartPred, signedParser, spaceParser) -import SimpleParser.Explain (ExplainLabel (..)) -import SimpleParser.Input (matchToken, satisfyToken, takeTokensWhile) -import SimpleParser.Parser (Parser, commitParser, onEmptyParser, orParser) -import SimpleParser.Stream (TextualStream) +import SimpleParser (Chunked (..), EmbedTextLabel (..), ExplainLabel (..), Parser, TextLabel, TextualStream, + betweenParser, commitParser, decimalParser, escapedStringParser, lexemeParser, matchToken, + onEmptyParser, orParser, packChunk, satisfyToken, scientificParser, sepByParser, + signedNumStartPred, signedParser, spaceParser, takeTokensWhile) data Atom = AtomIdent !Text diff --git a/src/SimpleParser/Explain.hs b/src/SimpleParser/Explain.hs --- a/src/SimpleParser/Explain.hs +++ b/src/SimpleParser/Explain.hs @@ -1,7 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} -module SimpleParser.Explain where +module SimpleParser.Explain + ( ExplainLabel (..) + , ErrorExplanation (..) + , ExplainError (..) + , Explainable + , ParseErrorExplanation (..) + , explainParseError + , buildParseErrorExplanation + , buildAllParseErrorExplanations + ) where import Control.Monad (join) import Data.Foldable (toList) @@ -39,11 +48,11 @@ CompoundTextLabelText l -> explainLabel l CompoundTextLabelCustom l -> explainLabel l -data ErrorExplanation = ErrorExplanation - { eeReason :: !Builder - , eeExpected :: !(Maybe Builder) - , eeActual :: !(Maybe Builder) - } +data ErrorExplanation = ErrorExplanation + { eeReason :: !Text + , eeExpected :: !(Maybe Text) + , eeActual :: !(Maybe Text) + } deriving (Eq, Show) class ExplainError e where explainError :: e -> ErrorExplanation @@ -51,62 +60,68 @@ instance ExplainError Void where explainError = absurd -endMsg :: Builder +endMsg :: Text endMsg = "end of stream" tokB :: Char -> Builder tokB t = "token '" <> TB.char t <> "'" -mayTokB :: Maybe Char -> Builder -mayTokB = maybe endMsg tokB +tokT :: Char -> Text +tokT = TB.run . tokB +mayTokT :: Maybe Char -> Text +mayTokT = maybe endMsg tokT + chunkB :: TextualChunked chunk => chunk -> Builder chunkB k = "chunk \"" <> buildChunk k <> "\"" -mayChunkB :: TextualChunked chunk => Maybe chunk -> Builder -mayChunkB = maybe endMsg chunkB +chunkT :: TextualChunked chunk => chunk -> Text +chunkT = TB.run . chunkB +mayChunkT :: TextualChunked chunk => Maybe chunk -> Text +mayChunkT = maybe endMsg chunkT + instance (Token s ~ Char, TextualChunked (Chunk s)) => ExplainError (StreamError s) where explainError (StreamError re) = case re of RawErrorMatchEnd actTok -> - ErrorExplanation "failed to match end of stream" (Just endMsg) (Just (tokB actTok)) + ErrorExplanation "failed to match end of stream" (Just endMsg) (Just (tokT actTok)) RawErrorAnyToken -> ErrorExplanation "failed to match any token" (Just "any token") (Just endMsg) RawErrorAnyChunk -> ErrorExplanation "failed to match any chunk" (Just "any chunk") (Just endMsg) RawErrorSatisfyToken mayActTok -> - ErrorExplanation "failed to satisfy token predicate" Nothing (Just (mayTokB mayActTok)) + ErrorExplanation "failed to satisfy token predicate" Nothing (Just (mayTokT mayActTok)) RawErrorMatchToken expTok mayActTok -> - ErrorExplanation "failed to match token" (Just (tokB expTok)) (Just (mayTokB mayActTok)) + ErrorExplanation "failed to match token" (Just (tokT expTok)) (Just (mayTokT mayActTok)) RawErrorMatchChunk expChunk mayActChunk -> - ErrorExplanation "failed to match chunk" (Just (chunkB expChunk)) (Just (mayChunkB mayActChunk)) + ErrorExplanation "failed to match chunk" (Just (chunkT expChunk)) (Just (mayChunkT mayActChunk)) RawErrorTakeTokensWhile1 mayActTok -> - ErrorExplanation "failed to take 1 or more tokens" Nothing (Just (mayTokB mayActTok)) + ErrorExplanation "failed to take 1 or more tokens" Nothing (Just (mayTokT mayActTok)) RawErrorDropTokensWhile1 mayActTok -> - ErrorExplanation "failed to drop 1 or more tokens" Nothing (Just (mayTokB mayActTok)) + ErrorExplanation "failed to drop 1 or more tokens" Nothing (Just (mayTokT mayActTok)) instance (Token s ~ Char, TextualChunked (Chunk s), ExplainError e) => ExplainError (CompoundError s e) where explainError ce = case ce of CompoundErrorStream se -> explainError se - CompoundErrorFail msg -> ErrorExplanation (TB.text msg) Nothing Nothing + CompoundErrorFail msg -> ErrorExplanation msg Nothing Nothing CompoundErrorCustom e -> explainError e type Explainable l s e = (TextualStream s, ExplainLabel l, ExplainError e) data ParseErrorExplanation p = ParseErrorExplanation { peeSpan :: !(Span p) - , peeContext :: !(Seq Builder) - , peeDetails :: !(Maybe Builder) + , peeContext :: !(Seq Text) + , peeDetails :: !(Maybe Text) , peeErrExp :: !ErrorExplanation - } + } deriving (Eq, Show) explainParseError :: Explainable l s e => ParseError l s e -> ParseErrorExplanation (Pos s) explainParseError pe = let (mayLab, sp) = parseErrorNarrowestSpan pe - context = fmap explainLabel (parseErrorEnclosingLabels pe) - mayDetails = fmap explainLabel mayLab + context = fmap explainLabelText (parseErrorEnclosingLabels pe) + mayDetails = fmap explainLabelText mayLab errExp = explainError (peError pe) in ParseErrorExplanation sp context mayDetails errExp @@ -116,19 +131,19 @@ buildErrorExplanation :: Maybe Builder -> ErrorExplanation -> [Builder] buildErrorExplanation mayDetails (ErrorExplanation reason mayExpected mayActual) = join - [ ["[Reason ] " <> reason] + [ ["[Reason ] " <> TB.text reason] , maybe [] (\de -> ["[Details ] " <> de]) mayDetails - , maybe [] (\ex -> ["[Expected] " <> ex]) mayExpected - , maybe [] (\ac -> ["[Actual ] " <> ac]) mayActual + , maybe [] (\ex -> ["[Expected] " <> TB.text ex]) mayExpected + , maybe [] (\ac -> ["[Actual ] " <> TB.text ac]) mayActual ] buildParseErrorExplanation :: ParseErrorExplanation LinePos -> Builder buildParseErrorExplanation (ParseErrorExplanation sp context mayDetails errExp) = let hd = join [ ["[Pos ] " <> buildSpan sp] - , ["[Context ] || " <> TB.intercalate " |> " context | not (Seq.null context)] + , ["[Context ] || " <> TB.intercalate " |> " (fmap TB.text (toList context)) | not (Seq.null context)] ] - tl = buildErrorExplanation mayDetails errExp + tl = buildErrorExplanation (fmap TB.text mayDetails) errExp in TB.intercalate "\n" (hd ++ tl) buildAllParseErrorExplanations :: Foldable f => f (ParseErrorExplanation LinePos) -> Builder diff --git a/src/SimpleParser/Parser.hs b/src/SimpleParser/Parser.hs --- a/src/SimpleParser/Parser.hs +++ b/src/SimpleParser/Parser.hs @@ -156,8 +156,8 @@ -- | Catch only a subset of custom errors. This preserves label information vs rethrowing. catchJustParser :: Monad m => (e -> Maybe b) -> ParserT l s e m a -> (b -> ParserT l s e m a) -> ParserT l s e m a -catchJustParser filterer parser handler = ParserT (runParserT parser >=> go) where - go mres = +catchJustParser filterer parser handler = ParserT (\s0 -> runParserT parser s0 >>= go s0) where + go s0 mres = case mres of Nothing -> pure Nothing Just res -> @@ -167,34 +167,34 @@ pure mres ParseResultError es -> -- Find first custom error to handle - goSplit Empty (NESeq.toSeq es) + goSplit s0 Empty (NESeq.toSeq es) - goSplit beforeEs afterEs = + goSplit s0 beforeEs afterEs = case seqPartition extractCustomError afterEs of Nothing -> -- No next custom error, finally yield all other errors pure (maybe empty (pure . ParseResultError) (NESeq.nonEmptySeq (beforeEs <> afterEs))) Just sep -> -- Found custom error - handle it - goHandle beforeEs sep + goHandle s0 beforeEs sep - goHandle beforeEs (SeqPartition nextBeforeEs targetE (s, e) afterEs) = + goHandle s0 beforeEs (SeqPartition nextBeforeEs targetE (_, e) afterEs) = case filterer e of Nothing -> -- Not handling error; - find next custom error - goSplit (beforeEs <> (targetE :<| nextBeforeEs)) afterEs + goSplit s0 (beforeEs <> (targetE :<| nextBeforeEs)) afterEs Just b -> do - mres <- runParserT (handler b) s + mres <- runParserT (handler b) s0 case mres of Nothing -> -- No results from handled error - find next custom error - goSplit (beforeEs <> nextBeforeEs) afterEs + goSplit s0 (beforeEs <> nextBeforeEs) afterEs Just res -> case res of ParseResultSuccess _ -> pure mres ParseResultError es -> -- Add to list of errors and find next custom error - goSplit (beforeEs <> nextBeforeEs <> NESeq.toSeq es) afterEs + goSplit s0 (beforeEs <> nextBeforeEs <> NESeq.toSeq es) afterEs -- | Throws a custom error throwParser :: Monad m => e -> ParserT l s e m a