{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo       #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | Common functions for parsers of UPLC, PLC, and PIR.
module PlutusCore.Parser.ParserCommon where

import Control.Monad (when)
import Control.Monad.Except (MonadError)
import Control.Monad.Reader (ReaderT, ask, local, runReaderT)
import Control.Monad.State (StateT, evalStateT)
import Data.Map qualified as M
import Data.Text (Text)
import Text.Megaparsec hiding (ParseError, State, parse, some)
import Text.Megaparsec.Char (char, space1)
import Text.Megaparsec.Char.Lexer qualified as Lex hiding (hexadecimal)

import Control.Monad.State.Class (MonadState, get, put)
import PlutusCore.Annotation
import PlutusCore.Core.Type
import PlutusCore.Error
import PlutusCore.Name.Unique (Name (..), Unique (..), isIdentifierChar, isIdentifierStartingChar,
                               isQuotedIdentifierChar)
import PlutusCore.Quote

{- Note [Whitespace invariant]
Every top-level 'Parser' must consume all whitespace after the thing that it parses, hence make
sure to enclose every 'Parser' that doesn't consume trailing whitespce (e.g. 'takeWhileP',
'manyTill', 'Lex.decimal' etc) in a call to 'lexeme'.
-}

newtype ParserState = ParserState {ParserState -> Map Text Unique
identifiers :: M.Map Text Unique}
  deriving stock (Int -> ParserState -> ShowS
[ParserState] -> ShowS
ParserState -> String
(Int -> ParserState -> ShowS)
-> (ParserState -> String)
-> ([ParserState] -> ShowS)
-> Show ParserState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParserState -> ShowS
showsPrec :: Int -> ParserState -> ShowS
$cshow :: ParserState -> String
show :: ParserState -> String
$cshowList :: [ParserState] -> ShowS
showList :: [ParserState] -> ShowS
Show)

type Parser =
  ParsecT ParserError Text (StateT ParserState (ReaderT (Maybe Version) Quote))

instance (Stream s, MonadQuote m) => MonadQuote (ParsecT e s m)

initial :: ParserState
initial :: ParserState
initial = Map Text Unique -> ParserState
ParserState Map Text Unique
forall k a. Map k a
M.empty

-- | Get the version of the program being parsed, if we know it.
getVersion :: Parser (Maybe Version)
getVersion :: Parser (Maybe Version)
getVersion = Parser (Maybe Version)
forall r (m :: * -> *). MonadReader r m => m r
ask

-- | Set the version of the program being parsed.
withVersion :: Version -> Parser a -> Parser a
withVersion :: forall a. Version -> Parser a -> Parser a
withVersion Version
v = (Maybe Version -> Maybe Version)
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
forall a.
(Maybe Version -> Maybe Version)
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Maybe Version -> Maybe Version -> Maybe Version
forall a b. a -> b -> a
const (Maybe Version -> Maybe Version -> Maybe Version)
-> Maybe Version -> Maybe Version -> Maybe Version
forall a b. (a -> b) -> a -> b
$ Version -> Maybe Version
forall a. a -> Maybe a
Just Version
v)

{- | Run an action conditionally based on a predicate on the version.
If we don't know the version then the predicate is assumed to be
false, i.e. we act if we _know_ the predicate is satisfied.
-}
whenVersion :: (Version -> Bool) -> Parser () -> Parser ()
whenVersion :: (Version -> Bool) -> Parser () -> Parser ()
whenVersion Version -> Bool
p Parser ()
act = do
  Maybe Version
mv <- Parser (Maybe Version)
getVersion
  case Maybe Version
mv of
    Maybe Version
Nothing -> () -> Parser ()
forall a.
a
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just Version
v  -> Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version -> Bool
p Version
v) Parser ()
act

parse
  :: (AsParserErrorBundle e, MonadError e m, MonadQuote m)
  => Parser a
  -> String
  -> Text
  -> m a
