gigaparsec 0.2.5.1 → 0.3.0.0

raw patch · 17 files changed

+235/−211 lines, 17 filesdep +rtPVP ok

version bump matches the API change (PVP)

Dependencies added: rt

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• gigaparsec.cabal +10/−5
• src/Text/Gigaparsec.hs +7/−7
• src/Text/Gigaparsec/Debug.hs +10/−10
• src/Text/Gigaparsec/Errors/DefaultErrorBuilder.hs +12/−12
• src/Text/Gigaparsec/Errors/ErrorBuilder.hs +24/−23
• src/Text/Gigaparsec/Internal.hs +1/−1
• src/Text/Gigaparsec/Internal/Errors/ParseError.hs +6/−7
• src/Text/Gigaparsec/Internal/RT.hs +0/−52
• src/Text/Gigaparsec/Internal/Token/Lexer.hs +4/−4
• src/Text/Gigaparsec/Internal/Token/Text.hs +7/−7
• src/Text/Gigaparsec/Patterns.hs +41/−5
• src/Text/Gigaparsec/Registers.hs +0/−71
• src/Text/Gigaparsec/State.hs +95/−0
• test/Text/Gigaparsec/DebugTests.hs +5/−4
• test/Text/Gigaparsec/Internal/Test.hs +1/−1
• test/Text/Gigaparsec/Internal/TestError.hs +2/−2

@@ -1,5 +1,15 @@ # Revision history for gigaparsec +## 0.3.0.0 -- TBD+* Generalised `deriveLiftedConstructors`/`deriveDeferredConstructors` functionality to also work+  with pattern synonyms and `forall`s in more places.+* Added line numbering for the line information in the `ErrorBuilder`.+* Renamed the `format` method of the `ErrorBuilder` to `build`.+* Removed `RT` from the library's internals, it is now part of the `rt` package.+* Renamed `Registers` to `State`, and made some combinators more consistent with `parsley`:+    * `put` -> `set`, `puts` -> `sets`, `local` -> `updateDuring`, `localWith` -> `setDuring`+* Added `for` combinators.+ ## 0.2.5.1 -- 2024-02-07 * Fixed bug where hints can be revived by the `hide` combinator. 

@@ -20,11 +20,11 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version:            0.2.5.1+version:            0.3.0.0  -- A short (one-line) description of the package. synopsis:-    Refreshed parsec-style library for compatiblity with Scala parsley+    Refreshed parsec-style library for compatibility with Scala parsley  -- A longer description of the package. description:@@ -75,6 +75,10 @@     -- 4.14 is GHC 8.10 (the 2022 State of Haskell indicates 41% still use 8.10)     build-depends:    base >=4.14 && < 5 +source-repository head+    type:     git+    location: git://github.com/j-mie6/gigaparsec.git+ library     import:           warnings, extensions, base @@ -96,7 +100,7 @@                       Text.Gigaparsec.Expr.Subtype,                       Text.Gigaparsec.Patterns,                       Text.Gigaparsec.Position,-                      Text.Gigaparsec.Registers,+                      Text.Gigaparsec.State,                       Text.Gigaparsec.Token.Descriptions,                       Text.Gigaparsec.Token.Errors,                       Text.Gigaparsec.Token.Lexer,@@ -112,7 +116,6 @@                       Text.Gigaparsec.Internal.Errors.DefuncTypes,                       Text.Gigaparsec.Internal.Errors.ErrorItem,                       Text.Gigaparsec.Internal.Errors.ParseError,-                      Text.Gigaparsec.Internal.RT,                       Text.Gigaparsec.Internal.Require,                       Text.Gigaparsec.Internal.Token.BitBounds,                       Text.Gigaparsec.Internal.Token.Errors,@@ -127,7 +130,8 @@     build-depends:    containers       >= 0.6   && < 0.7,                       selective        >= 0.6   && < 0.8,                       pretty-terminal  >= 0.1.0 && < 0.2,-                      template-haskell >= 2.16  && < 3+                      template-haskell >= 2.16  && < 3,+                      rt               >= 0.1   && < 0.2      -- Modules included in this library but not exported.     -- other-modules:@@ -197,6 +201,7 @@         --tasty-bench         -- we'd need to keep the basefile files somewhere, cache in CI or keep in repo?         knob >=0.1.1 && <0.3,+        rt >= 0.1 && < 0.2,  benchmark perf-test     import:           warnings, extensions, base

