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

-- | Parsing of Michelson types.

module Michelson.Parser.Type
  ( type_
  , typeWithParen
  , field
  ) where

import Prelude hiding (note, some, try)

import Data.Default (Default, def)
import qualified Data.Map as Map
import Fmt (pretty)
import Text.Megaparsec (choice, customFailure, sepBy)

import Michelson.Let (LetType(..))
import Michelson.Parser.Annotations
import Michelson.Parser.Error
import Michelson.Parser.Helpers
import Michelson.Parser.Lexer
import Michelson.Parser.Types (Parser, letTypes)
import Michelson.Untyped
import Util.Generic

type_ :: Parser Type
type_ :: Parser Type
type_ = (FieldAnn, Type) -> Type
forall a b. (a, b) -> b
snd ((FieldAnn, Type) -> Type)
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
-> Parser Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
typeInner (FieldAnn -> Parser FieldAnn
forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldAnn
forall k (a :: k). Annotation a
noAnn)

field :: Parser (FieldAnn, Type)
field :: ReaderT LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
field = Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
typeInner Parser FieldAnn
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note

t_operator :: Parser FieldAnn -> Parser (FieldAnn, Type)
t_operator :: Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
t_operator fp :: Parser FieldAnn
fp = do
  Maybe ((FieldAnn, Type), Maybe (Bool, [(FieldAnn, Type)]))
whole <- Parser (Maybe ((FieldAnn, Type), Maybe (Bool, [(FieldAnn, Type)])))
-> Parser
     (Maybe ((FieldAnn, Type), Maybe (Bool, [(FieldAnn, Type)])))
forall a. Parser a -> Parser a
parens do
    ReaderT
  LetEnv
  (Parsec CustomParserException Text)
  ((FieldAnn, Type), Maybe (Bool, [(FieldAnn, Type)]))
-> Parser
     (Maybe ((FieldAnn, Type), Maybe (Bool, [(FieldAnn, Type)])))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional do
      (FieldAnn, Type)
ty   <- ReaderT LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
field
      Maybe (Bool, [(FieldAnn, Type)])
rest <- ReaderT
  LetEnv
  (Parsec CustomParserException Text)
  (Bool, [(FieldAnn, Type)])
-> ReaderT
     LetEnv
     (Parsec CustomParserException Text)
     (Maybe (Bool, [(FieldAnn, Type)]))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional do
        Bool
