gigaparsec 0.2.0.0 → 0.2.1.0

raw patch · 12 files changed

+434/−62 lines, 12 filesdep +bytestringdep +knobdep +pretty-terminalPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, knob, pretty-terminal

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−3
• gigaparsec.cabal +9/−3
• src/Text/Gigaparsec.hs +82/−11
• src/Text/Gigaparsec/Debug.hs +201/−0
• src/Text/Gigaparsec/Errors/Combinator.hs +1/−1
• src/Text/Gigaparsec/Internal.hs +13/−1
• src/Text/Gigaparsec/Internal/RT.hs +20/−36
• src/Text/Gigaparsec/Registers.hs +2/−3
• test/Main.hs +2/−0
• test/Text/Gigaparsec/DebugTests.hs +70/−0
• test/Text/Gigaparsec/ErrorsTests.hs +14/−0
• test/Text/Gigaparsec/Internal/Test.hs +11/−4

@@ -1,11 +1,17 @@ # Revision history for gigaparsec -## 0.1.0.0 -- 2023-10-17+## 0.2.1.0 -- 2023-11-14 -* First version. Released on an unsuspecting world.+* Added `Text.Gigaparsec.Debug`, which provides debugging capabilities.+* Added `parseFromFile` for quick parsing from files.+* Added additional documentation.  ## 0.2.0.0 -- 2023-11-09  * Added error system.-* `parse` now has a type parameter, `parse @String` restores old behaviour+* `parse` now has a type parameter, `parse @String` restores old behaviour. * for convenience `parseRepl` will print a parse to the terminal with the `String` error messages.++## 0.1.0.0 -- 2023-10-17++* First version. Released on an unsuspecting world.

@@ -20,7 +20,7 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version:            0.2.0.0+version:            0.2.1.0  -- A short (one-line) description of the package. synopsis:@@ -83,6 +83,7 @@                       Text.Gigaparsec.Char,                       Text.Gigaparsec.Combinator,                       Text.Gigaparsec.Combinator.NonEmpty,+                      Text.Gigaparsec.Debug,                       Text.Gigaparsec.Errors.Combinator,                       Text.Gigaparsec.Errors.DefaultErrorBuilder,                       Text.Gigaparsec.Errors.ErrorBuilder,@@ -99,8 +100,9 @@                       Text.Gigaparsec.Internal.Require      -- this can probably be loosened?-    build-depends:    containers >= 0.6 && < 0.7,-                      selective >= 0.6 && < 0.8+    build-depends:    containers      >= 0.6 && < 0.7,+                      selective       >= 0.6 && < 0.8,+                      pretty-terminal >= 0.1.0   && < 0.2      -- Modules included in this library but not exported.     -- other-modules:@@ -128,6 +130,7 @@     other-modules: Text.Gigaparsec.PrimitiveTests,                    Text.Gigaparsec.CharTests,                    Text.Gigaparsec.CombinatorTests,+                   Text.Gigaparsec.DebugTests,                    Text.Gigaparsec.ExprTests,                    Text.Gigaparsec.ErrorsTests,                    Text.Gigaparsec.Expr.ChainTests,@@ -153,6 +156,8 @@     build-depends:         gigaparsec,         containers >= 0.6 && < 0.7,+        deepseq >= 1.4 && < 1.6,+        bytestring >= 0.10 && < 0.12,         --deriving-compat >= 0.6 && < 0.7,         tasty >=1.1 && <1.6,         tasty-expected-failure >=0.11 && <0.13,@@ -163,6 +168,7 @@         --TODO: performance testing with tasty-bench?         --tasty-bench         -- we'd need to keep the basefile files somewhere, cache in CI or keep in repo?+        knob >=0.1.1 && <0.3,  benchmark perf-test     import:           warnings, extensions, base