@@ -83,7 +83,6 @@  import Text.Gigaparsec.Internal (Parsec(Parsec), emptyState, manyr, somer) import Text.Gigaparsec.Internal qualified as Internal (State(..), useHints, expectedErr)-import Text.Gigaparsec.Internal.RT qualified as Internal (RT, runRT, rtToIO) import Text.Gigaparsec.Internal.Errors qualified as Internal (Error, ExpectItem(ExpectEndOfInput), fromError)  import Text.Gigaparsec.Errors.ErrorBuilder (ErrorBuilder)@@ -93,6 +92,7 @@ import Data.Functor (void) import Control.Applicative (liftA2, (<|>), empty, many, some, (<**>)) -- liftA2 required until 9.6 import Control.Selective (select, branch)+import Control.Monad.RT (RT, runRT, rtToIO)  import Data.Set qualified as Set (singleton, empty) import GHC.Generics (Generic)@@ -137,7 +137,7 @@       => Parsec a     -- ^ the parser to execute       -> String       -- ^ the input to parse       -> Result err a -- ^ result of the parse, either an error or result-parse p inp = Internal.runRT $ _parse Nothing p inp+parse p inp = runRT $ _parse Nothing p inp  {-| Runs a parser against some input, pretty-printing the result to the terminal.@@ -154,7 +154,7 @@           -> String   -- ^ the input to parse           -> IO () parseRepl p inp =-  do res <- Internal.rtToIO $ _parse Nothing p inp+  do res <- rtToIO $ _parse Nothing p inp      result putStrLn print res  {-# SPECIALISE parseFromFile :: Parsec a -> String -> IO (Result String a) #-}@@ -180,16 +180,16 @@               -> IO (Result err a) -- ^ the result of the parse, error or otherwise parseFromFile p f =   do inp <- readFile f-     Internal.rtToIO $ _parse (Just f) p inp+     rtToIO $ _parse (Just f) p inp  --TODO: parseFromHandle?  {-# INLINE _parse #-}-_parse :: forall err a. ErrorBuilder err => Maybe FilePath -> Parsec a -> String -> Internal.RT (Result err a)+_parse :: forall err a. ErrorBuilder err => Maybe FilePath -> Parsec a -> String -> RT (Result err a) _parse file (Parsec p) inp = p (emptyState inp) good bad-  where good :: a -> Internal.State -> Internal.RT (Result err a)+  where good :: a -> Internal.State -> RT (Result err a)         good x _  = return (Success x)-        bad :: Internal.Error -> Internal.State -> Internal.RT (Result err a)+        bad :: Internal.Error -> Internal.State -> RT (Result err a)         bad err _ = return (Failure (Internal.fromError file inp err))  {-|

@@ -15,11 +15,11 @@ module Text.Gigaparsec.Debug (debug, debugWith, debugConfig, DebugConfig(..), WatchedReg(..), Break(..)) where  import Text.Gigaparsec.Internal (Parsec)-import Text.Gigaparsec.Internal.RT (Reg, readReg) import Text.Gigaparsec.Internal qualified as Internal-import Text.Gigaparsec.Internal.RT qualified as Internal +import Data.Ref (Ref, readRef) import Control.Monad (when, forM)+import Control.Monad.RT.Unsafe (RT, unsafeIOToRT) import System.IO (hGetEcho, hSetEcho, hPutStr, stdin, stdout, Handle) import Data.List (intercalate, isPrefixOf) import Data.List.NonEmpty (NonEmpty((:|)), (<|))@@ -54,7 +54,7 @@ -} type WatchedReg :: * data WatchedReg = forall r a. Show a => WatchedReg String    -- ^ the name of the register-                                                   (Reg r a) -- ^ the register itself+                                                   (Ref r a) -- ^ the register itself  {-| This is used by 'DebugConfig' to specify whether the parsing should be paused@@ -94,7 +94,7 @@ debugWith :: DebugConfig -> String -> Parsec a -> Parsec a debugWith config@DebugConfig{ascii} name (Internal.Parsec p) = Internal.Parsec $ \st good bad -> do   -- TODO: could make it so the postamble can print input information from the entry?-  ascii' <- (\colourful -> ascii || not colourful) <$> Internal.unsafeIOToRT supportsPretty+  ascii' <- (\colourful -> ascii || not colourful) <$> unsafeIOToRT supportsPretty   let config' = config { ascii = ascii' }   doDebug name Enter st ""  config'   let good' x st' = do@@ -127,12 +127,12 @@ shouldBreak Enter = breakOnEntry shouldBreak Exit = breakOnExit -doDebug :: String -> Direction -> Internal.State -> String -> DebugConfig -> Internal.RT ()+doDebug :: String -> Direction -> Internal.State -> String -> DebugConfig -> RT () doDebug name dir st end DebugConfig{..} = do   printInfo handle name dir st end ascii watchedRegs   when (shouldBreak dir breakPoint) waitForUser -printInfo :: Handle -> String -> Direction -> Internal.State -> String -> Bool -> [WatchedReg] -> Internal.RT ()+printInfo :: Handle -> String -> Direction -> Internal.State -> String -> Bool -> [WatchedReg] -> RT () printInfo handle name dir st@Internal.State{input, line, col} end ascii regs = do   let cs = replace "\n" (newline ascii)          . replace " " (space ascii)@@ -146,12 +146,12 @@     if null regs then return []     else (++ [""]) . ("watched registers:" :) <$>       forM regs (\(WatchedReg rname reg) ->-        (\x -> "    " ++ rname ++ " = " ++ show x) <$> readReg reg)-  Internal.unsafeIOToRT $+        (\x -> "    " ++ rname ++ " = " ++ show x) <$> readRef reg)+  unsafeIOToRT $     hPutStr handle $ indentAndUnlines st ((prelude ++ cs' ++ end) : caret : regSummary) -waitForUser :: Internal.RT ()-waitForUser = Internal.unsafeIOToRT $ do+waitForUser :: RT ()+waitForUser = unsafeIOToRT $ do   echo <- hGetEcho stdin   hSetEcho stdin False   putStrLn "..."

