-- | Michelson annotations in untyped model.

module Michelson.Untyped.Annotation
  ( Annotation (..)
  , pattern Annotation
  , pattern WithAnn
  , KnownAnnTag(..)
  , TypeAnn
  , FieldAnn
  , VarAnn
  , SomeAnn
  , noAnn
  , ann
  , mkAnnotation
  , specialVarAnns
  , specialFieldAnn
  , isValidAnnStart
  , isValidAnnBodyChar
  , renderAnn
  , renderWEAnn
  , unifyAnn
  , ifAnnUnified
  , disjoinVn
  , convAnn
  ) where

import Data.Aeson.TH (defaultOptions, deriveJSON)
import Data.Char (isAlpha, isAscii, isNumber)
import Data.Data (Data(..))
import Data.Default (Default(..))
import qualified Data.Text as T
import Fmt (Buildable(build))
import Instances.TH.Lift ()
import Language.Haskell.TH.Lift (deriveLift)
import Text.PrettyPrint.Leijen.Text (Doc, textStrict)
import qualified Text.Show

import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc)

-- | Generic Type/Field/Variable Annotation
--
-- As per Michelson documentation, this type has an invariant:
-- (except for the first character, here parametrized in the type `tag`) the
-- allowed character set is the one matching the following regexp:
-- @%|@%%|%@|[@:%][_a-zA-Z][_0-9a-zA-Z\.%@]*
newtype Annotation tag = AnnotationUnsafe { unAnnotation :: Text }
  deriving stock (Eq, Data, Functor, Generic)
  deriving newtype (IsString)

pattern Annotation :: Text -> Annotation tag
pattern Annotation ann <- AnnotationUnsafe ann

{-# COMPLETE Annotation :: Annotation #-}

instance Default (Annotation tag) where
  def = noAnn

class KnownAnnTag tag where
  annPrefix :: Text

instance KnownAnnTag tag => Show (Annotation tag) where
  show (Annotation x) = toString $ annPrefix @tag <> x

data TypeTag
data FieldTag
data VarTag
data SomeTag

type TypeAnn = Annotation TypeTag
type FieldAnn = Annotation FieldTag
type VarAnn = Annotation VarTag
type SomeAnn = Annotation SomeTag

instance KnownAnnTag FieldTag where
  annPrefix = "%"
instance KnownAnnTag VarTag where
  annPrefix = "@"
instance KnownAnnTag TypeTag where
  annPrefix = ":"

instance KnownAnnTag tag => RenderDoc (Annotation tag) where
  renderDoc _ = renderAnn

renderAnn :: forall tag. KnownAnnTag tag => Annotation tag -> Doc
renderAnn a@(Annotation text)
  | a == noAnn = ""
  | otherwise = textStrict $ annPrefix @tag <> text

-- | Prints empty prefix in case of @noAnn@.
--
-- Such functionality is required in case when instruction
-- has two annotations of the same type, former is empty
-- and the latter is not. So that `PAIR noAnn noAnn noAnn %kek`
-- is printed as `PAIR % %kek`
renderWEAnn :: forall tag. KnownAnnTag tag => Annotation tag -> Doc
renderWEAnn (Annotation text) = textStrict $ annPrefix @tag <> text

instance KnownAnnTag tag => Buildable (Annotation tag) where
  build = buildRenderDoc

noAnn :: Annotation a
noAnn = AnnotationUnsafe ""

-- | Makes an `Annotation` from its textual value, prefix (%/@/:) excluded
-- Throws an error if the given `Text` contains invalid characters
ann :: HasCallStack => Text -> Annotation a
ann = either error id . mkAnnotation

-- | Makes an `Annotation` from its textual value, prefix (%/@/:) excluded
-- Returns a `Text` error message if the given `Text` contains invalid characters
mkAnnotation :: Text -> Either Text (Annotation a)
mkAnnotation text
  -- TODO [#48] these are special annotations and should not be always allowed
  | text `elem` specialVarAnns = Right $ AnnotationUnsafe text
  | text == specialFieldAnn = Right $ AnnotationUnsafe text
  | otherwise = do
    suffix <- case T.uncons text of
      Just (h, tl) | isValidAnnStart h -> Right tl
      Just (h, _) -> Left $ T.snoc "Invalid first character: " h
      _ -> Right ""
    maybe (Right $ AnnotationUnsafe text) (Left . T.snoc "Invalid character: ") $
      T.find (not . isValidAnnBodyChar) suffix

-- | List of all the special Variable Annotations, only allowed in `CAR` and `CDR`
-- instructions, prefix (@) excluded.
-- These do not respect the rules of `isValidAnnStart` and `isValidAnnBodyChar`.
specialVarAnns :: [Text]
specialVarAnns = ["%%","%"]

-- | The only special Field Annotation, only allowed in `PAIR`, `LEFT` and
-- `RIGHT` instructions, prefix (%) excluded.
-- This does not respect the rules of `isValidAnnStart` and `isValidAnnBodyChar`.
specialFieldAnn :: Text
specialFieldAnn = "@"


-- | Checks if a `Char` is valid to be the first of an annotation, prefix
-- (%/@/:) excluded, the ones following should be checked with
-- `isValidAnnBodyChar` instead.
-- Note that this does not check Special Annotations, see `specialVarAnns`
-- and `specialFieldAnn`
isValidAnnStart :: Char -> Bool
isValidAnnStart x = (isAscii x && isAlpha x) || x == '_'

-- | Checks if a `Char` is valid to be part of an annotation, following a valid
-- first character (see `isValidAnnStart`) and the prefix (%/@/:).
-- Note that this does not check Special Annotations, see `specialVarAnns`
-- and `specialFieldAnn`
isValidAnnBodyChar :: Char -> Bool
isValidAnnBodyChar x =
  isValidAnnStart x || (isAscii x && isNumber x) ||  x `elem` (".%@" :: String)

instance Semigroup VarAnn where
  Annotation a <> Annotation b
    | a == "" || b == "" = ann $ a <> b
    | otherwise          = ann $ a <> "." <> b

instance Monoid VarAnn where
    mempty = noAnn

unifyAnn :: Annotation tag -> Annotation tag -> Maybe (Annotation tag)
unifyAnn (Annotation ann1) (Annotation ann2)
  | ann1 == "" || ann2 == "" = Just $ ann $ ann1 <> ann2
  | ann1 == ann2 = Just $ ann ann1
  | otherwise  = Nothing

ifAnnUnified :: Annotation tag -> Annotation tag -> Bool
ifAnnUnified a1 a2 = isJust $ a1 `unifyAnn` a2

disjoinVn :: VarAnn -> (VarAnn, VarAnn)
disjoinVn (Annotation a) = case T.findIndex (== '.') $ T.reverse a of
  Just ((n - 1 -) -> pos) -> (ann $ T.take pos a, ann $ T.drop (pos + 1) a)
  Nothing                 -> (noAnn, ann a)
  where
    n = T.length a

convAnn :: Annotation tag1 -> Annotation tag2
convAnn (Annotation a) = ann a

pattern WithAnn :: Annotation tag -> Annotation tag
pattern WithAnn ann <- ann@(Annotation (toString -> _:_))

deriveJSON defaultOptions ''Annotation
deriveLift ''Annotation