simple-parser 0.10.0 → 0.11.0

raw patch · 16 files changed

+777/−502 lines, 16 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• simple-parser.cabal +9/−6
• src/SimpleParser.hs +2/−0
• src/SimpleParser/Examples/Ast.hs +0/−166
• src/SimpleParser/Examples/Common/Sexp.hs +24/−0
• src/SimpleParser/Examples/Direct/Ast.hs +166/−0
• src/SimpleParser/Examples/Direct/Json.hs +108/−0
• src/SimpleParser/Examples/Direct/Prop.hs +51/−0
• src/SimpleParser/Examples/Direct/Sexp.hs +130/−0
• src/SimpleParser/Examples/Json.hs +0/−108
• src/SimpleParser/Examples/Lexed/Sexp.hs +167/−0
• src/SimpleParser/Examples/Prop.hs +0/−51
• src/SimpleParser/Examples/Sexp.hs +0/−139
• src/SimpleParser/Lexer.hs +88/−0
• src/SimpleParser/Result.hs +1/−0
• src/SimpleParser/Stream.hs +23/−21
• test/Main.hs +8/−11

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 1af182b724d1b845d2db2904aa95dd0817606dfc138177a7d731c390f2c05a06+-- hash: 180d046a2a3f8dc8692f2667efbbe7f11bbf34969c2e11daa7abb119b50517bb  name:           simple-parser-version:        0.10.0+version:        0.11.0 synopsis:       Simple parser combinators description:    Please see the README on GitHub at <https://github.com/ejconlon/simple-parser#readme> category:       Parsing@@ -33,13 +33,16 @@       SimpleParser.Chunked       SimpleParser.Common       SimpleParser.Errata-      SimpleParser.Examples.Ast-      SimpleParser.Examples.Json-      SimpleParser.Examples.Prop-      SimpleParser.Examples.Sexp+      SimpleParser.Examples.Common.Sexp+      SimpleParser.Examples.Direct.Ast+      SimpleParser.Examples.Direct.Json+      SimpleParser.Examples.Direct.Prop+      SimpleParser.Examples.Direct.Sexp+      SimpleParser.Examples.Lexed.Sexp       SimpleParser.Explain       SimpleParser.Input       SimpleParser.Interactive+      SimpleParser.Lexer       SimpleParser.LookAhead       SimpleParser.Parser       SimpleParser.Result

@@ -10,6 +10,7 @@   , module SimpleParser.Explain   , module SimpleParser.Input   , module SimpleParser.Interactive+  , module SimpleParser.Lexer   , module SimpleParser.LookAhead   , module SimpleParser.Parser   , module SimpleParser.Result@@ -24,6 +25,7 @@ import SimpleParser.Explain import SimpleParser.Input import SimpleParser.Interactive+import SimpleParser.Lexer import SimpleParser.LookAhead import SimpleParser.Parser import SimpleParser.Result

@@ -1,166 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}---- | Parses Sexp-formatted ASTs-module SimpleParser.Examples.Ast-  ( AstLabel (..)-  , AstParserC-  , AstParserM-  , CtorRes (..)-  , Ctor (..)-  , CtorDefns-  , astParser-  , lexAstParser-  , identAstParser-  ) where--import Control.Monad (ap, void)-import Control.Monad.Except (MonadError (..))-import Data.Char (isSpace)-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map-import Data.Sequence (Seq)-import Data.Text (Text)-import SimpleParser (Chunk, EmbedTextLabel (..), ExplainLabel (..), MatchBlock (..), MatchCase (MatchCase), Parser,-                     TextLabel, TextualStream, anyToken, betweenParser, consumeMatch, greedyStarParser, lexemeParser,-                     lookAheadMatch, matchToken, spaceParser, takeTokensWhile1, throwParser)-import qualified Text.Builder as TB--data AstLabel =-    AstLabelEmbedText !TextLabel-  | AstLabelCtorList-  | AstLabelCtorHead-  | AstLabelCtorBody !Text-  | AstLabelCustom !Text-  deriving (Eq, Show)--instance ExplainLabel AstLabel where-  explainLabel sl =-    case sl of-      AstLabelEmbedText tl -> explainLabel tl-      AstLabelCtorList -> "constructor list"-      AstLabelCtorHead -> "constructor head"-      AstLabelCtorBody t -> "constructor body (" <> TB.text t <> ")"-      AstLabelCustom t -> "custom: " <> TB.text t--instance EmbedTextLabel AstLabel where-  embedTextLabel = AstLabelEmbedText--type AstParserC s = (TextualStream s, Chunk s ~ Text)-type AstParserM s e a = Parser AstLabel s e a--data CtorRes e a =-    CtorResFail !String-  | CtorResErr !e-  | CtorResVal !a-  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)--instance Applicative (CtorRes e) where-  pure = CtorResVal-  (<*>) = ap--instance Monad (CtorRes e) where-  return = pure-  r >>= f =-    case r of-      CtorResFail msg -> CtorResFail msg-      CtorResErr err -> CtorResErr err-      CtorResVal val -> f val--instance MonadFail (CtorRes e) where-  fail = CtorResFail--instance MonadError e (CtorRes e) where-  throwError = CtorResErr-  catchError r h =-    case r of-      CtorResFail msg -> CtorResFail msg-      CtorResErr err -> h err-      CtorResVal val -> CtorResVal val--embedCtorRes :: CtorRes e a -> AstParserM s e a-embedCtorRes = \case-  CtorResFail msg -> fail msg-  CtorResErr err -> throwParser err-  CtorResVal val -> pure val--data Ctor s e t where-  Ctor0 :: CtorRes e t -> Ctor s e t-  Ctor1 :: (a -> CtorRes e t) -> AstParserM s e a -> Ctor s e t-  Ctor2 :: (a -> b -> CtorRes e t) -> AstParserM s e a -> AstParserM s e b -> Ctor s e t-  Ctor3 :: (a -> b -> c -> CtorRes e t) -> AstParserM s e a -> AstParserM s e b -> AstParserM s e c -> Ctor s e t-  Ctor4 :: (a -> b -> c -> d -> CtorRes e t) -> AstParserM s e a -> AstParserM s e b -> AstParserM s e c -> AstParserM s e d -> Ctor s e t-  Ctor5 :: (a -> b -> c -> d -> x -> CtorRes e t) -> AstParserM s e a -> AstParserM s e b -> AstParserM s e c -> AstParserM s e d -> AstParserM s e x -> Ctor s e t-  CtorN :: (Seq a -> CtorRes e t) -> AstParserM s e a -> Ctor s e t--type CtorDefns s e t = Map Text (Ctor s e t)--data Defns s e t = Defns-  { defAtoms :: AstParserM s e t-  , defCtors :: CtorDefns s e t-  }--spaceP :: AstParserC s => AstParserM s e ()-spaceP = spaceParser--lexAstParser :: AstParserC s => AstParserM s e a -> AstParserM s e a-lexAstParser = lexemeParser spaceP--openParenP :: AstParserC s => AstParserM s e ()-openParenP = lexAstParser (void (matchToken '('))--closeParenP :: AstParserC s => AstParserM s e ()-closeParenP = lexAstParser (void (matchToken ')'))--nonDelimPred :: Char -> Bool-nonDelimPred c = c /= '(' && c /= ')' && not (isSpace c)--identAstParser :: AstParserC s => Maybe AstLabel -> AstParserM s e Text-identAstParser = lexAstParser . flip takeTokensWhile1 nonDelimPred--astParser :: AstParserC s => AstParserM s e t -> (AstParserM s e t -> CtorDefns s e t) -> AstParserM s e t-astParser mkAtom mkCtors = let p = recAstParser (Defns mkAtom (mkCtors p)) in p--recAstParser :: AstParserC s => Defns s e t -> AstParserM s e t-recAstParser defns = lookAheadMatch block where-  block = MatchBlock anyToken (lexAstParser (defAtoms defns))-    [ MatchCase (Just AstLabelCtorList) (== '(') (ctorDefnsAstParser (defCtors defns))-    ]--ctorDefnsAstParser :: AstParserC s => CtorDefns s e t -> AstParserM s e t-ctorDefnsAstParser ctors = betweenParser openParenP closeParenP (consumeMatch block) where-  block = MatchBlock (identAstParser (Just AstLabelCtorHead)) (fail "Could not match constructor") cases-  cases = flip fmap (Map.toList ctors) $ \(t, c) ->-    MatchCase (Just (AstLabelCtorBody t)) (== t) (ctorAstParser c)--ctorAstParser :: AstParserC s => Ctor s e t -> AstParserM s e t-ctorAstParser = \case-  Ctor0 r -> embedCtorRes r-  Ctor1 f pa -> do-    a <- lexAstParser pa-    embedCtorRes (f a)-  Ctor2 f pa pb -> do-    a <- lexAstParser pa-    b <- lexAstParser pb-    embedCtorRes (f a b)-  Ctor3 f pa pb pc -> do-    a <- lexAstParser pa-    b <- lexAstParser pb-    c <- lexAstParser pc-    embedCtorRes (f a b c)-  Ctor4 f pa pb pc pd -> do-    a <- lexAstParser pa-    b <- lexAstParser pb-    c <- lexAstParser pc-    d <- lexAstParser pd-    embedCtorRes (f a b c d)-  Ctor5 f pa pb pc pd px -> do-    a <- lexAstParser pa-    b <- lexAstParser pb-    c <- lexAstParser pc-    d <- lexAstParser pd-    x <- lexAstParser px-    embedCtorRes (f a b c d x)-  CtorN f px -> do-    xs <- greedyStarParser (lexAstParser px)-    embedCtorRes (f xs)

