diff --git a/simple-parser.cabal b/simple-parser.cabal --- a/simple-parser.cabal +++ b/simple-parser.cabal @@ -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 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.* diff --git a/src/SimpleParser/Common.hs b/src/SimpleParser/Common.hs --- a/src/SimpleParser/Common.hs +++ b/src/SimpleParser/Common.hs @@ -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 diff --git a/src/SimpleParser/Errata.hs b/src/SimpleParser/Errata.hs new file mode 100644 --- /dev/null +++ b/src/SimpleParser/Errata.hs @@ -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 _ -> [] 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 @@ -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 '{' 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 @@ -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)) diff --git a/src/SimpleParser/Explain.hs b/src/SimpleParser/Explain.hs --- a/src/SimpleParser/Explain.hs +++ b/src/SimpleParser/Explain.hs @@ -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) diff --git a/src/SimpleParser/Interactive.hs b/src/SimpleParser/Interactive.hs --- a/src/SimpleParser/Interactive.hs +++ b/src/SimpleParser/Interactive.hs @@ -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 "") (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 diff --git a/src/SimpleParser/LookAhead.hs b/src/SimpleParser/LookAhead.hs --- a/src/SimpleParser/LookAhead.hs +++ b/src/SimpleParser/LookAhead.hs @@ -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] diff --git a/src/SimpleParser/Parser.hs b/src/SimpleParser/Parser.hs --- a/src/SimpleParser/Parser.hs +++ b/src/SimpleParser/Parser.hs @@ -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 diff --git a/src/SimpleParser/Result.hs b/src/SimpleParser/Result.hs --- a/src/SimpleParser/Result.hs +++ b/src/SimpleParser/Result.hs @@ -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 diff --git a/src/SimpleParser/Stack.hs b/src/SimpleParser/Stack.hs --- a/src/SimpleParser/Stack.hs +++ b/src/SimpleParser/Stack.hs @@ -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' diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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)