-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

module Morley.Michelson.Parser.Annotations
  ( note
  , noteF
  , noteV
  , noteDef
  , noteV2Def
  , notesTVF
  , notesTVF2Def
  , notesVVFF
  , notesTV
  , notesTF
  , notesVF
  , fieldType
  , permute2Def
  , permute3Def
  ) where

import Prelude hiding (note)

import Control.Applicative.Permutations (runPermutation, toPermutationWithDefault)
import Data.Text qualified as T
import Text.Megaparsec (satisfy, takeWhileP)
import Text.Megaparsec.Char (string)

import Morley.Michelson.Parser.Helpers (parseDef)
import Morley.Michelson.Parser.Lexer
import Morley.Michelson.Parser.Types (Parser)
import Morley.Michelson.Untyped.Annotation
import Morley.Util.Default

-- | General T/V/F Annotation parser, including Special Annotations
note :: forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
note :: Parser' le (Annotation tag)
note = Parser le (Annotation tag) -> Parser le (Annotation tag)
forall le a. Parser le a -> Parser le a
lexeme (Parser le (Annotation tag) -> Parser le (Annotation tag))
-> Parser le (Annotation tag) -> Parser le (Annotation tag)
forall a b. (a -> b) -> a -> b
$ Tokens Text
-> ReaderT le (Parsec CustomParserException Text) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string (KnownAnnTag tag => Text
forall tag. KnownAnnTag tag => Text
annPrefix @tag) ReaderT le (Parsec CustomParserException Text) Text
-> Parser' le (Annotation tag) -> Parser' le (Annotation tag)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Parser' le (Annotation tag)
specialNote Parser' le (Annotation tag)
-> Parser' le (Annotation tag) -> Parser' le (Annotation tag)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser' le (Annotation tag)
forall k (a :: k).
ReaderT le (Parsec CustomParserException Text) (Annotation a)
note' Parser' le (Annotation tag)
-> Parser' le (Annotation tag) -> Parser' le (Annotation tag)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser' le (Annotation tag)
forall k (a :: k).
ReaderT le (Parsec CustomParserException Text) (Annotation a)
emptyNote)
  where
    -- TODO [#48] these are special annotations and should not always be accepted
    specialVNote :: ReaderT le (Parsec CustomParserException Text) (Annotation a)
specialVNote = Either Text (Annotation a) -> Annotation a
forall a b. (HasCallStack, Buildable a) => Either a b -> b
unsafe (Either Text (Annotation a) -> Annotation a)
-> (Text -> Either Text (Annotation a)) -> Text -> Annotation a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text (Annotation a)
forall k (a :: k). Text -> Either Text (Annotation a)
mkAnnotation (Text -> Annotation a)
-> ReaderT le (Parsec CustomParserException Text) Text
-> ReaderT le (Parsec CustomParserException Text) (Annotation a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ReaderT le (Parsec CustomParserException Text) Text]
-> ReaderT le (Parsec CustomParserException Text) Text
forall t (f :: * -> *) a.
(Container t, Alternative f, Element t ~ f a) =>
t -> f a
asum ((Text -> ReaderT le (Parsec CustomParserException Text) Text)
-> [Text] -> [ReaderT le (Parsec CustomParserException Text) Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> ReaderT le (Parsec CustomParserException Text) Text
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string [Text]
specialVarAnns)
    specialFNote :: ReaderT le (Parsec CustomParserException Text) (Annotation a)
specialFNote = Either Text (Annotation a) -> Annotation a
forall a b. (HasCallStack, Buildable a) => Either a b -> b
unsafe (Either Text (Annotation a) -> Annotation a)
-> (Text -> Either Text (Annotation a)) -> Text -> Annotation a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text (Annotation a)
forall k (a :: k). Text -> Either Text (Annotation a)
mkAnnotation (Text -> Annotation a)
-> ReaderT le (Parsec CustomParserException Text) Text
-> ReaderT le (Parsec CustomParserException Text) (Annotation a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tokens Text
-> ReaderT le (Parsec CustomParserException Text) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
Tokens Text
specialFieldAnn
    specialNote :: Parser' le (Annotation tag)
specialNote = Parser' le (Annotation tag)
forall k (a :: k).
ReaderT le (Parsec CustomParserException Text) (Annotation a)
specialVNote Parser' le (Annotation tag)
-> Parser' le (Annotation tag) -> Parser' le (Annotation tag)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser' le (Annotation tag)
forall k (a :: k).
ReaderT le (Parsec CustomParserException Text) (Annotation a)
specialFNote
    emptyNote :: ReaderT le (Parsec CustomParserException Text) (Annotation a)
emptyNote = Annotation a
-> ReaderT le (Parsec CustomParserException Text) (Annotation a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Annotation a
forall k (a :: k). Annotation a
noAnn
    note' :: ReaderT le (Parsec CustomParserException Text) (Annotation a)
note' = do
      Char
a <- (Token Text -> Bool)
-> ReaderT le (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
isValidAnnStart
      Text
b <- Maybe String
-> (Token Text -> Bool)
-> ReaderT le (Parsec CustomParserException Text) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe String
forall a. Maybe a
Nothing Char -> Bool
Token Text -> Bool
isValidAnnBodyChar
      Annotation a
-> ReaderT le (Parsec CustomParserException Text) (Annotation a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Annotation a
 -> ReaderT le (Parsec CustomParserException Text) (Annotation a))
-> (Text -> Annotation a)
-> Text
-> ReaderT le (Parsec CustomParserException Text) (Annotation a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text (Annotation a) -> Annotation a
forall a b. (HasCallStack, Buildable a) => Either a b -> b
unsafe (Either Text (Annotation a) -> Annotation a)
-> (Text -> Either Text (Annotation a)) -> Text -> Annotation a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text (Annotation a)
forall k (a :: k). Text -> Either Text (Annotation a)
mkAnnotation (Text
 -> ReaderT le (Parsec CustomParserException Text) (Annotation a))
-> Text
-> ReaderT le (Parsec CustomParserException Text) (Annotation a)
forall a b. (a -> b) -> a -> b
$ Char -> Text -> Text
T.cons Char
a Text
b

noteV :: Parser le VarAnn
noteV :: Parser' le VarAnn
noteV = Parser' le VarAnn
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
note

noteDef :: KnownAnnTag tag => Parser le (Annotation tag)
noteDef :: Parser' le (Annotation tag)
noteDef = Parser le (Annotation tag) -> Parser le (Annotation tag)
forall a le. Default a => Parser le a -> Parser le a
parseDef Parser le (Annotation tag)
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
note

noteF :: Parser le FieldAnn
noteF :: Parser' le FieldAnn
noteF = Parser' le FieldAnn
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
note

noteV2Def :: Parser le (VarAnn, VarAnn)
noteV2Def :: Parser' le (VarAnn, VarAnn)
noteV2Def = ReaderT le (Parsec CustomParserException Text) VarAnn
-> ReaderT le (Parsec CustomParserException Text) VarAnn
-> Parser' le (VarAnn, VarAnn)
forall a b (f :: * -> *).
(Default a, Default b, Monad f, Alternative f) =>
f a -> f b -> f (a, b)
permute2Def ReaderT le (Parsec CustomParserException Text) VarAnn
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
note ReaderT le (Parsec CustomParserException Text) VarAnn
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
note

notesTVF :: Parser le (TypeAnn, VarAnn, FieldAnn)
notesTVF :: Parser' le (TypeAnn, VarAnn, FieldAnn)
notesTVF = ReaderT le (Parsec CustomParserException Text) TypeAnn
-> ReaderT le (Parsec CustomParserException Text) VarAnn
-> ReaderT le (Parsec CustomParserException Text) FieldAnn
-> Parser' le (TypeAnn, VarAnn, FieldAnn)
forall a b c (f :: * -> *).
(Default a, Default b, Default c, Monad f, Alternative f) =>
f a -> f b -> f c -> f (a, b, c)
permute3Def ReaderT le (Parsec CustomParserException Text) TypeAnn
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
note ReaderT le (Parsec CustomParserException Text) VarAnn
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
note ReaderT le (Parsec CustomParserException Text) FieldAnn
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
note

notesTVF2Def :: Parser le (TypeAnn, VarAnn, (FieldAnn, FieldAnn))
notesTVF2Def :: Parser' le (TypeAnn, VarAnn, (FieldAnn, FieldAnn))
notesTVF2Def = ReaderT le (Parsec CustomParserException Text) TypeAnn
-> ReaderT le (Parsec CustomParserException Text) VarAnn
-> ReaderT
     le (Parsec CustomParserException Text) (FieldAnn, FieldAnn)
-> Parser' le (TypeAnn, VarAnn, (FieldAnn, FieldAnn))
forall a b c (f :: * -> *).
(Default a, Default b, Default c, Monad f, Alternative f) =>
f a -> f b -> f c -> f (a, b, c)
permute3Def ReaderT le (Parsec CustomParserException Text) TypeAnn
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
note ReaderT le (Parsec CustomParserException Text) VarAnn
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
note (ReaderT le (Parsec CustomParserException Text) FieldAnn
-> ReaderT le (Parsec CustomParserException Text) FieldAnn
-> ReaderT
     le (Parsec CustomParserException Text) (FieldAnn, FieldAnn)
forall a b (f :: * -> *).
(Default a, Default b, Monad f, Alternative f) =>
f a -> f b -> f (a, b)
permute2Def ReaderT le (Parsec CustomParserException Text) FieldAnn
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
note ReaderT le (Parsec CustomParserException Text) FieldAnn
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
note)

-- | Parse 0/1/2 var anns and 0/1/2 field anns.
-- It doesn't matter which come first, so long as annotations of the same type appear together.
--
-- E.g.:
--
-- * "" is valid
-- * "%a" is valid
-- * "%a @c" is valid
-- * "%a %b @c @d" is valid
-- * "@c @d %a %b" is valid
-- * "@c %a %b @d" is not valid, because the two var anns are not "grouped" together.
-- * "%a @c @d %b" is not valid, because the two fields anns are not "grouped" together.
notesVVFF :: Parser le ((VarAnn, VarAnn), (FieldAnn, FieldAnn))
notesVVFF :: Parser' le ((VarAnn, VarAnn), (FieldAnn, FieldAnn))
notesVVFF = ReaderT le (Parsec CustomParserException Text) (VarAnn, VarAnn)
-> ReaderT
     le (Parsec CustomParserException Text) (FieldAnn, FieldAnn)
-> Parser' le ((VarAnn, VarAnn), (FieldAnn, FieldAnn))
forall a b (f :: * -> *).
(Default a, Default b, Monad f, Alternative f) =>
f a -> f b -> f (a, b)
permute2Def ((VarAnn -> VarAnn -> (VarAnn, VarAnn))
-> ReaderT le (Parsec CustomParserException Text) VarAnn
-> ReaderT le (Parsec CustomParserException Text) VarAnn
-> ReaderT le (Parsec CustomParserException Text) (VarAnn, VarAnn)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) ReaderT le (Parsec CustomParserException Text) VarAnn
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
note ReaderT le (Parsec CustomParserException Text) VarAnn
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
noteDef) ((FieldAnn -> FieldAnn -> (FieldAnn, FieldAnn))
-> ReaderT le (Parsec CustomParserException Text) FieldAnn
-> ReaderT le (Parsec CustomParserException Text) FieldAnn
-> ReaderT
     le (Parsec CustomParserException Text) (FieldAnn, FieldAnn)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) ReaderT le (Parsec CustomParserException Text) FieldAnn
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
note ReaderT le (Parsec CustomParserException Text) FieldAnn
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
noteDef)

notesVF :: Parser le (VarAnn, FieldAnn)
notesVF :: Parser' le (VarAnn, FieldAnn)
notesVF = ReaderT le (Parsec CustomParserException Text) VarAnn
-> ReaderT le (Parsec CustomParserException Text) FieldAnn
-> Parser' le (VarAnn, FieldAnn)
forall a b (f :: * -> *).
(Default a, Default b, Monad f, Alternative f) =>
f a -> f b -> f (a, b)
permute2Def ReaderT le (Parsec CustomParserException Text) VarAnn
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
note ReaderT le (Parsec CustomParserException Text) FieldAnn
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
note

notesTV :: Parser le (TypeAnn, VarAnn)
notesTV :: Parser' le (TypeAnn, VarAnn)
notesTV = ReaderT le (Parsec CustomParserException Text) TypeAnn
-> ReaderT le (Parsec CustomParserException Text) VarAnn
-> Parser' le (TypeAnn, VarAnn)
forall a b (f :: * -> *).
(Default a, Default b, Monad f, Alternative f) =>
f a -> f b -> f (a, b)
permute2Def ReaderT le (Parsec CustomParserException Text) TypeAnn
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
note ReaderT le (Parsec CustomParserException Text) VarAnn
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
note

notesTF :: Parser le (TypeAnn, FieldAnn)
notesTF :: Parser' le (TypeAnn, FieldAnn)
notesTF = ReaderT le (Parsec CustomParserException Text) TypeAnn
-> ReaderT le (Parsec CustomParserException Text) FieldAnn
-> Parser' le (TypeAnn, FieldAnn)
forall a b (f :: * -> *).
(Default a, Default b, Monad f, Alternative f) =>
f a -> f b -> f (a, b)
permute2Def ReaderT le (Parsec CustomParserException Text) TypeAnn
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
note ReaderT le (Parsec CustomParserException Text) FieldAnn
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
note

fieldType :: Default a
          => Parser le a
          -> Parser le (a, TypeAnn)
fieldType :: Parser le a -> Parser le (a, TypeAnn)
fieldType Parser le a
fp = Permutation
  (ReaderT le (Parsec CustomParserException Text)) (a, TypeAnn)
-> ReaderT le (Parsec CustomParserException Text) (a, TypeAnn)
forall (m :: * -> *) a.
(Alternative m, Monad m) =>
Permutation m a -> m a
runPermutation (Permutation
   (ReaderT le (Parsec CustomParserException Text)) (a, TypeAnn)
 -> ReaderT le (Parsec CustomParserException Text) (a, TypeAnn))
-> Permutation
     (ReaderT le (Parsec CustomParserException Text)) (a, TypeAnn)
-> ReaderT le (Parsec CustomParserException Text) (a, TypeAnn)
forall a b. (a -> b) -> a -> b
$
  (,) (a -> TypeAnn -> (a, TypeAnn))
-> Permutation (ReaderT le (Parsec CustomParserException Text)) a
-> Permutation
     (ReaderT le (Parsec CustomParserException Text))
     (TypeAnn -> (a, TypeAnn))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a
-> ReaderT le (Parsec CustomParserException Text) a
-> Permutation (ReaderT le (Parsec CustomParserException Text)) a
forall (m :: * -> *) a.
Alternative m =>
a -> m a -> Permutation m a
toPermutationWithDefault  a
forall a. Default a => a
def     ReaderT le (Parsec CustomParserException Text) a
Parser le a
fp
      Permutation
  (ReaderT le (Parsec CustomParserException Text))
  (TypeAnn -> (a, TypeAnn))
-> Permutation
     (ReaderT le (Parsec CustomParserException Text)) TypeAnn
-> Permutation
     (ReaderT le (Parsec CustomParserException Text)) (a, TypeAnn)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypeAnn
-> ReaderT le (Parsec CustomParserException Text) TypeAnn
-> Permutation
     (ReaderT le (Parsec CustomParserException Text)) TypeAnn
forall (m :: * -> *) a.
Alternative m =>
a -> m a -> Permutation m a
toPermutationWithDefault TypeAnn
forall k (a :: k). Annotation a
noAnn ReaderT le (Parsec CustomParserException Text) TypeAnn
forall tag le. KnownAnnTag tag => Parser le (Annotation tag)
note