Generalise Input Type

gigaparsec.cabal

@@ -116,6 +116,7 @@ library
                       Text.Gigaparsec.Internal.Errors.DefuncTypes,
                       Text.Gigaparsec.Internal.Errors.ErrorItem,
                       Text.Gigaparsec.Internal.Errors.ParseError,
+                      Text.Gigaparsec.Internal.Input,
                       Text.Gigaparsec.Internal.Require,
                       Text.Gigaparsec.Internal.Token.BitBounds,
                       Text.Gigaparsec.Internal.Token.Errors,

src/Text/Gigaparsec.hs

@@ -84,6 +84,7 @@ module Text.Gigaparsec (
 import Text.Gigaparsec.Internal (Parsec(Parsec), emptyState, manyr, somer)
 import Text.Gigaparsec.Internal qualified as Internal (State(..), useHints, expectedErr)
 import Text.Gigaparsec.Internal.Errors qualified as Internal (Error, ExpectItem(ExpectEndOfInput), fromError)
+import Text.Gigaparsec.Internal.Input qualified as Internal (Input, stringInput, isEmptyInput)
 
 import Text.Gigaparsec.Errors.ErrorBuilder (ErrorBuilder)
 import Text.Gigaparsec.Errors.Combinator (filterSWith, mapMaybeSWith)
@@ -137,7 +138,7 @@ 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 = runRT $ _parse Nothing p inp
+parse p inp = runRT $ _parse Nothing p (Internal.stringInput inp)
 
 {-|
 Runs a parser against some input, pretty-printing the result to the terminal.
@@ -154,7 +155,7 @@ parseRepl :: Show a
           -> String   -- ^ the input to parse
           -> IO ()
 parseRepl p inp =
-  do res <- rtToIO $ _parse Nothing p inp
+  do res <- rtToIO $ _parse Nothing p (Internal.stringInput inp)
      result putStrLn print res
 
 {-# SPECIALISE parseFromFile :: Parsec a -> String -> IO (Result String a) #-}
@@ -174,18 +175,23 @@ error messages. This may not be required if it is clear from context.
 
 @since 0.2.1.0
 -}
-parseFromFile :: forall err a. ErrorBuilder err
+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
-     rtToIO $ _parse (Just f) p inp
+     rtToIO $ _parse (Just f) p (Internal.stringInput inp)
 
 --TODO: parseFromHandle?
 
 {-# INLINE _parse #-}
-_parse :: forall err a. ErrorBuilder err => Maybe FilePath -> Parsec a -> String -> RT (Result err a)
+_parse :: forall err a s. 
+          (ErrorBuilder err) 
+       => Maybe FilePath 
+       -> Parsec a 
+       -> (Internal.Input s)
+       -> RT (Result err a)
 _parse file (Parsec p) inp = p (emptyState inp) good bad
   where good :: a -> Internal.State -> RT (Result err a)
         good x _  = return (Success x)
@@ -273,10 +279,11 @@ Success ()
 @since 0.1.0.0
 -}
 eof :: Parsec ()
-eof = Parsec $ \st good bad -> case Internal.input st of
-  (:){} -> Internal.useHints bad
+eof = Parsec $ \st@Internal.State{Internal.input = input, Internal.inputOps = ops} good bad ->
+  if Internal.isEmptyInput input ops
+    then good () st
+    else Internal.useHints bad
              (Internal.expectedErr st (Set.singleton Internal.ExpectEndOfInput) 1) st
-  []    -> good () st
 
 {-|
 This parser produces @()@ without having any other effect.

src/Text/Gigaparsec/Char.hs

@@ -1,5 +1,5 @@
-{-# LANGUAGE Safe #-}
-{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE OverloadedLists, MagicHash #-}
 {-# OPTIONS_GHC -Wno-all-missed-specialisations -Wno-overflowed-literals #-}
 {-|
 Module      : Text.Gigaparsec.Char
@@ -49,7 +49,7 @@
 import Text.Gigaparsec.Combinator (skipMany)
 import Text.Gigaparsec.Errors.Combinator ((<?>))
 -- We want to use this to make the docs point to the right definition for users.
-import Text.Gigaparsec.Internal qualified as Internal (Parsec(Parsec, unParsec), State(..), expectedErr, useHints)
+import Text.Gigaparsec.Internal qualified as Internal (Parsec(Parsec, unParsec), State(..), expectedErr, useHints, unconsInput, InputOps)
 import Text.Gigaparsec.Internal.Errors qualified as Internal (ExpectItem(ExpectRaw), Error)
 import Text.Gigaparsec.Internal.Require (require)
 
@@ -69,22 +69,42 @@
 -------------------------------------------------
 
 _satisfy :: Set Internal.ExpectItem -> (Char -> Bool) -> Parsec Char
-_satisfy expecteds test = Internal.Parsec $ \st ok bad ->
-  case Internal.input st of
-    c:cs | test c -> ok c (updateState st c cs)
-    _             -> Internal.useHints bad (Internal.expectedErr st expecteds 1) st
+_satisfy expecteds test = Internal.Parsec $ \st@(Internal.State {..}) ok bad ->
+  case Internal.unconsInput input inputOps of
+    Just (c, cs) | test c  -> ok c (updateState st c cs inputOps)
+    _ -> Internal.useHints bad (Internal.expectedErr st expecteds 1) st
   where
+  -- Update the state depending on which character we have parsed. 
+  -- Newlines and tabs affect the lines/columns differently to standard characters.
+  updateState :: Internal.State -> Char -> s -> Internal.InputOps s -> Internal.State
+  updateState st '\n' cs ops = updateStateHelper st cs ops True  (const 1)
+  updateState st '\t' cs ops = updateStateHelper st cs ops False (\col -> ((col + 3) .&. (-4)) .|. 1)
+  updateState st _    cs ops = updateStateHelper st cs ops False (+ 1)
+
   -- The duplicated input & consumed update avoids double allocation
   -- that occurs if they were done separately to the line and col updates.
-  updateState st '\n' cs = st
-    { Internal.line = Internal.line st + 1, Internal.col = 1,
-      Internal.input = cs, Internal.consumed = Internal.consumed st + 1 }
-  updateState st '\t' cs = st
-    { Internal.col = ((Internal.col st + 3) .&. (-4)) .|. 1,
-      Internal.input = cs, Internal.consumed = Internal.consumed st + 1 }
-  updateState st _ cs = st
-    { Internal.col = Internal.col st + 1,
-      Internal.input = cs, Internal.consumed = Internal.consumed st + 1 }
+  -- 
+  -- In GHC < 9.8 (and maybe 9.6), record updates typechecking cannot handle records with existentials.
+  -- Sadly, this means we must reconstruct the entire state.
+  updateStateHelper 
+    :: Internal.State         -- old state
+    -> s                      -- input
+    -> Internal.InputOps s    -- inputOps
+    -> Bool                   -- increaseLine?
+    -> (Word -> Word)         -- how to update the column
+    -> Internal.State
+  updateStateHelper (Internal.State {..}) cs ops increaseLine colUpdate = 
+    Internal.State {
+      Internal.input = cs
+    , Internal.line = if increaseLine then line + 1 else line
+    , Internal.col  = colUpdate col
+    , Internal.consumed = consumed + 1
+      -- Unchanged
+    , Internal.inputOps = ops
+    , Internal.hintsValidOffset = hintsValidOffset
+    , Internal.hints = hints
+    , Internal.debugLevel = debugLevel
+    }
 
 {-|
 This combinator tries to parse a single character from the input that matches the given predicate.
@@ -397,7 +417,7 @@
 
 _trie :: String -> Map String (Parsec a) -> Parsec a
 _trie func strs = require (not (Map.member "" strs)) func "the empty string is not a valid key" $
   getAlt $ foldMap combineSameLeading (NonEmpty.groupWith (head . fst) (Map.toAscList strs))
   where -- When combining these parsers it is important to make sure the
         -- longest ones parse first. All but the last parser need an `atomic`.
         combineSameLeading :: NonEmpty (String, Parsec a) -> Alt Parsec a

src/Text/Gigaparsec/Debug.hs

@@ -133,12 +133,12 @@
   when (shouldBreak dir breakPoint) waitForUser
 
 printInfo :: Handle -> String -> Direction -> Internal.State -> String -> Bool -> [WatchedReg] -> RT ()
-printInfo handle name dir st@Internal.State{input, line, col} end ascii regs = do
+printInfo handle name dir st@Internal.State{input, inputOps, 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
+         $ take (5 + 1) (Internal.stInputToString st)
   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 "^"

src/Text/Gigaparsec/Errors/ErrorBuilder.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE Safe #-}
 {-# LANGUAGE TypeFamilies, AllowAmbiguousTypes, FlexibleInstances, FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ConstraintKinds #-}
 {-|
 Module      : Text.Gigaparsec.Errors.ErrorBuilder
 Description : This module defines the ErrorBuilder typeclass, which specifies how to generate 
@@ -216,6 +218,7 @@ import Text.Gigaparsec.Errors.DefaultErrorBuilder ( StringBuilder, buildDefault
                                                   )
 import {-# SOURCE #-} Text.Gigaparsec.Errors.TokenExtractors (Token(Named, Raw), tillNextWhitespace)
 
+
 import Data.Char (isSpace)
 import Data.Kind (Constraint)
 import Data.List.NonEmpty (NonEmpty)
@@ -226,7 +229,7 @@ import Data.Void (Void)
 
 {-|
 This class describes how to construct an error message generated by a parser in
-a represention, @err@, the parser writer desires.
+a representation, @err@, the parser writer desires.
 -}
 type ErrorBuilder :: * -> Constraint
 class Ord (Item err) => ErrorBuilder err where
@@ -329,7 +332,7 @@ class Ord (Item err) => ErrorBuilder err where
           -> Message err
 
   {-|
-  Describes how to process the information about the line that the error occured on,
+  Describes how to process the information about the line that the error occurred on,
   and its surrounding context.
   -}
   lineInfo :: String   -- ^ the full line of input that produced this error message.
@@ -340,9 +343,9 @@ class Ord (Item err) => ErrorBuilder err where
            -> Word     -- ^ how wide the caret in the message should be.
            -> LineInfo err
 
-  -- | The number of lines of input to request before an error occured.
+  -- | The number of lines of input to request before an error occurred.
   numLinesBefore :: Int
-  -- | The number of lines of input to request after an error occured.
+  -- | The number of lines of input to request after an error occurred.
   numLinesAfter :: Int
 
   -- | The type that represents the individual items within the error. It must be
@@ -380,6 +383,9 @@ class Ord (Item err) => ErrorBuilder err where
                   -> Bool          -- ^ was this error generated as part of \"lexing\", or in a wider parser (see 'Text.Gigaparsec.Errors.Combinator.markAsToken').
                   -> Token         -- ^ a token extracted from @cs@ that will be used as part of the unexpected message.
 
+
+
+
 {-|
 Builds error messages as @String@, using the functions found in
 "Text.Gigaparsec.Errors.DefaultErrorBuilder".

src/Text/Gigaparsec/Internal.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveFunctor, StandaloneDeriving, NamedFieldPuns, CPP #-}
 #include "portable-unlifted.h"
 {-# OPTIONS_HADDOCK hide #-}
+{-# LANGUAGE ExistentialQuantification, UnicodeSyntax #-}
 {-|
 Module      : Text.Gigaparsec.Internal
 Description : Internals of Gigaparsec
@@ -15,16 +16,18 @@
 
 @since 0.1.0.0
 -}
-module Text.Gigaparsec.Internal (module Text.Gigaparsec.Internal) where
+module Text.Gigaparsec.Internal (module Text.Gigaparsec.Internal, module Input) where
 
 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,
-    isExpectedEmpty, presentationOffset, useHints, DefuncHints(Blank), addError
+    isExpectedEmpty, presentationOffset, useHints, DefuncHints(Blank), addError,
   )
+import Text.Gigaparsec.Internal.Input (Input, inputToString, stringInput, unconsInput, InputOps)
+import Text.Gigaparsec.Internal.Input qualified as Input
 
 import Control.Applicative (Applicative(liftA2), Alternative(empty, (<|>), many, some)) -- liftA2 required until 9.6
 import Control.Selective (Selective(select))
 
 import Data.Set (Set)
@@ -54,7 +57,7 @@
 libraries like @parsec@ and @gigaparsec@.
 -}
 type Parsec :: * -> *
 newtype Parsec a = Parsec {
     unParsec :: forall r. State
              -> (a -> State -> RT r)     -- the good continuation
              -> (Error -> State -> RT r) -- the bad continuation
@@ -202,10 +205,21 @@
 
   {-# INLINE mempty #-}
 
+{-|
+The 'State' of a parser describes its current position and what input is left to be processed, among other things.
+
+'State' is existentially quantified over the input type.
+This can make 'State' tricky to work with when using the fields 'input' and 'inputOps', as they cannot be used as projections;
+instead, access them via pattern matching.
+
+See also 'useInput' and 'useState', which provide recursors on 'State' in a CPS form.
+-}
 type State :: UnliftedDatatype
-data State = State {
-    -- | the input string, in future this may be generalised
-    input :: !String,
+data State = ∀ s . State {
+    -- | the input stream, in future this may be generalised
+    input :: !s,
+    -- | the operations which process the 'input' stream
+    inputOps :: {-# UNPACK #-} !(InputOps s),
     -- | has the parser consumed input since the last relevant handler?
     consumed :: {-# UNPACK #-} !Word,
     -- | the current line number (incremented by \n)
@@ -220,8 +234,28 @@
     debugLevel :: {-# UNPACK #-} !Int
   }
 
-emptyState :: String -> State
-emptyState !str = State { input = str
+{-|
+Apply the given function to the 'input' of the 'State', which may use the 'inputOps'.
+-}
+useInput :: State -> (∀ s . (Input s -> r)) -> r
+useInput (State {input, inputOps}) f = f (Input.Input input inputOps)
+
+{-|
+A recursor for the 'State' type.
+
+This is sometimes preferable to using record projections, as the latter tend not to work for the fields referencing the existentially bound type in 'State'.
+In particular, if 'input' and/or 'inputOps' are to be updated, one cannot use projections to get their old values.
+-}
+useState :: State 
+  -> (∀ s . s -> InputOps s -> Word -> Word -> Word -> Word -> Hints -> Int -> r) -> r
+useState (State {..}) f = f input inputOps consumed line col hintsValidOffset hints debugLevel
+stInputToString :: State -> String
+stInputToString st = useInput st $ \inp -> Input.inputToString inp
+
+emptyState :: (Input s) -> State
+emptyState !(Input.Input str inputStream) = State { 
+                          input = str
+                        , inputOps = inputStream
                         , consumed = 0
                         , line = 1
                         , col = 1

src/Text/Gigaparsec/Internal/Errors.hs

@@ -23,7 +23,10 @@
 import Text.Gigaparsec.Internal.Errors.ParseError (fromParseError)
 import Text.Gigaparsec.Internal.Errors.DefuncBuilders (asParseError)
 
+import Text.Gigaparsec.Internal.Errors.DefuncBuilders (asParseError)
+
 CPP_import_PortableUnlifted
+import Text.Gigaparsec.Internal.Input (Input)
 
 type Error :: UnliftedDatatype
 type Error = DefuncError
@@ -39,15 +42,15 @@
 replaceHints = Hints.replace
 
 {-# INLINABLE fromError #-}
-fromError :: forall err. ErrorBuilder err => Maybe FilePath -> String -> Error -> err
+fromError :: forall err s. ErrorBuilder err => Maybe FilePath -> Input s -> Error -> err
 fromError fp inp err = fromParseError fp inp (asParseError inp err)
 
 {-# INLINE emptyErr #-}
 emptyErr :: Word -> Word -> Word -> Word -> Error
 emptyErr = Error.emptyError
 
 {-# INLINE expectedErr #-}
-expectedErr :: String -> Word -> Word -> Word -> Set ExpectItem -> Word -> Error
+expectedErr :: s -> Word -> Word -> Word -> Set ExpectItem -> Word -> Error
 expectedErr _ = Error.expectedError
 
 {-# INLINE specialisedErr #-}

src/Text/Gigaparsec/Internal/Errors/DefuncBuilders.hs

@@ -3,7 +3,7 @@
 {-# OPTIONS_HADDOCK hide #-}
 {-# OPTIONS_GHC -Wno-unused-imports #-}
 -- Yes, this is redundant, however, it is necessary to get the UNPACK to fire
 {-# OPTIONS_GHC -Wno-redundant-strictness-flags -Wno-missing-kind-signatures #-}
 #include "portable-unlifted.h"
 module Text.Gigaparsec.Internal.Errors.DefuncBuilders (
     asParseError
@@ -26,14 +26,16 @@
     ExpectItem(ExpectNamed),
     UnexpectItem(UnexpectEndOfInput, UnexpectNamed, UnexpectRaw)
   )
+import Text.Gigaparsec.Internal.Input (Input)
+import Text.Gigaparsec.Internal.Input qualified as Input
 
 import Data.Set (Set)
 import Data.Set qualified as Set (empty, insert, union, member, map)
 import Data.List.NonEmpty (nonEmpty)
 
 CPP_import_PortableUnlifted
 
-asParseError :: String -> DefuncError -> ParseError
+asParseError :: forall s . Input s -> DefuncError -> ParseError
 asParseError !input e@DefuncError{..} = case errKind of
   IsVanilla -> case makeVanilla 0 0 Set.empty (NoItem 0) Set.empty True errTy of
     (# line, col, exs, unex, reasons #) ->
@@ -42,7 +44,7 @@
     (# line, col, width, _, dmsgs #) ->
       SpecialisedError presentationOffset line col (distinct (dmsgs [])) width
   where
-    !outOfRange = presentationOffset >= fromIntegral (length input)
+    !outOfRange = presentationOffset >= fromIntegral (length (Input.inputToString input))
 
     makeVanilla :: Word -> Word -> Set ExpectItem -> BuilderUnexpectItem -> Set String -> Bool
                 -> DefuncError_ 'Vanilla
@@ -146,12 +148,14 @@
 addLabels True !exs !exs' = Set.union exs exs'
 addLabels False exs _     = exs
 
-toErrorItem :: String -> Word -> BuilderUnexpectItem -> Either Word UnexpectItem
+-- | Convert a 'BuilderUnexpectItem' into an 'UnexpectItem',
+-- Or ??? if it is a 'NoItem' error.
+toErrorItem :: forall s . Input s -> Word -> BuilderUnexpectItem -> Either Word UnexpectItem
 toErrorItem !_ !_ (NoItem w) = Left w
 toErrorItem _ _ (NamedItem item cw) = Right (UnexpectNamed item cw)
 toErrorItem _ _ EndOfInput = Right UnexpectEndOfInput
 toErrorItem input off (RawItem w) =
-  case nonEmpty (drop (fromIntegral off) input) of
+  case nonEmpty (drop (fromIntegral off) (Input.inputToString input)) of
     Nothing -> Right UnexpectEndOfInput
     Just cs -> Right (UnexpectRaw cs w)