Let.hs

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

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

-- | Parsing of let blocks

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

import Prelude hiding (try)

import Data.Char qualified as Char
import Data.Map qualified as Map
import Data.Set qualified as Set
import Data.Type.Equality ((:~:)(Refl))

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, Parser', assertLetEnv, 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 :: forall le. Parser' le ParsedOp -> Parser le le
letBlock opParser = do
  symbol "let"
  symbol "{"
  Refl <- assertLetEnv
  ls <- local (const noLetEnv) (letInner opParser)
  symbol "}"
  semicolon
  return ls

-- | Incrementally build the let environment
letInner :: Parser' LetEnv ParsedOp -> Parser' LetEnv 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' LetEnv ParsedOp -> Parser' LetEnv Let
lets opParser = choice
  [ (LetM <$> letMacro opParser)
  , (LetV <$> letValue opParser)
  , (LetT <$> letType)
  ]

-- | Build a let name parser from a leading character parser
letName :: Parser' LetEnv Char -> Parser' LetEnv Text
letName p = lexeme $ do
  v <- p
  let validChar x = Char.isAscii x && (Char.isAlphaNum x || x == '\'' || x == '_')
  vs <- many (satisfy validChar)
  return $ toText (v:vs)

letMacro :: Parser' LetEnv ParsedOp -> Parser' LetEnv 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' LetEnv 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' LetEnv ParsedOp -> Parser' LetEnv 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' LetEnv LetMacro
mkLetMac lms = choice $ mkParser lmName <$> (Map.elems lms)

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