-- 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 :: Parser' le ParsedOp -> Parser le le
letBlock Parser' le ParsedOp
opParser = do
  Tokens Text -> Parser le ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
"let"
  Tokens Text -> Parser le ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
"{"
  le :~: LetEnv
Refl <- Parser' le (le :~: LetEnv)
forall le. Parser le (le :~: LetEnv)
assertLetEnv
  LetEnv
ls <- (LetEnv -> LetEnv)
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetEnv
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetEnv
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (LetEnv -> LetEnv -> LetEnv
forall a b. a -> b -> a
const LetEnv
noLetEnv) (Parser' LetEnv ParsedOp
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetEnv
letInner Parser' le ParsedOp
Parser' LetEnv ParsedOp
opParser)
  Tokens Text -> Parser le ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
"}"
  Parser' le ()
forall le. Parser le ()
semicolon
  return le
ls

-- | Incrementally build the let environment
letInner :: Parser' LetEnv ParsedOp -> Parser' LetEnv LetEnv
letInner :: Parser' LetEnv ParsedOp
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetEnv
letInner Parser' LetEnv ParsedOp
opParser = do
  LetEnv
env <- ReaderT LetEnv (ParsecT CustomParserException Text Identity) LetEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
  Let
l <- Parser' LetEnv ParsedOp -> Parser' LetEnv Let
lets Parser' LetEnv ParsedOp
opParser
  Parser' LetEnv ()
forall le. Parser le ()
semicolon
  (LetEnv -> LetEnv)
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetEnv
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetEnv
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Let -> LetEnv -> LetEnv
addLet Let
l) (Parser' LetEnv ParsedOp
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetEnv
letInner Parser' LetEnv ParsedOp
opParser) ReaderT LetEnv (ParsecT CustomParserException Text Identity) LetEnv
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetEnv
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetEnv
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> LetEnv
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (Let -> LetEnv -> LetEnv
addLet Let
l LetEnv
env)

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

lets :: Parser' LetEnv ParsedOp -> Parser' LetEnv Let
lets :: Parser' LetEnv ParsedOp -> Parser' LetEnv Let
lets Parser' LetEnv ParsedOp
opParser = [Parser' LetEnv Let] -> Parser' LetEnv Let
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
  [ (LetMacro -> Let
LetM (LetMacro -> Let)
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetMacro
-> Parser' LetEnv Let
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser' LetEnv ParsedOp
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetMacro
letMacro Parser' LetEnv ParsedOp
opParser)
  , (LetValue -> Let
LetV (LetValue -> Let)
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetValue
-> Parser' LetEnv Let
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser' LetEnv ParsedOp
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetValue
letValue Parser' LetEnv ParsedOp
opParser)
  , (LetType -> Let
LetT (LetType -> Let)
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetType
-> Parser' LetEnv Let
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  LetEnv (ParsecT CustomParserException Text Identity) LetType
letType)
  ]

-- | Build a let name parser from a leading character parser
letName :: Parser' LetEnv Char -> Parser' LetEnv Text
letName :: Parser' LetEnv Char -> Parser' LetEnv Text
letName Parser' LetEnv Char
p = Parser LetEnv Text -> Parser LetEnv Text
forall le a. Parser le a -> Parser le a
lexeme (Parser LetEnv Text -> Parser LetEnv Text)
-> Parser LetEnv Text -> Parser LetEnv Text
forall a b. (a -> b) -> a -> b
$ do
  Char
v <- Parser' LetEnv Char
p
  let validChar :: Char -> Bool
validChar Char
x = Char -> Bool
Char.isAscii Char
x Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
&& (Char -> Bool
Char.isAlphaNum Char
x Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_')
  [Char]
vs <- Parser' LetEnv Char
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) [Char]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((Token Text -> Bool)
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
validChar)
  return $ [Char] -> Text
forall a. ToText a => a -> Text
toText (Char
vChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
vs)

letMacro :: Parser' LetEnv ParsedOp -> Parser' LetEnv LetMacro
letMacro :: Parser' LetEnv ParsedOp
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetMacro
letMacro Parser' LetEnv ParsedOp
opParser = Parser LetEnv LetMacro -> Parser LetEnv LetMacro
forall le a. Parser le a -> Parser le a
lexeme (Parser LetEnv LetMacro -> Parser LetEnv LetMacro)
-> Parser LetEnv LetMacro -> Parser LetEnv LetMacro
forall a b. (a -> b) -> a -> b
$ do
  Text
n <- Parser' LetEnv Text -> Parser' LetEnv Text
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser' LetEnv Text -> Parser' LetEnv Text)
-> Parser' LetEnv Text -> Parser' LetEnv Text
forall a b. (a -> b) -> a -> b
$ do
    Text
