paripari 0.6.0.1 → 0.7.0.0

raw patch · 15 files changed

+1059/−1490 lines, 15 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• example.hs +17/−19
• paripari.cabal +6/−15
• specialise-all.hs +18/−19
• src/Text/PariPari.hs +7/−21
• src/Text/PariPari/Internal/Acceptor.hs +127/−139
• src/Text/PariPari/Internal/CharCombinators.hs +0/−320
• src/Text/PariPari/Internal/Chunk.hs +123/−186
• src/Text/PariPari/Internal/Class.hs +20/−35
• src/Text/PariPari/Internal/Combinators.hs +445/−0
• src/Text/PariPari/Internal/ElementCombinators.hs +0/−202
• src/Text/PariPari/Internal/Reporter.hs +103/−137
• src/Text/PariPari/Internal/Run.hs +11/−72
• src/Text/PariPari/Internal/Tracer.hs +0/−48
• src/Text/PariPari/Lens.hs +8/−9
• test/test.hs +174/−268

@@ -9,14 +9,14 @@ 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)+type StringType = B.ByteString+type PMonad p = Parser StringType p+type P a = (forall p. PMonad 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 #-}+-- {-# SPECIALISE_ALL PMonad p = p ~ Acceptor StringType #-}+-- {-# SPECIALISE_ALL PMonad p = p ~ Reporter StringType #-}+-- {-# SPECIALISE_ALL P = Acceptor StringType #-}+-- {-# SPECIALISE_ALL P = Reporter StringType #-}  data Value   = Object ![(StringType, Value)]@@ -27,19 +27,19 @@   | Null   deriving (Eq, Show) -json :: Parser Value+json :: P Value json = space *> (object <|> array) <?> "json" -object :: Parser Value+object :: P Value object = Object <$> (char '{' *> space *> sepBy pair (space *> char ',' *> space) <* space <* char '}') <?> "object" -pair :: Parser (StringType, Value)+pair :: P (StringType, Value) pair = (,) <$> (text <* space) <*> (char ':' *> space *> value) -array :: Parser Value+array :: P Value array = Array <$> (char '[' *> sepBy value (space *> char ',' *> space) <* space <* char ']') <?> "array" -value :: Parser Value+value :: P Value value =   (String <$> text)     <|> object@@ -49,10 +49,10 @@     <|> (Null       <$ string "null")     <|> number -text :: Parser StringType+text :: P StringType text = char '"' *> takeCharsWhile (/= '"') <* char '"' <?> "text" -number :: Parser Value+number :: P Value number = label "number" $ do   neg <- sign   frac <- fractionDec (pure ())@@ -60,7 +60,7 @@            Left n -> Number (neg n) 0            Right (c, _, e) -> Number (neg c) e -space :: Parser ()+space :: P () space = skipCharsWhile (\c -> c == ' ' || c == '\n' || c == '\t')  main :: IO ()@@ -69,9 +69,7 @@   case args of     [file] -> do       src <- B.readFile file-      let (result, reports) = runCharParser json file src+      let (result, reports) = runParser json file src       for_ reports $ putStrLn . showReport-      case result of-        Just val -> print val-        Nothing  -> print $ runTracer json file src+      print result     _ -> error "Usage: paripari-example test.json"

@@ -1,15 +1,8 @@ cabal-version: 1.12---- This file has been generated from package.yaml by hpack version 0.31.2.------ see: https://github.com/sol/hpack------ hash: e2aa081115e4cfadf8c060813b3ede4ab8a817542bc9d7f33fa82a04ee85da38- name:           paripari-version:        0.6.0.1+version:        0.7.0.0 synopsis:       Parser combinators with fast-path and slower 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. Like Attoparsec, the parser combinators backtrack by default.+description:    PariPari offers two parsing strategies. There is a fast Acceptor and a slower Reporter. If the Acceptor fails, the Reporter returns a report about the parsing errors. category:       Text stability:      experimental homepage:       https://github.com/minad/paripari#readme@@ -19,7 +12,7 @@ copyright:      2018 Daniel Mendler license:        MIT license-file:   LICENSE-tested-with:    GHC == 8.0.1, GHC == 8.2.1, GHC == 8.4.3, GHC == 8.6.1+tested-with:    GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1 build-type:     Simple  source-repository head@@ -30,19 +23,17 @@   exposed-modules:       Text.PariPari       Text.PariPari.Internal.Acceptor-      Text.PariPari.Internal.CharCombinators       Text.PariPari.Internal.Chunk       Text.PariPari.Internal.Class-      Text.PariPari.Internal.ElementCombinators+      Text.PariPari.Internal.Combinators       Text.PariPari.Internal.Reporter       Text.PariPari.Internal.Run-      Text.PariPari.Internal.Tracer       Text.PariPari.Lens   other-modules:       Paths_paripari   hs-source-dirs:       src-  ghc-options: -Wall -Wcompat -Widentities -Wmonomorphism-restriction -Wincomplete-uni-patterns -Wincomplete-record-updates -Wtabs -fprint-potential-instances+  ghc-options: -O2 -Wall -Wcompat -Widentities -Wmonomorphism-restriction -Wincomplete-uni-patterns -Wincomplete-record-updates -Wtabs -fprint-potential-instances   build-depends:       base >=4.8 && <5     , bytestring >=0.10 && <0.11@@ -83,7 +74,7 @@       Paths_paripari   hs-source-dirs:       test-  ghc-options: -Wall -Wcompat -Widentities -Wmonomorphism-restriction -Wincomplete-uni-patterns -Wincomplete-record-updates -Wtabs -fprint-potential-instances+  ghc-options: -O0 -Wall -Wcompat -Widentities -Wmonomorphism-restriction -Wincomplete-uni-patterns -Wincomplete-record-updates -Wtabs -fprint-potential-instances   build-depends:       base >=4.8 && <5     , bytestring >=0.10 && <0.11

@@ -4,7 +4,6 @@ {-# LANGUAGE Rank2Types #-}  import Data.Foldable (for_)-import Data.Semigroup ((<>)) import System.Environment (getArgs) import Text.PariPari import qualified Data.Char as C@@ -12,9 +11,9 @@ 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)+type StringType = T.Text+type PMonad p = Parser StringType p+type P a = (forall p. PMonad p => p a)  data Type   = TypeName   !StringType@@ -33,34 +32,34 @@   | OtherLine     !StringType   deriving (Show) -source :: Parser [SourceLine]+source :: P [SourceLine] source = sepBy sourceLine (char '\n') <* eof -sourceLine :: Parser SourceLine+sourceLine :: P SourceLine sourceLine = specialiseAll <|> typeDecl <|> otherLine -otherLine :: Parser SourceLine+otherLine :: P SourceLine otherLine = OtherLine <$> takeCharsWhile (/= '\n') -specialiseAll :: Parser SourceLine+specialiseAll :: P SourceLine specialiseAll = SpecialiseAll   <$> (symbol "{-#" *> symbol "SPECIALISE_ALL" *> type_)   <*> (symbol "=" *> type_ <* symbol "#-}") -identifierAtom :: ParserMonad p => (Char -> Bool) -> p ()+identifierAtom :: PMonad p => (Char -> Bool) -> p () identifierAtom f = satisfy f *> skipCharsWhile (\c -> C.isAlphaNum c || c == '_' || c == '\'') -name :: Parser StringType+name :: P StringType name = asChunk (sepEndBy (identifierAtom C.isUpper) (char '.') *>                 identifierAtom C.isLower) <* space -typeName :: Parser StringType+typeName :: P StringType typeName = asChunk (void $ sepBy1 (identifierAtom C.isUpper) (char '.')) <* space -symbol :: ParserMonad p => String -> p StringType+symbol :: PMonad p => String -> p StringType symbol s = string s <* space -typeTuple :: Parser Type+typeTuple :: P Type typeTuple = do   ts <- between (symbol "(") (symbol ")") (sepBy type_ (symbol ","))   pure $ case ts of@@ -68,19 +67,19 @@            [t] -> t            _   -> TypeTuple ts -typeAtom :: Parser Type+typeAtom :: P Type typeAtom =   TypeName <$> typeName   <|> TypeVar <$> name   <|> TypeList <$> between (symbol "[") (symbol "]") type_   <|> typeTuple -typeApp :: Parser Type+typeApp :: P Type typeApp = do   t <- typeAtom   option t $ TypeApp t <$> some typeAtom -type_ :: Parser Type+type_ :: P Type type_ = do   t <- typeApp   TypeEq t <$> (symbol "~" *> type_)@@ -88,10 +87,10 @@     <|> TypeConstr t <$> (symbol "=>" *> type_)     <|> pure t -typeDecl :: Parser SourceLine+typeDecl :: P SourceLine typeDecl = TypeDecl <$> sepBy1 name (symbol ",") <*> (symbol "::" *> type_) -space :: Parser ()+space :: P () space = skipCharsWhile (== ' ')  showType :: Type -> StringType@@ -192,7 +191,7 @@   case args of     [src, _, dst] -> do       code <- T.readFile src-      let (result, reports) = runCharParser source src code+      let (result, reports) = runParser source src code       for_ reports $ putStrLn . showReport       case result of         Nothing -> pure ()

@@ -1,21 +1,13 @@ module Text.PariPari (-  C.ChunkParser(..)-  , C.CharParser(..)+  C.Parser(..)+  , C.Pos(..)   , C.Error(..)   , C.showError -  , K.Chunk(Element, showElement, showChunk)-  , K.CharChunk-  , K.Pos(..)+  , K.Chunk(showChunk) -  , U.runCharParser-  , U.runSeqCharParser-  , U.runCharParserWithOptions-  , U.runSeqCharParserWithOptions-  , U.runChunkParser-  , U.runSeqChunkParser-  , U.runChunkParserWithOptions-  , U.runSeqChunkParserWithOptions+  , U.runParser+  , U.runParserWithOptions    , A.Acceptor   , A.runAcceptor@@ -30,18 +22,12 @@   , R.runReporterWithOptions   , R.defaultReportOptions -  , T.Tracer-  , T.runTracer--  , module Text.PariPari.Internal.ElementCombinators-  , module Text.PariPari.Internal.CharCombinators+  , module Text.PariPari.Internal.Combinators ) where -import Text.PariPari.Internal.CharCombinators-import Text.PariPari.Internal.ElementCombinators+import Text.PariPari.Internal.Combinators 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,15 +1,18 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UnboxedTuples #-} module Text.PariPari.Internal.Acceptor (   Acceptor(..)   , Env(..)-  , State(..)   , get   , local   , runAcceptor@@ -18,32 +21,45 @@ import Control.Monad (void) import Data.Semigroup as Sem import Data.String (IsString(..))+import GHC.Base hiding (State#)+import GHC.Word import Text.PariPari.Internal.Chunk import Text.PariPari.Internal.Class import qualified Control.Monad.Fail as Fail  data Env k = Env-  { _envBuf       :: !(Buffer k)-  , _envEnd       :: !Int-  , _envFile      :: !FilePath-  , _envRefLine   :: !Int-  , _envRefColumn :: !Int+  { _envBuf     :: !(Buffer k)+  , _envFile    :: !FilePath+  , _envRefLine :: Int#+  , _envRefCol  :: Int#   } -data State = State-  { _stOff    :: !Int-  , _stLine   :: !Int-  , _stColumn :: !Int-  }+type State# = (# Int#, Int#, Int# #) +type Result# a = (# Int# | (# State#, a #) #)++pattern Ok# :: State# -> a -> Result# a+pattern Ok# s a = (# | (# s, a #) #)+pattern Err# :: Int# -> Result# a+pattern Err# o = (# o | #)+{-# COMPLETE Ok#, Err# #-}++_stLine :: State# -> Int#+_stLine (# _, x, _ #) = x+{-# INLINE _stLine #-}++_stCol :: State# -> Int#+_stCol (# _, _, x #) = x+{-# INLINE _stCol #-}++_stOff :: State# -> Int#+_stOff (# x, _, _ #) = x+{-# INLINE _stOff #-}+ -- | 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-  }+  { unAcceptor :: Env k -> State# -> Result# a }  instance (Chunk k, Semigroup a) => Sem.Semigroup (Acceptor k a) where   p1 <> p2 = (<>) <$> p1 <*> p2@@ -57,19 +73,20 @@   {-# INLINE mappend #-}  instance Functor (Acceptor k) where-  fmap f p = Acceptor $ \env st ok err ->-    unAcceptor p env st (ok . f) err+  fmap f p = Acceptor $ \env st -> case unAcceptor p env st of+    Err# o -> Err# o+    Ok# st' x -> Ok# st' (f x)   {-# INLINE fmap #-}  instance Chunk k => Applicative (Acceptor k) where-  pure x = Acceptor $ \_ st ok _ -> ok x st+  pure x = Acceptor $ \_ st -> Ok# st x   {-# 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+  f <*> a = Acceptor $ \env st -> case unAcceptor f env st of+    Err# o -> Err# o+    Ok# s f' -> case unAcceptor a env s of+      Err# o -> Err# o+      Ok# s' a' -> Ok# s' (f' a')   {-# INLINE (<*>) #-}    p1 *> p2 = do@@ -84,20 +101,22 @@   {-# INLINE (<*) #-}  instance Chunk k => Alternative (Acceptor k) where-  empty = Acceptor $ \_ _ _ err -> err $ ECombinator "empty"+  empty = Acceptor $ \_ st -> Err# (_stOff st)   {-# INLINE empty #-} -  p1 <|> p2 = Acceptor $ \env st ok err ->-    let err' _ = unAcceptor p2 env st ok err-    in unAcceptor p1 env st ok err'+  p1 <|> p2 = Acceptor $ \env st ->+    case unAcceptor p1 env st of+      Ok# st' x -> Ok# st' x+      Err# _ -> unAcceptor p2 env st   {-# 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+  p >>= f = Acceptor $ \env st ->+    case unAcceptor p env st of+      Err# o -> Err# o+      Ok# s x -> unAcceptor (f x) env s   {-# INLINE (>>=) #-}  #if !MIN_VERSION_base(4,11,0)@@ -109,38 +128,38 @@   fail msg = failWith $ EFail msg   {-# INLINE fail #-} -instance Chunk k => ChunkParser k (Acceptor k) where-  getPos = get $ \_ st -> Pos (_stLine st) (_stColumn st)+instance Chunk k => Parser k (Acceptor k) where+  getPos = get $ \_ st -> Pos (I# (_stLine st)) (I# (_stCol st))   {-# INLINE getPos #-}    getFile = get $ \env _ -> _envFile env   {-# INLINE getFile #-} -  getRefPos = get $ \env _ -> Pos (_envRefLine env) (_envRefColumn env)+  getRefPos = get $ \env _ -> Pos (I# (_envRefLine env)) (I# (_envRefCol env))   {-# INLINE getRefPos #-} -  withRefPos p = local (\st env -> env { _envRefLine = _stLine st, _envRefColumn = _stColumn st }) p+  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'+  notFollowedBy p = Acceptor $ \env st ->+    case unAcceptor p env st of+      Err# _ -> Ok# st ()+      Ok# _ _ -> Err# (_stOff st)   {-# INLINE notFollowedBy #-} -  lookAhead p = Acceptor $ \env st ok err ->-    let ok' x _ = ok x st-    in unAcceptor p env st ok' err+  lookAhead p = Acceptor $ \env st -> do+    case unAcceptor p env st of+      Err# _ -> Err# (_stOff st)+      Ok# _ x -> Ok# st x   {-# INLINE lookAhead #-} -  failWith e = Acceptor $ \_ _ _ err -> err e+  failWith _ = Acceptor $ \_ st -> Err# (_stOff st)   {-# INLINE failWith #-} -  eof = Acceptor $ \env st ok err ->-    if _stOff st >= _envEnd env then-      ok () st-    else-      err expectedEnd+  eof = Acceptor $ \env st ->+    case indexByte @k (_envBuf env) (_stOff st) `eqWord#` int2Word# 0# of+      1# -> Ok# st ()+      _ -> Err# (_stOff st)   {-# INLINE eof #-}    label _ p = p@@ -149,141 +168,110 @@   hidden p = p   {-# INLINE hidden #-} -  commit p = p-  {-# INLINE commit #-}-   recover p _ = p   {-# INLINE recover #-} -  element e = Acceptor $ \env st@State{_stOff, _stLine, _stColumn} ok err ->-    if | _stOff < _envEnd env,-         (e', w) <- elementAt @k (_envBuf env) _stOff,-         e == e',-         pos <- elementPos @k e (Pos _stLine _stColumn) ->-           ok e st { _stOff = _stOff + w, _stLine = _posLine pos, _stColumn = _posColumn pos }-       | otherwise ->-           err $ ECombinator "element"-  {-# INLINE element #-}+  try p = Acceptor $ \env st ->+    case unAcceptor p env st of+      Ok# st' x -> Ok# st' x+      Err# _ -> Err# (_stOff st)+  {-# INLINE try #-} -  elementScan f = Acceptor $ \env st@State{_stOff, _stLine, _stColumn} ok err ->-    if | _stOff < _envEnd env,-         (e, w) <- elementAt @k (_envBuf env) _stOff,-         Just r <- f e,-         pos <- elementPos @k e (Pos _stLine _stColumn) ->-           ok r st { _stOff = _stOff + w, _stLine = _posLine pos, _stColumn = _posColumn pos }-       | otherwise ->-           err $ ECombinator "elementScan"-  {-# INLINE elementScan #-}+  p1 <!> p2 = Acceptor $ \env st ->+    case unAcceptor p1 env st of+      Ok# st' x -> Ok# st' x+      Err# o | 1# <- o ==# _stOff st -> unAcceptor p2 env st+             | otherwise -> Err# o+  {-# INLINE (<!>) #-} -  chunk k = Acceptor $ \env st@State{_stOff,_stColumn} 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, _stColumn = _stColumn + n }-       else-         err $ ECombinator "chunk"+  chunk k = Acceptor $ \env (# stOff, stLine, stCol #) ->+    case matchChunk @k (_envBuf env) stOff k of+      -1# -> Err# stOff+      n -> Ok# (# stOff +# n, stLine, stCol +# n #) k   {-# INLINE chunk #-}    asChunk p = do-    begin <- get (const _stOff)+    I# begin' <- get (const (\s -> I# (_stOff s)))     p-    end <- get (const _stOff)+    I# end' <- get (const (\s -> I# (_stOff s)))     src <- get (\env _ -> _envBuf env)-    pure $ packChunk src begin (end - begin)+    pure $ packChunk src begin' (end' -# begin')   {-# INLINE asChunk #-} -instance CharChunk k => CharParser k (Acceptor k) where-  scan f = Acceptor $ \env st@State{_stOff, _stLine, _stColumn} ok err ->-    if | (c, w) <- charAt @k (_envBuf env) _stOff,-         c /= '\0',-         Just r <- f c ->-           ok r st-           { _stOff = _stOff + w-           , _stLine = if c == '\n' then _stLine + 1 else _stLine-           , _stColumn = if c == '\n' then 1 else _stColumn + 1-           }-       | otherwise ->-           err $ ECombinator "scan"+  scan f = Acceptor $ \env (# stOff, stLine, stCol #) ->+    case indexChar @k (_envBuf env) stOff of+      (# c, w #)+        | 1# <- c `neChar#` '\0'#, Just r <- f (C# c) ->+          Ok# (# stOff +# w,+                case c `eqChar#` '\n'# of 1# -> stLine +# 1#; _ -> stLine,+                case c `eqChar#` '\n'# of 1# -> 1#; _ -> stCol +# 1# #) r+      _ -> Err# stOff   {-# INLINE scan #-}    -- 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, _stColumn} 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-          , _stColumn = if c == '\n' then 1 else _stColumn + 1-          }-        else-          err $ ECombinator "char"+  char c@(C# c') =+    Acceptor $ \env (# stOff, stLine, stCol #) ->+    case matchChar @k (_envBuf env) stOff c' of+      -1# -> Err# stOff+      w -> Ok# (# stOff +# w,+                if c == '\n' then stLine +# 1# else stLine,+                if c == '\n' then 1# else stCol +# 1# #) c   {-# INLINE char #-} -  asciiScan f = Acceptor $ \env st@State{_stOff, _stLine, _stColumn} ok err ->-    if | b <- byteAt @k (_envBuf env) _stOff,+  asciiScan f = Acceptor $ \env (# stOff, stLine, stCol #) ->+    if | b <- W8# (indexByte @k (_envBuf env) stOff),          b /= 0,          b < 128,          Just x <- f b ->-           ok x st-           { _stOff = _stOff + 1-           , _stLine = if b == asc_newline then _stLine + 1 else _stLine-           , _stColumn = if b == asc_newline then 1 else _stColumn + 1-           }+           Ok# (# stOff +# 1#+               , if b == asc_newline then stLine +# 1# else stLine+               , if b == asc_newline then 1# else stCol +# 1# #) x        | otherwise ->-           err $ ECombinator "asciiScan"+           Err# stOff   {-# INLINE asciiScan #-}    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, _stColumn} 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-          , _stColumn = if b == asc_newline then 1 else _stColumn + 1-          }+    | otherwise = Acceptor $ \env (# stOff, stLine, stCol #) ->+        if W8# (indexByte @k (_envBuf env) stOff) == b then+          Ok# (# stOff +# 1#+              , if b == asc_newline then stLine +# 1# else stLine+              , if b == asc_newline then 1# else stCol +# 1# #) b         else-          err $ ECombinator "asciiByte"+          Err# stOff   {-# INLINE asciiByte #-} -instance CharChunk k => IsString (Acceptor k k) where+instance Chunk k => IsString (Acceptor k k) where   fromString = string   {-# INLINE fromString #-}  -- | 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+get :: (Env k -> State# -> a) -> Acceptor k a+get f = Acceptor $ \env st -> Ok# st (f env 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+local :: (State# -> Env k -> Env k) -> Acceptor k a -> Acceptor k a+local f p = Acceptor $ \env st ->+  unAcceptor p (f st env) st {-# 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 :: Chunk k => Acceptor k a -> FilePath -> k -> Maybe 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+  let !(# b, off #) = unpackChunk k+  in case unAcceptor p (initialEnv f b) (# off, 1#, 1# #) of+       Err# _ -> Nothing+       Ok# _ x -> Just x -initialEnv :: FilePath -> Buffer k -> Int -> Env k-initialEnv _envFile _envBuf _envEnd = Env+initialEnv :: FilePath -> Buffer k -> Env k+initialEnv _envFile _envBuf = Env   { _envBuf   , _envFile-  , _envEnd-  , _envRefLine = 1-  , _envRefColumn = 1-  }--initialState :: Int -> State-initialState _stOff = State-  { _stOff-  , _stLine = 1-  , _stColumn = 1+  , _envRefLine = 1#+  , _envRefCol = 1#   }

@@ -1,320 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE Rank2Types #-}-module Text.PariPari.Internal.CharCombinators (-  digitByte-  , integer-  , integer'-  , decimal-  , octal-  , hexadecimal-  , digit-  , sign-  , signed-  , fractionHex-  , fractionDec-  , char'-  , notChar-  , anyChar-  , anyAsciiByte-  , alphaNumChar-  , digitChar-  , letterChar-  , lowerChar-  , upperChar-  , symbolChar-  , categoryChar-  , punctuationChar-  , spaceChar-  , asciiChar-  , satisfy-  , asciiSatisfy-  , skipChars-  , takeChars-  , skipCharsWhile-  , takeCharsWhile-  , skipCharsWhile1-  , takeCharsWhile1-  , scanChars-  , scanChars1-  , string-) where--import Control.Applicative ((<|>), optional)-import Control.Monad.Combinators (option, skipCount, skipMany)-import Data.Functor (void)-import Data.Maybe (fromMaybe)-import Data.Semigroup ((<>))-import Data.Word (Word8)-import Text.PariPari.Internal.Chunk-import Text.PariPari.Internal.Class-import Text.PariPari.Internal.ElementCombinators ((<?>))-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 '_')`.--- Signs are not parsed by this combinator.-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 '_')`.--- Signs are not parsed by this combinator.-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---- | Parses a decimal integer.--- Signs are not parsed by this combinator.-decimal :: Num a => CharP k a-decimal = integer (pure ()) 10-{-# INLINE decimal #-}---- | Parses an octal integer.--- Signs are not parsed by this combinator.-octal :: Num a => CharP k a-octal = integer (pure ()) 8-{-# INLINE octal #-}---- | Parses a hexadecimal integer.--- Signs are not parsed by this combinator.-hexadecimal :: Num a => CharP k a-hexadecimal = integer (pure ()) 16-{-# INLINE hexadecimal #-}---- | Parse plus or minus sign-sign :: (CharParser k f, Num a) => f (a -> a)-sign = (negate <$ asciiByte asc_minus) <|> (id <$ optional (asciiByte asc_plus))-{-# INLINE sign #-}---- | Parse a number with a plus or minus sign.-signed :: (Num a, CharParser k p) => p a -> p a-signed p = ($) <$> sign <*> p-{-# INLINE signed #-}--fractionExp :: (Num a, CharParser k p) => p expSep -> p digitSep -> p (Maybe a)-fractionExp expSep digitSep = do-  e <- optional expSep-  case e of-    Nothing{} -> pure Nothing-    Just{} -> Just <$> signed (integer digitSep 10)-{-# INLINE fractionExp #-}---- | Parse a fraction of arbitrary exponent base and mantissa base.--- 'fractionDec' and 'fractionHex' should be used instead probably.--- Returns either an integer in 'Left' or a fraction in 'Right'.--- Signs are not parsed by this combinator.-fraction :: (Num a, CharParser k p) => p expSep -> Int -> Int -> p digitSep -> p (Either a (a, Int, a))-fraction expSep expBase mantBasePow digitSep = do-  let mantBase = expBase ^ mantBasePow-  mant <- integer digitSep mantBase-  frac <- optional $ asciiByte asc_point *> option (0, 0) (integer' digitSep mantBase)-  expn <- fractionExp expSep digitSep-  let (fracVal, fracLen) = fromMaybe (0, 0) frac-      expVal = fromMaybe 0 expn-  pure $ case (frac, expn) of-           (Nothing, Nothing) -> Left mant-           _ -> Right ( mant * fromIntegral mantBase ^ fracLen + fracVal-                      , expBase-                      , expVal - fromIntegral (fracLen * mantBasePow))-{-# INLINE fraction #-}---- | Parse a decimal fraction, e.g., 123.456e-78, returning (mantissa, 10, exponent),--- corresponding to mantissa * 10^exponent.--- Digits can be separated by separator, e.g. `optional (char '_')`.--- Signs are not parsed by this combinator.-fractionDec :: (Num a, CharParser k p) => p digitSep -> p (Either a (a, Int, a))-fractionDec sep = fraction (asciiSatisfy (\b -> b == asc_E || b == asc_e)) 10 1 sep <?> "fraction"-{-# INLINE fractionDec #-}---- | Parse a hexadecimal fraction, e.g., co.ffeep123, returning (mantissa, 2, exponent),--- corresponding to mantissa * 2^exponent.--- Digits can be separated by separator, e.g. `optional (char '_')`.--- Signs are not parsed by this combinator.-fractionHex :: (Num a, CharParser k p) => p digitSep -> p (Either a (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 arbitrary ASCII byte.-anyAsciiByte :: CharP k Word8-anyAsciiByte = asciiSatisfy (const True)-{-# INLINE anyAsciiByte #-}---- | 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 <$> anyAsciiByte-{-# 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 single character with the given predicate-satisfy :: CharParser k p => (Char -> Bool) -> p Char-satisfy f = scan $ \c -> if f c then Just c else Nothing-{-# INLINE satisfy #-}---- | Parse a single character within the ASCII charset with the given predicate-asciiSatisfy :: CharParser k p => (Word8 -> Bool) -> p Word8-asciiSatisfy f = asciiScan $ \b -> if f b then Just b else Nothing-{-# INLINE asciiSatisfy #-}--scanChars :: CharParser k p => (s -> Char -> Maybe s) -> s -> p s-scanChars f = go-  where go s = (scan (f s) >>= go) <|> pure s-{-# INLINE scanChars #-}--scanChars1 :: CharParser k p => (s -> Char -> Maybe s) -> s -> p s-scanChars1 f s = scan (f s) >>= scanChars f-{-# INLINE scanChars1 #-}

@@ -1,11 +1,15 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-} module Text.PariPari.Internal.Chunk (   Chunk(..)-  , CharChunk(..)-  , Pos(..)   , showByte   , showByteString   , unsafeAsciiToChar@@ -16,15 +20,11 @@ import Data.Bits (unsafeShiftL, (.|.), (.&.)) import Data.ByteString (ByteString) import Data.Foldable (foldl')-import Data.Semigroup ((<>)) 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.Base+import GHC.Word+import GHC.ForeignPtr import GHC.Show (showLitChar) import Numeric (showHex) import qualified Data.ByteString as B@@ -33,219 +33,152 @@ 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+class Ord k => Chunk k where+  type Buffer k+  matchChunk :: Buffer k -> Int# -> k -> Int# -- Returns -1# if not matched+  packChunk :: Buffer k -> Int# -> Int# -> k+  unpackChunk :: k -> (# Buffer k, Int# #)   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+  matchChar :: Buffer k -> Int# -> Char# -> Int# -- Returns -1# if not matched+  indexChar :: Buffer k -> Int# -> (# Char#, Int# #)+  indexByte :: Buffer k -> Int# -> Word#   stringToChunk :: String -> 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 #-}+  type Buffer ByteString = ForeignPtr Word8 -  chunkEqual b i (B.PS p j n) = ptrBytesEqual b i p j n-  {-# INLINE chunkEqual #-}+  matchChunk (ForeignPtr p _) i (B.PS (ForeignPtr p' _) (I# j) (I# n)) = go 0#+    where go :: Int# -> Int#+          go k | 1# <- k >=# n = n+               | w <- indexWord8OffAddr# p (i +# k),+                 w' <- indexWord8OffAddr# p' (j +# k),+                 1# <- w `neWord#` int2Word# 0#,+                 1# <- w `eqWord#` w' = go (k +# 1#)+               | otherwise = -1#+  {-# INLINE matchChunk #-} -  packChunk b i n = B.PS b i n+  packChunk b i n = B.PS b (I# i) (I# n)   {-# INLINE packChunk #-}    unpackChunk k =-    let (B.PS b i n) = k <> fromString "\0\0\0" -- sentinel-    in (b, i, n - 3)+    let !(B.PS b (I# i) _) = k <> fromString "\0\0\0" -- sentinel+    in (# b, i #)   {-# INLINE unpackChunk #-} -  showElement = showByte   showChunk = showByteString -instance CharChunk ByteString where-  byteAt = ptrByteAt-  {-# INLINE byteAt #-}--  charAt = ptrDecodeUtf8-  {-# INLINE charAt #-}+  indexByte (ForeignPtr p _) i = indexWord8OffAddr# p i+  {-# INLINE indexByte #-} -  charWidth = charWidthUtf8-  {-# INLINE charWidth #-}+  matchChar p i m+    | C# m <= '\x7F' =+        if | unsafeChr (at p i) == C# m -> 1#+           | otherwise -> -1#+    | C# m <= '\x7FF' =+        if | a1 <- at p i, a2 <- at p (i +# 1#),+             unsafeChr (((a1 .&. 31) `unsafeShiftL` 6)+                         .|. (a2 .&. 0x3F)) == C# m -> 2#+           | otherwise -> -1#+    | C# m <= '\xFFFF' =+        if | a1 <- at p i, a2 <- at p (i +# 1#), a3 <- at p (i +# 2#),+             unsafeChr (((a1 .&. 15) `unsafeShiftL` 12)+                         .|. ((a2 .&. 0x3F) `unsafeShiftL` 6)+                         .|. (a3 .&. 0x3F)) == C# m -> 3#+           | otherwise -> -1#+    | otherwise =+        if | a1 <- at p i, a2 <- at p (i +# 1#), a3 <- at p (i +# 2#), a4 <- at p (i +# 3#),+             unsafeChr (((a1 .&. 7) `unsafeShiftL` 18)+                         .|. ((a2 .&. 0x3F) `unsafeShiftL` 12)+                         .|. ((a3 .&. 0x3F) `unsafeShiftL` 6)+                         .|. (a4 .&. 0x3F)) == C# m -> 4#+           | otherwise -> -1#+  {-# INLINE matchChar #-} -  charAtFixed = ptrDecodeFixedUtf8-  {-# INLINE charAtFixed #-}+  -- TODO detect invalid utf-8?+  indexChar 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 indexChar #-}    stringToChunk t = T.encodeUtf8 $ fromString t   {-# INLINE stringToChunk #-}  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 #-}+  type Buffer Text = T.Array -  chunkEqual b i (T.Text a j n) = T.equal b i a j n-  {-# INLINE chunkEqual #-}+  matchChunk a i (T.Text a' (I# j) (I# n)) = go 0#+    where go :: Int# -> Int#+          go k | 1# <- k >=# n = n+               | w <- T.unsafeIndex a (I# (i +# k)),+                 w' <- T.unsafeIndex a' (I# (j +# k)),+                 w /= 0, w == w' = go (k +# 1#)+               | otherwise = -1#+  {-# INLINE matchChunk #-} -  packChunk b i n = T.Text b i n+  packChunk b i n = T.Text b (I# i) (I# n)   {-# INLINE packChunk #-}    unpackChunk k =-    let (T.Text b i n) = k <> fromString "\0" -- sentinel-    in (b, i, n - 1)+    let !(T.Text b (I# i) _) = k <> fromString "\0" -- sentinel+    in (# b, i #)   {-# INLINE unpackChunk #-} -  showElement = show   showChunk = show -instance CharChunk Text where-  byteAt = arrayByteAt-  {-# INLINE byteAt #-}--  charAt = arrayCharAt 2-  {-# INLINE charAt #-}+  indexByte a i+    | W16# c <- T.unsafeIndex a (I# i), 1# <- c `leWord#` (int2Word# 0xFF#) = c+    | otherwise = int2Word# 0#+  {-# INLINE indexByte #-} -  charWidth = charWidthUtf16-  {-# INLINE charWidth #-}+  indexChar a i+    | hi <- T.unsafeIndex a (I# i), lo <- T.unsafeIndex a (I# (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 indexChar #-} -  charAtFixed n b i = fst $ arrayCharAt n b i-  {-# INLINE charAtFixed #-}+  matchChar a i m+    | C# m <= '\xFFFF' =+        if | unsafeChr (fromIntegral (T.unsafeIndex a (I# i))) == C# m -> 1#+           | otherwise -> -1#+    | otherwise =+        if | hi <- T.unsafeIndex a (I# i), lo <- T.unsafeIndex a (I# (i +# 1#)),+             hi >= 0xD800, hi <= 0xDFFF,+             C# m == unsafeChr (0x10000 + ((fromIntegral $ hi - 0xD800) `unsafeShiftL` 10) ++                                (fromIntegral lo - 0xDC00)) -> 2#+           | otherwise -> -1#    stringToChunk t = fromString t   {-# INLINE stringToChunk #-} -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+at :: ForeignPtr Word8 -> Int# -> Int+at p i = fromIntegral $ W8# (indexByte @ByteString 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@@ -262,8 +195,12 @@ asc_newline = 10  unsafeAsciiToChar :: Word8 -> Char-unsafeAsciiToChar = unsafeChr . fromIntegral+unsafeAsciiToChar x = unsafeChr (fromIntegral x) {-# INLINE unsafeAsciiToChar #-}++unsafeChr# :: Int -> Char#+unsafeChr# (I# i) = chr# i+{-# INLINE unsafeChr# #-}  byteS :: Word8 -> ShowS byteS b

@@ -1,8 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FunctionalDependencies #-} module Text.PariPari.Internal.Class (-  ChunkParser(..)-  , CharParser(..)+  Parser(..)   , Alternative(..)   , MonadPlus   , Pos(..)@@ -15,13 +14,12 @@  import Control.Applicative (Alternative(empty, (<|>))) import Control.Monad (MonadPlus(..))-import Control.Monad.Fail (MonadFail(..)) import Data.List (intercalate)-import Data.Semigroup ((<>)) import Data.String (IsString) import Data.Word (Word8) import GHC.Generics (Generic) import Text.PariPari.Internal.Chunk+import qualified Control.Monad.Fail as Fail  -- | Parsing errors data Error@@ -29,16 +27,23 @@   | EExpected         [String]   | EUnexpected       String   | EFail             String-  | ECombinator       String-  | EIndentNotAligned !Int !Int-  | EIndentOverLine   !Int !Int-  | ENotEnoughIndent  !Int !Int+  | EIndentNotAligned {-#UNPACK#-}!Int {-#UNPACK#-}!Int+  | EIndentOverLine   {-#UNPACK#-}!Int {-#UNPACK#-}!Int+  | ENotEnoughIndent  {-#UNPACK#-}!Int {-#UNPACK#-}!Int   deriving (Eq, Ord, Show, Generic) +-- | Line and column position starting at (1,1)+data Pos = Pos+  { _posLine   :: {-#UNPACK#-}!Int+  , _posCol :: {-#UNPACK#-}!Int+  } deriving (Eq, Show, Generic)++infixl 3 <!>+ -- | 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+class (Fail.MonadFail p, MonadPlus p, Chunk k, IsString (p k)) => Parser k p | p -> k where   -- | Get file name associated with current parser   getFile :: p FilePath @@ -80,24 +85,12 @@   -- down the fast path of your parser.   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).-  ---  -- `commit` only applies to the reported-  -- errors, it has no effect on the backtracking behavior-  -- of the parser.-  ---  -- __Note__: This function has zero cost in the 'Acceptor'. You can-  -- use it to improve the error reports without slowing-  -- down the fast path of your parser.-  commit :: p a -> p a+  -- | Reset position if parser fails+  try :: p a -> p a +  -- | Alternative which does not backtrack.+  (<!>) :: p a -> p a -> p a+   -- | Parse with error recovery.   -- If the parser p fails in `recover p r`   -- the parser r continues at the position where p failed.@@ -112,12 +105,6 @@   -- down the fast path of your parser.   recover :: p a -> p a -> p a -  -- | Parse a single element-  element :: Element k -> p (Element k)--  -- | Scan a single element-  elementScan :: (Element k -> Maybe a) -> p a-   -- | Parse a chunk of elements. The chunk must not   -- contain multiple lines, otherwise the position information   -- will be invalid.@@ -127,7 +114,6 @@   -- result as buffer   asChunk :: p () -> p k -class (ChunkParser k p, IsString (p k), CharChunk k) => CharParser k p | p -> k where   -- | Parse a single character   --   -- __Note__: The character '\0' cannot be parsed using this combinator@@ -158,7 +144,6 @@ 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) = "Must be indented deeper than column " <> show rc <> ", got column " <> show c@@ -170,6 +155,6 @@ unexpectedEnd = EUnexpected "end of file"  -- | Parse a string-string :: CharParser k p => String -> p k+string :: Parser k p => String -> p k string t = chunk (stringToChunk t) {-# INLINE string #-}

@@ -0,0 +1,445 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE Rank2Types #-}+module Text.PariPari.Internal.Combinators (+  -- * 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++  -- * Labels+  , (<?>)++  -- * Position+  , getLine+  , getCol+  , withPos+  , withSpan++  -- * Indentation+  , getRefCol+  , getRefLine+  , withRefPos+  , align+  , indented+  , line+  , linefold++  -- * Char combinators+  , digitByte+  , integer+  , integer'+  , decimal+  , octal+  , hexadecimal+  , digit+  , sign+  , signed+  , fractionHex+  , fractionDec+  , char'+  , notChar+  , anyChar+  , anyAsciiByte+  , alphaNumChar+  , digitChar+  , letterChar+  , lowerChar+  , upperChar+  , symbolChar+  , categoryChar+  , punctuationChar+  , spaceChar+  , asciiChar+  , satisfy+  , asciiSatisfy+  , skipChars+  , takeChars+  , skipCharsWhile+  , takeCharsWhile+  , skipCharsWhile1+  , takeCharsWhile1+  , scanChars+  , scanChars1+  , string+) where++import Control.Applicative (optional)+import Control.Monad (when)+import Control.Monad.Combinators (option, skipCount, skipMany)+import Data.Functor (void)+import Data.Maybe (fromMaybe)+import Data.Word (Word8)+import Prelude hiding (getLine)+import Text.PariPari.Internal.Chunk+import Text.PariPari.Internal.Class+import qualified Control.Monad.Combinators as O+import qualified Control.Monad.Combinators.NonEmpty as ON+import qualified Data.Char as C++type P k a  = (forall p. Parser k p => p a)++-- | Infix alias for 'label'+(<?>) :: Parser k p => p a -> String -> p a+(<?>) = flip label+{-# INLINE (<?>) #-}+infix 0 <?>++-- | Get line number of the reference position+getRefLine :: P k Int+getRefLine = _posLine <$> getRefPos+{-# INLINE getRefLine #-}++-- | Get column number of the reference position+getRefCol :: P k Int+getRefCol = _posCol <$> getRefPos+{-# INLINE getRefCol #-}++-- | Get current line number+getLine :: P k Int+getLine = _posLine <$> getPos+{-# INLINE getLine #-}++-- | Get current column+getCol :: P k Int+getCol = _posCol <$> getPos+{-# INLINE getCol #-}++-- | Decorate the parser result with the current position+withPos :: Parser k p => p a -> p (Pos, a)+withPos p = do+  pos <- getPos+  ret <- p+  pure (pos, ret)+{-# INLINE withPos #-}++-- | Decorate the parser result with the position span+withSpan :: Parser k p => p a -> p (Pos, Pos, 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 :: P 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 :: P k ()+align = do+  c <- getCol+  rc <- getRefCol+  when (c /= rc) $ failWith $ EIndentNotAligned rc c+{-# INLINE align #-}++-- | Parser succeeds for columns greater than the current reference column+indented :: P k ()+indented = do+  c <- getCol+  rc <- getRefCol+  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 :: P k ()+linefold = line <|> indented+{-# INLINE linefold #-}++-- | Parse a digit byte for the given base.+-- Bases 2 to 36 are supported.+digitByte :: Parser 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 :: Parser 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 '_')`.+-- Signs are not parsed by this combinator.+integer' :: (Num a, Parser 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 '_')`.+-- Signs are not parsed by this combinator.+integer :: (Num a, Parser 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++-- | Parses a decimal integer.+-- Signs are not parsed by this combinator.+decimal :: Num a => P k a+decimal = integer (pure ()) 10+{-# INLINE decimal #-}++-- | Parses an octal integer.+-- Signs are not parsed by this combinator.+octal :: Num a => P k a+octal = integer (pure ()) 8+{-# INLINE octal #-}++-- | Parses a hexadecimal integer.+-- Signs are not parsed by this combinator.+hexadecimal :: Num a => P k a+hexadecimal = integer (pure ()) 16+{-# INLINE hexadecimal #-}++-- | Parse plus or minus sign+sign :: (Parser k f, Num a) => f (a -> a)+sign = (negate <$ asciiByte asc_minus) <|> (id <$ optional (asciiByte asc_plus))+{-# INLINE sign #-}++-- | Parse a number with a plus or minus sign.+signed :: (Num a, Parser k p) => p a -> p a+signed p = ($) <$> sign <*> p+{-# INLINE signed #-}++fractionExp :: (Num a, Parser k p) => p expSep -> p digitSep -> p (Maybe a)+fractionExp expSep digitSep = do+  e <- optional expSep+  case e of+    Nothing{} -> pure Nothing+    Just{} -> Just <$> signed (integer digitSep 10)+{-# INLINE fractionExp #-}++-- | Parse a fraction of arbitrary exponent base and mantissa base.+-- 'fractionDec' and 'fractionHex' should be used instead probably.+-- Returns either an integer in 'Left' or a fraction in 'Right'.+-- Signs are not parsed by this combinator.+fraction :: (Num a, Parser k p) => p expSep -> Int -> Int -> p digitSep -> p (Either a (a, Int, a))+fraction expSep expBase mantBasePow digitSep = do+  let mantBase = expBase ^ mantBasePow+  mant <- integer digitSep mantBase+  frac <- optional $ asciiByte asc_point *> option (0, 0) (integer' digitSep mantBase)+  expn <- fractionExp expSep digitSep+  let (fracVal, fracLen) = fromMaybe (0, 0) frac+      expVal = fromMaybe 0 expn+  pure $ case (frac, expn) of+           (Nothing, Nothing) -> Left mant+           _ -> Right ( mant * fromIntegral mantBase ^ fracLen + fracVal+                      , expBase+                      , expVal - fromIntegral (fracLen * mantBasePow))+{-# INLINE fraction #-}++-- | Parse a decimal fraction, e.g., 123.456e-78, returning (mantissa, 10, exponent),+-- corresponding to mantissa * 10^exponent.+-- Digits can be separated by separator, e.g. `optional (char '_')`.+-- Signs are not parsed by this combinator.+fractionDec :: (Num a, Parser k p) => p digitSep -> p (Either a (a, Int, a))+fractionDec sep = fraction (asciiSatisfy (\b -> b == asc_E || b == asc_e)) 10 1 sep <?> "fraction"+{-# INLINE fractionDec #-}++-- | Parse a hexadecimal fraction, e.g., co.ffeep123, returning (mantissa, 2, exponent),+-- corresponding to mantissa * 2^exponent.+-- Digits can be separated by separator, e.g. `optional (char '_')`.+-- Signs are not parsed by this combinator.+fractionHex :: (Num a, Parser k p) => p digitSep -> p (Either a (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' :: Parser 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 :: Parser k p => Char -> p Char+notChar c = satisfy (/= c)+{-# INLINE notChar #-}++-- | Parse an arbitrary character.+anyChar :: P k Char+anyChar = satisfy (const True)+{-# INLINE anyChar #-}++-- | Parse an arbitrary ASCII byte.+anyAsciiByte :: P k Word8+anyAsciiByte = asciiSatisfy (const True)+{-# INLINE anyAsciiByte #-}++-- | Parse an alphanumeric character, including Unicode.+alphaNumChar :: P k Char+alphaNumChar = satisfy C.isAlphaNum <?> "alphanumeric character"+{-# INLINE alphaNumChar #-}++-- | Parse a letter character, including Unicode.+letterChar :: P k Char+letterChar = satisfy C.isLetter <?> "letter"+{-# INLINE letterChar #-}++-- | Parse a lowercase letter, including Unicode.+lowerChar :: P k Char+lowerChar = satisfy C.isLower <?> "lowercase letter"+{-# INLINE lowerChar #-}++-- | Parse a uppercase letter, including Unicode.+upperChar :: P k Char+upperChar = satisfy C.isUpper <?> "uppercase letter"+{-# INLINE upperChar #-}++-- | Parse a space character, including Unicode.+spaceChar :: P k Char+spaceChar = satisfy C.isSpace <?> "space"+{-# INLINE spaceChar #-}++-- | Parse a symbol character, including Unicode.+symbolChar :: P k Char+symbolChar = satisfy C.isSymbol <?> "symbol"+{-# INLINE symbolChar #-}++-- | Parse a punctuation character, including Unicode.+punctuationChar :: P k Char+punctuationChar = satisfy C.isPunctuation <?> "punctuation"+{-# INLINE punctuationChar #-}++-- | Parse a digit character of the given base.+-- Bases 2 to 36 are supported.+digitChar :: Parser k p => Int -> p Char+digitChar base = unsafeAsciiToChar <$> digitByte base+{-# INLINE digitChar #-}++-- | Parse a character beloning to the ASCII charset (< 128)+asciiChar :: P k Char+asciiChar = unsafeAsciiToChar <$> anyAsciiByte+{-# INLINE asciiChar #-}++-- | Parse a character belonging to the given Unicode category+categoryChar :: Parser 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 :: Parser k p => Int -> p ()+skipChars n = skipCount n anyChar+{-# INLINE skipChars #-}++-- | Skip char while predicate is true+skipCharsWhile :: Parser k p => (Char -> Bool) -> p ()+skipCharsWhile f = skipMany (satisfy f)+{-# INLINE skipCharsWhile #-}++-- | Skip at least one char while predicate is true+skipCharsWhile1 :: Parser 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 :: Parser k p => Int -> p k+takeChars n = asChunk (skipChars n) <?> "string of length " <> show n+{-# INLINE takeChars #-}++-- | Take chars while predicate is true+takeCharsWhile :: Parser k p => (Char -> Bool) -> p k+takeCharsWhile f = asChunk (skipCharsWhile f)+{-# INLINE takeCharsWhile #-}++-- | Take at least one byte while predicate is true+takeCharsWhile1 :: Parser k p => (Char -> Bool) -> p k+takeCharsWhile1 f = asChunk (skipCharsWhile1 f)+{-# INLINE takeCharsWhile1 #-}++-- | Parse a single character with the given predicate+satisfy :: Parser k p => (Char -> Bool) -> p Char+satisfy f = scan $ \c -> if f c then Just c else Nothing+{-# INLINE satisfy #-}++-- | Parse a single character within the ASCII charset with the given predicate+asciiSatisfy :: Parser k p => (Word8 -> Bool) -> p Word8+asciiSatisfy f = asciiScan $ \b -> if f b then Just b else Nothing+{-# INLINE asciiSatisfy #-}++scanChars :: Parser k p => (s -> Char -> Maybe s) -> s -> p s+scanChars f = go+  where go s = (scan (f s) >>= go) <|> pure s+{-# INLINE scanChars #-}++scanChars1 :: Parser k p => (s -> Char -> Maybe s) -> s -> p s+scanChars1 f s = scan (f s) >>= scanChars f+{-# INLINE scanChars1 #-}

@@ -1,202 +0,0 @@-{-# 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-  , elementSatisfy-  , takeElements-  , skipElements-  , skipElementsWhile-  , takeElementsWhile-  , skipElementsWhile1-  , takeElementsWhile1-  , scanElements-  , scanElements1-) where--import Control.Applicative ((<|>), empty)-import Control.Monad (when)-import Control.Monad.Combinators (skipCount, skipMany)-import Data.Functor (void)-import Data.Semigroup ((<>))-import Prelude hiding (getLine)-import Text.PariPari.Internal.Chunk-import Text.PariPari.Internal.Class-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)---- | Decorate 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 element 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 element-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 #-}---- | Parse a single element with the given predicate-elementSatisfy :: ChunkParser k p => (Element k -> Bool) -> p (Element k)-elementSatisfy f = elementScan $ \e -> if f e then Just e else Nothing-{-# INLINE elementSatisfy #-}--scanElements :: ChunkParser k p => (s -> Element k -> Maybe s) -> s -> p s-scanElements f = go-  where go s = (elementScan (f s) >>= go) <|> pure s-{-# INLINE scanElements #-}--scanElements1 :: ChunkParser k p => (s -> Element k -> Maybe s) -> s -> p s-scanElements1 f s = elementScan (f s) >>= scanElements f-{-# INLINE scanElements1 #-}

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-}@@ -7,6 +8,8 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE MagicHash #-} module Text.PariPari.Internal.Reporter (   Reporter(..)   , Env(..)@@ -28,9 +31,10 @@ import Control.Monad (void) import Data.Function (on) import Data.List (intercalate, sort, group, sortOn)-import Data.List.NonEmpty (NonEmpty(..)) import Data.Semigroup as Sem import Data.String (IsString(..))+import GHC.Base+import GHC.Word import GHC.Generics (Generic) import Text.PariPari.Internal.Chunk import Text.PariPari.Internal.Class@@ -38,45 +42,42 @@ import qualified Data.List.NonEmpty as NE  data ErrorContext = ErrorContext-  { _ecErrors  :: [Error]-  , _ecContext :: [String]+  { _ecErrors  :: ![Error]+  , _ecContext :: ![String]   } deriving (Eq, Show, Generic)  data ReportOptions = ReportOptions-  { _optMaxContexts         :: !Int-  , _optMaxErrorsPerContext :: !Int-  , _optMaxLabelsPerContext :: !Int+  { _optMaxContexts         :: {-#UNPACK#-}!Int+  , _optMaxErrorsPerContext :: {-#UNPACK#-}!Int+  , _optMaxLabelsPerContext :: {-#UNPACK#-}!Int   } deriving (Eq, Show, Generic)  data Report = Report   { _reportFile   :: !FilePath-  , _reportLine   :: !Int-  , _reportColumn :: !Int-  , _reportErrors :: [ErrorContext]+  , _reportErrors :: ![ErrorContext]+  , _reportLine   :: {-#UNPACK#-}!Int+  , _reportCol    :: {-#UNPACK#-}!Int   } 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-  , _envRefColumn :: !Int+  , _envContext   :: ![String]+  , _envRefLine   :: Int#+  , _envRefCol    :: Int#   }  data State = State-  { _stOff       :: !Int-  , _stLine      :: !Int-  , _stColumn    :: !Int-  , _stErrOff    :: !Int-  , _stErrLine   :: !Int-  , _stErrColumn :: !Int-  , _stErrCommit :: !Int-  , _stErrors    :: [ErrorContext]-  , _stReports   :: [Report]+  { _stOff       :: Int#+  , _stLine      :: Int#+  , _stCol       :: Int#+  , _stErrOff    :: Int#+  , _stErrLine   :: Int#+  , _stErrCol    :: Int#+  , _stErrors    :: ![ErrorContext]+  , _stReports   :: ![Report]   }  -- | Parser which is optimised for good error reports.@@ -153,17 +154,17 @@   fail msg = failWith $ EFail msg   {-# INLINE fail #-} -instance Chunk k => ChunkParser k (Reporter k) where-  getPos = get $ \_ st -> Pos (_stLine st) (_stColumn st)+instance Chunk k => Parser k (Reporter k) where+  getPos = get $ \_ st -> Pos (I# (_stLine st)) (I# (_stCol st))   {-# INLINE getPos #-}    getFile = get $ \env _ -> _envFile env   {-# INLINE getFile #-} -  getRefPos = get $ \env _ -> Pos (_envRefLine env) (_envRefColumn env)+  getRefPos = get $ \env _ -> Pos (I# (_envRefLine env)) (I# (_envRefCol env))   {-# INLINE getRefPos #-} -  withRefPos p = local (\st env -> env { _envRefLine = _stLine st, _envRefColumn = _stColumn st }) p+  withRefPos p = local (\st env -> env { _envRefLine = _stLine st, _envRefCol = _stCol st }) p   {-# INLINE withRefPos #-}    label l p = local (const $ addLabel l) p@@ -172,9 +173,18 @@   hidden p = local (const $ \env -> env { _envHidden = True }) p   {-# INLINE hidden #-} -  commit p = local (const $ \env -> env { _envCommit = _envCommit env + 1 }) p-  {-# INLINE commit #-}+  try p = Reporter $ \env st ok err ->+    let err' _ = err st+    in unReporter p env st ok err'+  {-# INLINE try #-} +  p1 <!> p2 = Reporter $ \env st ok err ->+    let err' s+          | 1# <- _stOff s ==# _stOff st = unReporter p2 env (mergeErrorState env st s) ok err+          | otherwise = err s+    in unReporter p1 env st ok err'+  {-# INLINE (<!>) #-}+   notFollowedBy p = Reporter $ \env st ok err ->     let ok' x _ = raiseError env st err $ EUnexpected $ show x         err' _ = ok () st@@ -190,10 +200,9 @@   {-# INLINE failWith #-}    eof = Reporter $ \env st ok err ->-    if _stOff st >= _envEnd env then-      ok () st-    else-      raiseError env st err expectedEnd+    case indexByte @k (_envBuf env) (_stOff st) `eqWord#` int2Word# 0# of+      1# -> ok () st+      _ -> raiseError env st err expectedEnd   {-# INLINE eof #-}    recover p r = Reporter $ \env st ok err ->@@ -203,92 +212,57 @@     in unReporter p env st ok err1   {-# INLINE recover #-} -  element e = Reporter $ \env st@State{_stOff, _stLine, _stColumn} ok err ->-    if | _stOff < _envEnd env,-         (e', w) <- elementAt @k (_envBuf env) _stOff,-         e == e',-         pos <- elementPos @k e (Pos _stLine _stColumn) ->-           ok e st { _stOff =_stOff + w, _stLine = _posLine pos, _stColumn = _posColumn pos }-       | otherwise ->-           raiseError env st err $ EExpected [showElement @k e]-  {-# INLINE element #-}--  elementScan f = Reporter $ \env st@State{_stOff, _stLine, _stColumn} ok err ->-    let (e, w) = elementAt @k (_envBuf env) _stOff-    in if | _stOff >= _envEnd env ->-              raiseError env st err unexpectedEnd-          | _stOff < _envEnd env,-            Just r <- f e,-            pos <- elementPos @k e (Pos _stLine _stColumn) ->-              ok r st { _stOff =_stOff + w, _stLine = _posLine pos, _stColumn = _posColumn pos }-          | otherwise ->-              raiseError env st err $ EUnexpected $ showElement @k e-  {-# INLINE elementScan #-}--  chunk k = Reporter $ \env st@State{_stOff,_stColumn} 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, _stColumn = _stColumn + n }-       else-         raiseError env st err $ EExpected [showChunk @k k]+  chunk k = Reporter $ \env st@State{_stOff,_stCol} ok err ->+    case matchChunk @k (_envBuf env) _stOff k of+      -1# -> raiseError env st err $ EExpected [showChunk @k k]+      n -> ok k st { _stOff = _stOff +# n, _stCol = _stCol +# n }   {-# INLINE chunk #-}    asChunk p = do-    begin <- get (const _stOff)+    I# begin' <- get (const (\s -> I# (_stOff s)))     p-    end <- get (const _stOff)+    I# end' <- get (const (\s -> I# (_stOff s)))     src <- get (\env _ -> _envBuf env)-    pure $ packChunk src begin (end - begin)+    pure $ packChunk src begin' (end' -# begin')   {-# INLINE asChunk #-} -instance CharChunk k => CharParser k (Reporter k) where-  scan f = Reporter $ \env st@State{_stOff, _stLine, _stColumn} ok err ->-    if | (c, w) <- charAt @k (_envBuf env) _stOff,-         c /= '\0' ->-           case f c of-             Just r ->-               ok r st-               { _stOff = _stOff + w-               , _stLine = if c == '\n' then _stLine + 1 else _stLine-               , _stColumn = if c == '\n' then 1 else _stColumn + 1-               }-             Nothing ->-               raiseError env st err $ EUnexpected $ show c-       | _stOff >= _envEnd env ->-           raiseError env st err unexpectedEnd-       | otherwise ->-           raiseError env st err EInvalidUtf8+  scan f = Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err ->+    case indexChar @k (_envBuf env) _stOff of+      (# '\0'#, _ #) -> raiseError env st err unexpectedEnd+      (# c, w #) ->+        case f (C# c) of+          Just r ->+            ok r st { _stOff = _stOff +# w+                    , _stLine = case c `eqChar#` '\n'# of 1# -> _stLine +# 1#; _ -> _stLine+                    , _stCol = case c `eqChar#` '\n'# of 1# -> 1#; _ -> _stCol +# 1#+                    }+          Nothing -> raiseError env st err $ EUnexpected $ show (C# c)   {-# INLINE scan #-}    -- 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, _stColumn} 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-          , _stColumn = if c == '\n' then 1 else _stColumn + 1-          }-        else-          raiseError env st err $ EExpected [show c]+  char c@(C# c') =+    Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err ->+        case matchChar @k (_envBuf env) _stOff c' of+          -1# -> raiseError env st err $ EExpected [show c]+          w -> ok c st+            { _stOff = _stOff +# w+            , _stLine = if c == '\n' then _stLine +# 1# else _stLine+            , _stCol = if c == '\n' then 1# else _stCol +# 1#+            }   {-# INLINE char #-} -  asciiScan f = Reporter $ \env st@State{_stOff, _stLine, _stColumn} ok err ->-    let b = byteAt @k (_envBuf env) _stOff+  asciiScan f = Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err ->+    let b = W8# (indexByte @k (_envBuf env) _stOff)     in if | b /= 0,             b < 128,             Just x <- f b ->               ok x st-              { _stOff = _stOff + 1-              , _stLine = if b == asc_newline then _stLine + 1 else _stLine-              , _stColumn = if b == asc_newline then 1 else _stColumn + 1+              { _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 asciiScan #-}@@ -296,18 +270,18 @@   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, _stColumn} ok err ->-        if byteAt @k (_envBuf env) _stOff == b then+    | otherwise = Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err ->+        if W8# (indexByte @k (_envBuf env) _stOff) == b then           ok b st-          { _stOff = _stOff + 1-          , _stLine = if b == asc_newline then _stLine + 1 else _stLine-          , _stColumn = if b == asc_newline then 1 else _stColumn + 1+          { _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 #-} -instance CharChunk k => IsString (Reporter k k) where+instance Chunk k => IsString (Reporter k k) where   fromString = string   {-# INLINE fromString #-} @@ -338,17 +312,13 @@ -- 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,+  | 1# <- _stOff st ># _stErrOff st,     Just e' <- mkError env e =       st { _stErrors    = [e']          , _stErrOff    = _stOff st          , _stErrLine   = _stLine st-         , _stErrColumn = _stColumn st-         , _stErrCommit = _envCommit env+         , _stErrCol = _stCol st          }-  | _stOff st == _stErrOff st && _envCommit env == _stErrCommit st,-    Just e' <- mkError env e =-      st { _stErrors = shrinkErrors env $ e' : _stErrors st }   | otherwise = st {-# INLINE addError #-} @@ -362,23 +332,19 @@ -- | 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 =+  | 1# <- _stErrOff s' ># _stErrOff s =       s { _stErrors    = _stErrors s'         , _stErrOff    = _stErrOff s'         , _stErrLine   = _stErrLine s'-        , _stErrColumn = _stErrColumn s'-        , _stErrCommit = _stErrCommit s'+        , _stErrCol    = _stErrCol s'         }-  | _stErrOff s' == _stErrOff s && _stErrCommit s' == _stErrCommit s =+  | 1# <- _stErrOff s' ==# _stErrOff 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+shrinkErrors env = take (_optMaxContexts._envOptions $ env) . map (mergeErrorContexts env) . NE.groupBy ((==) `on` _ecContext) . sortOn _ecContext  -- | Shrink error context by deleting duplicates -- and merging errors if possible.@@ -409,8 +375,8 @@ -- | Run 'Reporter' with additional 'ReportOptions'. runReporterWithOptions :: Chunk k => ReportOptions -> Reporter k a -> FilePath -> k -> (Maybe a, [Report]) runReporterWithOptions o p f k =-  let (b, off, len) = unpackChunk k-      env = initialEnv o f b (off + len)+  let !(# b, off #) = unpackChunk k+      env = initialEnv o f b       ok x s = (Just x, reverse $ _stReports s)       err s = (Nothing, reverse $ _stReports $ addReport env s)   in unReporter p env (initialState off) ok err@@ -423,30 +389,30 @@ runReporter = runReporterWithOptions defaultReportOptions  addReport :: Env k -> State -> State-addReport e s = s { _stReports = Report (_envFile e) (_stErrLine s) (_stErrColumn s) (_stErrors s) : _stReports s }+addReport e s = s { _stReports = Report { _reportFile = _envFile e+                                        , _reportErrors = _stErrors s+                                        , _reportLine = I# (_stErrLine s)+                                        , _reportCol = I# (_stErrCol s) } : _stReports s } -initialEnv :: ReportOptions -> FilePath -> Buffer k -> Int -> Env k-initialEnv _envOptions _envFile _envBuf _envEnd = Env+initialEnv :: ReportOptions -> FilePath -> Buffer k -> Env k+initialEnv _envOptions _envFile _envBuf = Env   { _envFile   , _envBuf   , _envOptions-  , _envEnd   , _envContext   = []   , _envHidden    = False-  , _envCommit    = 0-  , _envRefLine   = 1-  , _envRefColumn = 1+  , _envRefLine   = 1#+  , _envRefCol    = 1#   } -initialState :: Int -> State+initialState :: Int# -> State initialState _stOff = State   { _stOff-  , _stLine      = 1-  , _stColumn    = 1-  , _stErrOff    = 0-  , _stErrLine   = 0-  , _stErrColumn = 0-  , _stErrCommit = 0+  , _stLine      = 1#+  , _stCol       = 1#+  , _stErrOff    = 0#+  , _stErrLine   = 0#+  , _stErrCol    = 0#   , _stErrors    = []   , _stReports   = []   }@@ -456,7 +422,7 @@ showReport r =   "Parser errors at " <> _reportFile r   <> ", line " <> show (_reportLine r)-  <> ", column " <> show (_reportColumn r)+  <> ", column " <> show (_reportCol r)   <> "\n\n" <> showErrors (_reportErrors r)  -- | Pretty string representation of '[ErrorContext]'.

@@ -1,89 +1,28 @@ {-# LANGUAGE Rank2Types #-} module Text.PariPari.Internal.Run (-  runCharParser-  , runSeqCharParser-  , runCharParserWithOptions-  , runSeqCharParserWithOptions-  , runChunkParser-  , runSeqChunkParser-  , runChunkParserWithOptions-  , runSeqChunkParserWithOptions+  runParser+  , runParserWithOptions ) 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 chunk **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 -> (Maybe a, [Report])-runCharParser = runCharParserWithOptions defaultReportOptions-{-# INLINE runCharParser #-}---- | Run fast 'Acceptor' and slower 'Reporter' on the given chunk **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 -> (Maybe a, [Report])-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 -> (Maybe a, [Report])-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 -> (Just x, [])-{-# INLINE runCharParserWithOptions #-}---- | Run parsers **sequentially** with additional 'ReportOptions'.-runSeqCharParserWithOptions :: CharChunk k => ReportOptions -> (forall p. CharParser k p => p a) -> FilePath -> k -> (Maybe a, [Report])-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 -> (Just x, [])-{-# INLINE runSeqCharParserWithOptions #-}---- | Run fast 'Acceptor' and slower 'Reporter' on the given chunk **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 -> (Maybe a, [Report])-runChunkParser = runCharParserWithOptions defaultReportOptions-{-# INLINE runChunkParser #-}---- | Run fast 'Acceptor' and slower 'Reporter' on the given chunk **sequentially**.+-- | Rsun fast 'Acceptor' and slower 'Reporter' on the given  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 -> (Maybe a, [Report])-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 -> (Maybe a, [Report])-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 -> (Just x, [])-{-# INLINE runChunkParserWithOptions #-}+runParser :: Chunk k => (forall p. Parser k p => p a) -> FilePath -> k -> (Maybe a, [Report])+runParser = runParserWithOptions defaultReportOptions+{-# INLINE runParser #-}  -- | Run parsers **sequentially** with additional 'ReportOptions'.-runSeqChunkParserWithOptions :: Chunk k => ReportOptions -> (forall p. ChunkParser k p => p a) -> FilePath -> k -> (Maybe a, [Report])-runSeqChunkParserWithOptions o p f b =+runParserWithOptions :: Chunk k => ReportOptions -> (forall p. Parser k p => p a) -> FilePath -> k -> (Maybe a, [Report])+runParserWithOptions o p f b =   let a = runAcceptor p f b       r = runReporterWithOptions o p f b   in case a of-       Left _  -> r-       Right x -> (Just x, [])-{-# INLINE runSeqChunkParserWithOptions #-}+       Nothing  -> r+       Just x -> (Just x, [])+{-# INLINE runParserWithOptions #-}

@@ -1,48 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeApplications #-}-module Text.PariPari.Internal.Tracer (-  Tracer(..)-  , runTracer-) where--import Data.Semigroup as Sem-import Data.String (IsString)-import Debug.Trace (trace)-import Text.PariPari.Internal.Chunk-import Text.PariPari.Internal.Class-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 (Sem.Semigroup, Monoid, Functor, Applicative, MonadPlus, Monad, Fail.MonadFail)--deriving instance CharChunk k => ChunkParser k (Tracer k)-deriving instance CharChunk k => CharParser k (Tracer k)-deriving instance CharChunk k => IsString (Tracer k 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 (_stColumn 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 chunk, returning the result--- if successful and reports from error recoveries.--- In the case of an error, 'Nothing' is returned and the 'Report' list--- is non-empty.-runTracer :: Chunk k => Tracer k a -> FilePath -> k -> (Maybe a, [Report])-runTracer = runReporter . unTracer

@@ -1,9 +1,9 @@ {-# LANGUAGE Rank2Types #-} module Text.PariPari.Lens (   posLine-  , posColumn+  , posCol   , reportLine-  , reportColumn+  , reportCol   , reportFile   , reportErrors   , ecErrors@@ -13,7 +13,6 @@   , optMaxLabelsPerContext ) where -import Text.PariPari.Internal.Chunk import Text.PariPari.Internal.Class import Text.PariPari.Internal.Reporter @@ -23,17 +22,17 @@ posLine k p = fmap (\x -> p { _posLine = x }) (k (_posLine p)) {-# INLINE posLine #-} -posColumn :: Lens Pos Int-posColumn k p = fmap (\x -> p { _posColumn = x }) (k (_posColumn p))-{-# INLINE posColumn #-}+posCol :: Lens Pos Int+posCol k p = fmap (\x -> p { _posCol = x }) (k (_posCol p))+{-# INLINE posCol #-}  reportLine :: Lens Report Int reportLine k r = fmap (\x -> r { _reportLine = x }) (k (_reportLine r)) {-# INLINE reportLine #-} -reportColumn :: Lens Report Int-reportColumn k r = fmap (\x -> r { _reportColumn = x }) (k (_reportColumn r))-{-# INLINE reportColumn #-}+reportCol :: Lens Report Int+reportCol k r = fmap (\x -> r { _reportCol = x }) (k (_reportCol r))+{-# INLINE reportCol #-}  reportFile :: Lens Report FilePath reportFile k r = fmap (\x -> r { _reportFile = x }) (k (_reportFile r))

@@ -9,7 +9,6 @@ import Data.ByteString (ByteString) import Data.Either (isLeft) import Data.Text (Text)-import GHC.Stack (HasCallStack) import Prelude hiding (getLine) import System.Random import Test.Tasty@@ -18,7 +17,11 @@ import Text.PariPari.Internal.Chunk (stringToChunk, asc_a, asc_0, asc_9) import qualified Data.Char as C import qualified Data.List.NonEmpty as NE+import Data.String (IsString(..)) +runAcceptor' :: Chunk k => Acceptor k a -> FilePath -> k -> Either Error a+runAcceptor' a f k = maybe (Left $ EFail "Nothing") Right $ runAcceptor a f k+ main :: IO () main = defaultMain tests @@ -55,31 +58,102 @@  tests :: TestTree tests = testGroup "Tests"-  [ testGroup "Chunk"-    [ testGroup "Acceptor" $ chunkTests runAcceptor-    , testGroup "Reporter" $ chunkTests runReporterEither+  [ testGroup "Acceptor"+    [ testGroup "Text"       $ parserTests @Text       runAcceptor'+    , testGroup "ByteString" $ parserTests @ByteString runAcceptor'     ] -  , testGroup "Char"-    [ testGroup "Acceptor"-      [ testGroup "Text"       $ charTests @Text       runAcceptor-      , testGroup "ByteString" $ charTests @ByteString runAcceptor-      ]--    , testGroup "Reporter"-      [ testGroup "Text"       $ charTests @Text       runReporterEither-      , testGroup "ByteString" $ charTests @ByteString runReporterEither-      ]+  , testGroup "Reporter"+    [ testGroup "Text"       $ parserTests @Text       runReporterEither+    , testGroup "ByteString" $ parserTests @ByteString runReporterEither     ]    , testGroup "Reporter specific" reporterTests   ] -charTests :: forall k p e. (CharParser k p, CharChunk k, Eq e, Show e, Show k)+parserTests :: forall k p e. (Parser k p, Chunk k, IsString k, Eq e, Show e, Show k)           => (forall a. p a -> FilePath -> k -> Either e a) -> [TestTree]-charTests run =-  [ testGroup "CharParser" $-    [ testCase "char" $ do+parserTests run =+  [ testGroup "ChunkParser"+    [ testCase "getFile" $ do+        ok getFile "" "filename"++    , testCase "getPos" $ do+        ok getPos "" (Pos 1 1)+        ok (char 'a' *> getPos) "abc" (Pos 1 2)+        ok (char 'a' *> char '\n' *> getPos) "a\nb" (Pos 2 1)+        ok (chunk "a\n" *> getPos) "a\nb" (Pos 1 3) -- chunk must not contain newlines!+        ok (char 'a' *> char '\n' *> char 'b' *> getPos) "a\nb" (Pos 2 2)++    , testCase "getRefPos" $ do+        ok getRefPos "" (Pos 1 1)+        ok (char 'a' *> getRefPos) "abc" (Pos 1 1)+        ok (char 'a' *> char '\n' *> withRefPos getRefPos) "a\nb" (Pos 2 1)+        ok (char 'a' *> char '\n' *> char 'b' *> withRefPos getRefPos) "a\nb" (Pos 2 2)+        ok (char 'a' *> char '\n' *> withRefPos (char 'b' *> getRefPos)) "a\nb" (Pos 2 1)++    , testCase "notFollowedBy" $ do+        ok (char 'a' <* notFollowedBy (char 'c')) "abc" 'a'+        err (char 'a' <* notFollowedBy (char 'b')) "abc"+        ok (char 'a' *> notFollowedBy (chunk "bd") *> char 'b') "abc" 'b'+        err (char 'a' *> notFollowedBy (chunk "bc")) "abc"+        ok (char 'a' *> notFollowedBy (char 'c') *> getPos) "abc" (Pos 1 2)++    , testCase "lookAhead" $ do+        ok (lookAhead (char 'a')) "abc" 'a'+        ok (lookAhead (char 'a') *> getPos) "abc" (Pos 1 1)+        ok (lookAhead (chunk "ab") *> getPos) "abc" (Pos 1 1)+        err (lookAhead (char 'b')) "abc"+        err (lookAhead (chunk "bd")) "abc"+        err (lookAhead (char 'a')) ""++    , testCase "failWith" $+        err (failWith (EFail "empty") :: p ()) "abc"++    , testCase "eof" $ do+        ok eof "" ()+        ok eof "\0" ()+        ok eof "\0\0" ()+        ok (chunk "abc" *> eof) "abc" ()+        ok (chunk "abc" *> eof) "abc\0" ()+        err eof "abc"+        err (chunk "ab" *> eof) "abc"++    , testCase "label" $ do+        ok (label "blub" $ char 'a') "abc" 'a'+        err (label "blub" $ char 'b') "abc"+        ok (char 'a' <?> "blub") "abc" 'a'++    , testCase "hidden" $ do+        ok (hidden $ char 'a') "abc" 'a'+        err (hidden $ char 'b') "abc"++    , testCase "try" $ do+        ok (try $ char 'a') "abc" 'a'+        err (try $ char 'b') "abc"++    , testCase "(<!>)" $ do+        ok (char 'b' <!> char 'a' <!> char 'c') "abc" 'a'+        ok (chunk "abd" <!> chunk "abc" <!> chunk "abe") "abcdef" "abc"++    , testCase "recover" $ do+        ok (recover (char 'a' <* eof) (char 'b')) "a" 'a'+        err (recover (char 'a') (char 'b')) "c"+        err (recover (char 'a' <* eof) (char 'b')) "c"++    , 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 $ anyChar *> anyChar)) "abc" "ab"+        ok (asChunk (skipCount 2 anyChar)) "abc" "ab"+        err (asChunk (void $ chunk "bc")) "abc"+        err (asChunk (void $ chunk "ab")) ""++    , testCase "char" $ do         ok (char 'a') "abc" 'a'         ok (char 'a' <* eof) "a" 'a'         err (char 'b') "abc"@@ -121,6 +195,78 @@         ok (traverse (asciiByte . fromIntegral . C.ord) s *> eof) s ()     ] +  , testGroup "Alternative"+    [ testCase "(<|>)" $ do+        ok (char 'b' <|> char 'a' <|> char 'c') "abc" 'a'+        ok (chunk "abd" <|> chunk "abc" <|> chunk "abe") "abcdef" "abc"++    , testCase "empty" $ do+        err (empty :: p ()) "abc"+        err (empty :: p ()) ""+    ]++  , testGroup "MonadFail"+    [ testCase "fail" $ do+        err (failWith (EFail "empty") :: p ()) "abc"+    ]++  , testGroup "Basic Combinators"+    [ testCase "optional" $ do+        ok (optional (char 'a')) "abc" (Just 'a')+        ok (optional (char 'b')) "abc" Nothing+        ok (optional (char 'a')) "" Nothing++    , testCase "some" $ do+        ok (some (char 'a')) "abc" (NE.fromList "a")+        ok (some (char 'a')) "aabc" (NE.fromList "aa")+        err (some (char 'b')) "abc"+        err (some (char 'a')) ""++    , testCase "many" $ do+        ok (many (char 'a')) "abc" "a"+        ok (many (char 'a')) "aabc" "aa"+        ok (many (char 'b')) "abc" ""+        ok (many (char 'a')) "" ""+    ]++  , testGroup "Position Combinators"+    [ testCase "getLine" $ do+        ok getLine "" 1+        ok (char 'a' *> getLine) "abc" 1+        ok (char 'a' *> char '\n' *> getLine) "a\nb" 2+        ok (char 'a' *> char '\n' *> char 'b' *> getLine) "a\nb" 2++    , testCase "getRefLine" $ do+        ok getRefLine "" 1+        ok (char 'a' *> getRefLine) "abc" 1+        ok (char 'a' *> char '\n' *> withRefPos getRefLine) "a\nb" 2+        ok (char 'a' *> char '\n' *> char 'b' *> withRefPos getRefLine) "a\nb" 2+        ok (char 'a' *> char '\n' *> withRefPos (char 'b' *> getRefLine)) "a\nb" 2++    , testCase "getCol" $ do+        ok getCol "" 1+        ok (char 'a' *> getCol) "abc" 2+        ok (char 'a' *> char '\n' *> getCol) "a\nb" 1+        ok (char 'a' *> char '\n' *> char 'b' *> getCol) "a\nb" 2++    , testCase "getRefCol" $ do+        ok getRefCol "" 1+        ok (char 'a' *> getRefCol) "abc" 1+        ok (char 'a' *> char '\n' *> withRefPos getRefCol) "a\nb" 1+        ok (char 'a' *> char '\n' *> char 'b' *> withRefPos getRefCol) "a\nb" 2+        ok (char 'a' *> char '\n' *> withRefPos (char 'b' *> getRefCol)) "a\nb" 1++    , testCase "withPos" $ do+        ok (withPos $ char 'a') "abc" (Pos 1 1, 'a')+        ok (char 'a' *> withPos (char 'b')) "abc" (Pos 1 2, 'b')+        ok (char 'a' *> char '\n' *> withPos (char 'b')) "a\nb" (Pos 2 1, 'b')++    , testCase "withSpan" $ do+        ok (withSpan $ chunk "ab") "abc" (Pos 1 1, Pos 1 3, "ab")+        ok (char 'a' *> withSpan (chunk "bcd")) "abcde" (Pos 1 2, Pos 1 5, "bcd")+        ok (char 'a' *> char '\n' *> withSpan (chunk "bcd")) "a\nbcde" (Pos 2 1, Pos 2 4, "bcd")+    ]+   , testGroup "Char Combinators"     [ testCase "satisfy" $ do         ok (satisfy (== 'a')) "abc" 'a'@@ -415,256 +561,20 @@   okFraction :: HasCallStack => p (Either Integer (Integer, Int, Integer)) -> String -> Either Integer (Integer, Int, Integer) -> Assertion   okFraction = ok -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 "recover" $ do-        ok (recover (element 'a' <* eof) (element 'b')) "a" 'a'-        err (recover (element 'a') (element 'b')) "c"-        err (recover (element 'a' <* eof) (element 'b')) "c"--    , 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 "elementScan" $ do-        ok (elementScan (\c -> if c == 'a' then Just c else Nothing)) "abc" 'a'-        ok (elementScan (\c -> if c == 'a' then Just c else Nothing) <* eof) "a" 'a'-        err (elementScan (\c -> if c == 'b' then Just c else Nothing)) "abc"-        err (elementScan Just) ""--        -- sentinel-        ok (elementScan (\c -> if c == '\0' then Just c else Nothing)) "\0" '\0'-        ok (elementScan (\c -> if c == '\0' then Just c else Nothing) <* eof) "\0" '\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 "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 "anyElement" $ do-        ok anyElement "abc" 'a'-        err anyElement ""--    , testCase "notElement" $ do-        ok (notElement 'b') "abc" 'a'-        err (notElement 'a') "a"-        err (notElement 'a') ""--    , testCase "takeElementsWhile" $ do-        ok (takeElementsWhile (== 'a')) "" ""-        ok (takeElementsWhile (== 'a')) "b" ""-        ok (takeElementsWhile (== 'a') <* eof) "aaa" "aaa"-        ok (takeElementsWhile (== 'a') <* element 'b') "aaab" "aaa"--    , testCase "skipElements" $ do-        ok (skipElements 0) "" ()-        ok (skipElements 3 <* eof) "abc" ()-        ok (skipElements 3 <* element 'b') "aaab" ()-        err (skipElements 1) ""-        err (skipElements 2) "a"--    , testCase "takeElements" $ do-        ok (takeElements 0) "" ""-        ok (takeElements 3 <* eof) "abc" "abc"-        ok (takeElements 3 <* element 'b') "aaab" "aaa"-        err (takeElements 1) ""-        err (takeElements 2) "a"--    , testCase "skipElementsWhile" $ do-        ok (skipElementsWhile (== 'a')) "" ()-        ok (skipElementsWhile (== 'a')) "b" ()-        ok (skipElementsWhile (== 'a') *> eof) "aaa" ()-        ok (skipElementsWhile (== 'a') *> element 'b') "aaab" 'b'--    , testCase "skipElementsWhile1" $ do-        err (skipElementsWhile1 (== 'a')) ""-        err (skipElementsWhile1 (== 'a')) "b"-        ok (skipElementsWhile1 (== 'a') *> eof) "aaa" ()-        ok (skipElementsWhile1 (== 'a') *> element 'b') "aaab" 'b'--    , testCase "takeElementsWhile1" $ do-        err (takeElementsWhile1 (== 'a')) ""-        err (takeElementsWhile1 (== 'a')) "b"-        ok (takeElementsWhile1 (== 'a') <* eof) "aaa" "aaa"-        ok (takeElementsWhile1 (== 'a') <* element 'b') "aaab" "aaa"-    ]--  , 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- reporterTests :: [TestTree] reporterTests =   [ testCase "recover" $ do-      run (element 'a' <* eof) "a" (Just 'a', 0)-      run (element 'a') "b" (Nothing, 1)-      run (recover (element 'a' <* eof) (element 'b')) "a" (Just 'a', 0)-      run (recover (element 'a') (element 'b')) "b" (Just 'b', 1)+      run (char 'a' <* eof) "a" (Just 'a', 0)+      run (char 'a') "b" (Nothing, 1)+      run (recover (char 'a' <* eof) (char 'b')) "a" (Just 'a', 0)+      run (recover (char 'a') (char 'b')) "b" (Just 'b', 1)       run ((,)-            <$> recover (element 'a') (element 'b')-            <*> recover (element 'a') (element 'c')) "bc" (Just ('b', 'c'), 2)-      run (recover (element 'a') (element 'b') *>-           recover (element 'a') (element 'c') *>-           element 'a') "bcd" (Nothing, 3)-      run (recover (element 'a' <* eof) (element 'b')) "c" (Nothing, 1)+            <$> recover (char 'a') (char 'b')+            <*> recover (char 'a') (char 'c')) "bc" (Just ('b', 'c'), 2)+      run (recover (char 'a') (char 'b') *>+           recover (char 'a') (char 'c') *>+           char 'a') "bcd" (Nothing, 3)+      run (recover (char 'a' <* eof) (char 'b')) "c" (Nothing, 1)   ]   where   run :: (Eq a, Show a, HasCallStack) => Reporter Text a -> Text -> (Maybe a, Int) -> Assertion@@ -716,10 +626,6 @@ Fraction: fraction fractionHex--Element Combinators:-scanElements-scanElements1  Char Combinators: scanChars