@@ -31,9 +31,9 @@ from :: Show a => a -> StringBuilder from = StringBuilder . shows -{-# INLINABLE formatDefault #-}-formatDefault :: StringBuilder -> Maybe StringBuilder -> [StringBuilder] -> String-formatDefault pos source lines = toString (blockError header lines 2)+{-# INLINABLE buildDefault #-}+buildDefault :: StringBuilder -> Maybe StringBuilder -> [StringBuilder] -> String+buildDefault pos source lines = toString (blockError header lines 2)   where header = maybe mempty (\src -> "In " <> src <> " ") source <> pos  {-# INLINABLE vanillaErrorDefault #-}@@ -114,21 +114,21 @@   where pre = replicate indent ' '  {-# INLINABLE lineInfoDefault #-}-lineInfoDefault :: String -> [String] -> [String] -> Word -> Word -> [StringBuilder]-lineInfoDefault curLine beforeLines afterLines pointsAt width =+lineInfoDefault :: String -> [String] -> [String] -> Word -> Word -> Word -> [StringBuilder]+lineInfoDefault curLine beforeLines afterLines _line pointsAt width =   concat [map inputLine beforeLines, [inputLine curLine, caretLine], map inputLine afterLines]   where inputLine :: String -> StringBuilder         inputLine = fromString . ('>' :)         caretLine :: StringBuilder         caretLine = fromString (replicate (fromIntegral (pointsAt + 1)) ' ') <> fromString (replicate (fromIntegral width) '^') -{-# INLINABLE formatPosDefault #-}-formatPosDefault :: Word -> Word -> StringBuilder-formatPosDefault line col = "(line "-                         <> from line-                         <> ", column "-                         <> from col-                         <> ")"+{-# INLINABLE posDefault #-}+posDefault :: Word -> Word -> StringBuilder+posDefault line col = "(line "+                   <> from line+                   <> ", column "+                   <> from col+                   <> ")"  {-# INLINABLE intercalate #-} intercalate :: Monoid m => m -> [m] -> m

@@ -2,12 +2,12 @@ {-# LANGUAGE TypeFamilies, AllowAmbiguousTypes, FlexibleInstances, FlexibleContexts #-} {-| Module      : Text.Gigaparsec.Errors.ErrorBuilder-Description : This typeclass specifies how to format an error from a parser as a specified type.+Description : This typeclass specifies how to generate an error from a parser as a specified type. License     : BSD-3-Clause Maintainer  : Jamie Willis, Gigaparsec Maintainers Stability   : stable -This typeclass specifies how to format an error from a parser+This typeclass specifies how to generate an error from a parser as a specified type.  An instance of this typeclass is required when calling 'Text.Gigaparsec.parse'@@ -117,12 +117,12 @@ -- TODO: at 0.3.0.0, remove the Token re-export, because hs-boot doesn't carry docs module Text.Gigaparsec.Errors.ErrorBuilder (ErrorBuilder(..), Token(..)) where -import Text.Gigaparsec.Errors.DefaultErrorBuilder ( StringBuilder, formatDefault+import Text.Gigaparsec.Errors.DefaultErrorBuilder ( StringBuilder, buildDefault                                                   , vanillaErrorDefault, specialisedErrorDefault                                                   , rawDefault, namedDefault, endOfInputDefault                                                   , expectedDefault, unexpectedDefault                                                   , disjunct, combineMessagesDefault-                                                  , formatPosDefault, lineInfoDefault+                                                  , posDefault, lineInfoDefault                                                   ) import {-# SOURCE #-} Text.Gigaparsec.Errors.TokenExtractors (Token(Named, Raw), tillNextWhitespace) @@ -135,32 +135,32 @@ import Data.Void (Void)  {-|-This class describes how to format an error message generated by a parser into-a form the parser writer desires.+This class describes how to construct an error message generated by a parser in+a represention the parser writer desires. -} type ErrorBuilder :: * -> Constraint-class (Ord (Item err)) => ErrorBuilder err where+class Ord (Item err) => ErrorBuilder err where   {-|-  This is the top level function, which finally compiles all the formatted+  This is the top level function, which finally compiles all the built   sub-parts into a finished value of type @err@.   -}-  format :: Position err       -- ^ the representation of the position of the error in the input (see the 'pos' method).-         -> Source err         -- ^ the representation of the filename, if it exists (see the 'source' method).-         -> ErrorInfoLines err -- ^ the main body of the error message (see 'vanillaError' or 'specialisedError' methods).-         -> err                -- ^ the final error message+  build :: Position err       -- ^ the representation of the position of the error in the input (see the 'pos' method).+        -> Source err         -- ^ the representation of the filename, if it exists (see the 'source' method).+        -> ErrorInfoLines err -- ^ the main body of the error message (see 'vanillaError' or 'specialisedError' methods).+        -> err                -- ^ the final error message    -- | The representation type of position information within the generated message.   type Position err   -- | The representation of the file information.   type Source err   {-|-  Formats a position into the representation type given by 'Position'.+  Converts a position into the representation type given by 'Position'.   -}   pos :: Word         -- ^ the line the error occurred at.       -> Word         -- ^ the column the error occurred at.       -> Position err -- ^ a representation of the position.   {-|-  Formats the name of the file parsed from, if it exists, into the type given by 'Source'.+  Converts the name of the file parsed from, if it exists, into the type given by 'Source'.   -}   source :: Maybe FilePath -- ^ the source name of the file, if any.          -> Source err@@ -239,12 +239,13 @@           -> Message err    {-|-  Describes how to format the information about the line that the error occured on,+  Describes how to process the information about the line that the error occured on,   and its surrounding context.   -}   lineInfo :: String   -- ^ the full line of input that produced this error message.            -> [String] -- ^ the lines of input from just before the one that produced this message (up to 'numLinesBefore').            -> [String] -- ^ the lines of input from just after the one that produced this message (up to 'numLinesAfter').+           -> Word     -- ^ the line number of the error message            -> Word     -- ^ the offset into the line that the error points at.            -> Word     -- ^ how wide the caret in the message should be.            -> LineInfo err@@ -259,12 +260,12 @@   type Item err    {-|-  Formats a raw item generated by either the input string or a input+  Converts a raw item generated by either the input string or a input   reading combinator without a label.   -}   raw :: String -- ^ the raw, unprocessed input.       -> Item err-  -- | Formats a named item generated by a label.+  -- | Converts a named item generated by a label.   named :: String -- ^ the name given to the label.         -> Item err   -- | Value that represents the end of the input in the error message.@@ -290,18 +291,18 @@                   -> Token         -- ^ a token extracted from @cs@ that will be used as part of the unexpected message.  {-|-Formats error messages as a string, using the functions found in+Builds error messages as @String@, using the functions found in "Text.Gigaparsec.Errors.DefaultErrorBuilder". -} instance ErrorBuilder String where-  {-# INLINE format #-}-  format = formatDefault+  {-# INLINE build #-}+  build = buildDefault    type Position String = StringBuilder   type Source String = Maybe StringBuilder    {-# INLINE pos #-}-  pos = formatPosDefault+  pos = posDefault   {-# INLINE source #-}   source = fmap fromString @@ -357,7 +358,7 @@ Can be used to ignore error messages, by just returning a @()@. -} instance ErrorBuilder () where-  format _ _ _ = ()+  build _ _ _ = ()   type Position () = ()   type Source () = ()   type ErrorInfoLines () = ()@@ -392,7 +393,7 @@ uninhabited. -} instance ErrorBuilder Void where-  format = undefined+  build = undefined   type Position Void = Void   type Source Void = Void   type ErrorInfoLines Void = Void

@@ -17,7 +17,7 @@ -} module Text.Gigaparsec.Internal (module Text.Gigaparsec.Internal) where -import Text.Gigaparsec.Internal.RT (RT)+import Control.Monad.RT (RT) import Text.Gigaparsec.Internal.Errors (Error, Hints, ExpectItem, CaretWidth) import Text.Gigaparsec.Internal.Errors qualified as Errors (     emptyErr, expectedErr, specialisedErr, mergeErr, unexpectedErr,

@@ -38,22 +38,21 @@ {-# INLINABLE fromParseError #-} fromParseError :: forall err. ErrorBuilder err => Maybe FilePath -> String -> ParseError -> err fromParseError srcFile input err =-  Builder.format (Builder.pos @err (line err) (col err)) (Builder.source @err srcFile)-                 (formatErr err)-  where formatErr :: ParseError -> Builder.ErrorInfoLines err-        formatErr VanillaError{..} =+  Builder.build (Builder.pos @err (line err) (col err)) (Builder.source @err srcFile) (buildErr err)+  where buildErr :: ParseError -> Builder.ErrorInfoLines err+        buildErr VanillaError{..} =           Builder.vanillaError @err             (Builder.unexpected @err (either (const Nothing) (Just . fst) unexpectedTok))             (Builder.expected @err (Builder.combineExpectedItems @err (Set.map expectItem expecteds)))             (Builder.combineMessages @err (Set.foldr (\r -> (Builder.reason @err r :)) [] reasons))-            (Builder.lineInfo @err curLine linesBefore linesAfter caret (trimToLine caretSize))+            (Builder.lineInfo @err curLine linesBefore linesAfter line caret (trimToLine caretSize))           where unexpectedTok = unexpectItem lexicalError <$> unexpected                 caretSize = either id snd unexpectedTok -        formatErr SpecialisedError{..} =+        buildErr SpecialisedError{..} =           Builder.specialisedError @err             (Builder.combineMessages @err (map (Builder.message @err) msgs))-            (Builder.lineInfo @err curLine linesBefore linesAfter caret (trimToLine caretWidth))+            (Builder.lineInfo @err curLine linesBefore linesAfter line caret (trimToLine caretWidth))          expectItem :: ExpectItem -> Builder.Item err         expectItem (ExpectRaw t) = Builder.raw @err t

@@ -1,52 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE DataKinds, MagicHash, RoleAnnotations, UnboxedTuples, DerivingVia #-}-{-# OPTIONS_HADDOCK hide #-}-module Text.Gigaparsec.Internal.RT (module Text.Gigaparsec.Internal.RT) where--import GHC.Base (MutVar#, RealWorld, State#, runRW#, newMutVar#, readMutVar#, writeMutVar#)--import Data.Coerce (coerce)-import GHC.IO (IO(IO))-import GHC.IORef (IORef(IORef))-import GHC.STRef (STRef(STRef))--type Reg :: * -> * -> *-type role Reg phantom representational--- Don't even expose the constructor, then it's pretty much safe-data Reg r a = Reg (MutVar# RealWorld a)--type RT :: * -> *-newtype RT a = RT (State# RealWorld -> (# State# RealWorld, a #))-  deriving (Functor, Applicative, Monad) via IO--{-# INLINE runRT #-}-runRT :: RT a -> a-runRT (RT mx) = case runRW# mx of (# _, x #) -> x--{-# INLINABLE newReg #-}-newReg :: a -> (forall r. Reg r a -> RT b) -> RT b-newReg x k = RT $ \s# ->-  case newMutVar# x s# of-    (# s'#, reg# #) -> let RT k' = k (Reg reg#) in k' s'#--{-# INLINE readReg #-}-readReg :: Reg r a -> RT a-readReg (Reg reg#) = RT $ \s# -> readMutVar# reg# s#--{-# INLINABLE writeReg #-}-writeReg :: Reg r a -> a -> RT ()-writeReg (Reg reg#) x = RT $ \s# ->-  case writeMutVar# reg# x s# of-    s'# -> (# s'#, () #)--{-# INLINE unsafeIOToRT #-}-unsafeIOToRT :: IO a -> RT a-unsafeIOToRT = coerce--{-# INLINE rtToIO #-}-rtToIO :: RT a -> IO a-rtToIO = coerce--{-# INLINE fromIORef #-}-fromIORef :: IORef a -> Reg r a-fromIORef (IORef (STRef reg#)) = Reg reg#

@@ -17,7 +17,7 @@ import Text.Gigaparsec (Parsec, eof, void, empty, (<|>), atomic, unit) import Text.Gigaparsec.Char (satisfy, string, item, endOfLine) import Text.Gigaparsec.Combinator (skipMany, skipManyTill)-import Text.Gigaparsec.Registers (put, get, localWith, rollback)+import Text.Gigaparsec.State (set, get, setDuring, rollback) import Text.Gigaparsec.Errors.Combinator (hide)  import Text.Gigaparsec.Token.Descriptions qualified as Desc@@ -44,11 +44,11 @@   ) import Text.Gigaparsec.Internal.Token.Text qualified as Text (lexeme) -import Text.Gigaparsec.Internal.RT (fromIORef) import Text.Gigaparsec.Internal.Require (require)  import Data.List (isPrefixOf) import Data.IORef (newIORef)+import Data.Ref (fromIORef) import Control.Exception (Exception, throw) import Control.Monad (join, guard) import System.IO.Unsafe (unsafePerformIO)@@ -172,10 +172,10 @@           | otherwise                    = configuredWhitespace         !skipComments = skipMany (comment errConfig)         alter p-          | whitespaceIsContextDependent = rollback wsImpl . localWith wsImpl (implOf p)+          | whitespaceIsContextDependent = rollback wsImpl . setDuring wsImpl (implOf p)           | otherwise                    = throw (UnsupportedOperation badAlter)         initSpace-          | whitespaceIsContextDependent = put wsImpl configuredWhitespace+          | whitespaceIsContextDependent = set wsImpl configuredWhitespace           | otherwise                    = throw (UnsupportedOperation badInit)         badInit = "whitespace cannot be initialised unless `spaceDesc.whitespaceIsContextDependent` is True"         badAlter = "whitespace cannot be altered unless `spaceDesc.whitespaceIsContextDependent` is True"

@@ -40,7 +40,7 @@ import Data.Set (Set) import Data.Set qualified as Set (toList) import Data.List.NonEmpty (NonEmpty((:|)), sort)-import Text.Gigaparsec.Registers (Reg, make, unsafeMake, gets, modify, put, get)+import Text.Gigaparsec.State (Ref, make, unsafeMake, gets, update, set, get) import Text.Gigaparsec.Combinator (guardS, choice, manyTill) import Control.Applicative (liftA3) import Data.Maybe (catMaybes)@@ -167,11 +167,11 @@              | c < toInteger (ord maxValue) = Just (chr (fromInteger c))              | otherwise = Nothing -    atMost' :: Int -> Parsec Char -> Reg r Word -> Parsec Integer+    atMost' :: Int -> Parsec Char -> Ref r Word -> Parsec Integer     atMost' radix dig atMostR =       -- FIXME: surely this is an inefficient mess with the translations?       somel (\n d -> n * toInteger radix + toInteger (digitToInt d)) 0-            (guardS (gets atMostR (> 0)) *> dig <* modify atMostR pred)+            (guardS (gets atMostR (> 0)) *> dig <* update atMostR pred)      atMost :: Word -> Int -> Parsec Char -> Parsec Integer     atMost n radix dig = make n (atMost' radix dig)@@ -182,15 +182,15 @@                  (\(num, m) -> if m == full then Just num else Nothing)                  (atMost' radix dig atMostR <~> gets atMostR (full -)) -    oneOfExactly' :: NonEmpty Word -> Word -> Word -> [Word] -> Int -> Parsec Char -> Reg r Word -> Parsec Integer+    oneOfExactly' :: NonEmpty Word -> Word -> Word -> [Word] -> Int -> Parsec Char -> Ref r Word -> Parsec Integer     oneOfExactly' reqDigits digits m [] radix dig digitsParsed =-      exactly digits m radix dig reqDigits <* put digitsParsed digits+      exactly digits m radix dig reqDigits <* set digitsParsed digits     oneOfExactly' reqDigits digits m (n:ns) radix dig digitsParsed =       let theseDigits = exactly digits m radix dig reqDigits           restDigits =                 atomic (Just <$> oneOfExactly' reqDigits (n - m) n ns radix dig digitsParsed-                     <* modify digitsParsed (+ digits))-            <|> put digitsParsed digits $> Nothing+                     <* update digitsParsed (+ digits))+            <|> set digitsParsed digits $> Nothing           combine !x Nothing !_ = x           -- digits is removed here, because it's been added before the get           combine x (Just y) e = x * toInteger radix ^ (e - digits) + y

