gigaparsec 0.2.1.0 → 0.2.2.0

raw patch · 26 files changed

+1875/−38 lines, 26 filesdep +template-haskelldep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: template-haskell

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• gigaparsec.cabal +23/−7
• src/Text/Gigaparsec.hs +64/−1
• src/Text/Gigaparsec/Combinator.hs +25/−19
• src/Text/Gigaparsec/Debug.hs +1/−1
• src/Text/Gigaparsec/Errors/Combinator.hs +43/−3
• src/Text/Gigaparsec/Errors/ErrorGen.hs +62/−0
• src/Text/Gigaparsec/Internal.hs +1/−1
• src/Text/Gigaparsec/Internal/Errors.hs +6/−3
• src/Text/Gigaparsec/Internal/Require.hs +0/−1
• src/Text/Gigaparsec/Internal/Token/Generic.hs +91/−0
• src/Text/Gigaparsec/Internal/Token/Lexer.hs +216/−0
• src/Text/Gigaparsec/Internal/Token/Names.hs +80/−0
• src/Text/Gigaparsec/Internal/Token/Numeric.hs +328/−0
• src/Text/Gigaparsec/Internal/Token/Symbol.hs +73/−0
• src/Text/Gigaparsec/Internal/Token/Text.hs +206/−0
• src/Text/Gigaparsec/Patterns.hs +154/−0
• src/Text/Gigaparsec/Position.hs +24/−0
• src/Text/Gigaparsec/Registers.hs +9/−2
• src/Text/Gigaparsec/Token/Descriptions.hs +212/−0
• src/Text/Gigaparsec/Token/Lexer.hs +59/−0
• src/Text/Gigaparsec/Token/Patterns.hs +36/−0
• test/Main.hs +2/−0
• test/Text/Gigaparsec/GigaparsecTests.hs +42/−0
• test/Text/Gigaparsec/Token/NamesTests.hs +101/−0
• test/Text/Gigaparsec/TokenTests.hs +9/−0

@@ -1,5 +1,13 @@ # Revision history for gigaparsec +## 0.2.2.0 -- 2024-01-21++* Added `manyMap` and `someMap` combinators.+* Added `filterS` and `mapMaybeS` combinators as well as `ErrorGen` and more general combinators.+* Added `Text.Gigaparsec.Position` module.+* Added `Text.Gigaparsec.Token` and associated functionality.+* Added `Text.Gigaparsec.Patterns` module, which is currently heavily experimental.+ ## 0.2.1.0 -- 2023-11-14  * Added `Text.Gigaparsec.Debug`, which provides debugging capabilities.

@@ -20,7 +20,7 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version:            0.2.1.0+version:            0.2.2.0  -- A short (one-line) description of the package. synopsis:@@ -68,7 +68,7 @@     -- Extensions we want enabled without having to specify them     default-extensions: ScopedTypeVariables, RankNTypes, BangPatterns, TypeApplications,                         MultiWayIf, DerivingStrategies, InstanceSigs, StandaloneKindSignatures,-                        ImportQualifiedPost+                        ImportQualifiedPost, RecordWildCards  common base     -- Other library packages from which modules are imported.@@ -87,22 +87,35 @@                       Text.Gigaparsec.Errors.Combinator,                       Text.Gigaparsec.Errors.DefaultErrorBuilder,                       Text.Gigaparsec.Errors.ErrorBuilder,+                      Text.Gigaparsec.Errors.ErrorGen,                       Text.Gigaparsec.Expr,                       Text.Gigaparsec.Expr.Chain,                       Text.Gigaparsec.Expr.Infix,                       Text.Gigaparsec.Expr.Subtype,+                      Text.Gigaparsec.Patterns,+                      Text.Gigaparsec.Position,                       Text.Gigaparsec.Registers,+                      Text.Gigaparsec.Token.Descriptions,+                      Text.Gigaparsec.Token.Lexer,+                      Text.Gigaparsec.Token.Patterns,                        -- Internals                       Text.Gigaparsec.Internal,                       Text.Gigaparsec.Internal.Errors,                       Text.Gigaparsec.Internal.RT,-                      Text.Gigaparsec.Internal.Require+                      Text.Gigaparsec.Internal.Require,+                      Text.Gigaparsec.Internal.Token.Generic,+                      Text.Gigaparsec.Internal.Token.Lexer,+                      Text.Gigaparsec.Internal.Token.Names,+                      Text.Gigaparsec.Internal.Token.Numeric,+                      Text.Gigaparsec.Internal.Token.Symbol,+                      Text.Gigaparsec.Internal.Token.Text,      -- this can probably be loosened?-    build-depends:    containers      >= 0.6 && < 0.7,-                      selective       >= 0.6 && < 0.8,-                      pretty-terminal >= 0.1.0   && < 0.2+    build-depends:    containers       >= 0.6   && < 0.7,+                      selective        >= 0.6   && < 0.8,+                      pretty-terminal  >= 0.1.0 && < 0.2,+                      template-haskell >= 2.16  && < 3      -- Modules included in this library but not exported.     -- other-modules:@@ -127,7 +140,8 @@     default-language: Haskell2010      -- Modules included in this executable, other than Main.-    other-modules: Text.Gigaparsec.PrimitiveTests,+    other-modules: Text.Gigaparsec.GigaparsecTests,+                   Text.Gigaparsec.PrimitiveTests,                    Text.Gigaparsec.CharTests,                    Text.Gigaparsec.CombinatorTests,                    Text.Gigaparsec.DebugTests,@@ -135,6 +149,8 @@                    Text.Gigaparsec.ErrorsTests,                    Text.Gigaparsec.Expr.ChainTests,                    Text.Gigaparsec.Expr.InfixTests,+                   Text.Gigaparsec.TokenTests,+                   Text.Gigaparsec.Token.NamesTests,                    Text.Gigaparsec.Internal.Test,                    Text.Gigaparsec.Internal.TestError,                    Text.Gigaparsec.Internal.PlainString

@@ -64,6 +64,7 @@   -- | These combinators perform filtering on the results of a parser. This means that, given the   -- result of a parser, they will perform some function on that result, and the success of that   -- function effects whether or not the parser fails.+    filterS, mapMaybeS,    -- * Folding Combinators   -- | These combinators repeatedly execute a parser (at least zero or one times depending on the@@ -72,7 +73,7 @@   -- or the first successful result is the initial accumulator (for the reduces). These are   -- implemented efficiently and do not need to construct any intermediate list with which to store   -- the results.-    many, some, manyl, manyr, somel, somer, -- TODO: these need to be properly categorised+    many, some, manyl, manyr, somel, somer, manyMap, someMap,-- TODO: these need to be properly categorised   ) where  -- NOTE:@@ -88,6 +89,8 @@ import Text.Gigaparsec.Internal.Errors qualified as Internal (ParseError, ExpectItem(ExpectEndOfInput), fromParseError)  import Text.Gigaparsec.Errors.ErrorBuilder (ErrorBuilder)+import Text.Gigaparsec.Errors.Combinator (filterSWith, mapMaybeSWith)+import Text.Gigaparsec.Errors.ErrorGen (vanillaGen)  import Data.Functor (void) import Control.Applicative (liftA2, (<|>), empty, many, some, (<**>)) -- liftA2 required until 9.6@@ -201,6 +204,7 @@ used for the latter purpose sparingly, however, since excessive backtracking in a parser can result in much lower efficiency. +==== __Examples__ >>> parse (string "abc" <|> string "abd") "abd" Failure .. -- first parser consumed a, so no backtrack >>> parse (atomic (string "abc") <|> string "abd") "abd"@@ -311,5 +315,64 @@ somel :: (b -> a -> b) -> b -> Parsec a -> Parsec b somel f k p = _repl f (f k <$> p) p +{-|+This combinator acts like the 'foldMap' function but with a parser.++The parser @manyMap f p@, will parse @p@ __zero__ or more times, then+adapt each result with the function @f@ to produce a bunch of values+in some 'Monoid' @m@. These values are then combined together to form a+single value; if @p@ could not be parsed, it will return the 'mempty'+for @m@.++==== __Examples__+>>> parse (manyMap Set.singleton item) "aaaab"+Success (Set.fromList ['a', 'b'])++@since 0.2.2.0+-}+manyMap :: Monoid m+        => (a -> m) -- injection function for parser results into a monoid+        -> Parsec a -- parser to execute multiple times+        -> Parsec m+manyMap f = manyr (<>) mempty . fmap f++{-|+This combinator acts like the 'foldMap' function but with a parser.++The parser @manyMap f p@, will parse @p@ __one__ or more times, then+adapt each result with the function @f@ to produce a bunch of values+in some 'Semigroup' @s@. These values are then combined together to form a+single value.++==== __Examples__+>>> parse (someMap Max item) "bdcjb"+Success (Max 'j')+>>> parse (someMap Min item) "bdcjb"+Success (Max 'b')++@since 0.2.2.0+-}+someMap :: Semigroup s+        => (a -> s) -- injection function for parser results into a monoid+        -> Parsec a -- parser to execute multiple times+        -> Parsec s+someMap f p = _repl (<>) (f <$> p) (f <$> p) -- is there a better implementation, it's tricky!+ _repl :: (b -> a -> b) -> Parsec b -> Parsec a -> Parsec b _repl f k p = k <**> manyr (\x next !acc -> next (f acc x)) id p++-- should these be implemented with branch? probably not.+{-++@since 0.2.2.0+-}+filterS :: (a -> Bool) -> Parsec a -> Parsec a+filterS = filterSWith vanillaGen++-- this is called mapFilter in Scala... there is no collect counterpart+{-++@since 0.2.2.0+-}+mapMaybeS :: (a -> Maybe b) -> Parsec a -> Parsec b+mapMaybeS = mapMaybeSWith vanillaGen