@@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies, DeriveGeneric #-} {-| Module      : Text.Gigaparsec Description : Contains the bulk of the core combinators.@@ -15,7 +15,7 @@ @since 0.1.0.0 -} module Text.Gigaparsec (-    Parsec, Result(..), result, parse, parseRepl,+    Parsec, Result(..), result, parse, parseFromFile, parseRepl,   -- * Primitive Combinators   -- | These combinators are specific to parser combinators. In one way or another, they influence   -- how a parser consumes input, or under what conditions a parser does or does not fail. These are@@ -84,7 +84,7 @@  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)+import Text.Gigaparsec.Internal.RT qualified as Internal (RT, runRT, rtToIO) import Text.Gigaparsec.Internal.Errors qualified as Internal (ParseError, ExpectItem(ExpectEndOfInput), fromParseError)  import Text.Gigaparsec.Errors.ErrorBuilder (ErrorBuilder)@@ -94,31 +94,102 @@ import Control.Selective (select, branch)  import Data.Set qualified as Set (singleton, empty)+import GHC.Generics (Generic)  -- Hiding the Internal module seems like the better bet: nobody needs to see it anyway :) -- re-expose like this to prevent hlint suggesting import refinement into internal --type Parsec :: * -> * --type Parsec = Internal.Parsec +{-|+Similar to @Either@, this type represents whether a parser has failed or not.++This is chosen instead of @Either@ to be more specific about the naming.+-} type Result :: * -> * -> *-data Result e a = Success a | Failure e deriving stock (Show, Eq)+data Result e a = Success a | Failure e deriving stock (Show, Eq, Generic) +{-|+A fold for the 'Result' type.++This functions like the 'either' function does for 'Either'.++@since 0.2.0.0+-} result :: (e -> b) -> (a -> b) -> Result e a -> b result _ success (Success x) = success x result failure _ (Failure err) = failure err  {-# SPECIALISE parse :: Parsec a -> String -> Result String a #-} {-# INLINABLE parse #-}-parse :: forall err a. ErrorBuilder err => Parsec a -> String -> Result err a-parse (Parsec p) inp = Internal.runRT $ p (emptyState inp) good bad+{-|+Runs a parser against some input.++Given a parser, some input, and a way of producing parse errors of a desired+type (via 'ErrorBuilder'), this function runs a parser to produce either a+successful result or an error. Note that the @err@ type parameter is first,+which allows for @parse \@String@ to make use of the defaultly formated @String@+error messages. This may not be required if it is clear from context. To make+this process nicer within GHCi, consider using 'parseRepl'.+-}+parse :: forall err a. ErrorBuilder err+      => 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++{-|+Runs a parser against some input, pretty-printing the result to the terminal.++Compared, with 'parse', this function will always generate error messages as+strings and will print them nicely to the terminal (on multiple lines). If the+parser succeeds, the result will also be printed to the terminal. This is useful+for playing around with parsers in GHCi, seeing the results more clearly.++@since 0.2.0.0+-}+parseRepl :: Show a+          => Parsec a -- ^ the parser to execute+          -> String   -- ^ the input to parse+          -> IO ()+parseRepl p inp =+  do res <- Internal.rtToIO $ _parse Nothing p inp+     result putStrLn print res++{-# SPECIALISE parseFromFile :: Parsec a -> String -> IO (Result String a) #-}+{-# INLINABLE parseFromFile #-}+{-|+Runs a parser against some input obtained from a given file.++Given a parser, a filename, and a way of producing parse errors of a desired+type (via 'ErrorBuilder'), this function runs a parser to produce either a+successful result or an error. First, input is collected by reading the file,+and then the result is returned within `IO`; the filename is forwarded on to+the 'ErrorBuilder', which may mean it forms part of the generated error messages.++Note that the @err@ type parameter is first,+which allows for @parseFromFile \@String@ to make use of the defaultly formated @String@+error messages. This may not be required if it is clear from context.++@since 0.2.1.0+-}+parseFromFile :: forall err a. ErrorBuilder err+              => Parsec a -- ^ the parser to execute+              -> FilePath -- ^ the file to source the input from+              -> 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++--TODO: parseFromHandle?++{-# INLINE _parse #-}+_parse :: forall err a. ErrorBuilder err => Maybe FilePath -> Parsec a -> String -> Internal.RT (Result err a)+_parse file (Parsec p) inp = p (emptyState inp) good bad   where good :: a -> Internal.State -> Internal.RT (Result err a)         good x _  = return (Success x)         bad :: Internal.ParseError -> Internal.State -> Internal.RT (Result err a)-        bad err _ = return (Failure (Internal.fromParseError Nothing inp err))---- TODO: documentation-parseRepl :: Show a => Parsec a -> String -> IO ()-parseRepl p inp = result putStrLn print (parse p inp)+        bad err _ = return (Failure (Internal.fromParseError file inp err))  {-| This combinator parses its argument @p@, but rolls back any consumed input on failure.