parse :: forall e (m :: * -> *) a.
(AsParserErrorBundle e, MonadError e m, MonadQuote m) =>
Parser a -> String -> Text -> m a
parse Parser a
p String
file Text
str = do
  let res :: Quote (Either ParserErrorBundle a)
res = (Either (ParseErrorBundle Text ParserError) a
 -> Either ParserErrorBundle a)
-> Quote (Either (ParseErrorBundle Text ParserError) a)
-> Quote (Either ParserErrorBundle a)
forall a b. (a -> b) -> Quote a -> Quote b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either (ParseErrorBundle Text ParserError) a
-> Either ParserErrorBundle a
forall a.
Either (ParseErrorBundle Text ParserError) a
-> Either ParserErrorBundle a
toErrorB (ReaderT
  (Maybe Version)
  Quote
  (Either (ParseErrorBundle Text ParserError) a)
-> Maybe Version
-> Quote (Either (ParseErrorBundle Text ParserError) a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (StateT
  ParserState
  (ReaderT (Maybe Version) Quote)
  (Either (ParseErrorBundle Text ParserError) a)
-> ParserState
-> ReaderT
     (Maybe Version)
     Quote
     (Either (ParseErrorBundle Text ParserError) a)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Parser a
-> String
-> Text
-> StateT
     ParserState
     (ReaderT (Maybe Version) Quote)
     (Either (ParseErrorBundle Text ParserError) a)
forall (m :: * -> *) e s a.
Monad m =>
ParsecT e s m a
-> String -> s -> m (Either (ParseErrorBundle s e) a)
runParserT Parser a
p String
file Text
str) ParserState
initial) Maybe Version
forall a. Maybe a
Nothing)
  AReview e ParserErrorBundle -> Either ParserErrorBundle a -> m a
forall e (m :: * -> *) t a.
MonadError e m =>
AReview e t -> Either t a -> m a
throwingEither AReview e ParserErrorBundle
forall r. AsParserErrorBundle r => Prism' r ParserErrorBundle
Prism' e ParserErrorBundle
_ParserErrorBundle (Either ParserErrorBundle a -> m a)
-> m (Either ParserErrorBundle a) -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Quote (Either ParserErrorBundle a)
-> m (Either ParserErrorBundle a)
forall a. Quote a -> m a
forall (m :: * -> *) a. MonadQuote m => Quote a -> m a
liftQuote Quote (Either ParserErrorBundle a)
res

toErrorB :: Either (ParseErrorBundle Text ParserError) a -> Either ParserErrorBundle a
toErrorB :: forall a.
Either (ParseErrorBundle Text ParserError) a
-> Either ParserErrorBundle a
toErrorB (Left ParseErrorBundle Text ParserError
err) = ParserErrorBundle -> Either ParserErrorBundle a
forall a b. a -> Either a b
Left (ParserErrorBundle -> Either ParserErrorBundle a)
-> ParserErrorBundle -> Either ParserErrorBundle a
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text ParserError -> ParserErrorBundle
ParseErrorB ParseErrorBundle Text ParserError
err
toErrorB (Right a
a)  = a -> Either ParserErrorBundle a
forall a b. b -> Either a b
Right a
a

-- | Generic parser function in which the file path is just "test".
parseGen :: (AsParserErrorBundle e, MonadError e m, MonadQuote m) => Parser a -> Text -> m a
parseGen :: forall e (m :: * -> *) a.
(AsParserErrorBundle e, MonadError e m, MonadQuote m) =>
Parser a -> Text -> m a
parseGen Parser a
stuff = Parser a -> String -> Text -> m a
forall e (m :: * -> *) a.
(AsParserErrorBundle e, MonadError e m, MonadQuote m) =>
Parser a -> String -> Text -> m a
parse Parser a
stuff String
"test"