@@ -0,0 +1,24 @@+module SimpleParser.Examples.Common.Sexp+  ( Atom (..)+  , SexpF (..)+  , Sexp (..)+  ) where++import Data.Scientific (Scientific)+import Data.Sequence (Seq)+import Data.Text (Text)++data Atom =+    AtomIdent !Text+  | AtomString !Text+  | AtomInt !Integer+  | AtomSci !Scientific+  deriving (Eq, Show)++data SexpF a =+    SexpAtom !Atom+  | SexpList !(Seq a)+  deriving (Eq, Show, Functor, Foldable, Traversable)++newtype Sexp = Sexp { unSexp :: SexpF Sexp }+  deriving (Eq, Show)

@@ -0,0 +1,166 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Parses Sexp-formatted ASTs+module SimpleParser.Examples.Direct.Ast+  ( AstLabel (..)+  , AstParserC+  , AstParserM+  , CtorRes (..)+  , Ctor (..)+  , CtorDefns+  , astParser+  , lexAstParser+  , identAstParser+  ) where++import Control.Monad (ap, void)+import Control.Monad.Except (MonadError (..))+import Data.Char (isSpace)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Sequence (Seq)+import Data.Text (Text)+import SimpleParser (Chunk, EmbedTextLabel (..), ExplainLabel (..), MatchBlock (..), MatchCase (MatchCase), Parser,+                     TextLabel, TextualStream, anyToken, betweenParser, consumeMatch, greedyStarParser, lexemeParser,+                     lookAheadMatch, matchToken, spaceParser, takeTokensWhile1, throwParser)+import qualified Text.Builder as TB++data AstLabel =+    AstLabelEmbedText !TextLabel+  | AstLabelCtorList+  | AstLabelCtorHead+  | AstLabelCtorBody !Text+  | AstLabelCustom !Text+  deriving (Eq, Show)++instance ExplainLabel AstLabel where+  explainLabel sl =+    case sl of+      AstLabelEmbedText tl -> explainLabel tl+      AstLabelCtorList -> "constructor list"+      AstLabelCtorHead -> "constructor head"+      AstLabelCtorBody t -> "constructor body (" <> TB.text t <> ")"+      AstLabelCustom t -> "custom: " <> TB.text t++instance EmbedTextLabel AstLabel where+  embedTextLabel = AstLabelEmbedText++type AstParserC s = (TextualStream s, Chunk s ~ Text)+type AstParserM s e a = Parser AstLabel s e a++data CtorRes e a =+    CtorResFail !String+  | CtorResErr !e+  | CtorResVal !a+  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)++instance Applicative (CtorRes e) where+  pure = CtorResVal+  (<*>) = ap++instance Monad (CtorRes e) where+  return = pure+  r >>= f =+    case r of+      CtorResFail msg -> CtorResFail msg+      CtorResErr err -> CtorResErr err+      CtorResVal val -> f val++instance MonadFail (CtorRes e) where+  fail = CtorResFail++instance MonadError e (CtorRes e) where+  throwError = CtorResErr+  catchError r h =+    case r of+      CtorResFail msg -> CtorResFail msg+      CtorResErr err -> h err+      CtorResVal val -> CtorResVal val++embedCtorRes :: CtorRes e a -> AstParserM s e a+embedCtorRes = \case+  CtorResFail msg -> fail msg+  CtorResErr err -> throwParser err+  CtorResVal val -> pure val++data Ctor s e t where+  Ctor0 :: CtorRes e t -> Ctor s e t+  Ctor1 :: (a -> CtorRes e t) -> AstParserM s e a -> Ctor s e t+  Ctor2 :: (a -> b -> CtorRes e t) -> AstParserM s e a -> AstParserM s e b -> Ctor s e t+  Ctor3 :: (a -> b -> c -> CtorRes e t) -> AstParserM s e a -> AstParserM s e b -> AstParserM s e c -> Ctor s e t+  Ctor4 :: (a -> b -> c -> d -> CtorRes e t) -> AstParserM s e a -> AstParserM s e b -> AstParserM s e c -> AstParserM s e d -> Ctor s e t+  Ctor5 :: (a -> b -> c -> d -> x -> CtorRes e t) -> AstParserM s e a -> AstParserM s e b -> AstParserM s e c -> AstParserM s e d -> AstParserM s e x -> Ctor s e t+  CtorN :: (Seq a -> CtorRes e t) -> AstParserM s e a -> Ctor s e t++type CtorDefns s e t = Map Text (Ctor s e t)++data Defns s e t = Defns+  { defAtoms :: AstParserM s e t+  , defCtors :: CtorDefns s e t+  }++spaceP :: AstParserC s => AstParserM s e ()+spaceP = spaceParser++lexAstParser :: AstParserC s => AstParserM s e a -> AstParserM s e a+lexAstParser = lexemeParser spaceP++openParenP :: AstParserC s => AstParserM s e ()+openParenP = lexAstParser (void (matchToken '('))++closeParenP :: AstParserC s => AstParserM s e ()+closeParenP = lexAstParser (void (matchToken ')'))++nonDelimPred :: Char -> Bool+nonDelimPred c = c /= '(' && c /= ')' && not (isSpace c)++identAstParser :: AstParserC s => Maybe AstLabel -> AstParserM s e Text+identAstParser = lexAstParser . flip takeTokensWhile1 nonDelimPred++astParser :: AstParserC s => AstParserM s e t -> (AstParserM s e t -> CtorDefns s e t) -> AstParserM s e t+astParser mkAtom mkCtors = let p = recAstParser (Defns mkAtom (mkCtors p)) in p++recAstParser :: AstParserC s => Defns s e t -> AstParserM s e t+recAstParser defns = lookAheadMatch block where+  block = MatchBlock anyToken (lexAstParser (defAtoms defns))+    [ MatchCase (Just AstLabelCtorList) (== '(') (ctorDefnsAstParser (defCtors defns))+    ]++ctorDefnsAstParser :: AstParserC s => CtorDefns s e t -> AstParserM s e t+ctorDefnsAstParser ctors = betweenParser openParenP closeParenP (consumeMatch block) where+  block = MatchBlock (identAstParser (Just AstLabelCtorHead)) (fail "Could not match constructor") cases+  cases = flip fmap (Map.toList ctors) $ \(t, c) ->+    MatchCase (Just (AstLabelCtorBody t)) (== t) (ctorAstParser c)++ctorAstParser :: AstParserC s => Ctor s e t -> AstParserM s e t+ctorAstParser = \case+  Ctor0 r -> embedCtorRes r+  Ctor1 f pa -> do+    a <- lexAstParser pa+    embedCtorRes (f a)+  Ctor2 f pa pb -> do+    a <- lexAstParser pa+    b <- lexAstParser pb+    embedCtorRes (f a b)+  Ctor3 f pa pb pc -> do+    a <- lexAstParser pa+    b <- lexAstParser pb+    c <- lexAstParser pc+    embedCtorRes (f a b c)+  Ctor4 f pa pb pc pd -> do+    a <- lexAstParser pa+    b <- lexAstParser pb+    c <- lexAstParser pc+    d <- lexAstParser pd+    embedCtorRes (f a b c d)+  Ctor5 f pa pb pc pd px -> do+    a <- lexAstParser pa+    b <- lexAstParser pb+    c <- lexAstParser pc+    d <- lexAstParser pd+    x <- lexAstParser px+    embedCtorRes (f a b c d x)+  CtorN f px -> do+    xs <- greedyStarParser (lexAstParser px)+    embedCtorRes (f xs)

