Parser.hs

-- 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
  , uparamTypeQ

  -- * Re-exports
  , errorBundlePretty
  ) where

import Prelude hiding (try)

import qualified Language.Haskell.TH.Lift as TH
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(..), unsafeMkPos)
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 p = parse (runReaderT p noLetEnv <* eof)

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

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

-- | Michelson contract with let definitions
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

cbParameter :: Parser ParameterType
cbParameter = symbol "parameter" *> cbParameterBare

cbParameterBare :: Parser ParameterType
cbParameterBare = do
  prefixRootAnn <- optional noteF
  (inTypeRootAnn, t) <- field
  rootAnn <- case (prefixRootAnn, inTypeRootAnn) of
    -- TODO: [#310] Handle cases where there are 2 empty root annotations.
    -- For example: root % (unit %) which should throw the error.
    (Just "", "") -> pure noAnn
    (Just a, "") -> pure a
    (Nothing, b) -> pure b
    (Just _, _) -> customFailure MultiRootAnnotationException
  pure $ ParameterType t rootAnn

cbStorage :: Parser Type
cbStorage = symbol "storage" *> type_

cbCode :: Parser [ParsedOp]
cbCode = symbol "code" *> codeEntry

contractBlock :: Parser (ContractBlock ParsedOp)
contractBlock = choice
  [ (CBParam <$> cbParameter)
  , (CBStorage <$> cbStorage)
  , (CBCode <$> cbCode)
  ]

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

-- | Michelson contract
contract :: Parser (Contract' ParsedOp)
contract = do
  mSpace
  result <- braces contractTuple <|> contractTuple
  case orderContractBlock result of
    Just contract' ->
      return contract'
    Nothing ->
      fail $ "Duplicate contract field: " <> show result
  where
    -- | @ensureNotDuplicate@ provides a better message and point to the correct line
    -- when the parser fails.
    contractTuple = do
      result1 <- contractBlock
      semicolon

      result2 <- do
        r <- contractBlock
        ensureNotDuplicate [result1] r
        pure r
      semicolon

      result3 <- do
        r <- contractBlock
        ensureNotDuplicate [result1, result2] r
        pure r
      optional semicolon
      pure (result1, result2, result3)

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

value :: Parser ParsedValue
value = value' 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 = first ParserException . parseNoEnv value ""

-- | Like 'parseValue', but also expands macros.
parseExpandValue :: Text -> Either ParserException U.Value
parseExpandValue = fmap expandValue . parseValue

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

prim :: Parser ParsedInstr
prim = primInstr contract 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 = 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
  -- reindexing starting from 0
  pure $ SrcPos (unsafeMkPos $ l - 1) (unsafeMkPos $ 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

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

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)

-- Some of the operations and macros have the same prefixes in their names
-- So this case should be handled separately
primOrMac :: Parser ParsedOp
primOrMac = (macWithPos (ifCmpMac parsedOp) <|> ifOrIfX)
  <|> (macWithPos (mapCadrMac parsedOp) <|> primWithPos (mapOp parsedOp))
  <|> (try (primWithPos pairOp) <|> macWithPos pairMac)
  <|> (try (macWithPos duupMac) <|> try (macWithPos dupNMac) <|> primWithPos dupOp)

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

parserToQuasiQuoter :: TH.Lift a => Parser a -> TH.QuasiQuoter
parserToQuasiQuoter parser = TH.QuasiQuoter
  { TH.quoteExp = \s ->
      case parseNoEnv (mSpace *> parser) "QuasiQuoter" (toText s) of
        Left err -> fail $ errorBundlePretty err
        Right res -> [e| res |]
  , TH.quotePat = \_ -> fail "Cannot be used as pattern"
  , TH.quoteType = \_ -> fail "Cannot be used as type"
  , TH.quoteDec = \_ -> fail "Cannot be used as declaration"
  }


-- | 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 = parserToQuasiQuoter type_

-- | Creates 'U.ParameterType' by its Morley representation.
uparamTypeQ :: TH.QuasiQuoter
uparamTypeQ = parserToQuasiQuoter cbParameterBare