{-# OPTIONS_GHC -Wno-deprecations #-}
module Morley.Michelson.Parser.Let
( letBlock
, mkLetMac
, 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)
data Let = LetM LetMacro | LetV LetValue | LetT LetType
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
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)
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)
]
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