@@ -31,7 +31,7 @@ import Language.Haskell.TH (     Q, Exp, Name, Dec,     Type (ForallT, AppT, ArrowT, StarT, ConT),-    Info (DataConI), TyVarBndr (KindedTV, PlainTV),+    Info (DataConI, PatSynI), TyVarBndr (KindedTV, PlainTV),     sigD, funD, clause, varP, normalB, varE, reify, mkName, newName,     isExtEnabled, Extension (KindSignatures),     forallT, conE, lamE@@ -48,7 +48,7 @@ means adding a single @'@ in front of the constructor name. For example:  > {-# LANGUAGE TemplateHaskell #-}-> data Foo = Foo a | Bar Int String+> data Foo a = Foo a | Bar Int String > $(deriveLiftedConstructors "mk" ['Foo, 'Bar])  Will generate two lifted constructors of the shape:@@ -61,6 +61,21 @@ of the generated constructor.  @since 0.2.2.0++Pattern synonyms can be used to set type parameters to `Text.Gigaparsec.Position.Pos`:++> {-# LANGUAGE PatternSynonyms #-}+> pattern PosFoo :: Pos -> Foo Pos+> pattern PosFoo p = Foo p+> $(deriveLiftedConstructors "mk" ['PosFoo])++This will generate a lifted constructor of the shape:++> mkPosFoo :: Parsec (Foo Pos)++The @pos@ combinator will be applied automatically.++@since 0.2.6.0 -} deriveLiftedConstructors :: String -- ^ The prefix to be added to generated names                          -> [Name] -- ^ The list of "ticked" constructors to generate for@@ -88,7 +103,7 @@ means adding a single @'@ in front of the constructor name. For example:  > {-# LANGUAGE TemplateHaskell #-}-> data Foo = Foo a | Bar Int String+> data Foo a = Foo a | Bar Int String > $(deriveDeferredConstructors "mk" ['Foo, 'Bar])  Will generate two deferred constructors of the shape:@@ -101,6 +116,21 @@ of the generated constructor.  @since 0.2.2.0++Pattern synonyms can be used to set type parameters to `Text.Gigaparsec.Position.Pos`:++> {-# LANGUAGE PatternSynonyms #-}+> pattern PosFoo :: Pos -> Foo Pos+> pattern PosFoo p = Foo p+> $(deriveLiftedConstructors "mk" ['PosFoo])++This will generate a lifted constructor of the shape:++> mkPosFoo :: Parsec (Foo Pos)++The @pos@ combinator will be applied automatically.++@since 0.2.6.0 -} deriveDeferredConstructors :: String -- ^ The prefix to be added to generated names                            -> [Name] -- ^ The list of "ticked" constructors to generate for@@ -124,10 +154,15 @@ parserOf :: Q Type -> Q Type parserOf ty = [t| Parsec $ty |] +extractConType :: Info -> Maybe Type+extractConType (DataConI _ ty _) = Just ty+extractConType (PatSynI _ ty) = Just ty+extractConType _ = Nothing+ extractMeta :: Bool -> String -> ([Q Type] -> Q Type) -> Name           -> Q (Name, Q Type, Q Exp, Bool, Int) extractMeta posLast prefix buildType con = do-  DataConI _ ty _ <- reify con+  Just ty <- fmap extractConType $ reify con   (forAll, tys) <- splitFun ty   posIdx <- findPosIdx con tys   let tys' = maybeApply deleteAt posIdx tys@@ -140,7 +175,8 @@ splitFun (ForallT bndrs ctx ty) = do   kindSigs <- isExtEnabled KindSignatures   let bndrs' = if kindSigs then bndrs else map sanitiseStarT bndrs-  return (forallT bndrs' (pure ctx), splitFun' ty)+  (forallT', ty') <- splitFun ty+  return (forallT bndrs' (pure ctx) . forallT', ty') splitFun ty                     = return (id, splitFun' ty)  splitFun' :: Type -> [Type]