isOr <- (Text -> Parser ()
symbol' "|" Parser ()
-> ReaderT LetEnv (Parsec CustomParserException Text) Bool
-> ReaderT LetEnv (Parsec CustomParserException Text) Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> ReaderT LetEnv (Parsec CustomParserException Text) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
            ReaderT LetEnv (Parsec CustomParserException Text) Bool
-> ReaderT LetEnv (Parsec CustomParserException Text) Bool
-> ReaderT LetEnv (Parsec CustomParserException Text) Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Parser ()
symbol' "," Parser ()
-> ReaderT LetEnv (Parsec CustomParserException Text) Bool
-> ReaderT LetEnv (Parsec CustomParserException Text) Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> ReaderT LetEnv (Parsec CustomParserException Text) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
        [(FieldAnn, Type)]
others <- ReaderT LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
field ReaderT LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
-> Parser ()
-> ReaderT
     LetEnv (Parsec CustomParserException Text) [(FieldAnn, Type)]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy` Text -> Parser ()
symbol' if Bool
isOr then "|" else ","
        return (Bool
isOr, [(FieldAnn, Type)]
others)
      return ((FieldAnn, Type)
ty, Maybe (Bool, [(FieldAnn, Type)])
rest)

  (f :: FieldAnn
f, t :: TypeAnn
t) <- Parser FieldAnn -> Parser (FieldAnn, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser FieldAnn
fp
  case Maybe ((FieldAnn, Type), Maybe (Bool, [(FieldAnn, Type)]))
whole of
    Just (ty :: (FieldAnn, Type)
ty, Just (isOr :: Bool
isOr, tys :: [(FieldAnn, Type)]
tys)) -> do
      let (f' :: FieldAnn
f', Type ty' :: T
ty' _) = (Natural
 -> (FieldAnn, Type) -> (FieldAnn, Type) -> (FieldAnn, Type))
-> NonEmpty (FieldAnn, Type) -> (FieldAnn, Type)
forall a. (Natural -> a -> a -> a) -> NonEmpty a -> a
mkGenericTree (Bool
-> Natural
-> (FieldAnn, Type)
-> (FieldAnn, Type)
-> (FieldAnn, Type)
forall k p (a :: k).
Bool
-> p
-> (FieldAnn, Type)
-> (FieldAnn, Type)
-> (Annotation a, Type)
mergeTwo Bool
isOr) ((FieldAnn, Type)
ty (FieldAnn, Type) -> [(FieldAnn, Type)] -> NonEmpty (FieldAnn, Type)
forall a. a -> [a] -> NonEmpty a
:| [(FieldAnn, Type)]
tys)
      FieldAnn
f'' <- FieldAnn -> FieldAnn -> Parser FieldAnn
forall a (m :: * -> *) s.
(Default a, MonadParsec CustomParserException s m, Eq a) =>
a -> a -> m a
mergeAnnots FieldAnn
f FieldAnn
f'
      return (FieldAnn
f'', T -> TypeAnn -> Type
Type T
ty' TypeAnn
t)
    Just (res :: (FieldAnn, Type)
res, _) -> do
      (FieldAnn, Type)
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldAnn, Type)
res
    Nothing -> do
      (FieldAnn, Type)
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldAnn
f, T -> TypeAnn -> Type
Type T
TUnit TypeAnn
t)
  where
    mergeTwo :: Bool
-> p
-> (FieldAnn, Type)
-> (FieldAnn, Type)
-> (Annotation a, Type)
mergeTwo isOr :: Bool
isOr _ (l :: FieldAnn
l, a :: Type
a) (r :: FieldAnn
r, b :: Type
b) =
      (Annotation a
forall k (a :: k). Annotation a
noAnn, T -> TypeAnn -> Type
Type ((if Bool
isOr then FieldAnn -> FieldAnn -> Type -> Type -> T
TOr else FieldAnn -> FieldAnn -> Type -> Type -> T
TPair) FieldAnn
l FieldAnn
r Type
a Type
b) TypeAnn
forall k (a :: k). Annotation a
noAnn)

    mergeAnnots :: a -> a -> m a
mergeAnnots l :: a
l r :: a
r
      | a
l a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Default a => a
def  = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
      | a
r a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Default a => a
def  = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
l
      | Bool
otherwise = CustomParserException -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure CustomParserException
ExcessFieldAnnotation

typeInner
  :: Parser FieldAnn -> Parser (FieldAnn, Type)
typeInner :: Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
typeInner fp :: Parser FieldAnn
fp = ReaderT LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Parser a -> Parser a
lexeme (ReaderT
   LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
 -> ReaderT
      LetEnv (Parsec CustomParserException Text) (FieldAnn, Type))
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a b. (a -> b) -> a -> b
$ [ReaderT
   LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)]
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([ReaderT
    LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)]
 -> ReaderT
      LetEnv (Parsec CustomParserException Text) (FieldAnn, Type))
-> [ReaderT
      LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)]
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a b. (a -> b) -> a -> b
$ (\x :: Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
x -> Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
x Parser FieldAnn
fp) ((Parser FieldAnn
  -> ReaderT
       LetEnv (Parsec CustomParserException Text) (FieldAnn, Type))
 -> ReaderT
      LetEnv (Parsec CustomParserException Text) (FieldAnn, Type))
-> [Parser FieldAnn
    -> ReaderT
         LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)]
-> [ReaderT
      LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  [ Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_int, Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_nat, Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_string, Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_bytes, Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_mutez, Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_bool
  , Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_keyhash, Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_timestamp, Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_address
  , Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_key, Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_unit, Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_signature, Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_chain_id
  , Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_option, Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_list, Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_set
  , Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_operation, Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_contract, Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_pair, Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_or
  , Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_lambda, Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_map, Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_big_map, Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_view
  , Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_void, Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a. Default a => Parser a -> Parser (a, Type)
t_letType
  , Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
t_operator
  , ReaderT LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
-> Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall a b. a -> b -> a
const (CustomParserException
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure CustomParserException
UnknownTypeException)
  ]

----------------------------------------------------------------------------
-- Comparable types
----------------------------------------------------------------------------

typeWithParen :: Parser Type
typeWithParen :: Parser Type
typeWithParen = Parser Type -> Parser Type
forall a. Parser a -> Parser a
mparens Parser Type
type_

----------------------------------------------------------------------------
-- Non-comparable types
----------------------------------------------------------------------------

mkType :: T -> (a, TypeAnn) -> (a, Type)
mkType :: T -> (a, TypeAnn) -> (a, Type)
mkType t :: T
t (a :: a
a, ta :: TypeAnn
ta) = (a
a, T -> TypeAnn -> Type
Type T
t TypeAnn
ta)


t_int :: (Default a) => Parser a -> Parser (a, Type)
t_int :: Parser a -> Parser (a, Type)
t_int fp :: Parser a
fp = Tokens Text
-> ((a, TypeAnn) -> (a, Type))
-> Parser ((a, TypeAnn) -> (a, Type))
forall a. Tokens Text -> a -> Parser a
word' "Int" (T -> (a, TypeAnn) -> (a, Type)
forall a. T -> (a, TypeAnn) -> (a, Type)
mkType T
TInt) Parser ((a, TypeAnn) -> (a, Type))
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
-> Parser (a, Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp

t_nat :: (Default a) => Parser a -> Parser (a, Type)
t_nat :: Parser a -> Parser (a, Type)
t_nat fp :: Parser a
fp = Tokens Text
-> ((a, TypeAnn) -> (a, Type))
-> Parser ((a, TypeAnn) -> (a, Type))
forall a. Tokens Text -> a -> Parser a
word' "Nat" (T -> (a, TypeAnn) -> (a, Type)
forall a. T -> (a, TypeAnn) -> (a, Type)
mkType T
TNat) Parser ((a, TypeAnn) -> (a, Type))
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
-> Parser (a, Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp

t_string :: (Default a) => Parser a -> Parser (a, Type)
t_string :: Parser a -> Parser (a, Type)
t_string fp :: Parser a
fp = Tokens Text
-> ((a, TypeAnn) -> (a, Type))
-> Parser ((a, TypeAnn) -> (a, Type))
forall a. Tokens Text -> a -> Parser a
word' "String" (T -> (a, TypeAnn) -> (a, Type)
forall a. T -> (a, TypeAnn) -> (a, Type)
mkType T
TString) Parser ((a, TypeAnn) -> (a, Type))
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
-> Parser (a, Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp

t_bytes :: (Default a) => Parser a -> Parser (a, Type)
t_bytes :: Parser a -> Parser (a, Type)
t_bytes fp :: Parser a
fp = Tokens Text
-> ((a, TypeAnn) -> (a, Type))
-> Parser ((a, TypeAnn) -> (a, Type))
forall a. Tokens Text -> a -> Parser a
word' "Bytes" (T -> (a, TypeAnn) -> (a, Type)
forall a. T -> (a, TypeAnn) -> (a, Type)
mkType T
TBytes) Parser ((a, TypeAnn) -> (a, Type))
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
-> Parser (a, Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp

t_mutez :: (Default a) => Parser a -> Parser (a, Type)
t_mutez :: Parser a -> Parser (a, Type)
t_mutez fp :: Parser a
fp = Tokens Text
-> ((a, TypeAnn) -> (a, Type))
-> Parser ((a, TypeAnn) -> (a, Type))
forall a. Tokens Text -> a -> Parser a
word' "Mutez" (T -> (a, TypeAnn) -> (a, Type)
forall a. T -> (a, TypeAnn) -> (a, Type)
mkType T
TMutez) Parser ((a, TypeAnn) -> (a, Type))
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
-> Parser (a, Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp

t_bool :: (Default a) => Parser a -> Parser (a, Type)
t_bool :: Parser a -> Parser (a, Type)
t_bool fp :: Parser a
fp = Tokens Text
-> ((a, TypeAnn) -> (a, Type))
-> Parser ((a, TypeAnn) -> (a, Type))
forall a. Tokens Text -> a -> Parser a
word' "Bool" (T -> (a, TypeAnn) -> (a, Type)
forall a. T -> (a, TypeAnn) -> (a, Type)
mkType T
TBool) Parser ((a, TypeAnn) -> (a, Type))
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
-> Parser (a, Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp

t_keyhash :: (Default a) => Parser a -> Parser (a, Type)
t_keyhash :: Parser a -> Parser (a, Type)
t_keyhash fp :: Parser a
fp = ((Tokens Text
-> ((a, TypeAnn) -> (a, Type))
-> Parser ((a, TypeAnn) -> (a, Type))
forall a. Tokens Text -> a -> Parser a
word' "KeyHash" (T -> (a, TypeAnn) -> (a, Type)
forall a. T -> (a, TypeAnn) -> (a, Type)
mkType T
TKeyHash)) Parser ((a, TypeAnn) -> (a, Type))
-> Parser ((a, TypeAnn) -> (a, Type))
-> Parser ((a, TypeAnn) -> (a, Type))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Tokens Text
-> ((a, TypeAnn) -> (a, Type))
-> Parser ((a, TypeAnn) -> (a, Type))
forall a. Tokens Text -> a -> Parser a
word "key_hash" (T -> (a, TypeAnn) -> (a, Type)
forall a. T -> (a, TypeAnn) -> (a, Type)
mkType T
TKeyHash))) Parser ((a, TypeAnn) -> (a, Type))
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
-> Parser (a, Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp

t_timestamp :: (Default a) => Parser a -> Parser (a, Type)
t_timestamp :: Parser a -> Parser (a, Type)
t_timestamp fp :: Parser a
fp = Tokens Text
-> ((a, TypeAnn) -> (a, Type))
-> Parser ((a, TypeAnn) -> (a, Type))
forall a. Tokens Text -> a -> Parser a
word' "Timestamp" (T -> (a, TypeAnn) -> (a, Type)
forall a. T -> (a, TypeAnn) -> (a, Type)
mkType T
TTimestamp) Parser ((a, TypeAnn) -> (a, Type))
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
-> Parser (a, Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp

t_address :: (Default a) => Parser a -> Parser (a, Type)
t_address :: Parser a -> Parser (a, Type)
t_address fp :: Parser a
fp = Tokens Text
-> ((a, TypeAnn) -> (a, Type))
-> Parser ((a, TypeAnn) -> (a, Type))
forall a. Tokens Text -> a -> Parser a
word' "Address" (T -> (a, TypeAnn) -> (a, Type)
forall a. T -> (a, TypeAnn) -> (a, Type)
mkType T
TAddress) Parser ((a, TypeAnn) -> (a, Type))
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
-> Parser (a, Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp

t_key :: (Default a) => Parser a -> Parser (a, Type)
t_key :: Parser a -> Parser (a, Type)
t_key fp :: Parser a
fp = Tokens Text
-> ((a, TypeAnn) -> (a, Type))
-> Parser ((a, TypeAnn) -> (a, Type))
forall a. Tokens Text -> a -> Parser a
word' "Key" (T -> (a, TypeAnn) -> (a, Type)
forall a. T -> (a, TypeAnn) -> (a, Type)
mkType T
TKey) Parser ((a, TypeAnn) -> (a, Type))
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
-> Parser (a, Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp

t_signature :: (Default a) => Parser a -> Parser (a, Type)
t_signature :: Parser a -> Parser (a, Type)
t_signature fp :: Parser a
fp = Tokens Text
-> ((a, TypeAnn) -> (a, Type))
-> Parser ((a, TypeAnn) -> (a, Type))
forall a. Tokens Text -> a -> Parser a
word' "Signature" (T -> (a, TypeAnn) -> (a, Type)
forall a. T -> (a, TypeAnn) -> (a, Type)
mkType T
TSignature) Parser ((a, TypeAnn) -> (a, Type))
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
-> Parser (a, Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp

t_chain_id :: (Default a) => Parser a -> Parser (a, Type)
t_chain_id :: Parser a -> Parser (a, Type)
t_chain_id fp :: Parser a
fp = do
  Text -> Parser ()
symbol' "ChainId" Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser ()
symbol' "chain_id"
  T -> (a, TypeAnn) -> (a, Type)
forall a. T -> (a, TypeAnn) -> (a, Type)
mkType T
TChainId ((a, TypeAnn) -> (a, Type))
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
-> Parser (a, Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp

t_operation :: (Default a) => Parser a -> Parser (a, Type)
t_operation :: Parser a -> Parser (a, Type)
t_operation fp :: Parser a
fp = Tokens Text
-> ((a, TypeAnn) -> (a, Type))
-> Parser ((a, TypeAnn) -> (a, Type))
forall a. Tokens Text -> a -> Parser a
word' "Operation" (T -> (a, TypeAnn) -> (a, Type)
forall a. T -> (a, TypeAnn) -> (a, Type)
mkType T
TOperation) Parser ((a, TypeAnn) -> (a, Type))
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
-> Parser (a, Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
-> ReaderT LetEnv (Parsec CustomParserException Text) (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp

t_contract :: (Default a) => Parser a -> Parser (a, Type)
t_contract :: Parser a -> Parser (a, Type)
t_contract fp :: Parser a
fp = do
  Text -> Parser ()
symbol' "Contract"
  (f :: a
f, t :: TypeAnn
t) <- Parser a -> Parser (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp
  Type
a <- Parser Type
type_
  return (a
f, T -> TypeAnn -> Type
Type (Type -> T
TContract Type
a) TypeAnn
t)

t_unit :: (Default a) => Parser a -> Parser (a, Type)
t_unit :: Parser a -> Parser (a, Type)
t_unit fp :: Parser a
fp = do
  Text -> Parser ()
symbol' "Unit" Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser ()
symbol' "()"
  (f :: a
f,t :: TypeAnn
t) <- Parser a -> Parser (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp
  return (a
f, T -> TypeAnn -> Type
Type T
TUnit TypeAnn
t)

t_pair :: (Default a) => Parser a -> Parser (a, Type)
t_pair :: Parser a -> Parser (a, Type)
t_pair fp :: Parser a
fp = do
  Text -> Parser ()
symbol' "Pair"
  (fieldAnn :: a
fieldAnn, typeAnn :: TypeAnn
typeAnn) <- Parser a -> Parser (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp
  [(FieldAnn, Type)]
fields <- ReaderT LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
-> ReaderT
     LetEnv (Parsec CustomParserException Text) [(FieldAnn, Type)]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ReaderT LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
field
  T
tPair <- [(FieldAnn, Type)] -> Parser T
go [(FieldAnn, Type)]
fields
  pure $ (a
fieldAnn, T -> TypeAnn -> Type
Type T
tPair TypeAnn
typeAnn)
  where
    go :: [(FieldAnn, Type)] -> Parser T
    go :: [(FieldAnn, Type)] -> Parser T
go = \case
      [] -> String -> Parser T
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "The 'pair' type expects at least 2 type arguments, but 0 were given."
      [(_, t :: Type
t)] -> String -> Parser T
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser T) -> String -> Parser T
forall a b. (a -> b) -> a -> b
$ "The 'pair' type expects at least 2 type arguments, but only 1 was given: '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty Type
t String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "'."
      [(fieldAnnL :: FieldAnn
fieldAnnL, typeL :: Type
typeL), (fieldAnnR :: FieldAnn
fieldAnnR, typeR :: Type
typeR)] ->
        T -> Parser T
forall (f :: * -> *) a. Applicative f => a -> f a
pure (T -> Parser T) -> T -> Parser T
forall a b. (a -> b) -> a -> b
$ FieldAnn -> FieldAnn -> Type -> Type -> T
TPair FieldAnn
fieldAnnL FieldAnn
fieldAnnR Type
typeL Type
typeR
      (fieldAnnL :: FieldAnn
fieldAnnL, typeL :: Type
typeL) : fields :: [(FieldAnn, Type)]
fields -> do
        T
rightCombedT <- [(FieldAnn, Type)] -> Parser T
go [(FieldAnn, Type)]
fields
        pure $ FieldAnn -> FieldAnn -> Type -> Type -> T
TPair FieldAnn
fieldAnnL FieldAnn
forall k (a :: k). Annotation a
noAnn Type
typeL (T -> TypeAnn -> Type
Type T
rightCombedT TypeAnn
forall k (a :: k). Annotation a
noAnn)

t_or :: (Default a) => Parser a -> Parser (a, Type)
t_or :: Parser a -> Parser (a, Type)
t_or fp :: Parser a
fp = do
  Text -> Parser ()
symbol' "Or"
  (f :: a
f, t :: TypeAnn
t) <- Parser a -> Parser (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp
  (l :: FieldAnn
l, a :: Type
a) <- ReaderT LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
field
  (r :: FieldAnn
r, b :: Type
b) <- ReaderT LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
field
  return (a
f, T -> TypeAnn -> Type
Type (FieldAnn -> FieldAnn -> Type -> Type -> T
TOr FieldAnn
l FieldAnn
r Type
a Type
b) TypeAnn
t)

t_option :: (Default a) => Parser a -> Parser (a, Type)
t_option :: Parser a -> Parser (a, Type)
t_option fp :: Parser a
fp = do
  Text -> Parser ()
symbol' "Option"
  (f :: a
f, t :: TypeAnn
t) <- Parser a -> Parser (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp
  Type
a <- Parser Type -> Parser Type
forall a. Parser a -> Parser a
mparens (Parser Type -> Parser Type) -> Parser Type -> Parser Type
forall a b. (a -> b) -> a -> b
$ (FieldAnn, Type) -> Type
forall a b. (a, b) -> b
snd ((FieldAnn, Type) -> Type)
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
-> Parser Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser FieldAnn
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (FieldAnn, Type)
typeInner (FieldAnn -> Parser FieldAnn
forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldAnn
forall k (a :: k). Annotation a
noAnn)
  return (a
f, T -> TypeAnn -> Type
Type (Type -> T
TOption Type
a) TypeAnn
t)

t_lambda :: (Default a) => Parser a -> Parser (a, Type)
t_lambda :: Parser a -> Parser (a, Type)
t_lambda fp :: Parser a
fp = Parser (a, Type)
core Parser (a, Type) -> Parser (a, Type) -> Parser (a, Type)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (a, Type)
slashLambda
  where
    core :: Parser (a, Type)
core = do
      Text -> Parser ()
symbol' "Lambda"
      (f :: a
f, t :: TypeAnn
t) <- Parser a -> Parser (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp
      Type
a <- Parser Type
type_
      Type
b <- Parser Type
type_
      return (a
f, T -> TypeAnn -> Type
Type (Type -> Type -> T
TLambda Type
a Type
b) TypeAnn
t)
    slashLambda :: Parser (a, Type)
slashLambda = do
      Tokens Text -> Parser ()
symbol "\\"
      (f :: a
f, t :: TypeAnn
t) <- Parser a -> Parser (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp
      Type
a <- Parser Type
type_
      Tokens Text -> Parser ()
symbol "->"
      Type
b <- Parser Type
type_
      return (a
f, T -> TypeAnn -> Type
Type (Type -> Type -> T
TLambda Type
a Type
b) TypeAnn
t)

-- Container types
t_list :: (Default a) => Parser a -> Parser (a, Type)
t_list :: Parser a -> Parser (a, Type)
t_list fp :: Parser a
fp = Parser (a, Type)
core Parser (a, Type) -> Parser (a, Type) -> Parser (a, Type)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (a, Type)
bracketList
  where
    core :: Parser (a, Type)
core = do
      Text -> Parser ()
symbol' "List"
      (f :: a
f, t :: TypeAnn
t) <- Parser a -> Parser (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp
      Type
a <- Parser Type
type_
      return (a
f, T -> TypeAnn -> Type
Type (Type -> T
TList Type
a) TypeAnn
t)
    bracketList :: Parser (a, Type)
bracketList = do
      Type
a <- Parser Type -> Parser Type
forall a. Parser a -> Parser a
brackets Parser Type
type_
      (f :: a
f, t :: TypeAnn
t) <- Parser a -> Parser (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp
      return (a
f, T -> TypeAnn -> Type
Type (Type -> T
TList Type
a) TypeAnn
t)

t_set :: (Default a) => Parser a -> Parser (a, Type)
t_set :: Parser a -> Parser (a, Type)
t_set fp :: Parser a
fp = Parser (a, Type)
core Parser (a, Type) -> Parser (a, Type) -> Parser (a, Type)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (a, Type)
braceSet
  where
    core :: Parser (a, Type)
core = do
      Text -> Parser ()
symbol' "Set"
      (f :: a
f, t :: TypeAnn
t) <- Parser a -> Parser (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp
      Type
a <- Parser Type
typeWithParen
      return (a
f, T -> TypeAnn -> Type
Type (Type -> T
TSet Type
a) TypeAnn
t)
    braceSet :: Parser (a, Type)
braceSet = do
      Type
a <- Parser Type -> Parser Type
forall a. Parser a -> Parser a
braces Parser Type
typeWithParen
      (f :: a
f, t :: TypeAnn
t) <- Parser a -> Parser (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp
      return (a
f, T -> TypeAnn -> Type
Type (Type -> T
TSet Type
a) TypeAnn
t)

t_map_like
  :: Default a
  => Parser a -> Parser (Type, Type, a, TypeAnn)
t_map_like :: Parser a -> Parser (Type, Type, a, TypeAnn)
t_map_like fp :: Parser a
fp = do
  (f :: a
f, t :: TypeAnn
t) <- Parser a -> Parser (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp
  Type
a <- Parser Type
typeWithParen
  Type
b <- Parser Type
type_
  return (Type
a, Type
b, a
f, TypeAnn
t)

t_map :: (Default a) => Parser a -> Parser (a, Type)
t_map :: Parser a -> Parser (a, Type)
t_map fp :: Parser a
fp = do
  Text -> Parser ()
symbol' "Map"
  (a :: Type
a, b :: Type
b, f :: a
f, t :: TypeAnn
t) <- Parser a -> Parser (Type, Type, a, TypeAnn)
forall a. Default a => Parser a -> Parser (Type, Type, a, TypeAnn)
t_map_like Parser a
fp
  return (a
f, T -> TypeAnn -> Type
Type (Type -> Type -> T
TMap Type
a Type
b) TypeAnn
t)

t_big_map :: (Default a) => Parser a -> Parser (a, Type)
t_big_map :: Parser a -> Parser (a, Type)
t_big_map fp :: Parser a
fp = do
  Text -> Parser ()
symbol' "BigMap" Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text -> Parser ()
symbol "big_map"
  (a :: Type
a, b :: Type
b, f :: a
f, t :: TypeAnn
t) <- Parser a -> Parser (Type, Type, a, TypeAnn)
forall a. Default a => Parser a -> Parser (Type, Type, a, TypeAnn)
t_map_like Parser a
fp
  return (a
f, T -> TypeAnn -> Type
Type (Type -> Type -> T
TBigMap Type
a Type
b) TypeAnn
t)

----------------------------------------------------------------------------
-- Non-standard types (Morley extensions)
----------------------------------------------------------------------------

t_view :: Default a => Parser a -> Parser (a, Type)
t_view :: Parser a -> Parser (a, Type)
t_view fp :: Parser a
fp = do
  Text -> Parser ()
symbol' "View"
  Type
a <- Parser Type
type_
  Type
r <- Parser Type
type_
  (f :: a
f, t :: TypeAnn
t) <- Parser a -> Parser (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp
  let c' :: Type
c' = T -> TypeAnn -> Type
Type (Type -> T
TContract Type
r) TypeAnn
forall k (a :: k). Annotation a
noAnn
  return (a
f, T -> TypeAnn -> Type
Type (FieldAnn -> FieldAnn -> Type -> Type -> T
TPair FieldAnn
forall k (a :: k). Annotation a
noAnn FieldAnn
forall k (a :: k). Annotation a
noAnn Type
a Type
c') TypeAnn
t)

t_void :: Default a => Parser a -> Parser (a, Type)
t_void :: Parser a -> Parser (a, Type)
t_void fp :: Parser a
fp = do
  Text -> Parser ()
symbol' "Void"
  Type
a <- Parser Type
type_
  Type
b <- Parser Type
type_
  (f :: a
f, t :: TypeAnn
t) <- Parser a -> Parser (a, TypeAnn)
forall a. Default a => Parser a -> Parser (a, TypeAnn)
fieldType Parser a
fp
  let c :: Type
c = T -> TypeAnn -> Type
Type (Type -> Type -> T
TLambda Type
b Type
b) TypeAnn
forall k (a :: k). Annotation a
noAnn
  return (a
f, T -> TypeAnn -> Type
Type (FieldAnn -> FieldAnn -> Type -> Type -> T
TPair FieldAnn
forall k (a :: k). Annotation a
noAnn FieldAnn
forall k (a :: k). Annotation a
noAnn Type
a Type
c) TypeAnn
t)

t_letType :: Default fp => Parser fp -> Parser (fp, Type)
t_letType :: Parser fp -> Parser (fp, Type)
t_letType fp :: Parser fp
fp = do
  Map Text LetType
lts <- (LetEnv -> Map Text LetType)
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (Map Text LetType)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks LetEnv -> Map Text LetType
letTypes
  Type
lt <- LetType -> Type
ltSig (LetType -> Type)
-> ReaderT LetEnv (Parsec CustomParserException Text) LetType
-> Parser Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Map Text LetType
-> ReaderT LetEnv (Parsec CustomParserException Text) LetType
mkLetType Map Text LetType
lts)
  fp
f <- Parser fp -> Parser fp
forall a. Default a => Parser a -> Parser a
parseDef Parser fp
fp
  return (fp
f, Type
lt)

mkLetType :: Map Text LetType -> Parser LetType
mkLetType :: Map Text LetType
-> ReaderT LetEnv (Parsec CustomParserException Text) LetType
mkLetType lts :: Map Text LetType
lts = [ReaderT LetEnv (Parsec CustomParserException Text) LetType]
-> ReaderT LetEnv (Parsec CustomParserException Text) LetType
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([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
$ (LetType -> Text)
-> LetType
-> ReaderT LetEnv (Parsec CustomParserException Text) LetType
forall a. (a -> Text) -> a -> Parser a
mkParser LetType -> Text
ltName (LetType
 -> ReaderT LetEnv (Parsec CustomParserException Text) LetType)
-> [LetType]
-> [ReaderT LetEnv (Parsec CustomParserException Text) LetType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Map Text LetType -> [LetType]
forall k a. Map k a -> [a]
Map.elems Map Text LetType
lts)