@@ -0,0 +1,201 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ExistentialQuantification, RecordWildCards, NamedFieldPuns #-}+{-|+Module      : Text.Gigaparsec.Debug+Description : This module contains the very useful debugging combinator, as well as breakpoints.+License     : BSD-3-Clause+Maintainer  : Jamie Willis, Gigaparsec Maintainers+Stability   : stable++This module contains the very useful debugging combinators 'debug' and 'debugWith', as well as+breakpoints that can be used to pause parsing execution.++@since 0.2.1.0+-}+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 Control.Monad (when, forM)+import System.IO (hGetEcho, hSetEcho, hPutStr, stdin, stdout, Handle)+import Data.List (intercalate, isPrefixOf)+import Data.List.NonEmpty (NonEmpty((:|)), (<|))+import Data.List.NonEmpty qualified as NonEmpty (toList)+import System.Console.Pretty (color, supportsPretty, Color(Green, White, Red, Blue))++{-|+Configuration that allows for customising the behaviour of a 'debugWith'+combinator.+-}+type DebugConfig :: *+data DebugConfig = DebugConfig {+    ascii :: !Bool, -- ^ should the output of the combinator be in plain uncoloured ascii?+    breakPoint :: !Break, -- ^ should parsing execution be paused when entering or leaving this combinator?+    watchedRegs :: ![WatchedReg], -- ^ what registers should have their values tracked during debugging?+    handle :: !Handle -- ^ where should the output of the combinator be sent?+  }++{-|+The plain configuration used by the 'debug' combinator itself. It will have coloured+terminal output (if available), never pause the parsing execution, not track any registers,+and print its output to 'stdout'.+-}+debugConfig :: DebugConfig+debugConfig = DebugConfig { ascii = False, breakPoint = Never, watchedRegs = [], handle = stdout }++{-|+This type allows for a specified register to be watched by a debug combinator. The+contents of the register must be 'Show'able, and it should be given a name to identify+it within the print-out. Registers containing different types can be simultaneously+tracked, which is why this datatype is existential.+-}+type WatchedReg :: *+data WatchedReg = forall r a. Show a => WatchedReg String    -- ^ the name of the register+                                                   (Reg r a) -- ^ the register itself++{-|+This is used by 'DebugConfig' to specify whether the parsing should be paused+when passing through a 'debugWith' combinator.+-}+type Break :: *+data Break = OnEntry -- ^ pause the parsing just after entering a debug combinator+           | OnExit  -- ^ pause the parsing just after leaving a debug combinator+           | Always  -- ^ pause the parsing both just after entry and exit of a debug combinator+           | Never   -- ^ do not pause execution when passing through (__default__)++{-|+This combinator allows this parser to be debugged by providing a trace through the execution.++When this combinator is entered, it will print the name assigned to the parser to the console,+as well as the current input context for a few characters that follow.+This parser is then executed. If it succeeded, this combinator again reports the+name along with \"@Good@\" and the input context. If it failed, it reports the name+along with \"@Bad@\" and the input context.+-}+debug :: String -> Parsec a -> Parsec a+debug = debugWith debugConfig++{-|+This combinator allows this parser to be debugged by providing a trace through the execution.+An additional 'DebugConfig' is provided to customise behaviour.++When this combinator is entered, it will print the name assigned to the parser to the+configured handle, as well as the current input context for a few characters that follow.+This parser is then executed. If it succeeded, this combinator again reports the+name along with \"@Good@\" and the input context. If it failed, it reports the name+along with \"@Bad@\" and the input context.++When breakpoints are enabled within the config, the execution of the combinator will pause+on either entry, exit, or both. The parse is resumed by entering any character on standard input.+-}+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+  let config' = config { ascii = ascii' }+  doDebug name Enter st ""  config'+  let good' x st' = do+        let st'' = st' { Internal.debugLevel = Internal.debugLevel st' - 1}+        doDebug name Exit st'' (green ascii' " Good") config'+        good x st''+  let bad' err st' = do+        let st'' = st' { Internal.debugLevel = Internal.debugLevel st' - 1}+        doDebug name Exit st'' (red ascii' " Bad") config'+        bad err st''+  p (st { Internal.debugLevel = Internal.debugLevel st + 1}) good' bad'++---------------------------------------------+---- INTERNALS++type Direction :: *+data Direction = Enter | Exit++breakOnEntry :: Break -> Bool+breakOnEntry OnEntry = True+breakOnEntry Always  = True+breakOnEntry _       = False++breakOnExit :: Break -> Bool+breakOnExit OnExit = True+breakOnExit Always = True+breakOnExit _      = False++shouldBreak :: Direction -> Break -> Bool+shouldBreak Enter = breakOnEntry+shouldBreak Exit = breakOnExit++doDebug :: String -> Direction -> Internal.State -> String -> DebugConfig -> Internal.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 name dir st@Internal.State{input, line, col} end ascii regs = do+  let cs = replace "\n" (newline ascii)+         . replace " " (space ascii)+         . replace "\r" (carriageReturn ascii)+         . replace "\t" (tab ascii)+         $ take (5 + 1) input+  let cs' = if length cs < (5 + 1) then cs ++ endOfInput ascii else cs+  let prelude = portal dir name ++ " " ++ show (line, col) ++ ": "+  let caret = replicate (length prelude) ' ' ++ blue ascii "^"+  regSummary <-+    if null regs then return []+    else (++ [""]) . ("watched registers:" :) <$>+      forM regs (\(WatchedReg rname reg) ->+        (\x -> "    " ++ rname ++ " = " ++ show x) <$> readReg reg)+  Internal.unsafeIOToRT $+    hPutStr handle $ indentAndUnlines st ((prelude ++ cs' ++ end) : caret : regSummary)++waitForUser :: Internal.RT ()+waitForUser = Internal.unsafeIOToRT $ do+  echo <- hGetEcho stdin+  hSetEcho stdin False+  putStrLn "..."+  _ <- getChar+  hSetEcho stdin echo++render :: Direction -> String+render Enter = ">"+render Exit = "<"++portal :: Direction -> String -> String+portal dir name = render dir ++ name ++ render dir++indent :: Internal.State -> String+indent st = replicate (Internal.debugLevel st * 2) ' '++indentAndUnlines :: Internal.State -> [String] -> String+indentAndUnlines st = unlines . map (indent st ++)++green, red, white, blue :: Bool -> String -> String+green = colour Green+red = colour Red+white = colour White+blue = colour Blue++colour :: Color -> Bool -> String -> String+colour _ True s = s+colour c False s = color c s++newline, space, carriageReturn, tab, endOfInput :: Bool -> String+newline ascii = green ascii "↙"+space ascii = white ascii "·"+carriageReturn ascii = green ascii "←"+tab ascii = white ascii "→"+endOfInput ascii = red ascii "•"++replace :: String -> String -> String -> String+replace needle replacement haystack =+  intercalate replacement (NonEmpty.toList (splitOn needle haystack))++splitOn :: String -> String -> NonEmpty String+splitOn pat = go+  where go src+          | isPrefixOf pat src = "" <| go (drop n src)+          | c:cs <- src        = let (w :| ws) = go cs in (c : w) :| ws+          | otherwise          = "" :| []+        n = length pat

