paripari 0.1.0.0 → 0.2.0.0

raw patch · 19 files changed

+2518/−1448 lines, 19 filesdep +tastydep +tasty-hunitnew-component:exe:paripari-examplenew-component:exe:paripari-specialise-allPVP ok

version bump matches the API change (PVP)

Dependencies added: tasty, tasty-hunit

API changes (from Hackage documentation)

Files

• example.hs +23/−9
• paripari.cabal +42/−11
• specialise-all.hs +199/−0
• src/Text/PariPari.hs +37/−47
• src/Text/PariPari/Acceptor.hs +0/−242
• src/Text/PariPari/Ascii.hs +0/−45
• src/Text/PariPari/Class.hs +0/−126
• src/Text/PariPari/Combinators.hs +0/−457
• src/Text/PariPari/Decode.hs +0/−90
• src/Text/PariPari/Internal/Acceptor.hs +274/−0
• src/Text/PariPari/Internal/CharCombinators.hs +266/−0
• src/Text/PariPari/Internal/Chunk.hs +280/−0
• src/Text/PariPari/Internal/Class.hs +142/−0
• src/Text/PariPari/Internal/ElementCombinators.hs +184/−0
• src/Text/PariPari/Internal/Reporter.hs +447/−0
• src/Text/PariPari/Internal/Run.hs +89/−0
• src/Text/PariPari/Internal/Tracer.hs +43/−0
• src/Text/PariPari/Reporter.hs +0/−421
• test/test.hs +492/−0