@@ -1,71 +0,0 @@-{-# LANGUAGE Trustworthy #-}-module Text.Gigaparsec.Registers (-    Reg,-    make, unsafeMake,-    get, gets,-    put, puts,-    modify,-    local, localWith,-    rollback-  ) where--import Text.Gigaparsec (Parsec, (<|>), empty)-import Text.Gigaparsec.Internal.RT (Reg, newReg, readReg, writeReg)-import Text.Gigaparsec.Internal qualified as Internal (Parsec(..))--unsafeMake :: (forall r. Reg r a -> Parsec b) -> Parsec b-unsafeMake = make (error "reference used but not set")--_make :: Parsec a -> (forall r. Reg r a -> Parsec b) -> Parsec b-_make p f = p >>= \x -> make x f--make :: a -> (forall r. Reg r a -> Parsec b) -> Parsec b-make x f = Internal.Parsec $ \st good bad ->-  newReg x $ \reg ->-    let Internal.Parsec p = f reg-    in p st good bad--get :: Reg r a -> Parsec a-get reg = Internal.Parsec $ \st good _ ->-  do x <- readReg reg-     good x st---- parsley provides multiple overloadings...-_gets :: Reg r a -> Parsec (a -> b) -> Parsec b-_gets reg pf = pf <*> get reg--gets :: Reg r a -> (a -> b) -> Parsec b-gets reg f = f <$> get reg--_put :: Reg r a -> Parsec a -> Parsec ()-_put reg px = px >>= put reg--put :: Reg r a -> a -> Parsec ()-put reg x = Internal.Parsec $ \st good _ ->-  do writeReg reg x-     good () st--puts :: Reg r b -> (a -> b) -> Parsec a -> Parsec ()-puts reg f px = _put reg (f <$> px)--_modify :: Reg r a -> Parsec (a -> a) -> Parsec ()-_modify reg pf = _put reg (_gets reg pf)--modify :: Reg r a -> (a -> a) -> Parsec ()-modify reg f = _put reg (gets reg f)--local :: Reg r a -> (a -> a) -> Parsec b -> Parsec b-local reg f p = do x <- get reg-                   put reg (f x)-                   p <* put reg x--localWith :: Reg r a -> a -> Parsec b -> Parsec b-localWith reg x = local reg (const x)--_localWith :: Reg r a -> Parsec a -> Parsec b -> Parsec b-_localWith reg px q = px >>= flip (localWith reg) q--rollback :: Reg r a -> Parsec a -> Parsec a-rollback reg p = get reg >>= \x -> p <|> (put reg x *> empty)---- TODO: for combinators

@@ -0,0 +1,95 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE BlockArguments #-}+module Text.Gigaparsec.State (+    Ref,+    make, unsafeMake,+    get, gets,+    set, sets,+    update,+    updateDuring, setDuring,+    rollback,+    forP, forP', forP_, forP'_+  ) where++import Text.Gigaparsec (Parsec, (<|>), empty)+import Text.Gigaparsec.Internal qualified as Internal (Parsec(..))++import Text.Gigaparsec.Combinator (ifS, whenS)++import Data.Ref (Ref, newRef, readRef, writeRef)++unsafeMake :: (forall r. Ref r a -> Parsec b) -> Parsec b+unsafeMake = make (error "reference used but not set")++_make :: Parsec a -> (forall r. Ref r a -> Parsec b) -> Parsec b+_make p f = p >>= \x -> make x f++make :: a -> (forall r. Ref r a -> Parsec b) -> Parsec b+make x f = Internal.Parsec $ \st good bad ->+  newRef x $ \ref ->+    let Internal.Parsec p = f ref+    in p st good bad++get :: Ref r a -> Parsec a+get ref = Internal.Parsec $ \st good _ ->+  do x <- readRef ref+     good x st++-- parsley provides multiple overloadings...+_gets :: Ref r a -> Parsec (a -> b) -> Parsec b+_gets ref pf = pf <*> get ref++gets :: Ref r a -> (a -> b) -> Parsec b+gets ref f = f <$> get ref++_set :: Ref r a -> Parsec a -> Parsec ()+_set ref px = px >>= set ref++set :: Ref r a -> a -> Parsec ()+set ref x = Internal.Parsec $ \st good _ ->+  do writeRef ref x+     good () st++sets :: Ref r b -> (a -> b) -> Parsec a -> Parsec ()+sets ref f px = _set ref (f <$> px)++_update :: Ref r a -> Parsec (a -> a) -> Parsec ()+_update ref pf = _set ref (_gets ref pf)++update :: Ref r a -> (a -> a) -> Parsec ()+update ref f = _set ref (gets ref f)++updateDuring :: Ref r a -> (a -> a) -> Parsec b -> Parsec b+updateDuring ref f p = do x <- get ref+                          set ref (f x)+                          p <* set ref x++setDuring :: Ref r a -> a -> Parsec b -> Parsec b+setDuring ref x = updateDuring ref (const x)++_setDuring :: Ref r a -> Parsec a -> Parsec b -> Parsec b+_setDuring ref px q = px >>= flip (setDuring ref) q++rollback :: Ref r a -> Parsec b -> Parsec b+rollback ref p = get ref >>= \x -> p <|> (set ref x *> empty)++forP :: Parsec a -> Parsec (a -> Bool) -> Parsec (a -> a) -> Parsec b -> Parsec [b]+forP ini cond step = forP' ini cond step . const++forP' :: Parsec a -> Parsec (a -> Bool) -> Parsec (a -> a) -> (a -> Parsec b) -> Parsec [b]+forP' ini cond step body = ini >>= go+  where go i = flip (ifS (cond <*> pure i)) (pure []) do+                  x <- body i+                  f <- step+                  xs <- go (f i)+                  return (x : xs)++forP_ :: Parsec a -> Parsec (a -> Bool) -> Parsec (a -> a) -> Parsec b -> Parsec ()+forP_ ini cond step = forP'_ ini cond step . const++forP'_ :: Parsec a -> Parsec (a -> Bool) -> Parsec (a -> a) -> (a -> Parsec b) -> Parsec ()+forP'_ ini cond step body = ini >>= go+  where go i = whenS (cond <*> pure i) do+                  body i+                  f <- step+                  go (f i)

@@ -10,7 +10,6 @@  import Text.Gigaparsec.Internal qualified as Internal import Text.Gigaparsec.Internal.Errors qualified as Internal-import Text.Gigaparsec.Internal.RT qualified as Internal  import System.IO import Data.Knob@@ -19,6 +18,8 @@ import Data.ByteString.Char8 (unpack) import Data.List (isInfixOf, isPrefixOf) +import Control.Monad.RT (RT, rtToIO)+ {- This is quite interesting, because testing the debug combinator is a bit odd. We need to redirect the standard IO channels to point to our own@@ -54,10 +55,10 @@   ]  ioParse :: Parsec a -> String -> IO ()-ioParse (Internal.Parsec p) inp = Internal.rtToIO $ p (Internal.emptyState inp) good bad-  where good :: a -> Internal.State -> Internal.RT ()+ioParse (Internal.Parsec p) inp = rtToIO $ p (Internal.emptyState inp) good bad+  where good :: a -> Internal.State -> RT ()         good _ _  = return ()-        bad :: Internal.Error -> Internal.State -> Internal.RT ()+        bad :: Internal.Error -> Internal.State -> RT ()         bad _ _ = return ()  mockDebug :: String -> (DebugConfig -> Parsec a) -> IO String

@@ -10,10 +10,10 @@  import Text.Gigaparsec import Text.Gigaparsec.Internal-import Text.Gigaparsec.Internal.RT  import Control.Exception (catches, catch, evaluate, Exception, SomeException(..), Handler(..), throwIO) import Control.Monad (unless, forM_)+import Control.Monad.RT import Type.Reflection (typeOf, typeRep) import Control.DeepSeq (rnf, NFData) 

@@ -17,7 +17,7 @@ data TestErrorItem = Raw !String | Named !String | EndOfInput deriving stock (Eq, Show, Ord)  instance ErrorBuilder TestError where-  format p _ = TestError p+  build p _ = TestError p    type Position TestError = (Word, Word)   pos = (,)@@ -45,7 +45,7 @@   message = id    type LineInfo TestError = Word-  lineInfo _ _ _ _ width = width+  lineInfo _ _ _ _ _ width = width    numLinesBefore = 2   numLinesAfter = 2