@@ -0,0 +1,108 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Parses JSON documents+module SimpleParser.Examples.Direct.Json+  ( Json (..)+  , JsonF (..)+  , JsonParserC+  , JsonParserM+  , jsonParser+  ) where++import Control.Monad (void)+import Data.Scientific (Scientific)+import Data.Sequence (Seq)+import Data.Text (Text)+import Data.Void (Void)+import SimpleParser (MatchBlock (..), MatchCase (..), Parser, Stream (..), TextLabel, TextualChunked (..),+                     TextualStream, anyToken, betweenParser, escapedStringParser, lexemeParser, lookAheadMatch,+                     matchChunk, matchToken, orParser, scientificParser, sepByParser, signedNumStartPred, spaceParser)++data JsonF a =+    JsonObject !(Seq (Text, a))+  | 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 JsonParserC s = (TextualStream s, Eq (Chunk s))++type JsonParserM s a = Parser TextLabel s Void a++jsonParser :: JsonParserC s => JsonParserM s Json+jsonParser = let p = fmap Json (recJsonParser p) in p++isBoolStartPred :: Char -> Bool+isBoolStartPred c = c == 't' || c == 'f'++recJsonParser :: JsonParserC s => JsonParserM s a -> JsonParserM s (JsonF a)+recJsonParser root = lexP (lookAheadMatch block) where+  block = MatchBlock anyToken (fail "failed to parse json document")+    [ MatchCase Nothing (== '{') (objectP (objectPairP root))+    , MatchCase Nothing (== '[') (arrayP root)+    , MatchCase Nothing (== '"') stringP+    , MatchCase Nothing signedNumStartPred numP+    , MatchCase Nothing isBoolStartPred boolP+    , MatchCase Nothing (== 'n') nullP+    ]++spaceP :: JsonParserC s => JsonParserM s ()+spaceP = spaceParser++lexP :: JsonParserC s => JsonParserM s a -> JsonParserM s a+lexP = lexemeParser spaceP++tokL :: JsonParserC s => Char -> JsonParserM s ()+tokL c = lexP (void (matchToken c))++chunkL :: JsonParserC s => Text -> JsonParserM s ()+chunkL cs = lexP (void (matchChunk (unpackChunk cs)))++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 '"'++openQuoteP :: JsonParserC s => JsonParserM s ()+openQuoteP = void (matchToken '"')++nullTokP, trueTokP, falseTokP :: JsonParserC s => JsonParserM s ()+nullTokP = chunkL "null"+trueTokP = chunkL "true"+falseTokP = chunkL "false"++rawStringP :: JsonParserC s => JsonParserM s Text+rawStringP = fmap packChunk (escapedStringParser '"')++stringP :: JsonParserC s => JsonParserM s (JsonF a)+stringP = fmap JsonString rawStringP++nullP :: JsonParserC s => JsonParserM s (JsonF a)+nullP = JsonNull <$ nullTokP++boolP :: JsonParserC s => JsonParserM s (JsonF a)+boolP = orParser (JsonBool True <$ trueTokP) (JsonBool False <$ falseTokP)++numP :: JsonParserC s => JsonParserM s (JsonF a)+numP = fmap JsonNum scientificParser++objectPairP :: JsonParserC s => JsonParserM s a -> JsonParserM s (Text, a)+objectPairP root = do+  name <- rawStringP+  colonP+  value <- root+  pure (name, value)++objectP :: JsonParserC s => JsonParserM s (Text, a) -> JsonParserM s (JsonF a)+objectP pairP = betweenParser openBraceP closeBraceP (fmap JsonObject (sepByParser pairP commaP))++arrayP :: JsonParserC s => JsonParserM s a -> JsonParserM s (JsonF a)+arrayP root = betweenParser openBracketP closeBracketP (fmap JsonArray (sepByParser root commaP))

