{-# LANGUAGE MultiWayIf        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE RecordWildCards   #-}
{-# 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
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 Data.Text qualified as 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
  :: (MonadError ParserErrorBundle m, MonadQuote m)
  => Parser a
  -> String
  -> Text
  -> m a
parse :: forall (m :: * -> *) a.
(MonadError ParserErrorBundle 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)
  Either ParserErrorBundle a -> m a
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (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 :: (MonadError ParserErrorBundle m, MonadQuote m) => Parser a -> Text -> m a
parseGen :: forall (m :: * -> *) a.
(MonadError ParserErrorBundle m, MonadQuote m) =>
Parser a -> Text -> m a
parseGen Parser a
stuff = Parser a -> String -> Text -> m a
forall (m :: * -> *) a.
(MonadError ParserErrorBundle 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)

-- This is samething from @Text.Megaparsec.Stream@.
reachOffsetNoLine' ::
  forall s.
  (Stream s) =>
  -- | How to split input stream at given offset
  (Int -> s -> (Tokens s, s)) ->
  -- | How to fold over input stream
  (forall b. (b -> Token s -> b) -> b -> Tokens s -> b) ->
  -- | Newline token and tab token
  (Token s, Token s) ->
  -- | Offset to reach
  -- | Increment in column position for a token
  (Token s -> Pos) ->
  Int ->
  -- | Initial 'PosState' to use
  PosState s ->
  -- | Updated 'PosState'
  PosState s
reachOffsetNoLine' :: forall s.
Stream s =>
(Int -> s -> (Tokens s, s))
-> (forall b. (b -> Token s -> b) -> b -> Tokens s -> b)
-> (Token s, Token s)
-> (Token s -> Pos)
-> Int
-> PosState s
-> PosState s
reachOffsetNoLine'
  Int -> s -> (Tokens s, s)
splitAt'
  forall b. (b -> Token s -> b) -> b -> Tokens s -> b
foldl''
  (Token s
newlineTok, Token s
tabTok)
  Token s -> Pos
columnIncrement
  Int
o
  PosState {s
Int
String
SourcePos
Pos
pstateInput :: s
pstateOffset :: Int
pstateSourcePos :: SourcePos
pstateTabWidth :: Pos
pstateLinePrefix :: String
pstateInput :: forall s. PosState s -> s
pstateOffset :: forall s. PosState s -> Int
pstateSourcePos :: forall s. PosState s -> SourcePos
pstateTabWidth :: forall s. PosState s -> Pos
pstateLinePrefix :: forall s. PosState s -> String
..} =
    ( PosState
        { pstateInput :: s
pstateInput = s
post,
          pstateOffset :: Int
pstateOffset = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
pstateOffset Int
o,
          pstateSourcePos :: SourcePos
pstateSourcePos = SourcePos
spos,
          pstateTabWidth :: Pos
pstateTabWidth = Pos
pstateTabWidth,
          pstateLinePrefix :: String
pstateLinePrefix = String
pstateLinePrefix
        }
    )
    where
      spos :: SourcePos
spos = (SourcePos -> Token s -> SourcePos)
-> SourcePos -> Tokens s -> SourcePos
forall b. (b -> Token s -> b) -> b -> Tokens s -> b
foldl'' SourcePos -> Token s -> SourcePos
go SourcePos
pstateSourcePos Tokens s
pre
      (Tokens s
pre, s
post) = Int -> s -> (Tokens s, s)
splitAt' (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
pstateOffset) s
pstateInput
      go :: SourcePos -> Token s -> SourcePos
go (SourcePos String
n Pos
l Pos
c) Token s
ch =
        let c' :: Int
c' = Pos -> Int
unPos Pos
c
            w :: Int
w = Pos -> Int
unPos Pos
pstateTabWidth
         in if
              | Token s
ch Token s -> Token s -> Bool
forall a. Eq a => a -> a -> Bool
== Token s
newlineTok ->
                  String -> Pos -> Pos -> SourcePos
SourcePos String
n (Pos
l Pos -> Pos -> Pos
forall a. Semigroup a => a -> a -> a
<> Pos
pos1) Pos
pos1
              | Token s
ch Token s -> Token s -> Bool
forall a. Eq a => a -> a -> Bool
== Token s
tabTok ->
                  String -> Pos -> Pos -> SourcePos
SourcePos String
n Pos
l (Int -> Pos
mkPos (Int -> Pos) -> Int -> Pos
forall a b. (a -> b) -> a -> b
$ Int
c' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- ((Int
c' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Int
w))
              | Bool
otherwise ->
                  String -> Pos -> Pos -> SourcePos
SourcePos String
n Pos
l (Pos
c Pos -> Pos -> Pos
forall a. Semigroup a => a -> a -> a
<> Token s -> Pos
columnIncrement Token s
ch)
{-# INLINE reachOffsetNoLine' #-}

getSourcePos' :: MonadParsec e Text m => m SourcePos
getSourcePos' :: forall e (m :: * -> *). MonadParsec e Text m => m SourcePos
getSourcePos' = do
  State Text e
st <- m (State Text e)
forall e s (m :: * -> *). MonadParsec e s m => m (State s e)
getParserState
  let
    pst :: PosState Text
pst =
      (Int -> Text -> (Tokens Text, Text))
-> (forall b. (b -> Token Text -> b) -> b -> Tokens Text -> b)
-> (Token Text, Token Text)
-> (Token Text -> Pos)
-> Int
-> PosState Text
-> PosState Text
forall s.
Stream s =>
(Int -> s -> (Tokens s, s))
-> (forall b. (b -> Token s -> b) -> b -> Tokens s -> b)
-> (Token s, Token s)
-> (Token s -> Pos)
-> Int
-> PosState s
-> PosState s
reachOffsetNoLine'
        Int -> Text -> (Text, Text)
Int -> Text -> (Tokens Text, Text)
Text.splitAt
        (b -> Char -> b) -> b -> Text -> b
(b -> Token Text -> b) -> b -> Tokens Text -> b
forall a. (a -> Char -> a) -> a -> Text -> a
forall b. (b -> Token Text -> b) -> b -> Tokens Text -> b
Text.foldl'
        (Char
Token Text
'\n', Char
Token Text
'\t')
        (Pos -> Char -> Pos
forall a b. a -> b -> a
const Pos
pos1)
        (State Text e -> Int
forall s e. State s e -> Int
stateOffset State Text e
st)
        (State Text e -> PosState Text
forall s e. State s e -> PosState s
statePosState State Text e
st)
  State Text e -> m ()
forall e s (m :: * -> *). MonadParsec e s m => State s e -> m ()
setParserState State Text e
st {statePosState = pst}
  SourcePos -> m SourcePos
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosState Text -> SourcePos
forall s. PosState s -> SourcePos
pstateSourcePos PosState Text
pst)

{- | 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 e (m :: * -> *). MonadParsec e Text 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 e (m :: * -> *). MonadParsec e Text 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