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

-- | Parsing of let blocks

module 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 Michelson.Let (LetType(..), LetValue(..))
import Michelson.Macro (LetMacro(..), ParsedOp(..))
import Michelson.Parser.Ext
import Michelson.Parser.Helpers
import Michelson.Parser.Instr
import Michelson.Parser.Lexer
import Michelson.Parser.Type
import Michelson.Parser.Types (LetEnv(..), Parser, noLetEnv)
import Michelson.Parser.Value
import 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 :: Parser ParsedOp -> Parser LetEnv
letBlock Parser ParsedOp
opParser = do
  Tokens Text -> Parser ()
symbol Tokens Text
"let"
  Tokens Text -> Parser ()
symbol Tokens Text
"{"
  LetEnv
ls <- (LetEnv -> LetEnv) -> Parser LetEnv -> Parser 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 ParsedOp -> Parser LetEnv
letInner Parser ParsedOp
opParser)
  Tokens Text -> Parser ()
symbol Tokens Text
"}"
  Parser ()
semicolon
  return LetEnv
ls

-- | Incrementally build the let environment
letInner :: Parser ParsedOp -> Parser LetEnv
letInner :: Parser ParsedOp -> Parser LetEnv
letInner Parser ParsedOp
opParser = do
  LetEnv
env <- Parser LetEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
  Let
l <- Parser ParsedOp -> Parser Let
lets Parser ParsedOp
opParser
  Parser ()
semicolon
  (LetEnv -> LetEnv) -> Parser LetEnv -> Parser LetEnv
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Let -> LetEnv -> LetEnv
addLet Let
l) (Parser ParsedOp -> Parser LetEnv
letInner Parser ParsedOp
opParser) Parser LetEnv -> Parser LetEnv -> Parser LetEnv
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> LetEnv -> Parser 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 ParsedOp -> Parser Let
lets :: Parser ParsedOp -> Parser Let
lets Parser ParsedOp
opParser = [Parser Let] -> Parser Let
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
  [ (LetMacro -> Let
LetM (LetMacro -> Let)
-> ReaderT LetEnv (Parsec CustomParserException Text) LetMacro
-> Parser Let
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ParsedOp
-> ReaderT LetEnv (Parsec CustomParserException Text) LetMacro
letMacro Parser ParsedOp
opParser)
  , (LetValue -> Let
LetV (LetValue -> Let)
-> ReaderT LetEnv (Parsec CustomParserException Text) LetValue
-> Parser Let
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ParsedOp
-> ReaderT LetEnv (Parsec CustomParserException Text) LetValue
letValue Parser ParsedOp
opParser)
  , (LetType -> Let
LetT (LetType -> Let)
-> ReaderT LetEnv (Parsec CustomParserException Text) LetType
-> Parser Let
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT LetEnv (Parsec CustomParserException Text) LetType
letType)
  ]