@@ -0,0 +1,51 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Parses simple Sexp-formatted logical propositions+module SimpleParser.Examples.Direct.Prop where++import qualified Data.Map.Strict as Map+import Data.Sequence (Seq (..))+import qualified Data.Sequence as Seq+import Data.Text (Text)+import Data.Void (Void)+import SimpleParser.Examples.Direct.Ast (AstLabel (..), AstParserC, AstParserM, Ctor (..), CtorDefns, astParser,+                                         identAstParser)++type PropParserC s = AstParserC s+type PropParserM s a = AstParserM s Void a++data SProp v =+    SPropVar !v+  | SPropBool !Bool+  | SPropNot (SProp v)+  | SPropAnd !(Seq (SProp v))+  | SPropOr !(Seq (SProp v))+  | SPropIf !(Seq (SProp v)) (SProp v)+  | SPropIff (SProp v) (SProp v)+  deriving stock (Eq, Show, Functor, Foldable, Traversable)++guard2 :: MonadFail m => Seq a -> m (Seq a)+guard2 ss = if Seq.length ss < 2 then fail "must have at least two subterms" else pure ss++guardLast :: MonadFail m => Seq a -> m (Seq a, a)+guardLast ss = case ss of { xs :|> x | not (Seq.null xs) -> pure (xs, x); _ -> fail "must have at least two subterms" }++mkPropCtors :: PropParserM s (SProp Text) -> CtorDefns s Void (SProp Text)+mkPropCtors root = Map.fromList+  [ ("<=>", Ctor2 (\a b -> pure (SPropIff a b)) root root)+  , ("not", Ctor1 (pure . SPropNot) root)+  , ("and", CtorN (fmap SPropAnd . guard2) root)+  , ("or", CtorN (fmap SPropOr . guard2) root)+  , ("=>", CtorN (fmap (uncurry SPropIf) . guardLast) root)+  ]++mkPropAtom :: PropParserC s => PropParserM s (SProp Text)+mkPropAtom = do+  ident <- identAstParser (Just (AstLabelCustom "atom"))+  case ident of+    "true" -> pure (SPropBool True)+    "false" -> pure (SPropBool False)+    _ -> pure (SPropVar ident)++propParser :: PropParserC s => PropParserM s (SProp Text)+propParser = astParser mkPropAtom mkPropCtors

@@ -0,0 +1,130 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Parses S-expressions+module SimpleParser.Examples.Direct.Sexp+  ( SexpLabel (..)+  , SexpParserC+  , SexpParserM+  , sexpParser+  , runSexpParser+  ) where++import Control.Applicative (empty)+import Control.Monad (void)+import Control.Monad.Catch (MonadThrow)+import Data.Char (isDigit, isSpace)+import Data.Sequence (Seq)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable (Typeable)+import Data.Void (Void)+import SimpleParser (Chunked (..), EmbedTextLabel (..), ExplainLabel (..), MatchBlock (..), MatchCase (..), Parser,+                     Stream (..), TextLabel, TextualStream, anyToken, applySign, betweenParser, escapedStringParser,+                     lexemeParser, lookAheadMatch, matchToken, numParser, packChunk, popChunk, runParserEnd,+                     satisfyToken, sepByParser, signParser, signedNumStartPred, spaceParser, takeTokensWhile)+import SimpleParser.Examples.Common.Sexp (Atom (..), Sexp (..), SexpF (..))++data SexpLabel =+    SexpLabelIdentStart+  | SexpLabelEmbedText !TextLabel+  | SexpLabelCustom !Text+  deriving (Eq, Show)++instance ExplainLabel SexpLabel where+  explainLabel sl =+    case sl of+      SexpLabelIdentStart -> "start of identifier"+      SexpLabelEmbedText tl -> explainLabel tl+      _ -> undefined++instance EmbedTextLabel SexpLabel where+  embedTextLabel = SexpLabelEmbedText++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 = lookAheadMatch block where+  block = MatchBlock anyToken (fmap SexpAtom atomP)+    [ MatchCase Nothing (== '(') (fmap SexpList (listP root))+    ]++nonDelimPred :: Char -> Bool+nonDelimPred c = c /= '(' && c /= ')' && not (isSpace c)++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 ')'))++numAtomP :: SexpParserC s => SexpParserM s Atom+numAtomP = do+  ms <- signParser+  n <- numParser+  case n of+    Left i -> pure (AtomInt (applySign ms i))+    Right s -> pure (AtomSci (applySign ms s))++chunk1 :: SexpParserC s => SexpParserM s Text+chunk1 = do+  mc <- popChunk 2+  case mc of+    Just c | not (chunkEmpty c) -> pure (packChunk c)+    _ -> empty++unaryIdentPred :: Char -> Text -> Bool+unaryIdentPred u t0 =+  case T.uncons t0 of+    Just (c0, t1) | u == c0 ->+      case T.uncons t1 of+        Just (c1, _) -> not (isDigit c1)+        Nothing -> True+    _ -> False++identAtomP :: SexpParserC s => SexpParserM s Atom+identAtomP = fmap AtomIdent identifierP++atomP :: SexpParserC s => SexpParserM s Atom+atomP = lexP (lookAheadMatch block) where+  block = MatchBlock chunk1 (fail "failed to parse sexp atom")+    [ MatchCase Nothing ((== '"') . T.head) (fmap AtomString stringP)+    , MatchCase Nothing (unaryIdentPred '+') identAtomP+    , MatchCase Nothing (unaryIdentPred '-') identAtomP+    , MatchCase Nothing (signedNumStartPred . T.head) numAtomP+    , MatchCase Nothing (identStartPred . T.head) identAtomP+    ]++listP :: SexpParserC s => SexpParserM s a -> SexpParserM s (Seq a)+listP root = lexP (betweenParser openParenP closeParenP (sepByParser root spaceP))++runSexpParser :: (+  Typeable s, Typeable (Token s), Typeable (Chunk s),+  Show s, Show (Token s), Show (Chunk s),+  SexpParserC s, MonadThrow m) => s -> m Sexp+runSexpParser = runParserEnd sexpParser