n <- Parser' LetEnv Char -> Parser' LetEnv Text
letName Parser' LetEnv Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
lowerChar
    Tokens Text -> Parser LetEnv ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
"::"
    return Text
n
  StackFn
s <- Parser' LetEnv StackFn
stackFn
  Tokens Text -> Parser LetEnv ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
"="
  [ParsedOp]
o <- Parser' LetEnv ParsedOp -> Parser LetEnv [ParsedOp]
forall le. Parser' le ParsedOp -> Parser le [ParsedOp]
ops' Parser' LetEnv ParsedOp
opParser
  return $ Text -> StackFn -> [ParsedOp] -> LetMacro
LetMacro Text
n StackFn
s [ParsedOp]
o

letType :: Parser' LetEnv LetType
letType :: ReaderT
  LetEnv (ParsecT CustomParserException Text Identity) LetType
letType = Parser LetEnv LetType -> Parser LetEnv LetType
forall le a. Parser le a -> Parser le a
lexeme (Parser LetEnv LetType -> Parser LetEnv LetType)
-> Parser LetEnv LetType -> Parser LetEnv LetType
forall a b. (a -> b) -> a -> b
$ do
  Text
n <- Parser' LetEnv Text -> Parser' LetEnv Text
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser' LetEnv Text -> Parser' LetEnv Text)
-> Parser' LetEnv Text -> Parser' LetEnv Text
forall a b. (a -> b) -> a -> b
$ do
    Tokens Text -> Parser LetEnv ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
"type"
    Text
n <- Parser' LetEnv Char -> Parser' LetEnv Text
letName Parser' LetEnv Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
upperChar Parser' LetEnv Text -> Parser' LetEnv Text -> Parser' LetEnv Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser' LetEnv Char -> Parser' LetEnv Text
letName Parser' LetEnv Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
lowerChar
    Tokens Text -> Parser LetEnv ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
"="
    return Text
n
  t :: Ty
t@(Ty T
t' TypeAnn
a) <- Parser' LetEnv Ty
forall le. Parser le Ty
type_
  if TypeAnn
a TypeAnn -> TypeAnn -> Bool
forall a. Eq a => a -> a -> Bool
== TypeAnn
forall k (a :: k). Annotation a
noAnn
    then case Text -> Either Text TypeAnn
forall k (a :: k). Text -> Either Text (Annotation a)
mkAnnotation Text
n of
      Right TypeAnn
an -> LetType
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetType
forall (m :: * -> *) a. Monad m => a -> m a
return (LetType
 -> ReaderT
      LetEnv (ParsecT CustomParserException Text Identity) LetType)
-> LetType
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetType
forall a b. (a -> b) -> a -> b
$ Text -> Ty -> LetType
LetType Text
n (T -> TypeAnn -> Ty
Ty T
t' TypeAnn
an)
      Left Text
err -> [Char]
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetType
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
 -> ReaderT
      LetEnv (ParsecT CustomParserException Text Identity) LetType)
-> [Char]
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetType
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
forall a. ToString a => a -> [Char]
toString Text
err
    else LetType
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetType
forall (m :: * -> *) a. Monad m => a -> m a
return (LetType
 -> ReaderT
      LetEnv (ParsecT CustomParserException Text Identity) LetType)
-> LetType
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetType
forall a b. (a -> b) -> a -> b
$ Text -> Ty -> LetType
LetType Text
n Ty
t