@@ -1,12 +1,26 @@ +{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+ import System.Environment (getArgs) import Text.PariPari import qualified Data.ByteString as B +type StringType    = B.ByteString+type ParserMonad p = CharParser StringType p+type Parser a      = (forall p. ParserMonad p => p a)++-- {-# SPECIALISE_ALL ParserMonad p = p ~ Acceptor StringType #-}+-- {-# SPECIALISE_ALL ParserMonad p = p ~ Reporter StringType #-}+-- {-# SPECIALISE_ALL Parser = Acceptor StringType #-}+-- {-# SPECIALISE_ALL Parser = Reporter StringType #-}+ data Value-  = Object ![(Text, Value)]+  = Object ![(StringType, Value)]   | Array  ![Value]-  | String !Text+  | String !StringType   | Number !Integer !Integer   | Bool   !Bool   | Null@@ -18,7 +32,7 @@ object :: Parser Value object = Object <$> (char '{' *> space *> sepBy pair (space *> char ',' *> space) <* space <* char '}') <?> "object" -pair :: Parser (Text, Value)+pair :: Parser (StringType, Value) pair = (,) <$> (text <* space) <*> (char ':' *> space *> value)  array :: Parser Value@@ -34,7 +48,7 @@     <|> (Null       <$ string "null")     <|> number -text :: Parser Text+text :: Parser StringType text = char '"' *> takeCharsWhile (/= '"') <* char '"' <?> "text"  number :: Parser Value@@ -52,9 +66,9 @@   case args of     [file] -> do       b <- B.readFile file-      case runParser json file b of-        Left x  -> do-          putStrLn $ showReport x+      case runCharParser json file b of+        Left report -> do+          putStrLn $ showReport report           print $ runTracer json file b-        Right x -> print x-    _ -> error "Usage: example test.json"+        Right val -> print val+    _ -> error "Usage: paripari-example test.json"

@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 35567a9d1dd99ccd046b88ea5fd4cf74ce38d5bb58560bb7f1b3450ff1a1fbbe+-- hash: 2b6dd0a88b444dee67e31d36c8744b234a1ef0a86434d9caacc7196eba7ac3f9  name:           paripari-version:        0.1.0.0+version:        0.2.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@@ -28,17 +28,18 @@ library   exposed-modules:       Text.PariPari-      Text.PariPari.Acceptor-      Text.PariPari.Ascii-      Text.PariPari.Class-      Text.PariPari.Combinators-      Text.PariPari.Decode-      Text.PariPari.Reporter+      Text.PariPari.Internal.Acceptor+      Text.PariPari.Internal.CharCombinators+      Text.PariPari.Internal.Chunk+      Text.PariPari.Internal.Class+      Text.PariPari.Internal.ElementCombinators+      Text.PariPari.Internal.Reporter+      Text.PariPari.Internal.Run+      Text.PariPari.Internal.Tracer   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@@ -47,16 +48,46 @@     , text >=0.11 && <1.3   default-language: Haskell2010 -executable example+executable paripari-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++executable paripari-specialise-all+  main-is: specialise-all.hs+  other-modules:+      Paths_paripari+  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++test-suite test+  type: exitcode-stdio-1.0+  main-is: test.hs+  other-modules:+      Paths_paripari+  hs-source-dirs:+      test+  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+    , tasty+    , tasty-hunit     , text >=0.11 && <1.3   default-language: Haskell2010

@@ -0,0 +1,199 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}++import System.Environment (getArgs)+import Text.PariPari+import qualified Data.Char as C+import qualified Data.List.NonEmpty as NE+import qualified Data.Text as T+import qualified Data.Text.IO as T++type StringType    = T.Text+type ParserMonad p = CharParser StringType p+type Parser a      = (forall p. ParserMonad p => p a)++data Type+  = TypeName   !StringType+  | TypeVar    !StringType+  | TypeApp    !Type !(NE.NonEmpty Type)+  | TypeEq     !Type !Type+  | TypeConstr !Type !Type+  | TypeLam    !Type !Type+  | TypeTuple  ![Type]+  | TypeList   !Type+  deriving (Show, Eq)++data SourceLine+  = SpecialiseAll !Type !Type+  | TypeDecl      !(NE.NonEmpty StringType) !Type+  | OtherLine     !StringType+  deriving (Show)++source :: Parser [SourceLine]+source = sepBy sourceLine (char '\n') <* eof++sourceLine :: Parser SourceLine+sourceLine = specialiseAll <|> typeDecl <|> otherLine++otherLine :: Parser SourceLine+otherLine = OtherLine <$> takeCharsWhile (/= '\n')++specialiseAll :: Parser SourceLine+specialiseAll = SpecialiseAll+  <$> (symbol "{-#" *> symbol "SPECIALISE_ALL" *> type_)+  <*> (symbol "=" *> type_ <* symbol "#-}")++identifierAtom :: ParserMonad p => (Char -> Bool) -> p ()+identifierAtom f = satisfy f *> skipCharsWhile (\c -> C.isAlphaNum c || c == '_' || c == '\'')++name :: Parser StringType+name = asChunk (sepEndBy (identifierAtom C.isUpper) (char '.') *>+                identifierAtom C.isLower) <* space++typeName :: Parser StringType+typeName = asChunk (void $ sepBy1 (identifierAtom C.isUpper) (char '.')) <* space++symbol :: ParserMonad p => StringType -> p StringType+symbol s = string s <* space++typeTuple :: Parser Type+typeTuple = do+  ts <- between (symbol "(") (symbol ")") (sepBy type_ (symbol ","))+  pure $ case ts of+           []  -> TypeName "()"+           [t] -> t+           _   -> TypeTuple ts++typeAtom :: Parser Type+typeAtom =+  TypeName <$> typeName+  <|> TypeVar <$> name+  <|> TypeList <$> between (symbol "[") (symbol "]") type_+  <|> typeTuple++typeApp :: Parser Type+typeApp = do+  t <- typeAtom+  option t $ TypeApp t <$> some typeAtom++type_ :: Parser Type+type_ = do+  t <- typeApp+  TypeEq t <$> (symbol "~" *> type_)+    <|> TypeLam t <$> (symbol "->" *> type_)+    <|> TypeConstr t <$> (symbol "=>" *> type_)+    <|> pure t++typeDecl :: Parser SourceLine+typeDecl = TypeDecl <$> sepBy1 name (symbol ",") <*> (symbol "::" *> type_)++space :: Parser ()+space = skipCharsWhile (== ' ')++showType :: Type -> StringType+showType (TypeName t)  = t+showType (TypeVar t)   = t+showType (TypeApp t a) = "(" <> showType t <> " " <> T.intercalate " " (NE.toList $ fmap showType a) <> ")"+showType (TypeEq a b)  = "(" <> showType a <> " ~ " <> showType b <> ")"+showType (TypeLam a b)  = "(" <> showType a <> " -> " <> showType b <> ")"+showType (TypeConstr a b)  = "(" <> showType a <> " => " <> showType b <> ")"+showType (TypeList t) = "[" <> showType t <> "]"+showType (TypeTuple t) = "(" <> T.intercalate ", " (fmap showType t) <> ")"++showSource :: SourceLine -> StringType+showSource (SpecialiseAll from to) = "-- SPECIALISE_ALL " <> showType from <> " = " <> showType to+showSource (TypeDecl      names t) = T.intercalate "," (NE.toList names) <> " :: " <> showType t+showSource (OtherLine     str)     = str++substitute :: [(StringType, Type)] -> Type -> Type+substitute vars t@(TypeVar v)+  | Just t' <- lookup v vars = t'+  | otherwise = t+substitute _    t@TypeName{} = t+substitute vars (TypeApp t a) = TypeApp (substitute vars t) (fmap (substitute vars) a)+substitute vars (TypeEq a b) = TypeEq (substitute vars a) (substitute vars b)+substitute vars (TypeConstr a b) = TypeConstr (substitute vars a) (substitute vars b)+substitute vars (TypeLam a b) = TypeLam (substitute vars a) (substitute vars b)+substitute vars (TypeTuple t) = TypeTuple (fmap (substitute vars) t)+substitute vars (TypeList t) = TypeList (substitute vars t)++unify :: Type -> Type -> Maybe [(StringType, Type)]+unify (TypeVar v) t =+  Just [(v, t)]+unify (TypeName t1) (TypeName t2)+  | t1 == t2 = Just []+unify (TypeApp t1 a1) (TypeApp t2 a2) | length a1 == length a2 = do+  t <- unify t1 t2+  a <- foldMap (uncurry unify) $ NE.zip a1 a2+  pure $ t <> a+unify (TypeEq a1 b1) (TypeEq a2 b2) = do+  a <- unify a1 a2+  b <- unify b1 b2+  pure $ a <> b+unify (TypeConstr a1 b1) (TypeConstr a2 b2) = do+  a <- unify a1 a2+  b <- unify b1 b2+  pure $ a <> b+unify (TypeLam a1 b1) (TypeLam a2 b2) = do+  a <- unify a1 a2+  b <- unify b1 b2+  pure $ a <> b+unify (TypeTuple t1) (TypeTuple t2) | length t1 == length t2 =+  foldMap (uncurry unify) $ zip t1 t2+unify (TypeList t1) (TypeList t2) =+  unify t1 t2+unify _ _ = Nothing++simplify :: Type -> Type+simplify t@TypeVar{} = t+simplify t@TypeName{} = t+simplify (TypeApp t a) = TypeApp (simplify t) (fmap simplify a)+simplify (TypeEq a b) = TypeEq (simplify a) (simplify b)+simplify (TypeLam a b) = TypeLam (simplify a) (simplify b)+simplify (TypeTuple t) = TypeTuple (fmap simplify t)+simplify (TypeList t) = TypeList (simplify t)+simplify (TypeConstr (TypeEq (TypeVar v) t) t') = substitute [(v, t)] t'+simplify (TypeConstr c t) = TypeConstr (TypeTuple otherConstraints) (substitute constraintVars t)+  where eqConstraints = [e | e@(TypeEq TypeVar{} _) <- constraints]+        constraintVars = [(v,x) | TypeEq (TypeVar v) x <- eqConstraints]+        otherConstraints = filter (\x -> all (/= x) eqConstraints) constraints+        constraints = case c of+          TypeTuple xs -> xs+          x -> [x]++specialiseType :: Type -> Type -> Type -> Type+specialiseType from to typ+  | Just vars <- unify from typ = substitute vars to+  | otherwise =+      case typ of+        TypeName{}     -> typ+        TypeVar{}      -> typ+        TypeApp t a    -> TypeApp (specialiseType from to t) (fmap (specialiseType from to) a)+        TypeEq a b     -> TypeEq (specialiseType from to a) (specialiseType from to b)+        TypeConstr a b -> TypeConstr (specialiseType from to a) (specialiseType from to b)+        TypeLam a b    -> TypeLam (specialiseType from to a) (specialiseType from to b)+        TypeTuple t    -> TypeTuple (fmap (specialiseType from to) t)+        TypeList t     -> TypeList (specialiseType from to t)++specialise :: [(Type, Type)] -> (NE.NonEmpty StringType, Type) -> [StringType]+specialise specs (names, typ) = concatMap go specs+  where go (from, to)+          | typ' <- specialiseType from to typ, typ /= typ' =+              ["{-# SPECIALISE " <> n <> " :: " <> showType (simplify typ') <> " #-}" | n <- NE.toList names]+          | otherwise = []++main :: IO ()+main = do+  args <- getArgs+  case args of+    [src, _, dst] -> do+      code <- T.readFile src+      case runCharParser source src code of+        Left report -> putStrLn $ showReport report+        Right ls -> do+          let specialisers = [(from, to) | SpecialiseAll from to <- ls]+              specialisedTypeDecls = concatMap (specialise specialisers) [(n, t) | TypeDecl n t <- ls]+          T.writeFile dst $ T.intercalate "\n" $ map showSource ls <> specialisedTypeDecls+    _ -> error "Usage: paripari-specialise-all src _ dst"

@@ -1,53 +1,43 @@ module Text.PariPari (-  module Text.PariPari.Class-  , module Text.PariPari.Combinators-  , module Text.PariPari.Acceptor-  , module Text.PariPari.Reporter-  , runParser-  , runSeqParser-  , runParserWithOptions-  , runSeqParserWithOptions-) where+  C.ChunkParser(..)+  , C.CharParser(..)+  , C.Error(..)+  , C.showError -import Text.PariPari.Acceptor-import Text.PariPari.Class-import Text.PariPari.Combinators-import Text.PariPari.Reporter-import GHC.Conc (par)+  , K.Chunk(Element, showElement, showChunk)+  , K.CharChunk+  , K.Pos(..) --- | 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+  , U.runCharParser+  , U.runSeqCharParser+  , U.runCharParserWithOptions+  , U.runSeqCharParserWithOptions+  , U.runChunkParser+  , U.runSeqChunkParser+  , U.runChunkParserWithOptions+  , U.runSeqChunkParserWithOptions --- | 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 #-}+  , A.Acceptor+  , A.runAcceptor --- | 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 #-}+  , R.Reporter+  , R.runReporter+  , R.showReport+  , R.showErrors+  , R.runReporterWithOptions --- | 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 #-}+  , T.Tracer+  , T.runTracer++  , module Text.PariPari.Internal.ElementCombinators+  , module Text.PariPari.Internal.CharCombinators+) where++import Text.PariPari.Internal.CharCombinators+import Text.PariPari.Internal.ElementCombinators+import qualified Text.PariPari.Internal.Acceptor as A+import qualified Text.PariPari.Internal.Chunk as K+import qualified Text.PariPari.Internal.Class as C+import qualified Text.PariPari.Internal.Reporter as R+import qualified Text.PariPari.Internal.Run as U+import qualified Text.PariPari.Internal.Tracer as T

@@ -1,242 +0,0 @@-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-  }

@@ -1,45 +0,0 @@-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 . ('"':) $ ""

@@ -1,126 +0,0 @@-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

@@ -1,457 +0,0 @@-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

@@ -1,90 +0,0 @@-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 #-}

@@ -0,0 +1,274 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+module Text.PariPari.Internal.Acceptor (+  Acceptor(..)+  , Env(..)+  , State(..)+  , get+  , local+  , runAcceptor+) where++import Control.Monad (void)+import Text.PariPari.Internal.Class+import Text.PariPari.Internal.Chunk+import qualified Control.Monad.Fail as Fail++data Env k = Env+  { _envBuf     :: !(Buffer k)+  , _envEnd     :: !Int+  , _envFile    :: !FilePath+  , _envRefLine :: !Int+  , _envRefCol  :: !Int+  }++data State = State+  { _stOff     :: !Int+  , _stLine    :: !Int+  , _stCol     :: !Int+  }++-- | Parser which is optimised for fast parsing. Error reporting+-- is minimal.+newtype Acceptor k a = Acceptor+  { unAcceptor :: forall b. Env k -> State+               -> (a     -> State -> b)+               -> (Error -> b)+               -> b+  }++instance (Chunk k, Semigroup a) => Semigroup (Acceptor k a) where+  p1 <> p2 = (<>) <$> p1 <*> p2+  {-# INLINE (<>) #-}++instance (Chunk k, Monoid a) => Monoid (Acceptor k a) where+  mempty = pure mempty+  {-# INLINE mempty #-}++instance Functor (Acceptor k) where+  fmap f p = Acceptor $ \env st ok err ->+    unAcceptor p env st (ok . f) err+  {-# INLINE fmap #-}++instance Chunk k => Applicative (Acceptor k) 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 Chunk k => Alternative (Acceptor k) where+  empty = Acceptor $ \_ _ _ err -> err $ ECombinator "empty"+  {-# 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 Chunk k => MonadPlus (Acceptor k)++instance Chunk k => Monad (Acceptor k) 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 Chunk k => Fail.MonadFail (Acceptor k) where+  fail msg = failWith $ EFail msg+  {-# INLINE fail #-}++instance Chunk k => ChunkParser k (Acceptor k) 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 expectedEnd+  {-# INLINE eof #-}++  label _ p = p+  {-# INLINE label #-}++  hidden p = p+  {-# INLINE hidden #-}++  commit p = p+  {-# INLINE commit #-}++  element e = Acceptor $ \env st@State{_stOff, _stLine, _stCol} ok err ->+    if | _stOff < _envEnd env,+         (e', w) <- elementAt @k (_envBuf env) _stOff,+         e == e',+         pos <- elementPos @k e (Pos _stLine _stCol) ->+           ok e st { _stOff = _stOff + w, _stLine = _posLine pos, _stCol = _posColumn pos }+       | otherwise ->+           err $ ECombinator "element"+  {-# INLINE element #-}++  elementSatisfy f = Acceptor $ \env st@State{_stOff, _stLine, _stCol} ok err ->+    if | _stOff < _envEnd env,+         (e, w) <- elementAt @k (_envBuf env) _stOff,+         f e,+         pos <- elementPos @k e (Pos _stLine _stCol) ->+           ok e st { _stOff = _stOff + w, _stLine = _posLine pos, _stCol = _posColumn pos }+       | otherwise ->+           err $ ECombinator "elementSatisfy"+  {-# INLINE elementSatisfy #-}++  chunk k = Acceptor $ \env st@State{_stOff,_stCol} ok err ->+    let n = chunkWidth @k k+    in if n + _stOff <= _envEnd env &&+          chunkEqual @k (_envBuf env) _stOff k then+         ok k st { _stOff = _stOff + n, _stCol = _stCol + n }+       else+         err $ ECombinator "chunk"+  {-# INLINE chunk #-}++  asChunk p = do+    begin <- get (const _stOff)+    p+    end <- get (const _stOff)+    src <- get (\env _ -> _envBuf env)+    pure $ packChunk src begin (end - begin)+  {-# INLINE asChunk #-}++instance CharChunk k => CharParser k (Acceptor k) where+  satisfy f = Acceptor $ \env st@State{_stOff, _stLine, _stCol} ok err ->+    if | (c, w) <- charAt @k (_envBuf env) _stOff,+         c /= '\0',+         f c ->+           ok c st+           { _stOff = _stOff + w+           , _stLine = if c == '\n' then _stLine + 1 else _stLine+           , _stCol = if c == '\n' then 1 else _stCol + 1+           }+       | otherwise ->+           err $ ECombinator "satisfy"+  {-# INLINE satisfy #-}++  -- By inling this combinator, GHC should figure out the `charWidth`+  -- of the character resulting in an optimised decoder.+  char '\0' = error "Character '\\0' cannot be parsed because it is used as sentinel"+  char c+    | w <- charWidth @k c =+        Acceptor $ \env st@State{_stOff, _stLine, _stCol} ok err ->+        if charAtFixed @k w (_envBuf 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 #-}++  asciiSatisfy f = Acceptor $ \env st@State{_stOff, _stLine, _stCol} ok err ->+    if | b <- byteAt @k (_envBuf env) _stOff,+         b /= 0,+         b < 128,+         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 "asciiSatisfy"+  {-# INLINE asciiSatisfy #-}++  asciiByte 0 = error "Character '\\0' cannot be parsed because it is used as sentinel"+  asciiByte b+    | b >= 128 = error "Not an ASCII character"+    | otherwise = Acceptor $ \env st@State{_stOff, _stLine, _stCol} ok err ->+        if byteAt @k (_envBuf env) _stOff == b then+          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+          }+        else+          err $ ECombinator "asciiByte"+  {-# INLINE asciiByte #-}++-- | Reader monad, get something from the environment+get :: (Env k -> State -> a) -> Acceptor k a+get f = Acceptor $ \env st ok _ -> ok (f env st) st+{-# INLINE get #-}++-- | Reader monad, modify environment locally+local :: (State -> Env k -> Env k) -> Acceptor k a -> Acceptor k a+local f p = Acceptor $ \env st ok err ->+  unAcceptor p (f st env) st ok err+{-# INLINE local #-}++-- | Run 'Acceptor' on the given chunk, returning either+-- a simple 'Error' or, if successful, the result.+runAcceptor :: Chunk k => Acceptor k a -> FilePath -> k -> Either Error a+runAcceptor p f k =+  let (b, off, len) = unpackChunk k+  in unAcceptor p (initialEnv f b (off + len)) (initialState off) (\x _ -> Right x) Left++initialEnv :: FilePath -> Buffer k -> Int -> Env k+initialEnv _envFile _envBuf _envEnd = Env+  { _envBuf+  , _envFile+  , _envEnd+  , _envRefLine = 1+  , _envRefCol = 1+  }++initialState :: Int -> State+initialState _stOff = State+  { _stOff+  , _stLine = 1+  , _stCol = 1+  }

@@ -0,0 +1,266 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE Rank2Types #-}+module Text.PariPari.Internal.CharCombinators (+  digitByte+  , integer+  , integer'+  , decimal+  , octal+  , hexadecimal+  , digit+  , signed+  , fractionHex+  , fractionDec+  , char'+  , notChar+  , anyChar+  , alphaNumChar+  , digitChar+  , letterChar+  , lowerChar+  , upperChar+  , symbolChar+  , categoryChar+  , punctuationChar+  , spaceChar+  , asciiChar+  , skipChars+  , takeChars+  , skipCharsWhile+  , takeCharsWhile+  , skipCharsWhile1+  , takeCharsWhile1+  , string+) where++import Control.Applicative ((<|>), optional)+import Control.Monad.Combinators (option, skipCount, skipMany)+import Text.PariPari.Internal.Chunk+import Text.PariPari.Internal.Class+import Text.PariPari.Internal.ElementCombinators ((<?>))+import Data.Text (Text)+import Data.Functor (void)+import Data.Word (Word8)+import qualified Data.Char as C++type CharP k a  = (forall p. CharParser k p => p a)++-- | Parse a digit byte for the given base.+-- Bases 2 to 36 are supported.+digitByte :: CharParser k p => Int -> p Word8+digitByte base = asciiSatisfy (isDigit base)+{-# INLINE digitByte #-}++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.Internal.Combinators.isDigit: Bases 2 to 36 are supported"+{-# INLINE isDigit #-}++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 :: CharParser k p => Int -> p Word+digit base = digitToInt base <$> asciiSatisfy (isDigit base)+{-# INLINE digit #-}++-- | 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, CharParser k 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, CharParser k 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 => CharP k a+decimal = integer (pure ()) 10+{-# INLINE decimal #-}++octal :: Num a => CharP k a+octal = integer (pure ()) 8+{-# INLINE octal #-}++hexadecimal :: Num a => CharP k a+hexadecimal = integer (pure ()) 16+{-# INLINE hexadecimal #-}++-- | Parse a number with a plus or minus sign.+signed :: (Num a, CharParser k p) => p a -> p a+signed p = ($) <$> ((id <$ asciiByte asc_plus) <|> (negate <$ asciiByte 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, CharParser k 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 $ asciiByte 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, CharParser k p) => p digitSep -> p (a, Int, a)+fractionDec sep = fraction (asciiSatisfy (\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, CharParser k p) => p digitSep -> p (a, Int, a)+fractionHex sep = fraction (asciiSatisfy (\b -> b == asc_P || b == asc_p)) 2 4 sep <?> "hexadecimal fraction"+{-# INLINE fractionHex #-}++-- | Parse a case-insensitive character+char' :: CharParser k p => Char -> p 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 :: CharParser k p => Char -> p Char+notChar c = satisfy (/= c)+{-# INLINE notChar #-}++-- | Parse an arbitrary character.+anyChar :: CharP k Char+anyChar = satisfy (const True)+{-# INLINE anyChar #-}++-- | Parse an alphanumeric character, including Unicode.+alphaNumChar :: CharP k Char+alphaNumChar = satisfy C.isAlphaNum <?> "alphanumeric character"+{-# INLINE alphaNumChar #-}++-- | Parse a letter character, including Unicode.+letterChar :: CharP k Char+letterChar = satisfy C.isLetter <?> "letter"+{-# INLINE letterChar #-}++-- | Parse a lowercase letter, including Unicode.+lowerChar :: CharP k Char+lowerChar = satisfy C.isLower <?> "lowercase letter"+{-# INLINE lowerChar #-}++-- | Parse a uppercase letter, including Unicode.+upperChar :: CharP k Char+upperChar = satisfy C.isUpper <?> "uppercase letter"+{-# INLINE upperChar #-}++-- | Parse a space character, including Unicode.+spaceChar :: CharP k Char+spaceChar = satisfy C.isSpace <?> "space"+{-# INLINE spaceChar #-}++-- | Parse a symbol character, including Unicode.+symbolChar :: CharP k Char+symbolChar = satisfy C.isSymbol <?> "symbol"+{-# INLINE symbolChar #-}++-- | Parse a punctuation character, including Unicode.+punctuationChar :: CharP k Char+punctuationChar = satisfy C.isPunctuation <?> "punctuation"+{-# INLINE punctuationChar #-}++-- | Parse a digit character of the given base.+-- Bases 2 to 36 are supported.+digitChar :: CharParser k p => Int -> p Char+digitChar base = unsafeAsciiToChar <$> digitByte base+{-# INLINE digitChar #-}++-- | Parse a character beloning to the ASCII charset (< 128)+asciiChar :: CharP k Char+asciiChar = unsafeAsciiToChar <$> asciiSatisfy (const True)+{-# INLINE asciiChar #-}++-- | Parse a character belonging to the given Unicode category+categoryChar :: CharParser k p => C.GeneralCategory -> p Char+categoryChar cat = satisfy ((== cat) . C.generalCategory) <?> untitle (show cat)+{-# INLINE categoryChar #-}++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++-- | Skip the next n characters+skipChars :: CharParser k p => Int -> p ()+skipChars n = skipCount n anyChar+{-# INLINE skipChars #-}++-- | Skip char while predicate is true+skipCharsWhile :: CharParser k p => (Char -> Bool) -> p ()+skipCharsWhile f = skipMany (satisfy f)+{-# INLINE skipCharsWhile #-}++-- | Skip at least one char while predicate is true+skipCharsWhile1 :: CharParser k p => (Char -> Bool) -> p ()+skipCharsWhile1 f = satisfy f *> skipCharsWhile f+{-# INLINE skipCharsWhile1 #-}++-- | Take the next n characters and advance the position by n characters+takeChars :: CharParser k p => Int -> p k+takeChars n = asChunk (skipChars n) <?> "string of length " <> show n+{-# INLINE takeChars #-}++-- | Take chars while predicate is true+takeCharsWhile :: CharParser k p => (Char -> Bool) -> p k+takeCharsWhile f = asChunk (skipCharsWhile f)+{-# INLINE takeCharsWhile #-}++-- | Take at least one byte while predicate is true+takeCharsWhile1 :: CharParser k p => (Char -> Bool) -> p k+takeCharsWhile1 f = asChunk (skipCharsWhile1 f)+{-# INLINE takeCharsWhile1 #-}++-- | Parse a string+string :: CharParser k p => Text -> p Text+string t = t <$ chunk (textToChunk t)+{-# INLINE string #-}

@@ -0,0 +1,280 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+module Text.PariPari.Internal.Chunk (+  Chunk(..)+  , CharChunk(..)+  , Pos(..)+  , showByte+  , showByteString+  , unsafeAsciiToChar+  , asc_0, asc_9, asc_A, asc_E, asc_P, asc_a, asc_e, asc_p,+    asc_minus, asc_plus, asc_point, asc_newline+) where++import Data.Bits (unsafeShiftL, (.|.), (.&.))+import Data.ByteString (ByteString)+import Data.Foldable (foldl')+import Data.String (fromString)+import Data.Text (Text)+import Data.Word (Word8)+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)+import Foreign.Ptr (plusPtr)+import Foreign.Storable (peekByteOff)+import GHC.Base (unsafeChr)+import GHC.Generics (Generic)+import GHC.Show (showLitChar)+import Numeric (showHex)+import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as B+import qualified Data.Text.Array as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Internal as T++-- | Line and column position starting at (1,1)+data Pos = Pos+  { _posLine   :: !Int+  , _posColumn :: !Int+  } deriving (Eq, Show, Generic)++class (Ord (Element k), Ord k) => Chunk k where+  type Element  k+  type Buffer   k+  elementAt :: Buffer k -> Int -> (Element k, Int)+  elementPos :: Element k -> Pos -> Pos+  chunkWidth :: k -> Int+  chunkEqual :: Buffer k -> Int -> k -> Bool+  packChunk :: Buffer k -> Int -> Int -> k+  unpackChunk :: k -> (Buffer k, Int, Int)+  showElement :: Element k -> String+  showChunk :: k -> String++class Chunk k => CharChunk k where+  byteAt :: Buffer k -> Int -> Word8+  charAt :: Buffer k -> Int -> (Char, Int)+  charAtFixed :: Int -> Buffer k -> Int -> Char+  charWidth :: Char -> Int+  textToChunk :: Text -> k++instance Chunk ByteString where+  type Element  ByteString = Word8+  type Buffer   ByteString = ForeignPtr Word8++  elementAt b i = (ptrByteAt b i, 1)+  {-# INLINE elementAt #-}++  elementPos e (Pos l c) =+    Pos (if e == asc_newline then l + 1 else l)+        (if e == asc_newline then 1 else c + 1)+  {-# INLINE elementPos #-}++  chunkWidth (B.PS _ _ n) = n+  {-# INLINE chunkWidth #-}++  chunkEqual b i (B.PS p j n) = ptrBytesEqual b i p j n+  {-# INLINE chunkEqual #-}++  packChunk b i n = B.PS b i n+  {-# INLINE packChunk #-}++  unpackChunk k =+    let (B.PS b i n) = k <> fromString "\0\0\0" -- sentinel+    in (b, i, n - 3)+  {-# INLINE unpackChunk #-}++  showElement = showByte+  showChunk = showByteString++instance CharChunk ByteString where+  byteAt = ptrByteAt+  {-# INLINE byteAt #-}++  charAt = ptrDecodeUtf8+  {-# INLINE charAt #-}++  charWidth = charWidthUtf8+  {-# INLINE charWidth #-}++  charAtFixed = ptrDecodeFixedUtf8+  {-# INLINE charAtFixed #-}++  textToChunk t = T.encodeUtf8 t+  {-# INLINE textToChunk #-}++instance Chunk Text where+  type Element  Text = Char+  type Buffer   Text = T.Array++  elementAt b i = arrayCharAt 2 b i+  {-# INLINE elementAt #-}++  elementPos e (Pos l c) =+    Pos (if e == '\n' then l + 1 else l)+        (if e == '\n' then 1 else c + 1)+  {-# INLINE elementPos #-}++  chunkWidth (T.Text _ _ n) = n+  {-# INLINE chunkWidth #-}++  chunkEqual b i (T.Text a j n) = T.equal b i a j n+  {-# INLINE chunkEqual #-}++  packChunk b i n = T.Text b i n+  {-# INLINE packChunk #-}++  unpackChunk k =+    let (T.Text b i n) = k <> fromString "\0" -- sentinel+    in (b, i, n - 1)+  {-# INLINE unpackChunk #-}++  showElement = show+  showChunk = show++instance CharChunk Text where+  byteAt = arrayByteAt+  {-# INLINE byteAt #-}++  charAt = arrayCharAt 2+  {-# INLINE charAt #-}++  charWidth = charWidthUtf16+  {-# INLINE charWidth #-}++  charAtFixed n b i = fst $ arrayCharAt n b i+  {-# INLINE charAtFixed #-}++  textToChunk t = t+  {-# INLINE textToChunk #-}++arrayByteAt :: T.Array -> Int -> Word8+arrayByteAt a i+  | c <- T.unsafeIndex a i, c <= 0xFF = fromIntegral c+  | otherwise = 0+{-# INLINE arrayByteAt #-}++arrayCharAt :: Int -> T.Array -> Int -> (Char, Int)+arrayCharAt 1 a i+  | c <- T.unsafeIndex a i, c < 0xD800 || c > 0xDFFF = (unsafeChr $ fromIntegral c, 1)+  | otherwise = ('\0', 0)+arrayCharAt _ a i+  | hi <- T.unsafeIndex a i, lo <- T.unsafeIndex a (i + 1) =+      if hi < 0xD800 || hi > 0xDFFF then+        (unsafeChr $ fromIntegral hi, 1)+      else+        (unsafeChr $ 0x10000 + ((fromIntegral $ hi - 0xD800) `unsafeShiftL` 10) + (fromIntegral lo - 0xDC00), 2)+{-# INLINE arrayCharAt #-}++ptrBytesEqual :: ForeignPtr Word8 -> Int -> ForeignPtr Word8 -> Int -> Int -> Bool+ptrBytesEqual p1 i1 p2 i2 n =+  B.accursedUnutterablePerformIO $+  withForeignPtr p1 $ \q1 ->+  withForeignPtr p2 $ \q2 ->+  (== 0) <$> B.memcmp (q1 `plusPtr` i1) (q2 `plusPtr` i2) n+{-# INLINE ptrBytesEqual #-}++ptrByteAt :: ForeignPtr Word8 -> Int -> Word8+ptrByteAt p i = B.accursedUnutterablePerformIO $+  withForeignPtr p $ \q -> peekByteOff q i+{-# INLINE ptrByteAt #-}++at :: ForeignPtr Word8 -> Int -> Int+at p i = fromIntegral $ ptrByteAt p i+{-# INLINE at #-}++-- | Decode UTF-8 character at the given offset relative to the pointer+ptrDecodeUtf8 :: ForeignPtr Word8 -> Int -> (Char, Int)+ptrDecodeUtf8 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 ptrDecodeUtf8 #-}++-- | Decode UTF-8 character with fixed width at the given offset relative to the pointer+ptrDecodeFixedUtf8 :: Int -> ForeignPtr Word8 -> Int -> Char+ptrDecodeFixedUtf8 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 ptrDecodeFixedUtf8 #-}++charWidthUtf16 :: Char -> Int+charWidthUtf16 c | c <= unsafeChr 0xFFFF = 1+                 | otherwise = 2+{-# INLINE charWidthUtf16 #-}++-- | Bytes width of an UTF-8 character+charWidthUtf8 :: Char -> Int+charWidthUtf8 c | c <= unsafeChr 0x7F = 1+                | c <= unsafeChr 0x7FF = 2+                | c <= unsafeChr 0xFFFF = 3+                | otherwise = 4+{-# INLINE charWidthUtf8 #-}++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 . ('\'':) $ ""++showByteString :: ByteString -> String+showByteString b = ('"':) . bytesS b . ('"':) $ ""

@@ -0,0 +1,142 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FunctionalDependencies #-}+module Text.PariPari.Internal.Class (+  ChunkParser(..)+  , CharParser(..)+  , Alternative(..)+  , MonadPlus+  , Pos(..)+  , Error(..)+  , showError+  , expectedEnd+  , unexpectedEnd+) where++import Control.Applicative (Alternative(empty, (<|>)))+import Control.Monad (MonadPlus(..))+import Control.Monad.Fail (MonadFail(..))+import Data.List (intercalate)+import Data.Word (Word8)+import GHC.Generics (Generic)+import Text.PariPari.Internal.Chunk++-- | Parsing errors+data Error+  = EInvalidUtf8+  | EExpected         [String]+  | EUnexpected       String+  | EFail             String+  | ECombinator       String+  | EIndentNotAligned !Int !Int+  | EIndentOverLine   !Int !Int+  | ENotEnoughIndent  !Int !Int+  deriving (Eq, Ord, Show, Generic)++-- | Parser class, which specifies the necessary+-- primitives for parsing. All other parser combinators+-- rely on these primitives.+class (MonadFail p, MonadPlus p, Chunk k) => ChunkParser k p | p -> k 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 element+  element :: Element k -> p (Element k)++  -- | Parse a single byte with the given predicate+  elementSatisfy :: (Element k -> Bool) -> p (Element k)++  -- | Parse a chunk of elements. The chunk must not+  -- contain multiple lines, otherwise the position information+  -- will be invalid.+  chunk :: k -> p k++  -- | Run the given parser and return the+  -- result as buffer+  asChunk :: p () -> p k++class (ChunkParser k p, CharChunk k) => CharParser k p | p -> k where+  -- | Parse a single character+  --+  -- __Note__: The character '\0' cannot be parsed using this combinator+  -- since it is used as decoding sentinel. Use 'element' instead.+  char :: Char -> p Char++  -- | Parse a single character with the given predicate+  --+  -- __Note__: The character '\0' cannot be parsed using this combinator+  -- since it is used as decoding sentinel. Use 'elementSatisfy' instead.+  satisfy :: (Char -> Bool) -> p Char++  -- | Parse a single character within the ASCII charset+  --+  -- __Note__: The character '\0' cannot be parsed using this combinator+  -- since it is used as decoding sentinel. Use 'element' instead.+  asciiByte :: Word8 -> p Word8++  -- | Parse a single character within the ASCII charset with the given predicate+  --+  -- __Note__: The character '\0' cannot be parsed using this combinator+  -- since it is used as decoding sentinel. Use 'elementSatisfy' instead.+  asciiSatisfy :: (Word8 -> Bool) -> p Word8++-- | Pretty string representation of 'Error'+showError :: Error -> String+showError EInvalidUtf8             = "Invalid UTF-8 character found"+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++expectedEnd :: Error+expectedEnd = EExpected ["end of file"]++unexpectedEnd :: Error+unexpectedEnd = EUnexpected "end of file"

@@ -0,0 +1,184 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+module Text.PariPari.Internal.ElementCombinators (+  -- * Basic combinators+  void+  , (<|>)+  , empty++  -- * Control.Monad.Combinators.NonEmpty+  , ON.some+  , ON.endBy1+  , ON.someTill+  , ON.sepBy1+  , ON.sepEndBy1++  -- * Control.Monad.Combinators+  , O.optional -- dont use Applicative version for efficiency+  , 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+  , notElement+  , anyElement+  , takeElements+  , skipElements+  , skipElementsWhile+  , takeElementsWhile+  , skipElementsWhile1+  , takeElementsWhile1+) where++import Control.Applicative ((<|>), empty)+import Control.Monad (when)+import Control.Monad.Combinators (skipCount, skipMany)+import Data.Functor (void)+import Prelude hiding (getLine)+import Text.PariPari.Internal.Class+import Text.PariPari.Internal.Chunk+import qualified Control.Monad.Combinators as O+import qualified Control.Monad.Combinators.NonEmpty as ON++type ChunkP k a = (forall p. ChunkParser k p => p a)++-- | Infix alias for 'label'+(<?>) :: ChunkParser k p => p a -> String -> p a+(<?>) = flip label+{-# INLINE (<?>) #-}+infix 0 <?>++-- | Get line number of the reference position+getRefLine :: ChunkP k Int+getRefLine = _posLine <$> getRefPos+{-# INLINE getRefLine #-}++-- | Get column number of the reference position+getRefColumn :: ChunkP k Int+getRefColumn = _posColumn <$> getRefPos+{-# INLINE getRefColumn #-}++-- | Get current line number+getLine :: ChunkP k Int+getLine = _posLine <$> getPos+{-# INLINE getLine #-}++-- | Get current column+getColumn :: ChunkP k Int+getColumn = _posColumn <$> getPos+{-# INLINE getColumn #-}++-- | Decorate the parser result with the current position+withPos :: ChunkParser k 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 :: ChunkParser k 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 :: ChunkP k ()+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 :: ChunkP k ()+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 :: ChunkP k ()+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 :: ChunkP k ()+linefold = line <|> indented+{-# INLINE linefold #-}++-- | Parser a single byte different from the given one+notElement :: forall k p. ChunkParser k p => Element k -> p (Element k)+notElement e = elementSatisfy @k (/= e) <?> "not " <> showElement @k e+{-# INLINE notElement #-}++-- | Parse an arbitrary byte+anyElement :: ChunkP k (Element k)+anyElement = elementSatisfy (const True)+{-# INLINE anyElement #-}++-- | Skip the next n elements+skipElements :: ChunkParser k p => Int -> p ()+skipElements n = skipCount n anyElement+{-# INLINE skipElements #-}++-- | Take the next n elements and advance the position by n+takeElements :: ChunkParser k p => Int -> p k+takeElements n = asChunk (skipElements n) <?> show n <> " elements"+{-# INLINE takeElements #-}++-- | Skip elements while predicate is true+skipElementsWhile :: ChunkParser k p => (Element k -> Bool) -> p ()+skipElementsWhile f = skipMany (elementSatisfy f)+{-# INLINE skipElementsWhile #-}++-- | Takes elements while predicate is true+takeElementsWhile :: ChunkParser k p => (Element k -> Bool) -> p k+takeElementsWhile f = asChunk (skipElementsWhile f)+{-# INLINE takeElementsWhile #-}++-- | Skip at least one element while predicate is true+skipElementsWhile1 :: ChunkParser k p => (Element k -> Bool) -> p ()+skipElementsWhile1 f = elementSatisfy f *> skipElementsWhile f+{-# INLINE skipElementsWhile1 #-}++-- | Take at least one element while predicate is true+takeElementsWhile1 :: ChunkParser k p => (Element k -> Bool) -> p k+takeElementsWhile1 f = asChunk (skipElementsWhile1 f)+{-# INLINE takeElementsWhile1 #-}

@@ -0,0 +1,447 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+module Text.PariPari.Internal.Reporter (+  Reporter(..)+  , Env(..)+  , State(..)+  , local+  , get+  , raiseError+  , mergeErrorState+  , Report(..)+  , runReporter+  , runReporterWithOptions+  , ErrorContext(..)+  , showReport+  , showErrors+  , ReportOptions(..)+  , defaultReportOptions+) where++import Control.Monad (void)+import Data.Function (on)+import Data.List (intercalate, sort, group, sortOn)+import Data.List.NonEmpty (NonEmpty(..))+import GHC.Generics (Generic)+import Text.PariPari.Internal.Chunk+import Text.PariPari.Internal.Class+import qualified Control.Monad.Fail as Fail+import qualified Data.List.NonEmpty as NE++data ErrorContext = ErrorContext+  { _ecErrors  :: [Error]+  , _ecContext :: [String]+  } deriving (Eq, Show, Generic)++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 k = Env+  { _envBuf     :: !(Buffer k)+  , _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 optimised for good error reports.+-- Performance is secondary, since the 'Reporter' is used+-- as a fallback to the 'Acceptor'.+newtype Reporter k a = Reporter+  { unReporter :: forall b. Env k -> State+               -> (a     -> State -> b)+               -> (State -> b)+               -> b+  }++instance (Chunk k, Semigroup a) => Semigroup (Reporter k a) where+  p1 <> p2 = (<>) <$> p1 <*> p2+  {-# INLINE (<>) #-}++instance (Chunk k, Monoid a) => Monoid (Reporter k a) where+  mempty = pure mempty+  {-# INLINE mempty #-}++instance Chunk k => Functor (Reporter k) where+  fmap f p = Reporter $ \env st ok err ->+    unReporter p env st (ok . f) err+  {-# INLINE fmap #-}++instance Chunk k => Applicative (Reporter k) 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 Chunk k => Alternative (Reporter k) where+  empty = Reporter $ \_ st _ err -> err st+  {-# INLINE empty #-}++  p1 <|> p2 = Reporter $ \env st ok err ->+    let err' s = unReporter p2 env (mergeErrorState env st s) ok err+    in unReporter p1 env st ok err'+  {-# INLINE (<|>) #-}++instance Chunk k => MonadPlus (Reporter k)++instance Chunk k => Monad (Reporter k) 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 Chunk k => Fail.MonadFail (Reporter k) where+  fail msg = failWith $ EFail msg+  {-# INLINE fail #-}++instance Chunk k => ChunkParser k (Reporter k) 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 expectedEnd+  {-# INLINE eof #-}++  element e = Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err ->+    if | _stOff < _envEnd env,+         (e', w) <- elementAt @k (_envBuf env) _stOff,+         e == e',+         pos <- elementPos @k e (Pos _stLine _stCol) ->+           ok e st { _stOff =_stOff + w, _stLine = _posLine pos, _stCol = _posColumn pos }+       | otherwise ->+           raiseError env st err $ EExpected [showElement @k e]+  {-# INLINE element #-}++  elementSatisfy f = Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err ->+    let (e, w) = elementAt @k (_envBuf env) _stOff+    in if | _stOff >= _envEnd env ->+              raiseError env st err unexpectedEnd+          | _stOff < _envEnd env,+            f e,+            pos <- elementPos @k e (Pos _stLine _stCol) ->+              ok e st { _stOff =_stOff + w, _stLine = _posLine pos, _stCol = _posColumn pos }+          | otherwise ->+              raiseError env st err $ EUnexpected $ showElement @k e+  {-# INLINE elementSatisfy #-}++  chunk k = Reporter $ \env st@State{_stOff,_stCol} ok err ->+    let n = chunkWidth @k k+    in if n + _stOff <= _envEnd env &&+          chunkEqual @k (_envBuf env) _stOff k then+         ok k st { _stOff = _stOff + n, _stCol = _stCol + n }+       else+         raiseError env st err $ EExpected [showChunk @k k]+  {-# INLINE chunk #-}++  asChunk p = do+    begin <- get (const _stOff)+    p+    end <- get (const _stOff)+    src <- get (\env _ -> _envBuf env)+    pure $ packChunk src begin (end - begin)+  {-# INLINE asChunk #-}++instance CharChunk k => CharParser k (Reporter k) where+  satisfy f = Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err ->+    if | (c, w) <- charAt @k (_envBuf env) _stOff,+         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+       | _stOff >= _envEnd env ->+           raiseError env st err unexpectedEnd+       | otherwise ->+           raiseError env st err EInvalidUtf8+  {-# INLINE satisfy #-}++  -- By inling this combinator, GHC should figure out the `charWidth`+  -- of the character resulting in an optimised decoder.+  char '\0' = error "Character '\\0' cannot be parsed because it is used as sentinel"+  char c+    | w <- charWidth @k c =+        Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err ->+        if charAtFixed @k w (_envBuf 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 #-}++  asciiSatisfy f = Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err ->+    let b = byteAt @k (_envBuf env) _stOff+    in if | b /= 0,+            b < 128,+            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+              }+          | _stOff >= _envEnd env ->+              raiseError env st err unexpectedEnd+          | otherwise ->+              raiseError env st err $ EUnexpected $ showByte b+  {-# INLINE asciiSatisfy #-}++  asciiByte 0 = error "Character '\\0' cannot be parsed because it is used as sentinel"+  asciiByte b+    | b >= 128 = error "Not an ASCII character"+    | otherwise = Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err ->+        if byteAt @k (_envBuf env) _stOff == b then+          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+          }+        else+          raiseError env st err $ EExpected [showByte b]+  {-# INLINE asciiByte #-}++raiseError :: Env k -> 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 k -> Env k) -> Reporter k a -> Reporter k 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 k -> State -> a) -> Reporter k a+get f = Reporter $ \env st ok _ -> ok (f env st) st+{-# INLINE get #-}++addLabel :: String -> Env k -> Env k+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 k -> 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 k -> Error -> Maybe ErrorContext+mkError env e+  | _envHidden env, (l:ls) <- _envContext env = Just $ ErrorContext [EExpected [l]] ls+  | _envHidden env = Nothing+  | otherwise = Just $ ErrorContext [e] $ _envContext env+{-# INLINE mkError #-}++-- | Merge errors of two states, used when backtracking+mergeErrorState :: Env k -> State -> State -> State+mergeErrorState 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 mergeErrorState #-}++groupOn :: Eq e => (a -> e) -> [a] -> [NonEmpty a]+groupOn f = NE.groupBy ((==) `on` f)++shrinkErrors :: Env k -> [ErrorContext] -> [ErrorContext]+shrinkErrors env = take (_optMaxContexts._envOptions $ env) . map (mergeErrorContexts env) . groupOn _ecContext . sortOn _ecContext++-- | Shrink error context by deleting duplicates+-- and merging errors if possible.+mergeErrorContexts :: Env k -> NonEmpty ErrorContext -> ErrorContext+mergeErrorContexts env es@(ErrorContext{_ecContext}:| _) = ErrorContext+  { _ecErrors = take (_optMaxErrorsPerContext._envOptions $ env) $ nubSort $ mergeEExpected $ concatMap _ecErrors $ NE.toList es+  , _ecContext = _ecContext+  }++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 _ = []++defaultReportOptions :: ReportOptions+defaultReportOptions = ReportOptions+  { _optMaxContexts         = 20+  , _optMaxErrorsPerContext = 20+  , _optMaxLabelsPerContext = 5+  }++-- | Run 'Reporter' with additional 'ReportOptions'.+runReporterWithOptions :: Chunk k => ReportOptions -> Reporter k a -> FilePath -> k -> Either Report a+runReporterWithOptions o p f k =+  let (b, off, len) = unpackChunk k+  in unReporter p (initialEnv o f b (off + len)) (initialState off) (\x _ -> Right x) (Left . getReport f)++-- | Run 'Reporter' on the given 'ByteString', returning either+-- an error 'Report' or, if successful, the result.+runReporter :: Chunk k => Reporter k a -> FilePath -> k -> Either Report a+runReporter = runReporterWithOptions defaultReportOptions++getReport :: FilePath -> State -> Report+getReport f s = Report f (_stErrLine s) (_stErrCol s) (_stErrors s)++initialEnv :: ReportOptions -> FilePath -> Buffer k -> Int -> Env k+initialEnv _envOptions _envFile _envBuf _envEnd = Env+  { _envFile+  , _envBuf+  , _envOptions+  , _envEnd+  , _envContext = []+  , _envHidden  = False+  , _envCommit  = 0+  , _envRefLine = 1+  , _envRefCol  = 1+  }++initialState :: Int -> State+initialState _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 ec =+  intercalate ", " (map showError $ _ecErrors ec)+  <> showContext (_ecContext ec) <> "."++showContext :: [String] -> String+showContext [] = ""+showContext xs = " in context of " <> intercalate ", " xs

@@ -0,0 +1,89 @@+{-# LANGUAGE Rank2Types #-}+module Text.PariPari.Internal.Run (+  runCharParser+  , runSeqCharParser+  , runCharParserWithOptions+  , runSeqCharParserWithOptions+  , runChunkParser+  , runSeqChunkParser+  , runChunkParserWithOptions+  , runSeqChunkParserWithOptions+) where++import Text.PariPari.Internal.Acceptor+import Text.PariPari.Internal.Class+import Text.PariPari.Internal.Chunk+import Text.PariPari.Internal.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.+runCharParser :: CharChunk k => (forall p. CharParser k p => p a) -> FilePath -> k -> Either Report a+runCharParser = runCharParserWithOptions defaultReportOptions+{-# INLINE runCharParser #-}++-- | 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.+runSeqCharParser :: CharChunk k => (forall p. CharParser k p => p a) -> FilePath -> k -> Either Report a+runSeqCharParser = runSeqCharParserWithOptions defaultReportOptions+{-# INLINE runSeqCharParser #-}++-- | Run parsers **in parallel** with additional 'ReportOptions'.+runCharParserWithOptions :: CharChunk k => ReportOptions -> (forall p. CharParser k p => p a) -> FilePath -> k -> Either Report a+runCharParserWithOptions 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 runCharParserWithOptions #-}++-- | Run parsers **sequentially** with additional 'ReportOptions'.+runSeqCharParserWithOptions :: CharChunk k => ReportOptions -> (forall p. CharParser k p => p a) -> FilePath -> k -> Either Report a+runSeqCharParserWithOptions 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 runSeqCharParserWithOptions #-}++-- | 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.+runChunkParser :: CharChunk k => (forall p. ChunkParser k p => p a) -> FilePath -> k -> Either Report a+runChunkParser = runCharParserWithOptions defaultReportOptions+{-# INLINE runChunkParser #-}++-- | 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.+runSeqChunkParser :: Chunk k => (forall p. ChunkParser k p => p a) -> FilePath -> k -> Either Report a+runSeqChunkParser = runSeqChunkParserWithOptions defaultReportOptions+{-# INLINE runSeqChunkParser #-}++-- | Run parsers **in parallel** with additional 'ReportOptions'.+runChunkParserWithOptions :: Chunk k => ReportOptions -> (forall p. ChunkParser k p => p a) -> FilePath -> k -> Either Report a+runChunkParserWithOptions 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 runChunkParserWithOptions #-}++-- | Run parsers **sequentially** with additional 'ReportOptions'.+runSeqChunkParserWithOptions :: Chunk k => ReportOptions -> (forall p. ChunkParser k p => p a) -> FilePath -> k -> Either Report a+runSeqChunkParserWithOptions 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 runSeqChunkParserWithOptions #-}

@@ -0,0 +1,43 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+module Text.PariPari.Internal.Tracer (+  Tracer(..)+  , runTracer+) where++import Debug.Trace (trace)+import Text.PariPari.Internal.Class+import Text.PariPari.Internal.Chunk+import Text.PariPari.Internal.Reporter+import qualified Control.Monad.Fail as Fail++-- | Parser which prints trace messages, when backtracking occurs.+newtype Tracer k a = Tracer { unTracer :: Reporter k a }+  deriving (Semigroup, Monoid, Functor, Applicative, MonadPlus, Monad, Fail.MonadFail)++deriving instance CharChunk k => ChunkParser k (Tracer k)+deriving instance CharChunk k => CharParser k (Tracer k)++instance Chunk k => Alternative (Tracer k) 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 (mergeErrorState env st s) ok err+          in if width > 1 then+               trace ("Backtracking " <> show width <> " bytes at line " <> show (_stLine s)+                       <> ", column " <> show (_stCol s) <> ", context " <> show (_envContext env) <> ": "+                       <> showChunk (packChunk @k (_envBuf 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 :: Chunk k => Tracer k a -> FilePath -> k -> Either Report a+runTracer = runReporter . unTracer

@@ -1,421 +0,0 @@-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

@@ -0,0 +1,492 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleContexts #-}+module Main (main) where++import Data.ByteString (ByteString)+import Data.Either (isLeft)+import Data.Text (Text)+import GHC.Stack (HasCallStack)+import Prelude hiding (getLine)+import Test.Tasty+import Test.Tasty.HUnit+import Text.PariPari+import Text.PariPari.Internal.Chunk (textToChunk, asc_a, asc_0, asc_9)+import qualified Data.Char as C+import qualified Data.List.NonEmpty as NE++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests"+  [ testGroup "Chunk"+    [ testGroup "Acceptor" $ chunkTests runAcceptor+    , testGroup "Reporter" $ chunkTests runAcceptor+    ]++  , testGroup "Char"+    [ testGroup "Acceptor"+      [ testGroup "Text"       $ charTests @Text       runAcceptor+      , testGroup "ByteString" $ charTests @ByteString runAcceptor+      ]++    , testGroup "Reporter"+      [ testGroup "Text"       $ charTests @Text       runReporter+      , testGroup "ByteString" $ charTests @ByteString runReporter+      ]+    ]+  ]++charTests :: forall k p e. (CharParser k p, CharChunk k, Eq e, Show e)+          => (forall a. p a -> FilePath -> k -> Either e a) -> [TestTree]+charTests run =+  [ testGroup "CharParser" $+    [ testCase "satisfy" $ do+        ok (satisfy (== 'a')) "abc" 'a'+        ok (satisfy (== 'a') <* eof) "a" 'a'+        err (satisfy (== 'b')) "abc"+        err (satisfy (== 'a')) ""++        -- because of sentinel+        err (satisfy (== '\0')) "\0"+        err (satisfy (== '\0')) ""++    , testCase "char" $ do+        ok (char 'a') "abc" 'a'+        ok (char 'a' <* eof) "a" 'a'+        err (char 'b') "abc"+        err (char 'a') ""++    , testCase "asciiSatisfy" $ do+        ok (asciiSatisfy (== asc_a)) "abc" asc_a+        ok (asciiSatisfy (== asc_a) <* eof) "a" asc_a+        err (asciiSatisfy (== asc_0)) "abc"+        err (asciiSatisfy (== asc_0)) ""++        -- because of sentinel+        err (asciiSatisfy (== 0)) "\0"+        err (asciiSatisfy (== 0)) ""++    , testCase "asciiByte" $ do+        ok (asciiByte asc_a) "abc" asc_a+        ok (asciiByte asc_a <* eof) "a" asc_a+        ok (asciiByte 127 <* eof) "\x7F" 127+        err (asciiByte asc_0) "abc"+        err (asciiByte asc_0) ""+    ]++  , testGroup "Char Combinators"+    [ testCase "string" $ do+        ok (string "ab") "abc" "ab"+        err (string "bc") "abc"+        err (string "ab") ""++    , testCase "anyChar" $ do+        ok anyChar "abc" 'a'+        ok (anyChar <* eof) "a" 'a'+        err anyChar ""++    , testCase "notChar" $ do+        ok (notChar 'b') "abc" 'a'+        ok (notChar 'b' <* eof) "a" 'a'+        err (notChar 'a') "a"+        err (notChar 'a') ""++    , testCase "char'" $ do+        ok (char' 'a') "a" 'a'+        ok (char' 'a' <* eof) "a" 'a'+        ok (char' 'a') "A" 'A'+        ok (char' 'A') "a" 'a'+        ok (char' 'A') "A" 'A'+        ok (char' '9') "9" '9'+        err (char' 'a') "b"+        err (char' 'a') ""++    , testCase "alphaNumChar" $ do+        ok (alphaNumChar <* eof) "a" 'a'+        ok alphaNumChar "9" '9'+        err alphaNumChar "_"+        err alphaNumChar ""++    , testCase "digitChar" $ do+        ok (digitChar 10 <* eof) "9" '9'+        ok (digitChar 36) "z" 'z'+        err (digitChar 2) "2"+        err (digitChar 2) ""++    , testCase "letterChar" $ do+        ok (letterChar <* eof) "a" 'a'+        err letterChar "9"+        err letterChar "_"+        err letterChar ""++    , testCase "lowerChar" $ do+        ok (lowerChar <* eof) "a" 'a'+        err lowerChar "A"+        err lowerChar "9"+        err lowerChar "_"+        err lowerChar ""++    , testCase "upperChar" $ do+        ok (upperChar <* eof) "A" 'A'+        err upperChar "a"+        err upperChar "9"+        err upperChar "_"+        err upperChar ""++    , testCase "symbolChar" $ do+        ok (symbolChar <* eof) "+" '+'+        err symbolChar "a"+        err symbolChar "."+        err symbolChar ""++    , testCase "punctuationChar" $ do+        ok (punctuationChar <* eof) "." '.'+        err punctuationChar "+"+        err punctuationChar "a"+        err punctuationChar ""++    , testCase "spaceChar" $ do+        ok (spaceChar <* eof) " " ' '+        ok (spaceChar <* eof) "\n" '\n'+        ok (spaceChar <* eof) "\r" '\r'+        ok (spaceChar <* eof) "\t" '\t'+        err spaceChar "a"+        err spaceChar ""++    , testCase "asciiChar" $ do+        ok (asciiChar <* eof) "a" 'a'+        ok (asciiChar <* eof) "\x7F" '\x7F'+        err asciiChar "\x80"+        err asciiChar ""++    , testCase "categoryChar" $ do+        ok (categoryChar C.UppercaseLetter <* eof) "A" 'A'+        err (categoryChar C.UppercaseLetter) "a"+        err (categoryChar C.UppercaseLetter) ""++    , testCase "digitByte" $ do+        ok (digitByte 2 <* eof) "0" asc_0+        ok (digitByte 10 <* eof) "9" asc_9+        err (digitByte 10) "\0"+        err (digitByte 10) ""+    ]++  , testGroup "Integer Combinators"+    [ testCase "decimal" $ do+        ok @Integer (decimal <* eof) "0123" 123+        ok @Integer (decimal <* eof) "1234567890" 1234567890+        ok @Integer (decimal <* string "abc" <* eof) "123abc" 123+        err @Integer decimal "abc"+        err @Integer decimal "-1"+        err @Integer decimal ""++    , testCase "octal" $ do+        ok @Integer (octal <* eof) "0123" 0o123+        ok @Integer (octal <* eof) "12345670" 0o12345670+        ok @Integer (octal <* string "abc" <* eof) "123abc" 0o123+        err @Integer octal "8abc"+        err @Integer octal "-1"+        err @Integer octal ""++    , testCase "hexadecimal" $ do+        ok @Integer (hexadecimal <* eof) "0123" 0x123+        ok @Integer (hexadecimal <* eof) "123456789aBcDeF0" 0x123456789ABCDEF0+        ok @Integer (hexadecimal <* string "xyz" <* eof) "123xyz" 0x123+        err @Integer hexadecimal "gabc"+        err @Integer hexadecimal "-1"+        err @Integer hexadecimal ""++    , testCase "integer" $ do+        err @Integer (integer (pure ()) 10) "abc"+        ok @Integer (integer (char '_') 10) "1_2_3" 123+        ok @Integer (integer (char '_') 10 <* char '_') "1_2_3_" 123+        err @Integer (integer (char '_') 10) "_1_2_3"+        ok @Integer (integer (optional $ char '_') 10) "123_456_789" 123456789+        err @Integer (integer (pure ()) 10) "-1"+        err @Integer (integer (pure ()) 10) ""++        ok @Integer (integer (pure ()) 2) "101" 5+        ok @Integer (integer (pure ()) 7) "321" 162+        ok @Integer (integer (pure ()) 36) "XyZ" 44027++    , testCase "integer'" $ do+        err @(Integer, Int) (integer' (pure ()) 10) "abc"+        ok @(Integer, Int) (integer' (char '_') 10) "1_2_3" (123, 3)+        ok @(Integer, Int) (integer' (char '_') 10 <* char '_') "1_2_3_" (123, 3)+        err @(Integer, Int) (integer' (char '_') 10) "_1_2_3"+        ok @(Integer, Int) (integer' (optional $ char '_') 10) "123_456_789" (123456789, 9)+        err @(Integer, Int) (integer' (pure ()) 10) "-1"+        err @(Integer, Int) (integer' (pure ()) 10) ""++        ok @(Integer, Int) (integer' (pure ()) 2) "101" (5, 3)+        ok @(Integer, Int) (integer' (pure ()) 7) "321" (162, 3)+        ok @(Integer, Int) (integer' (pure ()) 36) "XyZ" (44027, 3)++    , testCase "signed" $ do+        ok @Integer (signed decimal) "-123" (-123)+        ok @Integer (signed decimal) "+123" 123+        err @Integer (signed decimal) "- 123"+        err @Integer (signed decimal) "+ 123"+        err @Integer (signed decimal) ""++    , testCase "digit" $ do+        ok (digit 2) "1" 1+        ok (digit 10) "7" 7+        ok (digit 36) "Z" 35+        err (digit 10) "a"+        err (digit 10) ""+    ]+  ]+  where+  ok :: (Eq a, Show a, HasCallStack) => p a -> Text -> a -> Assertion+  ok p i o = run p "filename" (textToChunk @k i) @?= Right o+  err :: (Eq a, Show a, HasCallStack) => p a -> Text -> Assertion+  err p i = assertBool "err" $ isLeft $ run p "filename" (textToChunk @k i)++chunkTests :: forall p e. (ChunkParser Text p, Eq e, Show e)+          => (forall a. p a -> FilePath -> Text -> Either e a) -> [TestTree]+chunkTests run =+  [ testGroup "ChunkParser"+    [ testCase "getFile" $ do+        ok getFile "" "filename"++    , testCase "getPos" $ do+        ok getPos "" (Pos 1 1)+        ok (element 'a' *> getPos) "abc" (Pos 1 2)+        ok (element 'a' *> element '\n' *> getPos) "a\nb" (Pos 2 1)+        ok (chunk "a\n" *> getPos) "a\nb" (Pos 1 3) -- chunk must not contain newlines!+        ok (element 'a' *> element '\n' *> element 'b' *> getPos) "a\nb" (Pos 2 2)++    , testCase "getRefPos" $ do+        ok getRefPos "" (Pos 1 1)+        ok (element 'a' *> getRefPos) "abc" (Pos 1 1)+        ok (element 'a' *> element '\n' *> withRefPos getRefPos) "a\nb" (Pos 2 1)+        ok (element 'a' *> element '\n' *> element 'b' *> withRefPos getRefPos) "a\nb" (Pos 2 2)+        ok (element 'a' *> element '\n' *> withRefPos (element 'b' *> getRefPos)) "a\nb" (Pos 2 1)++    , testCase "notFollowedBy" $ do+        ok (element 'a' <* notFollowedBy (element 'c')) "abc" 'a'+        err (element 'a' <* notFollowedBy (element 'b')) "abc"+        ok (element 'a' *> notFollowedBy (chunk "bd") *> element 'b') "abc" 'b'+        err (element 'a' *> notFollowedBy (chunk "bc")) "abc"+        ok (element 'a' *> notFollowedBy (element 'c') *> getPos) "abc" (Pos 1 2)++    , testCase "lookAhead" $ do+        ok (lookAhead (element 'a')) "abc" 'a'+        ok (lookAhead (element 'a') *> getPos) "abc" (Pos 1 1)+        ok (lookAhead (chunk "ab") *> getPos) "abc" (Pos 1 1)+        err (lookAhead (element 'b')) "abc"+        err (lookAhead (chunk "bd")) "abc"+        err (lookAhead (element 'a')) ""++    , testCase "failWith" $+        err (failWith (ECombinator "empty") :: p ()) "abc"++    , testCase "eof" $ do+        ok eof "" ()+        ok (chunk "abc" *> eof) "abc" ()+        err eof "abc"+        err eof "\0"+        err (chunk "ab" *> eof) "abc"++    , testCase "label" $ do+        ok (label "blub" $ element 'a') "abc" 'a'+        err (label "blub" $ element 'b') "abc"+        ok (element 'a' <?> "blub") "abc" 'a'++    , testCase "hidden" $ do+        ok (hidden $ element 'a') "abc" 'a'+        err (hidden $ element 'b') "abc"++    , testCase "commit" $ do+        ok (commit $ element 'a') "abc" 'a'+        err (commit $ element 'b') "abc"++    , testCase "elementSatisfy" $ do+        ok (elementSatisfy (== 'a')) "abc" 'a'+        ok (elementSatisfy (== 'a') <* eof) "a" 'a'+        err (elementSatisfy (== 'b')) "abc"+        err (elementSatisfy (== 'a')) ""++        -- sentinel+        ok (elementSatisfy (== '\0')) "\0" '\0'+        ok (elementSatisfy (== '\0') <* eof) "\0" '\0'+        err (elementSatisfy (== '\0')) ""++    , testCase "element" $ do+        ok (element 'a') "abc" 'a'+        ok (element 'a' <* eof) "a" 'a'+        err (element 'b') "abc"+        err (element 'a') ""++        -- sentinel+        ok (element '\0') "\0" '\0'+        ok (element '\0' <* eof) "\0" '\0'+        err (element '\0') ""++    , testCase "chunk" $ do+        ok (chunk "ab") "abc" "ab"+        err (chunk "bc") "abc"+        err (chunk "ab") ""++    , testCase "asChunk" $ do+        ok (asChunk (void $ chunk "ab")) "abc" "ab"+        ok (asChunk (void $ anyElement *> anyElement)) "abc" "ab"+        ok (asChunk (skipCount 2 anyElement)) "abc" "ab"+        err (asChunk (void $ chunk "bc")) "abc"+        err (asChunk (void $ chunk "ab")) ""+    ]++  , testGroup "Position Combinators"+    [ testCase "getLine" $ do+        ok getLine "" 1+        ok (element 'a' *> getLine) "abc" 1+        ok (element 'a' *> element '\n' *> getLine) "a\nb" 2+        ok (element 'a' *> element '\n' *> element 'b' *> getLine) "a\nb" 2++    , testCase "getRefLine" $ do+        ok getRefLine "" 1+        ok (element 'a' *> getRefLine) "abc" 1+        ok (element 'a' *> element '\n' *> withRefPos getRefLine) "a\nb" 2+        ok (element 'a' *> element '\n' *> element 'b' *> withRefPos getRefLine) "a\nb" 2+        ok (element 'a' *> element '\n' *> withRefPos (element 'b' *> getRefLine)) "a\nb" 2++    , testCase "getColumn" $ do+        ok getColumn "" 1+        ok (element 'a' *> getColumn) "abc" 2+        ok (element 'a' *> element '\n' *> getColumn) "a\nb" 1+        ok (element 'a' *> element '\n' *> element 'b' *> getColumn) "a\nb" 2++    , testCase "getRefColumn" $ do+        ok getRefColumn "" 1+        ok (element 'a' *> getRefColumn) "abc" 1+        ok (element 'a' *> element '\n' *> withRefPos getRefColumn) "a\nb" 1+        ok (element 'a' *> element '\n' *> element 'b' *> withRefPos getRefColumn) "a\nb" 2+        ok (element 'a' *> element '\n' *> withRefPos (element 'b' *> getRefColumn)) "a\nb" 1++    , testCase "withPos" $ do+        ok (withPos $ element 'a') "abc" (Pos 1 1, 'a')+        ok (element 'a' *> withPos (element 'b')) "abc" (Pos 1 2, 'b')+        ok (element 'a' *> element '\n' *> withPos (element 'b')) "a\nb" (Pos 2 1, 'b')++    , testCase "withSpan" $ do+        ok (withSpan $ chunk "ab") "abc" ((Pos 1 1, Pos 1 3), "ab")+        ok (element 'a' *> withSpan (chunk "bcd")) "abcde" ((Pos 1 2, Pos 1 5), "bcd")+        ok (element 'a' *> element '\n' *> withSpan (chunk "bcd")) "a\nbcde" ((Pos 2 1, Pos 2 4), "bcd")+    ]++  , testGroup "Element Combinators"+    [ testCase "anyElement" $ do+        ok anyElement "abc" 'a'+        err anyElement ""++    , testCase "notElement" $ do+        ok (notElement 'b') "abc" 'a'+        err (notElement 'a') "a"+        err (notElement 'a') ""+    ]++  , testGroup "MonadFail"+    [ testCase "fail" $ do+        err (failWith (ECombinator "empty") :: p ()) "abc"+    ]++  , testGroup "Alternative"+    [ testCase "(<|>)" $ do+        ok (element 'b' <|> element 'a' <|> element 'c') "abc" 'a'+        ok (chunk "abd" <|> chunk "abc" <|> chunk "abe") "abcdef" "abc"++    , testCase "empty" $ do+        err (empty :: p ()) "abc"+        err (empty :: p ()) ""+    ]++  , testGroup "Basic Combinators"+    [ testCase "optional" $ do+        ok (optional (element 'a')) "abc" (Just 'a')+        ok (optional (element 'b')) "abc" Nothing+        ok (optional (element 'a')) "" Nothing++    , testCase "some" $ do+        ok (some (element 'a')) "abc" (NE.fromList "a")+        ok (some (element 'a')) "aabc" (NE.fromList "aa")+        err (some (element 'b')) "abc"+        err (some (element 'a')) ""++    , testCase "many" $ do+        ok (many (element 'a')) "abc" "a"+        ok (many (element 'a')) "aabc" "aa"+        ok (many (element 'b')) "abc" ""+        ok (many (element 'a')) "" ""+    ]+  ]+  where+  ok :: (Eq a, Show a, HasCallStack) => p a -> Text -> a -> Assertion+  ok p i o = run p "filename" i @?= Right o+  err :: (Eq a, Show a, HasCallStack) => p a -> Text -> Assertion+  err p i = assertBool "err" $ isLeft $ run p "filename" i+++{-++Semigroup+Monoid+Functor+Applicative+Monad+MonadPlus+Alternative:++TODO:++Additional combinators:+endBy1+someTill+sepBy1+sepEndBy1+between+choice+count+count'+eitherP+endBy+manyTill+option+sepBy+sepEndBy+skipMany+skipSome+skipCount+skipManyTill+skipSomeTill++Identation:+align+indented+line+linefold++Fraction:+fractionHex+fractionDec++Char Combinators:+skipChars+takeChars+skipCharsWhile+takeCharsWhile+skipCharsWhile1+takeCharsWhile1++Element Combinators:+takeElements+skipElements+skipElementsWhile+takeElementsWhile+skipElementsWhile1+takeElementsWhile1+-}