simple-parser 0.6.0 → 0.7.0

raw patch · 12 files changed

+345/−148 lines, 12 filesdep +errataPVP ok

version bump matches the API change (PVP)

Dependencies added: errata

API changes (from Hackage documentation)

Files

• simple-parser.cabal +7/−2
• src/SimpleParser/Common.hs +43/−3
• src/SimpleParser/Errata.hs +49/−0
• src/SimpleParser/Examples/Json.hs +17/−19
• src/SimpleParser/Examples/Sexp.hs +45/−23
• src/SimpleParser/Explain.hs +2/−2
• src/SimpleParser/Interactive.hs +25/−5
• src/SimpleParser/LookAhead.hs +37/−55
• src/SimpleParser/Parser.hs +17/−16
• src/SimpleParser/Result.hs +15/−1
• src/SimpleParser/Stack.hs +11/−0
• test/Main.hs +77/−22

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 4839c5f528bb2f3a48f2fbbcee91749ab73716791dc72efa365b56fefc75e6e6+-- hash: 7341b05daadfbc05dcc6e23a6a38993f95e78a160b7942b60b7d39fc93331b6e  name:           simple-parser-version:        0.6.0+version:        0.7.0 synopsis:       Simple parser combinators description:    Please see the README on GitHub at <https://github.com/ejconlon/simple-parser#readme> category:       Parsing@@ -31,6 +31,7 @@       SimpleParser       SimpleParser.Chunked       SimpleParser.Common+      SimpleParser.Errata       SimpleParser.Examples.Json       SimpleParser.Examples.Sexp       SimpleParser.Explain@@ -59,11 +60,13 @@       KindSignatures       MultiParamTypeClasses       StandaloneDeriving+      TupleSections       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.*+    , errata ==0.3.*     , list-t ==1.0.*     , mmorph ==1.1.*     , mtl ==2.2.*@@ -94,11 +97,13 @@       KindSignatures       MultiParamTypeClasses       StandaloneDeriving+      TupleSections       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.*+    , errata ==0.3.*     , list-t ==1.0.*     , mmorph ==1.1.*     , mtl ==2.2.*

