-- 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(..), Type(..), ann, 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 opParser :: Parser ParsedOp
opParser = do
  Tokens Text -> Parser ()
symbol "let"
  Tokens Text -> Parser ()
symbol "{"
  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 "}"
  Parser ()
semicolon
  return LetEnv
ls

-- | Incrementally build the let environment
letInner :: Parser ParsedOp -> Parser LetEnv
letInner :: Parser ParsedOp -> Parser LetEnv
letInner opParser :: 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 l :: Let
l (LetEnv lms :: Map Text LetMacro
lms lvs :: Map Text LetValue
lvs lts :: Map Text LetType
lts) = case Let
l of
  LetM lm :: 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 lv :: 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 lt :: 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 opParser :: 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 p :: 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
  let validChar :: Char -> Bool
validChar x :: Char
x = Char -> Bool
Char.isAscii Char
x Bool -> Bool -> Bool
&& (Char -> Bool
Char.isAlphaNum Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\'' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_')
  [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 opParser :: 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 "::"
    return Text
n
  StackFn
s <- Parser StackFn
stackFn
  Tokens Text -> Parser ()
symbol "="
  [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 "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 "="
    return Text
n
  t :: Type
t@(Type t' :: T
t' a :: TypeAnn
a) <- Parser Type
type_
  return $ if TypeAnn
a TypeAnn -> TypeAnn -> Bool
forall a. Eq a => a -> a -> Bool
== TypeAnn
forall k (a :: k). Annotation a
noAnn
    then Text -> Type -> LetType
LetType Text
n (T -> TypeAnn -> Type
Type T
t' (Text -> TypeAnn
forall k (a :: k). HasCallStack => Text -> Annotation a
ann Text
n))
    else Text -> Type -> LetType
LetType Text
n Type
t

letValue :: Parser ParsedOp -> Parser LetValue
letValue :: Parser ParsedOp
-> ReaderT LetEnv (Parsec CustomParserException Text) LetValue
letValue opParser :: 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 "::"
    return Text
n
  Type
t <- Parser Type
type_
  Tokens Text -> Parser ()
symbol "="
  ParsedValue
v <- Parser ParsedOp -> Parser ParsedValue
value' Parser ParsedOp
opParser
  return $ Text -> Type -> ParsedValue -> LetValue
LetValue Text
n Type
t ParsedValue
v

mkLetMac :: Map Text LetMacro -> Parser LetMacro
mkLetMac :: Map Text LetMacro
-> ReaderT LetEnv (Parsec CustomParserException Text) LetMacro
mkLetMac lms :: 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 "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 "."))
  StackTypePattern
a <- Parser StackTypePattern
stackType
  Tokens Text -> Parser ()
symbol "->"
  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