module Michelson.Parser
(
Parser
, program
, value
, CustomParserException (..)
, ParseErrorBundle
, ParserException (..)
, StringLiteralParserException (..)
, parseNoEnv
, parseValue
, parseExpandValue
, codeEntry
, type_
, letType
, stringLiteral
, bytesLiteral
, intLiteral
, printComment
) where
import Prelude hiding (try)
import Control.Applicative.Permutations (intercalateEffect, toPermutation)
import Text.Megaparsec (Parsec, choice, eitherP, eof, 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
parseNoEnv ::
Parser a
-> String
-> Text
-> Either (ParseErrorBundle Text CustomParserException) a
parseNoEnv p = parse (runReaderT p noLetEnv <* eof)
program :: Parsec CustomParserException Text (Contract' ParsedOp)
program = runReaderT programInner noLetEnv <* eof
where
programInner :: Parser (Contract' ParsedOp)
programInner = do
mSpace
env <- fromMaybe noLetEnv <$> (optional (letBlock parsedOp))
local (const env) contract
contract :: Parser (Contract' ParsedOp)
contract = do
mSpace
(p,s,c) <- braces contractTuple <|> contractTuple
return $ Contract p s c
where
contractTuple = intercalateEffect semicolon $
(,,) <$> toPermutation parameter
<*> toPermutation storage
<*> toPermutation code
parameter :: Parser Type
parameter = symbol "parameter" *> type_
storage :: Parser Type
storage = symbol "storage" *> type_
code :: Parser [ParsedOp]
code = symbol "code" *> codeEntry
value :: Parser ParsedValue
value = value' parsedOp
parseValue :: Text -> Either ParserException ParsedValue
parseValue = first ParserException . parseNoEnv value ""
parseExpandValue :: Text -> Either ParserException U.Value
parseExpandValue = fmap expandValue . parseValue
prim :: Parser ParsedInstr
prim = primInstr contract parsedOp
codeEntry :: Parser [ParsedOp]
codeEntry = bracewrappedOps
bracewrappedOps :: Parser [ParsedOp]
bracewrappedOps = lookAhead (symbol "{") *> ops
parsedOp :: Parser ParsedOp
parsedOp = do
lms <- asks letMacros
pos <- getSrcPos
choice
[ flip Prim pos <$> (EXT <$> extInstr ops)
, lmacWithPos (mkLetMac lms)
, flip Prim pos <$> prim
, flip Mac pos <$> macro parsedOp
, primOrMac
, flip Seq pos <$> bracewrappedOps
]
where
lmacWithPos :: Parser LetMacro -> Parser ParsedOp
lmacWithPos act = do
srcPos <- getSrcPos
flip LMac srcPos <$> act
getSrcPos :: Parser SrcPos
getSrcPos = do
sp <- getSourcePos
let l = unPos $ sourceLine sp
let c = unPos $ sourceColumn sp
pure $ SrcPos (mkPos $ l - 1) (mkPos $ c - 1)
primWithPos :: Parser ParsedInstr -> Parser ParsedOp
primWithPos act = do
srcPos <- getSrcPos
flip Prim srcPos <$> act
macWithPos :: Parser Macro -> Parser ParsedOp
macWithPos act = do
srcPos <- getSrcPos
flip Mac srcPos <$> act
ops :: Parser [ParsedOp]
ops = ops' parsedOp
ifOrIfX :: Parser ParsedOp
ifOrIfX = do
pos <- getSrcPos
symbol' "IF"
a <- eitherP cmpOp ops
case a of
Left cmp -> flip Mac pos <$> (IFX cmp <$> ops <*> ops)
Right op -> flip Prim pos <$> (IF op <$> ops)
primOrMac :: Parser ParsedOp
primOrMac = (macWithPos (ifCmpMac parsedOp) <|> ifOrIfX)
<|> (macWithPos (mapCadrMac parsedOp) <|> primWithPos (mapOp parsedOp))
<|> (try (primWithPos pairOp) <|> macWithPos pairMac)