-- | Space consumer.
whitespace :: Parser ()
whitespace :: Parser ()
whitespace = Parser () -> Parser () -> Parser () -> Parser ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
Lex.space Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1 (Tokens Text -> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
Lex.skipLineComment Tokens Text
"--") (Tokens Text -> Tokens Text -> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> Tokens s -> m ()
Lex.skipBlockCommentNested Tokens Text
"{-" Tokens Text
"-}")

leadingWhitespace :: Parser a -> Parser a
leadingWhitespace :: forall a. Parser a -> Parser a
leadingWhitespace = (Parser ()
whitespace Parser ()
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
forall a b.
ParsecT
  ParserError
  Text
  (StateT ParserState (ReaderT (Maybe Version) Quote))
  a
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     b
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>)

trailingWhitespace :: Parser a -> Parser a
trailingWhitespace :: forall a. Parser a -> Parser a
trailingWhitespace = (ParsecT
  ParserError
  Text
  (StateT ParserState (ReaderT (Maybe Version) Quote))
  a
-> Parser ()
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
forall a b.
ParsecT
  ParserError
  Text
  (StateT ParserState (ReaderT (Maybe Version) Quote))
  a
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     b
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
whitespace)

{- | Returns a parser for @a@ by calling the supplied function on the starting
and ending positions of @a@.

The supplied function should usually return a parser that does /not/ consume trailing
whitespaces. Otherwise, the end position will be the first character after the
trailing whitespaces.
-}
withSpan' :: (SrcSpan -> Parser a) -> Parser a
withSpan' :: forall a. (SrcSpan -> Parser a) -> Parser a
withSpan' SrcSpan -> Parser a
f = mdo
  SourcePos
start <- ParsecT
  ParserError
  Text
  (StateT ParserState (ReaderT (Maybe Version) Quote))
  SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
  a
res <- SrcSpan -> Parser a
f SrcSpan
sp
  SourcePos
end <- ParsecT
  ParserError
  Text
  (StateT ParserState (ReaderT (Maybe Version) Quote))
  SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
  let sp :: SrcSpan
sp = SourcePos -> SourcePos -> SrcSpan
toSrcSpan SourcePos
start SourcePos
end
  a -> Parser a
forall a.
a
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res

{- | Like `withSpan'`, but the result parser consumes whitespaces.

@withSpan = (<* whitespace) . withSpan'
-}
withSpan :: (SrcSpan -> Parser a) -> Parser a
withSpan :: forall a. (SrcSpan -> Parser a) -> Parser a
withSpan = (ParsecT
  ParserError
  Text
  (StateT ParserState (ReaderT (Maybe Version) Quote))
  a
-> Parser ()
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
forall a b.
ParsecT
  ParserError
  Text
  (StateT ParserState (ReaderT (Maybe Version) Quote))
  a
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     b
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
whitespace) (ParsecT
   ParserError
   Text
   (StateT ParserState (ReaderT (Maybe Version) Quote))
   a
 -> ParsecT
      ParserError
      Text
      (StateT ParserState (ReaderT (Maybe Version) Quote))
      a)
-> ((SrcSpan
     -> ParsecT
          ParserError
          Text
          (StateT ParserState (ReaderT (Maybe Version) Quote))
          a)
    -> ParsecT
         ParserError
         Text
         (StateT ParserState (ReaderT (Maybe Version) Quote))
         a)
-> (SrcSpan
    -> ParsecT
         ParserError
         Text
         (StateT ParserState (ReaderT (Maybe Version) Quote))
         a)
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SrcSpan
 -> ParsecT
      ParserError
      Text
      (StateT ParserState (ReaderT (Maybe Version) Quote))
      a)
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
forall a. (SrcSpan -> Parser a) -> Parser a
withSpan'

lexeme :: Parser a -> Parser a
lexeme :: forall a. Parser a -> Parser a
lexeme = Parser ()
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
Lex.lexeme Parser ()
whitespace