@@ -1,108 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | Parses JSON documents-module SimpleParser.Examples.Json-  ( Json (..)-  , JsonF (..)-  , JsonParserC-  , JsonParserM-  , jsonParser-  ) where--import Control.Monad (void)-import Data.Scientific (Scientific)-import Data.Sequence (Seq)-import Data.Text (Text)-import Data.Void (Void)-import SimpleParser (MatchBlock (..), MatchCase (..), Parser, Stream (..), TextLabel, TextualChunked (..),-                     TextualStream, anyToken, betweenParser, escapedStringParser, lexemeParser, lookAheadMatch,-                     matchChunk, matchToken, orParser, scientificParser, sepByParser, signedNumStartPred, spaceParser)--data JsonF a =-    JsonObject !(Seq (Text, a))-  | 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 JsonParserC s = (TextualStream s, Eq (Chunk s))--type JsonParserM s a = Parser TextLabel s Void a--jsonParser :: JsonParserC s => JsonParserM s Json-jsonParser = let p = fmap Json (recJsonParser p) in p--isBoolStartPred :: Char -> Bool-isBoolStartPred c = c == 't' || c == 'f'--recJsonParser :: JsonParserC s => JsonParserM s a -> JsonParserM s (JsonF a)-recJsonParser root = lexP (lookAheadMatch block) where-  block = MatchBlock anyToken (fail "failed to parse json document")-    [ MatchCase Nothing (== '{') (objectP (objectPairP root))-    , MatchCase Nothing (== '[') (arrayP root)-    , MatchCase Nothing (== '"') stringP-    , MatchCase Nothing signedNumStartPred numP-    , MatchCase Nothing isBoolStartPred boolP-    , MatchCase Nothing (== 'n') nullP-    ]--spaceP :: JsonParserC s => JsonParserM s ()-spaceP = spaceParser--lexP :: JsonParserC s => JsonParserM s a -> JsonParserM s a-lexP = lexemeParser spaceP--tokL :: JsonParserC s => Char -> JsonParserM s ()-tokL c = lexP (void (matchToken c))--chunkL :: JsonParserC s => Text -> JsonParserM s ()-chunkL cs = lexP (void (matchChunk (unpackChunk cs)))--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 '"'--openQuoteP :: JsonParserC s => JsonParserM s ()-openQuoteP = void (matchToken '"')--nullTokP, trueTokP, falseTokP :: JsonParserC s => JsonParserM s ()-nullTokP = chunkL "null"-trueTokP = chunkL "true"-falseTokP = chunkL "false"--rawStringP :: JsonParserC s => JsonParserM s Text-rawStringP = fmap packChunk (escapedStringParser '"')--stringP :: JsonParserC s => JsonParserM s (JsonF a)-stringP = fmap JsonString rawStringP--nullP :: JsonParserC s => JsonParserM s (JsonF a)-nullP = JsonNull <$ nullTokP--boolP :: JsonParserC s => JsonParserM s (JsonF a)-boolP = orParser (JsonBool True <$ trueTokP) (JsonBool False <$ falseTokP)--numP :: JsonParserC s => JsonParserM s (JsonF a)-numP = fmap JsonNum scientificParser--objectPairP :: JsonParserC s => JsonParserM s a -> JsonParserM s (Text, a)-objectPairP root = do-  name <- rawStringP-  colonP-  value <- root-  pure (name, value)--objectP :: JsonParserC s => JsonParserM s (Text, a) -> JsonParserM s (JsonF a)-objectP pairP = betweenParser openBraceP closeBraceP (fmap JsonObject (sepByParser pairP commaP))--arrayP :: JsonParserC s => JsonParserM s a -> JsonParserM s (JsonF a)-arrayP root = betweenParser openBracketP closeBracketP (fmap JsonArray (sepByParser root commaP))

