Parser.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- TODO [#712]: Remove this next major release
{-# OPTIONS_GHC -Wno-deprecations -Wno-redundant-constraints #-}

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

  -- * Parsers
  , program
  , programExt
  , value

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

  -- * Additional helpers
  , MichelsonSource (..)
  , codeSrc
  , parseNoEnv
  , parseValue
  , parseExpandValue

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

  -- * Quoters
  , utypeQ
  , uparamTypeQ
  , notes

  -- * Re-exports
  , errorBundlePretty
  ) where

import Prelude hiding (try)

import Data.Default (Default(..))
import Fmt (pretty, (+|), (|+))
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Quote qualified as TH
import Language.Haskell.TH.Syntax qualified as TH
import Text.Megaparsec
  (Parsec, choice, customFailure, eitherP, eof, errorBundlePretty, getSourcePos, hidden, lookAhead,
  parse, sepEndBy, try)
import Text.Megaparsec.Pos (SourcePos(..), unPos)

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

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

-- | Parse with empty environment
parseNoEnv ::
     Default le
  => Parser' le a
  -> MichelsonSource
  -> Text
  -> Either (ParseErrorBundle Text CustomParserException) a
parseNoEnv p src = parse (runReaderT p def <* eof) (pretty src)

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

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

-- | Michelson contract
program :: Parsec CustomParserException Text (Contract' ParsedOp)
program = runReaderT (programInner @()) def <* eof

programInner
  :: forall env. (Default env)
  => Parser env (Contract' ParsedOp)
programInner = do
  mSpace
  env <- fromMaybe def <$> (optional (letBlock parsedOp))
  local (const env) contract

-- TODO [#712]: Remove this next major release
-- | Michelson contract with let definitions
programExt :: Parsec CustomParserException Text (Contract' ParsedOp)
programExt = runReaderT (programInner @LetEnv) def <* eof

cbParameter :: Parser le ParameterType
cbParameter = symbol1 "parameter" *> cbParameterBare

cbParameterBare :: Parser le ParameterType
cbParameterBare = do
  prefixRootAnn <- optional noteF
  (inTypeRootAnn, t) <- field
  rootAnn <- case (prefixRootAnn, inTypeRootAnn) of
    (Just a, b) | a == noAnn && b == noAnn -> pure noAnn
    (Just a, b) | b == noAnn -> pure a
    (Nothing, b) -> pure b
    (Just _, _) -> customFailure MultiRootAnnotationException
  pure $ ParameterType t rootAnn

cbStorage :: Parser le Ty
cbStorage = symbol1 "storage" *> type_

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

cbView :: Parser le (View' ParsedOp)
cbView = do
  symbol "view"
  viewName <- viewName_
  viewArgument <- type_
  viewReturn <- type_
  viewCode <- ops
  return View{..}

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

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

-- | Michelson contract
contract :: Parser le (Contract' ParsedOp)
contract = do
  mSpace
  result <- braces contractTuple <|> contractTuple
  case orderContractBlock result of
    Just contract' ->
      return contract'
    Nothing ->
      fail $ "Duplicate contract field: " <> pretty result
  where
    -- | @ensureNotDuplicate@ provides a better message and point to the correct line
    -- when the parser fails.
    contractTuple = fmap reverse . executingStateT [] $ do
      (`sepEndBy` lift semicolon) $ do
        r <- lift contractBlock
        get >>= \prev -> lift $ ensureNotDuplicate prev r
        modify (r :)

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

value :: Parser le 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 MSUnspecified "{PUSH int aaa}" & either (putStrLn . displayException) (const $ pure ())
-- 1:11:
--   |
-- 1 | {PUSH int aaa}
--   |           ^^^^
-- unexpected "aaa}"
-- expecting value
-- <BLANKLINE>
parseValue :: MichelsonSource -> Text -> Either ParserException ParsedValue
parseValue = first ParserException ... (parseNoEnv @()) value

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

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

prim :: Parser le 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 le [ParsedOp]
codeEntry = bracewrappedOps

bracewrappedOps :: Parser le [ParsedOp]
bracewrappedOps = lookAhead (symbol "{") *> ops

-- |
-- >>> parseNoEnv @() parsedOp "" "{a}" & either (putStrLn . displayException . ParserException) (const $ pure ())
-- 1:2:
--   |
-- 1 | {a}
--   |  ^
-- unexpected 'a'
-- expecting '{', '}', macro, or primitive instruction
-- <BLANKLINE>
-- >>> :m + Morley.Michelson.Parser.Types
-- >>> parseNoEnv @LetEnv parsedOp "" "{a}" & either (putStrLn . displayException . ParserException) (const $ pure ())
-- ...
-- 1:2:
--   |
-- 1 | {a}
--   |  ^
-- unexpected 'a'
-- expecting '{', '}', macro, morley instruction, or primitive instruction
-- <BLANKLINE>
parsedOp :: Parser le ParsedOp
parsedOp = do
  pos <- getSrcPos
  choice
    [ withLetEnv $ flip Prim pos <$> (EXT <$> extInstr ops)
    , withLetEnv $ lmacWithPos
    , flip Prim pos <$> prim
    , flip Mac pos <$> macro parsedOp
    , primOrMac
    , flip Seq pos <$> bracewrappedOps
    ]
  where
    lmacWithPos :: Parser' LetEnv ParsedOp
    lmacWithPos = do
      act <- mkLetMac <$> asks letMacros
      srcPos <- getSrcPos
      flip LMac srcPos <$> act

getSrcPos :: Parser le SrcPos
getSrcPos = do
  sp <- getSourcePos
  let l = unPos $ sourceLine sp
  let c = unPos $ sourceColumn sp
  -- reindexing starting from 0
  pure . unsafe $ SrcPos <$> (mkPos $ l - 1) <*> (mkPos $ c - 1)

primWithPos :: Parser le ParsedInstr -> Parser le ParsedOp
primWithPos act = do
  srcPos <- getSrcPos
  flip Prim srcPos <$> act

macWithPos :: Parser le Macro -> Parser le ParsedOp
macWithPos act = do
  srcPos <- getSrcPos
  flip Mac srcPos <$> act

ops :: Parser le [ParsedOp]
ops = ops' parsedOp

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

ifOrIfX :: Parser le 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 le ParsedOp
primOrMac = hidden
   $  (macWithPos (ifCmpMac parsedOp) <|> ifOrIfX)
  <|> (macWithPos (mapCadrMac parsedOp) <|> primWithPos (mapOp parsedOp))
  <|> (try (primWithPos pairOp) <|> try (primWithPos pairNOp) <|> macWithPos pairMac)
  <|> (try (macWithPos duupMac) <|> primWithPos dupOp)
  <|> (try (macWithPos carnMac) <|> try (macWithPos cdrnMac) <|> try (macWithPos cadrMac) <|> primWithPos carOp <|> primWithPos cdrOp)

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

parserToQuasiQuoter :: Parser () (TH.Q TH.Exp) -> TH.QuasiQuoter
parserToQuasiQuoter parser = TH.QuasiQuoter
  { TH.quoteExp = \s ->
      case parseNoEnv (mSpace *> parser) "quasi-quoter" (toText s) of
        Left err -> fail $ errorBundlePretty err
        Right qexp -> qexp
  , 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.Ty' by its Morley representation.
--
-- >>> [utypeQ| or (int :a) (nat :b) |]
-- Ty (TOr (UnsafeAnnotation @FieldTag "") (UnsafeAnnotation @FieldTag "") (Ty TInt (UnsafeAnnotation @TypeTag "a")) (Ty TNat (UnsafeAnnotation @TypeTag "b"))) (UnsafeAnnotation @TypeTag "")
--
-- >>> [utypeQ|a|]
-- <BLANKLINE>
-- ...
--   |
-- 1 | a
--   | ^
-- unexpected 'a'
-- expecting type
-- ...
utypeQ :: TH.QuasiQuoter
utypeQ = parserToQuasiQuoter (TH.lift <$> type_)

-- | Creates 'U.ParameterType' by its Morley representation.
uparamTypeQ :: TH.QuasiQuoter
uparamTypeQ = parserToQuasiQuoter (TH.lift <$> cbParameterBare)

-- | Parses and typechecks a 'Morley.Michelson.Typed.Notes'.
--
-- >>> [notes|int :ty|]
-- NTInt (UnsafeAnnotation @TypeTag "ty")
notes :: TH.QuasiQuoter
notes =
  parserToQuasiQuoter do
    t <- type_
    pure $ withUType t TH.lift