@@ -219,7 +219,7 @@  This is useful if validation work is done on the output of a parser that may render it invalid, but the error should point to the-beginning of the structure. This combinators effect can be cancelled with [[entrench `entrench`]].+beginning of the structure. This combinators effect can be cancelled with 'entrench'.  ==== __Examples__ >>> let greeting = string "hello world" <* char '!'

@@ -45,6 +45,15 @@ core representation settled before doing any "hard" work (the composite combinator API, however, can be done whenever). -}++{-|+This type represents parsers as a first-class value.++Values of this type are constructed using the library's combinators, to build+up a final 'Parsec' value that can be passed to 'Text.Gigaparsec.parse' or one+of the similar functions. This is implemented internally similar to other+libraries like @parsec@ and @gigaparsec@.+-} type Parsec :: * -> * newtype Parsec a = Parsec {     unParsec :: forall r. State@@ -179,7 +188,9 @@     -- | the valid for which hints can be used     hintsValidOffset :: {-# UNPACK #-} !Word,     -- | the hints at this point in time-    hints :: !(Set ExpectItem)+    hints :: !(Set ExpectItem),+    -- | Debug nesting+    debugLevel :: {-# UNPACK #-} !Int   }  emptyState :: String -> State@@ -189,6 +200,7 @@                         , col = 1                         , hintsValidOffset = 0                         , hints = Set.empty+                        , debugLevel = 0                         }  emptyErr :: State -> Word -> ParseError

@@ -1,12 +1,14 @@ {-# LANGUAGE Unsafe #-}-{-# LANGUAGE DataKinds, MagicHash, RoleAnnotations, TupleSections, UnboxedTuples #-}+{-# 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 Control.Applicative (liftA, liftA2)-import Control.Monad (liftM2)+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@@ -15,54 +17,36 @@  type RT :: * -> * newtype RT a = RT (State# RealWorld -> (# State# RealWorld, a #))--instance Functor RT where-  fmap :: (a -> b) -> RT a -> RT b-  fmap = liftA -- TODO:--  {-# INLINE fmap #-}---- TODO: (*>), (<*), (<*>)?-instance Applicative RT where-  pure :: a -> RT a-  pure x = RT (# , x #)--  liftA2 :: (a -> b -> c) -> RT a -> RT b -> RT c-  liftA2 = liftM2 -- TODO:--  {-# INLINE pure #-}-  {-# INLINE liftA2 #-}---- TODO: (>>)-instance Monad RT where-  return :: a -> RT a-  return = pure--  (>>=) :: RT a -> (a -> RT b) -> RT b-  RT m >>= k = RT $ \s# ->-    case m s# of-      (# s'#, x #) -> let RT n = k x in n s'#--  {-# INLINE return #-}-  {-# INLINE (>>=) #-}+  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'#, () #) --- ioToRT?--- rtToIO?--- fromIORef?+{-# 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#

@@ -8,7 +8,7 @@     local, localWith,   ) where -import Text.Gigaparsec (Parsec, ($>))+import Text.Gigaparsec (Parsec) import Text.Gigaparsec.Internal.RT (Reg, newReg, readReg, writeReg) import Text.Gigaparsec.Internal qualified as Internal (Parsec(..)) @@ -53,8 +53,7 @@ local :: Reg r a -> (a -> a) -> Parsec b -> Parsec b local reg f p = do x <- get reg                    put reg (f x)-                   y <- p-                   put reg x $> y+                   p <* put reg x  localWith :: Reg r a -> a -> Parsec b -> Parsec b localWith reg x = local reg (const x)

@@ -5,6 +5,7 @@ import Text.Gigaparsec.PrimitiveTests qualified as Primitive import Text.Gigaparsec.CharTests qualified as Char import Text.Gigaparsec.CombinatorTests qualified as Combinator+import Text.Gigaparsec.DebugTests qualified as Debug import Text.Gigaparsec.ExprTests qualified as Expr import Text.Gigaparsec.ErrorsTests qualified as Errors @@ -15,4 +16,5 @@   , Combinator.tests   , Expr.tests   , Errors.tests+  , Debug.tests   ]