@@ -15,6 +15,10 @@   , decimalParser   , signedNumStartPred   , scientificParser+  , numParser+  , Sign (..)+  , signParser+  , applySign   , signedParser   , escapedStringParser   , spanParser@@ -24,11 +28,13 @@ import Control.Monad (void) import Control.Monad.State (get, gets) import Data.Char (digitToInt, isDigit, isSpace)+import Data.Functor (($>)) import Data.List (foldl') import Data.Scientific (Scientific) import qualified Data.Scientific as Sci import SimpleParser.Chunked (Chunked (..))-import SimpleParser.Input (dropTokensWhile, dropTokensWhile1, foldTokensWhile, matchToken, takeTokensWhile1)+import SimpleParser.Input (dropTokensWhile, dropTokensWhile1, foldTokensWhile, matchToken, peekToken, popToken,+                           takeTokensWhile1) import SimpleParser.Parser (ParserT, defaultParser, greedyStarParser, optionalParser, orParser) import SimpleParser.Stream (PosStream (..), Span (..), Stream (..)) @@ -148,6 +154,38 @@   e <- defaultParser e' (exponentParser e')   pure (Sci.scientific c e) +-- | Parses a number as a literal integer or a 'Scientific' number.+-- Though 'Scientific' can represent integers, this allows you to distinugish integer literals from scientific literals+-- since that information is lost after parsing.+numParser :: (EmbedTextLabel l, Stream s, Token s ~ Char, Monad m) => ParserT l s e m (Either Integer Scientific)+numParser = do+  c' <- decimalParser+  (SP c e', b1) <- defaultParser (SP c' 0, False) (fmap (,True) (dotDecimalParser c'))+  (e, b2) <- defaultParser (e', False) (fmap (,True) (exponentParser e'))+  -- If there is no decimal or exponent, return this as an integer+  -- Otherwise return as scientific, which may be float or exponentiated integer+  if not b1 && not b2+    then pure (Left c')+    else pure (Right (Sci.scientific c e))++data Sign = SignPos | SignNeg deriving (Eq, Show)++-- | Consumes an optional + or - representing the sign of a number.+signParser :: (Stream s, Token s ~ Char, Monad m) => ParserT l s e m (Maybe Sign)+signParser = do+  mc <- peekToken+  case mc of+    Just '+' -> popToken $> Just SignPos+    Just '-' -> popToken $> Just SignNeg+    _ -> pure Nothing++-- | Optionally negate the number according to the sign (treating 'Nothing' as positive sign).+applySign :: Num a => Maybe Sign -> a -> a+applySign ms n =+  case ms of+    Just SignNeg -> negate n+    _ -> n+ -- | Parses an optional sign character followed by a number and yields a correctly-signed -- number (equivalend to Megaparsec's 'signed'). signedParser :: (Stream s, Token s ~ Char, Monad m, Num a) =>@@ -157,8 +195,10 @@   ParserT l s e m a ->   -- | Parser for signed numbers   ParserT l s e m a-signedParser spc p = defaultParser id (lexemeParser spc sign) <*> p where-  sign = orParser (id <$ matchToken '+') (negate <$ matchToken '-')+signedParser spc p = do+  ms <- signParser+  spc+  fmap (applySign ms) p  data Pair = Pair ![Char] !Bool 

@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}++module SimpleParser.Errata+  ( LinePosExplainable+  , errataParseError+  , errataParseResult+  ) where++import Control.Monad (join)+import Data.Foldable (toList)+import Data.Sequence (Seq (..))+import qualified Data.Text as T+import Errata (Block, Style, blockMerged')+import SimpleParser.Explain (ErrorExplanation (..), Explainable, ParseErrorExplanation (..), explainParseError)+import SimpleParser.Result (ParseError, ParseResult (..))+import SimpleParser.Stream (Col (..), Line (..), LinePos (..), Pos, Span (..))++type LinePosExplainable l s e = (Explainable l s e, Pos s ~ LinePos)++errataExplanation :: Style -> FilePath -> ParseErrorExplanation LinePos -> Block+errataExplanation style fp (ParseErrorExplanation sp context mayDetails  (ErrorExplanation reason mayExpected mayActual)) =+  let Span (LinePos _ (Line startLine) (Col startCol)) (LinePos _ (Line endLine) (Col endCol)) = sp+      mayLabel = Just reason+      mayHeader =+       case context of+         Empty -> Nothing+         _ -> Just (T.intercalate " > " (toList context))+      start = (startLine + 1, startCol + 1, mayLabel)+      end = (endLine + 1, endCol + 1, Nothing)+      mayBody =+        case (mayDetails, mayExpected, mayActual) of+          (Nothing, Nothing, Nothing) -> Nothing+          _ -> Just $ T.unlines $ join+            [ maybe [] (\de -> ["[Details ] " <> de]) mayDetails+            , maybe [] (\ex -> ["[Expected] " <> ex]) mayExpected+            , maybe [] (\ac -> ["[Actual  ] " <> ac]) mayActual+            ]+  in blockMerged' style fp mayHeader start end mayLabel mayBody++errataParseError :: LinePosExplainable l s e => Style -> FilePath -> ParseError l s e -> Block+errataParseError style fp pe =+  let pee = explainParseError pe+  in errataExplanation style fp pee++errataParseResult :: LinePosExplainable l s e => Style -> FilePath -> ParseResult l s e a -> [Block]+errataParseResult style fp pr =+  case pr of+    ParseResultError errs -> fmap (errataParseError style fp) (toList errs)+    ParseResultSuccess _ -> []

@@ -14,10 +14,9 @@ import Data.Sequence (Seq) import Data.Text (Text) import Data.Void (Void)-import SimpleParser (DefaultCase (..), MatchBlock (..), MatchCase (..), Parser, PureMatchBlock, Stream (..), TextLabel,-                     TextualChunked (..), TextualStream, betweenParser, escapedStringParser, lexemeParser,-                     lookAheadMatch, matchChunk, matchToken, orParser, satisfyToken, scientificParser, sepByParser,-                     signedNumStartPred, spaceParser)+import SimpleParser (MatchBlock (..), MatchCase (..), Parser, Stream (..), TextLabel, TextualChunked (..),+                     TextualStream, anyToken, betweenParser, escapedStringParser, lexemeParser, lookAheadMatch,+                     matchChunk, matchToken, orParser, scientificParser, sepByParser, signedNumStartPred, spaceParser)  data JsonF a =     JsonObject !(Seq (Text, a))@@ -32,8 +31,6 @@  type JsonParserC s = (TextualStream s, Eq (Chunk s)) -type JsonParserB s a = PureMatchBlock TextLabel s Void a- type JsonParserM s a = Parser TextLabel s Void a  jsonParser :: JsonParserC s => JsonParserM s Json@@ -42,27 +39,28 @@ isBoolStartPred :: Char -> Bool isBoolStartPred c = c == 't' || c == 'f' -recJsonB :: JsonParserC s => JsonParserM s a -> JsonParserB s (JsonF a)-recJsonB root = MatchBlock (DefaultCase Nothing (const (fail "failed to parse json document")))-  [ MatchCase Nothing openBraceP (objectP (objectPairP root))-  , MatchCase Nothing openBracketP (arrayP root)-  , MatchCase Nothing openQuoteP stringP-  , MatchCase Nothing (void (satisfyToken Nothing signedNumStartPred)) numP-  , MatchCase Nothing (void (satisfyToken Nothing isBoolStartPred)) boolP-  , MatchCase Nothing (void (matchToken 'n')) nullP-  ]- recJsonParser :: JsonParserC s => JsonParserM s a -> JsonParserM s (JsonF a)-recJsonParser root = lookAheadMatch (recJsonB root)+recJsonParser root = lexP (lookAheadMatch block) where+  block = MatchBlock anyToken (fail "failed to parse json document")+    [ MatchCase Nothing (== '{') (objectP (objectPairP root))+    , MatchCase Nothing (== '[') (arrayP root)+    , MatchCase Nothing (== '"') stringP+    , MatchCase Nothing signedNumStartPred numP+    , MatchCase Nothing isBoolStartPred boolP+    , MatchCase Nothing (== 'n') nullP+    ]  spaceP :: JsonParserC s => JsonParserM s () spaceP = spaceParser +lexP :: JsonParserC s => JsonParserM s a -> JsonParserM s a+lexP = lexemeParser spaceP+ tokL :: JsonParserC s => Char -> JsonParserM s ()-tokL c = lexemeParser spaceP (void (matchToken c))+tokL c = lexP (void (matchToken c))  chunkL :: JsonParserC s => Text -> JsonParserM s ()-chunkL cs = lexemeParser spaceP (void (matchChunk (unpackChunk cs)))+chunkL cs = lexP (void (matchChunk (unpackChunk cs)))  openBraceP, closeBraceP, commaP, colonP, openBracketP, closeBracketP, closeQuoteP :: JsonParserC s => JsonParserM s () openBraceP = tokL '{'

@@ -11,23 +11,24 @@   , recSexpParser   ) where +import Control.Applicative (empty) import Control.Monad (void) import Data.Char (isDigit, isSpace) import Data.Scientific (Scientific) import Data.Sequence (Seq) import Data.Text (Text)+import qualified Data.Text as T import Data.Void (Void)-import SimpleParser (Chunked (..), DefaultCase (..), EmbedTextLabel (..), ExplainLabel (..), MatchBlock (..),-                     MatchCase (..), Parser, PureMatchBlock, TextLabel, TextualStream, betweenParser, commitParser,-                     decimalParser, escapedStringParser, lexemeParser, lookAheadMatch, matchToken, onEmptyParser,-                     orParser, packChunk, satisfyToken, scientificParser, sepByParser, signedNumStartPred, signedParser,-                     spaceParser, takeTokensWhile)+import SimpleParser (Chunked (..), EmbedTextLabel (..), ExplainLabel (..), MatchBlock (..), MatchCase (..), Parser,+                     TextLabel, TextualStream, anyToken, applySign, betweenParser, escapedStringParser, lexemeParser,+                     lookAheadMatch, matchToken, numParser, packChunk, popChunk, satisfyToken, sepByParser, signParser,+                     signedNumStartPred, spaceParser, takeTokensWhile)  data Atom =     AtomIdent !Text   | AtomString !Text   | AtomInt !Integer-  | AtomFloat !Scientific+  | AtomSci !Scientific   deriving (Eq, Show)  data SexpF a =@@ -38,6 +39,7 @@ data SexpLabel =     SexpLabelIdentStart   | SexpLabelEmbedText !TextLabel+  | SexpLabelCustom !Text   deriving (Eq, Show)  instance ExplainLabel SexpLabel where@@ -45,6 +47,7 @@     case sl of       SexpLabelIdentStart -> "start of identifier"       SexpLabelEmbedText tl -> explainLabel tl+      _ -> undefined  instance EmbedTextLabel SexpLabel where   embedTextLabel = SexpLabelEmbedText@@ -54,17 +57,16 @@  type SexpParserC s = TextualStream s -type SexpParserB s a = PureMatchBlock SexpLabel s Void a- type SexpParserM s a = Parser SexpLabel s Void a  sexpParser :: SexpParserC s => SexpParserM s Sexp sexpParser = let p = fmap Sexp (recSexpParser p) in p  recSexpParser :: SexpParserC s => SexpParserM s a -> SexpParserM s (SexpF a)-recSexpParser root = onEmptyParser (orParser lp ap) (fail "failed to parse sexp document") where-  lp = commitParser openParenP (fmap SexpList (listP root))-  ap = fmap SexpAtom atomP+recSexpParser root = lookAheadMatch block where+  block = MatchBlock anyToken (fmap SexpAtom atomP)+    [ MatchCase Nothing (== '(') (fmap SexpList (listP root))+    ]  nonDelimPred :: Char -> Bool nonDelimPred c = c /= '(' && c /= ')' && not (isSpace c)@@ -96,22 +98,42 @@ closeParenP :: SexpParserC s => SexpParserM s () closeParenP = lexP (void (matchToken ')')) -intP :: SexpParserC s => SexpParserM s Integer-intP = signedParser (pure ()) decimalParser+numAtomP :: SexpParserC s => SexpParserM s Atom+numAtomP = do+  ms <- signParser+  n <- numParser+  case n of+    Left i -> pure (AtomInt (applySign ms i))+    Right s -> pure (AtomSci (applySign ms s)) -floatP :: SexpParserC s => SexpParserM s Scientific-floatP = signedParser (pure ()) scientificParser+chunk1 :: SexpParserC s => SexpParserM s Text+chunk1 = do+  mc <- popChunk 2+  case mc of+    Just c | not (chunkEmpty c) -> pure (packChunk c)+    _ -> empty -atomB :: SexpParserC s => SexpParserB s Atom-atomB = MatchBlock (DefaultCase Nothing (const (fail "failed to parse sexp atom")))-  [ MatchCase Nothing (void (matchToken '"')) (fmap AtomString stringP)-  , MatchCase Nothing (void (satisfyToken Nothing signedNumStartPred)) (fmap AtomInt intP)-  , MatchCase Nothing (void (satisfyToken Nothing signedNumStartPred)) (fmap AtomFloat floatP)-  , MatchCase Nothing (void (satisfyToken Nothing identStartPred)) (fmap AtomIdent identifierP)-  ]+unaryIdentPred :: Char -> Text -> Bool+unaryIdentPred u t0 =+  case T.uncons t0 of+    Just (c0, t1) | u == c0 ->+      case T.uncons t1 of+        Just (c1, _) -> not (isDigit c1)+        Nothing -> True+    _ -> False +identAtomP :: SexpParserC s => SexpParserM s Atom+identAtomP = fmap AtomIdent identifierP+ atomP :: SexpParserC s => SexpParserM s Atom-atomP = lexP (lookAheadMatch atomB)+atomP = lexP (lookAheadMatch block) where+  block = MatchBlock chunk1 (fail "failed to parse sexp atom")+    [ MatchCase Nothing ((== '"') . T.head) (fmap AtomString stringP)+    , MatchCase Nothing (unaryIdentPred '+') identAtomP+    , MatchCase Nothing (unaryIdentPred '-') identAtomP+    , MatchCase Nothing (signedNumStartPred . T.head) numAtomP+    , MatchCase Nothing (identStartPred . T.head) identAtomP+    ]  listP :: SexpParserC s => SexpParserM s a -> SexpParserM s (Seq a) listP root = lexP (betweenParser openParenP closeParenP (sepByParser root spaceP))

@@ -140,8 +140,8 @@ buildParseErrorExplanation :: ParseErrorExplanation LinePos -> Builder buildParseErrorExplanation (ParseErrorExplanation sp context mayDetails errExp) =   let hd = join-        [ ["[Pos       ] " <> buildSpan sp]-        , ["[Context   ] || " <> TB.intercalate " |> " (fmap TB.text (toList context)) | not (Seq.null context)]+        [ ["[Pos     ] " <> buildSpan sp]+        , ["[Context ] " <> TB.intercalate " > " (fmap TB.text (toList context)) | not (Seq.null context)]         ]       tl = buildErrorExplanation (fmap TB.text mayDetails) errExp   in TB.intercalate "\n" (hd ++ tl)

@@ -1,13 +1,18 @@ {-# LANGUAGE OverloadedStrings #-}  module SimpleParser.Interactive-  ( parseInteractive+  ( ErrorStyle (..)+  , parseInteractiveStyle+  , parseInteractive   ) where  import Data.Foldable (toList) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as TIO+import qualified Data.Text.Lazy.IO as TLIO+import Errata (Errata (..), fancyStyle, prettyErrors)+import SimpleParser.Errata (errataParseError) import SimpleParser.Explain (Explainable, buildAllParseErrorExplanations, explainParseError) import SimpleParser.Input (matchEnd) import SimpleParser.Parser (Parser, runParser)@@ -15,13 +20,28 @@ import SimpleParser.Stream (LinePosStream, newLinePosStream) import qualified Text.Builder as TB -parseInteractive :: (s ~ LinePosStream Text, Explainable l s e, Show a) => Parser l s e a -> String -> IO ()-parseInteractive parser input =+data ErrorStyle =+    ErrorStyleErrata+  | ErrorStyleExplain+  deriving stock (Eq, Show)++parseInteractiveStyle :: (s ~ LinePosStream Text, Explainable l s e, Show a) => ErrorStyle -> Parser l s e a -> String -> IO ()+parseInteractiveStyle errStyle parser input =   case runParser (parser <* matchEnd) (newLinePosStream (T.pack input)) of     Nothing ->       putStrLn "No result."     Just (ParseResultError es) ->-      let b = buildAllParseErrorExplanations (fmap explainParseError (toList es))-      in TIO.putStrLn (TB.run ("Errors:\n" <> b))+      case errStyle of+        ErrorStyleErrata ->+          let blocks = fmap (errataParseError fancyStyle "<interactive>") (toList es)+              errata = Errata Nothing blocks Nothing+              pretty = prettyErrors input [errata]+          in TLIO.putStrLn pretty+        ErrorStyleExplain ->+          let b = buildAllParseErrorExplanations (fmap explainParseError (toList es))+          in TIO.putStrLn (TB.run ("Errors:\n" <> b))     Just (ParseResultSuccess (ParseSuccess _ a)) ->       putStrLn "Success:" *> print a++parseInteractive :: (s ~ LinePosStream Text, Explainable l s e, Show a) => Parser l s e a -> String -> IO ()+parseInteractive = parseInteractiveStyle ErrorStyleErrata

@@ -3,8 +3,6 @@ module SimpleParser.LookAhead   ( MatchCase (..)   , PureMatchCase-  , DefaultCase (..)-  , PureDefaultCase   , MatchBlock (..)   , PureMatchBlock   , lookAheadMatch@@ -12,59 +10,40 @@   , LookAheadTestResult (..)   , lookAheadTest   , pureLookAheadTest-  , lookAheadChunk+  , lookAheadSimple   ) where -import Control.Monad (void) import Control.Monad.Identity (Identity (runIdentity)) import Data.Sequence (Seq (..)) import Data.Sequence.NonEmpty (NESeq) import qualified Data.Sequence.NonEmpty as NESeq-import SimpleParser.Input (matchChunk)-import SimpleParser.Parser (ParserT (..), markParser)-import SimpleParser.Result (ParseError, ParseResult (..))-import SimpleParser.Stream (Stream (..))+import SimpleParser.Parser (ParserT (..), lookAheadParser, markParser)+import SimpleParser.Result (ParseResult (..), ParseSuccess (..)) -data MatchCase l s e m a = MatchCase+data MatchCase l s e m a b = MatchCase   { matchCaseLabel :: !(Maybe l)-  , matchCaseGuard :: !(ParserT l s e m ())-  , matchCaseBody :: !(ParserT l s e m a)-  }--type PureMatchCase l s e a = MatchCase l s e Identity a--data MatchMiss l s e = MatchMiss-  { matchMissLabel :: !(Maybe l)-  , matchMissErrors :: !(Maybe (NESeq (ParseError l s e)))-  }--deriving instance (Eq l, Eq s, Eq (Token s), Eq (Chunk s), Eq e) => Eq (MatchMiss l s e)-deriving instance (Show l, Show s, Show (Token s), Show (Chunk s), Show e) => Show (MatchMiss l s e)--data DefaultCase l s e m a = DefaultCase-  { defaultCaseLabel :: !(Maybe l)-  , defaultCaseHandle :: !(Seq (MatchMiss l s e) -> ParserT l s e m a)+  , matchCaseChoose :: !(a -> Bool)+  , matchCaseHandle :: !(ParserT l s e m b)   } -type PureDefaultCase l s e a = DefaultCase l s e Identity a+type PureMatchCase l s e a b = MatchCase l s e Identity a b -data MatchBlock l s e m a = MatchBlock-  { matchBlockDefault :: !(DefaultCase l s e m a)-  , matchBlockElems :: ![MatchCase l s e m a]+data MatchBlock l s e m a b = MatchBlock+  { matchBlockSelect :: !(ParserT l s e m a)+  , matchBlockDefault :: !(ParserT l s e m b)+  , matchBlockElems :: ![MatchCase l s e m a b]   } -type PureMatchBlock l s e a = MatchBlock l s e Identity a+type PureMatchBlock l s e a b = MatchBlock l s e Identity a b  -- | Parse with look-ahead for each case and follow the first that matches (or follow the default if none do).-lookAheadMatch :: Monad m => MatchBlock l s e m a -> ParserT l s e m a-lookAheadMatch (MatchBlock (DefaultCase dcl dch) mcs) = ParserT (go Empty mcs) where-  go !macc [] s = runParserT (markParser dcl (dch macc)) s-  go !macc ((MatchCase mcl mcg mcb):mcs') s = do-    mres <- runParserT mcg s-    case mres of-      Nothing -> go (macc :|> MatchMiss mcl Nothing) mcs' s-      Just (ParseResultError es) -> go (macc :|> MatchMiss mcl (Just es)) mcs' s-      Just (ParseResultSuccess _) -> runParserT (markParser mcl mcb) s+lookAheadMatch :: Monad m => MatchBlock l s e m a b -> ParserT l s e m b+lookAheadMatch (MatchBlock sel dc mcs) = lookAheadParser sel >>= go mcs where+  go [] _ = dc+  go ((MatchCase mcl mcg mch):mcs') val =+    if mcg val+      then markParser mcl mch+      else go mcs' val  data MatchPos l = MatchPos   { matchPosIndex :: !Int@@ -72,26 +51,29 @@   } deriving stock (Eq, Show)  data LookAheadTestResult l =-    LookAheadTestDefault !(Maybe l)+    LookAheadTestEmpty+  | LookAheadTestDefault   | LookAheadTestMatches !(NESeq (MatchPos l))   deriving stock (Eq, Show)  -- | Test which branches match the look-ahead. Useful to assert that your parser makes exclusive choices.-lookAheadTest :: Monad m => MatchBlock l s e m a -> s -> m (LookAheadTestResult l)-lookAheadTest (MatchBlock (DefaultCase dcl _) mcs) = go Empty 0 mcs where-  go !acc _ [] _ =-    case NESeq.nonEmptySeq acc of-      Nothing -> pure (LookAheadTestDefault dcl)-      Just ms -> pure (LookAheadTestMatches ms)-  go !acc !i ((MatchCase mcl mcg _):mcs') s = do-    mres <- runParserT mcg s+lookAheadTest :: Monad m => MatchBlock l s e m a b -> s -> m (LookAheadTestResult l)+lookAheadTest (MatchBlock sel _ mcs) = go1 where+  go1 s = do+    mres <- runParserT sel s     case mres of-      Just (ParseResultSuccess _) -> go (acc :|> MatchPos i mcl) (i + 1) mcs' s-      _ -> go acc (i + 1) mcs' s+      Just (ParseResultSuccess (ParseSuccess _ val)) -> pure (go2 Empty 0 mcs val)+      _ -> pure LookAheadTestEmpty+  go2 !acc _ [] _ = maybe LookAheadTestDefault LookAheadTestMatches (NESeq.nonEmptySeq acc)+  go2 !acc !i ((MatchCase mcl mcg _):mcs') val =+    if mcg val+      then go2 (acc :|> MatchPos i mcl) (i + 1) mcs' val+      else go2 acc (i + 1) mcs' val -pureLookAheadTest :: PureMatchBlock l s e a -> s -> LookAheadTestResult l+pureLookAheadTest :: PureMatchBlock l s e a b -> s -> LookAheadTestResult l pureLookAheadTest mb = runIdentity . lookAheadTest mb --- | Simple look-ahead that matches by chunk.-lookAheadChunk :: (Stream s, Monad m, Eq (Chunk s)) => [(Chunk s, ParserT l s e m a)] -> ParserT l s e m a -> ParserT l s e m a-lookAheadChunk ps d = lookAheadMatch (MatchBlock (DefaultCase Nothing (const d)) (fmap (\(c, p) -> MatchCase Nothing (void (matchChunk c)) p) ps))+-- | Simple look-ahead that selects a parser based on first equal prefix.+lookAheadSimple :: (Monad m, Eq a) => ParserT l s e m a -> ParserT l s e m b -> [(a, ParserT l s e m b)] -> ParserT l s e m b+lookAheadSimple sel dc pairs = lookAheadMatch (MatchBlock sel dc mcs) where+  mcs = [MatchCase Nothing (== x) p | (x, p) <- pairs]

@@ -242,30 +242,31 @@ -- | Run the parser speculatively and return results. Does not advance state or throw errors. reflectParser :: Monad m => ParserT l s e m a -> ParserT l s e m (Maybe (ParseResult l s e a)) reflectParser parser = ParserT go where-  go s0 = do-    mres <- runParserT parser s0-    pure (Just (ParseResultSuccess (ParseSuccess s0 mres)))+  go s = do+    mres <- runParserT parser s+    pure (Just (ParseResultSuccess (ParseSuccess s mres)))  -- | Removes all failures from the parse results. Catches more errors than 'catchError (const empty)' -- because this includes stream errors, not just custom errors. -- If you want more fine-grained control, use 'reflectParser' and map over the results. silenceParser :: Monad m => ParserT l s e m a -> ParserT l s e m a-silenceParser parser = ParserT (fmap (>>= go) . runParserT parser) where-  go res =-    case res of-      ParseResultError _ -> Nothing-      ParseResultSuccess _ -> Just res+silenceParser parser = ParserT (fmap go . runParserT parser) where+  go mres =+    case mres of+      Just (ParseResultSuccess _) -> mres+      _ -> Nothing --- | Yield the results of the given parser, but rewind back to the starting state in ALL cases (success and error).+-- | Yield the results of the given parser, but rewind back to the starting state. -- Note that these results may contain errors, so you may want to stifle them with 'silenceParser', for example.-lookAheadParser :: Monad m => Maybe l -> ParserT l s e m a -> ParserT l s e m a-lookAheadParser ml parser = ParserT (\s -> fmap (fmap (go s)) (runParserT parser s)) where+lookAheadParser :: Monad m => ParserT l s e m a -> ParserT l s e m a+lookAheadParser parser = ParserT (\s -> fmap (fmap (go s)) (runParserT parser s)) where   go s res =     case res of-      ParseResultError es -> ParseResultError (fmap (markParseError (Mark ml s)) es)+      ParseResultError es -> ParseResultError es       ParseResultSuccess (ParseSuccess _ a) -> ParseResultSuccess (ParseSuccess s a) --- | Yield the results of the given parser, but rewind back to the starting state on error ONLY.+-- | Push the label and current state onto the parse error mark stack.+-- Useful to delimit named sub-spans for error reporting. markParser :: Monad m => Maybe l -> ParserT l s e m a -> ParserT l s e m a markParser ml parser = ParserT (\s -> fmap (fmap (go s)) (runParserT parser s)) where   go s res =@@ -290,9 +291,9 @@       ParseResultError es -> ParseResultError (fmap unmarkParseError es)       ParseResultSuccess _ -> res --- | If the first parser succeeds in the given state, yield results from the second parser in the given--- state. This is likely the look-ahead you want. Use the first parser to check a prefix of input,--- and use the second to consume that input.+-- | If the first parser succeeds in the initial state, yield results from the second parser in the initial+-- state. This is likely the look-ahead you want, since errors from the first parser are completely ignored.+-- Use the first parser to check a prefix of input, and use the second to consume that input. commitParser :: Monad m => ParserT l s e m () -> ParserT l s e m a -> ParserT l s e m a commitParser checker parser = do   s <- get

@@ -3,10 +3,12 @@ module SimpleParser.Result   ( RawError (..)   , StreamError (..)+  , coerceStreamError   , CompoundError (..)   , Mark (..)   , ParseError (..)   , parseErrorResume+  , parseErrorLabels   , markParseError   , unmarkParseError   , parseErrorEnclosingLabels@@ -20,7 +22,7 @@ import qualified Data.Sequence as Seq import Data.Sequence.NonEmpty (NESeq (..)) import Data.Text (Text)-import SimpleParser.Stack (Stack (..), bottomStack, emptyStack, pushStack, topStack)+import SimpleParser.Stack (Stack (..), bottomStack, bottomUpStack, emptyStack, pushStack, topStack) import SimpleParser.Stream (PosStream (..), Span (..), Stream (..))  data RawError chunk token =@@ -43,6 +45,9 @@ deriving instance (Eq (Token s), Eq (Chunk s)) => Eq (StreamError s) deriving instance (Show (Token s), Show (Chunk s)) => Show (StreamError s) +coerceStreamError :: (Chunk s ~ Chunk t, Token s ~ Token t) => StreamError s -> StreamError t+coerceStreamError = StreamError . unStreamError+ data CompoundError s e =     CompoundErrorStream !(StreamError s)   | CompoundErrorFail !Text@@ -59,6 +64,10 @@  type MarkStack l s = Stack (Mark l s) +-- | Returns a sequence of labels from most general to most specific.+markStackLabels :: MarkStack l s -> Seq l+markStackLabels = bottomUpStack markLabel+ data ParseError l s e = ParseError   { peMarkStack :: !(MarkStack l s)   , peEndState :: !s@@ -70,6 +79,10 @@ parseErrorResume :: ParseError l s e -> s parseErrorResume pe = maybe (peEndState pe) markState (topStack (peMarkStack pe)) +-- | Returns the sequence of ALL labels from coarsest to finest.+parseErrorLabels :: ParseError l s e -> Seq l+parseErrorLabels = markStackLabels . peMarkStack+ -- | Updates a 'ParseError' with a resumption point. markParseError :: Mark l s -> ParseError l s e -> ParseError l s e markParseError s pe = pe { peMarkStack = pushStack s (peMarkStack pe) }@@ -85,6 +98,7 @@   (ml, startPos) = maybe (Nothing, endPos) (\(Mark mx s) -> (mx, streamViewPos s)) (bottomStack (peMarkStack pe))  -- | Returns labels enclosing the narrowest span, from coarsest to finest+-- Does NOT include the label for the narrowest span (if any). parseErrorEnclosingLabels :: ParseError l s e -> Seq l parseErrorEnclosingLabels pe =   case unStack (peMarkStack pe) of

@@ -4,6 +4,7 @@   , pushStack   , topStack   , bottomStack+  , bottomUpStack   ) where  import Data.Sequence (Seq (..))@@ -36,3 +37,13 @@   case s of     Empty -> Nothing     a :<| _ -> Just a++-- | Selects elements from the bottom of the stack to the top.+bottomUpStack :: (a -> Maybe b) -> Stack a -> Seq b+bottomUpStack f = go Empty . unStack where+  go !acc s =+    case s of+      Empty -> acc+      a :<| s' ->+        let acc' = maybe acc (acc :|>) (f a)+        in go acc' s'

@@ -1,3 +1,4 @@+{-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -6,6 +7,7 @@ import Control.Monad (void) import Data.Foldable (asum) import Data.Functor (($>))+import Data.Sequence (Seq (..)) import qualified Data.Sequence as Seq import qualified Data.Sequence.NonEmpty as NESeq import Data.String (IsString)@@ -13,6 +15,7 @@ import qualified Data.Text as T import SimpleParser import SimpleParser.Examples.Json (Json (..), JsonF (..), jsonParser)+import SimpleParser.Examples.Sexp (Atom (..), Sexp (..), SexpF (..), sexpParser) import Test.Tasty (TestName, TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) import Test.Tasty.TH (defaultMainGenerator)@@ -23,7 +26,7 @@  type TestState = OffsetStream Text -type TestBlock a = PureMatchBlock Label TestState Error a+type TestBlock a b = PureMatchBlock Label TestState Error a b  type TestParser a = Parser Label TestState Error a @@ -35,7 +38,7 @@  data ParserCase a = ParserCase !TestName !(TestParser a) !Text !(Maybe (TestResult a)) -data ExamineCase a = ExamineCase !TestName !(TestBlock a) !Text !(LookAheadTestResult Label)+data ExamineCase a b = ExamineCase !TestName !(TestBlock a b) !Text !(LookAheadTestResult Label)  fwd :: Int -> TestState -> TestState fwd n (OffsetStream (Offset i) t) =@@ -86,7 +89,7 @@   let actual = runParser parser (newOffsetStream input)   actual @?= expected -testExamineCase :: ExamineCase a -> TestTree+testExamineCase :: ExamineCase a b -> TestTree testExamineCase (ExamineCase name block input expected) = testCase name $ do   let actual = pureLookAheadTest block (newOffsetStream input)   actual @?= expected@@ -461,7 +464,7 @@  test_look_ahead_pure :: [TestTree] test_look_ahead_pure =-  let parser = lookAheadParser Nothing (pure 1) :: TestParser Int+  let parser = lookAheadParser (pure 1) :: TestParser Int       cases =         [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") 1)         , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") 1)@@ -470,9 +473,9 @@  test_look_ahead_success :: [TestTree] test_look_ahead_success =-  let parser = lookAheadParser Nothing anyToken+  let parser = lookAheadParser anyToken       cases =-        [ ParserCase "non-match empty" parser "" (errRes [markWith (OffsetStream 0 "") (anyTokErr (OffsetStream 0 ""))])+        [ ParserCase "non-match empty" parser "" (errRes [anyTokErr (OffsetStream 0 "")])         , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") 'h')         ]   in fmap testParserCase cases@@ -480,10 +483,10 @@ test_look_ahead_failure :: [TestTree] test_look_ahead_failure =   let err = Error "boo"-      parser = lookAheadParser Nothing (anyToken *> throwParser err) :: TestParser Char+      parser = lookAheadParser (anyToken *> throwParser err) :: TestParser Char       cases =-        [ ParserCase "non-match empty" parser "" (errRes [markWith (OffsetStream 0 "") (anyTokErr (OffsetStream 0 ""))])-        , ParserCase "non-empty" parser "hi" (errRes [markWith (OffsetStream 0 "hi") (custErr (OffsetStream 1 "i") err)])+        [ ParserCase "non-match empty" parser "" (errRes [anyTokErr (OffsetStream 0 "")])+        , ParserCase "non-empty" parser "hi" (errRes [custErr (OffsetStream 1 "i") err])         ]   in fmap testParserCase cases @@ -545,19 +548,19 @@         ]   in fmap testParserCase cases -simpleBlock :: TestBlock Text-simpleBlock = MatchBlock (DefaultCase (Just (Label "default")) (\misses -> pure ("n misses: " <> T.pack (show (Seq.length misses)))))-  [ MatchCase (Just (Label "match x")) (void (matchToken 'x')) (anyToken $> "found x - consuming")-  , MatchCase (Just (Label "match x dupe")) (void (matchToken 'x')) (pure "dupe x - leaving")-  , MatchCase (Just (Label "match y")) (void (matchToken 'y')) (pure "found y - leaving")+simpleBlock :: TestBlock Char Text+simpleBlock = MatchBlock anyToken (pure "default")+  [ MatchCase (Just (Label "match x")) (== 'x') (anyToken $> "found x - consuming")+  , MatchCase (Just (Label "match x dupe")) (== 'x') (pure "dupe x - leaving")+  , MatchCase (Just (Label "match y")) (== 'y') (pure "found y - leaving")   ]  test_look_ahead_match :: [TestTree] test_look_ahead_match =   let parser = lookAheadMatch simpleBlock       cases =-        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") "n misses: 3")-        , ParserCase "non-match" parser "wz" (sucRes (OffsetStream 0 "wz") "n misses: 3")+        [ ParserCase "empty" parser "" (errRes [anyTokErr (OffsetStream 0 "")])+        , ParserCase "non-match" parser "wz" (sucRes (OffsetStream 0 "wz") "default")         , ParserCase "match x" parser "xz" (sucRes (OffsetStream 1 "z") "found x - consuming")         , ParserCase "match y" parser "yz" (sucRes (OffsetStream 0 "yz") "found y - leaving")         ]@@ -568,8 +571,8 @@   let xpositions = [MatchPos 0 (Just (Label "match x")), MatchPos 1 (Just (Label "match x dupe"))]       ypositions = [MatchPos 2 (Just (Label "match y"))]       cases =-        [ ExamineCase "empty" simpleBlock "" (LookAheadTestDefault (Just (Label "default")))-        , ExamineCase "non-match" simpleBlock "wz" (LookAheadTestDefault (Just (Label "default")))+        [ ExamineCase "empty" simpleBlock "" LookAheadTestEmpty+        , ExamineCase "non-match" simpleBlock "wz" LookAheadTestDefault         , ExamineCase "match x" simpleBlock "xz" (LookAheadTestMatches (NESeq.unsafeFromSeq (Seq.fromList xpositions)))         , ExamineCase "match y" simpleBlock "yz" (LookAheadTestMatches (NESeq.unsafeFromSeq (Seq.fromList ypositions)))         ]@@ -620,13 +623,65 @@         , ("obj0", "{}", Just (objVal []))         , ("obj1", "{\"x\": true}", Just (objVal [("x", trueVal)]))         , ("obj2", "{\"x\": true, \"y\": false}", Just (objVal [("x", trueVal), ("y", falseVal)]))-        , ("num0", "0", Just (numVal (read "0")))-        , ("num1", "123", Just (numVal (read "123")))-        , ("num2", "123.45", Just (numVal (read "123.45")))+        , ("num0", "0", Just (numVal 0))+        , ("num1", "123", Just (numVal 123))+        , ("num2", "123.45", Just (numVal 123.45))         , ("num3", "1e100", Just (numVal (read "1e100")))-        , ("num4", "{\"x\": 1e100, \"y\": 123.45}", Just (objVal [("x", numVal (read "1e100")), ("y", numVal (read "123.45"))]))+        , ("num4", "{\"x\": 1e100, \"y\": 123.45}", Just (objVal [("x", numVal (read "1e100")), ("y", numVal 123.45)]))         ]   in testJsonTrees cases++type SexpResult = Maybe Sexp++testSexpCase :: TestName -> Text -> SexpResult -> TestTree+testSexpCase name str expected = testCase ("sexp " <> name) $ do+  let actual = parseSexp str+  actual @?= expected++testSexpTrees :: [(TestName, Text, SexpResult)] -> [TestTree]+testSexpTrees = fmap (\(n, s, e) -> testSexpCase n s e)++parseSexp :: Text -> SexpResult+parseSexp str =+  let p = sexpParser <* matchEnd+  in case runParser p str of+    Just (ParseResultSuccess (ParseSuccess _ a)) -> Just a+    _ -> Nothing++test_sexp :: [TestTree]+test_sexp =+  let numSexp = Sexp (SexpAtom (AtomInt 1))+      sciExpSexp = Sexp (SexpAtom (AtomSci 1))+      identSexp = Sexp (SexpAtom (AtomIdent "abc"))+      stringSexp = Sexp (SexpAtom (AtomString "xyz"))+      sciSexp = Sexp (SexpAtom (AtomSci 3.14))+      emptyList = Sexp (SexpList Empty)+      singletonList = Sexp (SexpList (Seq.singleton numSexp))+      pairList = Sexp (SexpList (Seq.fromList [numSexp, numSexp]))+      cases =+        [ ("empty", "", Nothing)+        , ("empty list", "()", Just emptyList)+        , ("singleton list", "(1)", Just singletonList)+        , ("singleton empty list", "(())", Just (Sexp (SexpList (Seq.fromList [emptyList]))))+        , ("singleton nested list", "((1))", Just (Sexp (SexpList (Seq.fromList [singletonList]))))+        , ("num", "1", Just numSexp)+        , ("num pos", "+1", Just numSexp)+        , ("num neg", "-1", Just (Sexp (SexpAtom (AtomInt -1))))+        , ("ident", "abc", Just identSexp)+        , ("string", "\"xyz\"", Just stringSexp)+        , ("sci", "3.14", Just sciSexp)+        , ("sci pos", "+3.14", Just sciSexp)+        , ("sci neg", "-3.14", Just (Sexp (SexpAtom (AtomSci -3.14))))+        , ("sci exp", "1e0", Just sciExpSexp)+        , ("sci pos exp", "+1e0", Just sciExpSexp)+        , ("sci dec exp", "1.0", Just sciExpSexp)+        , ("sci dec exp 2", "1.0e0", Just sciExpSexp)+        , ("plus", "+", Just (Sexp (SexpAtom (AtomIdent "+"))))+        , ("minus", "-", Just (Sexp (SexpAtom (AtomIdent "-"))))+        , ("multi list", "(1 abc \"xyz\" 3.14)", Just (Sexp (SexpList (Seq.fromList [numSexp, identSexp, stringSexp, sciSexp]))))+        , ("pair nested list", "((1 1) (1 1))", Just (Sexp (SexpList (Seq.fromList [pairList, pairList]))))+        ]+  in testSexpTrees cases  main :: IO () main = $(defaultMainGenerator)