{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_GHC -Wno-partial-fields #-}
{-# OPTIONS_HADDOCK hide #-}
module Text.Gigaparsec.Internal.Token.Lexer (
    Lexer, mkLexer, mkLexerWithErrorConfig,
    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.State (set, get, setDuring, rollback)
import Text.Gigaparsec.Errors.Combinator (hide)

import Text.Gigaparsec.Token.Descriptions qualified as Desc
import Text.Gigaparsec.Token.Errors (
    ErrorConfig (labelSpaceEndOfLineComment, labelSpaceEndOfMultiComment),
    defaultErrorConfig
  )
import Text.Gigaparsec.Internal.Token.Errors (annotate)
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,
  )
import Text.Gigaparsec.Internal.Token.BitBounds (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.Require (require)

import Data.List (isPrefixOf)
import Data.IORef (newIORef)
import Data.Ref (fromIORef)
import Control.Exception (Exception, throw)
import Control.Monad (join, guard)
import System.IO.Unsafe (unsafePerformIO)

{-|
A lexer describes how to transform the input string into a series of tokens.
-}
type Lexer :: *
data Lexer = Lexer { 
  -- | This contains parsers for tokens treated as "words", 
  -- such that whitespace will be consumed after each token has been parsed.
    Lexer -> Lexeme
lexeme :: !Lexeme
  -- | This contains parsers for tokens that do not give any special treatment to whitespace.
  , Lexer -> Lexeme
nonlexeme :: !Lexeme
  -- | This combinator ensures a parser fully parses all available input, and consumes whitespace at the start.
  , Lexer -> forall a. Parsec a -> Parsec a
fully :: !(forall a. Parsec a -> Parsec a)
  -- | This contains parsers that directly treat whitespace.
  , Lexer -> Space
space :: !Space
  }

{-|
Create a 'Lexer' with a given description for the lexical structure of the language.
-}
mkLexer :: Desc.LexicalDesc -- ^ The description of the lexical structure of the language.
        -> Lexer -- ^ A lexer which can convert the input stream into a series of lexemes.
mkLexer :: LexicalDesc -> Lexer
mkLexer !LexicalDesc
desc = LexicalDesc -> ErrorConfig -> Lexer
mkLexerWithErrorConfig LexicalDesc
desc ErrorConfig
defaultErrorConfig

{-|
Create a 'Lexer' with a given description for the lexical structure of the language, 
which reports errors according to the given error config.
-}
mkLexerWithErrorConfig  :: Desc.LexicalDesc -- ^ The description of the lexical structure of the language.
                        -> ErrorConfig -- ^ The description of how to process errors during lexing.
                        -> Lexer -- ^ A lexer which can convert the input stream into a series of lexemes.
mkLexerWithErrorConfig :: LexicalDesc -> ErrorConfig -> Lexer
mkLexerWithErrorConfig Desc.LexicalDesc{SpaceDesc
TextDesc
NumericDesc
SymbolDesc
NameDesc
nameDesc :: NameDesc
symbolDesc :: SymbolDesc
numericDesc :: NumericDesc
textDesc :: TextDesc
spaceDesc :: SpaceDesc
spaceDesc :: LexicalDesc -> SpaceDesc
textDesc :: LexicalDesc -> TextDesc
numericDesc :: LexicalDesc -> NumericDesc
symbolDesc :: LexicalDesc -> SymbolDesc
nameDesc :: LexicalDesc -> NameDesc
..} !ErrorConfig
errConfig = Lexer {Space
Lexeme
Parsec a -> Parsec a
forall a. Parsec a -> Parsec a
lexeme :: Lexeme
nonlexeme :: Lexeme
fully :: forall a. Parsec a -> Parsec a
space :: Space
lexeme :: Lexeme
nonlexeme :: Lexeme
fully :: forall a. Parsec a -> Parsec a
space :: Space
..}
  where apply :: Parsec a -> Parsec a
apply Parsec a
p = Parsec a
p Parsec a -> Parsec () -> Parsec a
forall a b. Parsec a -> Parsec b -> Parsec a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Space -> Parsec ()
whiteSpace Space
space
        gen :: GenericNumeric
gen = ErrorConfig -> GenericNumeric
mkGeneric ErrorConfig
errConfig
        -- DO NOT HAVE MUTUALLY RECURSIVE FIELDS
        lexeme :: Lexeme
lexeme = Lexeme { apply :: forall a. Parsec a -> Parsec a
apply = Parsec a -> Parsec a
forall a. Parsec a -> Parsec a
apply
                        , sym :: String -> Parsec ()
sym = Parsec () -> Parsec ()
forall a. Parsec a -> Parsec a
apply (Parsec () -> Parsec ())
-> (String -> Parsec ()) -> String -> Parsec ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lexeme -> String -> Parsec ()
sym Lexeme
nonlexeme
                        , symbol :: Symbol
symbol = (forall a. Parsec a -> Parsec a) -> Symbol -> Symbol
Symbol.lexeme Parsec a -> Parsec a
forall a. Parsec a -> Parsec a
apply Symbol
symbolNonLexeme
                        , names :: Names
names = (forall a. Parsec a -> Parsec a) -> Names -> Names
Names.lexeme Parsec a -> Parsec a
forall a. Parsec a -> Parsec a
apply (Lexeme -> Names
names Lexeme
nonlexeme)
                        , natural :: IntegerParsers CanHoldUnsigned
natural = (forall a. Parsec a -> Parsec a)
-> IntegerParsers CanHoldUnsigned -> IntegerParsers CanHoldUnsigned
forall (c :: Bits -> * -> Constraint).
(forall a. Parsec a -> Parsec a)
-> IntegerParsers c -> IntegerParsers c
Numeric.lexemeInteger Parsec a -> Parsec a
forall a. Parsec a -> Parsec a
apply IntegerParsers CanHoldUnsigned
naturalNonLexeme
                        , integer :: IntegerParsers CanHoldSigned
integer = (forall a. Parsec a -> Parsec a)
-> IntegerParsers CanHoldSigned -> IntegerParsers CanHoldSigned
forall (c :: Bits -> * -> Constraint).
(forall a. Parsec a -> Parsec a)
-> IntegerParsers c -> IntegerParsers c
Numeric.lexemeInteger Parsec a -> Parsec a
forall a. Parsec a -> Parsec a
apply (Lexeme -> IntegerParsers CanHoldSigned
integer Lexeme
nonlexeme)
                        {-, floating = Numeric.lexemeFloating apply (floating nonlexeme)
                        , unsignedCombined =
                            Numeric.lexemeCombined apply (unsignedCombined nonlexeme)
                        , signedCombined =
                            Numeric.lexemeCombined apply (signedCombined nonlexeme)-}
                        , stringLiteral :: TextParsers String
stringLiteral = (forall a. Parsec a -> Parsec a)
-> TextParsers String -> TextParsers String
forall t.
(forall a. Parsec a -> Parsec a) -> TextParsers t -> TextParsers t
Text.lexeme Parsec a -> Parsec a
forall a. Parsec a -> Parsec a
apply (Lexeme -> TextParsers String
stringLiteral Lexeme
nonlexeme)
                        , rawStringLiteral :: TextParsers String
rawStringLiteral = (forall a. Parsec a -> Parsec a)
-> TextParsers String -> TextParsers String
forall t.
(forall a. Parsec a -> Parsec a) -> TextParsers t -> TextParsers t
Text.lexeme Parsec a -> Parsec a
forall a. Parsec a -> Parsec a
apply (Lexeme -> TextParsers String
rawStringLiteral Lexeme
nonlexeme)
                        , multiStringLiteral :: TextParsers String
multiStringLiteral = (forall a. Parsec a -> Parsec a)
-> TextParsers String -> TextParsers String
forall t.
(forall a. Parsec a -> Parsec a) -> TextParsers t -> TextParsers t
Text.lexeme Parsec a -> Parsec a
forall a. Parsec a -> Parsec a
apply (Lexeme -> TextParsers String
multiStringLiteral Lexeme
nonlexeme)
                        , rawMultiStringLiteral :: TextParsers String
rawMultiStringLiteral = (forall a. Parsec a -> Parsec a)
-> TextParsers String -> TextParsers String
forall t.
(forall a. Parsec a -> Parsec a) -> TextParsers t -> TextParsers t
Text.lexeme Parsec a -> Parsec a
forall a. Parsec a -> Parsec a
apply (Lexeme -> TextParsers String
rawMultiStringLiteral Lexeme
nonlexeme)
                        , charLiteral :: TextParsers Char
charLiteral = (forall a. Parsec a -> Parsec a)
-> TextParsers Char -> TextParsers Char
forall t.
(forall a. Parsec a -> Parsec a) -> TextParsers t -> TextParsers t
Text.lexeme Parsec a -> Parsec a
forall a. Parsec a -> Parsec a
apply (Lexeme -> TextParsers Char
charLiteral Lexeme
nonlexeme)
                        }
        nonlexeme :: Lexeme
nonlexeme = NonLexeme { sym :: String -> Parsec ()
sym = SymbolDesc -> Symbol -> ErrorConfig -> String -> Parsec ()
mkSym SymbolDesc
symbolDesc Symbol
symbolNonLexeme ErrorConfig
errConfig
                              , symbol :: Symbol
symbol = Symbol
symbolNonLexeme
                              , names :: Names
names = NameDesc -> SymbolDesc -> ErrorConfig -> Names
mkNames NameDesc
nameDesc SymbolDesc
symbolDesc ErrorConfig
errConfig
                              , natural :: IntegerParsers CanHoldUnsigned
natural = IntegerParsers CanHoldUnsigned
naturalNonLexeme
                              , integer :: IntegerParsers CanHoldSigned
integer = NumericDesc
-> IntegerParsers CanHoldUnsigned
-> ErrorConfig
-> IntegerParsers CanHoldSigned
forall (c :: Bits -> * -> Constraint).
NumericDesc
-> IntegerParsers c -> ErrorConfig -> IntegerParsers CanHoldSigned
mkSigned NumericDesc
numericDesc IntegerParsers CanHoldUnsigned
naturalNonLexeme ErrorConfig
errConfig
                              {-, floating = mkSignedFloating numericDesc positiveFloating
                              , unsignedCombined = mkUnsignedCombined numericDesc naturalNonLexeme positiveFloating
                              , signedCombined = mkSignedCombined numericDesc (unsignedCombined nonlexeme)-}
                              , stringLiteral :: TextParsers String
stringLiteral = Set (String, String)
-> StringChar
-> CharPredicate
-> Bool
-> ErrorConfig
-> TextParsers String
mkStringParsers Set (String, String)
stringEnds StringChar
escapeChar CharPredicate
graphicCharacter Bool
False ErrorConfig
errConfig
                              , rawStringLiteral :: TextParsers String
rawStringLiteral = Set (String, String)
-> StringChar
-> CharPredicate
-> Bool
-> ErrorConfig
-> TextParsers String
mkStringParsers Set (String, String)
stringEnds StringChar
rawChar CharPredicate
graphicCharacter Bool
False ErrorConfig
errConfig
                              , multiStringLiteral :: TextParsers String
multiStringLiteral = Set (String, String)
-> StringChar
-> CharPredicate
-> Bool
-> ErrorConfig
-> TextParsers String
mkStringParsers Set (String, String)
multiStringEnds StringChar
escapeChar CharPredicate
graphicCharacter Bool
True ErrorConfig
errConfig
                              , rawMultiStringLiteral :: TextParsers String
rawMultiStringLiteral = Set (String, String)
-> StringChar
-> CharPredicate
-> Bool
-> ErrorConfig
-> TextParsers String
mkStringParsers Set (String, String)
multiStringEnds StringChar
rawChar CharPredicate
graphicCharacter Bool
True ErrorConfig
errConfig
                              , charLiteral :: TextParsers Char
charLiteral = TextDesc -> Escape -> ErrorConfig -> TextParsers Char
mkCharacterParsers TextDesc
textDesc Escape
escape ErrorConfig
errConfig
                              }
        !symbolNonLexeme :: Symbol
symbolNonLexeme = SymbolDesc -> NameDesc -> ErrorConfig -> Symbol
mkSymbol SymbolDesc
symbolDesc NameDesc
nameDesc ErrorConfig
errConfig
        !naturalNonLexeme :: IntegerParsers CanHoldUnsigned
naturalNonLexeme = NumericDesc
-> GenericNumeric -> ErrorConfig -> IntegerParsers CanHoldUnsigned
mkUnsigned NumericDesc
numericDesc GenericNumeric
gen ErrorConfig
errConfig
        --positiveFloating = mkUnsignedFloating numericDesc naturalNonLexeme gen
        !escape :: Escape
escape = EscapeDesc -> GenericNumeric -> ErrorConfig -> Escape
mkEscape (TextDesc -> EscapeDesc
Desc.escapeSequences TextDesc
textDesc) GenericNumeric
gen ErrorConfig
errConfig
        graphicCharacter :: CharPredicate
graphicCharacter = TextDesc -> CharPredicate
Desc.graphicCharacter TextDesc
textDesc
        stringEnds :: Set (String, String)
stringEnds = TextDesc -> Set (String, String)
Desc.stringEnds TextDesc
textDesc
        multiStringEnds :: Set (String, String)
multiStringEnds = TextDesc -> Set (String, String)
Desc.multiStringEnds TextDesc
textDesc
        rawChar :: StringChar
rawChar = StringChar
RawChar
        escapeChar :: StringChar
escapeChar = EscapeDesc -> Escape -> Parsec () -> ErrorConfig -> StringChar
mkEscapeChar (TextDesc -> EscapeDesc
Desc.escapeSequences TextDesc
textDesc) Escape
escape (Space -> Parsec ()
whiteSpace Space
space) ErrorConfig
errConfig
        fully' :: Parsec a -> Parsec a
fully' Parsec a
p = Space -> Parsec ()
whiteSpace Space
space Parsec () -> Parsec a -> Parsec a
forall a b. Parsec a -> Parsec b -> Parsec b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec a
p Parsec a -> Parsec () -> Parsec a
forall a b. Parsec a -> Parsec b -> Parsec a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parsec ()
eof
        fully :: Parsec b -> Parsec b
fully Parsec b
p
          | SpaceDesc -> Bool
Desc.whitespaceIsContextDependent SpaceDesc
spaceDesc = Space -> Parsec ()
initSpace Space
space Parsec () -> Parsec b -> Parsec b
forall a b. Parsec a -> Parsec b -> Parsec b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec b -> Parsec b
forall a. Parsec a -> Parsec a
fully' Parsec b
p
          | Bool
otherwise                                   = Parsec b -> Parsec b
forall a. Parsec a -> Parsec a
fully' Parsec b
p
        space :: Space
space = SpaceDesc -> ErrorConfig -> Space
mkSpace SpaceDesc
spaceDesc ErrorConfig
errConfig

--TODO: better name for this, I guess?
{-|
A 'Lexeme' is a collection of parsers for handling various tokens (such as symbols and names), where either all or none of the parsers consume whitespace.
-}
type Lexeme :: *
data Lexeme = 
  -- | The parsers do consume whitespace
  Lexeme {
      -- | This turns a non-lexeme parser into a lexeme one by ensuring whitespace is consumed after the parser.
        Lexeme -> forall a. Parsec a -> Parsec a
apply :: !(forall a. Parsec a -> Parsec a) -- this is tricky...
      -- | Parse the given string.
      , Lexeme -> String -> Parsec ()
sym :: !(String -> Parsec ())
      -- | This contains lexing functionality relevant to the parsing of atomic symbols.
      , Lexeme -> Symbol
symbol :: !Symbol
      -- | This contains lexing functionality relevant to the parsing of names, which include operators or identifiers.
      -- The parsing of names is mostly concerned with finding the longest valid name that is not a reserved name, 
      -- such as a hard keyword or a special operator.
      , Lexeme -> Names
names :: !Names
      -- | A collection of parsers concerned with handling unsigned (positive) integer literals.
      , Lexeme -> IntegerParsers CanHoldUnsigned
natural :: !(IntegerParsers CanHoldUnsigned)
      {-|
      This is a collection of parsers concerned with handling signed integer literals.

      Signed integer literals are an extension of unsigned integer literals which may be prefixed by a sign.
      -}
      , Lexeme -> IntegerParsers CanHoldSigned
integer :: !(IntegerParsers CanHoldSigned)
      -- desperate times, desperate measures
      --, floating :: !FloatingParsers
      --, unsignedCombined :: !CombinedParsers
      --, signedCombined :: !CombinedParsers
      {-|
      A collection of parsers concerned with handling single-line string literals.

      String literals are generally described by the 'Text.Gigaparsec.Token.Descriptions.TextDesc' fields:

      * 'Text.Gigaparsec.Token.Descriptions.stringEnds'
      * 'Text.Gigaparsec.Token.Descriptions.graphicCharacter'
      * 'Text.Gigaparsec.Token.Descriptions.escapeSequences'

      -}
      , Lexeme -> TextParsers String
stringLiteral :: !(TextParsers String)
      {-|
      A collection of parsers concerned with handling single-line string literals, /without/ handling any escape sequences:
      this includes literal-end characters and the escape prefix (often @"@ and @\\@ respectively).

      String literals are generally described by the 'Text.Gigaparsec.Token.Descriptions.TextDesc' fields:

      * 'Text.Gigaparsec.Token.Descriptions.stringEnds'
      * 'Text.Gigaparsec.Token.Descriptions.graphicCharacter'
      * 'Text.Gigaparsec.Token.Descriptions.escapeSequences'

      -}
      , Lexeme -> TextParsers String
rawStringLiteral :: !(TextParsers String)
      {-|
      A collection of parsers concerned with handling multi-line string literals.

      Multi-string literals are generally described by the 'Text.Gigaparsec.Token.Descriptions.TextDesc' fields:

      * 'Text.Gigaparsec.Token.Descriptions.multiStringEnds'
      * 'Text.Gigaparsec.Token.Descriptions.graphicCharacter'
      * 'Text.Gigaparsec.Token.Descriptions.escapeSequences'

      -}
      , Lexeme -> TextParsers String
multiStringLiteral :: !(TextParsers String)
      {-|
      A collection of parsers concerned with handling multi-line string literals, /without/ handling any escape sequences:
      this includes literal-end characters and the escape prefix (often @"@ and @\\@ respectively).

      Multi-string literals are generally described by the 'Text.Gigaparsec.Token.Descriptions.TextDesc' fields:

      * 'Text.Gigaparsec.Token.Descriptions.multiStringEnds'
      * 'Text.Gigaparsec.Token.Descriptions.graphicCharacter'
      * 'Text.Gigaparsec.Token.Descriptions.escapeSequences'
  
      -}
      , Lexeme -> TextParsers String
rawMultiStringLiteral :: !(TextParsers String)
      {-|
      A collection of parsers concerned with handling character literals.

      Charcter literals are generally described by the 'Text.Gigaparsec.Token.Descriptions.TextDesc' fields:

      * 'Text.Gigaparsec.Token.Descriptions.characterLiteralEnd'
      * 'Text.Gigaparsec.Token.Descriptions.graphicCharacter'
      * 'Text.Gigaparsec.Token.Descriptions.escapeSequences'

      -}
      , Lexeme -> TextParsers Char
charLiteral :: !(TextParsers Char)
      }
  -- | The parsers do not consume whitespace
  | 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)
      }

{-|
This type is concerned with special treatment of whitespace.

For the vast majority of cases, the functionality within this object shouldn't be needed, 
as whitespace is consistently handled by lexeme and fully. 
However, for grammars where whitespace is significant (like indentation-sensitive languages), 
this object provides some more fine-grained control over how whitespace is consumed by the parsers within lexeme.
-}
type Space :: *
data Space = Space { 
  {-|
  Skips zero or more (insignificant) whitespace characters as well as comments.

  The implementation of this parser depends on whether 'Text.Gigaparsec.Token.Descriptions.whiteSpaceIsContextDependent' is true: 
  when it is, this parser may change based on the use of the alter combinator. 

  This parser will always use the hide combinator as to not appear as a valid alternative in an error message: 
  it's likely always the case whitespace can be added at any given time, but that doesn't make it a useful suggestion unless it is significant.
  -}
    Space -> Parsec ()
whiteSpace :: !(Parsec ())
  {-|
  Skips zero or more comments.

  The implementation of this combinator does not vary with 'Text.Gigaparsec.Token.Descriptions.whiteSpaceIsContextDependent'. 
  It will use the hide combinator as to not appear as a valid alternative in an error message: 
  adding a comment is often legal, 
  but not a useful solution for how to make the input syntactically valid.
  -}
  , Space -> Parsec ()
skipComments :: !(Parsec ())
  {-|
  This combinator changes how lexemes parse whitespace for the duration of a given parser.

  So long as 'Text.Gigaparsec.Token.Descriptions.whiteSpaceIsContextDependent' is true, 
  this combinator will be able to locally change the definition of whitespace during the given parser.

  === __Examples__
  * In indentation sensitive languages, the indentation sensitivity is often ignored within parentheses or braces. 
  In these cases, 
  @parens (alter withNewLine p)@ 
  would allow unrestricted newlines within parentheses.
  -}
  , Space -> forall a. CharPredicate -> Parsec a -> Parsec a
alter :: forall a. Desc.CharPredicate -> Parsec a -> Parsec a
  {-|
  This parser initialises the whitespace used by the lexer when 'Text.Gigaparsec.Token.Descriptions.whiteSpaceIsContextDependent' is true.

  The whitespace is set to the implementation given by the lexical description.
  This parser must be used, by fully or otherwise, 
  as the first thing the global parser does or an UnfilledRegisterException will occur.

  See 'alter' for how to change whitespace during a parse.
  -}
  , Space -> Parsec ()
initSpace :: Parsec ()
  }

mkSpace :: Desc.SpaceDesc -> ErrorConfig -> Space
mkSpace :: SpaceDesc -> ErrorConfig -> Space
mkSpace desc :: SpaceDesc
desc@Desc.SpaceDesc{Bool
String
CharPredicate
whitespaceIsContextDependent :: SpaceDesc -> Bool
lineCommentStart :: String
lineCommentAllowsEOF :: Bool
multiLineCommentStart :: String
multiLineCommentEnd :: String
multiLineNestedComments :: Bool
space :: CharPredicate
whitespaceIsContextDependent :: Bool
space :: SpaceDesc -> CharPredicate
multiLineNestedComments :: SpaceDesc -> Bool
multiLineCommentEnd :: SpaceDesc -> String
multiLineCommentStart :: SpaceDesc -> String
lineCommentAllowsEOF :: SpaceDesc -> Bool
lineCommentStart :: SpaceDesc -> String
..} !ErrorConfig
errConfig = Space {Parsec ()
CharPredicate -> Parsec a -> Parsec a
forall a. CharPredicate -> Parsec a -> Parsec a
skipComments :: Parsec ()
whiteSpace :: Parsec ()
alter :: forall a. CharPredicate -> Parsec a -> Parsec a
initSpace :: Parsec ()
whiteSpace :: Parsec ()
skipComments :: Parsec ()
alter :: forall a. CharPredicate -> Parsec a -> Parsec a
initSpace :: Parsec ()
..}
  where -- don't think we can trust doing initialisation here, it'll happen in some random order
        {-# NOINLINE wsImpl #-}
        !wsImpl :: Ref r a
wsImpl = IORef a -> Ref r a
forall a r. IORef a -> Ref r a
fromIORef (IO (IORef a) -> IORef a
forall a. IO a -> a
unsafePerformIO (a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef (String -> a
forall a. HasCallStack => String -> a
error String
"uninitialised space")))
        comment :: ErrorConfig -> Parsec ()
comment = SpaceDesc -> ErrorConfig -> Parsec ()
commentParser SpaceDesc
desc -- do not make this strict
        implOf :: CharPredicate -> Parsec ()
implOf
          | SpaceDesc -> Bool
supportsComments SpaceDesc
desc = Parsec () -> Parsec ()
forall a. Parsec a -> Parsec a
hide (Parsec () -> Parsec ())
-> (CharPredicate -> Parsec ()) -> CharPredicate -> Parsec ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec ()
-> ((Char -> Bool) -> Parsec ()) -> CharPredicate -> Parsec ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Parsec ()
skipComments (Parsec () -> Parsec ()
forall a. Parsec a -> Parsec ()
skipMany (Parsec () -> Parsec ())
-> ((Char -> Bool) -> Parsec ()) -> (Char -> Bool) -> Parsec ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Parsec () -> Parsec () -> Parsec ()
forall a. Parsec a -> Parsec a -> Parsec a
<|> ErrorConfig -> Parsec ()
comment ErrorConfig
errConfig) (Parsec () -> Parsec ())
-> ((Char -> Bool) -> Parsec ()) -> (Char -> Bool) -> Parsec ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Char -> Parsec ()
forall a. Parsec a -> Parsec ()
void (Parsec Char -> Parsec ())
-> ((Char -> Bool) -> Parsec Char) -> (Char -> Bool) -> Parsec ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Parsec Char
satisfy)
          | Bool
otherwise             = Parsec () -> Parsec ()
forall a. Parsec a -> Parsec a
hide (Parsec () -> Parsec ())
-> (CharPredicate -> Parsec ()) -> CharPredicate -> Parsec ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec ()
-> ((Char -> Bool) -> Parsec ()) -> CharPredicate -> Parsec ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Parsec ()
forall a. Parsec a
empty (Parsec Char -> Parsec ()
forall a. Parsec a -> Parsec ()
skipMany (Parsec Char -> Parsec ())
-> ((Char -> Bool) -> Parsec Char) -> (Char -> Bool) -> Parsec ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Parsec Char
satisfy)
        !configuredWhitespace :: Parsec ()
configuredWhitespace = CharPredicate -> Parsec ()
implOf CharPredicate
space
        !whiteSpace :: Parsec ()
whiteSpace
          | Bool
whitespaceIsContextDependent = Parsec (Parsec ()) -> Parsec ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Ref Any (Parsec ()) -> Parsec (Parsec ())
forall r a. Ref r a -> Parsec a
get Ref Any (Parsec ())
forall {r} {a}. Ref r a
wsImpl)
          | Bool
otherwise                    = Parsec ()
configuredWhitespace
        !skipComments :: Parsec ()
skipComments = Parsec () -> Parsec ()
forall a. Parsec a -> Parsec ()
skipMany (ErrorConfig -> Parsec ()
comment ErrorConfig
errConfig)
        alter :: CharPredicate -> Parsec b -> Parsec b
alter CharPredicate
p
          | Bool
whitespaceIsContextDependent = Ref Any Any -> Parsec b -> Parsec b
forall r a b. Ref r a -> Parsec b -> Parsec b
rollback Ref Any Any
forall {r} {a}. Ref r a
wsImpl (Parsec b -> Parsec b)
-> (Parsec b -> Parsec b) -> Parsec b -> Parsec b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ref Any (Parsec ()) -> Parsec () -> Parsec b -> Parsec b
forall r a b. Ref r a -> a -> Parsec b -> Parsec b
setDuring Ref Any (Parsec ())
forall {r} {a}. Ref r a
wsImpl (CharPredicate -> Parsec ()
implOf CharPredicate
p)
          | Bool
otherwise                    = UnsupportedOperation -> Parsec b -> Parsec b
forall a e. (HasCallStack, Exception e) => e -> a
throw (String -> UnsupportedOperation
UnsupportedOperation String
badAlter)
        initSpace :: Parsec ()
initSpace
          | Bool
whitespaceIsContextDependent = Ref Any (Parsec ()) -> Parsec () -> Parsec ()
forall r a. Ref r a -> a -> Parsec ()
set Ref Any (Parsec ())
forall {r} {a}. Ref r a
wsImpl Parsec ()
configuredWhitespace
          | Bool
otherwise                    = UnsupportedOperation -> Parsec ()
forall a e. (HasCallStack, Exception e) => e -> a
throw (String -> UnsupportedOperation
UnsupportedOperation String
badInit)
        badInit :: String
badInit = String
"whitespace cannot be initialised unless `spaceDesc.whitespaceIsContextDependent` is True"
        badAlter :: String
badAlter = String
"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 -> ErrorConfig -> Parsec ()
commentParser :: SpaceDesc -> ErrorConfig -> Parsec ()
commentParser Desc.SpaceDesc{Bool
String
CharPredicate
whitespaceIsContextDependent :: SpaceDesc -> Bool
space :: SpaceDesc -> CharPredicate
multiLineNestedComments :: SpaceDesc -> Bool
multiLineCommentEnd :: SpaceDesc -> String
multiLineCommentStart :: SpaceDesc -> String
lineCommentAllowsEOF :: SpaceDesc -> Bool
lineCommentStart :: SpaceDesc -> String
lineCommentStart :: String
lineCommentAllowsEOF :: Bool
multiLineCommentStart :: String
multiLineCommentEnd :: String
multiLineNestedComments :: Bool
space :: CharPredicate
whitespaceIsContextDependent :: Bool
..} !ErrorConfig
errConfig =
  Bool -> String -> String -> Parsec () -> Parsec ()
forall a. Bool -> String -> String -> a -> a
require (Bool
multiEnabled Bool -> Bool -> Bool
|| Bool
singleEnabled) String
"skipComments" String
noComments (Parsec () -> Parsec ()) -> Parsec () -> Parsec ()
forall a b. (a -> b) -> a -> b
$
    Bool -> String -> String -> Parsec () -> Parsec ()
forall a. Bool -> String -> String -> a -> a
require (Bool -> Bool
not (Bool
multiEnabled Bool -> Bool -> Bool
&& String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
multiLineCommentStart String
lineCommentStart)) String
"skipComments" String
noOverlap (Parsec () -> Parsec ()) -> Parsec () -> Parsec ()
forall a b. (a -> b) -> a -> b
$
      Parsec () -> Parsec ()
forall a. Parsec a -> Parsec a
hide (Parsec ()
multiLine Parsec () -> Parsec () -> Parsec ()
forall a. Parsec a -> Parsec a -> Parsec a
<|> Parsec ()
singleLine)
  where
    -- can't make these strict until guard is gone
    openComment :: Parsec String
openComment = Parsec String -> Parsec String
forall a. Parsec a -> Parsec a
atomic (String -> Parsec String
string String
multiLineCommentStart)
    closeComment :: Parsec String
closeComment = LabelWithExplainConfig -> Parsec String -> Parsec String
forall config a. Annotate config => config -> Parsec a -> Parsec a
forall a. LabelWithExplainConfig -> Parsec a -> Parsec a
annotate (ErrorConfig -> LabelWithExplainConfig
labelSpaceEndOfMultiComment ErrorConfig
errConfig) (Parsec String -> Parsec String
forall a. Parsec a -> Parsec a
atomic (String -> Parsec String
string String
multiLineCommentEnd))
    multiLine :: Parsec ()
multiLine = Bool -> Parsec ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
multiEnabled Parsec () -> Parsec String -> Parsec String
forall a b. Parsec a -> Parsec b -> Parsec b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec String
openComment Parsec String -> Parsec () -> Parsec ()
forall a b. Parsec a -> Parsec b -> Parsec b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parsec ()
wellNested Int
1
    wellNested :: Int -> Parsec ()
    wellNested :: Int -> Parsec ()
wellNested Int
0 = Parsec ()
unit
    wellNested Int
n = Parsec String
closeComment Parsec String -> Parsec () -> Parsec ()
forall a b. Parsec a -> Parsec b -> Parsec b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parsec ()
wellNested (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
               Parsec () -> Parsec () -> Parsec ()
forall a. Parsec a -> Parsec a -> Parsec a
<|> Bool -> Parsec ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
multiLineNestedComments Parsec () -> Parsec String -> Parsec String
forall a b. Parsec a -> Parsec b -> Parsec b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec String
openComment Parsec String -> Parsec () -> Parsec ()
forall a b. Parsec a -> Parsec b -> Parsec b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parsec ()
wellNested (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
               Parsec () -> Parsec () -> Parsec ()
forall a. Parsec a -> Parsec a -> Parsec a
<|> Parsec Char
item Parsec Char -> Parsec () -> Parsec ()
forall a b. Parsec a -> Parsec b -> Parsec b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parsec ()
wellNested Int
n
    singleLine :: Parsec ()
singleLine = Bool -> Parsec ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
singleEnabled
              Parsec () -> Parsec String -> Parsec String
forall a b. Parsec a -> Parsec b -> Parsec b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec String -> Parsec String
forall a. Parsec a -> Parsec a
atomic (String -> Parsec String
string String
lineCommentStart)
              Parsec String -> Parsec () -> Parsec ()
forall a b. Parsec a -> Parsec b -> Parsec b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Char -> Parsec () -> Parsec ()
forall a end. Parsec a -> Parsec end -> Parsec ()
skipManyTill Parsec Char
item (LabelWithExplainConfig -> Parsec () -> Parsec ()
forall config a. Annotate config => config -> Parsec a -> Parsec a
forall a. LabelWithExplainConfig -> Parsec a -> Parsec a
annotate (ErrorConfig -> LabelWithExplainConfig
labelSpaceEndOfLineComment ErrorConfig
errConfig) Parsec ()
endOfLineComment)

    endOfLineComment :: Parsec ()
endOfLineComment
      | Bool
lineCommentAllowsEOF = Parsec Char -> Parsec ()
forall a. Parsec a -> Parsec ()
void Parsec Char
endOfLine Parsec () -> Parsec () -> Parsec ()
forall a. Parsec a -> Parsec a -> Parsec a
<|> Parsec ()
eof
      | Bool
otherwise            = Parsec Char -> Parsec ()
forall a. Parsec a -> Parsec ()
void Parsec Char
endOfLine

    multiEnabled :: Bool
multiEnabled = Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
multiLineCommentStart Bool -> Bool -> Bool
|| String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
multiLineCommentEnd)
    singleEnabled :: Bool
singleEnabled = Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
lineCommentStart)
    noComments :: String
noComments = String
"one of single- or multi-line comments must be enabled"
    noOverlap :: String
noOverlap = String
"single-line comments must not overlap with multi-line comments"

supportsComments :: Desc.SpaceDesc -> Bool
supportsComments :: SpaceDesc -> Bool
supportsComments Desc.SpaceDesc{Bool
String
CharPredicate
whitespaceIsContextDependent :: SpaceDesc -> Bool
space :: SpaceDesc -> CharPredicate
multiLineNestedComments :: SpaceDesc -> Bool
multiLineCommentEnd :: SpaceDesc -> String
multiLineCommentStart :: SpaceDesc -> String
lineCommentAllowsEOF :: SpaceDesc -> Bool
lineCommentStart :: SpaceDesc -> String
lineCommentStart :: String
lineCommentAllowsEOF :: Bool
multiLineCommentStart :: String
multiLineCommentEnd :: String
multiLineNestedComments :: Bool
space :: CharPredicate
whitespaceIsContextDependent :: Bool
..} = Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
lineCommentStart Bool -> Bool -> Bool
&& String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
multiLineCommentStart)

type UnsupportedOperation :: *
newtype UnsupportedOperation = UnsupportedOperation String deriving stock UnsupportedOperation -> UnsupportedOperation -> Bool
(UnsupportedOperation -> UnsupportedOperation -> Bool)
-> (UnsupportedOperation -> UnsupportedOperation -> Bool)
-> Eq UnsupportedOperation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnsupportedOperation -> UnsupportedOperation -> Bool
== :: UnsupportedOperation -> UnsupportedOperation -> Bool
$c/= :: UnsupportedOperation -> UnsupportedOperation -> Bool
/= :: UnsupportedOperation -> UnsupportedOperation -> Bool
Eq
instance Show UnsupportedOperation where
  show :: UnsupportedOperation -> String
show (UnsupportedOperation String
msg) = String
"unsupported operation: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg
instance Exception UnsupportedOperation