@@ -0,0 +1,70 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.Gigaparsec.DebugTests where++import Test.Tasty+import Test.Tasty.HUnit++import Text.Gigaparsec+import Text.Gigaparsec.Char+import Text.Gigaparsec.Debug++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+import Data.Knob qualified as Knob (getContents)++import Data.ByteString.Char8 (unpack)+import Data.List (isInfixOf, isPrefixOf)++{-+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+implementations, and then analyse the input to look for key indicators+its working without testing the exact formats (which is not useful).+-}++tests :: TestTree+tests = testGroup "Debug" [+    debugTests+  ]++debugTests :: TestTree+debugTests = testGroup "debug should"+  [ testCase "have correct depth when nested" do+      output <- mockDebug "a\r\n \t" $ \config ->+        debugWith config "outer" (debugWith config "inner" item)+      -- a line containing inner should have more leading spaces than+      -- one containing outer+      let ls = lines output+      let outers = filter (isInfixOf "outer") ls+      let inners = filter (isInfixOf "inners") ls+      assertBool "all outer lines should have no leading spaces" $+        not (any (isPrefixOf " ") outers)+      assertBool "all inner lines should have leading spaces" $+        all (isPrefixOf " ") inners+  , testCase "don't have line breaks in the input string" do+      output <- mockDebug "\n\n\n\n\n\n" $ \config ->+        debugWith config "letter" letter+      let ls = lines output+      length ls @?= 4+  -- TODO: watched registers never boil+  ]++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 ()+        good _ _  = return ()+        bad :: Internal.ParseError -> Internal.State -> Internal.RT ()+        bad _ _ = return ()++mockDebug :: String -> (DebugConfig -> Parsec a) -> IO String+mockDebug input f =+  do mock <- newKnob ""+     hMock <- newFileHandle mock "mock" WriteMode+     let config = debugConfig { handle = hMock }+     ioParse (f config) input+     hClose hMock+     unpack <$> Knob.getContents mock