symbol :: Text -> Parser Text
symbol :: Text -> Parser Text
symbol = Parser ()
-> Tokens Text
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
Lex.symbol Parser ()
whitespace

inParens :: Parser a -> Parser a
inParens :: forall a. Parser a -> Parser a
inParens = Parser Text
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     Char
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Text -> Parser Text
symbol Text
"(") (Token Text
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
')')

inBrackets :: Parser a -> Parser a
inBrackets :: forall a. Parser a -> Parser a
inBrackets = Parser Text
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     Char
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Text -> Parser Text
symbol Text
"[") (Token Text
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
']')

inBraces :: Parser a -> Parser a
inBraces :: forall a. Parser a -> Parser a
inBraces = Parser Text
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     Char
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Text -> Parser Text
symbol Text
"{") (Token Text
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'}')

toSrcSpan :: SourcePos -> SourcePos -> SrcSpan
toSrcSpan :: SourcePos -> SourcePos -> SrcSpan
toSrcSpan SourcePos
start SourcePos
end =
  SrcSpan
    { srcSpanFile :: String
srcSpanFile = SourcePos -> String
sourceName SourcePos
start
    , srcSpanSLine :: Int
srcSpanSLine = Pos -> Int
unPos (SourcePos -> Pos
sourceLine SourcePos
start)
    , srcSpanSCol :: Int
srcSpanSCol = Pos -> Int
unPos (SourcePos -> Pos
sourceColumn SourcePos
start)
    , srcSpanELine :: Int
srcSpanELine = Pos -> Int
unPos (SourcePos -> Pos
sourceLine SourcePos
end)
    , srcSpanECol :: Int
srcSpanECol = Pos -> Int
unPos (SourcePos -> Pos
sourceColumn SourcePos
end)
    }

version :: Parser Version
version :: Parser Version
version = Parser Version -> Parser Version
forall a. Parser a -> Parser a
trailingWhitespace (Parser Version -> Parser Version)
-> Parser Version -> Parser Version
forall a b. (a -> b) -> a -> b
$ do
  Natural
x <- ParsecT
  ParserError
  Text
  (StateT ParserState (ReaderT (Maybe Version) Quote))
  Natural
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
Lex.decimal
  Char
_ <- Token Text
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'.'
  Natural
y <- ParsecT
  ParserError
  Text
  (StateT ParserState (ReaderT (Maybe Version) Quote))
  Natural
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
Lex.decimal
  Char
_ <- Token Text
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'.'
  Natural -> Natural -> Natural -> Version
Version Natural
x Natural
y (Natural -> Version)
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     Natural
-> Parser Version
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT
  ParserError
  Text
  (StateT ParserState (ReaderT (Maybe Version) Quote))
  Natural
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
Lex.decimal

-- | Parses a `Name`. Does not consume leading or trailing whitespaces.
name :: Parser Name
name :: Parser Name
name = Parser Name -> Parser Name
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser Name -> Parser Name) -> Parser Name -> Parser Name
forall a b. (a -> b) -> a -> b
$ Parser Name
parseUnquoted Parser Name -> Parser Name -> Parser Name
forall a.
ParsecT
  ParserError
  Text
  (StateT ParserState (ReaderT (Maybe Version) Quote))
  a
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Name
parseQuoted
  where
    parseUnquoted :: Parser Name
    parseUnquoted :: Parser Name
parseUnquoted = do
      Token Text
_ <- ParsecT
  ParserError
  Text
  (StateT ParserState (ReaderT (Maybe Version) Quote))
  (Token Text)
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     (Token Text)
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead ((Token Text -> Bool)
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
isIdentifierStartingChar)
      Text
str <- Maybe String
-> (Token Text -> Bool)
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"identifier-unquoted") Char -> Bool
Token Text -> Bool
isIdentifierChar
      Text -> Unique -> Name
