simple-parser 0.9.1 → 0.10.0

raw patch · 8 files changed

+251/−18 lines, 8 filesdep ~errataPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: errata

API changes (from Hackage documentation)

Files

• simple-parser.cabal +8/−4
• src/SimpleParser/Errata.hs +10/−10
• src/SimpleParser/Examples/Ast.hs +166/−0
• src/SimpleParser/Examples/Json.hs +1/−1
• src/SimpleParser/Examples/Prop.hs +51/−0
• src/SimpleParser/Examples/Sexp.hs +1/−1
• src/SimpleParser/Interactive.hs +3/−2
• src/SimpleParser/LookAhead.hs +11/−0

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 2dde56d3da565fdc6e3d1169838c11305bea87da7a5484c25ef8892490a1f441+-- hash: 1af182b724d1b845d2db2904aa95dd0817606dfc138177a7d731c390f2c05a06  name:           simple-parser-version:        0.9.1+version:        0.10.0 synopsis:       Simple parser combinators description:    Please see the README on GitHub at <https://github.com/ejconlon/simple-parser#readme> category:       Parsing@@ -33,7 +33,9 @@       SimpleParser.Chunked       SimpleParser.Common       SimpleParser.Errata+      SimpleParser.Examples.Ast       SimpleParser.Examples.Json+      SimpleParser.Examples.Prop       SimpleParser.Examples.Sexp       SimpleParser.Explain       SimpleParser.Input@@ -60,6 +62,7 @@       FunctionalDependencies       GeneralizedNewtypeDeriving       KindSignatures+      LambdaCase       MultiParamTypeClasses       StandaloneDeriving       TupleSections@@ -69,7 +72,7 @@       base >=4.12 && <5     , bytestring ==0.10.*     , containers ==0.6.*-    , errata ==0.3.*+    , errata ==0.4.*     , exceptions ==0.10.*     , mmorph ==1.1.*     , mtl ==2.2.*@@ -98,6 +101,7 @@       FunctionalDependencies       GeneralizedNewtypeDeriving       KindSignatures+      LambdaCase       MultiParamTypeClasses       StandaloneDeriving       TupleSections@@ -107,7 +111,7 @@       base >=4.12 && <5     , bytestring ==0.10.*     , containers ==0.6.*-    , errata ==0.3.*+    , errata ==0.4.*     , exceptions ==0.10.*     , mmorph ==1.1.*     , mtl ==2.2.*

@@ -10,15 +10,15 @@ import Data.Foldable (toList) import Data.Sequence (Seq (..)) import qualified Data.Text as T-import Errata (Block, Style, blockMerged')+import Errata (Block, PointerStyle, Style, blockMerged') import SimpleParser.Explain (ErrorExplanation (..), Explainable, ParseErrorExplanation (..), explainParseError) import SimpleParser.Result (ParseError, ParseErrorBundle (ParseErrorBundle), ParseResult (..)) import SimpleParser.Stream (Col (..), HasLinePos (..), Line (..), Pos, Span (..))  type LinePosExplainable l s e = (Explainable l s e, HasLinePos (Pos s)) -errataExplanation :: HasLinePos p => Style -> FilePath -> ParseErrorExplanation p -> Block-errataExplanation style fp (ParseErrorExplanation sp context mayDetails  (ErrorExplanation reason mayExpected mayActual)) =+errataExplanation :: HasLinePos p => Style -> PointerStyle  -> FilePath -> ParseErrorExplanation p -> Block+errataExplanation bsty psty fp (ParseErrorExplanation sp context mayDetails  (ErrorExplanation reason mayExpected mayActual)) =   let Span startPos endPos = sp       startLine = unLine (viewLine startPos)       startCol = unCol (viewCol startPos)@@ -39,15 +39,15 @@             , maybe [] (\ex -> ["[Expected] " <> ex]) mayExpected             , maybe [] (\ac -> ["[Actual  ] " <> ac]) mayActual             ]-  in blockMerged' style fp mayHeader start end mayLabel mayBody+  in blockMerged' bsty psty fp mayHeader start end mayLabel mayBody -errataParseError :: LinePosExplainable l s e => Style -> FilePath -> ParseError l s e -> Block-errataParseError style fp pe =+errataParseError :: LinePosExplainable l s e => Style -> PointerStyle -> FilePath -> ParseError l s e -> Block+errataParseError bsty psty fp pe =   let pee = explainParseError pe-  in errataExplanation style fp pee+  in errataExplanation bsty psty fp pee -errataParseResult :: LinePosExplainable l s e => Style -> FilePath -> ParseResult l s e a -> [Block]-errataParseResult style fp pr =+errataParseResult :: LinePosExplainable l s e => Style -> PointerStyle -> FilePath -> ParseResult l s e a -> [Block]+errataParseResult bsty psty fp pr =   case pr of-    ParseResultError (ParseErrorBundle errs) -> fmap (errataParseError style fp) (toList errs)+    ParseResultError (ParseErrorBundle errs) -> fmap (errataParseError bsty psty fp) (toList errs)     ParseResultSuccess _ -> []