-- | Build a let name parser from a leading character parser
letName :: Parser Char -> Parser Text
letName :: Parser Char -> Parser Text
letName Parser Char
p = Parser Text -> Parser Text
forall a. Parser a -> Parser a
lexeme (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ do
  Char
v <- Parser Char
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 :: 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 Char
-> ReaderT LetEnv (Parsec CustomParserException Text) [Char]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((Token Text -> Bool)
-> ReaderT LetEnv (Parsec CustomParserException Text) (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 ParsedOp -> Parser LetMacro
letMacro :: Parser ParsedOp
-> ReaderT LetEnv (Parsec CustomParserException Text) LetMacro
letMacro Parser ParsedOp
opParser = ReaderT LetEnv (Parsec CustomParserException Text) LetMacro
-> ReaderT LetEnv (Parsec CustomParserException Text) LetMacro
forall a. Parser a -> Parser a
lexeme (ReaderT LetEnv (Parsec CustomParserException Text) LetMacro
 -> ReaderT LetEnv (Parsec CustomParserException Text) LetMacro)
-> ReaderT LetEnv (Parsec CustomParserException Text) LetMacro
-> ReaderT LetEnv (Parsec CustomParserException Text) LetMacro
forall a b. (a -> b) -> a -> b
$ do
  Text
n <- Parser Text -> Parser Text
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ do
    Text
n <- Parser Char -> Parser Text
letName Parser Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
lowerChar
    Tokens Text -> Parser ()
symbol Tokens Text
"::"
    return Text
n
  StackFn
s <- Parser StackFn
stackFn
  Tokens Text -> Parser ()
symbol Tokens Text
"="
  [ParsedOp]
o <- Parser ParsedOp -> Parser [ParsedOp]
ops' Parser ParsedOp
opParser
  return $ Text -> StackFn -> [ParsedOp] -> LetMacro
LetMacro Text
n StackFn
s [ParsedOp]
o

letType :: Parser LetType
letType :: ReaderT LetEnv (Parsec CustomParserException Text) LetType
letType = ReaderT LetEnv (Parsec CustomParserException Text) LetType
-> ReaderT LetEnv (Parsec CustomParserException Text) LetType
forall a. Parser a -> Parser a
lexeme (ReaderT LetEnv (Parsec CustomParserException Text) LetType
 -> ReaderT LetEnv (Parsec CustomParserException Text) LetType)
-> ReaderT LetEnv (Parsec CustomParserException Text) LetType
-> ReaderT LetEnv (Parsec CustomParserException Text) LetType
forall a b. (a -> b) -> a -> b
$ do
  Text
n <- Parser Text -> Parser Text
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ do
    Tokens Text -> Parser ()
symbol Tokens Text
"type"
    Text
n <- Parser Char -> Parser Text
letName Parser Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
upperChar Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char -> Parser Text
letName Parser Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
lowerChar
    Tokens Text -> Parser ()
symbol Tokens Text
"="
    return Text
n
  t :: Ty
t@(Ty T
t' TypeAnn
a) <- Parser 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 (Parsec CustomParserException Text) LetType
forall (m :: * -> *) a. Monad m => a -> m a
return (LetType
 -> ReaderT LetEnv (Parsec CustomParserException Text) LetType)
-> LetType
-> ReaderT LetEnv (Parsec CustomParserException Text) 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 (Parsec CustomParserException Text) LetType
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
 -> ReaderT LetEnv (Parsec CustomParserException Text) LetType)
-> [Char]
-> ReaderT LetEnv (Parsec CustomParserException Text) LetType
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
forall a. ToString a => a -> [Char]
toString Text
err
    else LetType
-> ReaderT LetEnv (Parsec CustomParserException Text) LetType
forall (m :: * -> *) a. Monad m => a -> m a
return (LetType
 -> ReaderT LetEnv (Parsec CustomParserException Text) LetType)
-> LetType
-> ReaderT LetEnv (Parsec CustomParserException Text) LetType
forall a b. (a -> b) -> a -> b
$ Text -> Ty -> LetType
LetType Text
n Ty
t

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

mkLetMac :: Map Text LetMacro -> Parser LetMacro
mkLetMac :: Map Text LetMacro
-> ReaderT LetEnv (Parsec CustomParserException Text) LetMacro
mkLetMac Map Text LetMacro
lms = [ReaderT LetEnv (Parsec CustomParserException Text) LetMacro]
-> ReaderT LetEnv (Parsec CustomParserException Text) LetMacro
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([ReaderT LetEnv (Parsec CustomParserException Text) LetMacro]
 -> ReaderT LetEnv (Parsec CustomParserException Text) LetMacro)
-> [ReaderT LetEnv (Parsec CustomParserException Text) LetMacro]
-> ReaderT LetEnv (Parsec CustomParserException Text) LetMacro
forall a b. (a -> b) -> a -> b
$ (LetMacro -> Text)
-> LetMacro
-> ReaderT LetEnv (Parsec CustomParserException Text) LetMacro
forall a. (a -> Text) -> a -> Parser a
mkParser LetMacro -> Text
lmName (LetMacro
 -> ReaderT LetEnv (Parsec CustomParserException Text) LetMacro)
-> [LetMacro]
-> [ReaderT LetEnv (Parsec CustomParserException Text) 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 StackFn
stackFn :: Parser StackFn
stackFn = do
  Maybe [Var]
vs <- (ReaderT LetEnv (Parsec CustomParserException Text) [Var]
-> ReaderT LetEnv (Parsec CustomParserException Text) (Maybe [Var])
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Tokens Text -> Parser ()
symbol Tokens Text
"forall" Parser ()
-> ReaderT LetEnv (Parsec CustomParserException Text) [Var]
-> ReaderT LetEnv (Parsec CustomParserException Text) [Var]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReaderT LetEnv (Parsec CustomParserException Text) Var
-> ReaderT LetEnv (Parsec CustomParserException Text) [Var]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ReaderT LetEnv (Parsec CustomParserException Text) Var
varID ReaderT LetEnv (Parsec CustomParserException Text) [Var]
-> Parser ()
-> ReaderT LetEnv (Parsec CustomParserException Text) [Var]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text -> Parser ()
symbol Tokens Text
"."))
  StackTypePattern
a <- Parser StackTypePattern
stackType
  Tokens Text -> Parser ()
symbol Tokens Text
"->"
  StackTypePattern
b <- Parser 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