-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

module Michelson.Parser
  ( -- * Main parser type
    Parser

  -- * Parsers
  , program
  , value

  -- * Errors
  , CustomParserException (..)
  , ParseErrorBundle
  , ParserException (..)
  , StringLiteralParserException (..)

  -- * Additional helpers
  , parseNoEnv
  , parseValue
  , parseExpandValue

  -- * For tests
  , codeEntry
  , ops
  , type_
  , letInner
  , letType
  , stringLiteral
  , bytesLiteral
  , intLiteral
  , parsedOp
  , printComment

  -- * Quoters
  , utypeQ

  -- * Re-exports
  , errorBundlePretty
  ) where

import Prelude hiding (try)

import qualified Language.Haskell.TH.Quote as TH
import Text.Megaparsec (Parsec, choice, customFailure, eitherP, eof, errorBundlePretty,
  getSourcePos, lookAhead, parse, try)
import Text.Megaparsec.Pos (SourcePos(..), unPos)

import Michelson.ErrorPos (SrcPos(..), mkPos)
import Michelson.Macro (LetMacro, Macro(..), ParsedInstr, ParsedOp(..), ParsedValue, expandValue)
import Michelson.Parser.Annotations (noteF)
import Michelson.Parser.Error
import Michelson.Parser.Ext
import Michelson.Parser.Instr
import Michelson.Parser.Let
import Michelson.Parser.Lexer
import Michelson.Parser.Macro
import Michelson.Parser.Type
import Michelson.Parser.Types
import Michelson.Parser.Value
import Michelson.Untyped
import qualified Michelson.Untyped as U

----------------------------------------------------------------------------
-- Helpers
----------------------------------------------------------------------------

-- | Parse with empty environment
parseNoEnv ::
     Parser a
  -> String
  -> Text
  -> Either (ParseErrorBundle Text CustomParserException) a
parseNoEnv :: Parser a
-> String
-> Text
-> Either (ParseErrorBundle Text CustomParserException) a
parseNoEnv p :: Parser a
p = Parsec CustomParserException Text a
-> String
-> Text
-> Either (ParseErrorBundle Text CustomParserException) a
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (Parser a -> LetEnv -> Parsec CustomParserException Text a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Parser a
p LetEnv
noLetEnv Parsec CustomParserException Text a
-> Parsec CustomParserException Text ()
-> Parsec CustomParserException Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parsec CustomParserException Text ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof)

-------------------------------------------------------------------------------
-- Parsers
-------------------------------------------------------------------------------

-- Contract
------------------