@@ -22,7 +22,7 @@   -- parser succeeds, depending on the combinator. Depending on the combinator, all of the results produced by the   -- repeated execution of the parser may be returned in a @[]@. These are almost essential for any practical parsing   -- task.-    manyN, skipMany, skipSome, skipManyN, count, count1, manyTill, someTill,+    manyN, skipMany, skipSome, skipManyN, count, count1, manyTill, someTill, skipManyTill, skipSomeTill,    -- * Optional Parsing Combinators   -- | These combinators allow for the /possible/ parsing of some parser. If the parser succeeds, that is ok@@ -53,7 +53,7 @@   ) where  import Text.Gigaparsec (Parsec, many, some, (<|>), ($>), (<:>), select,-                        branch, empty, unit, manyl, somel, notFollowedBy, liftA2)+                        branch, empty, unit, manyl, somel, notFollowedBy, liftA2, void) import Data.Foldable (asum, sequenceA_)  {-|@@ -555,26 +555,32 @@          -> Parsec [a] -- ^ a parser that parses @p@ until @end@ succeeds, returning the list of all the successful results. someTill p end = notFollowedBy end *> (p <:> manyTill p end) +skipManyTill :: Parsec a -> Parsec end -> Parsec ()+skipManyTill p end = void (manyTill p end)++skipSomeTill :: Parsec a -> Parsec end -> Parsec ()+skipSomeTill p end = void (someTill p end)+ -- this is ifP {-| This combinator parses one of @thenP@ or @elseP@ depending on the result of parsing @condP@.  This is a lifted @if@-statement. First, parse @condP@: if it is successful and returns-@true@, then parse @thenP@; else, if it returned @false@, parse @elseP@; or, if @condP@ failed+@True@, then parse @thenP@; else, if it returned @False@, parse @elseP@; or, if @condP@ failed then fail. If either of @thenP@ or @elseP@ fail, then this combinator also fails.  Most useful in conjunction with /Registers/, as this allows for decisions to be made based on state.  ==== __Examples__->>> ifP (pure true) p _ == p->>> ifP (pure false) _ p == p+>>> ifP (pure True) p _ == p+>>> ifP (pure False) _ p == p  @since 0.1.0.0 -} ifS :: Parsec Bool -- ^ @condP@, the parser that yields the condition value.-    -> Parsec a    -- ^ @thenP@, the parser to execute if the condition is @true@.-    -> Parsec a    -- ^ @elseP@, the parser to execute if the condition is @false.+    -> Parsec a    -- ^ @thenP@, the parser to execute if the condition is @True@.+    -> Parsec a    -- ^ @elseP@, the parser to execute if the condition is @False@.     -> Parsec a    -- ^ a parser that conditionally parses @thenP@ or @elseP@ after @condP@. ifS cond t e = branch (bool <$> cond) (const <$> e) (const <$> t)   where bool True = Right ()@@ -585,33 +591,33 @@ This combinator conditionally parses @thenP@ depending on the result of parsing @condP@.  This is a lifted @if@-statement. First, parse @condP@: if it is successful and returns-@true@, then parse @thenP@; else, if it returned @false@ do nothing; or, if @condP@ failed+@True@, then parse @thenP@; else, if it returned @False@ do nothing; or, if @condP@ failed then fail. If @thenP@ fails, then this combinator also fails.  Most useful in conjunction with /Registers/, as this allows for decisions to be made based on state.  ==== __Examples__->>> when (pure true) p == p->>> when (pure false) _ == unit+>>> when (pure True) p == p+>>> when (pure False) _ == unit  @since 0.1.0.0 -} whenS :: Parsec Bool -- ^ @condP@, the parser that yields the condition value.-      -> Parsec ()   -- ^ @thenP@, the parser to execute if the condition is @true@.+      -> Parsec ()   -- ^ @thenP@, the parser to execute if the condition is @True@.       -> Parsec ()   -- ^ a parser that conditionally parses @thenP@ after @condP@. whenS cond p = ifS cond p unit  -- this is guard {-|-This combinator verfies that the given parser returns @true@, or else fails.+This combinator verfies that the given parser returns @True@, or else fails. -First, parse @p@; if it succeeds then, so long at returns @true@, this @guard p@ succeeds. Otherwise,-if @p@ either fails, or returns @false@, @guard p@ will fail.+First, parse @p@; if it succeeds then, so long at returns @True@, this @guard p@ succeeds. Otherwise,+if @p@ either fails, or returns @False@, @guard p@ will fail.  ==== __Examples__->>> guard (pure true) == unit->>> guard (pure false) == empty+>>> guard (pure True) == unit+>>> guard (pure False) == empty >>> when (not <$> p) empty == guard p  @since 0.1.0.0@@ -622,10 +628,10 @@  -- this is whileP {-|-This combinator repeatedly parses @p@ so long as it returns @true@.+This combinator repeatedly parses @p@ so long as it returns @True@.  This is a lifted @while@-loop. First, parse @p@: if it is successful and-returns @true@, then repeat; else if it returned @false@ stop; or, if it+returns @True@, then repeat; else if it returned @False@ stop; or, if it failed then this combinator fails.  Most useful in conjunction with /Registers/, as this allows for decisions to be made@@ -634,7 +640,7 @@ @since 0.1.0.0 -} whileS :: Parsec Bool -- ^ @p@, the parser to repeatedly parse.-       -> Parsec ()   -- ^ a parser that continues to parse @p@ until it returns @false@.+       -> Parsec ()   -- ^ a parser that continues to parse @p@ until it returns @False@. whileS c = let go = whenS c go in go  {-|

@@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE ExistentialQuantification, RecordWildCards, NamedFieldPuns #-}+{-# LANGUAGE ExistentialQuantification, NamedFieldPuns #-} {-| Module      : Text.Gigaparsec.Debug Description : This module contains the very useful debugging combinator, as well as breakpoints.

@@ -1,5 +1,6 @@ {-# LANGUAGE Safe #-} {-# OPTIONS_GHC -Wno-missing-import-lists #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-| Module      : Text.Gigaparsec.Errors.Combinator Description : This module contains combinators that can be used to directly influence error@@ -43,7 +44,8 @@   -- at the position on entry to the combinator, 'entrench' will resist these changes.     amend, partialAmend, entrench, dislodge, dislodgeBy,     amendThenDislodge, amendThenDislodgeBy, partialAmendThenDislodge, partialAmendThenDislodgeBy,-    markAsToken+    markAsToken,+    filterSWith, mapMaybeSWith, filterOut, guardAgainst, unexpectedWhen, unexpectedWithReasonWhen   ) where  {-@@ -71,17 +73,21 @@  import Prelude hiding (fail) -import Text.Gigaparsec (Parsec)+import Text.Gigaparsec.Errors.ErrorGen (ErrorGen, vanillaGen, specializedGen)+import Text.Gigaparsec.Errors.ErrorGen qualified as ErrorGen -- We want to use this to make the docs point to the right definition for users.+import Text.Gigaparsec.Internal (Parsec) import Text.Gigaparsec.Internal qualified as Internal (Parsec(Parsec), line, col, emptyErr, specialisedErr, raise, unexpectedErr, hints, consumed, useHints, adjustErr, hints, hintsValidOffset) import Text.Gigaparsec.Internal.Errors (ParseError, CaretWidth(FlexibleCaret, RigidCaret), ExpectItem(ExpectNamed)) import Text.Gigaparsec.Internal.Errors qualified as Internal (setLexical, amendErr, entrenchErr, dislodgeErr, partialAmendErr, labelErr, explainErr) import Text.Gigaparsec.Internal.Require (require)+import Text.Gigaparsec.Position (withWidth)  import Data.Set (Set) import Data.Set qualified as Set (empty, map) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty (toList)+import Data.Maybe (isNothing, fromJust)  {-| This combinator changes the expected component of any errors generated by this parser.@@ -116,7 +122,7 @@ hide (Internal.Parsec p) =   Internal.Parsec $ \st good bad ->     let !origConsumed = Internal.consumed st-        good' x st' = good x st' { Internal.hints = Set.empty }+        good' x st' = good x st' { Internal.hints = Internal.hints st } -- TODO: should this change valid offset?         bad' err st'           | Internal.consumed st' /= origConsumed = bad err st'           | otherwise = Internal.useHints bad (Internal.emptyErr st' 0) st'@@ -353,3 +359,37 @@ infix 0 <?> (<?>) :: Parsec a -> Set String -> Parsec a (<?>) = flip label++-- should these be implemented with branch? probably not.+{-+@since 0.2.2.0+-}+filterSWith :: ErrorGen a -> (a -> Bool) -> Parsec a -> Parsec a+filterSWith errGen f p = amendThenDislodgeBy 1 $ withWidth (entrench p) >>= \(x, w) ->+  if f x then pure x else ErrorGen.asErr errGen x w++filterOut :: (a -> Maybe String) -> Parsec a -> Parsec a+filterOut p =+  filterSWith (vanillaGen { ErrorGen.reason = p }) (isNothing . p)++guardAgainst :: (a -> Maybe [String]) -> Parsec a -> Parsec a+guardAgainst p =+  filterSWith (specializedGen { ErrorGen.messages = fromJust . p }) (isNothing . p)++unexpectedWhen :: (a -> Maybe String) -> Parsec a -> Parsec a+unexpectedWhen p =+  filterSWith (vanillaGen { ErrorGen.unexpected = ErrorGen.NamedItem . fromJust . p }) (isNothing . p)++unexpectedWithReasonWhen :: (a -> Maybe (String, String)) -> Parsec a -> Parsec a+unexpectedWithReasonWhen p =+  filterSWith (vanillaGen { ErrorGen.unexpected = ErrorGen.NamedItem . fst . fromJust . p+                          , ErrorGen.reason = fmap snd . p+                          }) (isNothing . p)++-- this is called mapFilter in Scala... there is no collect counterpart+{-+@since 0.2.2.0+-}+mapMaybeSWith :: ErrorGen a -> (a -> Maybe b) -> Parsec a -> Parsec b+mapMaybeSWith errGen f p = amendThenDislodgeBy 1 $ withWidth (entrench p) >>= \(x, w) ->+  maybe (ErrorGen.asErr errGen x w) pure (f x)

@@ -0,0 +1,62 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE OverloadedLists, RecordWildCards #-}+{-# OPTIONS_GHC -Wno-partial-fields #-}+module Text.Gigaparsec.Errors.ErrorGen (+    ErrorGen(..), UnexpectedItem(..), asFail, asSelect, asErr, vanillaGen, specializedGen+  ) where+import Text.Gigaparsec.Internal (Parsec)+import Text.Gigaparsec.Internal qualified as Internal (Parsec(Parsec), State, specialisedErr, emptyErr, expectedErr, unexpectedErr, raise)+import Text.Gigaparsec.Internal.Errors qualified as Internal (ParseError, CaretWidth(RigidCaret), addReason)++type ErrorGen :: * -> *+data ErrorGen a = SpecializedGen { messages :: a -> [String]+                                 , adjustWidth :: a -> Word -> Word+                                 }+                | VanillaGen { unexpected :: a -> UnexpectedItem+                             , reason :: a -> Maybe String+                             , adjustWidth :: a -> Word -> Word+                             }++vanillaGen :: ErrorGen a+vanillaGen = VanillaGen { unexpected = const EmptyItem+                        , reason = const Nothing+                        , adjustWidth = const id+                        }++specializedGen :: ErrorGen a+specializedGen = SpecializedGen { messages = const []+                                , adjustWidth = const id+                                }++type UnexpectedItem :: *+data UnexpectedItem = RawItem | EmptyItem | NamedItem String++asErr :: ErrorGen a -> a -> Word -> Parsec b+asErr errGen x w = Internal.raise $ \st -> genErr errGen st x w++asFail :: ErrorGen a -> Parsec (a, Word) -> Parsec b+asFail errGen (Internal.Parsec p) = Internal.Parsec $ \st _ bad ->+  let good (x, w) st' = bad (genErr errGen st' x w) st'+  in  p st good bad++asSelect :: ErrorGen a -> Parsec (Either (a, Word) b) -> Parsec b+asSelect errGen (Internal.Parsec p) = Internal.Parsec $ \st good bad ->+  let good' (Right x) st' = good x st'+      good' (Left (x, w)) st' = bad (genErr errGen st' x w) st'+  in p st good' bad++genErr :: ErrorGen a -> Internal.State -> a -> Word -> Internal.ParseError+genErr SpecializedGen{..} st x w =+  Internal.specialisedErr st (messages x) (Internal.RigidCaret (adjustWidth x w))+genErr VanillaGen{..} st x w =+  addReason (reason x) (makeError (unexpected x) st (adjustWidth x w))++makeError :: UnexpectedItem -> Internal.State -> Word -> Internal.ParseError+makeError RawItem st cw = Internal.expectedErr st [] cw+makeError EmptyItem st cw = Internal.emptyErr st cw+makeError (NamedItem name) st cw = Internal.unexpectedErr st [] name (Internal.RigidCaret cw)++-- no fold, unlifed type+addReason :: Maybe String -> Internal.ParseError -> Internal.ParseError+addReason Nothing err = err+addReason (Just reason) err = Internal.addReason reason err

@@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE DeriveFunctor, StandaloneDeriving, RecordWildCards, NamedFieldPuns, CPP #-}+{-# LANGUAGE DeriveFunctor, StandaloneDeriving, NamedFieldPuns, CPP #-} #include "portable-unlifted.h" {-# OPTIONS_HADDOCK hide #-} {-|

@@ -1,9 +1,8 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE RecordWildCards, BangPatterns, NamedFieldPuns, CPP #-} #include "portable-unlifted.h"-{-# OPTIONS_GHC -Wno-partial-fields -Wno-all-missed-specialisations #-}+{-# OPTIONS_GHC -Wno-partial-fields -Wno-all-missed-specialisations -Wno-missing-import-lists #-} {-# OPTIONS_HADDOCK hide #-}-{-# OPTIONS_GHC -Wno-missing-import-lists #-} module Text.Gigaparsec.Internal.Errors (module Text.Gigaparsec.Internal.Errors) where  import Prelude hiding (lines)@@ -122,8 +121,12 @@  explainErr :: Word -> String -> ParseError -> ParseError explainErr !offset reason err@VanillaError{}-  | offset == presentationOffset err = err { reasons = Set.insert reason (reasons err) }+  | offset == presentationOffset err = addReason reason err explainErr _ _ err = err++addReason :: String -> ParseError -> ParseError+addReason reason err@VanillaError{} = err { reasons = Set.insert reason (reasons err) }+addReason _ err = err  amendErr :: Word -> Word -> Word -> ParseError -> ParseError amendErr !offset !line !col err

@@ -1,5 +1,4 @@ {-# LANGUAGE Safe #-}-{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_GHC -Wno-all-missed-specialisations #-} module Text.Gigaparsec.Internal.Require (require, RequirementUnsatisfied) where

@@ -0,0 +1,91 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE OverloadedLists, NamedFieldPuns #-}+{-# OPTIONS_HADDOCK hide #-}+module Text.Gigaparsec.Internal.Token.Generic (module Text.Gigaparsec.Internal.Token.Generic) where++import Text.Gigaparsec ((<|>), many, Parsec, ($>), (<:>))+import Text.Gigaparsec.Char (satisfy, char, digit, hexDigit, octDigit, bit)+import Text.Gigaparsec.Combinator (optional)+import Text.Gigaparsec.Errors.Combinator ((<?>), hide)+import Text.Gigaparsec.Token.Descriptions (+    BreakCharDesc(BreakCharSupported, NoBreakChar),+    NumericDesc(NumericDesc, literalBreakChar, leadingZerosAllowed)+  )++import Data.Char (isDigit, isHexDigit, isOctDigit, digitToInt)+import Data.List (foldl')++type GenericNumeric :: *+data GenericNumeric = Generic { zeroAllowedDecimal :: Parsec Integer+                              , zeroAllowedHexadecimal :: Parsec Integer+                              , zeroAllowedOctal :: Parsec Integer+                              , zeroAllowedBinary :: Parsec Integer+                              , zeroNotAllowedDecimal :: Parsec Integer+                              , zeroNotAllowedHexadecimal :: Parsec Integer+                              , zeroNotAllowedOctal :: Parsec Integer+                              , zeroNotAllowedBinary :: Parsec Integer+                              -- FIXME: labels are configurable here+                              , plainDecimal :: NumericDesc -> Parsec Integer+                              , plainHexadecimal :: NumericDesc -> Parsec Integer+                              , plainOctal :: NumericDesc -> Parsec Integer+                              , plainBinary :: NumericDesc -> Parsec Integer+                              }++mkGeneric :: GenericNumeric+mkGeneric = Generic {..}+  where ofRadix1 :: Integer -> Parsec Char -> Parsec Integer+        ofRadix1 radix dig = ofRadix2 radix dig dig+        ofRadix2 :: Integer -> Parsec Char -> Parsec Char -> Parsec Integer+        ofRadix2 radix startDig dig =+          foldl' (withDigit radix) 0 <$> (startDig <:> many dig) --TODO: improve++        ofRadixBreak1 :: Integer -> Parsec Char -> Char -> Parsec Integer+        ofRadixBreak1 radix dig = ofRadixBreak2 radix dig dig+        ofRadixBreak2 :: Integer -> Parsec Char -> Parsec Char -> Char -> Parsec Integer+        ofRadixBreak2 radix startDig dig breakChar =+          foldl' (withDigit radix) 0 <$> (startDig <:> many (optional (char breakChar) *> dig)) --TODO: improve++        nonZeroDigit = satisfy (\c -> isDigit c && c /= '0') <?> ["digit"]+        nonZeroHexDigit = satisfy (\c -> isHexDigit c && c /= '0') <?> ["hexadecimal digit"]+        nonZeroOctDigit = satisfy (\c -> isOctDigit c && c /= '0') <?> ["octal digit"]+        nonZeroBit = char '1' <?> ["bit"]+        -- why secret? so that the above digits can be marked as digits without "non-zero or zero digit"+        secretZero :: Parsec Integer+        secretZero = hide (char '0') $> 0++        zeroAllowedDecimal = ofRadix1 10 digit+        zeroAllowedHexadecimal = ofRadix1 16 hexDigit+        zeroAllowedOctal = ofRadix1 8 octDigit+        zeroAllowedBinary = ofRadix1 2 bit++        zeroNotAllowedDecimal = ofRadix2 10 nonZeroDigit digit <|> secretZero+        zeroNotAllowedHexadecimal = ofRadix2 16 nonZeroHexDigit hexDigit <|> secretZero+        zeroNotAllowedOctal = ofRadix2 8 nonZeroOctDigit octDigit <|> secretZero+        zeroNotAllowedBinary = ofRadix2 2 nonZeroBit bit <|> secretZero++        plainDecimal NumericDesc{leadingZerosAllowed, literalBreakChar} = case literalBreakChar of+          NoBreakChar | leadingZerosAllowed            -> zeroAllowedDecimal+          NoBreakChar                                  -> zeroNotAllowedDecimal+          BreakCharSupported c _ | leadingZerosAllowed -> ofRadixBreak1 10 digit c+          BreakCharSupported c _                       -> ofRadixBreak2 10 nonZeroDigit digit c <|> secretZero++        plainHexadecimal NumericDesc{leadingZerosAllowed, literalBreakChar} = case literalBreakChar of+          NoBreakChar | leadingZerosAllowed            -> zeroAllowedDecimal+          NoBreakChar                                  -> zeroNotAllowedDecimal+          BreakCharSupported c _ | leadingZerosAllowed -> ofRadixBreak1 16 hexDigit c+          BreakCharSupported c _                       -> ofRadixBreak2 16 nonZeroHexDigit hexDigit c <|> secretZero++        plainOctal NumericDesc{leadingZerosAllowed, literalBreakChar} = case literalBreakChar of+          NoBreakChar | leadingZerosAllowed            -> zeroAllowedDecimal+          NoBreakChar                                  -> zeroNotAllowedDecimal+          BreakCharSupported c _ | leadingZerosAllowed -> ofRadixBreak1 8 octDigit c+          BreakCharSupported c _                       -> ofRadixBreak2 8 nonZeroOctDigit octDigit c <|> secretZero++        plainBinary NumericDesc{leadingZerosAllowed, literalBreakChar} = case literalBreakChar of+          NoBreakChar | leadingZerosAllowed            -> zeroAllowedDecimal+          NoBreakChar                                  -> zeroNotAllowedDecimal+          BreakCharSupported c _ | leadingZerosAllowed -> ofRadixBreak1 2 bit c+          BreakCharSupported c _                       -> ofRadixBreak2 2 nonZeroBit bit c <|> secretZero++withDigit :: Integer -> Integer -> Char -> Integer+withDigit radix n d = n * radix + fromIntegral (digitToInt d)

@@ -0,0 +1,216 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE OverloadedLists #-}+{-# OPTIONS_GHC -Wno-partial-fields #-}+{-# OPTIONS_HADDOCK hide #-}+module Text.Gigaparsec.Internal.Token.Lexer (+    Lexer, mkLexer,+    Lexeme, lexeme, nonlexeme, fully, space,+    apply, sym, symbol, names, -- more go here, no numeric and no text+    -- Numeric+    integer, natural,+    -- Text+    stringLiteral, rawStringLiteral, multiStringLiteral, rawMultiStringLiteral,+    charLiteral,+    -- Space+    Space, skipComments, whiteSpace, alter, initSpace,+  ) where++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.Errors.Combinator (hide, (<?>))++import Text.Gigaparsec.Token.Descriptions qualified as Desc+import Text.Gigaparsec.Internal.Token.Generic (mkGeneric)+import Text.Gigaparsec.Internal.Token.Symbol (Symbol, mkSym, mkSymbol)+import Text.Gigaparsec.Internal.Token.Symbol qualified as Symbol (lexeme)+import Text.Gigaparsec.Internal.Token.Names (Names, mkNames)+import Text.Gigaparsec.Internal.Token.Names qualified as Names (lexeme)+import Text.Gigaparsec.Internal.Token.Numeric (+    IntegerParsers, mkSigned, mkUnsigned,+    --FloatingParsers, mkSignedFloating, mkUnsignedFloating,+    --CombinedParsers, mkSignedCombined, mkUnsignedCombined,+    CanHoldSigned, CanHoldUnsigned+  )+import Text.Gigaparsec.Internal.Token.Numeric qualified as Numeric (lexemeInteger, {-lexemeFloating, lexemeCombined-})+import Text.Gigaparsec.Internal.Token.Text (+    TextParsers,+    mkStringParsers, mkCharacterParsers, mkEscape, mkEscapeChar, StringChar(RawChar)+  )+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 Control.Exception (Exception, throw)+import Control.Monad (join, guard)+import System.IO.Unsafe (unsafePerformIO)++type Lexer :: *+data Lexer = Lexer { lexeme :: !Lexeme+                   , nonlexeme :: !Lexeme+                   , fully :: !(forall a. Parsec a -> Parsec a)+                   , space :: !Space+                   }++mkLexer :: Desc.LexicalDesc -> Lexer+mkLexer Desc.LexicalDesc{..} = Lexer {..}+  where apply p = p <* whiteSpace space+        gen = mkGeneric+        lexeme = Lexeme { apply = apply+                        , sym = apply . sym nonlexeme+                        , symbol = Symbol.lexeme apply (symbol nonlexeme)+                        , names = Names.lexeme apply (names nonlexeme)+                        , natural = Numeric.lexemeInteger apply (natural nonlexeme)+                        , integer = Numeric.lexemeInteger apply (integer nonlexeme)+                        {-, floating = Numeric.lexemeFloating apply (floating nonlexeme)+                        , unsignedCombined =+                            Numeric.lexemeCombined apply (unsignedCombined nonlexeme)+                        , signedCombined =+                            Numeric.lexemeCombined apply (signedCombined nonlexeme)-}+                        , stringLiteral = Text.lexeme apply (stringLiteral nonlexeme)+                        , rawStringLiteral = Text.lexeme apply (rawStringLiteral nonlexeme)+                        , multiStringLiteral = Text.lexeme apply (multiStringLiteral nonlexeme)+                        , rawMultiStringLiteral = Text.lexeme apply (rawMultiStringLiteral nonlexeme)+                        , charLiteral = Text.lexeme apply (charLiteral nonlexeme)+                        }+        nonlexeme = NonLexeme { sym = mkSym symbolDesc (symbol nonlexeme)+                              , symbol = mkSymbol symbolDesc nameDesc+                              , names = mkNames nameDesc symbolDesc+                              , natural = mkUnsigned numericDesc gen+                              , integer = mkSigned numericDesc (natural nonlexeme)+                              {-, floating = mkSignedFloating numericDesc positiveFloating+                              , unsignedCombined = mkUnsignedCombined numericDesc (natural nonlexeme) positiveFloating+                              , signedCombined = mkSignedCombined numericDesc (unsignedCombined nonlexeme)-}+                              , stringLiteral = mkStringParsers stringEnds escapeChar graphicCharacter False+                              , rawStringLiteral = mkStringParsers stringEnds rawChar graphicCharacter False+                              , multiStringLiteral = mkStringParsers multiStringEnds escapeChar graphicCharacter True+                              , rawMultiStringLiteral = mkStringParsers multiStringEnds rawChar graphicCharacter True+                              , charLiteral = mkCharacterParsers textDesc escape+                              }+        --positiveFloating = mkUnsignedFloating numericDesc (natural nonlexeme) gen+        !escape = mkEscape (Desc.escapeSequences textDesc) mkGeneric -- this is mkGeneric because of errors+        graphicCharacter = Desc.graphicCharacter textDesc+        stringEnds = Desc.stringEnds textDesc+        multiStringEnds = Desc.multiStringEnds textDesc+        rawChar = RawChar+        escapeChar = mkEscapeChar (Desc.escapeSequences textDesc) escape (whiteSpace space)+        fully' p = whiteSpace space *> p <* eof+        fully p+          | Desc.whitespaceIsContextDependent spaceDesc = initSpace space *> fully' p+          | otherwise                                   = fully' p+        space = mkSpace spaceDesc++--TODO: better name for this, I guess?+type Lexeme :: *+data Lexeme = Lexeme+                { apply :: !(forall a. Parsec a -> Parsec a) -- this is tricky...+                , sym :: !(String -> Parsec ())+                , symbol :: !Symbol+                , names :: !Names+                , natural :: !(IntegerParsers CanHoldUnsigned)+                , integer :: !(IntegerParsers CanHoldSigned)+                -- desperate times, desperate measures+                --, floating :: !FloatingParsers+                --, unsignedCombined :: !CombinedParsers+                --, signedCombined :: !CombinedParsers+                , stringLiteral :: !(TextParsers String)+                , rawStringLiteral :: !(TextParsers String)+                , multiStringLiteral :: !(TextParsers String)+                , rawMultiStringLiteral :: !(TextParsers String)+                , charLiteral :: !(TextParsers Char)+                }+            | NonLexeme+                { sym :: !(String -> Parsec ())+                , symbol :: !Symbol+                , names :: !Names+                , natural :: !(IntegerParsers CanHoldUnsigned)+                , integer :: !(IntegerParsers CanHoldSigned)+                -- desperate times, desperate measures+                --, floating :: !FloatingParsers+                --, unsignedCombined :: !CombinedParsers+                --, signedCombined :: !CombinedParsers+                , stringLiteral :: !(TextParsers String)+                , rawStringLiteral :: !(TextParsers String)+                , multiStringLiteral :: !(TextParsers String)+                , rawMultiStringLiteral :: !(TextParsers String)+                , charLiteral :: !(TextParsers Char)+                }++type Space :: *+data Space = Space { whiteSpace :: !(Parsec ())+                   , skipComments :: !(Parsec ())+                   , alter :: forall a. Desc.CharPredicate -> Parsec a -> Parsec a+                   , initSpace :: Parsec ()+                   }++mkSpace :: Desc.SpaceDesc -> Space+mkSpace desc@Desc.SpaceDesc{..} = Space {..}+  where -- don't think we can trust doing initialisation here, it'll happen in some random order+        {-# NOINLINE wsImpl #-}+        !wsImpl = fromIORef (unsafePerformIO (newIORef (error "uninitialised space")))+        comment = commentParser desc -- do not make this strict+        implOf+          | supportsComments desc = hide . maybe skipComments (skipMany . (<|> comment) . void . satisfy)+          | otherwise             = hide . maybe empty (skipMany . satisfy)+        !configuredWhitespace = implOf space+        !whiteSpace+          | whitespaceIsContextDependent = join (get wsImpl)+          | otherwise                    = configuredWhitespace+        !skipComments = skipMany comment+        alter p+          | whitespaceIsContextDependent = rollback wsImpl . localWith wsImpl (implOf p)+          | otherwise                    = throw (UnsupportedOperation badAlter)+        initSpace+          | whitespaceIsContextDependent = put 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"++{-+We have the following invariances to be checked up front:+  * at least one kind of comment must be enabled+  * the starts of line and multiline must not overlap++-- TODO: needs error messages put in (is the hide correct)+-- TODO: remove guard, configure properly+-}+commentParser :: Desc.SpaceDesc -> Parsec ()+commentParser Desc.SpaceDesc{..} =+  require (multiEnabled || singleEnabled) "skipComments" noComments $+    require (not (multiEnabled && isPrefixOf multiLineCommentStart lineCommentStart)) "skipComments" noOverlap $+      hide (multiLine <|> singleLine)+  where+    -- can't make these strict until guard is gone+    openComment = atomic (string multiLineCommentStart)+    closeComment = atomic (string multiLineCommentEnd) <?> ["end of comment"]+    multiLine = guard multiEnabled *> openComment *> wellNested 1+    wellNested :: Int -> Parsec ()+    wellNested 0 = unit+    wellNested n = closeComment *> wellNested (n - 1)+               <|> guard multiLineNestedComments *> openComment *> wellNested (n + 1)+               <|> item *> wellNested n+    singleLine = guard singleEnabled+              *> atomic (string lineCommentStart)+              *> skipManyTill item (endOfLineComment <?> ["end of comment"])++    endOfLineComment+      | lineCommentAllowsEOF = void endOfLine <|> eof+      | otherwise            = void endOfLine++    multiEnabled = not (null multiLineCommentStart || null multiLineCommentEnd)+    singleEnabled = not (null lineCommentStart)+    noComments = "one of single- or multi-line comments must be enabled"+    noOverlap = "single-line comments must not overlap with multi-line comments"++supportsComments :: Desc.SpaceDesc -> Bool+supportsComments Desc.SpaceDesc{..} = not (null lineCommentStart && null multiLineCommentStart)++type UnsupportedOperation :: *+newtype UnsupportedOperation = UnsupportedOperation String deriving stock Eq+instance Show UnsupportedOperation where+  show (UnsupportedOperation msg) = "unsupported operation: " ++ msg+instance Exception UnsupportedOperation

@@ -0,0 +1,80 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE OverloadedLists #-}+{-# OPTIONS_HADDOCK hide #-}+module Text.Gigaparsec.Internal.Token.Names (+    Names, mkNames,+    identifier, identifier',+    userDefinedOperator, userDefinedOperator',+    lexeme+  ) where++import Text.Gigaparsec (Parsec, empty, (<:>), atomic)+import Text.Gigaparsec.Char (stringOfMany, satisfy)+import Text.Gigaparsec.Errors.Combinator ((<?>), unexpectedWhen)++import Data.Set qualified as Set (member, map)++import Text.Gigaparsec.Token.Descriptions (+    SymbolDesc(SymbolDesc, hardKeywords, hardOperators, caseSensitive),+    NameDesc(NameDesc, identifierStart, identifierLetter,+                       operatorStart, operatorLetter),+    CharPredicate+  )+import Data.Char (toLower)++-- TODO: primes are gross, better way?+type Names :: *+data Names = Names { identifier :: !(Parsec String)+                   , identifier' :: !(CharPredicate -> Parsec String)+                   , userDefinedOperator :: !(Parsec String)+                   , userDefinedOperator' :: !(CharPredicate -> Parsec String)+                   }++mkNames :: NameDesc -> SymbolDesc -> Names+mkNames NameDesc{..} symbolDesc@SymbolDesc{..} = Names {..}+  where+    -- TODO: error transformers+    !isReserved = isReservedName symbolDesc+    !identifier =+      keyOrOp identifierStart identifierLetter isReserved "identifier" ("keyword " ++)+    identifier' start =+      unexpectedWhen (\v -> if startsWith start v then Nothing else Just ("identifier " ++ v))+                     identifier+    !userDefinedOperator =+      keyOrOp operatorStart operatorLetter (flip Set.member hardOperators) "operator" ("reserved operator " ++)+    userDefinedOperator' start =+      unexpectedWhen (\v -> if startsWith start v then Nothing else Just ("operator " ++ v))+                     userDefinedOperator++    keyOrOp :: CharPredicate -> CharPredicate -> (String -> Bool) -> String -> (String -> String) -> Parsec String+    keyOrOp start letter illegal name unexpectedIllegal =+      atomic (unexpectedWhen cond (complete start letter)) <?> [name]+      where cond x+              | illegal x = Just (unexpectedIllegal x)+              | otherwise = Nothing++    trailer :: CharPredicate -> Parsec String+    trailer = maybe (pure "") stringOfMany++    complete :: CharPredicate -> CharPredicate -> Parsec String+    complete (Just start) letter = satisfy start <:> trailer letter+    complete Nothing _ = empty++    startsWith :: CharPredicate -> String -> Bool+    startsWith Nothing _ = True+    startsWith (Just _) [] = False+    startsWith (Just p) (c:_) = p c++lexeme :: (forall a. Parsec a -> Parsec a) -> Names -> Names+lexeme lexe Names{..} = Names { identifier = lexe identifier+                              , identifier' = lexe . identifier'+                              , userDefinedOperator = lexe userDefinedOperator+                              , userDefinedOperator' = lexe . userDefinedOperator'+                              }++isReservedName :: SymbolDesc -> String -> Bool+isReservedName SymbolDesc{..}+  | caseSensitive = flip Set.member hardKeywords+  | otherwise     = flip Set.member lowerHardKeywords . allLower+  where allLower = map toLower+        lowerHardKeywords = Set.map allLower hardKeywords

@@ -0,0 +1,328 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE DataKinds, ConstraintKinds, MultiParamTypeClasses, AllowAmbiguousTypes, FlexibleInstances, FlexibleContexts, UndecidableInstances, ApplicativeDo, TypeFamilies, TypeOperators, CPP #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# OPTIONS_HADDOCK hide #-}+module Text.Gigaparsec.Internal.Token.Numeric (module Text.Gigaparsec.Internal.Token.Numeric) where++import Text.Gigaparsec (Parsec, unit, void, atomic, (<|>), ($>))+import Text.Gigaparsec.Char (char, oneOf)+import Text.Gigaparsec.Combinator (optional, optionalAs)+import Text.Gigaparsec.Errors.Combinator (mapMaybeSWith)+import Text.Gigaparsec.Errors.ErrorGen (specializedGen, messages)+import Text.Gigaparsec.Token.Descriptions+    ( BreakCharDesc(BreakCharSupported, NoBreakChar),+      NumericDesc( NumericDesc, positiveSign, literalBreakChar+                 , integerNumbersCanBeHexadecimal, integerNumbersCanBeOctal+                 , integerNumbersCanBeBinary+                 , hexadecimalLeads, octalLeads, binaryLeads+                 ),+      PlusSignPresence(PlusIllegal, PlusRequired, PlusOptional) )+import Text.Gigaparsec.Internal.Token.Generic (GenericNumeric(plainDecimal, plainHexadecimal, plainOctal, plainBinary))+import Data.Char (intToDigit)+import Data.Kind (Constraint)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64)+import Numeric.Natural (Natural)+import Data.Proxy (Proxy(Proxy))+import Control.Monad (when, unless)+import Numeric (showIntAtBase)++#if __GLASGOW_HASKELL__ >= 904++import GHC.TypeLits (type (<=?), Nat)+import GHC.TypeError (TypeError, ErrorMessage(Text, (:<>:), ShowType), Assert)++#else++import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(Text, (:<>:), ShowType))++type Assert :: Bool -> Constraint -> Constraint+type family Assert b c where+  Assert 'True  _ = ()+  Assert 'False c = c++#endif++type Bits :: *+data Bits = B8 | B16 | B32 | B64++type BitWidth :: * -> Bits+type family BitWidth t where+  BitWidth Integer = 'B64+  BitWidth Int     = 'B64+  BitWidth Word    = 'B64+  BitWidth Word64  = 'B64+  BitWidth Natural = 'B64+  BitWidth Int32   = 'B32+  BitWidth Word32  = 'B32+  BitWidth Int16   = 'B16+  BitWidth Word16  = 'B16+  BitWidth Int8    = 'B8+  BitWidth Word8   = 'B8+  BitWidth t       = TypeError ('Text "The type '" ' :<>: 'ShowType t+                          ':<>: 'Text "' is not a numeric type supported by Gigaparsec")++type SignednessK :: *+data SignednessK = Signed | Unsigned++type Signedness :: * -> SignednessK -> Constraint+type family Signedness t s where+  Signedness Integer _         = () -- integers are allowed to serve as both unsigned and signed+  Signedness Int     'Signed   = ()+  Signedness Word    'Unsigned = ()+  Signedness Word64  'Unsigned = ()+  Signedness Natural 'Unsigned = ()+  Signedness Int32   'Signed   = ()+  Signedness Word32  'Unsigned = ()+  Signedness Int16   'Signed   = ()+  Signedness Word16  'Unsigned = ()+  Signedness Int8    'Signed   = ()+  Signedness Word8   'Unsigned = ()+  Signedness t       'Signed   = TypeError ('Text "The type '" ':<>: 'ShowType t+                                      ':<>: 'Text "' does not hold signed numbers")+  Signedness t       'Unsigned = TypeError ('Text "The type '" ' :<>: 'ShowType t+                                      ':<>: 'Text "' does not hold unsigned numbers")++type ShowBits :: Bits -> ErrorMessage+type ShowBits b = 'ShowType (BitsNat b)++-- This is intentionally not a type alias. On GHC versions < 9.4.1 it appears that TypeErrors are+-- reported slightly more eagerly and we get an error on this definition because+-- > BitsNat b <=? BitsNat (BitWidth t)+-- cannot be solved+type HasWidthFor :: Bits -> * -> Constraint+type family HasWidthFor bits t where+  HasWidthFor bits t = Assert (BitsNat bits <=? BitsNat (BitWidth t))+                              (TypeError ('Text "The type '"+                                    ':<>: 'ShowType t  ' :<>: 'Text "' cannot store a "+                                    ':<>: ShowBits bits ' :<>: 'Text " bit number (only supports up to "+                                    ':<>: ShowBits (BitWidth t) ' :<>: 'Text " bits)."))++type BitBounds :: Bits -> Constraint+class BitBounds b where+  upperSigned :: Integer+  lowerSigned :: Integer+  upperUnsigned :: Integer+  bits :: Int+  type BitsNat b :: Nat+instance BitBounds 'B8 where+  upperSigned = fromIntegral (maxBound @Int8)+  lowerSigned = fromIntegral (minBound @Int8)+  upperUnsigned = fromIntegral (maxBound @Word8)+  bits = 8+  type BitsNat 'B8 = 8+instance BitBounds 'B16 where+  upperSigned = fromIntegral (maxBound @Int16)+  lowerSigned = fromIntegral (minBound @Int16)+  upperUnsigned = fromIntegral (maxBound @Word16)+  bits = 16+  type BitsNat 'B16 = 16+instance BitBounds 'B32 where+  upperSigned = fromIntegral (maxBound @Int32)+  lowerSigned = fromIntegral (minBound @Int32)+  upperUnsigned = fromIntegral (maxBound @Word32)+  bits = 32+  type BitsNat 'B32 = 32+instance BitBounds 'B64 where+  upperSigned = fromIntegral (maxBound @Int64)+  lowerSigned = fromIntegral (minBound @Int64)+  upperUnsigned = fromIntegral (maxBound @Word64)+  bits = 64+  type BitsNat 'B64 = 64++type CanHoldSigned :: Bits -> * -> Constraint+class (BitBounds bits, Num t) => CanHoldSigned bits t where+instance (BitBounds bits, Num t, Signedness t 'Signed, HasWidthFor bits t) => CanHoldSigned bits t++type CanHoldUnsigned :: Bits -> * -> Constraint+class (BitBounds bits, Num t) => CanHoldUnsigned bits t where+instance (BitBounds bits, Num t, Signedness t 'Unsigned, HasWidthFor bits t) => CanHoldUnsigned bits t++type IntegerParsers :: (Bits -> * -> Constraint) -> *+data IntegerParsers canHold = IntegerParsers { decimal :: Parsec Integer+                                             , hexadecimal :: Parsec Integer+                                             , octal :: Parsec Integer+                                             , binary :: Parsec Integer+                                             , number :: Parsec Integer+                                             , _bounded :: forall (bits :: Bits) t. canHold bits t => Proxy bits -> Parsec Integer -> Int -> Parsec t+                                             }++decimalBounded :: forall (bits :: Bits) canHold t. canHold bits t => IntegerParsers canHold -> Parsec t+decimalBounded IntegerParsers{..} = _bounded (Proxy @bits) decimal 10++hexadecimalBounded :: forall (bits :: Bits) canHold t. canHold bits t => IntegerParsers canHold -> Parsec t+hexadecimalBounded IntegerParsers{..} = _bounded (Proxy @bits) hexadecimal 16++octalBounded :: forall (bits :: Bits) canHold t. canHold bits t => IntegerParsers canHold -> Parsec t+octalBounded IntegerParsers{..} = _bounded (Proxy @bits) octal 8++binaryBounded :: forall (bits :: Bits) canHold t. canHold bits t => IntegerParsers canHold -> Parsec t+binaryBounded IntegerParsers{..} = _bounded (Proxy @bits) binary 2++numberBounded :: forall (bits :: Bits) canHold t. canHold bits t => IntegerParsers canHold -> Parsec t+numberBounded IntegerParsers{..} = _bounded (Proxy @bits) number 10++decimal8 :: forall a canHold. canHold 'B8 a => IntegerParsers canHold -> Parsec a+decimal8 = decimalBounded @'B8+hexadecimal8 :: forall a canHold. canHold 'B8 a => IntegerParsers canHold -> Parsec a+hexadecimal8 = hexadecimalBounded @'B8+octal8 :: forall a canHold. canHold 'B8 a => IntegerParsers canHold -> Parsec a+octal8 = octalBounded @'B8+binary8 :: forall a canHold. canHold 'B8 a => IntegerParsers canHold -> Parsec a+binary8 = binaryBounded @'B8+number8 :: forall a canHold. canHold 'B8 a => IntegerParsers canHold -> Parsec a+number8 = numberBounded @'B8++decimal16 :: forall a canHold. canHold 'B16 a => IntegerParsers canHold -> Parsec a+decimal16 = decimalBounded @'B16+hexadecimal16 :: forall a canHold. canHold 'B16 a => IntegerParsers canHold -> Parsec a+hexadecimal16 = hexadecimalBounded @'B16+octal16 :: forall a canHold. canHold 'B16 a => IntegerParsers canHold -> Parsec a+octal16 = octalBounded @'B16+binary16 :: forall a canHold. canHold 'B16 a => IntegerParsers canHold -> Parsec a+binary16 = binaryBounded @'B16+number16 :: forall a canHold. canHold 'B16 a => IntegerParsers canHold -> Parsec a+number16 = numberBounded @'B16++decimal32 :: forall a canHold. canHold 'B32 a => IntegerParsers canHold -> Parsec a+decimal32 = decimalBounded @'B32+hexadecimal32 :: forall a canHold. canHold 'B32 a => IntegerParsers canHold -> Parsec a+hexadecimal32 = hexadecimalBounded @'B32+octal32 :: forall a canHold. canHold 'B32 a => IntegerParsers canHold -> Parsec a+octal32 = octalBounded @'B32+binary32 :: forall a canHold. canHold 'B32 a => IntegerParsers canHold -> Parsec a+binary32 = binaryBounded @'B32+number32 :: forall a canHold. canHold 'B32 a => IntegerParsers canHold -> Parsec a+number32 = numberBounded @'B32++decimal64 :: forall a canHold. canHold 'B64 a => IntegerParsers canHold -> Parsec a+decimal64 = decimalBounded @'B64+hexadecimal64 :: forall a canHold. canHold 'B64 a => IntegerParsers canHold -> Parsec a+hexadecimal64 = hexadecimalBounded @'B64+octal64 :: forall a canHold. canHold 'B64 a => IntegerParsers canHold -> Parsec a+octal64 = octalBounded @'B64+binary64 :: forall a canHold. canHold 'B64 a => IntegerParsers canHold -> Parsec a+binary64 = binaryBounded @'B64+number64 :: forall a canHold. canHold 'B64 a => IntegerParsers canHold -> Parsec a+number64 = numberBounded @'B64++outOfBounds :: Integer -> Integer -> Int -> Integer -> [String]+outOfBounds small big radix _n = [+    "literal is not within the range " ++ resign small (" to " ++ resign big "")+  ]+  where resign n+          | n < 0 = ('-' :) . showIntAtBase (toInteger radix) intToDigit (abs n)+          | otherwise = showIntAtBase (toInteger radix) intToDigit n++mkUnsigned :: NumericDesc -> GenericNumeric -> IntegerParsers CanHoldUnsigned+mkUnsigned desc@NumericDesc{..} gen = IntegerParsers {..}+  where _bounded :: forall (bits :: Bits) t. CanHoldUnsigned bits t+                 => Proxy bits -> Parsec Integer -> Int -> Parsec t+        _bounded _ num radix = mapMaybeSWith+          (specializedGen { messages = outOfBounds 0 (upperUnsigned @bits) radix })+          (\n -> if n >= 0 && n <= upperUnsigned @bits then Just (fromInteger n) else Nothing)+          num++        leadingBreakChar = case literalBreakChar of+          NoBreakChar -> unit+          BreakCharSupported breakChar allowedAfterNonDecimalPrefix ->+            when allowedAfterNonDecimalPrefix (optional (char breakChar))++        noZeroHexadecimal = do+          unless (null hexadecimalLeads) (void (oneOf hexadecimalLeads))+          leadingBreakChar+          plainHexadecimal gen desc++        noZeroOctal = do+          unless (null octalLeads) (void (oneOf octalLeads))+          leadingBreakChar+          plainOctal gen desc++        noZeroBinary = do+          unless (null binaryLeads) (void (oneOf binaryLeads))+          leadingBreakChar+          plainBinary gen desc++        decimal = plainDecimal gen desc+        hexadecimal = atomic (char '0' *> noZeroHexadecimal)+        octal = atomic (char '0' *> noZeroOctal)+        binary = atomic (char '0' *> noZeroBinary)+        number+          | not integerNumbersCanBeBinary+          , not integerNumbersCanBeHexadecimal+          , not integerNumbersCanBeOctal = decimal+          | otherwise = atomic (zeroLead <|> decimal)+          where zeroLead = char '0' *> addHex (addOct (addBin (decimal <|> pure 0)))+                addHex+                  | integerNumbersCanBeHexadecimal = (noZeroHexadecimal <|>)+                  | otherwise = id+                addOct+                  | integerNumbersCanBeOctal = (noZeroOctal <|>)+                  | otherwise = id+                addBin+                  | integerNumbersCanBeBinary = (noZeroBinary <|>)+                  | otherwise = id++mkSigned :: NumericDesc -> IntegerParsers c -> IntegerParsers CanHoldSigned+mkSigned NumericDesc{..} unsigned = IntegerParsers {+    decimal = _decimal,+    hexadecimal = _hexadecimal,+    octal = _octal,+    binary = _binary,+    number = _number,+    ..+  }+  where _bounded :: forall (bits :: Bits) t. CanHoldSigned bits t+                 => Proxy bits -> Parsec Integer -> Int -> Parsec t+        _bounded _ num radix = mapMaybeSWith+          (specializedGen { messages = outOfBounds (lowerSigned @bits) (upperSigned @bits) radix })+          (\n -> if n >= lowerSigned @bits && n <= upperSigned @bits+                 then Just (fromInteger n)+                 else Nothing)+          num++        sign :: Parsec (Integer -> Integer)+        sign = case positiveSign of+          PlusRequired -> char '+' $> id <|> char '-' $> negate+          PlusOptional -> char '-' $> negate <|> optionalAs id (char '+')+          PlusIllegal  -> pure id+        _decimal = atomic (sign <*> decimal unsigned)+        _hexadecimal = atomic (sign <*> hexadecimal unsigned)+        _octal = atomic (sign <*> octal unsigned)+        _binary = atomic (sign <*> binary unsigned)+        _number = atomic (sign <*> number unsigned)++{-type FloatingParsers :: *+data FloatingParsers = FloatingParsers {}++mkUnsignedFloating :: NumericDesc -> IntegerParsers CanHoldUnsigned -> GenericNumeric -> FloatingParsers+mkUnsignedFloating NumericDesc{..} nat gen = FloatingParsers {}++mkSignedFloating :: NumericDesc -> FloatingParsers -> FloatingParsers+mkSignedFloating NumericDesc{..} unsigned = FloatingParsers {}++type CombinedParsers :: *+data CombinedParsers = CombinedParsers {}++mkUnsignedCombined :: NumericDesc -> IntegerParsers CanHoldUnsigned -> FloatingParsers -> CombinedParsers+mkUnsignedCombined NumericDesc{..} natural floating = CombinedParsers {}++mkSignedCombined :: NumericDesc -> CombinedParsers -> CombinedParsers+mkSignedCombined NumericDesc{..} unsigned = CombinedParsers {}-}++lexemeInteger :: (forall a. Parsec a -> Parsec a) -> IntegerParsers c -> IntegerParsers c+lexemeInteger lexe IntegerParsers{..} = IntegerParsers {+    decimal = lexe decimal,+    hexadecimal = lexe hexadecimal,+    octal = lexe octal,+    binary = lexe binary,+    number = lexe number,+    _bounded = \n b radix -> lexe (_bounded n b radix)+  }++{-lexemeFloating :: (forall a. Parsec a -> Parsec a) -> FloatingParsers -> FloatingParsers+lexemeFloating = const id++lexemeCombined :: (forall a. Parsec a -> Parsec a) -> CombinedParsers -> CombinedParsers+lexemeCombined = const id+-}

@@ -0,0 +1,73 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE RecordWildCards, OverloadedLists #-}+{-# OPTIONS_HADDOCK hide #-}+module Text.Gigaparsec.Internal.Token.Symbol (+    Symbol, softKeyword, softOperator, mkSymbol, mkSym, lexeme+  ) where++import Text.Gigaparsec (Parsec, void, notFollowedBy, atomic, (<|>), empty)+import Text.Gigaparsec.Char (string, satisfy, char, strings)+import Text.Gigaparsec.Token.Descriptions ( SymbolDesc(SymbolDesc, hardKeywords, hardOperators, caseSensitive)+                                          , NameDesc(NameDesc, identifierLetter, operatorLetter)+                                          , CharPredicate+                                          )++import Data.Set qualified as Set (member, toList, fromList, null)+import Data.Char (toUpper, toLower, isLetter)+import Text.Gigaparsec.Errors.Combinator (amend, emptyWide, (<?>))+import Data.Set (Set)+import Data.Maybe (mapMaybe)+import Text.Gigaparsec.Internal.Require (require)++type Symbol :: *+data Symbol = Symbol { softKeyword :: !(String -> Parsec ())+                     , softOperator :: !(String -> Parsec ())+                     }++mkSymbol :: SymbolDesc -> NameDesc -> Symbol+mkSymbol SymbolDesc{..} NameDesc{..} = Symbol {..}+  where softKeyword name = require (not (null name)) "softKeyword" "keywords may not be empty"+          (_softKeyword caseSensitive identifierLetter name <?> [name])+        softOperator name = require (not (null name)) "softOperator" "operators may not be empty"+          (_softOperator hardOperators operatorLetter name <?> [name])++mkSym :: SymbolDesc -> Symbol -> (String -> Parsec ())+mkSym SymbolDesc{..} Symbol{..} str+  | Set.member str hardKeywords  = softKeyword str+  | Set.member str hardOperators = softOperator str+  | otherwise                    = void (atomic (string str))++lexeme :: (forall a. Parsec a -> Parsec a) -> Symbol -> Symbol+lexeme lexe Symbol{..} = Symbol { softKeyword = lexe . softKeyword+                                , softOperator = lexe . softOperator+                                }++_softKeyword :: Bool -> CharPredicate -> String -> Parsec ()+_softKeyword caseSensitive letter kw+  | caseSensitive = atomic (nfb letter caseString)+  | otherwise     = atomic (nfb letter (string kw))+  where nfb Nothing p = void p+        nfb (Just c) p = p *> (notFollowedBy (satisfy c) <?> ["end of " ++ kw])+        n = length kw+        caseChar c+          | isLetter c = char (toUpper c) <|> char (toLower c)+          | otherwise  = char c+        caseString = atomic (amend (traverse caseChar kw))+                 <|> emptyWide (fromIntegral n)++-- TODO: trie-based implementation+_softOperator :: Set String -> CharPredicate -> String -> Parsec ()+_softOperator hardOperators letter op =+  if Set.null ends then atomic (string op *> notFollowedBy letter')+  else atomic (string op *> (notFollowedBy (void letter' <|> void (strings ends)) <?> ["end of " ++ op]))+  where ends = Set.fromList (mapMaybe (flip strip op) (Set.toList hardOperators))+        letter' = maybe empty satisfy letter+        strip []      str@(:){}          = Just str+        strip (c:pre) (c':str) | c == c' = strip pre str+        strip _       _                  = Nothing++-- TODO: HasField instances for the dot/comma/etc?+-- FIXME: to make these work, well need to move sym into Symbol?+{-dot :: Symbol -> Parsec ()+dot =+-}

@@ -0,0 +1,206 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE OverloadedLists, OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_HADDOCK hide #-}+module Text.Gigaparsec.Internal.Token.Text (module Text.Gigaparsec.Internal.Token.Text) where++import Text.Gigaparsec (Parsec, void, (<|>), empty, somel, (<~>), ($>), atomic, some)+import Text.Gigaparsec.Char (char, digit, hexDigit, octDigit, bit, satisfy, trie, string)+import Text.Gigaparsec.Token.Descriptions (+    TextDesc(TextDesc, characterLiteralEnd, graphicCharacter),+    EscapeDesc(EscapeDesc, escBegin, emptyEscape, gapsSupported, mapping, literals,+               decimalEscape, hexadecimalEscape, octalEscape, binaryEscape),+    NumericEscape(NumericSupported, NumericIllegal, numDigits, maxValue, prefix),+    CharPredicate,+    NumberOfDigits(Exactly, AtMost, Unbounded)+  )+import Text.Gigaparsec.Internal.Token.Generic (GenericNumeric(zeroAllowedDecimal, zeroAllowedHexadecimal, zeroAllowedOctal, zeroAllowedBinary))+import Data.Char (isSpace, chr, ord, digitToInt, isAscii, isLatin1, intToDigit)+import Data.Map qualified as Map (insert, map)+import Data.Set (Set)+import Data.Set qualified as Set (toList)+import Data.List.NonEmpty (NonEmpty((:|)), sort)+import Data.List.NonEmpty qualified as NonEmpty (toList)+import Text.Gigaparsec.Registers (Reg, make, unsafeMake, gets, modify, put, get)+import Text.Gigaparsec.Combinator (guardS, choice, manyTill)+import Text.Gigaparsec.Errors.Combinator (filterOut, (<?>), label, explain, mapMaybeSWith)+import Control.Applicative (liftA3)+import Data.Maybe (catMaybes)+import Text.Gigaparsec.Errors.ErrorGen (specializedGen, messages)+import Text.Gigaparsec.Errors.DefaultErrorBuilder (disjunct, toString, from)+import Numeric (showIntAtBase)++-- TODO: is it possible to /actually/ support Text/Bytestring in future?+-- Perhaps something like the Numeric stuff?+type TextParsers :: * -> *+data TextParsers t = TextParsers { unicode :: Parsec t+                                 , ascii :: Parsec t+                                 , latin1 :: Parsec t+                                 }++-- I want the convenient naming, sue me+type StringParsers :: *+type StringParsers = TextParsers String++type CharacterParsers :: *+type CharacterParsers = TextParsers Char++mkCharacterParsers :: TextDesc -> Escape -> CharacterParsers+mkCharacterParsers TextDesc{..} escape = TextParsers {..}+  where unicode = lit uncheckedUniLetter+        ascii = lit (filterOut (\c -> if c > '\x7f' then Just "non-ascii character" else Nothing) uncheckedUniLetter)+        latin1 = lit (filterOut (\c -> if c > '\xff' then Just "non-latin1 character" else Nothing) uncheckedUniLetter)++        quote = char characterLiteralEnd+        lit c = quote *> c <* quote+        uncheckedUniLetter = escapeChar escape <|> graphic++        graphic = maybe empty satisfy (letter characterLiteralEnd False graphicCharacter) <?> ["graphic character"]++type StringChar :: *+data StringChar = RawChar+                | EscapeChar {-# UNPACK #-} !Char (Parsec (Maybe Char))++mkEscapeChar :: EscapeDesc -> Escape -> Parsec () -> StringChar+mkEscapeChar !desc !esc !space = EscapeChar (escBegin desc) stringEsc+  where stringEsc = escapeBegin esc *> (escapeGap $> Nothing <|>+                                        escapeEmpty $> Nothing <|>+                                        Just <$> escapeCode esc)+        escapeEmpty = maybe empty char (emptyEscape desc)+        escapeGap+          | gapsSupported desc = some (space <?> ["string gap"]) *> (escapeBegin esc <?> ["end of string gap"])+          | otherwise = empty++mkChar :: StringChar -> CharPredicate -> Parsec (Maybe Char)+mkChar RawChar = maybe empty (fmap Just . label ["string character"] . satisfy)+mkChar (EscapeChar escBegin stringEsc) =+  foldr (\p -> label ["string character"] . (<|> fmap Just (satisfy (\c -> p c && c /= escBegin) <?> ["graphic character"])))+        stringEsc++isRawChar :: StringChar -> Bool+isRawChar RawChar = True+isRawChar EscapeChar{} = False++ensureAscii :: Parsec String -> Parsec String+ensureAscii = filterOut $ \s ->+  if not (all isAscii s) then Just "non-ascii characters in string literal, this is not allowed"+  else Nothing++ensureLatin1 :: Parsec String -> Parsec String+ensureLatin1 = filterOut $ \s ->+  if not (all isLatin1 s) then Just "non-latin1 characters in string literal, this is not allowed"+  else Nothing++mkStringParsers :: Set (String, String) -> StringChar -> CharPredicate -> Bool -> StringParsers+mkStringParsers !ends !stringChar !isGraphic !allowsAllSpace = TextParsers {..}+  where ascii = stringLiteral ensureAscii+        latin1 = stringLiteral ensureLatin1+        unicode = stringLiteral id++        stringLiteral :: (Parsec String -> Parsec String) -> Parsec String+        stringLiteral valid = choice (map (uncurry (makeStringParser valid)) (Set.toList ends))++        makeStringParser :: (Parsec String -> Parsec String) -> String -> String -> Parsec String+        makeStringParser valid begin end@(terminalInit : _) =+          let strChar = mkChar stringChar (letter terminalInit allowsAllSpace isGraphic)+          in (string begin *>) . valid $+               catMaybes <$> manyTill (Just <$> char terminalInit <|> strChar) (atomic (string end))+        makeStringParser _ _ [] = error "string terminals cannot be empty"++letter :: Char -> Bool -> CharPredicate -> CharPredicate+letter !terminalLead !allowsAllSpace (Just g)+  | allowsAllSpace = Just $ \c -> c /= terminalLead && (g c || isSpace c)+  | otherwise      = Just $ \c -> c /= terminalLead && g c+letter _ _ Nothing = Nothing++type Escape :: *+data Escape = Escape { escapeCode :: !(Parsec Char)+                     , escapeBegin :: !(Parsec ())+                     , escapeChar :: !(Parsec Char)+                     }++mkEscape :: EscapeDesc -> GenericNumeric -> Escape+mkEscape EscapeDesc{..} gen = Escape {..}+  where+    escapeBegin = void (char escBegin) <?> ["escape sequence"]+    escapeCode = explain "invalid escape sequence" $ label ["end of escape sequence"] $+      escMapped <|> numericEscape+    escapeChar = escapeBegin *> escapeCode++    escs = foldr (\c -> Map.insert [c] c) mapping literals+    escMapped = trie (Map.map pure escs)++    numericEscape = decimalEsc <|> hexadecimalEsc <|> octalEsc <|> binaryEsc++    decimalEsc = fromDesc 10 decimalEscape (zeroAllowedDecimal gen) digit+    hexadecimalEsc = fromDesc 16 hexadecimalEscape (zeroAllowedHexadecimal gen) hexDigit+    octalEsc = fromDesc 8 octalEscape (zeroAllowedOctal gen) octDigit+    binaryEsc = fromDesc 2 binaryEscape (zeroAllowedBinary gen) bit++    boundedChar :: Parsec Integer -> Char -> Maybe Char -> Int -> Parsec Char+    boundedChar p maxValue prefix radix = foldr (\c t -> char c *> t) (mapMaybeSWith err f p) prefix+      where f c+             | c < toInteger (ord maxValue) = Just (chr (fromInteger c))+             | otherwise = Nothing+            err = specializedGen { messages = messages }+            messages :: Integer -> [String]+            messages c+              | c > toInteger (ord maxValue) =+                  [showIntAtBase (toInteger radix) intToDigit c+                    (" is greater than the maximum character value of "+                    ++ showIntAtBase (toInteger radix) intToDigit (toInteger (ord maxValue)) "")]+              | otherwise = ["illegal unicode character: "+                          ++ showIntAtBase (toInteger radix) intToDigit c ""]+++    atMost' :: Int -> Parsec Char -> Reg 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)++    atMost :: Word -> Int -> Parsec Char -> Parsec Integer+    atMost n radix dig = make n (atMost' radix dig)++    exactly :: Word -> Word -> Int -> Parsec Char -> NonEmpty Word -> Parsec Integer+    exactly n full radix dig reqDigits = make n $ \atMostR ->+      mapMaybeSWith (specializedGen {messages = messages})+                    (\(num, m) -> if m == full then Just num else Nothing)+                    (atMost' radix dig atMostR <~> gets atMostR (full -))+      where messages :: (Integer, Word) -> [String]+            messages (_, got) =+              [toString ("numeric escape requires " <> formatted <> "digits, but only got" <> from got)]+            ~(Just formatted) = disjunct True (map show (NonEmpty.toList reqDigits))++    oneOfExactly' :: NonEmpty Word -> Word -> Word -> [Word] -> Int -> Parsec Char -> Reg r Word -> Parsec Integer+    oneOfExactly' reqDigits digits m [] radix dig digitsParsed =+      exactly digits m radix dig reqDigits <* put 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+          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+      in liftA3 combine theseDigits restDigits (get digitsParsed)++    oneOfExactly :: NonEmpty Word -> Int -> Parsec Char -> Parsec Integer+    oneOfExactly ns radix dig =+      let reqDigits@(m :| ms) = sort ns+      in unsafeMake (oneOfExactly' reqDigits m m ms radix dig)++    fromDesc :: Int -> NumericEscape -> Parsec Integer -> Parsec Char -> Parsec Char+    fromDesc !_ NumericIllegal !_ !_ = empty+    fromDesc radix NumericSupported{..} integer dig = case numDigits of+      Unbounded  -> boundedChar integer maxValue prefix radix+      AtMost n   -> boundedChar (atMost n radix dig) maxValue prefix radix+      Exactly ns -> boundedChar (oneOfExactly ns radix dig) maxValue prefix radix++lexeme :: (forall a. Parsec a -> Parsec a) -> TextParsers t -> TextParsers t+lexeme lexe TextParsers{..} = TextParsers {+    unicode = lexe unicode,+    ascii = lexe ascii,+    latin1 = lexe latin1+  }

@@ -0,0 +1,154 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TemplateHaskell, CPP #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Use fewer imports" #-}+{-# OPTIONS_GHC -Wno-monomorphism-restriction #-}+{-|+Module      : Text.Gigaparsec.Patterns+Description : Template Haskell generators to help with patterns+License     : BSD-3-Clause+Maintainer  : Jamie Willis, Gigaparsec Maintainers+Stability   : experimental++This module is currently experimental, and may have bugs depending on the version+of Haskell, or the extensions enabled. Please report any issues to the maintainers.++@since 0.2.2.0+-}+module Text.Gigaparsec.Patterns (deriveLiftedConstructors, deriveDeferredConstructors) where++import Prelude (+    Bool(True, False), String, Int, Maybe(Just, Nothing), Eq((==), (/=)),+    fmap, map, concat, (.), traverse, sequence, foldr1, length, (-), return, (++),+    fail, ($), unwords, maybe, otherwise, id, reverse, show, flip, takeWhile, (+)+  )++import Text.Gigaparsec (Parsec, (<**>), (<*>), pure)+import Text.Gigaparsec.Position (Pos, pos)+import Control.Monad (replicateM)+import Data.List (foldl')+import Data.Maybe (isJust, isNothing)+import Language.Haskell.TH (+    Q, Exp, Name, Dec,+    Type (ForallT, AppT, ArrowT, StarT, ConT),+    Info (DataConI), TyVarBndr (KindedTV, PlainTV),+    sigD, funD, clause, varP, normalB, varE, reify, mkName, newName,+    isExtEnabled, Extension (KindSignatures),+    forallT, conE, lamE+  )+#if __GLASGOW_HASKELL__ >= 902+import Language.Haskell.TH (Type(MulArrowT))+#endif++posAp :: Bool -> Q Exp -> Q Exp+posAp True  p = [e| pos <**> $p |]+posAp False p = p++deriveLiftedConstructors :: String -> [Name] -> Q [Dec]+deriveLiftedConstructors prefix = fmap concat . traverse deriveCon+  where+    deriveCon :: Name -> Q [Dec]+    deriveCon con = do+      (con', ty, func, posFound, n) <- extractMeta True prefix (funcType . map parserOf) con+      args <- replicateM n (newName "x")+      sequence [ sigD con' ty+               , funD con' [clause (map varP args)+                   (normalB (posAp posFound (applyArgs [e|pure $func|] args))) []]+               ]++    applyArgs :: Q Exp -> [Name] -> Q Exp+    applyArgs = foldl' (\rest arg -> [e|$rest <*> $(varE arg)|])++deriveDeferredConstructors :: String -> [Name] -> Q [Dec]+deriveDeferredConstructors prefix = fmap concat . traverse deriveCon+  where+    deriveCon :: Name -> Q [Dec]+    deriveCon con = do+      (con', ty, func, posFound, _) <- extractMeta False prefix (parserOf . funcType) con+      sequence [ sigD con' ty+               , funD con' [clause [] (normalB (posAp posFound [e|pure $func|])) []]+               ]++funcType :: [Q Type] -> Q Type+funcType = foldr1 (\ty rest -> [t| $ty -> $rest |])++parserOf :: Q Type -> Q Type+parserOf ty = [t| Parsec $ty |]++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+  (forAll, tys) <- splitFun ty+  posIdx <- findPosIdx con tys+  let tys' = maybeApply deleteAt posIdx tys+  let nargs = length tys' - 1+  let con' = mkName (prefix ++ pretty con)+  let func = buildLiftedLambda posLast con nargs posIdx+  return (con', forAll (buildType (map return tys')), func, isJust posIdx, nargs)++splitFun :: Type -> Q (Q Type -> Q Type, [Type])+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)+splitFun ty                     = return (id, splitFun' ty)++splitFun' :: Type -> [Type]+splitFun' (AppT (AppT ArrowT a) b)             = a : splitFun' b -- regular function type+#if __GLASGOW_HASKELL__ >= 902+splitFun' (AppT (AppT (AppT MulArrowT _) a) b) = a : splitFun' b -- linear function type+#endif+splitFun' ty                                   = [ty]++-- When KindSignatures is off, the default (a :: *) that TH generates is broken!+#if __GLASGOW_HASKELL__ >= 902+sanitiseStarT :: TyVarBndr flag -> TyVarBndr flag+sanitiseStarT (KindedTV ty flag StarT) = PlainTV ty flag+sanitiseStarT ty = ty+#else+sanitiseStarT :: TyVarBndr -> TyVarBndr+sanitiseStarT (KindedTV ty StarT) = PlainTV ty+sanitiseStarT ty = ty+#endif++findPosIdx :: Name -> [Type] -> Q (Maybe Int)+findPosIdx con tys = case elemIndices (ConT ''Pos) tys of+     []    -> return Nothing+     [idx] -> return (Just idx)+     _     -> fail $ unwords -- more than 1 index, which is ambiguous+        ["constructor", pretty con, "has multiple occurrences of Text.Gigaparsec.Position.Pos"]++buildLiftedLambda :: Bool -> Name -> Int -> Maybe Int -> Q Exp+buildLiftedLambda posLast con nargs posIdx = do+  args <- replicateM nargs (newName "x")+  posArg <- newName "pos"+  let pargs = if | isNothing posIdx -> map varP args+                 | posLast          -> map varP args ++ [varP posArg]+                 | otherwise        -> varP posArg : map varP args+  let eargs = maybeApply (flip insertAt (varE posArg)) posIdx (map varE args)+  lamE pargs (foldl' (\acc arg -> [e|$acc $arg|]) (conE con) eargs)++insertAt :: Int -> a -> [a] -> [a]+insertAt 0 x xs = x : xs+insertAt n x (x' : xs) = x' : insertAt (n - 1) x xs+insertAt _ _ [] = []++maybeApply :: (a -> b -> b) -> Maybe a -> b -> b+maybeApply = maybe id++deleteAt :: Int -> [a] -> [a]+deleteAt 0 (_:xs)  = xs+deleteAt n (x:xs)  = x : deleteAt (n-1) xs+deleteAt _ []      = []++elemIndices :: forall a. Eq a => a -> [a] -> [Int]+elemIndices = go 0+  where go :: Int -> a -> [a] -> [Int]+        go _ _ [] = []+        go i y (x:xs)+          | x == y     = i : go (i + 1) y xs+          | otherwise  = go (i + 1) y xs++pretty :: Name -> String+pretty = reverse . takeWhile (/= '.') . reverse . show

@@ -0,0 +1,24 @@+{-# LANGUAGE Safe #-}+module Text.Gigaparsec.Position (Pos, line, col, pos, offset, withWidth) where++import Text.Gigaparsec.Internal (Parsec)+import Text.Gigaparsec.Internal qualified as Internal (Parsec(Parsec), line, col, consumed)+import Control.Applicative (liftA2, liftA3)++type Pos :: *+type Pos = (Word, Word)++line :: Parsec Word+line = Internal.Parsec $ \st good _ -> good (Internal.line st) st++col :: Parsec Word+col = Internal.Parsec $ \st good _ -> good (Internal.col st) st++offset :: Parsec Word+offset = Internal.Parsec $ \st good _ -> good (Internal.consumed st) st++pos :: Parsec Pos+pos = liftA2 (,) line col++withWidth :: Parsec a -> Parsec (a, Word)+withWidth p = liftA3 (\s x e -> (x, e-s)) offset p offset

@@ -1,17 +1,21 @@ {-# LANGUAGE Trustworthy #-} module Text.Gigaparsec.Registers (     Reg,-    make,+    make, unsafeMake,     get, gets,     put, puts,     modify,     local, localWith,+    rollback   ) where -import Text.Gigaparsec (Parsec)+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 @@ -60,5 +64,8 @@  _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,212 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE OverloadedLists #-}+{-# OPTIONS_GHC -Wno-partial-fields #-}+module Text.Gigaparsec.Token.Descriptions (module Text.Gigaparsec.Token.Descriptions) where++import Data.Char (isSpace)+import Data.Set (Set)+import Data.Map (Map)+import Data.List.NonEmpty (NonEmpty)++type LexicalDesc :: *+data LexicalDesc = LexicalDesc { nameDesc :: {-# UNPACK #-} !NameDesc+                               , symbolDesc :: {-# UNPACK #-} !SymbolDesc+                               , numericDesc :: {-# UNPACK #-} !NumericDesc+                               , textDesc :: {-# UNPACK #-} !TextDesc+                               , spaceDesc :: {-# UNPACK #-} !SpaceDesc+                               }++plain :: LexicalDesc+plain = LexicalDesc { nameDesc = plainName+                    , symbolDesc = plainSymbol+                    , numericDesc = plainNumeric+                    , textDesc = plainText+                    , spaceDesc = plainSpace+                    }++type NameDesc :: *+data NameDesc = NameDesc { identifierStart :: !CharPredicate+                         , identifierLetter :: !CharPredicate+                         , operatorStart :: !CharPredicate+                         , operatorLetter :: !CharPredicate+                         }++plainName :: NameDesc+plainName = NameDesc { identifierStart = Nothing+                     , identifierLetter = Nothing+                     , operatorStart = Nothing+                     , operatorLetter = Nothing+                     }++type SymbolDesc :: *+data SymbolDesc = SymbolDesc { hardKeywords :: !(Set String)+                             , hardOperators :: !(Set String)+                             , caseSensitive :: !Bool+                             }++plainSymbol :: SymbolDesc+plainSymbol = SymbolDesc { hardKeywords = []+                         , hardOperators = []+                         , caseSensitive = True+                         }++type NumericDesc :: *+data NumericDesc = NumericDesc { literalBreakChar :: !BreakCharDesc+                               , leadingDotAllowed :: !Bool+                               , trailingDotAllowed :: !Bool+                               , leadingZerosAllowed :: !Bool+                               , positiveSign :: !PlusSignPresence+                               -- generic number+                               , integerNumbersCanBeHexadecimal :: !Bool+                               , integerNumbersCanBeOctal :: !Bool+                               , integerNumbersCanBeBinary :: !Bool+                               , realNumbersCanBeHexadecimal :: !Bool+                               , realNumbersCanBeOctal :: !Bool+                               , realNumbersCanBeBinary :: !Bool+                               -- special literals+                               , hexadecimalLeads :: !(Set Char)+                               , octalLeads :: !(Set Char)+                               , binaryLeads :: !(Set Char)+                               -- exponents+                               , decimalExponentDesc :: !ExponentDesc+                               , hexadecimalExponentDesc :: !ExponentDesc+                               , octalExponentDesc :: !ExponentDesc+                               , binaryExponentDesc :: !ExponentDesc+                               }++plainNumeric :: NumericDesc+plainNumeric = NumericDesc { literalBreakChar = NoBreakChar+                           , leadingDotAllowed = False+                           , trailingDotAllowed = False+                           , leadingZerosAllowed = True+                           , positiveSign = PlusOptional+                           -- generic number+                           , integerNumbersCanBeHexadecimal = True+                           , integerNumbersCanBeOctal = True+                           , integerNumbersCanBeBinary = False+                           , realNumbersCanBeHexadecimal = False+                           , realNumbersCanBeOctal = False+                           , realNumbersCanBeBinary = False+                           -- special literals+                           , hexadecimalLeads = ['x', 'X']+                           , octalLeads = ['o', 'O']+                           , binaryLeads = ['b', 'B']+                           -- exponents+                           , decimalExponentDesc = ExponentsSupported { compulsory = False+                                                                      , chars = ['e', 'E']+                                                                      , base = 10+                                                                      , expSign = PlusOptional+                                                                      , expLeadingZerosAllowd = True+                                                                      }+                           , hexadecimalExponentDesc = ExponentsSupported { compulsory = True+                                                                          , chars = ['p', 'P']+                                                                          , base = 2+                                                                          , expSign = PlusOptional+                                                                          , expLeadingZerosAllowd = True+                                                                          }+                           , octalExponentDesc = ExponentsSupported { compulsory = True+                                                                    , chars = ['e', 'E', 'p', 'P']+                                                                    , base = 2+                                                                    , expSign = PlusOptional+                                                                    , expLeadingZerosAllowd = True+                                                                    }+                           , binaryExponentDesc = ExponentsSupported { compulsory = True+                                                                     , chars = ['e', 'E', 'p', 'P']+                                                                     , base = 2+                                                                     , expSign = PlusOptional+                                                                     , expLeadingZerosAllowd = True+                                                                     }+                           }++type ExponentDesc :: *+data ExponentDesc = NoExponents+                  | ExponentsSupported { compulsory :: !Bool+                                       , chars :: !(Set Char)+                                       , base :: !Int+                                       , expSign :: !PlusSignPresence+                                       , expLeadingZerosAllowd :: !Bool+                                       }++type BreakCharDesc :: *+data BreakCharDesc = NoBreakChar+                   | BreakCharSupported { breakChar :: !Char+                                        , allowedAfterNonDecimalPrefix :: !Bool+                                        }++type PlusSignPresence :: *+data PlusSignPresence = PlusRequired | PlusOptional | PlusIllegal++type TextDesc :: *+data TextDesc = TextDesc { escapeSequences :: {-# UNPACK #-} !EscapeDesc+                         , characterLiteralEnd :: !Char+                         , stringEnds :: !(Set (String, String))+                         , multiStringEnds :: !(Set (String, String))+                         , graphicCharacter :: !CharPredicate+                         }++plainText :: TextDesc+plainText = TextDesc { escapeSequences = plainEscape+                     , characterLiteralEnd = '\''+                     , stringEnds = [("\"", "\"")]+                     , multiStringEnds = []+                     , graphicCharacter = Just (>= ' ')+                     }++type EscapeDesc :: *+data EscapeDesc = EscapeDesc { escBegin :: !Char+                             , literals :: !(Set Char)+                             , mapping :: !(Map String Char)+                             , decimalEscape :: !NumericEscape+                             , hexadecimalEscape :: !NumericEscape+                             , octalEscape :: !NumericEscape+                             , binaryEscape :: !NumericEscape+                             , emptyEscape :: !(Maybe Char)+                             , gapsSupported :: !Bool+                             }++plainEscape :: EscapeDesc+plainEscape = EscapeDesc { escBegin = '\\'+                         , literals = ['\\']+                         , mapping = []+                         , decimalEscape = NumericIllegal+                         , hexadecimalEscape = NumericIllegal+                         , octalEscape = NumericIllegal+                         , binaryEscape = NumericIllegal+                         , emptyEscape = Nothing+                         , gapsSupported = False+                         }++-- TODO: haskellEscape++type NumericEscape :: *+data NumericEscape = NumericIllegal+                   | NumericSupported { prefix :: !(Maybe Char)+                                      , numDigits :: !NumberOfDigits+                                      , maxValue :: !Char+                                      }++type NumberOfDigits :: *+data NumberOfDigits = Unbounded | Exactly !(NonEmpty Word) | AtMost !Word++type SpaceDesc :: *+data SpaceDesc = SpaceDesc { lineCommentStart :: !String+                           , lineCommentAllowsEOF :: !Bool+                           , multiLineCommentStart :: !String+                           , multiLineCommentEnd :: !String+                           , multiLineNestedComments :: !Bool+                           , space :: !CharPredicate+                           , whitespaceIsContextDependent :: !Bool+                           }++plainSpace :: SpaceDesc+plainSpace = SpaceDesc { lineCommentStart = ""+                       , lineCommentAllowsEOF = True+                       , multiLineCommentStart = ""+                       , multiLineCommentEnd = ""+                       , multiLineNestedComments = False+                       , space = Just isSpace+                       , whitespaceIsContextDependent = False+                       }++type CharPredicate :: *+type CharPredicate = Maybe (Char -> Bool)

@@ -0,0 +1,59 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE ConstraintKinds, DataKinds #-}+-- Ideally, we should probably expose all the functionally via this one file+-- for ergonomics+module Text.Gigaparsec.Token.Lexer (+    Lexer, mkLexer,+    Lexeme, lexeme, nonlexeme, fully, space,+    apply, sym, symbol, names,+    -- Symbol+    Symbol, softKeyword, softOperator,+    -- Names+    Names, identifier, identifier', userDefinedOperator, userDefinedOperator',+    -- Numeric+    IntegerParsers, CanHoldSigned, CanHoldUnsigned,+    integer, natural, decimal, hexadecimal, octal, binary,+    decimal8, decimal16, decimal32, decimal64,+    hexadecimal8, hexadecimal16, hexadecimal32, hexadecimal64,+    octal8, octal16, octal32, octal64,+    binary8, binary16, binary32, binary64,+    -- Text+    TextParsers,+    stringLiteral, rawStringLiteral, multiStringLiteral, rawMultiStringLiteral,+    charLiteral,+    ascii, unicode, latin1,+    -- Space+    Space, skipComments, whiteSpace, alter, initSpace,+  ) where++import Text.Gigaparsec.Internal.Token.Lexer (+    Lexer, mkLexer,+    Lexeme (rawMultiStringLiteral), lexeme, nonlexeme, fully, space,+    apply, sym, symbol, names,+    integer, natural,+    stringLiteral, rawStringLiteral, multiStringLiteral, rawMultiStringLiteral,+    charLiteral,+    Space, skipComments, whiteSpace, alter, initSpace+  )+import Text.Gigaparsec.Internal.Token.Symbol (Symbol, softKeyword, softOperator)+import Text.Gigaparsec.Internal.Token.Names (+    Names, identifier, identifier', userDefinedOperator, userDefinedOperator'+  )+import Text.Gigaparsec.Internal.Token.Numeric (+    IntegerParsers, decimal, hexadecimal, octal, binary,+    decimal8, decimal16, decimal32, decimal64,+    hexadecimal8, hexadecimal16, hexadecimal32, hexadecimal64,+    octal8, octal16, octal32, octal64,+    binary8, binary16, binary32, binary64+  )+import Text.Gigaparsec.Internal.Token.Numeric qualified as Internal+import Text.Gigaparsec.Internal.Token.Text (+    TextParsers, ascii, unicode, latin1+  )++import Data.Kind (Constraint)++type CanHoldSigned :: Internal.Bits -> * -> Constraint+type CanHoldSigned = Internal.CanHoldSigned+type CanHoldUnsigned :: Internal.Bits -> * -> Constraint+type CanHoldUnsigned = Internal.CanHoldUnsigned

@@ -0,0 +1,36 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TemplateHaskell, TypeOperators #-}+{-|+Module      : Text.Gigaparsec.Token.Patterns+Description : Template Haskell generators to help with patterns+License     : BSD-3-Clause+Maintainer  : Jamie Willis, Gigaparsec Maintainers+Stability   : experimental++This module is currently experimental, and may have bugs depending on the version+of Haskell, or the extensions enabled. Please report any issues to the maintainers.++@since 0.2.2.0+-}+module Text.Gigaparsec.Token.Patterns (overloadedStrings) where++import Text.Gigaparsec (Parsec)+import Text.Gigaparsec.Token.Lexer (lexeme, sym)++import Data.String (IsString(fromString))+import Language.Haskell.TH.Syntax (Q, Dec, Exp)++{-|+When given a quoted reference to a 'Text.Gigaparsec.Token.Lexer', for example+@[|lexer|]@, this function will synthesise an `IsString` instance that will+allow string literals to serve as @Parsec ()@. These literals will parse symbols+in the language associated with the lexer, followed by consuming valid whitespace.++@since 0.2.2.0+-}+overloadedStrings :: Q Exp   -- ^ the quoted 'Text.Gigaparsec.Token.Lexer'+                  -> Q [Dec] -- ^ a synthesised `IsString` instance.+overloadedStrings qlexer = [d|+    instance u ~ () => IsString (Parsec u) where+      fromString = sym (lexeme $qlexer) -- TODO: one day, $qlexer.lexeme.sym+  |]

@@ -8,6 +8,7 @@ import Text.Gigaparsec.DebugTests qualified as Debug import Text.Gigaparsec.ExprTests qualified as Expr import Text.Gigaparsec.ErrorsTests qualified as Errors+import Text.Gigaparsec.TokenTests qualified as Token  main :: IO () main = defaultMain $ testGroup "gigaparsec"@@ -16,5 +17,6 @@   , Combinator.tests   , Expr.tests   , Errors.tests+  , Token.tests   , Debug.tests   ]

@@ -0,0 +1,42 @@+module Text.Gigaparsec.GigaparsecTests where++import Test.Tasty+import Test.Tasty.HUnit+--import Test.Tasty.ExpectedFailure++import Text.Gigaparsec+import Text.Gigaparsec.Char+import Text.Gigaparsec.Internal.Test++import Data.Monoid+import Data.Semigroup+import Data.Char (digitToInt)+import Data.Set (singleton, fromList)++tests :: TestTree+tests = testGroup "gigaparsec"+  [ manyMapTests+  , someMapTests+  ]++manyMapTests :: TestTree+manyMapTests = testGroup "manyMap should"+  [ testCase "should treat (: []) as an identity" do+      testParse (manyMap (: []) item) "acbdefh324" @?= Success "acbdefh324"+      testParse (manyMap (: []) item) "" @?= Success ""+  , testCase "should allow for collapsing into any monoid" do+      testParse (manyMap (Sum . digitToInt) digit) "1234" @?= Success 10+      testParse (manyMap (Product . digitToInt) digit) "1234" @?= Success 24+      testParse (manyMap singleton item) "1234aaa43" @?= Success (fromList ['1', '2', '3', '4', 'a'])+  ]++someMapTests :: TestTree+someMapTests = testGroup "someMap should"+  [ testCase "should treat (: []) as an identity" do+      testParse (someMap (: []) item) "abcdef123" @?= Success "abcdef123"+      ensureFails (someMap (: []) item) ""+  , testCase "should allow for collapsing into any semi-group" do+      testParse (someMap Max item) "adehfizs" @?= Success (Max 'z')+      testParse (someMap Min item) "adehfizs" @?= Success (Min 'a')+      testParse (someMap singleton item) "aaabbbccc" @?= Success (fromList ['a', 'b', 'c'])+  ]

@@ -0,0 +1,101 @@+{-# LANGUAGE BlockArguments, OverloadedLists #-}+module Text.Gigaparsec.Token.NamesTests where++import Test.Tasty+import Test.Tasty.HUnit++import Text.Gigaparsec+import Text.Gigaparsec.Char (spaces)+import Text.Gigaparsec.Token.Descriptions+import Text.Gigaparsec.Internal.Token.Names (mkNames, lexeme, identifier, Names)++--import Text.Gigaparsec.Internal.Require+import Text.Gigaparsec.Internal.Test+import Control.Monad (forM_)+import Data.Char (isLetter, isAlphaNum)+import Text.Gigaparsec.Internal.TestError++tests :: TestTree+tests = testGroup "Names"+  [ identifierTests+  , userDefinedOperatorTests+  ]++identifierTests :: TestTree+identifierTests = testGroup "identifier should"+  [ testCase "parse valid identifiers" do+      identCases (Just isLetter) (Just isAlphaNum) True+        [ "hello1" --> Just "hello1"+        , "7f" --> Nothing+        , "hi" --> Just "hi"+        , "x7" --> Just "x7"+        ]+      identCases (Just isLetter) Nothing True+        [ "x" --> Just "x"+        , "y" --> Just "y"+        , "hi" --> Just "h"+        , "x7" --> Just "x"+        ]+      identCases (Just (== '🙂')) (Just isAlphaNum) True+        [ "🙂ello1" --> Just "🙂ello1"+        , "df" --> Nothing+        , "🙂i" --> Just "🙂i"+        , "🙂7" --> Just "🙂7"+        , "🙂🙂" --> Just "🙂"+        ]+  , testCase "fail to parse valid keywords" do+      identCases (Just isLetter) (Just isAlphaNum) True+        [ "keyword" --> Nothing+        , "KEYWORD" --> Just "KEYWORD"+        , "keyword1" --> Just "keyword1"+        ]+  , testCase "point at the correct place for the error" do+      case testParseAll (identifier basicNames) "keyword" of+        Failure (TestError pos _) -> pos @?= (1, 1)+        _ -> assertFailure "parser must fail"+  , testCase "report the correct label" do+      case testParseAll (identifier basicNames) "HARD" of+        Failure (TestError _ (VanillaError unex exs rs width)) -> do+          width @?= 4+          unex @?= Just (Named "keyword HARD")+          exs @?= [Named "identifier"]+          rs @?= []+        _ -> assertFailure "parser must fail"+  , testCase "work in the presence of case insensitivity with respect to keywords" do+      identCases (Just isLetter) (Just isAlphaNum) False+        [ "HARD" --> Nothing+        , "hard" --> Nothing+        , "HArd" --> Nothing+        , "harD" --> Nothing+        , "keyword" --> Nothing+        , "Keyword" --> Nothing+        , "keyWORD" --> Nothing+        , "KEYword" --> Nothing+        ]+  ]++userDefinedOperatorTests :: TestTree+userDefinedOperatorTests = testGroup "user defined operator should"+  []++(-->) :: a -> b -> (a, b)+(-->) = (,)++identCases :: CharPredicate -> CharPredicate -> Bool -> [(String, Maybe String)] -> Assertion+identCases start letter sensitive ts =+  do let p = identifier (namesFor start letter sensitive)+     forM_ ts $ \(sym, res) ->+        case res of+          Nothing -> ensureFails p sym+          Just r  -> testParse p sym @?= Success r++namesFor :: CharPredicate -> CharPredicate -> Bool -> Names+namesFor start letter sensitive = lexeme (<* spaces) $+  mkNames (plainName { identifierStart = start, identifierLetter = letter })+          (plainSymbol { caseSensitive = sensitive+                       , hardKeywords = ["keyword", "HARD"]+                       , hardOperators = ["+", "<", "<="]+                       })++basicNames :: Names+basicNames = namesFor (Just isLetter) (Just isAlphaNum) True

@@ -0,0 +1,9 @@+module Text.Gigaparsec.TokenTests where++import Test.Tasty+import Text.Gigaparsec.Token.NamesTests as Names++tests :: TestTree+tests = testGroup "Token"+  [ Names.tests+  ]