@@ -0,0 +1,166 @@+{-# 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)

@@ -1,12 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} +-- | Parses JSON documents module SimpleParser.Examples.Json   ( Json (..)   , JsonF (..)   , JsonParserC   , JsonParserM   , jsonParser-  , recJsonParser   ) where  import Control.Monad (void)

@@ -0,0 +1,51 @@+{-# 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,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} +-- | Parses S-expressions module SimpleParser.Examples.Sexp   ( Sexp (..)   , SexpF (..)@@ -8,7 +9,6 @@   , SexpParserC   , SexpParserM   , sexpParser-  , recSexpParser   ) where  import Control.Applicative (empty)

@@ -11,7 +11,8 @@ import qualified Data.Text as T import qualified Data.Text.IO as TIO import qualified Data.Text.Lazy.IO as TLIO-import Errata (Errata (..), fancyStyle, prettyErrors)+import Errata (Errata (..), prettyErrors)+import Errata.Styles (fancyPointer, fancyStyle) import SimpleParser.Errata (errataParseError) import SimpleParser.Explain (Explainable, buildAllParseErrorExplanations, explainParseError) import SimpleParser.Input (matchEnd)@@ -33,7 +34,7 @@     Just (ParseResultError (ParseErrorBundle es)) ->       case errStyle of         ErrorStyleErrata ->-          let blocks = fmap (errataParseError fancyStyle "<interactive>") (toList es)+          let blocks = fmap (errataParseError fancyStyle fancyPointer "<interactive>") (toList es)               errata = Errata Nothing blocks Nothing               pretty = prettyErrors input [errata]           in TLIO.putStrLn pretty

@@ -6,6 +6,7 @@   , MatchBlock (..)   , PureMatchBlock   , lookAheadMatch+  , consumeMatch   , MatchPos (..)   , LookAheadTestResult (..)   , lookAheadTest@@ -39,6 +40,16 @@ -- | Parse with look-ahead for each case and follow the first that matches (or follow the default if none do). lookAheadMatch :: Monad m => MatchBlock l s e m a b -> ParserT l s e m b lookAheadMatch (MatchBlock sel dc mcs) = lookAheadParser sel >>= go mcs where+  go [] _ = dc+  go ((MatchCase mcl mcg mch):mcs') val =+    if mcg val+      then markParser mcl mch+      else go mcs' val++-- | Same as 'lookAheadMatch' but consumes the selector instead of looking ahead.+-- Cases will not have to re-parse the selected portion.+consumeMatch :: Monad m => MatchBlock l s e m a b -> ParserT l s e m b+consumeMatch (MatchBlock sel dc mcs) = sel >>= go mcs where   go [] _ = dc   go ((MatchCase mcl mcg mch):mcs') val =     if mcg val