-- | Michelson contract with let definitions
program :: Parsec CustomParserException Text (Contract' ParsedOp)
program :: Parsec CustomParserException Text (Contract' ParsedOp)
program = ReaderT
  LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
-> LetEnv -> Parsec CustomParserException Text (Contract' ParsedOp)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT
  LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
programInner LetEnv
noLetEnv Parsec CustomParserException Text (Contract' ParsedOp)
-> Parsec CustomParserException Text ()
-> Parsec CustomParserException Text (Contract' ParsedOp)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parsec CustomParserException Text ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
  where
    programInner :: Parser (Contract' ParsedOp)
    programInner :: ReaderT
  LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
programInner = do
      Parser ()
mSpace
      LetEnv
env <- LetEnv -> Maybe LetEnv -> LetEnv
forall a. a -> Maybe a -> a
fromMaybe LetEnv
noLetEnv (Maybe LetEnv -> LetEnv)
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (Maybe LetEnv)
-> ReaderT LetEnv (Parsec CustomParserException Text) LetEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReaderT LetEnv (Parsec CustomParserException Text) LetEnv
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (Maybe LetEnv)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser ParsedOp
-> ReaderT LetEnv (Parsec CustomParserException Text) LetEnv
letBlock Parser ParsedOp
parsedOp))
      (LetEnv -> LetEnv)
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (LetEnv -> LetEnv -> LetEnv
forall a b. a -> b -> a
const LetEnv
env) ReaderT
  LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
contract

cbParameter :: Parser ParameterType
cbParameter :: Parser ParameterType
cbParameter = do
  Tokens Text -> Parser ()
symbol "parameter"
  Maybe FieldAnn
prefixRootAnn <- ReaderT LetEnv (Parsec CustomParserException Text) FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (Maybe FieldAnn)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ReaderT LetEnv (Parsec CustomParserException Text) FieldAnn
noteF
  (inTypeRootAnn :: FieldAnn
inTypeRootAnn, t :: Type
t) <- Parser (FieldAnn, Type)
field
  FieldAnn
rootAnn <- case (Maybe FieldAnn
prefixRootAnn, FieldAnn
inTypeRootAnn) of
    -- TODO: [#310] Handle cases where there are 2 empty root annotations.
    -- For example: root % (unit %) which should throw the error.
    (Just "", "") -> FieldAnn
-> ReaderT LetEnv (Parsec CustomParserException Text) FieldAnn
forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldAnn
forall k (a :: k). Annotation a
noAnn
    (Just a :: FieldAnn
a, "") -> FieldAnn
-> ReaderT LetEnv (Parsec CustomParserException Text) FieldAnn
forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldAnn
a
    (Nothing, b :: FieldAnn
b) -> FieldAnn
-> ReaderT LetEnv (Parsec CustomParserException Text) FieldAnn
forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldAnn
b
    (Just _, _) -> CustomParserException
-> ReaderT LetEnv (Parsec CustomParserException Text) FieldAnn
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure CustomParserException
MultiRootAnnotationException
  pure $ Type -> RootAnn -> ParameterType
ParameterType Type
t (FieldAnn -> RootAnn
forall k1 k2 (tag1 :: k1) (tag2 :: k2).
Annotation tag1 -> Annotation tag2
convAnn FieldAnn
rootAnn)

cbStorage :: Parser Type
cbStorage :: Parser Type
cbStorage = Tokens Text -> Parser ()
symbol "storage" Parser () -> Parser Type -> Parser Type
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Type
type_

cbCode :: Parser [ParsedOp]
cbCode :: Parser [ParsedOp]
cbCode = Tokens Text -> Parser ()
symbol "code" Parser () -> Parser [ParsedOp] -> Parser [ParsedOp]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser [ParsedOp]
codeEntry

contractBlock :: Parser (ContractBlock ParsedOp)
contractBlock :: Parser (ContractBlock ParsedOp)
contractBlock = [Parser (ContractBlock ParsedOp)]
-> Parser (ContractBlock ParsedOp)
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
  [ (ParameterType -> ContractBlock ParsedOp
forall op. ParameterType -> ContractBlock op
CBParam (ParameterType -> ContractBlock ParsedOp)
-> Parser ParameterType -> Parser (ContractBlock ParsedOp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ParameterType
cbParameter)
  , (Type -> ContractBlock ParsedOp
forall op. Type -> ContractBlock op
CBStorage (Type -> ContractBlock ParsedOp)
-> Parser Type -> Parser (ContractBlock ParsedOp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Type
cbStorage)
  , ([ParsedOp] -> ContractBlock ParsedOp
forall op. [op] -> ContractBlock op
CBCode ([ParsedOp] -> ContractBlock ParsedOp)
-> Parser [ParsedOp] -> Parser (ContractBlock ParsedOp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [ParsedOp]
cbCode)
  ]

-- | This ensures that the error message will point to the correct line.
ensureNotDuplicate :: [ContractBlock ParsedOp] -> ContractBlock ParsedOp -> Parser ()
ensureNotDuplicate :: [ContractBlock ParsedOp] -> ContractBlock ParsedOp -> Parser ()
ensureNotDuplicate blocks :: [ContractBlock ParsedOp]
blocks result :: ContractBlock ParsedOp
result =
  let
    failDuplicateField :: String -> m a
failDuplicateField a :: String
a = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ "Duplicate contract field: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
a
  in
    case (ContractBlock ParsedOp
result, [ContractBlock ParsedOp]
blocks) of
      (CBParam _, CBParam _ : _) -> String -> Parser ()
forall (m :: * -> *) a. MonadFail m => String -> m a
failDuplicateField "parameter"
      (CBStorage _, CBStorage _: _) -> String -> Parser ()
forall (m :: * -> *) a. MonadFail m => String -> m a
failDuplicateField "storage"
      (CBCode _, CBCode _: _) -> String -> Parser ()
forall (m :: * -> *) a. MonadFail m => String -> m a
failDuplicateField "code"
      (_, _:xs :: [ContractBlock ParsedOp]
xs) -> [ContractBlock ParsedOp] -> ContractBlock ParsedOp -> Parser ()
ensureNotDuplicate [ContractBlock ParsedOp]
xs ContractBlock ParsedOp
result
      (_, []) -> () -> Parser ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Michelson contract
contract :: Parser (Contract' ParsedOp)
contract :: ReaderT
  LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
contract = do
  Parser ()
mSpace
  (ContractBlock ParsedOp, ContractBlock ParsedOp,
 ContractBlock ParsedOp)
result <- Parser
  (ContractBlock ParsedOp, ContractBlock ParsedOp,
   ContractBlock ParsedOp)
-> Parser
     (ContractBlock ParsedOp, ContractBlock ParsedOp,
      ContractBlock ParsedOp)
forall a. Parser a -> Parser a
braces Parser
  (ContractBlock ParsedOp, ContractBlock ParsedOp,
   ContractBlock ParsedOp)
contractTuple Parser
  (ContractBlock ParsedOp, ContractBlock ParsedOp,
   ContractBlock ParsedOp)
-> Parser
     (ContractBlock ParsedOp, ContractBlock ParsedOp,
      ContractBlock ParsedOp)
-> Parser
     (ContractBlock ParsedOp, ContractBlock ParsedOp,
      ContractBlock ParsedOp)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser
  (ContractBlock ParsedOp, ContractBlock ParsedOp,
   ContractBlock ParsedOp)
contractTuple
  case (ContractBlock ParsedOp, ContractBlock ParsedOp,
 ContractBlock ParsedOp)
-> Maybe (Contract' ParsedOp)
forall op.
(ContractBlock op, ContractBlock op, ContractBlock op)
-> Maybe (Contract' op)
orderContractBlock (ContractBlock ParsedOp, ContractBlock ParsedOp,
 ContractBlock ParsedOp)
result of
    Just contract' :: Contract' ParsedOp
contract' ->
      Contract' ParsedOp
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
forall (m :: * -> *) a. Monad m => a -> m a
return Contract' ParsedOp
contract'
    Nothing ->
      String
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
 -> ReaderT
      LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp))
-> String
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
forall a b. (a -> b) -> a -> b
$ "Duplicate contract field: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (ContractBlock ParsedOp, ContractBlock ParsedOp,
 ContractBlock ParsedOp)
-> String
forall b a. (Show a, IsString b) => a -> b
show (ContractBlock ParsedOp, ContractBlock ParsedOp,
 ContractBlock ParsedOp)
result
  where
    -- | @ensureNotDuplicate@ provides a better message and point to the correct line
    -- when the parser fails.
    contractTuple :: Parser
  (ContractBlock ParsedOp, ContractBlock ParsedOp,
   ContractBlock ParsedOp)
contractTuple = do
      ContractBlock ParsedOp
result1 <- Parser (ContractBlock ParsedOp)
contractBlock
      Parser ()
semicolon

      ContractBlock ParsedOp
result2 <- do
        ContractBlock ParsedOp
r <- Parser (ContractBlock ParsedOp)
contractBlock
        [ContractBlock ParsedOp] -> ContractBlock ParsedOp -> Parser ()
ensureNotDuplicate [ContractBlock ParsedOp
result1] ContractBlock ParsedOp
r
        pure ContractBlock ParsedOp
r
      Parser ()
semicolon

      ContractBlock ParsedOp
result3 <- do
        ContractBlock ParsedOp
r <- Parser (ContractBlock ParsedOp)
contractBlock
        [ContractBlock ParsedOp] -> ContractBlock ParsedOp -> Parser ()
ensureNotDuplicate [ContractBlock ParsedOp
result1, ContractBlock ParsedOp
result2] ContractBlock ParsedOp
r
        pure ContractBlock ParsedOp
r
      Parser ()
-> ReaderT LetEnv (Parsec CustomParserException Text) (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ()
semicolon
      pure (ContractBlock ParsedOp
result1, ContractBlock ParsedOp
result2, ContractBlock ParsedOp
result3)

-- Value
------------------

value :: Parser ParsedValue
value :: Parser ParsedValue
value = Parser ParsedOp -> Parser ParsedValue
value' Parser ParsedOp
parsedOp

-- | Parse untyped value from text which comes from something that is
-- not a file (which is often the case). So we assume it does not need
-- any parsing environment.
parseValue :: Text -> Either ParserException ParsedValue
parseValue :: Text -> Either ParserException ParsedValue
parseValue = (ParseErrorBundle Text CustomParserException -> ParserException)
-> Either (ParseErrorBundle Text CustomParserException) ParsedValue
-> Either ParserException ParsedValue
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseErrorBundle Text CustomParserException -> ParserException
ParserException (Either (ParseErrorBundle Text CustomParserException) ParsedValue
 -> Either ParserException ParsedValue)
-> (Text
    -> Either
         (ParseErrorBundle Text CustomParserException) ParsedValue)
-> Text
-> Either ParserException ParsedValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser ParsedValue
-> String
-> Text
-> Either (ParseErrorBundle Text CustomParserException) ParsedValue
forall a.
Parser a
-> String
-> Text
-> Either (ParseErrorBundle Text CustomParserException) a
parseNoEnv Parser ParsedValue
value ""

-- | Like 'parseValue', but also expands macros.
parseExpandValue :: Text -> Either ParserException U.Value
parseExpandValue :: Text -> Either ParserException Value
parseExpandValue = (ParsedValue -> Value)
-> Either ParserException ParsedValue
-> Either ParserException Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParsedValue -> Value
expandValue (Either ParserException ParsedValue
 -> Either ParserException Value)
-> (Text -> Either ParserException ParsedValue)
-> Text
-> Either ParserException Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either ParserException ParsedValue
parseValue

-- Primitive instruction
------------------

prim :: Parser ParsedInstr
prim :: Parser ParsedInstr
prim = ReaderT
  LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
-> Parser ParsedOp -> Parser ParsedInstr
primInstr ReaderT
  LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
contract Parser ParsedOp
parsedOp

-- Parsed operations (primitive instructions, macros, extras, etc.)
------------------

-- | Parses code block after "code" keyword of a contract.
--
-- This function is part of the module API, its semantics should not change.
codeEntry :: Parser [ParsedOp]
codeEntry :: Parser [ParsedOp]
codeEntry = Parser [ParsedOp]
bracewrappedOps

bracewrappedOps :: Parser [ParsedOp]
bracewrappedOps :: Parser [ParsedOp]
bracewrappedOps = Parser () -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (Tokens Text -> Parser ()
symbol "{") Parser () -> Parser [ParsedOp] -> Parser [ParsedOp]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser [ParsedOp]
ops

parsedOp :: Parser ParsedOp
parsedOp :: Parser ParsedOp
parsedOp = do
  Map Text LetMacro
lms <- (LetEnv -> Map Text LetMacro)
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (Map Text LetMacro)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks LetEnv -> Map Text LetMacro
letMacros
  SrcPos
pos <- Parser SrcPos
getSrcPos
  [Parser ParsedOp] -> Parser ParsedOp
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ (ParsedInstr -> SrcPos -> ParsedOp)
-> SrcPos -> ParsedInstr -> ParsedOp
forall a b c. (a -> b -> c) -> b -> a -> c
flip ParsedInstr -> SrcPos -> ParsedOp
Prim SrcPos
pos (ParsedInstr -> ParsedOp) -> Parser ParsedInstr -> Parser ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExtInstrAbstract ParsedOp -> ParsedInstr
forall op. ExtInstrAbstract op -> InstrAbstract op
EXT (ExtInstrAbstract ParsedOp -> ParsedInstr)
-> ReaderT
     LetEnv
     (Parsec CustomParserException Text)
     (ExtInstrAbstract ParsedOp)
-> Parser ParsedInstr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [ParsedOp]
-> ReaderT
     LetEnv
     (Parsec CustomParserException Text)
     (ExtInstrAbstract ParsedOp)
extInstr Parser [ParsedOp]
ops)
    , Parser LetMacro -> Parser ParsedOp
lmacWithPos (Map Text LetMacro -> Parser LetMacro
mkLetMac Map Text LetMacro
lms)
    , (ParsedInstr -> SrcPos -> ParsedOp)
-> SrcPos -> ParsedInstr -> ParsedOp
forall a b c. (a -> b -> c) -> b -> a -> c
flip ParsedInstr -> SrcPos -> ParsedOp
Prim SrcPos
pos (ParsedInstr -> ParsedOp) -> Parser ParsedInstr -> Parser ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ParsedInstr
prim
    , (Macro -> SrcPos -> ParsedOp) -> SrcPos -> Macro -> ParsedOp
forall a b c. (a -> b -> c) -> b -> a -> c
flip Macro -> SrcPos -> ParsedOp
Mac SrcPos
pos (Macro -> ParsedOp)
-> ReaderT LetEnv (Parsec CustomParserException Text) Macro
-> Parser ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ParsedOp
-> ReaderT LetEnv (Parsec CustomParserException Text) Macro
macro Parser ParsedOp
parsedOp
    , Parser ParsedOp
primOrMac
    , ([ParsedOp] -> SrcPos -> ParsedOp)
-> SrcPos -> [ParsedOp] -> ParsedOp
forall a b c. (a -> b -> c) -> b -> a -> c
flip [ParsedOp] -> SrcPos -> ParsedOp
Seq SrcPos
pos ([ParsedOp] -> ParsedOp) -> Parser [ParsedOp] -> Parser ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [ParsedOp]
bracewrappedOps
    ]
  where
    lmacWithPos :: Parser LetMacro -> Parser ParsedOp
    lmacWithPos :: Parser LetMacro -> Parser ParsedOp
lmacWithPos act :: Parser LetMacro
act = do
      SrcPos
srcPos <- Parser SrcPos
getSrcPos
      (LetMacro -> SrcPos -> ParsedOp) -> SrcPos -> LetMacro -> ParsedOp
forall a b c. (a -> b -> c) -> b -> a -> c
flip LetMacro -> SrcPos -> ParsedOp
LMac SrcPos
srcPos (LetMacro -> ParsedOp) -> Parser LetMacro -> Parser ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser LetMacro
act

getSrcPos :: Parser SrcPos
getSrcPos :: Parser SrcPos
getSrcPos = do
  SourcePos
sp <- ReaderT LetEnv (Parsec CustomParserException Text) SourcePos
forall e s (m :: * -> *). MonadParsec e s m => m SourcePos
getSourcePos
  let l :: Int
l = Pos -> Int
unPos (Pos -> Int) -> Pos -> Int
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceLine SourcePos
sp
  let c :: Int
c = Pos -> Int
unPos (Pos -> Int) -> Pos -> Int
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceColumn SourcePos
sp
  -- reindexing starting from 0
  SrcPos -> Parser SrcPos
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcPos -> Parser SrcPos) -> SrcPos -> Parser SrcPos
forall a b. (a -> b) -> a -> b
$ Pos -> Pos -> SrcPos
SrcPos (Int -> Pos
mkPos (Int -> Pos) -> Int -> Pos
forall a b. (a -> b) -> a -> b
$ Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) (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
- 1)

primWithPos :: Parser ParsedInstr -> Parser ParsedOp
primWithPos :: Parser ParsedInstr -> Parser ParsedOp
primWithPos act :: Parser ParsedInstr
act = do
  SrcPos
srcPos <- Parser SrcPos
getSrcPos
  (ParsedInstr -> SrcPos -> ParsedOp)
-> SrcPos -> ParsedInstr -> ParsedOp
forall a b c. (a -> b -> c) -> b -> a -> c
flip ParsedInstr -> SrcPos -> ParsedOp
Prim SrcPos
srcPos (ParsedInstr -> ParsedOp) -> Parser ParsedInstr -> Parser ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ParsedInstr
act

macWithPos :: Parser Macro -> Parser ParsedOp
macWithPos :: ReaderT LetEnv (Parsec CustomParserException Text) Macro
-> Parser ParsedOp
macWithPos act :: ReaderT LetEnv (Parsec CustomParserException Text) Macro
act = do
  SrcPos
srcPos <- Parser SrcPos
getSrcPos
  (Macro -> SrcPos -> ParsedOp) -> SrcPos -> Macro -> ParsedOp
forall a b c. (a -> b -> c) -> b -> a -> c
flip Macro -> SrcPos -> ParsedOp
Mac SrcPos
srcPos (Macro -> ParsedOp)
-> ReaderT LetEnv (Parsec CustomParserException Text) Macro
-> Parser ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT LetEnv (Parsec CustomParserException Text) Macro
act

ops :: Parser [ParsedOp]
ops :: Parser [ParsedOp]
ops = Parser ParsedOp -> Parser [ParsedOp]
ops' Parser ParsedOp
parsedOp

-------------------------------------------------------------------------------
-- Mixed parsers
-- These are needed for better error messages
-------------------------------------------------------------------------------

ifOrIfX :: Parser ParsedOp
ifOrIfX :: Parser ParsedOp
ifOrIfX = do
  SrcPos
pos <- Parser SrcPos
getSrcPos
  Text -> Parser ()
symbol' "IF"
  Either ParsedInstr [ParsedOp]
a <- Parser ParsedInstr
-> Parser [ParsedOp]
-> ReaderT
     LetEnv
     (Parsec CustomParserException Text)
     (Either ParsedInstr [ParsedOp])
forall (m :: * -> *) a b.
Alternative m =>
m a -> m b -> m (Either a b)
eitherP Parser ParsedInstr
cmpOp Parser [ParsedOp]
ops
  case Either ParsedInstr [ParsedOp]
a of
    Left cmp :: ParsedInstr
cmp -> (Macro -> SrcPos -> ParsedOp) -> SrcPos -> Macro -> ParsedOp
forall a b c. (a -> b -> c) -> b -> a -> c
flip Macro -> SrcPos -> ParsedOp
Mac SrcPos
pos (Macro -> ParsedOp)
-> ReaderT LetEnv (Parsec CustomParserException Text) Macro
-> Parser ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsedInstr -> [ParsedOp] -> [ParsedOp] -> Macro
IFX ParsedInstr
cmp ([ParsedOp] -> [ParsedOp] -> Macro)
-> Parser [ParsedOp]
-> ReaderT
     LetEnv (Parsec CustomParserException Text) ([ParsedOp] -> Macro)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [ParsedOp]
ops ReaderT
  LetEnv (Parsec CustomParserException Text) ([ParsedOp] -> Macro)
-> Parser [ParsedOp]
-> ReaderT LetEnv (Parsec CustomParserException Text) Macro
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [ParsedOp]
ops)
    Right op :: [ParsedOp]
op -> (ParsedInstr -> SrcPos -> ParsedOp)
-> SrcPos -> ParsedInstr -> ParsedOp
forall a b c. (a -> b -> c) -> b -> a -> c
flip ParsedInstr -> SrcPos -> ParsedOp
Prim SrcPos
pos (ParsedInstr -> ParsedOp) -> Parser ParsedInstr -> Parser ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([ParsedOp] -> [ParsedOp] -> ParsedInstr
forall op. [op] -> [op] -> InstrAbstract op
IF [ParsedOp]
op ([ParsedOp] -> ParsedInstr)
-> Parser [ParsedOp] -> Parser ParsedInstr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [ParsedOp]
ops)

-- Some of the operations and macros have the same prefixes in their names
-- So this case should be handled separately
primOrMac :: Parser ParsedOp
primOrMac :: Parser ParsedOp
primOrMac = (ReaderT LetEnv (Parsec CustomParserException Text) Macro
-> Parser ParsedOp
macWithPos (Parser ParsedOp
-> ReaderT LetEnv (Parsec CustomParserException Text) Macro
ifCmpMac Parser ParsedOp
parsedOp) Parser ParsedOp -> Parser ParsedOp -> Parser ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ParsedOp
ifOrIfX)
  Parser ParsedOp -> Parser ParsedOp -> Parser ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ReaderT LetEnv (Parsec CustomParserException Text) Macro
-> Parser ParsedOp
macWithPos (Parser ParsedOp
-> ReaderT LetEnv (Parsec CustomParserException Text) Macro
mapCadrMac Parser ParsedOp
parsedOp) Parser ParsedOp -> Parser ParsedOp -> Parser ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ParsedInstr -> Parser ParsedOp
primWithPos (Parser ParsedOp -> Parser ParsedInstr
mapOp Parser ParsedOp
parsedOp))
  Parser ParsedOp -> Parser ParsedOp -> Parser ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser ParsedOp -> Parser ParsedOp
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser ParsedInstr -> Parser ParsedOp
primWithPos Parser ParsedInstr
pairOp) Parser ParsedOp -> Parser ParsedOp -> Parser ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReaderT LetEnv (Parsec CustomParserException Text) Macro
-> Parser ParsedOp
macWithPos ReaderT LetEnv (Parsec CustomParserException Text) Macro
pairMac)
  Parser ParsedOp -> Parser ParsedOp -> Parser ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser ParsedOp -> Parser ParsedOp
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ReaderT LetEnv (Parsec CustomParserException Text) Macro
-> Parser ParsedOp
macWithPos ReaderT LetEnv (Parsec CustomParserException Text) Macro
duupMac) Parser ParsedOp -> Parser ParsedOp -> Parser ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ParsedOp -> Parser ParsedOp
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ReaderT LetEnv (Parsec CustomParserException Text) Macro
-> Parser ParsedOp
macWithPos ReaderT LetEnv (Parsec CustomParserException Text) Macro
dupNMac) Parser ParsedOp -> Parser ParsedOp -> Parser ParsedOp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ParsedInstr -> Parser ParsedOp
primWithPos Parser ParsedInstr
dupOp)