@@ -0,0 +1,167 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Parses S-expressions but lexes first+module SimpleParser.Examples.Lexed.Sexp+  ( Sexp (..)+  , SexpF (..)+  , Atom (..)+  , SexpTokLabel (..)+  , SexpTokParserC+  , runSexpParser+  ) where++import Control.Applicative (empty)+import Control.Monad (void)+import Control.Monad.Catch (MonadThrow)+import Data.Char (isDigit, isSpace)+import Data.Sequence (Seq)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable (Typeable)+import Data.Void (Void)+import SimpleParser (Chunked (..), EmbedTextLabel (..), ExplainLabel (..), MatchBlock (..), MatchCase (..), Parser,+                     PosStream (..), Stream (..), TextLabel, TextualStream, anyToken, applySign, betweenParser,+                     escapedStringParser, greedyStarParser, lexemeParser, lookAheadMatch, matchToken, numParser,+                     packChunk, popChunk, popToken, runParserLexed, satisfyToken, signParser, signedNumStartPred,+                     spaceParser, takeTokensWhile)+import SimpleParser.Examples.Common.Sexp (Atom (..), Sexp (..), SexpF (..))++-- First, our tokenizer:++data SexpTokLabel =+    SexpTokLabelIdentStart+  | SexpTokLabelEmbedText !TextLabel+  deriving (Eq, Show)++instance ExplainLabel SexpTokLabel where+  explainLabel sl =+    case sl of+      SexpTokLabelIdentStart -> "start of identifier"+      SexpTokLabelEmbedText tl -> explainLabel tl++instance EmbedTextLabel SexpTokLabel where+  embedTextLabel = SexpTokLabelEmbedText++type SexpTokParserC s = (PosStream s, TextualStream s)++type SexpTokParserM s a = Parser SexpTokLabel s Void a++data SexpTok =+    SexpTokOpenParen+  | SexpTokCloseParen+  | SexpTokAtom !Atom+  deriving stock (Eq, Show)++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++stringTP :: SexpTokParserC s => SexpTokParserM s Text+stringTP = fmap packChunk (escapedStringParser '"')++identifierTP :: SexpTokParserC s => SexpTokParserM s Text+identifierTP = do+  x <- satisfyToken (Just SexpTokLabelIdentStart) identStartPred+  xs <- takeTokensWhile identContPred+  pure (packChunk (consChunk x xs))++spaceTP :: SexpTokParserC s => SexpTokParserM s ()+spaceTP = spaceParser++lexTP :: SexpTokParserC s => SexpTokParserM s a -> SexpTokParserM s a+lexTP = lexemeParser spaceTP++openParenTP :: SexpTokParserC s => SexpTokParserM s ()+openParenTP = lexTP (void (matchToken '('))++closeParenTP :: SexpTokParserC s => SexpTokParserM s ()+closeParenTP = lexTP (void (matchToken ')'))++numAtomTP :: SexpTokParserC s => SexpTokParserM s Atom+numAtomTP = do+  ms <- signParser+  n <- numParser+  case n of+    Left i -> pure (AtomInt (applySign ms i))+    Right s -> pure (AtomSci (applySign ms s))++chunk1 :: SexpTokParserC s => SexpTokParserM s Text+chunk1 = do+  mc <- popChunk 2+  case mc of+    Just c | not (chunkEmpty c) -> pure (packChunk c)+    _ -> empty++unaryIdentPred :: Char -> Text -> Bool+unaryIdentPred u t0 =+  case T.uncons t0 of+    Just (c0, t1) | u == c0 ->+      case T.uncons t1 of+        Just (c1, _) -> not (isDigit c1)+        Nothing -> True+    _ -> False++identAtomTP :: SexpTokParserC s => SexpTokParserM s Atom+identAtomTP = fmap AtomIdent identifierTP++atomTP :: SexpTokParserC s => SexpTokParserM s Atom+atomTP = lexTP (lookAheadMatch block) where+  block = MatchBlock chunk1 (fail "failed to parse sexp atom")+    [ MatchCase Nothing ((== '"') . T.head) (fmap AtomString stringTP)+    , MatchCase Nothing (unaryIdentPred '+') identAtomTP+    , MatchCase Nothing (unaryIdentPred '-') identAtomTP+    , MatchCase Nothing (signedNumStartPred . T.head) numAtomTP+    , MatchCase Nothing (identStartPred . T.head) identAtomTP+    ]++sexpTokParser :: SexpTokParserC s => SexpTokParserM s SexpTok+sexpTokParser= lookAheadMatch block where+  block = MatchBlock anyToken (fmap SexpTokAtom atomTP)+    [ MatchCase Nothing (== '(') (SexpTokOpenParen <$ openParenTP)+    , MatchCase Nothing (== ')') (SexpTokCloseParen <$ closeParenTP)+    ]++-- Now the Sexp parser itself:++type SexpParserC s = (Stream s, Token s ~ SexpTok)++type SexpParserM s a = Parser Void s Void a++isOpenParenTok, isCloseParenTok, isAtomTok :: SexpTok -> Bool+isOpenParenTok = \case { SexpTokOpenParen -> True; _ -> False }+isCloseParenTok = \case { SexpTokCloseParen -> True; _ -> False }+isAtomTok = \case { SexpTokAtom _ -> True; _ -> False }++atomP :: SexpParserC s => SexpParserM s Atom+atomP = popToken >>= \case { Just (SexpTokAtom a) -> pure a; _ -> empty }++openParenP, closeParenP :: SexpParserC s => SexpParserM s ()+openParenP = popToken >>= \case { Just SexpTokOpenParen -> pure (); _ -> empty }+closeParenP = popToken >>= \case { Just SexpTokCloseParen -> pure (); _ -> empty }++listP :: SexpParserC s => SexpParserM s a -> SexpParserM s (Seq a)+listP root = betweenParser openParenP closeParenP (greedyStarParser root)++recSexpParser :: SexpParserC s => SexpParserM s a -> SexpParserM s (SexpF a)+recSexpParser root = lookAheadMatch block where+  block = MatchBlock anyToken empty+    [ MatchCase Nothing isOpenParenTok (fmap SexpList (listP root))+    , MatchCase Nothing isCloseParenTok (fail "invalid close paren")+    , MatchCase Nothing isAtomTok (fmap SexpAtom atomP)+    ]++sexpParser :: SexpParserC s => SexpParserM s Sexp+sexpParser = let p = fmap Sexp (recSexpParser p) in p++-- And combined:++runSexpParser :: (+  Typeable s, Typeable (Token s), Typeable (Chunk s), Typeable (Pos s),+  Show s, Show (Token s), Show (Chunk s), Show (Pos s),+  SexpTokParserC s, MonadThrow m) => s -> m Sexp+runSexpParser = runParserLexed sexpTokParser sexpParser

@@ -1,51 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | Parses simple Sexp-formatted logical propositions-module SimpleParser.Examples.Prop where--import qualified Data.Map.Strict as Map-import Data.Sequence (Seq (..))-import qualified Data.Sequence as Seq-import Data.Text (Text)-import Data.Void (Void)-import SimpleParser.Examples.Ast (AstLabel (..), AstParserC, AstParserM, Ctor (..), CtorDefns, astParser,-                                  identAstParser)--type PropParserC s = AstParserC s-type PropParserM s a = AstParserM s Void a--data SProp v =-    SPropVar !v-  | SPropBool !Bool-  | SPropNot (SProp v)-  | SPropAnd !(Seq (SProp v))-  | SPropOr !(Seq (SProp v))-  | SPropIf !(Seq (SProp v)) (SProp v)-  | SPropIff (SProp v) (SProp v)-  deriving stock (Eq, Show, Functor, Foldable, Traversable)--guard2 :: MonadFail m => Seq a -> m (Seq a)-guard2 ss = if Seq.length ss < 2 then fail "must have at least two subterms" else pure ss--guardLast :: MonadFail m => Seq a -> m (Seq a, a)-guardLast ss = case ss of { xs :|> x | not (Seq.null xs) -> pure (xs, x); _ -> fail "must have at least two subterms" }--mkPropCtors :: PropParserM s (SProp Text) -> CtorDefns s Void (SProp Text)-mkPropCtors root = Map.fromList-  [ ("<=>", Ctor2 (\a b -> pure (SPropIff a b)) root root)-  , ("not", Ctor1 (pure . SPropNot) root)-  , ("and", CtorN (fmap SPropAnd . guard2) root)-  , ("or", CtorN (fmap SPropOr . guard2) root)-  , ("=>", CtorN (fmap (uncurry SPropIf) . guardLast) root)-  ]--mkPropAtom :: PropParserC s => PropParserM s (SProp Text)-mkPropAtom = do-  ident <- identAstParser (Just (AstLabelCustom "atom"))-  case ident of-    "true" -> pure (SPropBool True)-    "false" -> pure (SPropBool False)-    _ -> pure (SPropVar ident)--propParser :: PropParserC s => PropParserM s (SProp Text)-propParser = astParser mkPropAtom mkPropCtors

