{-# LANGUAGE DeriveDataTypeable, DerivingStrategies #-}

-- | Michelson annotations in untyped model.

module Michelson.Untyped.Annotation
  ( Annotation (..)
  , pattern WithAnn
  , TypeAnn
  , FieldAnn
  , VarAnn
  , SomeAnn
  , noAnn
  , ann
  , renderAnn
  , renderWEAnn
  , unifyAnn
  , ifAnnUnified
  , disjoinVn
  , convAnn
  ) where

import Data.Aeson.TH (defaultOptions, deriveJSON)
import Data.Data (Data(..))
import Data.Default (Default(..))
import qualified Data.Text as T
import Fmt (Buildable(build))
import Text.PrettyPrint.Leijen.Text (Doc, textStrict)
import qualified Text.Show

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

newtype Annotation tag = Annotation T.Text
  deriving stock (Eq, Data, Functor, Generic)
  deriving newtype (IsString)

instance Default (Annotation tag) where
  def = Annotation ""

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 = Annotation ""

ann :: T.Text -> Annotation a
ann = Annotation

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) = Annotation a

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

deriveJSON defaultOptions ''Annotation