@@ -34,6 +34,7 @@                            , partialAmendTests                            , oneOfTests                            , noneOfTests+                           , builderTests                            , regressionTests                            ] @@ -356,6 +357,19 @@   ]  --TODO: patterns tests++builderTests :: TestTree+builderTests = testGroup "the default error builder should"+  [ testCase "not crash with vanilla errors" do+      notThrow (parse @String (explain "hello" (label ["hi"] (char 'a') <|> char 'b')) "c")+      notThrow (parse @String (char 'a' <|> char 'b' <|> char 'c') "d")+      notThrow (parse @String (char 'a' <|> char ',' <|> char 'c') "d")+      notThrow (parse @String (char ' ' <|> char '\BEL') "a")+      notThrow (parse @String (char 'a') " ")+      notThrow (parse @String (char 'a') "\BEL")+  , testCase "not crash with specialised errors" do+      notThrow (parse @String @() (fail ["hello", "world"] <|> fail ["!"]) "")+  ]  regressionTests :: TestTree regressionTests = testGroup "thou shalt not regress"

@@ -1,5 +1,5 @@ -- A collection of test helpers-{-# LANGUAGE AllowAmbiguousTypes, RecordWildCards #-}+{-# LANGUAGE AllowAmbiguousTypes, RecordWildCards, StandaloneDeriving, DeriveAnyClass #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use newtype instead of data" #-} module Text.Gigaparsec.Internal.Test where@@ -12,9 +12,10 @@ import Text.Gigaparsec.Internal import Text.Gigaparsec.Internal.RT -import Control.Exception (catches, evaluate, Exception, SomeException(..), Handler(..), throwIO)+import Control.Exception (catches, catch, evaluate, Exception, SomeException(..), Handler(..), throwIO) import Control.Monad (unless, forM_) import Type.Reflection (typeOf, typeRep)+import Control.DeepSeq (rnf, NFData)  data LiftedState = Lifted State @@ -87,6 +88,10 @@                                                     ++ " but got: " ++ show (typeOf ex))     ] +notThrow :: NFData a => a -> Assertion+notThrow x = catch (evaluate (rnf x)) $ \(SomeException ex) ->+  assertFailure ("expected no exception but got " ++ show (typeOf ex))+ -- TODO: we want result/error comparison later down the line (~~) :: HasCallStack => Parsec a -> Parsec a -> [String] -> Assertion (p ~~ q) inps =@@ -103,11 +108,13 @@ parseState :: Parsec a -> State -> LiftedState parseState (Parsec p) st = runRT (p st (\ !_ st' -> return (Lifted st')) (\ _ st' -> return (Lifted st'))) +deriving anyclass instance (NFData e, NFData a) => NFData (Result e a)+ -- don't @ me instance Eq LiftedState where   (==) :: LiftedState -> LiftedState -> Bool-  Lifted (State input1 consumed1 line1 col1 _hintValidOffset1 _hints1) ==-    Lifted (State input2 consumed2 line2 col2 _hintValidOffset2 _hints2) =+  Lifted (State input1 consumed1 line1 col1 _hintValidOffset1 _hints1 _debugLevel1) ==+    Lifted (State input2 consumed2 line2 col2 _hintValidOffset2 _hints2 _debugLevel2) =        consumed1 == consumed2 && line1 == line2 && col1 == col2 && input1 == input2     -- this throws off a whole bunch of tests, understandably     -- && hintValidOffset1 == hintValidOffset2 && hints1 == hints2