@@ -1,139 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | Parses S-expressions-module SimpleParser.Examples.Sexp-  ( Sexp (..)-  , SexpF (..)-  , Atom (..)-  , SexpLabel (..)-  , SexpParserC-  , SexpParserM-  , sexpParser-  ) where--import Control.Applicative (empty)-import Control.Monad (void)-import Data.Char (isDigit, isSpace)-import Data.Scientific (Scientific)-import Data.Sequence (Seq)-import Data.Text (Text)-import qualified Data.Text as T-import Data.Void (Void)-import SimpleParser (Chunked (..), EmbedTextLabel (..), ExplainLabel (..), MatchBlock (..), MatchCase (..), Parser,-                     TextLabel, TextualStream, anyToken, applySign, betweenParser, escapedStringParser, lexemeParser,-                     lookAheadMatch, matchToken, numParser, packChunk, popChunk, satisfyToken, sepByParser, signParser,-                     signedNumStartPred, spaceParser, takeTokensWhile)--data Atom =-    AtomIdent !Text-  | AtomString !Text-  | AtomInt !Integer-  | AtomSci !Scientific-  deriving (Eq, Show)--data SexpF a =-    SexpAtom !Atom-  | SexpList !(Seq a)-  deriving (Eq, Show, Functor, Foldable, Traversable)--data SexpLabel =-    SexpLabelIdentStart-  | SexpLabelEmbedText !TextLabel-  | SexpLabelCustom !Text-  deriving (Eq, Show)--instance ExplainLabel SexpLabel where-  explainLabel sl =-    case sl of-      SexpLabelIdentStart -> "start of identifier"-      SexpLabelEmbedText tl -> explainLabel tl-      _ -> undefined--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 = lookAheadMatch block where-  block = MatchBlock anyToken (fmap SexpAtom atomP)-    [ MatchCase Nothing (== '(') (fmap SexpList (listP root))-    ]--nonDelimPred :: Char -> Bool-nonDelimPred c = c /= '(' && c /= ')' && not (isSpace c)--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 ')'))--numAtomP :: SexpParserC s => SexpParserM s Atom-numAtomP = do-  ms <- signParser-  n <- numParser-  case n of-    Left i -> pure (AtomInt (applySign ms i))-    Right s -> pure (AtomSci (applySign ms s))--chunk1 :: SexpParserC s => SexpParserM s Text-chunk1 = do-  mc <- popChunk 2-  case mc of-    Just c | not (chunkEmpty c) -> pure (packChunk c)-    _ -> empty--unaryIdentPred :: Char -> Text -> Bool-unaryIdentPred u t0 =-  case T.uncons t0 of-    Just (c0, t1) | u == c0 ->-      case T.uncons t1 of-        Just (c1, _) -> not (isDigit c1)-        Nothing -> True-    _ -> False--identAtomP :: SexpParserC s => SexpParserM s Atom-identAtomP = fmap AtomIdent identifierP--atomP :: SexpParserC s => SexpParserM s Atom-atomP = lexP (lookAheadMatch block) where-  block = MatchBlock chunk1 (fail "failed to parse sexp atom")-    [ MatchCase Nothing ((== '"') . T.head) (fmap AtomString stringP)-    , MatchCase Nothing (unaryIdentPred '+') identAtomP-    , MatchCase Nothing (unaryIdentPred '-') identAtomP-    , MatchCase Nothing (signedNumStartPred . T.head) numAtomP-    , MatchCase Nothing (identStartPred . T.head) identAtomP-    ]--listP :: SexpParserC s => SexpParserM s a -> SexpParserM s (Seq a)-listP root = lexP (betweenParser openParenP closeParenP (sepByParser root spaceP))

@@ -0,0 +1,88 @@+-- | Utilities for handling lexing/tokenization as a separate parsing pass+module SimpleParser.Lexer+  ( Spanned (..)+  , LexedStream (..)+  , LexedSpan (..)+  , spannedParser+  , lexedParser+  , runParserLexed+  ) where++import Control.Monad.Catch (MonadThrow)+import Control.Monad.State.Strict (gets)+import Data.Sequence (Seq (..))+import qualified Data.Sequence as Seq+import Data.Typeable (Typeable)+import SimpleParser.Parser (Parser, ParserT, greedyStarParser)+import SimpleParser.Stream (PosStream (..), Span (Span), Stream (..))+import SimpleParser.Throw (runParserEnd)++-- | A value annotated with a 'Span'+data Spanned p a = Spanned+  { spannedSpan :: !(Span p)+  , spannedValue :: !a+  } deriving stock (Eq, Show, Functor, Foldable, Traversable)++-- | A materialized sequence of 'Spanned' values+newtype LexedStream p a = LexedStream { unLexedStream :: Seq (Spanned p a) }+  deriving stock (Show, Functor, Foldable, Traversable)+  deriving newtype (Eq)++instance Stream (LexedStream p a) where+  type Token (LexedStream p a) = a+  type Chunk (LexedStream p a) = Seq a++  streamTake1 (LexedStream ss) =+    case ss of+      Empty -> Nothing+      Spanned _ a :<| tl -> Just (a, LexedStream tl)++  streamTakeN n s@(LexedStream ss)+    | n <= 0 = Just (Seq.empty, s)+    | Seq.null ss = Nothing+    | otherwise =+        let (out, rest) = Seq.splitAt n ss+        in Just (fmap spannedValue out, LexedStream rest)++  streamTakeWhile f (LexedStream ss) =+    let (out, rest) = Seq.spanl (f . spannedValue) ss+    in (fmap spannedValue out, LexedStream rest)++  -- TODO(ejconlon) Specialize drops++-- | Position in a 'LexedStream'+data LexedSpan p =+    LexedSpanNext !(Span p)+  | LexedSpanEnd+  deriving stock (Eq, Show)++instance PosStream (LexedStream p a) where+  type Pos (LexedStream p a) = LexedSpan p++  streamViewPos (LexedStream ss) =+    case ss of+      Empty -> LexedSpanEnd+      Spanned sp _ :<| _ -> LexedSpanNext sp++-- | Annotates parse result with a span+spannedParser :: (PosStream s, Monad m) => ParserT l s e m a -> ParserT l s e m (Spanned (Pos s) a)+spannedParser p = do+  p1 <- gets streamViewPos+  a <- p+  p2 <- gets streamViewPos+  pure (Spanned (Span p1 p2) a)++-- | Given a parser for a single token, repeatedly apply it and annotate results with spans+lexedParser :: (PosStream s, Monad m) => ParserT l s e m a -> ParserT l s e m (LexedStream (Pos s) a)+lexedParser p = fmap LexedStream (greedyStarParser (spannedParser p))++-- | Similar to 'runParserEnd' - first lexes the entire stream then runs the second parser over the results+runParserLexed :: (+  Typeable l1, Typeable e1, Typeable s, Typeable (Token s), Typeable (Chunk s),+  Show l1, Show e1, Show s, Show (Token s), Show (Chunk s),+  Typeable l2, Typeable e2, Typeable (Pos s), Typeable a,+  Show l2, Show e2, Show (Pos s), Show a,+  PosStream s, MonadThrow m) => Parser l1 s e1 a -> Parser l2 (LexedStream (Pos s) a) e2 b -> s -> m b+runParserLexed lp p s = do+  ls <- runParserEnd (lexedParser lp) s+  runParserEnd p ls

