packages feed

paripari (empty) → 0.1.0.0

raw patch · 10 files changed

+1578/−0 lines, 10 filesdep +basedep +bytestringdep +paripari

Dependencies added: base, bytestring, paripari, parser-combinators, text

Files

+ LICENSE view
@@ -0,0 +1,22 @@+The MIT License (MIT)++Copyright (c) 2018 Daniel Mendler++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.+
+ example.hs view
@@ -0,0 +1,60 @@++import System.Environment (getArgs)+import Text.PariPari+import qualified Data.ByteString as B++data Value+  = Object ![(Text, Value)]+  | Array  ![Value]+  | String !Text+  | Number !Integer !Integer+  | Bool   !Bool+  | Null+  deriving (Eq, Show)++json :: Parser Value+json = space *> (object <|> array) <?> "json"++object :: Parser Value+object = Object <$> (char '{' *> space *> sepBy pair (space *> char ',' *> space) <* space <* char '}') <?> "object"++pair :: Parser (Text, Value)+pair = (,) <$> (text <* space) <*> (char ':' *> space *> value)++array :: Parser Value+array = Array <$> (char '[' *> sepBy value (space *> char ',' *> space) <* space <* char ']') <?> "array"++value :: Parser Value+value =+  (String <$> text)+    <|> object+    <|> array+    <|> (Bool False <$ string "false")+    <|> (Bool True  <$ string "true")+    <|> (Null       <$ string "null")+    <|> number++text :: Parser Text+text = char '"' *> takeCharsWhile (/= '"') <* char '"' <?> "text"++number :: Parser Value+number = label "number" $ do+  neg <- option id $ negate <$ char '-'+  (c, _, e) <- fractionDec (pure ())+  pure $ Number (neg c) e++space :: Parser ()+space = skipCharsWhile (\c -> c == ' ' || c == '\n' || c == '\t')++main :: IO ()+main = do+  args <- getArgs+  case args of+    [file] -> do+      b <- B.readFile file+      case runParser json file b of+        Left x  -> do+          putStrLn $ showReport x+          print $ runTracer json file b+        Right x -> print x+    _ -> error "Usage: example test.json"
+ paripari.cabal view
@@ -0,0 +1,62 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 35567a9d1dd99ccd046b88ea5fd4cf74ce38d5bb58560bb7f1b3450ff1a1fbbe++name:           paripari+version:        0.1.0.0+synopsis:       Fast-path parser combinators with fallback for error reporting+description:    PariPari offers two parsing strategies. There is a fast Acceptor and a slower Reporter which are evaluated in parallel. If the Acceptor fails, the Reporter returns a report about the parsing errors. Unlike Parsec and like Attoparsec, the parser combinators backtrack by default.+category:       Text+stability:      experimental+homepage:       https://github.com/minad/paripari#readme+bug-reports:    https://github.com/minad/paripari/issues+author:         Daniel Mendler <mail@daniel-mendler.de>+maintainer:     Daniel Mendler <mail@daniel-mendler.de>+copyright:      2018 Daniel Mendler+license:        MIT+license-file:   LICENSE+tested-with:    GHC == 8.4.3, GHC == 8.6.1+build-type:     Simple+cabal-version:  >= 1.10++source-repository head+  type: git+  location: https://github.com/minad/paripari++library+  exposed-modules:+      Text.PariPari+      Text.PariPari.Acceptor+      Text.PariPari.Ascii+      Text.PariPari.Class+      Text.PariPari.Combinators+      Text.PariPari.Decode+      Text.PariPari.Reporter+  other-modules:+      Paths_paripari+  hs-source-dirs:+      src+  default-extensions: BangPatterns DeriveGeneric GeneralizedNewtypeDeriving MultiWayIf NamedFieldPuns OverloadedStrings Rank2Types+  ghc-options: -Wall -Widentities -Wmonomorphism-restriction -Wincomplete-uni-patterns -Wincomplete-record-updates -Wtabs -fprint-potential-instances+  build-depends:+      base >=4.8 && <5+    , bytestring >=0.10 && <0.11+    , parser-combinators >=1.0 && <1.1+    , text >=0.11 && <1.3+  default-language: Haskell2010++executable example+  main-is: example.hs+  other-modules:+      Paths_paripari+  default-extensions: BangPatterns DeriveGeneric GeneralizedNewtypeDeriving MultiWayIf NamedFieldPuns OverloadedStrings Rank2Types+  ghc-options: -Wall -Widentities -Wmonomorphism-restriction -Wincomplete-uni-patterns -Wincomplete-record-updates -Wtabs -fprint-potential-instances+  build-depends:+      base >=4.8 && <5+    , bytestring >=0.10 && <0.11+    , paripari+    , parser-combinators >=1.0 && <1.1+    , text >=0.11 && <1.3+  default-language: Haskell2010
+ src/Text/PariPari.hs view
@@ -0,0 +1,53 @@+module Text.PariPari (+  module Text.PariPari.Class+  , module Text.PariPari.Combinators+  , module Text.PariPari.Acceptor+  , module Text.PariPari.Reporter+  , runParser+  , runSeqParser+  , runParserWithOptions+  , runSeqParserWithOptions+) where++import Text.PariPari.Acceptor+import Text.PariPari.Class+import Text.PariPari.Combinators+import Text.PariPari.Reporter+import GHC.Conc (par)++-- | Run fast 'Acceptor' and slower 'Reporter' on the given 'ByteString' **in parallel**.+-- The 'FilePath' is used for error reporting.+-- When the acceptor does not return successfully, the result from the reporter+-- is awaited.+runParser :: Parser a -> FilePath -> ByteString -> Either Report a+runParser = runParserWithOptions defaultReportOptions+{-# INLINE runParser #-}+-- Inline to force the specializer to kick in++-- | Run fast 'Acceptor' and slower 'Reporter' on the given 'ByteString' **sequentially**.+-- The 'FilePath' is used for error reporting.+-- When the acceptor does not return successfully, the result from the reporter+-- is awaited.+runSeqParser :: Parser a -> FilePath -> ByteString -> Either Report a+runSeqParser = runSeqParserWithOptions defaultReportOptions+{-# INLINE runSeqParser #-}++-- | Run parsers **in parallel** with additional 'ReportOptions'.+runParserWithOptions :: ReportOptions -> Parser a -> FilePath -> ByteString -> Either Report a+runParserWithOptions o p f b =+  let a = runAcceptor p f b+      r = runReporterWithOptions o p f b+  in case r `par` a of+       Left _  -> r+       Right x -> Right x+{-# INLINE runParserWithOptions #-}++-- | Run parsers **sequentially** with additional 'ReportOptions'.+runSeqParserWithOptions :: ReportOptions -> Parser a -> FilePath -> ByteString -> Either Report a+runSeqParserWithOptions o p f b =+  let a = runAcceptor p f b+      r = runReporterWithOptions o p f b+  in case a of+       Left _  -> r+       Right x -> Right x+{-# INLINE runSeqParserWithOptions #-}
+ src/Text/PariPari/Acceptor.hs view
@@ -0,0 +1,242 @@+module Text.PariPari.Acceptor (+  Acceptor+  , runAcceptor+) where++import Control.Monad (void)+import Text.PariPari.Ascii+import Text.PariPari.Class+import Text.PariPari.Decode+import Foreign.ForeignPtr (ForeignPtr)+import qualified Control.Monad.Fail as Fail+import qualified Data.ByteString.Internal as B++data Env = Env+  { _envSrc     :: !(ForeignPtr Word8)+  , _envEnd     :: !Int+  , _envFile    :: !FilePath+  , _envRefLine :: !Int+  , _envRefCol  :: !Int+  }++data State = State+  { _stOff     :: !Int+  , _stLine    :: !Int+  , _stCol     :: !Int+  }++-- | Parser which is optimized for fast parsing. Error reporting+-- is minimal.+newtype Acceptor a = Acceptor+  { unAcceptor :: forall b. Env -> State+               -> (a     -> State -> b)+               -> (Error -> b)+               -> b+  }++instance Semigroup a => Semigroup (Acceptor a) where+  p1 <> p2 = (<>) <$> p1 <*> p2+  {-# INLINE (<>) #-}++instance Monoid a => Monoid (Acceptor a) where+  mempty = pure mempty+  {-# INLINE mempty #-}++instance Functor Acceptor where+  fmap f p = Acceptor $ \env st ok err ->+    unAcceptor p env st (ok . f) err+  {-# INLINE fmap #-}++instance Applicative Acceptor where+  pure x = Acceptor $ \_ st ok _ -> ok x st+  {-# INLINE pure #-}++  f <*> a = Acceptor $ \env st ok err ->+    let ok1 f' s =+          let ok2 a' s' = ok (f' a') s'+          in unAcceptor a env s ok2 err+    in unAcceptor f env st ok1 err+  {-# INLINE (<*>) #-}++  p1 *> p2 = do+    void p1+    p2+  {-# INLINE (*>) #-}++  p1 <* p2 = do+    x <- p1+    void p2+    pure x+  {-# INLINE (<*) #-}++instance Alternative Acceptor where+  empty = Acceptor $ \_ _ _ err -> err EEmpty+  {-# INLINE empty #-}++  p1 <|> p2 = Acceptor $ \env st ok err ->+    let err' _ = unAcceptor p2 env st ok err+    in unAcceptor p1 env st ok err'+  {-# INLINE (<|>) #-}++instance MonadPlus Acceptor++instance Monad Acceptor where+  p >>= f = Acceptor $ \env st ok err ->+    let ok' x s = unAcceptor (f x) env s ok err+    in unAcceptor p env st ok' err+  {-# INLINE (>>=) #-}++  fail msg = Fail.fail msg+  {-# INLINE fail #-}++instance Fail.MonadFail Acceptor where+  fail msg = failWith $ EFail msg+  {-# INLINE fail #-}++instance MonadParser Acceptor where+  getPos = get $ \_ st -> Pos (_stLine st) (_stCol st)+  {-# INLINE getPos #-}++  getFile = get $ \env _ -> _envFile env+  {-# INLINE getFile #-}++  getRefPos = get $ \env _ -> Pos (_envRefLine env) (_envRefCol env)+  {-# INLINE getRefPos #-}++  withRefPos p = local (\st env -> env { _envRefLine = _stLine st, _envRefCol = _stCol st }) p+  {-# INLINE withRefPos #-}++  notFollowedBy p = Acceptor $ \env st ok err ->+    let ok' _ _ = err $ ECombinator "notFollowedBy"+        err' _ = ok () st+    in unAcceptor p env st ok' err'+  {-# INLINE notFollowedBy #-}++  lookAhead p = Acceptor $ \env st ok err ->+    let ok' x _ = ok x st+    in unAcceptor p env st ok' err+  {-# INLINE lookAhead #-}++  failWith e = Acceptor $ \_ _ _ err -> err e+  {-# INLINE failWith #-}++  eof = Acceptor $ \env st ok err ->+    if _stOff st >= _envEnd env then+      ok () st+    else+      err EExpectedEnd+  {-# INLINE eof #-}++  label _ p = p+  {-# INLINE label #-}++  hidden p = p+  {-# INLINE hidden #-}++  commit p = p+  {-# INLINE commit #-}++  byte b = Acceptor $ \env st@State{_stOff, _stLine, _stCol} ok err ->+    if | _stOff >= _envEnd env -> err EEmpty+       | b == byteAt (_envSrc env) _stOff ->+           ok b st+           { _stOff =_stOff + 1+           , _stLine = if b == asc_newline then _stLine + 1 else _stLine+           , _stCol = if b == asc_newline then 1 else _stCol + 1+           }+       | otherwise ->+           err $ ECombinator "byte"+  {-# INLINE byte #-}++  byteSatisfy f = Acceptor $ \env st@State{_stOff, _stLine, _stCol} ok err ->+    let b = byteAt (_envSrc env) _stOff+    in if | _stOff >= _envEnd env -> err EEmpty+          | f b ->+              ok b st+              { _stOff =_stOff + 1+              , _stLine = if b == asc_newline then _stLine + 1 else _stLine+              , _stCol = if b == asc_newline then 1 else _stCol + 1+              }+          | otherwise ->+              err $ ECombinator "byteSatisfy"+  {-# INLINE byteSatisfy #-}++  bytes b@(B.PS p i n) = Acceptor $ \env st@State{_stOff,_stCol} ok err ->+    if n + _stOff <= _envEnd env &&+       bytesEqual (_envSrc env) _stOff p i n then+      ok b st { _stOff = _stOff + n, _stCol = _stCol + n }+    else+      err $ ECombinator "bytes"+  {-# INLINE bytes #-}++  asBytes p = do+    begin <- get (const _stOff)+    p+    end <- get (const _stOff)+    src <- get (\env _ -> _envSrc env)+    pure $ B.PS src begin (end - begin)+  {-# INLINE asBytes #-}++  satisfy f = Acceptor $ \env st@State{_stOff, _stLine, _stCol} ok err ->+    let (c, w) = utf8Decode (_envSrc env) _stOff+    in if | c /= '\0' ->+            if f c then+              ok c st+              { _stOff =_stOff + w+              , _stLine = if c == '\n' then _stLine + 1 else _stLine+              , _stCol = if c == '\n' then 1 else _stCol + 1+              }+            else+              err $ ECombinator "satisfy"+          | c == '\0' && _stOff >= _envEnd env -> err EEmpty+          | otherwise -> err $ ECombinator "satisfy"+  {-# INLINE satisfy #-}++  -- By inling this combinator, GHC should figure out the `utf8Width`+  -- of the character resulting in an optimized decoder.+  char c =+    let w = utf8Width c+    in Acceptor $ \env st@State{_stOff, _stLine, _stCol} ok err ->+      if utf8DecodeFixed w (_envSrc env) _stOff == c then+        ok c st+        { _stOff =_stOff + w+        , _stLine = if c == '\n' then _stLine + 1 else _stLine+        , _stCol = if c == '\n' then 1 else _stCol + 1+        }+      else+        err $ ECombinator "char"+  {-# INLINE char #-}++-- | Reader monad, get something from the environment+get :: (Env -> State -> a) -> Acceptor a+get f = Acceptor $ \env st ok _ -> ok (f env st) st+{-# INLINE get #-}++-- | Reader monad, modify environment locally+local :: (State -> Env -> Env) -> Acceptor a -> Acceptor a+local f p = Acceptor $ \env st ok err ->+  unAcceptor p (f st env) st ok err+{-# INLINE local #-}++-- | Run 'Acceptor' on the given 'ByteString', returning either+-- a simple 'Error' or, if successful, the result.+runAcceptor :: Acceptor a -> FilePath -> ByteString -> Either Error a+runAcceptor p f t =+  let b = t <> "\0\0\0"+  in unAcceptor p (initialEnv f b) (initialState b) (\x _ -> Right x) Left++initialEnv :: FilePath -> ByteString -> Env+initialEnv _envFile (B.PS _envSrc off len) = Env+  { _envSrc+  , _envFile+  , _envEnd = off + len - 3+  , _envRefLine = 0+  , _envRefCol = 0+  }++initialState :: ByteString -> State+initialState (B.PS _ _stOff _) = State+  { _stOff+  , _stLine = 1+  , _stCol = 1+  }
+ src/Text/PariPari/Ascii.hs view
@@ -0,0 +1,45 @@+module Text.PariPari.Ascii (+  module Text.PariPari.Ascii+) where++import Data.ByteString (ByteString)+import Data.Foldable (foldl')+import Data.Word (Word8)+import GHC.Base (unsafeChr)+import GHC.Show (showLitChar)+import Numeric (showHex)+import qualified Data.ByteString as B++asc_0, asc_9, asc_A, asc_E, asc_P, asc_a, asc_e, asc_p,+  asc_minus, asc_plus, asc_point, asc_newline :: Word8+asc_0 = 48+asc_9 = 57+asc_A = 65+asc_E = 69+asc_P = 80+asc_a = 97+asc_e = 101+asc_p = 112+asc_minus = 45+asc_plus = 43+asc_point = 46+asc_newline = 10++unsafeAsciiToChar :: Word8 -> Char+unsafeAsciiToChar = unsafeChr . fromIntegral+{-# INLINE unsafeAsciiToChar #-}++byteS :: Word8 -> ShowS+byteS b+  | b < 128 = showLitChar $ unsafeAsciiToChar b+  | otherwise = ("\\x" <>) . showHex b++bytesS :: ByteString -> ShowS+bytesS b | B.length b == 1 = byteS $ B.head b+         | otherwise = foldl' ((. byteS) . (.)) id $ B.unpack b++showByte :: Word8 -> String+showByte b = ('\'':) . byteS b . ('\'':) $ ""++showBytes :: ByteString -> String+showBytes b = ('"':) . bytesS b . ('"':) $ ""
+ src/Text/PariPari/Class.hs view
@@ -0,0 +1,126 @@+module Text.PariPari.Class (+  MonadParser(..)+  , Parser+  , Alternative(..)+  , MonadPlus+  , Pos(..)+  , Error(..)+  , ByteString+  , Word8+  , showError+) where++import Control.Applicative (Alternative(empty, (<|>)))+import Control.Monad (MonadPlus(..))+import Control.Monad.Fail (MonadFail(..))+import Data.ByteString (ByteString)+import Data.List (intercalate)+import Data.Word (Word8)+import GHC.Generics (Generic)++-- | Line and column position starting at (1,1)+data Pos = Pos+  { _posLine   :: !Int+  , _posColumn :: !Int+  } deriving (Eq, Show, Generic)++-- | Parsing errors+data Error+  = EEmpty+  | EInvalidUtf8+  | EExpectedEnd+  | EExpected         [String]+  | EUnexpected       String+  | EFail             String+  | ECombinator       String+  | EIndentNotAligned !Int !Int+  | EIndentOverLine   !Int !Int+  | ENotEnoughIndent  !Int !Int+  deriving (Eq, Ord, Show, Generic)++-- | Parser shortcut+type Parser a = (forall p. MonadParser p => p a)++-- | Parser class, which specifies the necessary+-- primitives for parsing. All other parser combinators+-- rely on these primitives.+class (MonadFail p, MonadPlus p) => MonadParser p where+  -- | Get file name associated with current parser+  getFile :: p FilePath++  -- | Get current position of the parser+  getPos :: p Pos++  -- | Get reference position used for indentation-sensitive parsing+  getRefPos :: p Pos++  -- | Update reference position with current position+  withRefPos :: p a -> p a++  -- | Parser which succeeds when the given parser fails+  notFollowedBy :: Show a => p a -> p ()++  -- | Look ahead and return result of the given parser+  -- The current position stays the same.+  lookAhead :: p a -> p a++  -- | Parser failure with detailled 'Error'+  failWith :: Error -> p a++  -- | Parser which succeeds at the end of file+  eof :: p ()++  -- | Annotate the given parser with a label+  -- used for error reporting+  label :: String -> p a -> p a++  -- | Hide errors occurring within the given parser+  -- from the error report. Based on the given+  -- labels an 'Error' is constructed instead.+  hidden :: p a -> p a++  -- | Commit to the given branch, increasing+  -- the priority of the errors within this branch+  -- in contrast to other branches.+  --+  -- This is basically the opposite of the `try`+  -- combinator provided by other parser combinator+  -- libraries, which decreases the error priority+  -- within the given branch (and usually also influences backtracking).+  --+  -- __Note__: `commit` only applies to the reported+  -- errors, it has no effect on the backtracking behavior+  -- of the parser.+  commit :: p a -> p a++  -- | Parse a single byte+  byte :: Word8 -> p Word8++  -- | Parse a single UTF-8 character+  char :: Char -> p Char++  -- | Parse a single character with the given predicate+  satisfy :: (Char -> Bool) -> p Char++  -- | Parse a single byte with the given predicate+  byteSatisfy :: (Word8 -> Bool) -> p Word8++  -- | Parse a string of bytes+  bytes :: ByteString -> p ByteString++  -- | Run the given parser and return the+  -- result as bytes+  asBytes :: p () -> p ByteString++-- | Pretty string representation of 'Error'+showError :: Error -> String+showError EEmpty                   = "No error"+showError EInvalidUtf8             = "Invalid UTF-8 character found"+showError EExpectedEnd             = "Expected end of file"+showError (EExpected tokens)       = "Expected " <> intercalate ", " tokens+showError (EUnexpected token)      = "Unexpected " <> token+showError (EFail msg)              = msg+showError (ECombinator name)       = "Combinator " <> name <> " failed"+showError (EIndentNotAligned rc c) = "Invalid alignment, expected column " <> show rc <> " expected, got " <> show c+showError (EIndentOverLine   rl l) = "Indentation over line, expected line " <> show rl <> ", got " <> show l+showError (ENotEnoughIndent  rc c) = "Not enough indentation, expected column " <> show rc <> ", got " <> show c
+ src/Text/PariPari/Combinators.hs view
@@ -0,0 +1,457 @@+module Text.PariPari.Combinators (+  -- * Basics+  Text+  , void+  , (<|>)+  , empty+  , optional++  -- * Control.Monad.Combinators.NonEmpty+  , NonEmpty(..)+  , ON.some+  , ON.endBy1+  , ON.someTill+  , ON.sepBy1+  , ON.sepEndBy1++  -- * Control.Monad.Combinators+  , O.many -- dont use Applicative version for efficiency+  , O.between+  , O.choice+  , O.count+  , O.count'+  , O.eitherP+  , O.endBy+  , O.manyTill+  , O.option+  , O.sepBy+  , O.sepEndBy+  , O.skipMany+  , O.skipSome+  , O.skipCount+  , O.skipManyTill+  , O.skipSomeTill++  -- * PariPari+  , (<?>)+  , getLine+  , getColumn+  , withPos+  , withSpan+  , getRefColumn+  , getRefLine+  , withRefPos+  , align+  , indented+  , line+  , linefold+  , notByte+  , anyByte+  , digitByte+  , asciiByte+  , integer+  , integer'+  , decimal+  , octal+  , hexadecimal+  , digit+  , signed+  , fractionHex+  , fractionDec+  , char'+  , notChar+  , anyChar+  , alphaNumChar+  , digitChar+  , letterChar+  , lowerChar+  , upperChar+  , symbolChar+  , categoryChar+  , punctuationChar+  , spaceChar+  , asciiChar+  , string+  , string'+  , asString+  , takeBytes+  , skipChars+  , skipBytes+  , takeChars+  , skipCharsWhile+  , takeCharsWhile+  , skipBytesWhile+  , takeBytesWhile+  , skipBytesWhile1+  , takeBytesWhile1+  , skipCharsWhile1+  , takeCharsWhile1+) where++import Control.Applicative ((<|>), empty, optional)+import Control.Monad (when)+import Control.Monad.Combinators (option, skipCount, skipMany)+import Data.List.NonEmpty (NonEmpty(..))+import Text.PariPari.Ascii+import Text.PariPari.Class+import Data.Text (Text)+import Data.Functor (void)+import Prelude hiding (getLine)+import qualified Control.Monad.Combinators as O+import qualified Control.Monad.Combinators.NonEmpty as ON+import qualified Data.Char as C+import qualified Data.Text.Encoding as T+import qualified Data.Text as T++infix 0 <?>++-- | Infix alias for 'label'+(<?>) :: MonadParser p => p a -> String -> p a+(<?>) = flip label+{-# INLINE (<?>) #-}++-- | Get line number of the reference position+getRefLine :: Parser Int+getRefLine = _posLine <$> getRefPos+{-# INLINE getRefLine #-}++-- | Get column number of the reference position+getRefColumn :: Parser Int+getRefColumn = _posColumn <$> getRefPos+{-# INLINE getRefColumn #-}++-- | Get current line number+getLine :: Parser Int+getLine = _posLine <$> getPos+{-# INLINE getLine #-}++-- | Get current column+getColumn :: Parser Int+getColumn = _posColumn <$> getPos+{-# INLINE getColumn #-}++-- | Decorate the parser result with the current position+withPos :: MonadParser p => p a -> p (Pos, a)+withPos p = do+  pos <- getPos+  ret <- p+  pure (pos, ret)+{-# INLINE withPos #-}++type Span = (Pos, Pos)++-- | Decoreate the parser result with the position span+withSpan :: MonadParser p => p a -> p (Span, a)+withSpan p = do+  begin <- getPos+  ret <- p+  end <- getPos+  pure ((begin, end), ret)+{-# INLINE withSpan #-}++-- | Parser succeeds on the same line as the reference line+line :: Parser ()+line = do+  l <- getLine+  rl <- getRefLine+  when (l /= rl) $ failWith $ EIndentOverLine rl l+{-# INLINE line #-}++-- | Parser succeeds on the same column as the reference column+align :: Parser ()+align = do+  c <- getColumn+  rc <- getRefColumn+  when (c /= rc) $ failWith $ EIndentNotAligned rc c+{-# INLINE align #-}++-- | Parser succeeds for columns greater than the current reference column+indented :: Parser ()+indented = do+  c <- getColumn+  rc <- getRefColumn+  when (c <= rc) $ failWith $ ENotEnoughIndent rc c+{-# INLINE indented #-}++-- | Parser succeeds either on the reference line or+-- for columns greater than the current reference column+linefold :: Parser ()+linefold = line <|> indented+{-# INLINE linefold #-}++-- | Parser a single byte different from the given one+notByte :: Word8 -> Parser Word8+notByte b = byteSatisfy (/= b) <?> "not " <> showByte b+{-# INLINE notByte #-}++-- | Parse an arbitrary byte+anyByte :: Parser Word8+anyByte = byteSatisfy (const True)+{-# INLINE anyByte #-}++-- | Parse a byte of the ASCII charset (< 128)+asciiByte :: Parser Word8+asciiByte = byteSatisfy (< 128)+{-# INLINE asciiByte #-}++-- | Parse a digit byte for the given base.+-- Bases 2 to 36 are supported.+digitByte :: Int -> Parser Word8+digitByte base = byteSatisfy (isDigit base)+{-# INLINE digitByte #-}++-- | Parse an integer of the given base.+-- Returns the integer and the number of digits.+-- Bases 2 to 36 are supported.+-- Digits can be separated by separator, e.g. `optional (char '_')`.+integer' :: (Num a, MonadParser p) => p sep -> Int -> p (a, Int)+integer' sep base = label (integerLabel base) $ do+  d <- digit base+  accum 1 $ fromIntegral d+  where accum !i !n = next i n <|> pure (n, i)+        next !i !n = do+          void $ sep+          d <- digit base+          accum (i + 1) $ n * fromIntegral base + fromIntegral d+{-# INLINE integer' #-}++-- | Parse an integer of the given base.+-- Bases 2 to 36 are supported.+-- Digits can be separated by separator, e.g. `optional (char '_')`.+integer :: (Num a, MonadParser p) => p sep -> Int -> p a+integer sep base = label (integerLabel base) $ do+  d <- digit base+  accum $ fromIntegral d+  where accum !n = next n <|> pure n+        next !n = do+          void $ sep+          d <- digit base+          accum $ n * fromIntegral base + fromIntegral d+{-# INLINE integer #-}++integerLabel :: Int -> String+integerLabel 2  = "binary integer"+integerLabel 8  = "octal integer"+integerLabel 10 = "decimal integer"+integerLabel 16 = "hexadecimal integer"+integerLabel b  = "integer of base " <> show b++decimal :: Num a => Parser a+decimal = integer (pure ()) 10+{-# INLINE decimal #-}++octal :: Num a => Parser a+octal = integer (pure ()) 8+{-# INLINE octal #-}++hexadecimal :: Num a => Parser a+hexadecimal = integer (pure ()) 16+{-# INLINE hexadecimal #-}++digitToInt :: Int -> Word8 -> Word+digitToInt base b+  | n <- (fromIntegral b :: Word) - fromIntegral asc_0, base <= 10 || n <= 9  = n+  | n <- (fromIntegral b :: Word) - fromIntegral asc_A, n               <= 26 = n + 10+  | n <- (fromIntegral b :: Word) - fromIntegral asc_a                        = n + 10+{-# INLINE digitToInt #-}++-- | Parse a single digit of the given base and return its value.+-- Bases 2 to 36 are supported.+digit :: Int -> Parser Word+digit base = digitToInt base <$> byteSatisfy (isDigit base)+{-# INLINE digit #-}++isDigit :: Int -> Word8 -> Bool+isDigit base b+  | base >= 2 && base <= 10 = b >= asc_0 && b <= asc_0 + fromIntegral base - 1+  | base <= 36 = (b >= asc_0 && b <= asc_9)+                 || ((fromIntegral b :: Word) - fromIntegral asc_A) < fromIntegral (base - 10)+                 || ((fromIntegral b :: Word) - fromIntegral asc_a) < fromIntegral (base - 10)+  |otherwise = error "Text.PariPari.Combinators.isDigit: Bases 2 to 36 are supported"+{-# INLINE isDigit #-}++-- | Parse a number with a plus or minus sign.+signed :: (Num a, MonadParser p) => p a -> p a+signed p = ($) <$> ((id <$ byte asc_plus) <|> (negate <$ byte asc_minus) <|> pure id) <*> p+{-# INLINE signed #-}++-- | Parse a fraction of arbitrary exponent base and coefficient base.+-- 'fractionDec' and 'fractionHex' should be used instead probably.+fraction :: (Num a, MonadParser p) => p expSep -> Int -> Int -> p digitSep -> p (a, Int, a)+fraction expSep expBase coeffBasePow digitSep = do+  let coeffBase = expBase ^ coeffBasePow+  coeff <- integer digitSep coeffBase+  void $ optional $ byte asc_point+  (frac, fracLen) <- option (0, 0) $ integer' digitSep coeffBase+  expVal <- option 0 $ expSep *> signed (integer digitSep 10)+  pure (coeff * fromIntegral coeffBase ^ fracLen + frac,+        expBase,+        expVal - fromIntegral (fracLen * coeffBasePow))+{-# INLINE fraction #-}++-- | Parse a decimal fraction, returning (coefficient, 10, exponent),+-- corresponding to coefficient * 10^exponent.+-- Digits can be separated by separator, e.g. `optional (char '_')`.+fractionDec :: (Num a, MonadParser p) => p digitSep -> p (a, Int, a)+fractionDec sep = fraction (byteSatisfy (\b -> b == asc_E || b == asc_e)) 10 1 sep <?> "fraction"+{-# INLINE fractionDec #-}++-- | Parse a hexadecimal fraction, returning (coefficient, 2, exponent),+-- corresponding to coefficient * 2^exponent.+-- Digits can be separated by separator, e.g. `optional (char '_')`.+fractionHex :: (Num a, MonadParser p) => p digitSep -> p (a, Int, a)+fractionHex sep = fraction (byteSatisfy (\b -> b == asc_P || b == asc_p)) 2 4 sep <?> "hexadecimal fraction"+{-# INLINE fractionHex #-}++-- | Parse a case-insensitive character+char' :: Char -> Parser Char+char' x =+  let l = C.toLower x+      u = C.toUpper x+  in satisfy (\c -> c == l || c == u)+{-# INLINE char' #-}++-- | Parse a character different from the given one.+notChar :: Char -> Parser Char+notChar c = satisfy (/= c)+{-# INLINE notChar #-}++-- | Parse an arbitrary character.+anyChar :: Parser Char+anyChar = satisfy (const True)+{-# INLINE anyChar #-}++-- | Parse an alphanumeric character, including Unicode.+alphaNumChar :: Parser Char+alphaNumChar = satisfy C.isAlphaNum <?> "alphanumeric character"+{-# INLINE alphaNumChar #-}++-- | Parse a letter character, including Unicode.+letterChar :: Parser Char+letterChar = satisfy C.isLetter <?> "letter"+{-# INLINE letterChar #-}++-- | Parse a lowercase letter, including Unicode.+lowerChar :: Parser Char+lowerChar = satisfy C.isLower <?> "lowercase letter"+{-# INLINE lowerChar #-}++-- | Parse a uppercase letter, including Unicode.+upperChar :: Parser Char+upperChar = satisfy C.isUpper <?> "uppercase letter"+{-# INLINE upperChar #-}++-- | Parse a space character, including Unicode.+spaceChar :: Parser Char+spaceChar = satisfy C.isSpace <?> "space"+{-# INLINE spaceChar #-}++-- | Parse a symbol character, including Unicode.+symbolChar :: Parser Char+symbolChar = satisfy C.isSymbol <?> "symbol"+{-# INLINE symbolChar #-}++-- | Parse a punctuation character, including Unicode.+punctuationChar :: Parser Char+punctuationChar = satisfy C.isPunctuation <?> "punctuation"+{-# INLINE punctuationChar #-}++-- | Parse a digit character of the given base.+-- Bases 2 to 36 are supported.+digitChar :: Int -> Parser Char+digitChar base = unsafeAsciiToChar <$> digitByte base+{-# INLINE digitChar #-}++-- | Parse a character beloning to the ASCII charset (< 128)+asciiChar :: Int -> Parser Char+asciiChar base = unsafeAsciiToChar <$> digitByte base+{-# INLINE asciiChar #-}++-- | Parse a character belonging to the given Unicode category+categoryChar :: C.GeneralCategory -> Parser Char+categoryChar cat = satisfy ((== cat) . C.generalCategory) <?> untitle (show cat)+{-# INLINE categoryChar #-}++-- | Parse a text string+string :: Text -> Parser Text+string t = t <$ bytes (T.encodeUtf8 t)+{-# INLINE string #-}++string' :: Text -> Parser Text+string' s = asString (go s) <?> "case-insensitive \"" <> T.unpack (T.toLower s) <> "\""+  where go t+          | T.null t  = pure ()+          | otherwise = char' (T.head t) *> go (T.tail t)+{-# INLINE string' #-}++-- | Run the given parser but return the result as a 'Text' string+asString :: MonadParser p => p () -> p Text+asString p = T.decodeUtf8 <$> asBytes p+{-# INLINE asString #-}++-- | Take the next n bytes and advance the position by n bytes+takeBytes :: Int -> Parser ByteString+takeBytes n = asBytes (skipBytes n) <?> show n <> " bytes"+{-# INLINE takeBytes #-}++-- | Skip the next n bytes+skipBytes :: Int -> Parser ()+skipBytes n = skipCount n anyByte+{-# INLINE skipBytes #-}++-- | Skip the next n characters+skipChars :: Int -> Parser ()+skipChars n = skipCount n anyChar+{-# INLINE skipChars #-}++-- | Take the next n characters and advance the position by n characters+takeChars :: Int -> Parser Text+takeChars n = asString (skipChars n) <?> "string of length " <> show n+{-# INLINE takeChars #-}++-- | Skip char while predicate is true+skipCharsWhile :: (Char -> Bool) -> Parser ()+skipCharsWhile f = skipMany (satisfy f)+{-# INLINE skipCharsWhile #-}++-- | Take chars while predicate is true+takeCharsWhile :: (Char -> Bool) -> Parser Text+takeCharsWhile f = asString (skipCharsWhile f)+{-# INLINE takeCharsWhile #-}++-- | Skip bytes while predicate is true+skipBytesWhile :: (Word8 -> Bool) -> Parser ()+skipBytesWhile f = skipMany (byteSatisfy f)+{-# INLINE skipBytesWhile #-}++-- | Takes bytes while predicate is true+takeBytesWhile :: (Word8 -> Bool) -> Parser ByteString+takeBytesWhile f = asBytes (skipBytesWhile f)+{-# INLINE takeBytesWhile #-}++-- | Skip at least one byte while predicate is true+skipBytesWhile1 :: (Word8 -> Bool) -> Parser ()+skipBytesWhile1 f = byteSatisfy f *> skipBytesWhile f+{-# INLINE skipBytesWhile1 #-}++-- | Take at least one byte while predicate is true+takeBytesWhile1 :: (Word8 -> Bool) -> Parser ByteString+takeBytesWhile1 f = asBytes (skipBytesWhile1 f)+{-# INLINE takeBytesWhile1 #-}++-- | Skip at least one byte while predicate is true+skipCharsWhile1 :: (Char -> Bool) -> Parser ()+skipCharsWhile1 f = satisfy f *> skipCharsWhile f+{-# INLINE skipCharsWhile1 #-}++-- | Take at least one byte while predicate is true+takeCharsWhile1 :: (Char -> Bool) -> Parser Text+takeCharsWhile1 f = asString (skipCharsWhile1 f)+{-# INLINE takeCharsWhile1 #-}++untitle :: String -> String+untitle []     = []+untitle (x:xs) = C.toLower x : go xs+  where go [] = ""+        go (y:ys) | C.isUpper y = ' ' : C.toLower y : untitle ys+                  | otherwise   = y : ys
+ src/Text/PariPari/Decode.hs view
@@ -0,0 +1,90 @@+module Text.PariPari.Decode (+  bytesEqual+  , byteAt+  , utf8Decode+  , utf8DecodeFixed+  , utf8Width+) where++import Data.Word (Word8)+import Data.Bits (unsafeShiftL, (.|.), (.&.))+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)+import Foreign.Ptr (plusPtr)+import Foreign.Storable (peekByteOff)+import GHC.Base (unsafeChr)+import qualified Data.ByteString.Internal as B++bytesEqual :: ForeignPtr Word8 -> Int -> ForeignPtr Word8 -> Int -> Int -> Bool+bytesEqual p1 i1 p2 i2 n =+  B.accursedUnutterablePerformIO $+  withForeignPtr p1 $ \q1 ->+  withForeignPtr p2 $ \q2 ->+  (== 0) <$> B.memcmp (q1 `plusPtr` i1) (q2 `plusPtr` i2) n+{-# INLINE bytesEqual #-}++byteAt :: ForeignPtr Word8 -> Int -> Word8+byteAt p i = B.accursedUnutterablePerformIO $+  withForeignPtr p $ \q -> peekByteOff q i+{-# INLINE byteAt #-}++at :: ForeignPtr Word8 -> Int -> Int+at p i = fromIntegral $ byteAt p i+{-# INLINE at #-}++-- | Decode UTF-8 character at the given offset relative to the pointer+utf8Decode :: ForeignPtr Word8 -> Int -> (Char, Int)+utf8Decode p i+  | a1 <- at p i,+    a1 <= 0x7F =+    (unsafeChr a1, 1)+  | a1 <- at p i, a2 <- at p (i + 1),+    (a1 .&. 0xE0) == 0xC0,+    (a2 .&. 0xC0) == 0x80 =+    (unsafeChr (((a1 .&. 31) `unsafeShiftL` 6)+                .|. (a2 .&. 0x3F)), 2)+  | a1 <- at p i, a2 <- at p (i + 1), a3 <- at p (i + 2),+    (a1 .&. 0xF0) == 0xE0,+    (a2 .&. 0xC0) == 0x80,+    (a3 .&. 0xC0) == 0x80 =+    (unsafeChr (((a1 .&. 15) `unsafeShiftL` 12)+                 .|. ((a2 .&. 0x3F) `unsafeShiftL` 6)+                 .|. (a3 .&. 0x3F)), 3)+  | a1 <- at p i, a2 <- at p (i + 1), a3 <- at p (i + 2), a4 <- at p (i + 3),+    (a1 .&. 0xF8) == 0xF0,+    (a2 .&. 0xC0) == 0x80,+    (a3 .&. 0xC0) == 0x80,+    (a4 .&. 0xC0) == 0x80 =+    (unsafeChr (((a1 .&. 7) `unsafeShiftL` 18)+                 .|. ((a2 .&. 0x3F) `unsafeShiftL` 12)+                 .|. ((a3 .&. 0x3F) `unsafeShiftL` 6)+                 .|. (a4 .&. 0x3F)), 4)+  | otherwise = ('\0', 0)+{-# INLINE utf8Decode #-}++-- | Decode UTF-8 character with known width at the given offset relative to the pointer+utf8DecodeFixed :: Int -> ForeignPtr Word8 -> Int -> Char+utf8DecodeFixed w p i = unsafeChr $+  case w of+    1 -> at p i+    2 | a1 <- at p i, a2 <- at p (i + 1) ->+        ((a1 .&. 31) `unsafeShiftL` 6)+        .|. (a2 .&. 0x3F)+    3 | a1 <- at p i, a2 <- at p (i + 1), a3 <- at p (i + 2) ->+        ((a1 .&. 15) `unsafeShiftL` 12)+        .|. ((a2 .&. 0x3F) `unsafeShiftL` 6)+        .|. (a3 .&. 0x3F)+    4 | a1 <- at p i, a2 <- at p (i + 1), a3 <- at p (i + 2), a4 <- at p (i + 3) ->+        ((a1 .&. 7) `unsafeShiftL` 18)+        .|. ((a2 .&. 0x3F) `unsafeShiftL` 12)+        .|. ((a3 .&. 0x3F) `unsafeShiftL` 6)+        .|. (a4 .&. 0x3F)+    _ -> 0+{-# INLINE utf8DecodeFixed #-}++-- | Bytes width of an UTF-8 character+utf8Width :: Char -> Int+utf8Width c | c <= unsafeChr 0x7F = 1+            | c <= unsafeChr 0x7FF = 2+            | c <= unsafeChr 0xFFFF = 3+            | otherwise = 4+{-# INLINE utf8Width #-}
+ src/Text/PariPari/Reporter.hs view
@@ -0,0 +1,421 @@+module Text.PariPari.Reporter (+  Reporter+  , Report(..)+  , runReporter+  , runReporterWithOptions+  , ErrorContext+  , showReport+  , showErrors+  , ReportOptions(..)+  , defaultReportOptions+  , Tracer+  , runTracer+) where++import Control.Monad (void)+import Data.Function (on)+import Data.List (intercalate, sort, group, sortOn)+import Data.List.NonEmpty (NonEmpty(..))+import Debug.Trace (trace)+import Foreign.ForeignPtr (ForeignPtr)+import GHC.Generics (Generic)+import Text.PariPari.Ascii+import Text.PariPari.Class+import Text.PariPari.Decode+import qualified Control.Monad.Fail as Fail+import qualified Data.ByteString.Internal as B+import qualified Data.List.NonEmpty as NE++type ErrorContext = ([Error], [String])++data ReportOptions = ReportOptions+  { _optMaxContexts         :: !Int+  , _optMaxErrorsPerContext :: !Int+  , _optMaxLabelsPerContext :: !Int+  } deriving (Eq, Show, Generic)++data Report = Report+  { _reportFile   :: !FilePath+  , _reportLine   :: !Int+  , _reportCol    :: !Int+  , _reportErrors :: [ErrorContext]+  } deriving (Eq, Show, Generic)++data Env = Env+  { _envSrc     :: !(ForeignPtr Word8)+  , _envEnd     :: !Int+  , _envFile    :: !FilePath+  , _envOptions :: !ReportOptions+  , _envHidden  :: !Bool+  , _envCommit  :: !Int+  , _envContext :: [String]+  , _envRefLine :: !Int+  , _envRefCol  :: !Int+  }++data State = State+  { _stOff       :: !Int+  , _stLine      :: !Int+  , _stCol       :: !Int+  , _stErrOff    :: !Int+  , _stErrLine   :: !Int+  , _stErrCol    :: !Int+  , _stErrCommit :: !Int+  , _stErrors    :: [ErrorContext]+  }++-- | Parser which is optimized for good error reports.+-- Performance is secondary, since the 'Reporter' is used+-- as a fallback to the 'Acceptor'.+newtype Reporter a = Reporter+  { unReporter :: forall b. Env -> State+               -> (a     -> State -> b)+               -> (State -> b)+               -> b+  }++instance Semigroup a => Semigroup (Reporter a) where+  p1 <> p2 = (<>) <$> p1 <*> p2+  {-# INLINE (<>) #-}++instance Monoid a => Monoid (Reporter a) where+  mempty = pure mempty+  {-# INLINE mempty #-}++instance Functor Reporter where+  fmap f p = Reporter $ \env st ok err ->+    unReporter p env st (ok . f) err+  {-# INLINE fmap #-}++instance Applicative Reporter where+  pure x = Reporter $ \_ st ok _ -> ok x st+  {-# INLINE pure #-}++  f <*> a = Reporter $ \env st ok err ->+    let ok1 f' s =+          let ok2 a' s' = ok (f' a') s'+          in unReporter a env s ok2 err+    in unReporter f env st ok1 err+  {-# INLINE (<*>) #-}++  p1 *> p2 = do+    void p1+    p2+  {-# INLINE (*>) #-}++  p1 <* p2 = do+    x <- p1+    void p2+    pure x+  {-# INLINE (<*) #-}++instance Alternative Reporter where+  empty = Reporter $ \_ st _ err -> err st+  {-# INLINE empty #-}++  p1 <|> p2 = Reporter $ \env st ok err ->+    let err' s = unReporter p2 env (mergeStateErrors env st s) ok err+    in unReporter p1 env st ok err'+  {-# INLINE (<|>) #-}++instance MonadPlus Reporter++instance Monad Reporter where+  p >>= f = Reporter $ \env st ok err ->+    let ok' x s = unReporter (f x) env s ok err+    in unReporter p env st ok' err+  {-# INLINE (>>=) #-}++  fail msg = Fail.fail msg+  {-# INLINE fail #-}++instance Fail.MonadFail Reporter where+  fail msg = failWith $ EFail msg+  {-# INLINE fail #-}++instance MonadParser Reporter where+  getPos = get $ \_ st -> Pos (_stLine st) (_stCol st)+  {-# INLINE getPos #-}++  getFile = get $ \env _ -> _envFile env+  {-# INLINE getFile #-}++  getRefPos = get $ \env _ -> Pos (_envRefLine env) (_envRefCol env)+  {-# INLINE getRefPos #-}++  withRefPos p = local (\st env -> env { _envRefLine = _stLine st, _envRefCol = _stCol st }) p+  {-# INLINE withRefPos #-}++  label l p = local (const $ addLabel l) p+  {-# INLINE label #-}++  hidden p = local (const $ \env -> env { _envHidden = True }) p+  {-# INLINE hidden #-}++  commit p = local (const $ \env -> env { _envCommit = _envCommit env + 1 }) p+  {-# INLINE commit #-}++  notFollowedBy p = Reporter $ \env st ok err ->+    let ok' x _ = raiseError env st err $ EUnexpected $ show x+        err' _ = ok () st+    in unReporter p env st ok' err'+  {-# INLINE notFollowedBy #-}++  lookAhead p = Reporter $ \env st ok err ->+    let ok' x _ = ok x st+    in unReporter p env st ok' err+  {-# INLINE lookAhead #-}++  failWith e = Reporter $ \env st _ err -> raiseError env st err e+  {-# INLINE failWith #-}++  eof = Reporter $ \env st ok err ->+    if _stOff st >= _envEnd env then+      ok () st+    else+      raiseError env st err EExpectedEnd+  {-# INLINE eof #-}++  byte b = Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err ->+    if | _stOff >= _envEnd env -> err st+       | b == byteAt (_envSrc env) _stOff ->+           ok b st+           { _stOff =_stOff + 1+           , _stLine = if b == asc_newline then _stLine + 1 else _stLine+           , _stCol = if b == asc_newline then 1 else _stCol + 1+           }+       | otherwise ->+           raiseError env st err $ EExpected [showByte b]+  {-# INLINE byte #-}++  byteSatisfy f = Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err ->+    let b = byteAt (_envSrc env) _stOff+    in if | _stOff >= _envEnd env -> err st+          | f b ->+              ok b st+              { _stOff =_stOff + 1+              , _stLine = if b == asc_newline then _stLine + 1 else _stLine+              , _stCol = if b == asc_newline then 1 else _stCol + 1+              }+          | otherwise ->+              raiseError env st err $ EUnexpected $ showByte b+  {-# INLINE byteSatisfy #-}++  bytes b@(B.PS p i n) = Reporter $ \env st@State{_stOff,_stCol} ok err ->+    if n + _stOff <= _envEnd env &&+       bytesEqual (_envSrc env) _stOff p i n then+      ok b st { _stOff = _stOff + n, _stCol = _stCol + n }+    else+      raiseError env st err $ EExpected [showBytes b]+  {-# INLINE bytes #-}++  asBytes p = do+    begin <- get (const _stOff)+    p+    end <- get (const _stOff)+    src <- get (\env _ -> _envSrc env)+    pure $ B.PS src begin (end - begin)+  {-# INLINE asBytes #-}++  satisfy f = Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err ->+    let (c, w) = utf8Decode (_envSrc env) _stOff+    in if | c /= '\0' ->+            if f c then+              ok c st+              { _stOff =_stOff + w+              , _stLine = if c == '\n' then _stLine + 1 else _stLine+              , _stCol = if c == '\n' then 1 else _stCol + 1+              }+            else+              raiseError env st err $ EUnexpected $ show c+          | c == '\0' && _stOff >= _envEnd env -> err st+          | otherwise -> raiseError env st err EInvalidUtf8+  {-# INLINE satisfy #-}++  char c =+    let w = utf8Width c+    in Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err ->+      if utf8DecodeFixed w (_envSrc env) _stOff == c then+        ok c st+        { _stOff =_stOff + w+        , _stLine = if c == '\n' then _stLine + 1 else _stLine+        , _stCol = if c == '\n' then 1 else _stCol + 1+        }+      else+        raiseError env st err $ EExpected [show c]+  {-# INLINE char #-}++raiseError :: Env -> State -> (State -> b) -> Error -> b+raiseError env st err e = err $ addError env st e+{-# INLINE raiseError #-}++-- | Reader monad, modify environment locally+local :: (State -> Env -> Env) -> Reporter a -> Reporter a+local f p = Reporter $ \env st ok err ->+  unReporter p (f st env) st ok err+{-# INLINE local #-}++-- | Reader monad, get something from the environment+get :: (Env -> State -> a) -> Reporter a+get f = Reporter $ \env st ok _ -> ok (f env st) st+{-# INLINE get #-}++addLabel :: String -> Env -> Env+addLabel l env = case _envContext env of+  (l':_) | l == l' -> env+  ls               -> env { _envContext = take (_optMaxLabelsPerContext._envOptions $ env) $ l : ls }+{-# INLINE addLabel #-}++-- | Add parser error to the list of errors+-- which are kept in the parser state.+-- Errors of lower priority and at an earlier position.+-- Furthermore the error is merged with existing errors if possible.+addError :: Env -> State -> Error -> State+addError env st e+  | _stOff st > _stErrOff st || _envCommit env > _stErrCommit st,+    Just e' <- mkError env e =+      st { _stErrors    = [e']+         , _stErrOff    = _stOff st+         , _stErrLine   = _stLine st+         , _stErrCol    = _stCol st+         , _stErrCommit = _envCommit env+         }+  | _stOff st == _stErrOff st && _envCommit env == _stErrCommit st,+    Just e' <- mkError env e =+      st { _stErrors = shrinkErrors env $ e' : _stErrors st }+  | otherwise = st+{-# INLINE addError #-}++mkError :: Env -> Error -> Maybe ErrorContext+mkError env e+  | _envHidden env, (l:ls) <- _envContext env = Just $ ([EExpected [l]], ls)+  | _envHidden env = Nothing+  | otherwise = Just $ ([e], _envContext env)+{-# INLINE mkError #-}++-- | Merge errors of two states, used when backtracking+mergeStateErrors :: Env -> State -> State -> State+mergeStateErrors env s s'+  | _stErrOff s' > _stErrOff s || _stErrCommit s' > _stErrCommit s =+      s { _stErrors    = _stErrors s'+        , _stErrOff    = _stErrOff s'+        , _stErrLine   = _stErrLine s'+        , _stErrCol    = _stErrCol s'+        , _stErrCommit = _stErrCommit s'+        }+  | _stErrOff s' == _stErrOff s && _stErrCommit s' == _stErrCommit s =+      s { _stErrors = shrinkErrors env $ _stErrors s' <> _stErrors s }+  | otherwise = s+{-# INLINE mergeStateErrors #-}++groupOn :: Eq e => (a -> e) -> [a] -> [NonEmpty a]+groupOn f = NE.groupBy ((==) `on` f)++shrinkErrors :: Env -> [ErrorContext] -> [ErrorContext]+shrinkErrors env = take (_optMaxContexts._envOptions $ env) . map (mergeErrorContexts env) . groupOn snd . sortOn snd++-- | Shrink error context by deleting duplicates+-- and merging errors if possible.+mergeErrorContexts :: Env -> NonEmpty ErrorContext -> ErrorContext+mergeErrorContexts env es@((_, ctx):| _) = (take (_optMaxErrorsPerContext._envOptions $ env) $ nubSort $ mergeEExpected $ concatMap fst $ NE.toList es, ctx)++mergeEExpected :: [Error] -> [Error]+mergeEExpected es = [EExpected $ nubSort expects | not (null expects)] <> filter (null . asEExpected) es+  where expects = concatMap asEExpected es++nubSort :: Ord a => [a] -> [a]+nubSort = map head . group . sort++asEExpected :: Error -> [String]+asEExpected (EExpected s) = s+asEExpected _ = []++-- | Run 'Reporter' with additional 'ReportOptions'.+runReporterWithOptions :: ReportOptions -> Reporter a -> FilePath -> ByteString -> Either Report a+runReporterWithOptions o p f t =+  let b = t <> "\0\0\0"+  in unReporter p (initialEnv o f b) (initialState b) (\x _ -> Right x) (Left . getReport f)++-- | Run 'Reporter' on the given 'ByteString', returning either+-- an error 'Report' or, if successful, the result.+runReporter :: Reporter a -> FilePath -> ByteString -> Either Report a+runReporter = runReporterWithOptions defaultReportOptions++getReport :: FilePath -> State -> Report+getReport f s = Report f (_stErrLine s) (_stErrCol s) (_stErrors s)++initialEnv :: ReportOptions -> FilePath -> ByteString -> Env+initialEnv _envOptions _envFile (B.PS _envSrc off len) = Env+  { _envFile+  , _envSrc+  , _envOptions+  , _envEnd     = off + len - 3+  , _envContext = []+  , _envHidden  = False+  , _envCommit  = 0+  , _envRefLine = 0+  , _envRefCol  = 0+  }++defaultReportOptions :: ReportOptions+defaultReportOptions = ReportOptions+  { _optMaxContexts         = 20+  , _optMaxErrorsPerContext = 20+  , _optMaxLabelsPerContext = 5+  }++initialState :: ByteString -> State+initialState (B.PS _ _stOff _) = State+  { _stOff+  , _stLine      = 1+  , _stCol       = 1+  , _stErrOff    = 0+  , _stErrLine   = 0+  , _stErrCol    = 0+  , _stErrCommit = 0+  , _stErrors    = []+  }++-- | Pretty string representation of 'Report'.+showReport :: Report -> String+showReport r =+  "Parser errors at " <> _reportFile r+  <> ", line " <> show (_reportLine r)+  <> ", column " <> show (_reportCol r)+  <> "\n\n" <> showErrors (_reportErrors r)++-- | Pretty string representation of '[ErrorContext]'.+showErrors :: [ErrorContext] -> String+showErrors [] = "No errors"+showErrors es = intercalate "\n" $ map showErrorContext es++showErrorContext :: ErrorContext -> String+showErrorContext (e, c) = intercalate ", " (map showError e) <> showContext c <> "."++showContext :: [String] -> String+showContext [] = ""+showContext xs = " in context of " <> intercalate ", " xs++-- | Parser which prints trace messages, when backtracking occurs.+newtype Tracer a = Tracer { unTracer :: Reporter a }+  deriving (Semigroup, Monoid, Functor, Applicative, MonadPlus, Monad, Fail.MonadFail, MonadParser)++instance Alternative Tracer where+  empty = Tracer empty++  p1 <|> p2 = Tracer $ Reporter $ \env st ok err ->+    let err' s =+          let width = _stOff s -_stOff st+              next  = unReporter (unTracer p2) env (mergeStateErrors env st s) ok err+          in if width > 1 then+               trace ("Back tracking " <> show width <> " bytes at line " <> show (_stLine s)+                       <> ", column " <> show (_stCol s) <> ", context " <> show (_envContext env) <> ": "+                       <> showBytes (B.PS (_envSrc env) (_stOff st) width)) next+             else+               next+    in unReporter (unTracer p1) env st ok err'++-- | Run 'Tracer' on the given 'ByteString', returning either+-- an error 'Report' or, if successful, the result.+runTracer :: Tracer a -> FilePath -> ByteString -> Either Report a+runTracer = runReporter . unTracer