diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -9,4 +9,8 @@ To lists of pairs Of things and strings. -In this case, we subsitute `ListT` for the list and add some error handling. We also swap out strings for any kind of input (streaming or not). +In this case, our lists are are little fancier. + +## License + +This project is BSD-licenced. Some gnarly functions to parse numbers and such have been adapted from Megaparsec, which is also [BSD-licensed](https://github.com/mrkkrp/megaparsec/blob/master/LICENSE.md). 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: 05dbeeb0f7613ae6d38c54b0654472b0b1d48dc401b57a41cae0dc16554fb065 +-- hash: 1d43d6b4332cdf22af4c6c459935317446659f1e7a3e9e1ff035e8447b877d50 name: simple-parser -version: 0.2.2 +version: 0.3.0 synopsis: Simple parser combinators description: Please see the README on GitHub at category: Parsing @@ -29,16 +29,22 @@ library exposed-modules: SimpleParser + SimpleParser.Chunked + SimpleParser.Common SimpleParser.Examples.Json + SimpleParser.Examples.Sexp + SimpleParser.Explain SimpleParser.Input + SimpleParser.Interactive SimpleParser.Parser SimpleParser.Result + SimpleParser.Stack SimpleParser.Stream other-modules: Paths_simple_parser hs-source-dirs: src - default-extensions: BangPatterns 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 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 @@ -46,7 +52,10 @@ , 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 default-language: Haskell2010 test-suite simple-parser-test @@ -56,7 +65,7 @@ Paths_simple_parser hs-source-dirs: test - default-extensions: BangPatterns 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 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 @@ -64,9 +73,12 @@ , 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 , simple-parser , tasty , tasty-hunit , tasty-th , text >=1.2 && <1.3 + , text-builder >=0.6 && <0.7 default-language: Haskell2010 diff --git a/src/SimpleParser.hs b/src/SimpleParser.hs --- a/src/SimpleParser.hs +++ b/src/SimpleParser.hs @@ -4,13 +4,23 @@ -- "SimpleParser.Parser" for the core transformer, "SimpleParser.Stream" for the source abstraction, -- or "SimpleParser.Input" for useful combinators. module SimpleParser - ( module SimpleParser.Input + ( module SimpleParser.Chunked + , module SimpleParser.Common + , module SimpleParser.Explain + , module SimpleParser.Input + , module SimpleParser.Interactive , module SimpleParser.Parser , module SimpleParser.Result + , module SimpleParser.Stack , module SimpleParser.Stream ) where +import SimpleParser.Chunked +import SimpleParser.Common +import SimpleParser.Explain import SimpleParser.Input +import SimpleParser.Interactive import SimpleParser.Parser import SimpleParser.Result +import SimpleParser.Stack import SimpleParser.Stream diff --git a/src/SimpleParser/Chunked.hs b/src/SimpleParser/Chunked.hs new file mode 100644 --- /dev/null +++ b/src/SimpleParser/Chunked.hs @@ -0,0 +1,84 @@ +module SimpleParser.Chunked + ( Chunked (..) + , TextualChunked (..) + ) where + +import Data.Foldable (toList) +import Data.List (uncons) +import Data.Sequence (Seq (..)) +import qualified Data.Sequence as Seq +import Data.Text (Text) +import qualified Data.Text as T +import Text.Builder (Builder) +import qualified Text.Builder as TB + +-- | 'Chunked' captures the basic relationship between tokens and chunks of them. +-- Basically, these things behave like lists, sequences, text, etc. +class Monoid chunk => Chunked chunk token | chunk -> token where + consChunk :: token -> chunk -> chunk + unconsChunk :: chunk -> Maybe (token, chunk) + tokenToChunk :: token -> chunk + tokensToChunk :: [token] -> chunk + chunkToTokens :: chunk -> [token] + chunkLength :: chunk -> Int + chunkEmpty :: chunk -> Bool + + -- | Some datatypes (like 'Seq') may admit a "better" implementation + -- for building a chunk in reverse. + revTokensToChunk :: [token] -> chunk + revTokensToChunk = tokensToChunk . reverse + +-- | Captures textual streams. +class Chunked chunk Char => TextualChunked chunk where + buildChunk :: chunk -> Builder + packChunk :: chunk -> Text + packChunk = TB.run . buildChunk + unpackChunk :: Text -> chunk + +-- TODO(ejconlon) Add instances for Strict BS, Lazy BS, and Lazy Text + +instance Chunked [a] a where + consChunk = (:) + unconsChunk = uncons + tokenToChunk a = [a] + tokensToChunk = id + chunkToTokens = id + chunkLength = length + chunkEmpty = null + +instance (a ~ Char) => TextualChunked [a] where + buildChunk = TB.string + packChunk = T.pack + unpackChunk = T.unpack + +instance Chunked (Seq a) a where + consChunk = (:<|) + unconsChunk s = + case s of + Empty -> Nothing + a :<| b -> Just (a, b) + tokenToChunk = Seq.singleton + tokensToChunk = Seq.fromList + chunkToTokens = toList + chunkLength = Seq.length + chunkEmpty = Seq.null + revTokensToChunk = foldr (flip (:|>)) Empty + +instance (a ~ Char) => TextualChunked (Seq a) where + buildChunk = TB.string . toList + packChunk = T.pack . toList + unpackChunk = Seq.fromList . T.unpack + +instance Chunked Text Char where + consChunk = T.cons + unconsChunk = T.uncons + tokenToChunk = T.singleton + tokensToChunk = T.pack + chunkToTokens = T.unpack + chunkLength = T.length + chunkEmpty = T.null + +instance TextualChunked Text where + buildChunk = TB.text + packChunk = id + unpackChunk = id diff --git a/src/SimpleParser/Common.hs b/src/SimpleParser/Common.hs new file mode 100644 --- /dev/null +++ b/src/SimpleParser/Common.hs @@ -0,0 +1,199 @@ +-- | Common parsers. +-- See . +module SimpleParser.Common + ( TextLabel (..) + , EmbedTextLabel (..) + , CompoundTextLabel (..) + , sepByParser + , betweenParser + , lexemeParser + , newlineParser + , spaceParser + , hspaceParser + , spaceParser1 + , hspaceParser1 + , decimalParser + , signedNumStartPred + , scientificParser + , signedParser + , escapedStringParser + , spanParser + , getStreamPos + ) where + +import Control.Monad (void) +import Control.Monad.State (get, gets) +import Data.Char (digitToInt, isDigit, isSpace) +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.Parser (ParserT, defaultParser, greedyStarParser, optionalParser, orParser) +import SimpleParser.Stream (Span (..), Stream (..)) + +-- | Enumeration of common labels in textual parsing. +data TextLabel = + TextLabelSpace + | TextLabelHSpace + | TextLabelDigit + deriving (Eq, Show) + +class EmbedTextLabel l where + embedTextLabel :: TextLabel -> l + +instance EmbedTextLabel TextLabel where + embedTextLabel = id + +-- | Union of text and custom labels +data CompoundTextLabel l = + CompoundTextLabelText !TextLabel + | CompoundTextLabelCustom !l + deriving (Eq, Show, Functor, Foldable, Traversable) + +instance EmbedTextLabel (CompoundTextLabel l) where + embedTextLabel = CompoundTextLabelText + +-- | Yields the maximal list of separated items. May return an empty list. +sepByParser :: (Chunked seq elem, Monad m) => + -- | How to parse item + ParserT l s e m elem -> + -- | How to parse separator + ParserT l s e m () -> + ParserT l s e m seq +sepByParser thing sep = do + ma <- optionalParser thing + case ma of + Nothing -> pure mempty + Just a -> do + as <- greedyStarParser (sep *> thing) + pure (consChunk a as) + +-- | Parses between start and end markers. +betweenParser :: Monad m => + -- | How to parse start + ParserT l s e m () -> + -- | How to parse end + ParserT l s e m () -> + -- | How to parse inside + ParserT l s e m a -> + ParserT l s e m a +betweenParser start end thing = do + start + a <- thing + end + pure a + +-- | A wrapper for lexemes (equivalent to Megaparsec's 'lexeme'). +lexemeParser :: Monad m => + -- | How to consume white space after lexeme + ParserT l s e m () -> + -- | How to parse actual lexeme + ParserT l s e m a -> + ParserT l s e m a +lexemeParser spc p = p <* spc + +-- | Consumes a newline character. +newlineParser :: (Stream s, Token s ~ Char, Monad m) => ParserT l s e m () +newlineParser = void (matchToken '\n') + +-- | Consumes 0 or more space characters. +spaceParser :: (Stream s, Token s ~ Char, Monad m) => ParserT l s e m () +spaceParser = void (dropTokensWhile isSpace) + +isHSpace :: Char -> Bool +isHSpace c = isSpace c && c /= '\n' && c /= '\r' + +-- | Consumes 0 or more non-line-break space characters +hspaceParser :: (Stream s, Token s ~ Char, Monad m) => ParserT l s e m () +hspaceParser = void (dropTokensWhile isHSpace) + +-- | Consumes 1 or more space characters. +spaceParser1 :: (EmbedTextLabel l, Stream s, Token s ~ Char, Monad m) => ParserT l s e m () +spaceParser1 = void (dropTokensWhile1 (Just (embedTextLabel TextLabelSpace)) isSpace) + +-- | Consumes 1 or more non-line-break space characters +hspaceParser1 :: (EmbedTextLabel l, Stream s, Token s ~ Char, Monad m) => ParserT l s e m () +hspaceParser1 = void (dropTokensWhile1 (Just (embedTextLabel TextLabelHSpace)) isHSpace) + +-- | Parses an integer in decimal representation (equivalent to Megaparsec's 'decimal'). +decimalParser :: (EmbedTextLabel l, Stream s, Token s ~ Char, Monad m, Num a) => ParserT l s e m a +decimalParser = fmap mkNum (takeTokensWhile1 (Just (embedTextLabel TextLabelDigit)) isDigit) where + mkNum = foldl' step 0 . chunkToTokens + step a c = a * 10 + fromIntegral (digitToInt c) + +data SP = SP !Integer !Int + +dotDecimalParser :: (EmbedTextLabel l, Stream s, Token s ~ Char, Monad m) => Integer -> ParserT l s e m SP +dotDecimalParser c' = do + void (matchToken '.') + let mkNum = foldl' step (SP c' 0) . chunkToTokens + step (SP a e') c = SP (a * 10 + fromIntegral (digitToInt c)) (e' - 1) + fmap mkNum (takeTokensWhile1 (Just (embedTextLabel TextLabelDigit)) isDigit) + +exponentParser :: (EmbedTextLabel l, Stream s, Token s ~ Char, Monad m) => Int -> ParserT l s e m Int +exponentParser e' = do + void (orParser (matchToken 'e') (matchToken 'E')) + fmap (+ e') (signedParser (pure ()) decimalParser) + +-- | Predicate for satisfying the start of signed numbers +signedNumStartPred :: Char -> Bool +signedNumStartPred c = isDigit c || c == '+' || c == '-' + +-- | Parses a floating point value as a 'Scientific' number (equivalent to Megaparsec's 'scientific'). +scientificParser :: (EmbedTextLabel l, Stream s, Token s ~ Char, Monad m) => ParserT l s e m Scientific +scientificParser = do + c' <- decimalParser + SP c e' <- defaultParser (SP c' 0) (dotDecimalParser c') + e <- defaultParser e' (exponentParser e') + pure (Sci.scientific c e) + +-- | 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) => + -- | How to consume white space after the sign + ParserT l s e m () -> + -- | How to parse the number itself + 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 '-') + +data Pair = Pair ![Char] !Bool + +-- | Given a quote charcter (like a single or double quote), yields the contents of the +-- string bounded by those quotes. The contents may contain backslash-escaped quotes. +-- Returns nothing if outside quotes are missing or the stream ends before unquote. +escapedStringParser :: (Stream s, Token s ~ Char, Monad m) => Char -> ParserT l s e m (Chunk s) +escapedStringParser quoteChar = + let quoteParser = void (matchToken quoteChar) + accParser = foldTokensWhile go (Pair [] False) + innerParser = fmap (\(Pair acc _) -> revTokensToChunk acc) accParser + escChar = '\\' + go c (Pair acc esc) + | c == escChar = + if esc + then (True, Pair (escChar:acc) False) -- Was escaped escape, append one + else (True, Pair acc True) -- Skip appending this esc + | c == quoteChar = + if esc + then (True, Pair (c:acc) False) -- Escaped quote + else (False, Pair acc False) -- End of quote + | otherwise = + if esc + then (True, Pair (c:escChar:acc) False) -- Was a non-quote esc, append both + else (True, Pair (c:acc) False) -- Just consume char + in betweenParser quoteParser quoteParser innerParser + +-- | Adds span information to parsed values. +spanParser :: (Stream s, Monad m) => (Span (Pos s) -> a -> b) -> ParserT l s e m a -> ParserT l s e m b +spanParser f p = do + start <- get + val <- p + end <- get + pure (f (Span (streamViewPos start) (streamViewPos end)) val) + +-- | Gets the current stream position +getStreamPos :: (Stream s, Monad m) => ParserT l s e m (Pos s) +getStreamPos = gets streamViewPos 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 @@ -3,131 +3,108 @@ module SimpleParser.Examples.Json ( Json (..) , JsonF (..) - , parseJson + , JsonParserC + , JsonParserM + , jsonParser + , recJsonParser ) where -import Control.Applicative (empty) import Control.Monad (void) -import Data.Char (isSpace) +import Data.Foldable (asum) +import Data.Scientific (Scientific) +import Data.Sequence (Seq) import Data.Text (Text) import Data.Void (Void) -import SimpleParser +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) --- JSON without numbers... data JsonF a = - JsonObject ![(String, a)] - | JsonArray ![a] - | JsonString !String + JsonObject !(Seq (Text, a)) + | JsonArray !(Seq a) + | JsonString !Text | JsonBool !Bool + | JsonNum !Scientific | JsonNull deriving (Eq, Show, Functor, Foldable, Traversable) newtype Json = Json { unJson :: JsonF Json } deriving (Eq, Show) -type JsonParser a = Parser Void Text a - -parseJson :: Text -> [Json] -parseJson str = do - ParseResult v _ <- runParser (jsonParser <* matchEnd) str - case v of - ParseSuccess a -> pure a +type JsonParserC s = (TextualStream s, Eq (Chunk s)) -jsonSpace :: JsonParser () -jsonSpace = greedyStarParser_ (void (satisfyToken isSpace)) +type JsonParserM s a = Parser TextLabel s Void a -jsonLexeme :: JsonParser () -> JsonParser a -> JsonParser a -jsonLexeme spaceAfter thing = do - a <- thing - spaceAfter - pure a +jsonParser :: JsonParserC s => JsonParserM s Json +jsonParser = let p = fmap Json (recJsonParser p) in p -jsonBetween :: JsonParser () -> JsonParser () -> JsonParser a -> JsonParser a -jsonBetween start end thing = do - start - a <- thing - end - pure a +isBoolStartPred :: Char -> Bool +isBoolStartPred c = c == 't' || c == 'f' -jsonSepBy :: JsonParser a -> JsonParser () -> JsonParser [a] -jsonSepBy thing sep = go [] where - optThing = optionalParser thing - optSep = optionalParser sep - go !acc = do - ma <- optThing - case ma of - Nothing -> if null acc then pure [] else empty - Just a -> do - let newAcc = a:acc - ms <- optSep - case ms of - Nothing -> pure (reverse newAcc) - Just () -> go newAcc +recJsonParser :: JsonParserC s => JsonParserM s a -> JsonParserM s (JsonF a) +recJsonParser root = onEmptyParser (asum opts) (fail "failed to parse json document") where + pairP = objectPairP root + opts = + [ commitParser openBraceP (objectP pairP) + , commitParser openBracketP (arrayP root) + , commitParser openQuoteP stringP + , commitParser (void (satisfyToken Nothing signedNumStartPred)) numP + , commitParser (void (satisfyToken Nothing isBoolStartPred)) boolP + , commitParser (void (matchToken 'n')) nullP + ] -jsonCharLexeme :: Char -> JsonParser () -jsonCharLexeme c = void (jsonLexeme jsonSpace (matchToken c)) +spaceP :: JsonParserC s => JsonParserM s () +spaceP = spaceParser -jsonWordLexeme :: Text -> JsonParser () -jsonWordLexeme cs = void (jsonLexeme jsonSpace (matchChunk cs)) +tokL :: JsonParserC s => Char -> JsonParserM s () +tokL c = lexemeParser spaceP (void (matchToken c)) -openBrace, closeBrace, comma, colon, openBracket, closeBracket, closeQuote :: JsonParser () -openBrace = jsonCharLexeme '{' -closeBrace = jsonCharLexeme '}' -comma = jsonCharLexeme ',' -colon = jsonCharLexeme ':' -openBracket = jsonCharLexeme '[' -closeBracket = jsonCharLexeme ']' -closeQuote = jsonCharLexeme '"' +chunkL :: JsonParserC s => Text -> JsonParserM s () +chunkL cs = lexemeParser spaceP (void (matchChunk (unpackChunk cs))) -openQuote :: JsonParser () -openQuote = void (matchToken '"') +openBraceP, closeBraceP, commaP, colonP, openBracketP, closeBracketP, closeQuoteP :: JsonParserC s => JsonParserM s () +openBraceP = tokL '{' +closeBraceP = tokL '}' +commaP = tokL ',' +colonP = tokL ':' +openBracketP = tokL '[' +closeBracketP = tokL ']' +closeQuoteP = tokL '"' -nullTok, trueTok, falseTok :: JsonParser () -nullTok = jsonWordLexeme "null" -trueTok = jsonWordLexeme "true" -falseTok = jsonWordLexeme "false" +openQuoteP :: JsonParserC s => JsonParserM s () +openQuoteP = void (matchToken '"') -nonQuoteChar :: JsonParser Char -nonQuoteChar = satisfyToken (/= '"') +nullTokP, trueTokP, falseTokP :: JsonParserC s => JsonParserM s () +nullTokP = chunkL "null" +trueTokP = chunkL "true" +falseTokP = chunkL "false" -nonQuoteString :: JsonParser String -nonQuoteString = greedyStarParser nonQuoteChar +rawStringP :: JsonParserC s => JsonParserM s Text +rawStringP = fmap packChunk (escapedStringParser '"') -rawStringParser :: JsonParser String -rawStringParser = jsonBetween openQuote closeQuote nonQuoteString +stringP :: JsonParserC s => JsonParserM s (JsonF a) +stringP = fmap JsonString rawStringP --- TODO(ejconlon) This does not handle escape codes. Use `foldTokensWhile` for that... -stringParser :: JsonParser (JsonF a) -stringParser = fmap JsonString rawStringParser +nullP :: JsonParserC s => JsonParserM s (JsonF a) +nullP = JsonNull <$ nullTokP -nullParser :: JsonParser (JsonF a) -nullParser = JsonNull <$ nullTok +boolP :: JsonParserC s => JsonParserM s (JsonF a) +boolP = orParser (JsonBool True <$ trueTokP) (JsonBool False <$ falseTokP) -boolParser :: JsonParser (JsonF a) -boolParser = isolateParser (branchParser [JsonBool True <$ trueTok, JsonBool False <$ falseTok]) +numP :: JsonParserC s => JsonParserM s (JsonF a) +numP = fmap JsonNum scientificParser -objectPairParser :: JsonParser a -> JsonParser (String, a) -objectPairParser root = do - name <- rawStringParser - colon +objectPairP :: JsonParserC s => JsonParserM s a -> JsonParserM s (Text, a) +objectPairP root = do + name <- rawStringP + colonP value <- root pure (name, value) -objectParser :: JsonParser (String, a) -> JsonParser (JsonF a) -objectParser pairParser = jsonBetween openBrace closeBrace (fmap JsonObject (jsonSepBy pairParser comma)) - -arrayParser :: JsonParser a -> JsonParser (JsonF a) -arrayParser root = jsonBetween openBracket closeBracket (fmap JsonArray (jsonSepBy root comma)) - -rootParser :: JsonParser a -> JsonParser (JsonF a) -rootParser root = isolateParser (branchParser opts) where - pairParser = objectPairParser root - opts = - [ objectParser pairParser - , arrayParser root - , stringParser - , boolParser - , nullParser - ] +objectP :: JsonParserC s => JsonParserM s (Text, a) -> JsonParserM s (JsonF a) +objectP pairP = betweenParser openBraceP closeBraceP (fmap JsonObject (sepByParser pairP commaP)) -jsonParser :: JsonParser Json -jsonParser = let p = fmap Json (rootParser p) in p +arrayP :: JsonParserC s => JsonParserM s a -> JsonParserM s (JsonF a) +arrayP root = betweenParser openBracketP closeBracketP (fmap JsonArray (sepByParser root commaP)) diff --git a/src/SimpleParser/Examples/Sexp.hs b/src/SimpleParser/Examples/Sexp.hs new file mode 100644 --- /dev/null +++ b/src/SimpleParser/Examples/Sexp.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SimpleParser.Examples.Sexp + ( Sexp (..) + , SexpF (..) + , Atom (..) + , SexpLabel (..) + , SexpParserC + , SexpParserM + , sexpParser + , recSexpParser + ) where + +import Control.Monad (void) +import Data.Char (isDigit, isSpace) +import Data.Foldable (asum) +import Data.Scientific (Scientific) +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) + +data Atom = + AtomIdent !Text + | AtomString !Text + | AtomInt !Integer + | AtomFloat !Scientific + deriving (Eq, Show) + +data SexpF a = + SexpAtom !Atom + | SexpList !(Seq a) + deriving (Eq, Show, Functor, Foldable, Traversable) + +data SexpLabel = + SexpLabelIdentStart + | SexpLabelEmbedText !TextLabel + deriving (Eq, Show) + +instance ExplainLabel SexpLabel where + explainLabel sl = + case sl of + SexpLabelIdentStart -> "start of identifier" + SexpLabelEmbedText tl -> explainLabel tl + +instance EmbedTextLabel SexpLabel where + embedTextLabel = SexpLabelEmbedText + +newtype Sexp = Sexp { unSexp :: SexpF Sexp } + deriving (Eq, Show) + +type SexpParserC s = TextualStream s + +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 + +nonDelimPred :: Char -> Bool +nonDelimPred c = c /= '(' && c /= ')' && not (isSpace c) + +identStartPred :: Char -> Bool +identStartPred c = not (isDigit c) && identContPred c + +identContPred :: Char -> Bool +identContPred c = c /= '"' && nonDelimPred c + +stringP :: SexpParserC s => SexpParserM s Text +stringP = fmap packChunk (escapedStringParser '"') + +identifierP :: SexpParserC s => SexpParserM s Text +identifierP = do + x <- satisfyToken (Just SexpLabelIdentStart) identStartPred + xs <- takeTokensWhile identContPred + pure (packChunk (consChunk x xs)) + +spaceP :: SexpParserC s => SexpParserM s () +spaceP = spaceParser + +lexP :: SexpParserC s => SexpParserM s a -> SexpParserM s a +lexP = lexemeParser spaceP + +openParenP :: SexpParserC s => SexpParserM s () +openParenP = lexP (void (matchToken '(')) + +closeParenP :: SexpParserC s => SexpParserM s () +closeParenP = lexP (void (matchToken ')')) + +intP :: SexpParserC s => SexpParserM s Integer +intP = signedParser (pure ()) decimalParser + +floatP :: SexpParserC s => SexpParserM s Scientific +floatP = signedParser (pure ()) scientificParser + +atomP :: SexpParserC s => SexpParserM s Atom +atomP = lexP $ asum + [ commitParser (void (matchToken '"')) (fmap AtomString stringP) + , commitParser (void (satisfyToken Nothing signedNumStartPred)) (fmap AtomInt intP) + , commitParser (void (satisfyToken Nothing signedNumStartPred)) (fmap AtomFloat floatP) + , commitParser (void (satisfyToken Nothing identStartPred)) (fmap AtomIdent identifierP) + ] + +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 new file mode 100644 --- /dev/null +++ b/src/SimpleParser/Explain.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +module SimpleParser.Explain where + +import Control.Monad (join) +import Data.Foldable (toList) +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Text (Text) +import Data.Void (Void, absurd) +import SimpleParser.Chunked (TextualChunked (..)) +import SimpleParser.Common (CompoundTextLabel (..), TextLabel (..)) +import SimpleParser.Result (CompoundError (..), ParseError (..), RawError (..), StreamError (..), + parseErrorEnclosingLabels, parseErrorNarrowestSpan) +import SimpleParser.Stream (LinePos (..), Span (..), Stream (..), TextualStream) +import Text.Builder (Builder) +import qualified Text.Builder as TB + +class ExplainLabel l where + explainLabel :: l -> Builder + + explainLabelText :: l -> Text + explainLabelText = TB.run . explainLabel + +instance ExplainLabel Void where + explainLabel = absurd + +instance ExplainLabel TextLabel where + explainLabel l = + case l of + TextLabelSpace -> "space" + TextLabelHSpace -> "non-line-breaking space" + TextLabelDigit -> "digit" + +instance ExplainLabel l => ExplainLabel (CompoundTextLabel l) where + explainLabel c = + case c of + CompoundTextLabelText l -> explainLabel l + CompoundTextLabelCustom l -> explainLabel l + +data ErrorExplanation = ErrorExplanation + { eeReason :: !Builder + , eeExpected :: !(Maybe Builder) + , eeActual :: !(Maybe Builder) + } + +class ExplainError e where + explainError :: e -> ErrorExplanation + +instance ExplainError Void where + explainError = absurd + +endMsg :: Builder +endMsg = "end of stream" + +tokB :: Char -> Builder +tokB t = "token '" <> TB.char t <> "'" + +mayTokB :: Maybe Char -> Builder +mayTokB = maybe endMsg tokB + +chunkB :: TextualChunked chunk => chunk -> Builder +chunkB k = "chunk \"" <> buildChunk k <> "\"" + +mayChunkB :: TextualChunked chunk => Maybe chunk -> Builder +mayChunkB = maybe endMsg chunkB + +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)) + 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)) + RawErrorMatchToken expTok mayActTok -> + ErrorExplanation "failed to match token" (Just (tokB expTok)) (Just (mayTokB mayActTok)) + RawErrorMatchChunk expChunk mayActChunk -> + ErrorExplanation "failed to match chunk" (Just (chunkB expChunk)) (Just (mayChunkB mayActChunk)) + RawErrorTakeTokensWhile1 mayActTok -> + ErrorExplanation "failed to take 1 or more tokens" Nothing (Just (mayTokB mayActTok)) + RawErrorDropTokensWhile1 mayActTok -> + ErrorExplanation "failed to drop 1 or more tokens" Nothing (Just (mayTokB 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 + 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) + , peeErrExp :: !ErrorExplanation + } + +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 + errExp = explainError (peError pe) + in ParseErrorExplanation sp context mayDetails errExp + +buildSpan :: Span LinePos -> Builder +buildSpan (Span (LinePos _ sl sc) (LinePos _ el ec)) = + TB.decimal (succ sl) <> ":" <> TB.decimal (succ sc) <> "-" <> TB.decimal (succ el) <> ":" <> TB.decimal (succ ec) + +buildErrorExplanation :: Maybe Builder -> ErrorExplanation -> [Builder] +buildErrorExplanation mayDetails (ErrorExplanation reason mayExpected mayActual) = join + [ ["[Reason ] " <> reason] + , maybe [] (\de -> ["[Details ] " <> de]) mayDetails + , maybe [] (\ex -> ["[Expected] " <> ex]) mayExpected + , maybe [] (\ac -> ["[Actual ] " <> 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)] + ] + tl = buildErrorExplanation mayDetails errExp + in TB.intercalate "\n" (hd ++ tl) + +buildAllParseErrorExplanations :: Foldable f => f (ParseErrorExplanation LinePos) -> Builder +buildAllParseErrorExplanations = TB.intercalate "\n\n" . fmap buildParseErrorExplanation . toList diff --git a/src/SimpleParser/Input.hs b/src/SimpleParser/Input.hs --- a/src/SimpleParser/Input.hs +++ b/src/SimpleParser/Input.hs @@ -1,6 +1,9 @@ -- | Useful combinators for 'ParserT' and 'Stream'. +-- Classified as SAFE or UNSAFE. SAFE always return a value. UNSAFE throw. module SimpleParser.Input - ( peekToken + ( withToken + , withChunk + , peekToken , popToken , peekChunk , popChunk @@ -19,99 +22,129 @@ , matchChunk ) where -import Control.Applicative (empty) import Control.Monad.State (gets, state) import Data.Bifunctor (first) import Data.Maybe (isNothing) -import SimpleParser.Parser (ParserT) -import SimpleParser.Stream (Chunked (..), Stream (..)) +import SimpleParser.Chunked (Chunked (..)) +import SimpleParser.Parser (ParserT (..), markWithOptStateParser, markWithStateParser) +import SimpleParser.Result (CompoundError (..), ParseError (..), ParseResult (..), RawError (..), StreamError (..)) +import SimpleParser.Stack (emptyStack) +import SimpleParser.Stream (Stream (..)) --- | Return the next token, if any, but don't consume it. -peekToken :: (Stream s, Monad m) => ParserT e s m (Maybe (Token s)) +throwStreamError :: Monad m => RawError (Chunk s) (Token s) -> ParserT l s e m a +throwStreamError re = ParserT (\s -> pure (Just (ParseResultError (pure (ParseError emptyStack s (CompoundErrorStream (StreamError re))))))) + +-- | Fetches the next token from the stream and runs the callback. +withToken :: (Stream s, Monad m) => Maybe l -> (Maybe (Token s) -> ParserT l s e m a) -> ParserT l s e m a +withToken ml = markWithOptStateParser ml streamTake1 + +-- | Fetches the next chunk from the stream and runs the callback. +withChunk :: (Stream s, Monad m) => Maybe l -> Int -> (Maybe (Chunk s) -> ParserT l s e m a) -> ParserT l s e m a +withChunk ml n = markWithOptStateParser ml (streamTakeN n) + +-- | Return the next token, if any, but don't consume it. (SAFE) +peekToken :: (Stream s, Monad m) => ParserT l s e m (Maybe (Token s)) peekToken = gets (fmap fst . streamTake1) --- | Return the next token, if any, and consume it. -popToken :: (Stream s, Monad m) => ParserT e s m (Maybe (Token s)) +-- | Return the next token, if any, and consume it. (SAFE) +popToken :: (Stream s, Monad m) => ParserT l s e m (Maybe (Token s)) popToken = state (\stream -> maybe (Nothing, stream) (first Just) (streamTake1 stream)) -- | Return the next chunk of the given size, if any, but don't consume it. --- May return a smaller chunk at end of stream, but never returns an empty chunk. -peekChunk :: (Stream s, Monad m) => Int -> ParserT e s m (Maybe (Chunk s)) +-- May return a smaller chunk at end of stream, but never returns an empty chunk. (SAFE) +peekChunk :: (Stream s, Monad m) => Int -> ParserT l s e m (Maybe (Chunk s)) peekChunk n = gets (fmap fst . streamTakeN n) -- | Return the next chunk of the given size, if any, and consume it. --- May return a smaller chunk at end of stream, but never returns an empty chunk. -popChunk :: (Stream s, Monad m) => Int -> ParserT e s m (Maybe (Chunk s)) +-- May return a smaller chunk at end of stream, but never returns an empty chunk. (SAFE) +popChunk :: (Stream s, Monad m) => Int -> ParserT l s e m (Maybe (Chunk s)) popChunk n = state (\stream -> maybe (Nothing, stream) (first Just) (streamTakeN n stream)) -- | Drop the next chunk of the given size, if any, and consume it. --- May return a smaller size at end of stream, but never returns size 0. -dropChunk :: (Stream s, Monad m) => Int -> ParserT e s m (Maybe Int) +-- May return a smaller size at end of stream, but never returns size 0. (SAFE) +dropChunk :: (Stream s, Monad m) => Int -> ParserT l s e m (Maybe Int) dropChunk n = state (\stream -> maybe (Nothing, stream) (first Just) (streamDropN n stream)) --- | Is this the end of the stream? -isEnd :: (Stream s, Monad m) => ParserT e s m Bool -isEnd = isNothing <$> peekToken +-- | Is this the end of the stream? (SAFE) +isEnd :: (Stream s, Monad m) => ParserT l s e m Bool +isEnd = fmap isNothing peekToken --- | Match the end of the stream or terminate the parser. -matchEnd :: (Stream s, Monad m) => ParserT e s m () -matchEnd = peekToken >>= maybe (pure ()) (const empty) +-- | Match the end of the stream or terminate the parser. (UNSAFE) +matchEnd :: (Stream s, Monad m) => ParserT l s e m () +matchEnd = withToken Nothing (maybe (pure ()) (throwStreamError . RawErrorMatchEnd)) --- | Return the next token or terminate the parser at end of stream. -anyToken :: (Stream s, Monad m) => ParserT e s m (Token s) -anyToken = popToken >>= maybe empty pure +-- | Return the next token or terminate the parser at end of stream. (UNSAFE) +anyToken :: (Stream s, Monad m) => ParserT l s e m (Token s) +anyToken = withToken Nothing (maybe (throwStreamError RawErrorAnyToken) pure) -- | Return the next chunk of the given size or terminate the parser at end of stream. --- May return a smaller chunk at end of stream, but never returns an empty chunk. -anyChunk :: (Stream s, Monad m) => Int -> ParserT e s m (Chunk s) -anyChunk n = popChunk n >>= maybe empty pure +-- May return a smaller chunk at end of stream, but never returns an empty chunk. (UNSAFE) +anyChunk :: (Stream s, Monad m) => Int -> ParserT l s e m (Chunk s) +anyChunk n = withChunk Nothing n (maybe (throwStreamError RawErrorAnyChunk) pure) --- | Match the next token with the given predicate or terminate the parser at predicate false or end of stream. -satisfyToken :: (Stream s, Monad m) => (Token s -> Bool) -> ParserT e s m (Token s) -satisfyToken p = do - m <- popToken - case m of - Just c | p c -> pure c - _ -> empty +-- | Match the next token with the given predicate or terminate the parser at predicate false or end of stream. (UNSAFE) +satisfyToken :: (Stream s, Monad m) => Maybe l -> (Token s -> Bool) -> ParserT l s e m (Token s) +satisfyToken ml pcate = withToken ml $ \mu -> + case mu of + Just u | pcate u -> pure u + _ -> throwStreamError (RawErrorSatisfyToken mu) -- | Folds over a stream of tokens while the boolean value is true. --- Always succeeds, even at end of stream. -foldTokensWhile :: (Stream s, Monad m) => (Token s -> x -> (Bool, x)) -> (x -> x) -> x -> ParserT e s m x -foldTokensWhile f g = go where +-- Always succeeds, even at end of stream. Only consumes greediest match. (SAFE) +foldTokensWhile :: (Stream s, Monad m) => (Token s -> x -> (Bool, x)) -> x -> ParserT l s e m x +foldTokensWhile processNext = go where go !x = do m <- peekToken case m of - Nothing -> pure (g x) + Nothing -> pure x Just c -> - let (ok, newX) = f c x + let (ok, newX) = processNext c x in if ok then popToken *> go newX else pure x -- | Take tokens into a chunk while they satisfy the given predicate. --- Always succeeds, even at end of stream. May return an empty chunk. -takeTokensWhile :: (Stream s, Monad m) => (Token s -> Bool) -> ParserT e s m (Chunk s) +-- Always succeeds, even at end of stream. May return an empty chunk. Only yields greediest match. (SAFE) +takeTokensWhile :: (Stream s, Monad m) => (Token s -> Bool) -> ParserT l s e m (Chunk s) takeTokensWhile = state . streamTakeWhile -- | Take tokens into a chunk while they satisfy the given predicate. -- Only succeeds if 1 or more tokens are taken, so it never returns an empty chunk. -takeTokensWhile1 :: (Stream s, Monad m) => (Token s -> Bool) -> ParserT e s m (Chunk s) -takeTokensWhile1 pcate = takeTokensWhile pcate >>= \c -> if chunkEmpty c then empty else pure c +-- Also takes an optional label to describe the predicate. (UNSAFE) +takeTokensWhile1 :: (Stream s, Monad m) => Maybe l -> (Token s -> Bool) -> ParserT l s e m (Chunk s) +takeTokensWhile1 ml pcate = markWithStateParser ml (streamTakeWhile pcate) $ \j -> + if chunkEmpty j + then do + mu <- peekToken + throwStreamError (RawErrorTakeTokensWhile1 mu) + else pure j -- | Drop tokens and return chunk size while they satisfy the given predicate. --- Always succeeds, even at end of stream. May return empty chunk size 0. -dropTokensWhile :: (Stream s, Monad m) => (Token s -> Bool) -> ParserT e s m Int +-- Always succeeds, even at end of stream. May return empty chunk size 0. Only drops greediest match. (SAFE) +dropTokensWhile :: (Stream s, Monad m) => (Token s -> Bool) -> ParserT l s e m Int dropTokensWhile = state . streamDropWhile -- | Drop tokens and return chunk size while they satisfy the given predicate. -- Only succeeds if 1 or more tokens are dropped. -dropTokensWhile1 :: (Stream s, Monad m) => (Token s -> Bool) -> ParserT e s m Int -dropTokensWhile1 pcate = dropTokensWhile pcate >>= \s -> if s == 0 then empty else pure s +-- Also takes an optional label to describe the predicate. (UNSAFE) +dropTokensWhile1 :: (Stream s, Monad m) => Maybe l -> (Token s -> Bool) -> ParserT l s e m Int +dropTokensWhile1 ml pcate = markWithStateParser ml (streamDropWhile pcate) $ \s -> + if s == 0 + then do + mu <- peekToken + throwStreamError (RawErrorDropTokensWhile1 mu) + else pure s --- | Match token with equality or terminate the parser at inequality or end of stream. -matchToken :: (Stream s, Monad m, Eq (Token s)) => Token s -> ParserT e s m (Token s) -matchToken = satisfyToken . (==) +-- | Match token with equality or terminate the parser at inequality or end of stream. (UNSAFE) +matchToken :: (Stream s, Monad m, Eq (Token s)) => Token s -> ParserT l s e m (Token s) +matchToken t = withToken Nothing $ \mu -> + case mu of + Just u | t == u -> pure u + _ -> throwStreamError (RawErrorMatchToken t mu) --- | Match chunk with equality or terminate the parser at inequality or end of stream. -matchChunk :: (Stream s, Monad m, Eq (Chunk s)) => Chunk s -> ParserT e s m (Chunk s) -matchChunk k = popChunk (chunkLength k) >>= maybe empty (\j -> if k == j then pure j else empty) +-- | Match chunk with equality or terminate the parser at inequality or end of stream. (UNSAFE) +matchChunk :: (Stream s, Monad m, Eq (Chunk s)) => Chunk s -> ParserT l s e m (Chunk s) +matchChunk k = withChunk Nothing (chunkLength k) $ \mj -> + case mj of + Just j | k == j -> pure j + _ -> throwStreamError (RawErrorMatchChunk k mj) diff --git a/src/SimpleParser/Interactive.hs b/src/SimpleParser/Interactive.hs new file mode 100644 --- /dev/null +++ b/src/SimpleParser/Interactive.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SimpleParser.Interactive + ( parseInteractive + ) where + +import Data.Foldable (toList) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import SimpleParser.Explain (Explainable, buildAllParseErrorExplanations, explainParseError) +import SimpleParser.Input (matchEnd) +import SimpleParser.Parser (Parser, runParser) +import SimpleParser.Result (ParseResult (..), ParseSuccess (..)) +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 = + 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)) + Just (ParseResultSuccess (ParseSuccess _ a)) -> + putStrLn "Success:" *> print a diff --git a/src/SimpleParser/Parser.hs b/src/SimpleParser/Parser.hs --- a/src/SimpleParser/Parser.hs +++ b/src/SimpleParser/Parser.hs @@ -1,21 +1,34 @@ +{-# LANGUAGE Rank2Types #-} + -- | 'ParserT' is the core monad transformer for parsing. module SimpleParser.Parser ( ParserT (..) , Parser , runParser - , filterParser - , reflectParser - , branchParser - , suppressParser - , isolateParser - , defaultParser - , optionalParser - , silenceParser + , pureParser + , bindParser + , failParser + , liftParser + , hoistParser + , catchJustParser + , throwParser + , catchParser + , emptyParser + , orParser , greedyStarParser , greedyStarParser_ , greedyPlusParser , greedyPlusParser_ + , defaultParser + , optionalParser + , silenceParser , lookAheadParser + , markParser + , markWithStateParser + , markWithOptStateParser + , unmarkParser + , commitParser + , onEmptyParser ) where import Control.Applicative (Alternative (..), liftA2) @@ -25,205 +38,291 @@ import Control.Monad.Morph (MFunctor (..)) import Control.Monad.State (MonadState (..)) import Control.Monad.Trans (MonadTrans (..)) -import Data.Foldable (toList) -import ListT (ListT (..)) -import qualified ListT -import SimpleParser.Result (ParseResult (..), ParseValue (..)) +import Data.Bifunctor (first) +import Data.Sequence (Seq (..)) +import Data.Sequence.NonEmpty ((><|)) +import qualified Data.Sequence.NonEmpty as NESeq +import Data.Text (Text) +import qualified Data.Text as T +import SimpleParser.Chunked (Chunked (..)) +import SimpleParser.Result (CompoundError (..), Mark (..), ParseError (..), ParseResult (..), ParseSuccess (..), + markParseError, parseErrorResume, unmarkParseError) +import SimpleParser.Stack (emptyStack) -- | A 'ParserT' is a state/error/list transformer useful for parsing. -- All MTL instances are for this transformer only. If, for example, your effect -- has its own 'MonadState' instance, you'll have to use 'lift get' instead of 'get'. -newtype ParserT e s m a = ParserT { runParserT :: s -> ListT m (ParseResult e s a) } +newtype ParserT l s e m a = ParserT { runParserT :: s -> m (Maybe (ParseResult l s e a)) } deriving (Functor) -- | Use 'Parser' if you have no need for other monadic effects. -type Parser e s a = ParserT e s Identity a +type Parser l s e a = ParserT l s e Identity a -instance Monad m => Applicative (ParserT e s m) where - pure a = ParserT (pure . ParseResult (ParseSuccess a)) +-- | Runs a non-effectful parser from an inital state and collects all results. +runParser :: Parser l s e a -> s -> Maybe (ParseResult l s e a) +runParser parser s = runIdentity (runParserT parser s) + +-- | Applicative pure +pureParser :: Monad m => a -> ParserT l s e m a +pureParser a = ParserT (\s -> pure (Just (ParseResultSuccess (ParseSuccess s a)))) + +instance Monad m => Applicative (ParserT l s e m) where + pure = pureParser (<*>) = ap -instance Monad m => Monad (ParserT e s m) where +-- | Monadic bind +bindParser :: Monad m => ParserT l s e m a -> (a -> ParserT l s e m b) -> ParserT l s e m b +bindParser parser f = ParserT (runParserT parser >=> go) where + go mres = + case mres of + Nothing -> pure Nothing + Just res -> + case res of + ParseResultError errs -> pure (Just (ParseResultError errs)) + ParseResultSuccess (ParseSuccess t a) -> runParserT (f a) t + +instance Monad m => Monad (ParserT l s e m) where return = pure - parser >>= f = ParserT (runParserT parser >=> go) where - go (ParseResult v t) = - case v of - ParseError e -> pure (ParseResult (ParseError e) t) - ParseSuccess a -> runParserT (f a) t + (>>=) = bindParser -instance Monad m => Alternative (ParserT e s m) where - empty = ParserT (const empty) - first <|> second = ParserT (\s -> runParserT first s <|> runParserT second s) +-- | The empty parser +emptyParser :: Monad m => ParserT l s e m a +emptyParser = ParserT (const (pure Nothing)) -instance Monad m => MonadPlus (ParserT e s m) where +-- | Yields from the first parser of the two that returns a successfull result. +-- Otherwise will merge and yield all errors. +orParser :: Monad m => ParserT l s e m a -> ParserT l s e m a -> ParserT l s e m a +orParser one two = ParserT (\s -> runParserT one s >>= go1 s) where + go1 s mres1 = + case mres1 of + Nothing -> runParserT two s >>= go2 empty + Just res1 -> + case res1 of + ParseResultSuccess _ -> pure mres1 + ParseResultError es1 -> runParserT two s >>= go2 (NESeq.toSeq es1) + + go2 es1 mres2 = + case mres2 of + Nothing -> pure (fmap ParseResultError (NESeq.nonEmptySeq es1)) + Just res2 -> + case res2 of + ParseResultSuccess _ -> pure mres2 + ParseResultError es2 -> pure (Just (ParseResultError (es1 ><| es2))) + +-- | Yields the LONGEST string of 0 or more successes of the given parser. +-- Failures will be silenced. +greedyStarParser :: (Chunked seq elem, Monad m) => ParserT l s e m elem -> ParserT l s e m seq +greedyStarParser parser = go [] where + opt = optionalParser parser + go !acc = do + res <- opt + case res of + Nothing -> pure (revTokensToChunk acc) + Just a -> go (consChunk a acc) + +-- | Same as 'greedyStarParser' but discards the result. +greedyStarParser_ :: Monad m => ParserT l s e m a -> ParserT l s e m () +greedyStarParser_ parser = go where + opt = optionalParser parser + go = do + res <- opt + case res of + Nothing -> pure () + Just _ -> go + +-- | Yields the LONGEST string of 1 or more successes of the given parser. +-- Failures in the tail will be silenced, but those in the head will be returned. +greedyPlusParser :: (Chunked seq elem, Monad m) => ParserT l s e m elem -> ParserT l s e m seq +greedyPlusParser parser = liftA2 consChunk parser (greedyStarParser parser) + +-- | Same as 'greedyPlusParser' but discards the result. +greedyPlusParser_ :: Monad m => ParserT l s e m a -> ParserT l s e m () +greedyPlusParser_ parser = parser *> greedyStarParser_ parser + +instance Monad m => Alternative (ParserT l s e m) where + empty = emptyParser + (<|>) = orParser + some = greedyPlusParser + many = greedyStarParser + +instance Monad m => MonadPlus (ParserT l s e m) where mzero = empty mplus = (<|>) -instance Monad m => MonadError e (ParserT e s m) where - throwError e = ParserT (pure . ParseResult (ParseError e)) - -- TODO(ejconlon) Implement directly by unwrapping? - catchError parser handler = do - r <- reflectParser parser - case r of - ParseError e -> handler e - ParseSuccess a -> pure a +instance Monad m => MonadState s (ParserT l s e m) where + get = ParserT (\s -> pure (Just (ParseResultSuccess (ParseSuccess s s)))) + put t = ParserT (\_ -> pure (Just (ParseResultSuccess (ParseSuccess t ())))) + state f = ParserT (\s -> let (!a, !t) = f s in pure (Just (ParseResultSuccess (ParseSuccess t a)))) -instance Monad m => MonadState s (ParserT e s m) where - get = ParserT (\s -> pure (ParseResult (ParseSuccess s) s)) - put t = ParserT (const (pure (ParseResult (ParseSuccess ()) t))) - state f = ParserT (\s -> let (a, t) = f s in pure (ParseResult (ParseSuccess a) t)) +-- | 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 = + case mres of + Nothing -> pure Nothing + Just res -> + case res of + ParseResultSuccess _ -> + -- Nothing to catch, yield existing success + pure mres + ParseResultError es -> + -- Find first custom error to handle + goSplit Empty (NESeq.toSeq es) -instance MonadTrans (ParserT e s) where - lift ma = ParserT (\s -> lift (fmap (\a -> ParseResult (ParseSuccess a) s) ma)) + goSplit 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 -instance MFunctor (ParserT e s) where - hoist trans (ParserT f) = ParserT (hoist trans . f) + goHandle beforeEs (SeqPartition nextBeforeEs targetE (s, e) afterEs) = + case filterer e of + Nothing -> + -- Not handling error; - find next custom error + goSplit (beforeEs <> (targetE :<| nextBeforeEs)) afterEs + Just b -> do + mres <- runParserT (handler b) s + case mres of + Nothing -> + -- No results from handled error - find next custom error + goSplit (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 --- | Runs a non-effectful parser from an inital state and collects all results. -runParser :: Parser e s a -> s -> [ParseResult e s a] -runParser m s = runIdentity (ListT.toList (runParserT m s)) +-- | Throws a custom error +throwParser :: Monad m => e -> ParserT l s e m a +throwParser e = ParserT (\s -> pure (Just (ParseResultError (pure (ParseError emptyStack s (CompoundErrorCustom e)))))) --- | Filters parse results -filterParser :: Monad m => (a -> Bool) -> ParserT e s m a -> ParserT e s m a -filterParser f parser = ParserT (ListT . go . runParserT parser) where - go listt = do - m <- ListT.uncons listt - case m of - Nothing -> pure Nothing - Just (r@(ParseResult v _), rest) -> - case v of - ParseSuccess a | not (f a) -> go rest - _ -> pure (Just (r, ListT (go rest))) +-- | Catches a custom error +catchParser :: Monad m => ParserT l s e m a -> (e -> ParserT l s e m a) -> ParserT l s e m a +catchParser = catchJustParser Just --- | A kind of "catch" that returns all results, success and failure. -reflectParser :: Monad m => ParserT e s m a -> ParserT e s m (ParseValue e a) -reflectParser parser = ParserT (ListT . go . runParserT parser) where - go listt = do - m <- ListT.uncons listt - case m of - Nothing -> pure Nothing - Just (ParseResult v t, rest) -> - pure (Just (ParseResult (ParseSuccess v) t, ListT (go rest))) +instance Monad m => MonadError e (ParserT l s e m) where + throwError = throwParser + catchError = catchJustParser Just --- | Combines the results of many parsers. --- Equvalent to 'asum'. -branchParser :: (Foldable f, Monad m) => f (ParserT e s m a) -> ParserT e s m a -branchParser = start . toList where - start ps = - case ps of - [] -> empty - q:qs -> ParserT (\s -> ListT (run s q qs)) - run s q qs = do - m <- ListT.uncons (runParserT q s) - case m of - Nothing -> - case qs of - [] -> pure Nothing - r:rs -> run s r rs - Just (a, rest) -> pure (Just (a, rest)) +-- | A simple failing parser +failParser :: Monad m => Text -> ParserT l s e m a +failParser msg = ParserT (\s -> pure (Just (ParseResultError (pure (ParseError emptyStack s (CompoundErrorFail msg)))))) -gatherParser :: Monad m => Bool -> ParserT e s m a -> ParserT e s m a -gatherParser single parser = ParserT (ListT . go [] . runParserT parser) where - go !acc listt = do - m <- ListT.uncons listt - case m of - Nothing -> returnErr (reverse acc) - Just (r@(ParseResult v _), rest) -> - case v of - ParseError _ -> go (r:acc) rest - ParseSuccess _ -> - let t = if single then empty else ListT (filterOk rest) - in pure (Just (r, t)) +instance Monad m => MonadFail (ParserT l s e m) where + fail = failParser . T.pack - returnErr racc = - case racc of - [] -> pure Nothing - r:rs -> pure (Just (r, ListT (returnErr rs))) +liftParser :: Monad m => m a -> ParserT l s e m a +liftParser ma = ParserT (\s -> fmap (Just . ParseResultSuccess . ParseSuccess s) ma) - filterOk listt = do - m <- ListT.uncons listt - case m of - Nothing -> pure Nothing - Just (r@(ParseResult v _), rest) -> - let nextListt = filterOk rest - in case v of - ParseError _ -> nextListt - ParseSuccess _ -> pure (Just (r, ListT nextListt)) +instance MonadTrans (ParserT l s e) where + lift = liftParser --- | If the parse results in ANY successes, keep only those. Otherwise return all failures. --- This may block indefinitely as it awaits either the end of the parser or its first success. --- See 'isolateParser' if you want only one success. -suppressParser :: Monad m => ParserT e s m a -> ParserT e s m a -suppressParser = gatherParser False +hoistParser :: (forall x. m x -> n x) -> ParserT l s e m a -> ParserT l s e n a +hoistParser trans (ParserT f) = ParserT (trans . f) --- | If the parse results in ANY successes, keep only THE FIRST. Otherwise return all failures. --- This may block indefinitely as it awaits either the end of the parser or its first success. --- See 'suppressParser' if you want all successes. -isolateParser :: Monad m => ParserT e s m a -> ParserT e s m a -isolateParser = gatherParser True +instance MFunctor (ParserT l s e) where + hoist = hoistParser --- | If the parser yields no results (success or failure), yield a given value. -defaultParser :: Monad m => a -> ParserT e s m a -> ParserT e s m a -defaultParser def parser = ParserT (\s -> ListT (go s (runParserT parser s))) where - go s listt = do - m <- ListT.uncons listt - case m of - Nothing -> pure (Just (ParseResult (ParseSuccess def) s, empty)) - Just _ -> pure m +-- | If the parser does not succeed, yield the given value. +defaultParser :: Monad m => a -> ParserT l s e m a -> ParserT l s e m a +defaultParser val parser = orParser parser (pure val) --- | A parser that yields 'Nothing' if there are no results (success or failure), --- otherwise wrapping successes in 'Just'. -optionalParser :: Monad m => ParserT e s m a -> ParserT e s m (Maybe a) +-- | A parser that yields 'Nothing' if the parser does not succeed, otherwise +-- wraps success in 'Just'. +optionalParser :: Monad m => ParserT l s e m a -> ParserT l s e m (Maybe a) optionalParser parser = defaultParser Nothing (fmap Just parser) --- | Removes all failures from the parse results. --- Equivalent to 'catchError (const empty)'. -silenceParser :: Monad m => ParserT e s m a -> ParserT e s m a -silenceParser parser = ParserT (ListT . go . runParserT parser) where - go listt = do - m <- ListT.uncons listt - case m of - Nothing -> pure Nothing - Just (r@(ParseResult v _), rest) -> - let nextListt = go rest - in case v of - ParseError _ -> nextListt - ParseSuccess _ -> pure (Just (r, ListT nextListt)) +-- | 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 --- | Yields the LONGEST string of 0 or more successes of the given parser (and passes through failures). -greedyStarParser :: Monad m => ParserT e s m a -> ParserT e s m [a] -greedyStarParser parser = go [] where - opt = optionalParser parser - go !acc = do - res <- opt +-- | Yield the results of the given parser, but rewind back to the starting state in ALL cases (success and error). +-- 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 + go s res = case res of - Nothing -> pure (reverse acc) - Just a -> go (a:acc) + ParseResultError es -> ParseResultError (fmap (markParseError (Mark ml s)) es) + ParseResultSuccess (ParseSuccess _ a) -> ParseResultSuccess (ParseSuccess s a) --- | Same as 'greedyStarParser' but discards the result. -greedyStarParser_ :: Monad m => ParserT e s m a -> ParserT e s m () -greedyStarParser_ parser = go where - opt = optionalParser parser - go = do - res <- opt +-- | Yield the results of the given parser, but rewind back to the starting state on error ONLY. +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 = case res of - Nothing -> pure () - Just _ -> go + ParseResultError es -> ParseResultError (fmap (markParseError (Mark ml s)) es) + ParseResultSuccess _ -> res --- | Yields the LONGEST string of 1 or more successes of the given parser (and passes through failures). -greedyPlusParser :: Monad m => ParserT e s m a -> ParserT e s m [a] -greedyPlusParser parser = liftA2 (:) parser (greedyStarParser parser) +-- | Like 'markParser' but allows you to mutate state. See 'withToken' and 'withChunk'. +markWithStateParser :: Monad m => Maybe l -> (s -> (b, s)) -> (b -> ParserT l s e m a) -> ParserT l s e m a +markWithStateParser ml g f = markParser ml (state g >>= f) --- | Same as 'greedyPlusParser' but discards the result. -greedyPlusParser_ :: Monad m => ParserT e s m a -> ParserT e s m () -greedyPlusParser_ parser = parser *> greedyStarParser_ parser +-- | Like 'markParser' but allows you to mutate state. See 'withToken' and 'withChunk'. +markWithOptStateParser :: Monad m => Maybe l -> (s -> Maybe (b, s)) -> (Maybe b -> ParserT l s e m a) -> ParserT l s e m a +markWithOptStateParser ml g = markWithStateParser ml (\s -> maybe (Nothing, s) (first Just) (g s)) --- | 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 => ParserT e s m a -> ParserT e s m a -lookAheadParser parser = do +-- | Clear marks from parse errors. You can mark immediately after to widen the narrowest +-- marked span to the range you want to report. +unmarkParser :: Monad m => ParserT l s e m a -> ParserT l s e m a +unmarkParser parser = ParserT (fmap (fmap go) . runParserT parser) where + go res = + case res of + 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. +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 - flip catchError (\e -> put s *> throwError e) $ do - v <- parser - put s - pure v + o <- optionalParser checker + case o of + Nothing -> empty + Just _ -> put s *> parser + +-- | If the first parser yields NO results (success or failure), yield from the second. +-- Note that this is different from 'orParser' in that it does not try the second if there +-- are errors in the first. You might use this on the outside of a complex parser with +-- a fallback to 'fail' to indicate that there are no matches. +onEmptyParser :: Parser l s e a -> Parser l s e a -> Parser l s e a +onEmptyParser parser fallback = ParserT (\s -> runParserT parser s >>= go s) where + go s mres = + case mres of + Nothing -> runParserT fallback s + Just _ -> pure mres + +-- Private utility functions + +data SeqPartition a b = SeqPartition + { spBefore :: !(Seq a) + , spKey :: !a + , spValue :: !b + , spAfter :: !(Seq a) + } deriving (Eq, Show) + +seqPartition :: (a -> Maybe b) -> Seq a -> Maybe (SeqPartition a b) +seqPartition f = go Empty where + go before after = + case after of + Empty -> Nothing + (x :<| xs) -> + case f x of + Nothing -> go (before :|> x) xs + Just y -> Just (SeqPartition before x y xs) + +extractCustomError :: ParseError l s e -> Maybe (s, e) +extractCustomError pe@(ParseError _ _ ce) = + case ce of + CompoundErrorCustom e -> Just (parseErrorResume pe, e) + _ -> Nothing diff --git a/src/SimpleParser/Result.hs b/src/SimpleParser/Result.hs --- a/src/SimpleParser/Result.hs +++ b/src/SimpleParser/Result.hs @@ -1,31 +1,108 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + module SimpleParser.Result - ( ParseResult (..) - , ParseValue (..) - , parseSuccessResult - , parseErrorResult - , parseValue + ( RawError (..) + , StreamError (..) + , CompoundError (..) + , Mark (..) + , ParseError (..) + , parseErrorResume + , markParseError + , unmarkParseError + , parseErrorEnclosingLabels + , parseErrorNarrowestSpan + , ParseSuccess (..) + , ParseResult (..) ) where --- | Strict 'Either' for parse results. -data ParseValue e a = - ParseError !e - | ParseSuccess !a - deriving (Eq, Show, Functor, Foldable, Traversable) +import Data.Sequence (Seq (..)) +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.Stream (Span (..), Stream (..)) -parseValue :: (e -> r) -> (a -> r) -> ParseValue e a -> r -parseValue onError onSuccess value = - case value of - ParseError e -> onError e - ParseSuccess a -> onSuccess a +data RawError chunk token = + RawErrorMatchEnd !token + | RawErrorAnyToken + | RawErrorAnyChunk + | RawErrorSatisfyToken !(Maybe token) + | RawErrorMatchToken !token !(Maybe token) + | RawErrorMatchChunk !chunk !(Maybe chunk) + | RawErrorTakeTokensWhile1 !(Maybe token) + | RawErrorDropTokensWhile1 !(Maybe token) + deriving (Eq, Show) --- | Strict pair of parse result and state at the time it was yielded. -data ParseResult e s a = ParseResult - { prValue :: !(ParseValue e a) - , prState :: !s +-- | 'RawStreamError' specialized to 'Stream' types - newtyped to allow GHC +-- to derive eq/show in the absense of type families. +newtype StreamError s = StreamError + { unStreamError :: RawError (Chunk s) (Token s) + } + +deriving instance (Eq (Token s), Eq (Chunk s)) => Eq (StreamError s) +deriving instance (Show (Token s), Show (Chunk s)) => Show (StreamError s) + +data CompoundError s e = + CompoundErrorStream !(StreamError s) + | CompoundErrorFail !Text + | CompoundErrorCustom !e + deriving (Functor, Foldable, Traversable) + +deriving instance (Eq (Token s), Eq (Chunk s), Eq e) => Eq (CompoundError s e) +deriving instance (Show (Token s), Show (Chunk s), Show e) => Show (CompoundError s e) + +data Mark l s = Mark + { markLabel :: !(Maybe l) + , markState :: !s + } deriving (Eq, Show) + +type MarkStack l s = Stack (Mark l s) + +data ParseError l s e = ParseError + { peMarkStack :: !(MarkStack l s) + , peEndState :: !s + , peError :: !(CompoundError s e) + } + +-- | Returns the resumption point of the 'ParseError'. +-- If it has been marked, we use that, otherwise we assume it starts at the exact error point. +parseErrorResume :: ParseError l s e -> s +parseErrorResume pe = maybe (peEndState pe) markState (topStack (peMarkStack pe)) + +-- | 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) } + +-- | Clears marks from a 'ParseError'. +unmarkParseError :: ParseError l s e -> ParseError l s e +unmarkParseError pe = pe { peMarkStack = emptyStack } + +-- | Returns the narrowest span +parseErrorNarrowestSpan :: Stream s => ParseError l s e -> (Maybe l, Span (Pos s)) +parseErrorNarrowestSpan pe = (ml, Span startPos endPos) where + endPos = streamViewPos (peEndState pe) + (ml, startPos) = maybe (Nothing, endPos) (\(Mark mx s) -> (mx, streamViewPos s)) (bottomStack (peMarkStack pe)) + +-- | Returns labels enclosing the narrowest span, from coarsest to finest +parseErrorEnclosingLabels :: ParseError l s e -> Seq l +parseErrorEnclosingLabels pe = + case unStack (peMarkStack pe) of + Empty -> Empty + _ :<| s -> s >>= \(Mark ml _) -> maybe Seq.empty Seq.singleton ml + +deriving instance (Eq l, Eq s, Eq (Token s), Eq (Chunk s), Eq e) => Eq (ParseError l s e) +deriving instance (Show l, Show s, Show (Token s), Show (Chunk s), Show e) => Show (ParseError l s e) + +data ParseSuccess s a = ParseSuccess + { psEndState :: !s + , psValue :: !a } deriving (Eq, Show, Functor, Foldable, Traversable) -parseSuccessResult :: a -> s -> ParseResult e s a -parseSuccessResult = ParseResult . ParseSuccess +data ParseResult l s e a = + ParseResultError !(NESeq (ParseError l s e)) + | ParseResultSuccess !(ParseSuccess s a) + deriving (Functor, Foldable, Traversable) -parseErrorResult :: e -> s -> ParseResult e s a -parseErrorResult = ParseResult . ParseError +deriving instance (Eq l, Eq s, Eq (Token s), Eq (Chunk s), Eq e, Eq a) => Eq (ParseResult l s e a) +deriving instance (Show l, Show s, Show (Token s), Show (Chunk s), Show e, Show a) => Show (ParseResult l s e a) diff --git a/src/SimpleParser/Stack.hs b/src/SimpleParser/Stack.hs new file mode 100644 --- /dev/null +++ b/src/SimpleParser/Stack.hs @@ -0,0 +1,38 @@ +module SimpleParser.Stack + ( Stack (..) + , emptyStack + , pushStack + , topStack + , bottomStack + ) where + +import Data.Sequence (Seq (..)) + +-- | A stack supporting O(1) push, top, and bottom. +-- Behind the newtype, a "push" onto the stack is implemented as "snoc", therefore +-- fold/traverse goes from bottom of stack (most generic label) to top (most specific label). +newtype Stack a = Stack + { unStack :: Seq a + } deriving (Eq, Show, Functor, Foldable, Traversable) + +-- | Easy constructor for the empty stack +emptyStack :: Stack a +emptyStack = Stack Empty + +-- | Pushes a an element onto a 'Stack' +pushStack :: a -> Stack a -> Stack a +pushStack a = Stack . (:|> a) . unStack + +-- | Returns the top element of the stack (most recently pushed). +topStack :: Stack a -> Maybe a +topStack (Stack s) = + case s of + Empty -> Nothing + _ :|> a -> Just a + +-- | Returns the bottom element of the stack (least recently pushed). +bottomStack :: Stack a -> Maybe a +bottomStack (Stack s) = + case s of + Empty -> Nothing + a :<| _ -> Just a diff --git a/src/SimpleParser/Stream.hs b/src/SimpleParser/Stream.hs --- a/src/SimpleParser/Stream.hs +++ b/src/SimpleParser/Stream.hs @@ -1,72 +1,39 @@ -- | This reworks 'Text.Megaparsec.Stream' to split interfaces. -- See . module SimpleParser.Stream - ( Chunked (..) - , Stream (..) + ( Stream (..) + , TextualStream , defaultStreamDropN , defaultStreamDropWhile + , Offset (..) , OffsetStream (..) , newOffsetStream + , Line (..) + , Col (..) + , LinePos (..) + , LinePosStream (..) + , newLinePosStream + , Span (..) ) where import Data.Bifunctor (first, second) -import Data.Foldable (toList) import Data.Kind (Type) -import Data.List (uncons) +import Data.List (foldl') import Data.Sequence (Seq (..)) import qualified Data.Sequence as Seq import Data.Text (Text) import qualified Data.Text as T - --- | 'Chunked' captures the basic relationship between tokens and chunks of them. --- Basically, these things behave like lists, sequences, text, etc. -class Monoid chunk => Chunked chunk token | chunk -> token where - consChunk :: token -> chunk -> chunk - unconsChunk :: chunk -> Maybe (token, chunk) - tokenToChunk :: token -> chunk - tokensToChunk :: [token] -> chunk - chunkToTokens :: chunk -> [token] - chunkLength :: chunk -> Int - chunkEmpty :: chunk -> Bool - --- TODO(ejconlon) Add instances for Strict BS, Lazy BS, and Lazy Text - -instance Chunked [a] a where - consChunk = (:) - unconsChunk = uncons - tokenToChunk a = [a] - tokensToChunk = id - chunkToTokens = id - chunkLength = length - chunkEmpty = null - -instance Chunked (Seq a) a where - consChunk = (:<|) - unconsChunk s = - case s of - Empty -> Nothing - a :<| b -> Just (a, b) - tokenToChunk = Seq.singleton - tokensToChunk = Seq.fromList - chunkToTokens = toList - chunkLength = Seq.length - chunkEmpty = Seq.null - -instance Chunked Text Char where - consChunk = T.cons - unconsChunk = T.uncons - tokenToChunk = T.singleton - tokensToChunk = T.pack - chunkToTokens = T.unpack - chunkLength = T.length - chunkEmpty = T.null +import SimpleParser.Chunked (Chunked (..), TextualChunked (..)) -- | 'Stream' lets us peel off tokens and chunks for parsing -- with explicit state passing. class Chunked (Chunk s) (Token s) => Stream s where type family Chunk s :: Type type family Token s :: Type + type family Pos s :: Type + streamViewPos :: s -> Pos s + streamTake1 :: s -> Maybe (Token s, s) streamTakeN :: Int -> s -> Maybe (Chunk s, s) streamTakeWhile :: (Token s -> Bool) -> s -> (Chunk s, s) @@ -77,22 +44,21 @@ streamDropWhile :: (Token s -> Bool) -> s -> (Int, s) streamDropWhile = defaultStreamDropWhile --- TODO(ejconlon) Specialize drops - defaultStreamDropN :: Stream s => Int -> s -> Maybe (Int, s) defaultStreamDropN n = fmap (first chunkLength) . streamTakeN n defaultStreamDropWhile :: Stream s => (Token s -> Bool) -> s -> (Int, s) defaultStreamDropWhile pcate = first chunkLength . streamTakeWhile pcate +type TextualStream s = (Stream s, Token s ~ Char, TextualChunked (Chunk s)) + instance Stream [a] where type instance Chunk [a] = [a] type instance Token [a] = a + type instance Pos [a] = () - streamTake1 l = - case l of - [] -> Nothing - t:ts -> Just (t, ts) + streamViewPos = const () + streamTake1 = unconsChunk streamTakeN n s | n <= 0 = Just ([], s) | null s = Nothing @@ -102,21 +68,24 @@ instance Stream (Seq a) where type instance Chunk (Seq a) = Seq a type instance Token (Seq a) = a + type instance Pos (Seq a) = () - streamTake1 s = - case s of - Empty -> Nothing - t :<| ts -> Just (t, ts) + streamViewPos = const () + streamTake1 = unconsChunk streamTakeN n s | n <= 0 = Just (Seq.empty, s) | Seq.null s = Nothing | otherwise = Just (Seq.splitAt n s) streamTakeWhile = Seq.spanl + -- TODO(ejconlon) Specialize drops + instance Stream Text where type instance Chunk Text = Text type instance Token Text = Char + type instance Pos Text = () + streamViewPos = const () streamTake1 = T.uncons streamTakeN n s | n <= 0 = Just (T.empty, s) @@ -124,26 +93,87 @@ | otherwise = Just (T.splitAt n s) streamTakeWhile = T.span +newtype Offset = Offset { unOffset :: Int } + deriving newtype (Eq, Show, Ord, Enum, Num, Real, Integral) + +-- | Stream wrapper that maintains an offset position. data OffsetStream s = OffsetStream - { osOffset :: !Int + { osOffset :: !Offset , osState :: !s } deriving (Eq, Show, Functor, Foldable, Traversable) instance Stream s => Stream (OffsetStream s) where type instance Chunk (OffsetStream s) = Chunk s type instance Token (OffsetStream s) = Token s + type instance Pos (OffsetStream s) = Offset + streamViewPos (OffsetStream o _) = o streamTake1 (OffsetStream o s) = fmap (second (OffsetStream (succ o))) (streamTake1 s) - streamTakeN n (OffsetStream o s) = fmap go (streamTakeN n s) where - go (a, b) = (a, OffsetStream (o + chunkLength a) b) - streamTakeWhile pcate (OffsetStream o s) = + streamTakeN n (OffsetStream (Offset x) s) = fmap go (streamTakeN n s) where + go (a, b) = (a, OffsetStream (Offset (x + chunkLength a)) b) + streamTakeWhile pcate (OffsetStream (Offset x) s) = let (a, b) = streamTakeWhile pcate s - in (a, OffsetStream (o + chunkLength a) b) - streamDropN n (OffsetStream o s) = fmap go (streamDropN n s) where - go (m, b) = (m, OffsetStream (o + m) b) - streamDropWhile pcate (OffsetStream o s) = + in (a, OffsetStream (Offset (x + chunkLength a)) b) + streamDropN n (OffsetStream (Offset x) s) = fmap go (streamDropN n s) where + go (m, b) = (m, OffsetStream (Offset (x + m)) b) + streamDropWhile pcate (OffsetStream (Offset x) s) = let (m, b) = streamDropWhile pcate s - in (m, OffsetStream (o + m) b) + in (m, OffsetStream (Offset (x + m)) b) newOffsetStream :: s -> OffsetStream s newOffsetStream = OffsetStream 0 + +newtype Line = Line { unLine :: Int } + deriving newtype (Eq, Show, Ord, Enum, Num, Real, Integral) + +newtype Col = Col { unCol :: Int } + deriving newtype (Eq, Show, Ord, Enum, Num, Real, Integral) + +-- | A 0-based line/col position in a character-based stream. +data LinePos = LinePos + { lpOffset :: !Offset + , lpLine :: !Line + , lpCol :: !Col + } deriving (Eq, Show, Ord) + +-- | The canonical initial position. +initLinePos :: LinePos +initLinePos = LinePos 0 0 0 + +incrLinePosToken :: LinePos -> Char -> LinePos +incrLinePosToken (LinePos o l c) z + | z == '\n' = LinePos (succ o) (succ l) 0 + | otherwise = LinePos (succ o) l (succ c) + +incrLinePosChunk :: LinePos -> [Char] -> LinePos +incrLinePosChunk = foldl' incrLinePosToken + +-- | Stream wrapper that maintains a line/col position. +data LinePosStream s = LinePosStream + { lpsLinePos :: !LinePos + , lpsState :: !s + } deriving (Eq, Show, Functor, Foldable, Traversable) + +instance (Stream s, Token s ~ Char) => Stream (LinePosStream s) where + type instance Chunk (LinePosStream s) = Chunk s + type instance Token (LinePosStream s) = Token s + type instance Pos (LinePosStream s) = LinePos + + streamViewPos (LinePosStream p _) = p + streamTake1 (LinePosStream p s) = fmap (\(a, b) -> (a, LinePosStream (incrLinePosToken p a) b)) (streamTake1 s) + streamTakeN n (LinePosStream p s) = fmap go (streamTakeN n s) where + go (a, b) = (a, LinePosStream (incrLinePosChunk p (chunkToTokens a)) b) + streamTakeWhile pcate (LinePosStream p s) = + let (a, b) = streamTakeWhile pcate s + in (a, LinePosStream (incrLinePosChunk p (chunkToTokens a)) b) + + -- Drops can't be specialized because we need to examine each character for newlines. + +newLinePosStream :: s -> LinePosStream s +newLinePosStream = LinePosStream initLinePos + +-- | A range between two positions. +data Span p = Span + { spanStart :: !p + , spanEnd :: !p + } deriving (Eq, Show, Ord) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -3,606 +3,588 @@ module Main (main) where -import Control.Applicative (empty) -import Control.Monad.Except (catchError, throwError) +import Control.Monad (void) import Data.Foldable (asum) -import Data.Functor (($>)) +import qualified Data.Sequence as Seq +import qualified Data.Sequence.NonEmpty as NESeq +import Data.String (IsString) import Data.Text (Text) +import qualified Data.Text as T import SimpleParser -import SimpleParser.Examples.Json (Json (..), JsonF (..), parseJson) +import SimpleParser.Examples.Json (Json (..), JsonF (..), jsonParser) import Test.Tasty (TestName, TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, testCase, (@?=)) +import Test.Tasty.HUnit (testCase, (@?=)) import Test.Tasty.TH (defaultMainGenerator) -newtype Error = Error { unError :: String } deriving (Eq, Show) +newtype Label = Label { unLabel :: String } deriving (Eq, Show, IsString) -type TestParser a = Parser Error (OffsetStream Text) a +newtype Error = Error { unError :: String } deriving (Eq, Show, IsString) -type TestResult a = ParseResult Error (OffsetStream Text) a +type TestState = OffsetStream Text -data InputOutput a = InputOutput !Text ![TestResult a] +type TestParser a = Parser Label TestState Error a -runParserCase :: (Show a, Eq a) => TestParser a -> InputOutput a -> Assertion -runParserCase parser (InputOutput input expected) = do - let actual = runParser parser (newOffsetStream input) - actual @?= expected +type TestResult a = ParseResult Label TestState Error a -testParserCase :: (Show a, Eq a) => TestName -> TestParser a -> InputOutput a -> TestTree -testParserCase name parser inOut = testCase name (runParserCase parser inOut) +type TestRawError = RawError Text Char -testParserTrees :: (Show a, Eq a) => TestParser a -> [(TestName, InputOutput a)] -> [TestTree] -testParserTrees parser = fmap (\(n, io) -> testParserCase n parser io) +type TestParseError = ParseError Label TestState Error +data ParserCase a = ParserCase !TestName !(TestParser a) !Text !(Maybe (TestResult a)) + +fwd :: Int -> TestState -> TestState +fwd n (OffsetStream (Offset i) t) = + let m = min n (T.length t) + in OffsetStream (Offset (i + m)) (T.drop m t) + +sucRes :: TestState -> a -> Maybe (TestResult a) +sucRes st = Just . ParseResultSuccess . ParseSuccess st + +errRes :: [TestParseError] -> Maybe (TestResult a) +errRes es = Just (ParseResultError (NESeq.unsafeFromSeq (Seq.fromList es))) + +custErr :: TestState -> Error -> TestParseError +custErr endSt = ParseError emptyStack endSt . CompoundErrorCustom + +stmErr :: TestState -> TestRawError -> TestParseError +stmErr endSt = ParseError emptyStack endSt . CompoundErrorStream . StreamError + +failErr :: TestState -> Text -> TestParseError +failErr endSt = ParseError emptyStack endSt . CompoundErrorFail + +markWith :: TestState -> TestParseError -> TestParseError +markWith s = markParseError (Mark Nothing s) + +anyTokErr :: TestState -> TestParseError +anyTokErr s = markWith s (stmErr s RawErrorAnyToken) + +anyChunkErr :: TestState -> TestParseError +anyChunkErr s = markWith s (stmErr s RawErrorAnyChunk) + +matchTokErr :: TestState -> Char -> Maybe Char -> TestParseError +matchTokErr s x my = markWith s (stmErr (fwd 1 s) (RawErrorMatchToken x my)) + +matchChunkErr :: TestState -> Text -> Maybe Text -> TestParseError +matchChunkErr s x my = markWith s (stmErr (fwd (T.length x) s) (RawErrorMatchChunk x my)) + +matchEndErr :: TestState -> Char -> TestParseError +matchEndErr s x = markWith s (stmErr (fwd 1 s) (RawErrorMatchEnd x)) + +takeTokErr :: TestState -> Int -> Maybe Char -> TestParseError +takeTokErr s n my = markWith s (stmErr (fwd n s) (RawErrorTakeTokensWhile1 my)) + +dropTokErr :: TestState -> Int -> Maybe Char -> TestParseError +dropTokErr s n my = markWith s (stmErr (fwd n s) (RawErrorDropTokensWhile1 my)) + +testParserCase :: (Show a, Eq a) => ParserCase a -> TestTree +testParserCase (ParserCase name parser input expected) = testCase name $ do + let actual = runParser parser (newOffsetStream input) + actual @?= expected + test_empty :: [TestTree] test_empty = - let parser = empty :: TestParser Int + let parser = emptyParser :: TestParser Int cases = - [ ("empty", InputOutput "" []) - , ("non-empty", InputOutput "hi" []) + [ ParserCase "empty" parser "" Nothing + , ParserCase "non-empty" parser "hi" Nothing ] - in testParserTrees parser cases + in fmap testParserCase cases test_pure :: [TestTree] test_pure = let parser = pure (1 :: Int) cases = - [ ("empty", InputOutput "" [parseSuccessResult 1 (OffsetStream 0 "")]) - , ("non-empty", InputOutput "hi" [parseSuccessResult 1 (OffsetStream 0 "hi")]) + [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") 1) + , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") 1) ] - in testParserTrees parser cases + in fmap testParserCase cases +test_fail :: [TestTree] +test_fail = + let parser = fail "i give up" :: TestParser Int + cases = + [ ParserCase "empty" parser "" (errRes [(failErr (OffsetStream 0 "") "i give up")]) + , ParserCase "non-empty" parser "hi" (errRes [(failErr (OffsetStream 0 "hi") "i give up")]) + ] + in fmap testParserCase cases + test_peek_token :: [TestTree] test_peek_token = let parser = peekToken cases = - [ ("empty", InputOutput "" [parseSuccessResult Nothing (OffsetStream 0 "")]) - , ("match", InputOutput "hi" [parseSuccessResult (Just 'h') (OffsetStream 0 "hi")]) + [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") Nothing) + , ParserCase "match" parser "hi" (sucRes (OffsetStream 0 "hi") (Just 'h')) ] - in testParserTrees parser cases + in fmap testParserCase cases test_pop_token :: [TestTree] test_pop_token = let parser = popToken cases = - [ ("empty", InputOutput "" [parseSuccessResult Nothing (OffsetStream 0 "")]) - , ("match", InputOutput "hi" [parseSuccessResult (Just 'h') (OffsetStream 1 "i")]) + [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") Nothing) + , ParserCase "match" parser "hi" (sucRes (OffsetStream 1 "i") (Just 'h')) ] - in testParserTrees parser cases + in fmap testParserCase cases test_peek_chunk :: [TestTree] test_peek_chunk = let parser = peekChunk 2 cases = - [ ("len 0", InputOutput "" [parseSuccessResult Nothing (OffsetStream 0 "")]) - , ("len 1", InputOutput "h" [parseSuccessResult (Just "h") (OffsetStream 0 "h")]) - , ("len 2", InputOutput "hi" [parseSuccessResult (Just "hi") (OffsetStream 0 "hi")]) - , ("len 3", InputOutput "hii" [parseSuccessResult (Just "hi") (OffsetStream 0 "hii")]) + [ ParserCase "len 0" parser "" (sucRes (OffsetStream 0 "") Nothing) + , ParserCase "len 1" parser "h" (sucRes (OffsetStream 0 "h") (Just "h")) + , ParserCase "len 2" parser "hi" (sucRes (OffsetStream 0 "hi") (Just "hi")) + , ParserCase "len 3" parser "hii" (sucRes (OffsetStream 0 "hii") (Just "hi")) ] - in testParserTrees parser cases + in fmap testParserCase cases test_pop_chunk :: [TestTree] test_pop_chunk = let parser = popChunk 2 cases = - [ ("len 0", InputOutput "" [parseSuccessResult Nothing (OffsetStream 0 "")]) - , ("len 1", InputOutput "h" [parseSuccessResult (Just "h") (OffsetStream 1 "")]) - , ("len 2", InputOutput "hi" [parseSuccessResult (Just "hi") (OffsetStream 2 "")]) - , ("len 3", InputOutput "hii" [parseSuccessResult (Just "hi") (OffsetStream 2 "i")]) + [ ParserCase "len 0" parser "" (sucRes (OffsetStream 0 "") Nothing) + , ParserCase "len 1" parser "h" (sucRes (OffsetStream 1 "") (Just "h")) + , ParserCase "len 2" parser "hi" (sucRes (OffsetStream 2 "") (Just "hi")) + , ParserCase "len 3" parser "hii" (sucRes (OffsetStream 2 "i") (Just "hi")) ] - in testParserTrees parser cases + in fmap testParserCase cases test_drop_chunk :: [TestTree] test_drop_chunk = let parser = dropChunk 2 cases = - [ ("len 0", InputOutput "" [parseSuccessResult Nothing (OffsetStream 0 "")]) - , ("len 1", InputOutput "h" [parseSuccessResult (Just 1) (OffsetStream 1 "")]) - , ("len 2", InputOutput "hi" [parseSuccessResult (Just 2) (OffsetStream 2 "")]) - , ("len 3", InputOutput "hii" [parseSuccessResult (Just 2) (OffsetStream 2 "i")]) + [ ParserCase "len 0" parser "" (sucRes (OffsetStream 0 "") Nothing) + , ParserCase "len 1" parser "h" (sucRes (OffsetStream 1 "") (Just 1)) + , ParserCase "len 2" parser "hi" (sucRes (OffsetStream 2 "") (Just 2)) + , ParserCase "len 3" parser "hii" (sucRes (OffsetStream 2 "i") (Just 2)) ] - in testParserTrees parser cases + in fmap testParserCase cases test_is_end :: [TestTree] test_is_end = let parser = isEnd cases = - [ ("empty", InputOutput "" [parseSuccessResult True (OffsetStream 0 "")]) - , ("non-empty", InputOutput "hi" [parseSuccessResult False (OffsetStream 0 "hi")]) + [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") True) + , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") False) ] - in testParserTrees parser cases + in fmap testParserCase cases test_match_end :: [TestTree] test_match_end = let parser = matchEnd cases = - [ ("empty", InputOutput "" [parseSuccessResult () (OffsetStream 0 "")]) - , ("non-empty", InputOutput "hi" []) + [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") ()) + , ParserCase "non-empty" parser "hi" (errRes [matchEndErr (OffsetStream 0 "hi") 'h']) ] - in testParserTrees parser cases + in fmap testParserCase cases test_any_token :: [TestTree] test_any_token = let parser = anyToken cases = - [ ("empty", InputOutput "" []) - , ("non-empty", InputOutput "hi" [parseSuccessResult 'h' (OffsetStream 1 "i")]) + [ ParserCase "empty" parser "" (errRes [anyTokErr (OffsetStream 0 "")]) + , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 1 "i") 'h') ] - in testParserTrees parser cases + in fmap testParserCase cases test_any_chunk :: [TestTree] test_any_chunk = let parser = anyChunk 2 :: TestParser Text cases = - [ ("len 0", InputOutput "" []) - , ("len 1", InputOutput "h" [parseSuccessResult "h" (OffsetStream 1 "")]) - , ("len 2", InputOutput "hi" [parseSuccessResult "hi" (OffsetStream 2 "")]) - , ("len 3", InputOutput "hii" [parseSuccessResult "hi" (OffsetStream 2 "i")]) + [ ParserCase "len 0" parser "" (errRes [anyChunkErr (OffsetStream 0 "")]) + , ParserCase "len 1" parser "h" (sucRes (OffsetStream 1 "") "h") + , ParserCase "len 2" parser "hi" (sucRes (OffsetStream 2 "") "hi") + , ParserCase "len 3" parser "hii" (sucRes (OffsetStream 2 "i") "hi") ] - in testParserTrees parser cases + in fmap testParserCase cases test_match_token :: [TestTree] test_match_token = let parser = matchToken 'h' cases = - [ ("empty", InputOutput "" []) - , ("non-empty", InputOutput "hi" [parseSuccessResult 'h' (OffsetStream 1 "i")]) - , ("non-match", InputOutput "bye" []) + [ ParserCase "empty" parser "" (errRes [matchTokErr (OffsetStream 0 "") 'h' Nothing]) + , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 1 "i") 'h') + , ParserCase "non-match" parser "bye" (errRes [matchTokErr (OffsetStream 0 "bye") 'h' (Just 'b')]) ] - in testParserTrees parser cases + in fmap testParserCase cases test_match_chunk :: [TestTree] test_match_chunk = let parser = matchChunk "hi" cases = - [ ("empty", InputOutput "" []) - , ("non-empty", InputOutput "hi" [parseSuccessResult "hi" (OffsetStream 2 "")]) - , ("prefix", InputOutput "hiya" [parseSuccessResult "hi" (OffsetStream 2 "ya")]) - , ("partial", InputOutput "hey" []) - , ("non-match", InputOutput "bye" []) + [ ParserCase "empty" parser "" (errRes [matchChunkErr (OffsetStream 0 "") "hi" Nothing]) + , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 2 "") "hi") + , ParserCase "prefix" parser "hiya" (sucRes (OffsetStream 2 "ya") "hi") + , ParserCase "partial" parser "hey" (errRes [matchChunkErr (OffsetStream 0 "hey") "hi" (Just "he")]) + , ParserCase "non-match" parser "bye" (errRes [matchChunkErr (OffsetStream 0 "bye") "hi" (Just "by")]) + , ParserCase "short" parser "h" (errRes [matchChunkErr (OffsetStream 0 "h") "hi" (Just "h")]) ] - in testParserTrees parser cases + in fmap testParserCase cases test_greedy_star :: [TestTree] test_greedy_star = - let parser = greedyStarParser (matchToken 'h') + let parser = greedyStarParser (matchToken 'h') :: TestParser String cases = - [ ("empty", InputOutput "" [parseSuccessResult "" (OffsetStream 0 "")]) - , ("non-empty", InputOutput "hi" [parseSuccessResult "h" (OffsetStream 1 "i")]) - , ("repeat", InputOutput "hhi" [parseSuccessResult "hh" (OffsetStream 2 "i")]) - , ("full", InputOutput "hhh" [parseSuccessResult "hhh" (OffsetStream 3 "")]) - , ("non-match", InputOutput "bye" [parseSuccessResult "" (OffsetStream 0 "bye")]) + [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") "") + , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 1 "i") "h") + , ParserCase "repeat" parser "hhi" (sucRes (OffsetStream 2 "i") "hh") + , ParserCase "full" parser "hhh" (sucRes (OffsetStream 3 "") "hhh") + , ParserCase "non-match" parser "bye" (sucRes (OffsetStream 0 "bye") "") ] - in testParserTrees parser cases + in fmap testParserCase cases test_greedy_star_unit :: [TestTree] test_greedy_star_unit = let parser = greedyStarParser_ (matchToken 'h') cases = - [ ("empty", InputOutput "" [parseSuccessResult () (OffsetStream 0 "")]) - , ("non-empty", InputOutput "hi" [parseSuccessResult () (OffsetStream 1 "i")]) - , ("repeat", InputOutput "hhi" [parseSuccessResult () (OffsetStream 2 "i")]) - , ("full", InputOutput "hhh" [parseSuccessResult () (OffsetStream 3 "")]) - , ("non-match", InputOutput "bye" [parseSuccessResult () (OffsetStream 0 "bye")]) + [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") ()) + , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 1 "i") ()) + , ParserCase "repeat" parser "hhi" (sucRes (OffsetStream 2 "i") ()) + , ParserCase "full" parser "hhh" (sucRes (OffsetStream 3 "") ()) + , ParserCase "non-match" parser "bye" (sucRes (OffsetStream 0 "bye") ()) ] - in testParserTrees parser cases + in fmap testParserCase cases test_greedy_plus :: [TestTree] test_greedy_plus = - let parser = greedyPlusParser (matchToken 'h') + let parser = greedyPlusParser (matchToken 'h') :: TestParser String cases = - [ ("empty", InputOutput "" []) - , ("non-empty", InputOutput "hi" [parseSuccessResult "h" (OffsetStream 1 "i")]) - , ("repeat", InputOutput "hhi" [parseSuccessResult "hh" (OffsetStream 2 "i")]) - , ("full", InputOutput "hhh" [parseSuccessResult "hhh" (OffsetStream 3 "")]) - , ("non-match", InputOutput "bye" []) + [ ParserCase "empty" parser "" (errRes [matchTokErr (OffsetStream 0 "") 'h' Nothing]) + , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 1 "i") "h") + , ParserCase "repeat" parser "hhi" (sucRes (OffsetStream 2 "i") "hh") + , ParserCase "full" parser "hhh" (sucRes (OffsetStream 3 "") "hhh") + , ParserCase "non-match" parser "bye" (errRes [matchTokErr (OffsetStream 0 "bye") 'h' (Just 'b')]) ] - in testParserTrees parser cases + in fmap testParserCase cases test_greedy_plus_unit :: [TestTree] test_greedy_plus_unit = let parser = greedyPlusParser_ (matchToken 'h') cases = - [ ("empty", InputOutput "" []) - , ("non-empty", InputOutput "hi" [parseSuccessResult () (OffsetStream 1 "i")]) - , ("repeat", InputOutput "hhi" [parseSuccessResult () (OffsetStream 2 "i")]) - , ("full", InputOutput "hhh" [parseSuccessResult () (OffsetStream 3 "")]) - , ("non-match", InputOutput "bye" []) - ] - in testParserTrees parser cases - -test_branch :: [TestTree] -test_branch = - let parser = branchParser [matchToken 'h', matchToken 'x'] - cases = - [ ("empty", InputOutput "" []) - , ("first", InputOutput "hi" [parseSuccessResult 'h' (OffsetStream 1 "i")]) - , ("second", InputOutput "xi" [parseSuccessResult 'x' (OffsetStream 1 "i")]) - , ("non-match", InputOutput "bye" []) - ] - in testParserTrees parser cases - -test_branch_first :: [TestTree] -test_branch_first = - let parser = branchParser [anyToken $> 'h', matchToken 'x'] - cases = - [ ("empty", InputOutput "" []) - , ("first", InputOutput "hi" [parseSuccessResult 'h' (OffsetStream 1 "i")]) - , ("second", InputOutput "xi" [parseSuccessResult 'h' (OffsetStream 1 "i")]) - ] - in testParserTrees parser cases - -test_branch_second :: [TestTree] -test_branch_second = - let parser = branchParser [empty, anyToken $> 'x'] - cases = - [ ("empty", InputOutput "" []) - , ("first", InputOutput "hi" [parseSuccessResult 'x' (OffsetStream 1 "i")]) - , ("second", InputOutput "xi" [parseSuccessResult 'x' (OffsetStream 1 "i")]) - ] - in testParserTrees parser cases - -test_combine :: [TestTree] -test_combine = - let parser = asum [matchToken 'h', matchToken 'x'] - cases = - [ ("empty", InputOutput "" []) - , ("first", InputOutput "hi" [parseSuccessResult 'h' (OffsetStream 1 "i")]) - , ("second", InputOutput "xi" [parseSuccessResult 'x' (OffsetStream 1 "i")]) - , ("non-match", InputOutput "bye" []) + [ ParserCase "empty" parser "" (errRes [matchTokErr (OffsetStream 0 "") 'h' Nothing]) + , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 1 "i") ()) + , ParserCase "repeat" parser "hhi" (sucRes (OffsetStream 2 "i") ()) + , ParserCase "full" parser "hhh" (sucRes (OffsetStream 3 "") ()) + , ParserCase "non-match" parser "bye" (errRes [matchTokErr (OffsetStream 0 "bye") 'h' (Just 'b')]) ] - in testParserTrees parser cases + in fmap testParserCase cases -test_combine_first :: [TestTree] -test_combine_first = - let state = OffsetStream 1 "i" - parser = asum [anyToken $> 'h', matchToken 'x'] +test_or :: [TestTree] +test_or = + let parser = orParser (matchToken 'h') (matchToken 'x') cases = - [ ("empty", InputOutput "" []) - , ("first", InputOutput "hi" [parseSuccessResult 'h' state]) - , ("second", InputOutput "xi" [parseSuccessResult 'h' state, parseSuccessResult 'x' state]) + [ ParserCase "empty" parser "" $ errRes + [ matchTokErr (OffsetStream 0 "") 'h' Nothing + , matchTokErr (OffsetStream 0 "") 'x' Nothing + ] + , ParserCase "first" parser "hi" (sucRes (OffsetStream 1 "i") 'h') + , ParserCase "second" parser "xi" (sucRes (OffsetStream 1 "i") 'x') + , ParserCase "non-match" parser "bye" $ errRes + [ matchTokErr (OffsetStream 0 "bye") 'h' (Just 'b') + , matchTokErr (OffsetStream 0 "bye") 'x' (Just 'b') + ] ] - in testParserTrees parser cases + in fmap testParserCase cases -test_combine_second :: [TestTree] -test_combine_second = +test_asum :: [TestTree] +test_asum = let state = OffsetStream 1 "i" - parser = asum [empty, anyToken $> 'x'] + parser = asum [matchToken 'h', 'y' <$ anyToken, matchToken 'x'] cases = - [ ("empty", InputOutput "" []) - , ("first", InputOutput "hi" [parseSuccessResult 'x' state]) - , ("second", InputOutput "xi" [parseSuccessResult 'x' state]) + [ ParserCase "empty" parser "" $ errRes + [ matchTokErr (OffsetStream 0 "") 'h' Nothing + , anyTokErr (OffsetStream 0 "") + , matchTokErr (OffsetStream 0 "") 'x' Nothing + ] + , ParserCase "first" parser "hi" (sucRes state 'h') + , ParserCase "middle" parser "zi" (sucRes state 'y') + , ParserCase "last" parser "xi" (sucRes state 'y') ] - in testParserTrees parser cases + in fmap testParserCase cases -test_with_default_empty :: [TestTree] -test_with_default_empty = - let parser = defaultParser 'z' empty +test_default_empty :: [TestTree] +test_default_empty = + let parser = defaultParser 'z' emptyParser cases = - [ ("empty", InputOutput "" [parseSuccessResult 'z' (OffsetStream 0 "")]) - , ("non-empty", InputOutput "hi" [parseSuccessResult 'z' (OffsetStream 0 "hi")]) + [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") 'z') + , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") 'z') ] - in testParserTrees parser cases + in fmap testParserCase cases -test_with_default :: [TestTree] -test_with_default = +test_default :: [TestTree] +test_default = let parser = defaultParser 'z' (matchToken 'h') cases = - [ ("empty", InputOutput "" [parseSuccessResult 'z' (OffsetStream 0 "")]) - , ("match", InputOutput "hi" [parseSuccessResult 'h' (OffsetStream 1 "i")]) - , ("non-match", InputOutput "bye" [parseSuccessResult 'z' (OffsetStream 0 "bye")]) + [ ParserCase "non-match empty" parser "" (sucRes (OffsetStream 0 "") 'z') + , ParserCase "match" parser "hi" (sucRes (OffsetStream 1 "i") 'h') + , ParserCase "non-match" parser "bye" (sucRes (OffsetStream 0 "bye") 'z') ] - in testParserTrees parser cases + in fmap testParserCase cases -test_bind_multi_pre :: [TestTree] -test_bind_multi_pre = +test_bind_1 :: [TestTree] +test_bind_1 = let state = OffsetStream 1 "i" - parser = asum [anyToken $> 'h', matchToken 'x'] >>= \c -> pure [c, c] + parser = matchToken 'x' >>= \c -> pure [c, c] cases = - [ ("empty", InputOutput "" []) - , ("first", InputOutput "hi" [parseSuccessResult "hh" state]) - , ("second", InputOutput "xi" [parseSuccessResult "hh" state, parseSuccessResult "xx" state]) + [ ParserCase "empty" parser "" (errRes [matchTokErr (OffsetStream 0 "") 'x' Nothing]) + , ParserCase "first" parser "hi" (errRes [matchTokErr (OffsetStream 0 "hi") 'x' (Just 'h')]) + , ParserCase "second" parser "xi" (sucRes state "xx") ] - in testParserTrees parser cases + in fmap testParserCase cases -test_bind_multi_post :: [TestTree] -test_bind_multi_post = - let state1 = OffsetStream 1 "i" - state2 = OffsetStream 2 "" - parser = anyToken >>= \x -> asum [pure x, matchToken 'i'] +test_bind_2 :: [TestTree] +test_bind_2 = + let state = OffsetStream 1 "i" + parser = anyToken >>= \x -> if x == 'x' then pure 'y' else emptyParser cases = - [ ("empty", InputOutput "" []) - , ("first", InputOutput "hi" [parseSuccessResult 'h' state1, parseSuccessResult 'i' state2]) - , ("second", InputOutput "xi" [parseSuccessResult 'x' state1, parseSuccessResult 'i' state2]) + [ ParserCase "empty" parser "" (errRes [anyTokErr (OffsetStream 0 "")]) + , ParserCase "first" parser "hi" Nothing + , ParserCase "second" parser "xi" (sucRes state 'y') ] - in testParserTrees parser cases + in fmap testParserCase cases test_throw :: [TestTree] test_throw = let err = Error "boo" - parser = throwError err :: TestParser Int + parser = throwParser err :: TestParser Int cases = - [ ("empty", InputOutput "" [parseErrorResult err (OffsetStream 0 "")]) - , ("non-empty", InputOutput "hi" [parseErrorResult err (OffsetStream 0 "hi")]) + [ ParserCase "empty" parser "" (errRes [custErr (OffsetStream 0 "") err]) + , ParserCase "non-empty" parser "hi" (errRes [custErr (OffsetStream 0 "hi") err]) ] - in testParserTrees parser cases + in fmap testParserCase cases test_consume_throw :: [TestTree] test_consume_throw = let err = Error "boo" - parser = anyToken *> throwError err :: TestParser Int + parser = anyToken *> throwParser err :: TestParser Int cases = - [ ("empty", InputOutput "" []) - , ("non-empty", InputOutput "hi" [parseErrorResult err (OffsetStream 1 "i")]) + [ ParserCase "empty" parser "" (errRes [anyTokErr (OffsetStream 0 "")]) + , ParserCase "non-empty" parser "hi" (errRes [custErr (OffsetStream 1 "i") err]) ] - in testParserTrees parser cases + in fmap testParserCase cases -test_with_default_throw :: [TestTree] -test_with_default_throw = +test_default_throw :: [TestTree] +test_default_throw = let err = Error "boo" - parser = defaultParser 'z' (throwError err) + parser = defaultParser 'z' (throwParser err) cases = - [ ("empty", InputOutput "" [parseErrorResult err (OffsetStream 0 "")]) - , ("non-empty", InputOutput "hi" [parseErrorResult err (OffsetStream 0 "hi")]) + [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") 'z') + , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") 'z') ] - in testParserTrees parser cases + in fmap testParserCase cases -test_with_default_consume_throw :: [TestTree] -test_with_default_consume_throw = +test_default_consume_throw :: [TestTree] +test_default_consume_throw = let err = Error "boo" - parser = defaultParser 'z' (anyToken *> throwError err) + parser = defaultParser 'z' (anyToken *> throwParser err) cases = - [ ("empty", InputOutput "" [parseSuccessResult 'z' (OffsetStream 0 "")]) - , ("non-empty", InputOutput "hi" [parseErrorResult err (OffsetStream 1 "i")]) + [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") 'z') + , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") 'z') ] - in testParserTrees parser cases + in fmap testParserCase cases test_throw_mixed :: [TestTree] test_throw_mixed = let state = OffsetStream 0 "hi" err = Error "boo" - parser = asum [throwError err, pure 1 :: TestParser Int] + parser = orParser (throwParser err) (pure 1) :: TestParser Int cases = - [ ("non-empty", InputOutput "hi" [parseErrorResult err state, parseSuccessResult 1 state]) + [ ParserCase "non-empty" parser "hi" (sucRes state 1) ] - in testParserTrees parser cases + in fmap testParserCase cases +test_throw_mixed_flip :: [TestTree] +test_throw_mixed_flip = + let state = OffsetStream 0 "hi" + err = Error "boo" + parser = orParser (pure 1) (throwParser err) :: TestParser Int + cases = + [ ParserCase "non-empty" parser "hi" (sucRes state 1) + ] + in fmap testParserCase cases + test_catch :: [TestTree] test_catch = let state = OffsetStream 0 "hi" err = Error "boo" - parser = catchError (asum [throwError err, pure 1]) (\(Error m) -> pure (if m == "boo" then 2 else 3)) :: TestParser Int + parser = catchParser (throwParser err) (\(Error m) -> pure (if m == "boo" then 2 else 3)) :: TestParser Int cases = - [ ("non-empty", InputOutput "hi" [parseSuccessResult 2 state, parseSuccessResult 1 state]) + [ ParserCase "non-empty" parser "hi" (sucRes state 2) ] - in testParserTrees parser cases + in fmap testParserCase cases test_catch_recur :: [TestTree] test_catch_recur = let state = OffsetStream 0 "hi" err1 = Error "boo" err2 = Error "two" - parser = catchError (throwError err1) (const (throwError err2)) :: TestParser Int - cases = - [ ("non-empty", InputOutput "hi" [parseErrorResult err2 state]) - ] - in testParserTrees parser cases - -test_suppress_success :: [TestTree] -test_suppress_success = - let state = OffsetStream 0 "hi" - parser = suppressParser (asum [pure 1, pure 2]) :: TestParser Int - cases = - [ ("non-empty", InputOutput "hi" [parseSuccessResult 1 state, parseSuccessResult 2 state]) - ] - in testParserTrees parser cases - -test_suppress_fail_first :: [TestTree] -test_suppress_fail_first = - let err = Error "boo" - parser = suppressParser (asum [throwError err, pure 2]) :: TestParser Int - cases = - [ ("non-empty", InputOutput "hi" [parseSuccessResult 2 (OffsetStream 0 "hi")]) - ] - in testParserTrees parser cases - -test_suppress_fail_second :: [TestTree] -test_suppress_fail_second = - let err = Error "boo" - parser = suppressParser (asum [pure 1, throwError err]) :: TestParser Int - cases = - [ ("non-empty", InputOutput "hi" [parseSuccessResult 1 (OffsetStream 0 "hi")]) - ] - in testParserTrees parser cases - -test_suppress_fail_both :: [TestTree] -test_suppress_fail_both = - let state = OffsetStream 0 "hi" - err1 = Error "boo1" - err2 = Error "boo2" - parser = suppressParser (asum [throwError err1, throwError err2]) :: TestParser Int - cases = - [ ("non-empty", InputOutput "hi" [parseErrorResult err1 state, parseErrorResult err2 state]) - ] - in testParserTrees parser cases - -test_isolate_success :: [TestTree] -test_isolate_success = - let state = OffsetStream 0 "hi" - parser = isolateParser (asum [pure 1, pure 2]) :: TestParser Int - cases = - [ ("non-empty", InputOutput "hi" [parseSuccessResult 1 state]) - ] - in testParserTrees parser cases - -test_isolate_fail_first :: [TestTree] -test_isolate_fail_first = - let err = Error "boo" - parser = isolateParser (asum [throwError err, pure 2]) :: TestParser Int - cases = - [ ("non-empty", InputOutput "hi" [parseSuccessResult 2 (OffsetStream 0 "hi")]) - ] - in testParserTrees parser cases - -test_isolate_fail_second :: [TestTree] -test_isolate_fail_second = - let err = Error "boo" - parser = isolateParser (asum [pure 1, throwError err]) :: TestParser Int - cases = - [ ("non-empty", InputOutput "hi" [parseSuccessResult 1 (OffsetStream 0 "hi")]) - ] - in testParserTrees parser cases - -test_isolate_fail_both :: [TestTree] -test_isolate_fail_both = - let state = OffsetStream 0 "hi" - err1 = Error "boo1" - err2 = Error "boo2" - parser = isolateParser (asum [throwError err1, throwError err2]) :: TestParser Int + parser = catchParser (throwParser err1) (const (throwParser err2)) :: TestParser Int cases = - [ ("non-empty", InputOutput "hi" [parseErrorResult err1 state, parseErrorResult err2 state]) + [ ParserCase "non-empty" parser "hi" (errRes [custErr state err2]) ] - in testParserTrees parser cases + in fmap testParserCase cases test_silence_success :: [TestTree] test_silence_success = let state = OffsetStream 0 "hi" - parser = silenceParser (asum [pure 1, pure 2]) :: TestParser Int + parser = silenceParser (pure 1) :: TestParser Int cases = - [ ("non-empty", InputOutput "hi" [parseSuccessResult 1 state, parseSuccessResult 2 state]) + [ ParserCase "non-empty" parser "hi" (sucRes state 1) ] - in testParserTrees parser cases + in fmap testParserCase cases -test_silence_fail_first :: [TestTree] -test_silence_fail_first = +test_silence_fail :: [TestTree] +test_silence_fail = let err = Error "boo" - parser = silenceParser (asum [throwError err, pure 2]) :: TestParser Int + parser = silenceParser (throwParser err) :: TestParser Int cases = - [ ("non-empty", InputOutput "hi" [parseSuccessResult 2 (OffsetStream 0 "hi")]) + [ ParserCase "non-empty" parser "hi" Nothing ] - in testParserTrees parser cases + in fmap testParserCase cases -test_silence_fail_second :: [TestTree] -test_silence_fail_second = - let err = Error "boo" - parser = silenceParser (asum [pure 1, throwError err]) :: TestParser Int +test_silence_empty :: [TestTree] +test_silence_empty = + let parser = silenceParser emptyParser :: TestParser Int cases = - [ ("non-empty", InputOutput "hi" [parseSuccessResult 1 (OffsetStream 0 "hi")]) + [ ParserCase "non-empty" parser "hi" Nothing ] - in testParserTrees parser cases + in fmap testParserCase cases -test_silence_fail_both :: [TestTree] -test_silence_fail_both = - let err1 = Error "boo1" - err2 = Error "boo2" - parser = silenceParser (asum [throwError err1, throwError err2]) :: TestParser Int +test_look_ahead_pure :: [TestTree] +test_look_ahead_pure = + let parser = lookAheadParser Nothing (pure 1) :: TestParser Int cases = - [ ("non-empty", InputOutput "hi" []) + [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") 1) + , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") 1) ] - in testParserTrees parser cases + in fmap testParserCase cases test_look_ahead_success :: [TestTree] test_look_ahead_success = - let parser = lookAheadParser anyToken + let parser = lookAheadParser Nothing anyToken cases = - [ ("empty", InputOutput "" []) - , ("non-empty", InputOutput "hi" [parseSuccessResult 'h' (OffsetStream 0 "hi")]) + [ ParserCase "non-match empty" parser "" (errRes [markWith (OffsetStream 0 "") (anyTokErr (OffsetStream 0 ""))]) + , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") 'h') ] - in testParserTrees parser cases + in fmap testParserCase cases test_look_ahead_failure :: [TestTree] test_look_ahead_failure = let err = Error "boo" - parser = lookAheadParser (anyToken *> throwError err) :: TestParser Char + parser = lookAheadParser Nothing (anyToken *> throwParser err) :: TestParser Char cases = - [ ("empty", InputOutput "" []) - , ("non-empty", InputOutput "hi" [parseErrorResult err (OffsetStream 0 "hi")]) + [ 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)]) ] - in testParserTrees parser cases + in fmap testParserCase cases +test_commit :: [TestTree] +test_commit = + let parser = commitParser (void (matchToken 'h')) (matchChunk "hi") :: TestParser Text + cases = + [ ParserCase "non-match empty" parser "" Nothing + , ParserCase "non-match non-empty" parser "ho" (errRes [matchChunkErr (OffsetStream 0 "ho") "hi" (Just "ho")]) + , ParserCase "match" parser "hi" (sucRes (OffsetStream 2 "") "hi") + ] + in fmap testParserCase cases + test_take_while :: [TestTree] test_take_while = let parser = takeTokensWhile (=='h') :: TestParser Text cases = - [ ("empty", InputOutput "" [parseSuccessResult "" (OffsetStream 0 "")]) - , ("non-match", InputOutput "i" [parseSuccessResult "" (OffsetStream 0 "i")]) - , ("match", InputOutput "hi" [parseSuccessResult "h" (OffsetStream 1 "i")]) - , ("match 2", InputOutput "hhi" [parseSuccessResult "hh" (OffsetStream 2 "i")]) - , ("match end", InputOutput "hh" [parseSuccessResult "hh" (OffsetStream 2 "")]) + [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") "") + , ParserCase "non-match" parser "i" (sucRes (OffsetStream 0 "i") "") + , ParserCase "match" parser "hi" (sucRes (OffsetStream 1 "i") "h") + , ParserCase "match 2" parser "hhi" (sucRes (OffsetStream 2 "i") "hh") + , ParserCase "match end" parser "hh" (sucRes (OffsetStream 2 "") "hh") ] - in testParserTrees parser cases + in fmap testParserCase cases test_take_while_1 :: [TestTree] test_take_while_1 = - let parser = takeTokensWhile1 (=='h') :: TestParser Text + let parser = takeTokensWhile1 Nothing (=='h') :: TestParser Text cases = - [ ("empty", InputOutput "" []) - , ("non-match", InputOutput "i" []) - , ("match", InputOutput "hi" [parseSuccessResult "h" (OffsetStream 1 "i")]) - , ("match 2", InputOutput "hhi" [parseSuccessResult "hh" (OffsetStream 2 "i")]) - , ("match end", InputOutput "hh" [parseSuccessResult "hh" (OffsetStream 2 "")]) + [ ParserCase "empty" parser "" (errRes [takeTokErr(OffsetStream 0 "") 0 Nothing]) + , ParserCase "non-match" parser "i" (errRes [takeTokErr (OffsetStream 0 "i") 0 (Just 'i')]) + , ParserCase "match" parser "hi" (sucRes (OffsetStream 1 "i") "h") + , ParserCase "match 2" parser "hhi" (sucRes (OffsetStream 2 "i") "hh") + , ParserCase "match end" parser "hh" (sucRes (OffsetStream 2 "") "hh") ] - in testParserTrees parser cases + in fmap testParserCase cases test_drop_while :: [TestTree] test_drop_while = let parser = dropTokensWhile (=='h') :: TestParser Int cases = - [ ("empty", InputOutput "" [parseSuccessResult 0 (OffsetStream 0 "")]) - , ("non-match", InputOutput "i" [parseSuccessResult 0 (OffsetStream 0 "i")]) - , ("match", InputOutput "hi" [parseSuccessResult 1 (OffsetStream 1 "i")]) - , ("match 2", InputOutput "hhi" [parseSuccessResult 2 (OffsetStream 2 "i")]) - , ("match end", InputOutput "hh" [parseSuccessResult 2 (OffsetStream 2 "")]) + [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") 0) + , ParserCase "non-match" parser "i" (sucRes (OffsetStream 0 "i") 0) + , ParserCase "match" parser "hi" (sucRes (OffsetStream 1 "i") 1) + , ParserCase "match 2" parser "hhi" (sucRes (OffsetStream 2 "i") 2) + , ParserCase "match end" parser "hh" (sucRes (OffsetStream 2 "") 2) ] - in testParserTrees parser cases + in fmap testParserCase cases test_drop_while_1 :: [TestTree] test_drop_while_1 = - let parser = dropTokensWhile1 (=='h') :: TestParser Int + let parser = dropTokensWhile1 Nothing (=='h') :: TestParser Int cases = - [ ("empty", InputOutput "" []) - , ("non-match", InputOutput "i" []) - , ("match", InputOutput "hi" [parseSuccessResult 1 (OffsetStream 1 "i")]) - , ("match 2", InputOutput "hhi" [parseSuccessResult 2 (OffsetStream 2 "i")]) - , ("match end", InputOutput "hh" [parseSuccessResult 2 (OffsetStream 2 "")]) + [ ParserCase "empty" parser "" (errRes [dropTokErr (OffsetStream 0 "") 0 Nothing]) + , ParserCase "non-match" parser "i" (errRes [dropTokErr (OffsetStream 0 "i") 0 (Just 'i')]) + , ParserCase "match" parser "hi" (sucRes (OffsetStream 1 "i") 1) + , ParserCase "match 2" parser "hhi" (sucRes (OffsetStream 2 "i") 2) + , ParserCase "match end" parser "hh" (sucRes (OffsetStream 2 "") 2) ] - in testParserTrees parser cases + in fmap testParserCase cases -testJsonCase :: TestName -> Text -> [Json] -> TestTree +type JsonResult = Maybe Json + +testJsonCase :: TestName -> Text -> JsonResult -> TestTree testJsonCase name str expected = testCase ("json " <> name) $ do let actual = parseJson str actual @?= expected -testJsonTrees :: [(TestName, Text, [Json])] -> [TestTree] +testJsonTrees :: [(TestName, Text, JsonResult)] -> [TestTree] testJsonTrees = fmap (\(n, s, e) -> testJsonCase n s e) +parseJson :: Text -> JsonResult +parseJson str = + let p = jsonParser <* matchEnd + in case runParser p str of + Just (ParseResultSuccess (ParseSuccess _ a)) -> Just a + _ -> Nothing + test_json :: [TestTree] test_json = let nullVal = Json JsonNull trueVal = Json (JsonBool True) falseVal = Json (JsonBool False) - arrVal = Json . JsonArray + arrVal = Json . JsonArray . Seq.fromList strVal = Json . JsonString - objVal = Json . JsonObject + objVal = Json . JsonObject . Seq.fromList + numVal = Json . JsonNum cases = - [ ("empty", "", []) - , ("bad", "bad", []) - , ("null", "null", [nullVal]) - , ("true", "true", [trueVal]) - , ("false", "false", [falseVal]) - , ("arr0", "[]", [arrVal []]) - , ("arr1", "[null]", [arrVal [nullVal]]) - , ("arr2", "[null, false]", [arrVal [nullVal, falseVal]]) - , ("arr3", "[null, false, true]", [arrVal [nullVal, falseVal, trueVal]]) - , ("arrx", "[null,]", []) - , ("str0", "\"\"", [strVal ""]) - , ("str1", "\"x\"", [strVal "x"]) - , ("str2", "\"xy\"", [strVal "xy"]) - , ("str3", "\"xyz\"", [strVal "xyz"]) - -- TODO(ejconlon) Refine parser to make this pass - -- , ("str4", "\"xy\\\"z\"", [strVal "xy\"z"]) - , ("obj0", "{}", [objVal []]) - , ("obj1", "{\"x\": true}", [objVal [("x", trueVal)]]) - , ("obj2", "{\"x\": true, \"y\": false}", [objVal [("x", trueVal), ("y", falseVal)]]) + [ ("empty", "", Nothing) + , ("bad", "bad", Nothing) + , ("null", "null", Just nullVal) + , ("true", "true", Just trueVal) + , ("false", "false", Just falseVal) + , ("arr0", "[]", Just (arrVal [])) + , ("arr1", "[null]", Just (arrVal [nullVal])) + , ("arr2", "[null, false]", Just (arrVal [nullVal, falseVal])) + , ("arr3", "[null, false, true]", Just (arrVal [nullVal, falseVal, trueVal])) + , ("arrx", "[null,]", Nothing) + , ("str0", "\"\"", Just (strVal "")) + , ("str1", "\"x\"", Just (strVal "x")) + , ("str2", "\"xy\"", Just (strVal "xy")) + , ("str3", "\"xyz\"", Just (strVal "xyz")) + , ("str4", "\"xy\\\"z\"", Just (strVal "xy\"z")) + , ("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"))) + , ("num3", "1e100", Just (numVal (read "1e100"))) + , ("num4", "{\"x\": 1e100, \"y\": 123.45}", Just (objVal [("x", numVal (read "1e100")), ("y", numVal (read "123.45"))])) ] in testJsonTrees cases