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

  -- * Parsers
  , program
  , value

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

  -- * Additional helpers
  , parseNoEnv
  , parseValue
  , parseExpandValue

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

  -- * Quoters
  , utypeQ

  -- * Re-exports
  , errorBundlePretty
  ) where

import Prelude hiding (try)

import Control.Applicative.Permutations (intercalateEffect, toPermutation)
import qualified Language.Haskell.TH.Quote as TH
import Text.Megaparsec
  (Parsec, choice, 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.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

-- | Michelson contract
contract :: Parser (Contract' ParsedOp)
contract :: ReaderT
  LetEnv (Parsec CustomParserException Text) (Contract' ParsedOp)
contract = do
  Parser ()
mSpace
  ((r :: FieldAnn
r, p :: Type
p), s :: Type
s, c :: [ParsedOp]
c) <- Parser ((FieldAnn, Type), Type, [ParsedOp])
-> Parser ((FieldAnn, Type), Type, [ParsedOp])
forall a. Parser a -> Parser a
braces Parser ((FieldAnn, Type), Type, [ParsedOp])
contractTuple Parser ((FieldAnn, Type), Type, [ParsedOp])
-> Parser ((FieldAnn, Type), Type, [ParsedOp])
-> Parser ((FieldAnn, Type), Type, [ParsedOp])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ((FieldAnn, Type), Type, [ParsedOp])
contractTuple
  return $ ParameterType -> Type -> [ParsedOp] -> Contract' ParsedOp
forall op. ParameterType -> Type -> [op] -> Contract' op
Contract (Type -> RootAnn -> ParameterType
ParameterType Type
p (FieldAnn -> RootAnn
forall k1 k2 (tag1 :: k1) (tag2 :: k2).
Annotation tag1 -> Annotation tag2
convAnn FieldAnn
r)) Type
s [ParsedOp]
c
  where
    contractTuple :: Parser ((FieldAnn, Type), Type, [ParsedOp])
contractTuple = Parser ()
-> Permutation
     (ReaderT LetEnv (Parsec CustomParserException Text))
     ((FieldAnn, Type), Type, [ParsedOp])
-> Parser ((FieldAnn, Type), Type, [ParsedOp])
forall (m :: * -> *) b a.
(Alternative m, Monad m) =>
m b -> Permutation m a -> m a
intercalateEffect Parser ()
semicolon (Permutation
   (ReaderT LetEnv (Parsec CustomParserException Text))
   ((FieldAnn, Type), Type, [ParsedOp])
 -> Parser ((FieldAnn, Type), Type, [ParsedOp]))
-> Permutation
     (ReaderT LetEnv (Parsec CustomParserException Text))
     ((FieldAnn, Type), Type, [ParsedOp])
-> Parser ((FieldAnn, Type), Type, [ParsedOp])
forall a b. (a -> b) -> a -> b
$
                     (,,) ((FieldAnn, Type)
 -> Type -> [ParsedOp] -> ((FieldAnn, Type), Type, [ParsedOp]))
-> Permutation
     (ReaderT LetEnv (Parsec CustomParserException Text))
     (FieldAnn, Type)
-> Permutation
     (ReaderT LetEnv (Parsec CustomParserException Text))
     (Type -> [ParsedOp] -> ((FieldAnn, Type), Type, [ParsedOp]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
-> Permutation
     (ReaderT LetEnv (Parsec CustomParserException Text))
     (FieldAnn, Type)
forall (m :: * -> *) a. Alternative m => m a -> Permutation m a
toPermutation ReaderT LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
parameter
                          Permutation
  (ReaderT LetEnv (Parsec CustomParserException Text))
  (Type -> [ParsedOp] -> ((FieldAnn, Type), Type, [ParsedOp]))
-> Permutation
     (ReaderT LetEnv (Parsec CustomParserException Text)) Type
-> Permutation
     (ReaderT LetEnv (Parsec CustomParserException Text))
     ([ParsedOp] -> ((FieldAnn, Type), Type, [ParsedOp]))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT LetEnv (Parsec CustomParserException Text) Type
-> Permutation
     (ReaderT LetEnv (Parsec CustomParserException Text)) Type
forall (m :: * -> *) a. Alternative m => m a -> Permutation m a
toPermutation ReaderT LetEnv (Parsec CustomParserException Text) Type
storage
                          Permutation
  (ReaderT LetEnv (Parsec CustomParserException Text))
  ([ParsedOp] -> ((FieldAnn, Type), Type, [ParsedOp]))
-> Permutation
     (ReaderT LetEnv (Parsec CustomParserException Text)) [ParsedOp]
-> Permutation
     (ReaderT LetEnv (Parsec CustomParserException Text))
     ((FieldAnn, Type), Type, [ParsedOp])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
-> Permutation
     (ReaderT LetEnv (Parsec CustomParserException Text)) [ParsedOp]
forall (m :: * -> *) a. Alternative m => m a -> Permutation m a
toPermutation ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
code

    parameter :: Parser (FieldAnn, Type)
    parameter :: ReaderT LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
parameter = Tokens Text -> Parser ()
symbol "parameter" Parser ()
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ReaderT LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
field

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

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


-- 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 :: ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
codeEntry = ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
bracewrappedOps

bracewrappedOps :: Parser [ParsedOp]
bracewrappedOps :: ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
bracewrappedOps = Parser () -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (Tokens Text -> Parser ()
symbol "{") Parser ()
-> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
-> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ReaderT LetEnv (Parsec CustomParserException Text) [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
<$> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
-> ReaderT
     LetEnv
     (Parsec CustomParserException Text)
     (ExtInstrAbstract ParsedOp)
extInstr ReaderT LetEnv (Parsec CustomParserException Text) [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)
-> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
-> Parser ParsedOp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT LetEnv (Parsec CustomParserException Text) [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 :: ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
ops = Parser ParsedOp
-> ReaderT LetEnv (Parsec CustomParserException Text) [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
-> ReaderT LetEnv (Parsec CustomParserException Text) [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 ReaderT LetEnv (Parsec CustomParserException Text) [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)
-> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
-> ReaderT
     LetEnv (Parsec CustomParserException Text) ([ParsedOp] -> Macro)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
ops ReaderT
  LetEnv (Parsec CustomParserException Text) ([ParsedOp] -> Macro)
-> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
-> ReaderT LetEnv (Parsec CustomParserException Text) Macro
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT LetEnv (Parsec CustomParserException Text) [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)
-> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
-> Parser ParsedInstr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT LetEnv (Parsec CustomParserException Text) [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 ReaderT LetEnv (Parsec CustomParserException Text) Type
-> String
-> Text
-> Either (ParseErrorBundle Text CustomParserException) Type
forall a.
Parser a
-> String
-> Text
-> Either (ParseErrorBundle Text CustomParserException) a
parseNoEnv (Parser ()
mSpace Parser ()
-> ReaderT LetEnv (Parsec CustomParserException Text) Type
-> ReaderT LetEnv (Parsec CustomParserException Text) Type
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ReaderT LetEnv (Parsec CustomParserException Text) 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"
  }