Let.hs

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

-- | Parsing of let blocks

module Morley.Michelson.Parser.Let
  ( letBlock
  , mkLetMac
  -- * For tests
  , letInner
  , letType
  ) where

import Prelude hiding (try)

import qualified Data.Char as Char
import qualified Data.Map as Map
import qualified Data.Set as Set

import Text.Megaparsec (choice, satisfy, try)
import Text.Megaparsec.Char (lowerChar, upperChar)

import Morley.Michelson.Let (LetType(..), LetValue(..))
import Morley.Michelson.Macro (LetMacro(..), ParsedOp(..))
import Morley.Michelson.Parser.Ext
import Morley.Michelson.Parser.Helpers
import Morley.Michelson.Parser.Instr
import Morley.Michelson.Parser.Lexer
import Morley.Michelson.Parser.Type
import Morley.Michelson.Parser.Types (LetEnv(..), Parser, noLetEnv)
import Morley.Michelson.Parser.Value
import Morley.Michelson.Untyped (StackFn(..), Ty(..), mkAnnotation, noAnn)

-- | Element of a let block
data Let = LetM LetMacro | LetV LetValue | LetT LetType

-- | let block parser
letBlock :: Parser ParsedOp -> Parser LetEnv
letBlock opParser = do
  symbol "let"
  symbol "{"
  ls <- local (const noLetEnv) (letInner opParser)
  symbol "}"
  semicolon
  return ls

-- | Incrementally build the let environment
letInner :: Parser ParsedOp -> Parser LetEnv
letInner opParser = do
  env <- ask
  l <- lets opParser
  semicolon
  local (addLet l) (letInner opParser) <|> return (addLet l env)

-- | Add a Let to the environment in the correct place
addLet :: Let -> LetEnv -> LetEnv
addLet l (LetEnv lms lvs lts) = case l of
  LetM lm -> LetEnv (Map.insert (lmName lm) lm lms) lvs lts
  LetV lv -> LetEnv lms (Map.insert (lvName lv) lv lvs) lts
  LetT lt -> LetEnv lms lvs (Map.insert (ltName lt) lt lts)

lets :: Parser ParsedOp -> Parser Let
lets opParser = choice
  [ (LetM <$> letMacro opParser)
  , (LetV <$> letValue opParser)
  , (LetT <$> letType)
  ]

-- | Build a let name parser from a leading character parser
letName :: Parser Char -> Parser Text
letName p = lexeme $ do
  v <- p
  -- FIXME (#557): It is possible to define a let name such as "add3", but then
  -- the parser doesn't recognize when it's used as an instruction.
  let validChar x = Char.isAscii x && (Char.isAlphaNum x || x == '\'' || x == '_')
  vs <- many (satisfy validChar)
  return $ toText (v:vs)

letMacro :: Parser ParsedOp -> Parser LetMacro
letMacro opParser = lexeme $ do
  n <- try $ do
    n <- letName lowerChar
    symbol "::"
    return n
  s <- stackFn
  symbol "="
  o <- ops' opParser
  return $ LetMacro n s o

letType :: Parser LetType
letType = lexeme $ do
  n <- try $ do
    symbol "type"
    n <- letName upperChar <|> letName lowerChar
    symbol "="
    return n
  t@(Ty t' a) <- type_
  if a == noAnn
    then case mkAnnotation n of
      Right an -> return $ LetType n (Ty t' an)
      Left err -> fail $ toString err
    else return $ LetType n t

letValue :: Parser ParsedOp -> Parser LetValue
letValue opParser = lexeme $ do
  n <- try $ do
    n <- letName upperChar
    symbol "::"
    return n
  t <- type_
  symbol "="
  v <- value' opParser
  return $ LetValue n t v

mkLetMac :: Map Text LetMacro -> Parser LetMacro
mkLetMac lms = choice $ mkParser lmName <$> (Map.elems lms)

stackFn :: Parser StackFn
stackFn = do
  vs <- (optional (symbol "forall" >> some varID <* symbol "."))
  a <- stackType
  symbol "->"
  b <- stackType
  return $ StackFn (Set.fromList <$> vs) a b