Name Text
str (Unique -> Name)
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     Unique
-> Parser Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     Unique
uniqueSuffix Text
str

    parseQuoted :: Parser Name
    parseQuoted :: Parser Name
parseQuoted = do
      Char
_ <- Token Text
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'`'
      Token Text
_ <- ParsecT
  ParserError
  Text
  (StateT ParserState (ReaderT (Maybe Version) Quote))
  (Token Text)
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     (Token Text)
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead ((Token Text -> Bool)
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
isQuotedIdentifierChar)
      Text
str <- Maybe String
-> (Token Text -> Bool)
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"identifier-quoted") Char -> Bool
Token Text -> Bool
isQuotedIdentifierChar
      Char
_ <- Token Text
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'`'
      Text -> Unique -> Name
Name Text
str (Unique -> Name)
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     Unique
-> Parser Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     Unique
uniqueSuffix Text
str

    -- Tries to parse a `Unique` value.
    -- If it fails then looks up the `Unique` value for the given name.
    -- If lookup fails too then generates a fresh `Unique` value.
    uniqueSuffix :: Text -> Parser Unique
    uniqueSuffix :: Text
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     Unique
uniqueSuffix Text
nameStr = ParsecT
  ParserError
  Text
  (StateT ParserState (ReaderT (Maybe Version) Quote))
  Unique
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     Unique
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Int -> Unique
Unique (Int -> Unique)
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     Int
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     Unique
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token Text
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-' ParsecT
  ParserError
  Text
  (StateT ParserState (ReaderT (Maybe Version) Quote))
  Char
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     Int
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     Int
forall a b.
ParsecT
  ParserError
  Text
  (StateT ParserState (ReaderT (Maybe Version) Quote))
  a
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     b
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT
  ParserError
  Text
  (StateT ParserState (ReaderT (Maybe Version) Quote))
  Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
Lex.decimal)) ParsecT
  ParserError
  Text
  (StateT ParserState (ReaderT (Maybe Version) Quote))
  Unique
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     Unique
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     Unique
forall a.
ParsecT
  ParserError
  Text
  (StateT ParserState (ReaderT (Maybe Version) Quote))
  a
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text
-> ParsecT
     ParserError
     Text
     (StateT ParserState (ReaderT (Maybe Version) Quote))
     Unique
forall (m :: * -> *).
(MonadState ParserState m, MonadQuote m) =>
Text -> m Unique
uniqueForName Text
nameStr

    -- Return the unique identifier of a name.
    -- If it's not in the current parser state, map the name to a fresh id and add it to the state.
    uniqueForName :: (MonadState ParserState m, MonadQuote m) => Text -> m Unique
    uniqueForName :: forall (m :: * -> *).
(MonadState ParserState m, MonadQuote m) =>
Text -> m Unique
uniqueForName Text
nameStr = do
      ParserState
parserState <- m ParserState
forall s (m :: * -> *). MonadState s m => m s
get
      case Text -> Map Text Unique -> Maybe Unique
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
nameStr (ParserState -> Map Text Unique
identifiers ParserState
parserState) of
        Just Unique
u -> Unique -> m Unique
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Unique
u
        Maybe Unique
Nothing -> do
          Unique
fresh <- m Unique
forall (m :: * -> *). MonadQuote m => m Unique
freshUnique
          ParserState -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ParserState -> m ()) -> ParserState -> m ()
forall a b. (a -> b) -> a -> b
$ Map Text Unique -> ParserState
ParserState (Map Text Unique -> ParserState) -> Map Text Unique -> ParserState
forall a b. (a -> b) -> a -> b
$ Text -> Unique -> Map Text Unique -> Map Text Unique
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
nameStr Unique
fresh (Map Text Unique -> Map Text Unique)
-> Map Text Unique -> Map Text Unique
forall a b. (a -> b) -> a -> b
$ ParserState -> Map Text Unique
identifiers ParserState
parserState
          Unique -> m Unique
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Unique
fresh