@@ -6,6 +6,7 @@   , coerceStreamError   , CompoundError (..)   , Mark (..)+  , MarkStack   , ParseError (..)   , parseErrorResume   , parseErrorLabels

@@ -32,8 +32,8 @@  -- | '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 Chunk s :: Type+  type Token s :: Type    streamTake1 :: s -> Maybe (Token s, s) @@ -63,8 +63,8 @@ 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 Chunk [a] = [a]+  type Token [a] = a    streamTake1 = unconsChunk   streamTakeN n s@@ -74,8 +74,8 @@   streamTakeWhile = span  instance Stream (Seq a) where-  type instance Chunk (Seq a) = Seq a-  type instance Token (Seq a) = a+  type Chunk (Seq a) = Seq a+  type Token (Seq a) = a    streamTake1 = unconsChunk   streamTakeN n s@@ -87,8 +87,8 @@   -- TODO(ejconlon) Specialize drops  instance Stream Text where-  type instance Chunk Text = Text-  type instance Token Text = Char+  type Chunk Text = Text+  type Token Text = Char    streamTake1 = T.uncons   streamTakeN n s@@ -100,8 +100,8 @@   -- TODO(ejconlon) Specialize drops  instance Stream TL.Text where-  type instance Chunk TL.Text = TL.Text-  type instance Token TL.Text = Char+  type Chunk TL.Text = TL.Text+  type Token TL.Text = Char    streamTake1 = TL.uncons   streamTakeN n s@@ -113,8 +113,8 @@   -- TODO(ejconlon) Specialize drops  instance Stream ByteString where-  type instance Chunk ByteString = ByteString-  type instance Token ByteString = Word8+  type Chunk ByteString = ByteString+  type Token ByteString = Word8    streamTake1 = BS.uncons   streamTakeN n s@@ -126,8 +126,8 @@   -- TODO(ejconlon) Specialize drops  instance Stream BSL.ByteString where-  type instance Chunk BSL.ByteString = BSL.ByteString-  type instance Token BSL.ByteString = Word8+  type Chunk BSL.ByteString = BSL.ByteString+  type Token BSL.ByteString = Word8    streamTake1 = BSL.uncons   streamTakeN n s@@ -140,7 +140,7 @@  -- | 'PosStream' adds position tracking to a 'Stream'. class Stream s => PosStream s where-  type family Pos s :: Type+  type Pos s :: Type    streamViewPos :: s -> Pos s @@ -154,8 +154,9 @@   } 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 Chunk (OffsetStream s) = Chunk s+  type Token (OffsetStream s) = Token s+   streamTake1 (OffsetStream o s) = fmap (second (OffsetStream (succ o))) (streamTake1 s)   streamTakeN n (OffsetStream (Offset x) s) = fmap go (streamTakeN n s) where     go (a, b) = (a, OffsetStream (Offset (x + chunkLength a)) b)@@ -169,7 +170,7 @@     in (m, OffsetStream (Offset (x + m)) b)  instance Stream s => PosStream (OffsetStream s) where-  type instance Pos (OffsetStream s) = Offset+  type Pos (OffsetStream s) = Offset    streamViewPos (OffsetStream o _) = o @@ -208,8 +209,9 @@   } 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 Chunk (LinePosStream s) = Chunk s+  type Token (LinePosStream s) = Token s+   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)@@ -220,7 +222,7 @@   -- Drops can't be specialized because we need to examine each character for newlines.  instance (Stream s, Token s ~ Char) => PosStream (LinePosStream s) where-  type instance Pos (LinePosStream s) = LinePos+  type Pos (LinePosStream s) = LinePos    streamViewPos (LinePosStream p _) = p 

@@ -14,8 +14,10 @@ import Data.Text (Text) import qualified Data.Text as T import SimpleParser-import SimpleParser.Examples.Json (Json (..), JsonF (..), jsonParser)-import SimpleParser.Examples.Sexp (Atom (..), Sexp (..), SexpF (..), sexpParser)+import SimpleParser.Examples.Common.Sexp (Atom (..), Sexp (..), SexpF (..))+import SimpleParser.Examples.Direct.Json (Json (..), JsonF (..), jsonParser)+import qualified SimpleParser.Examples.Direct.Sexp as SexpDirect+import qualified SimpleParser.Examples.Lexed.Sexp as SexpLexed import Test.Tasty (TestName, TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) import Test.Tasty.TH (defaultMainGenerator)@@ -635,18 +637,13 @@  testSexpCase :: TestName -> Text -> SexpResult -> TestTree testSexpCase name str expected = testCase ("sexp " <> name) $ do-  let actual = parseSexp str-  actual @?= expected+  let actualDirect = SexpDirect.runSexpParser str+  actualDirect @?= expected+  let actualLexed = SexpLexed.runSexpParser (newOffsetStream str)+  actualLexed @?= expected  testSexpTrees :: [(TestName, Text, SexpResult)] -> [TestTree] testSexpTrees = fmap (\(n, s, e) -> testSexpCase n s e)--parseSexp :: Text -> SexpResult-parseSexp str =-  let p = sexpParser <* matchEnd-  in case runParser p str of-    Just (ParseResultSuccess (ParseSuccess _ a)) -> Just a-    _ -> Nothing  test_sexp :: [TestTree] test_sexp =