-------------------------------------------------------------------------------
-- Safe construction of Haskell values
-------------------------------------------------------------------------------

-- | Creates 'U.Type' by its Morley representation.
--
-- >>> [utypeQ| (int :a | nat :b) |]
-- Type (TOr % % (Type (Tc CInt) :a) (Type (Tc CNat) :b)) :
utypeQ :: TH.QuasiQuoter
utypeQ :: QuasiQuoter
utypeQ = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
TH.QuasiQuoter
  { quoteExp :: String -> Q Exp
TH.quoteExp = \s :: String
s ->
      case Parser Type
-> String
-> Text
-> Either (ParseErrorBundle Text CustomParserException) Type
forall a.
Parser a
-> String
-> Text
-> Either (ParseErrorBundle Text CustomParserException) a
parseNoEnv (Parser ()
mSpace Parser () -> Parser Type -> Parser Type
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Type
type_) "QuasiQuoter" (String -> Text
forall a. ToText a => a -> Text
toText String
s) of
        Left err :: ParseErrorBundle Text CustomParserException
err -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text CustomParserException -> String
forall s e.
(Stream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle Text CustomParserException
err
        Right res :: Type
res -> [e| res |]
  , quotePat :: String -> Q Pat
TH.quotePat = \_ -> String -> Q Pat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot be used as pattern"
  , quoteType :: String -> Q Type
TH.quoteType = \_ -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot be used as type"
  , quoteDec :: String -> Q [Dec]
TH.quoteDec = \_ -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot be used as declaration"
  }