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

module Morley.Michelson.Parser.Annotations
  ( note
  , anyNote
  , 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. KnownAnnTag tag => Parser (Annotation tag)
note :: forall tag. KnownAnnTag tag => Parser (Annotation tag)
note = Parser (Annotation tag) -> Parser (Annotation tag)
forall a. Parser a -> Parser a
lexeme (Parser (Annotation tag) -> Parser (Annotation tag))
-> Parser (Annotation tag) -> Parser (Annotation tag)
forall a b. (a -> b) -> a -> b
$ Tokens Text
-> ParsecT CustomParserException Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string (forall tag. KnownAnnTag tag => Text
annPrefix @tag) ParsecT CustomParserException Text Identity Text
-> Parser (Annotation tag) -> Parser (Annotation tag)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Parser (Annotation tag)
specialNote Parser (Annotation tag)
-> Parser (Annotation tag) -> Parser (Annotation tag)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Annotation tag)
forall {k} {a :: k}.
ParsecT CustomParserException Text Identity (Annotation a)
note' Parser (Annotation tag)
-> Parser (Annotation tag) -> Parser (Annotation tag)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Annotation tag)
forall {k} {a :: k}.
ParsecT CustomParserException Text Identity (Annotation a)
emptyNote)
  where
    -- TODO [#48]: these are special annotations and should not always be accepted
    specialVNote :: ParsecT CustomParserException Text Identity (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)
-> ParsecT CustomParserException Text Identity Text
-> ParsecT CustomParserException Text Identity (Annotation a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ParsecT CustomParserException Text Identity Text]
-> ParsecT CustomParserException Text Identity Text
forall t (f :: * -> *) a.
(Container t, Alternative f, Element t ~ f a) =>
t -> f a
asum ((Text -> ParsecT CustomParserException Text Identity Text)
-> [Text] -> [ParsecT CustomParserException Text Identity Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> ParsecT CustomParserException Text Identity Text
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string [Text]
specialVarAnns)
    specialFNote :: ParsecT CustomParserException Text Identity (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)
-> ParsecT CustomParserException Text Identity Text
-> ParsecT CustomParserException Text Identity (Annotation a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tokens Text
-> ParsecT CustomParserException Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
Tokens Text
specialFieldAnn
    specialNote :: Parser (Annotation tag)
specialNote = Parser (Annotation tag)
forall {k} {a :: k}.
ParsecT CustomParserException Text Identity (Annotation a)
specialVNote Parser (Annotation tag)
-> Parser (Annotation tag) -> Parser (Annotation tag)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Annotation tag)
forall {k} {a :: k}.
ParsecT CustomParserException Text Identity (Annotation a)
specialFNote
    emptyNote :: ParsecT CustomParserException Text Identity (Annotation a)
emptyNote = Annotation a
-> ParsecT CustomParserException Text Identity (Annotation a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Annotation a
forall {k} (a :: k). Annotation a
noAnn
    note' :: ParsecT CustomParserException Text Identity (Annotation a)
note' = do
      Char
a <- (Token Text -> Bool)
-> 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
isValidAnnStart
      Text
b <- Maybe String
-> (Token Text -> Bool)
-> ParsecT CustomParserException Text Identity (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
-> ParsecT CustomParserException Text Identity (Annotation a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Annotation a
 -> ParsecT CustomParserException Text Identity (Annotation a))
-> (Text -> Annotation a)
-> Text
-> ParsecT CustomParserException Text Identity (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
 -> ParsecT CustomParserException Text Identity (Annotation a))
-> Text
-> ParsecT CustomParserException Text Identity (Annotation a)
forall a b. (a -> b) -> a -> b
$ Char -> Text -> Text
T.cons Char
a Text
b

-- | Parse arbitrary annotation.
anyNote :: Parser AnyAnn
anyNote :: Parser AnyAnn
anyNote =
      Annotation TypeTag -> AnyAnn
AnyAnnType (Annotation TypeTag -> AnyAnn)
-> ParsecT CustomParserException Text Identity (Annotation TypeTag)
-> Parser AnyAnn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall tag. KnownAnnTag tag => Parser (Annotation tag)
note @TypeTag
  Parser AnyAnn -> Parser AnyAnn -> Parser AnyAnn
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Annotation FieldTag -> AnyAnn
AnyAnnField (Annotation FieldTag -> AnyAnn)
-> ParsecT
     CustomParserException Text Identity (Annotation FieldTag)
-> Parser AnyAnn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall tag. KnownAnnTag tag => Parser (Annotation tag)
note @FieldTag
  Parser AnyAnn -> Parser AnyAnn -> Parser AnyAnn
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Annotation VarTag -> AnyAnn
AnyAnnVar (Annotation VarTag -> AnyAnn)
-> ParsecT CustomParserException Text Identity (Annotation VarTag)
-> Parser AnyAnn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall tag. KnownAnnTag tag => Parser (Annotation tag)
note @VarTag

noteV :: Parser VarAnn
noteV :: ParsecT CustomParserException Text Identity (Annotation VarTag)
noteV = ParsecT CustomParserException Text Identity (Annotation VarTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note

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

noteF :: Parser FieldAnn
noteF :: ParsecT CustomParserException Text Identity (Annotation FieldTag)
noteF = ParsecT CustomParserException Text Identity (Annotation FieldTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note

noteV2Def :: Parser (VarAnn, VarAnn)
noteV2Def :: Parser (Annotation VarTag, Annotation VarTag)
noteV2Def = ParsecT CustomParserException Text Identity (Annotation VarTag)
-> ParsecT CustomParserException Text Identity (Annotation VarTag)
-> Parser (Annotation VarTag, Annotation VarTag)
forall a b (f :: * -> *).
(Default a, Default b, Monad f, Alternative f) =>
f a -> f b -> f (a, b)
permute2Def ParsecT CustomParserException Text Identity (Annotation VarTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note ParsecT CustomParserException Text Identity (Annotation VarTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note

notesTVF :: Parser (TypeAnn, VarAnn, FieldAnn)
notesTVF :: Parser (Annotation TypeTag, Annotation VarTag, Annotation FieldTag)
notesTVF = ParsecT CustomParserException Text Identity (Annotation TypeTag)
-> ParsecT CustomParserException Text Identity (Annotation VarTag)
-> ParsecT
     CustomParserException Text Identity (Annotation FieldTag)
-> Parser
     (Annotation TypeTag, Annotation VarTag, Annotation FieldTag)
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 ParsecT CustomParserException Text Identity (Annotation TypeTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note ParsecT CustomParserException Text Identity (Annotation VarTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note ParsecT CustomParserException Text Identity (Annotation FieldTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note

notesTVF2Def :: Parser (TypeAnn, VarAnn, (FieldAnn, FieldAnn))
notesTVF2Def :: Parser
  (Annotation TypeTag, Annotation VarTag,
   (Annotation FieldTag, Annotation FieldTag))
notesTVF2Def = ParsecT CustomParserException Text Identity (Annotation TypeTag)
-> ParsecT CustomParserException Text Identity (Annotation VarTag)
-> ParsecT
     CustomParserException
     Text
     Identity
     (Annotation FieldTag, Annotation FieldTag)
-> Parser
     (Annotation TypeTag, Annotation VarTag,
      (Annotation FieldTag, Annotation FieldTag))
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 ParsecT CustomParserException Text Identity (Annotation TypeTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note ParsecT CustomParserException Text Identity (Annotation VarTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note (ParsecT CustomParserException Text Identity (Annotation FieldTag)
-> ParsecT
     CustomParserException Text Identity (Annotation FieldTag)
-> ParsecT
     CustomParserException
     Text
     Identity
     (Annotation FieldTag, Annotation FieldTag)
forall a b (f :: * -> *).
(Default a, Default b, Monad f, Alternative f) =>
f a -> f b -> f (a, b)
permute2Def ParsecT CustomParserException Text Identity (Annotation FieldTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note ParsecT CustomParserException Text Identity (Annotation FieldTag)
forall tag. KnownAnnTag tag => Parser (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 ((VarAnn, VarAnn), (FieldAnn, FieldAnn))
notesVVFF :: Parser
  ((Annotation VarTag, Annotation VarTag),
   (Annotation FieldTag, Annotation FieldTag))
notesVVFF = Parser (Annotation VarTag, Annotation VarTag)
-> ParsecT
     CustomParserException
     Text
     Identity
     (Annotation FieldTag, Annotation FieldTag)
-> Parser
     ((Annotation VarTag, Annotation VarTag),
      (Annotation FieldTag, Annotation FieldTag))
forall a b (f :: * -> *).
(Default a, Default b, Monad f, Alternative f) =>
f a -> f b -> f (a, b)
permute2Def ((Annotation VarTag
 -> Annotation VarTag -> (Annotation VarTag, Annotation VarTag))
-> ParsecT CustomParserException Text Identity (Annotation VarTag)
-> ParsecT CustomParserException Text Identity (Annotation VarTag)
-> Parser (Annotation VarTag, Annotation VarTag)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) ParsecT CustomParserException Text Identity (Annotation VarTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note ParsecT CustomParserException Text Identity (Annotation VarTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
noteDef) ((Annotation FieldTag
 -> Annotation FieldTag
 -> (Annotation FieldTag, Annotation FieldTag))
-> ParsecT
     CustomParserException Text Identity (Annotation FieldTag)
-> ParsecT
     CustomParserException Text Identity (Annotation FieldTag)
-> ParsecT
     CustomParserException
     Text
     Identity
     (Annotation FieldTag, Annotation FieldTag)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) ParsecT CustomParserException Text Identity (Annotation FieldTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note ParsecT CustomParserException Text Identity (Annotation FieldTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
noteDef)

notesVF :: Parser (VarAnn, FieldAnn)
notesVF :: Parser (Annotation VarTag, Annotation FieldTag)
notesVF = ParsecT CustomParserException Text Identity (Annotation VarTag)
-> ParsecT
     CustomParserException Text Identity (Annotation FieldTag)
-> Parser (Annotation VarTag, Annotation FieldTag)
forall a b (f :: * -> *).
(Default a, Default b, Monad f, Alternative f) =>
f a -> f b -> f (a, b)
permute2Def ParsecT CustomParserException Text Identity (Annotation VarTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note ParsecT CustomParserException Text Identity (Annotation FieldTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note

notesTV :: Parser (TypeAnn, VarAnn)
notesTV :: Parser (Annotation TypeTag, Annotation VarTag)
notesTV = ParsecT CustomParserException Text Identity (Annotation TypeTag)
-> ParsecT CustomParserException Text Identity (Annotation VarTag)
-> Parser (Annotation TypeTag, Annotation VarTag)
forall a b (f :: * -> *).
(Default a, Default b, Monad f, Alternative f) =>
f a -> f b -> f (a, b)
permute2Def ParsecT CustomParserException Text Identity (Annotation TypeTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note ParsecT CustomParserException Text Identity (Annotation VarTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note

notesTF :: Parser (TypeAnn, FieldAnn)
notesTF :: Parser (Annotation TypeTag, Annotation FieldTag)
notesTF = ParsecT CustomParserException Text Identity (Annotation TypeTag)
-> ParsecT
     CustomParserException Text Identity (Annotation FieldTag)
-> Parser (Annotation TypeTag, Annotation FieldTag)
forall a b (f :: * -> *).
(Default a, Default b, Monad f, Alternative f) =>
f a -> f b -> f (a, b)
permute2Def ParsecT CustomParserException Text Identity (Annotation TypeTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note ParsecT CustomParserException Text Identity (Annotation FieldTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note

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