letValue :: Parser' LetEnv ParsedOp -> Parser' LetEnv LetValue
letValue :: Parser' LetEnv ParsedOp
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetValue
letValue Parser' LetEnv ParsedOp
opParser = Parser LetEnv LetValue -> Parser LetEnv LetValue
forall le a. Parser le a -> Parser le a
lexeme (Parser LetEnv LetValue -> Parser LetEnv LetValue)
-> Parser LetEnv LetValue -> Parser LetEnv LetValue
forall a b. (a -> b) -> a -> b
$ do
  Text
n <- Parser' LetEnv Text -> Parser' LetEnv Text
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser' LetEnv Text -> Parser' LetEnv Text)
-> Parser' LetEnv Text -> Parser' LetEnv Text
forall a b. (a -> b) -> a -> b
$ do
    Text
n <- Parser' LetEnv Char -> Parser' LetEnv Text
letName Parser' LetEnv Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
upperChar
    Tokens Text -> Parser LetEnv ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
"::"
    return Text
n
  Ty
t <- Parser' LetEnv Ty
forall le. Parser le Ty
type_
  Tokens Text -> Parser LetEnv ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
"="
  ParsedValue
v <- Parser LetEnv ParsedOp -> Parser LetEnv ParsedValue
forall le. Parser le ParsedOp -> Parser le ParsedValue
value' Parser' LetEnv ParsedOp
Parser LetEnv ParsedOp
opParser
  return $ Text -> Ty -> ParsedValue -> LetValue
LetValue Text
n Ty
t ParsedValue
v

mkLetMac :: Map Text LetMacro -> Parser' LetEnv LetMacro
mkLetMac :: Map Text LetMacro
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetMacro
mkLetMac Map Text LetMacro
lms = [ReaderT
   LetEnv (ParsecT CustomParserException Text Identity) LetMacro]
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetMacro
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([ReaderT
    LetEnv (ParsecT CustomParserException Text Identity) LetMacro]
 -> ReaderT
      LetEnv (ParsecT CustomParserException Text Identity) LetMacro)
-> [ReaderT
      LetEnv (ParsecT CustomParserException Text Identity) LetMacro]
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) LetMacro
forall a b. (a -> b) -> a -> b
$ (LetMacro -> Text) -> LetMacro -> Parser LetEnv LetMacro
forall a le. (a -> Text) -> a -> Parser le a
mkParser LetMacro -> Text
lmName (LetMacro
 -> ReaderT
      LetEnv (ParsecT CustomParserException Text Identity) LetMacro)
-> [LetMacro]
-> [ReaderT
      LetEnv (ParsecT CustomParserException Text Identity) LetMacro]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Map Text LetMacro -> [LetMacro]
forall k a. Map k a -> [a]
Map.elems Map Text LetMacro
lms)

stackFn :: Parser' LetEnv StackFn
stackFn :: Parser' LetEnv StackFn
stackFn = do
  Maybe [Var]
vs <- (ReaderT LetEnv (ParsecT CustomParserException Text Identity) [Var]
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) (Maybe [Var])
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Tokens Text -> Parser LetEnv ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
"forall" Parser' LetEnv ()
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) [Var]
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) [Var]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReaderT LetEnv (ParsecT CustomParserException Text Identity) Var
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) [Var]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ReaderT LetEnv (ParsecT CustomParserException Text Identity) Var
forall le. Parser le Var
varID ReaderT LetEnv (ParsecT CustomParserException Text Identity) [Var]
-> Parser' LetEnv ()
-> ReaderT
     LetEnv (ParsecT CustomParserException Text Identity) [Var]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text -> Parser LetEnv ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
"."))
  StackTypePattern
a <- Parser' LetEnv StackTypePattern
stackType
  Tokens Text -> Parser LetEnv ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
"->"
  StackTypePattern
b <- Parser' LetEnv StackTypePattern
stackType
  return $ Maybe (Set Var) -> StackTypePattern -> StackTypePattern -> StackFn
StackFn ([Var] -> Set Var
forall a. Ord a => [a] -> Set a
Set.fromList ([Var] -> Set Var) -> Maybe [Var] -> Maybe (Set Var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Var]
vs) StackTypePattern
a StackTypePattern
b