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

-- | Michelson annotations in untyped model.

module Michelson.Untyped.Annotation
  ( Annotation (..)
  , pattern Annotation
  , pattern WithAnn

  -- * Annotation Set
  , AnnotationSet
  , emptyAnnSet
  , fullAnnSet
  , isNoAnnSet
  , minAnnSetSize
  , singleAnnSet
  , singleGroupAnnSet

  -- * Rendering
  , KnownAnnTag(..)
  , TypeAnn
  , FieldAnn
  , VarAnn
  , SomeAnn
  , RootAnn
  , TypeTag
  , FieldTag
  , VarTag

  -- * Creation and conversions
  , noAnn
  , ann
  , mkAnnotation
  , specialVarAnns
  , specialFieldAnn
  , isValidAnnStart
  , isValidAnnBodyChar
  , unifyAnn
  , ifAnnUnified
  , disjoinVn
  , convAnn
  ) where

import Data.Aeson.TH (deriveJSON)
import Data.Char (isAlpha, isAscii, isDigit, isNumber)
import Data.Data (Data(..))
import Data.Default (Default(..))
import qualified Data.Kind as Kind
import qualified Data.Text as T
import Data.Typeable ((:~:)(..), eqT)
import Fmt (Buildable(build))
import Instances.TH.Lift ()
import Language.Haskell.TH.Lift (deriveLift)
import Text.PrettyPrint.Leijen.Text (Doc, hsep, textStrict, (<+>))
import qualified Text.Show

import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, doesntNeedParens, printDocS)
import Util.Aeson

-- | 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:
-- @%|@%%|%@|[@:%][_0-9a-zA-Z][_0-9a-zA-Z\.%@]*
newtype Annotation tag = AnnotationUnsafe { Annotation tag -> Text
unAnnotation :: Text }
  deriving stock (Annotation tag -> Annotation tag -> Bool
(Annotation tag -> Annotation tag -> Bool)
-> (Annotation tag -> Annotation tag -> Bool)
-> Eq (Annotation tag)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (tag :: k). Annotation tag -> Annotation tag -> Bool
/= :: Annotation tag -> Annotation tag -> Bool
$c/= :: forall k (tag :: k). Annotation tag -> Annotation tag -> Bool
== :: Annotation tag -> Annotation tag -> Bool
$c== :: forall k (tag :: k). Annotation tag -> Annotation tag -> Bool
Eq, Typeable (Annotation tag)
DataType
Constr
Typeable (Annotation tag) =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> Annotation tag -> c (Annotation tag))
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (Annotation tag))
-> (Annotation tag -> Constr)
-> (Annotation tag -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (Annotation tag)))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c (Annotation tag)))
-> ((forall b. Data b => b -> b)
    -> Annotation tag -> Annotation tag)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> Annotation tag -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> Annotation tag -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> Annotation tag -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> Annotation tag -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> Annotation tag -> m (Annotation tag))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> Annotation tag -> m (Annotation tag))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> Annotation tag -> m (Annotation tag))
-> Data (Annotation tag)
Annotation tag -> DataType
Annotation tag -> Constr
(forall b. Data b => b -> b) -> Annotation tag -> Annotation tag
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Annotation tag -> c (Annotation tag)
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Annotation tag)
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> Annotation tag -> u
forall u. (forall d. Data d => d -> u) -> Annotation tag -> [u]
forall k (tag :: k).
(Typeable tag, Typeable k) =>
Typeable (Annotation tag)
forall k (tag :: k).
(Typeable tag, Typeable k) =>
Annotation tag -> DataType
forall k (tag :: k).
(Typeable tag, Typeable k) =>
Annotation tag -> Constr
forall k (tag :: k).
(Typeable tag, Typeable k) =>
(forall b. Data b => b -> b) -> Annotation tag -> Annotation tag
forall k (tag :: k) u.
(Typeable tag, Typeable k) =>
Int -> (forall d. Data d => d -> u) -> Annotation tag -> u
forall k (tag :: k) u.
(Typeable tag, Typeable k) =>
(forall d. Data d => d -> u) -> Annotation tag -> [u]
forall k (tag :: k) r r'.
(Typeable tag, Typeable k) =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Annotation tag -> r
forall k (tag :: k) r r'.
(Typeable tag, Typeable k) =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Annotation tag -> r
forall k (tag :: k) (m :: * -> *).
(Typeable tag, Typeable k, Monad m) =>
(forall d. Data d => d -> m d)
-> Annotation tag -> m (Annotation tag)
forall k (tag :: k) (m :: * -> *).
(Typeable tag, Typeable k, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> Annotation tag -> m (Annotation tag)
forall k (tag :: k) (c :: * -> *).
(Typeable tag, Typeable k) =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Annotation tag)
forall k (tag :: k) (c :: * -> *).
(Typeable tag, Typeable k) =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Annotation tag -> c (Annotation tag)
forall k (tag :: k) (t :: * -> *) (c :: * -> *).
(Typeable tag, Typeable k, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Annotation tag))
forall k (tag :: k) (t :: * -> * -> *) (c :: * -> *).
(Typeable tag, Typeable k, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (Annotation tag))
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Annotation tag -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Annotation tag -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> Annotation tag -> m (Annotation tag)
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> Annotation tag -> m (Annotation tag)
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Annotation tag)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Annotation tag -> c (Annotation tag)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (Annotation tag))
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (Annotation tag))
$cAnnotationUnsafe :: Constr
$tAnnotation :: DataType
gmapMo :: (forall d. Data d => d -> m d)
-> Annotation tag -> m (Annotation tag)
$cgmapMo :: forall k (tag :: k) (m :: * -> *).
(Typeable tag, Typeable k, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> Annotation tag -> m (Annotation tag)
gmapMp :: (forall d. Data d => d -> m d)
-> Annotation tag -> m (Annotation tag)
$cgmapMp :: forall k (tag :: k) (m :: * -> *).
(Typeable tag, Typeable k, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> Annotation tag -> m (Annotation tag)
gmapM :: (forall d. Data d => d -> m d)
-> Annotation tag -> m (Annotation tag)
$cgmapM :: forall k (tag :: k) (m :: * -> *).
(Typeable tag, Typeable k, Monad m) =>
(forall d. Data d => d -> m d)
-> Annotation tag -> m (Annotation tag)
gmapQi :: Int -> (forall d. Data d => d -> u) -> Annotation tag -> u
$cgmapQi :: forall k (tag :: k) u.
(Typeable tag, Typeable k) =>
Int -> (forall d. Data d => d -> u) -> Annotation tag -> u
gmapQ :: (forall d. Data d => d -> u) -> Annotation tag -> [u]
$cgmapQ :: forall k (tag :: k) u.
(Typeable tag, Typeable k) =>
(forall d. Data d => d -> u) -> Annotation tag -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Annotation tag -> r
$cgmapQr :: forall k (tag :: k) r r'.
(Typeable tag, Typeable k) =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Annotation tag -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Annotation tag -> r
$cgmapQl :: forall k (tag :: k) r r'.
(Typeable tag, Typeable k) =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Annotation tag -> r
gmapT :: (forall b. Data b => b -> b) -> Annotation tag -> Annotation tag
$cgmapT :: forall k (tag :: k).
(Typeable tag, Typeable k) =>
(forall b. Data b => b -> b) -> Annotation tag -> Annotation tag
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (Annotation tag))
$cdataCast2 :: forall k (tag :: k) (t :: * -> * -> *) (c :: * -> *).
(Typeable tag, Typeable k, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (Annotation tag))
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c (Annotation tag))
$cdataCast1 :: forall k (tag :: k) (t :: * -> *) (c :: * -> *).
(Typeable tag, Typeable k, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Annotation tag))
dataTypeOf :: Annotation tag -> DataType
$cdataTypeOf :: forall k (tag :: k).
(Typeable tag, Typeable k) =>
Annotation tag -> DataType
toConstr :: Annotation tag -> Constr
$ctoConstr :: forall k (tag :: k).
(Typeable tag, Typeable k) =>
Annotation tag -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Annotation tag)
$cgunfold :: forall k (tag :: k) (c :: * -> *).
(Typeable tag, Typeable k) =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Annotation tag)
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Annotation tag -> c (Annotation tag)
$cgfoldl :: forall k (tag :: k) (c :: * -> *).
(Typeable tag, Typeable k) =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Annotation tag -> c (Annotation tag)
$cp1Data :: forall k (tag :: k).
(Typeable tag, Typeable k) =>
Typeable (Annotation tag)
Data, (a -> b) -> Annotation a -> Annotation b
(forall a b. (a -> b) -> Annotation a -> Annotation b)
-> (forall a b. a -> Annotation b -> Annotation a)
-> Functor Annotation
forall a b. a -> Annotation b -> Annotation a
forall a b. (a -> b) -> Annotation a -> Annotation b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Annotation b -> Annotation a
$c<$ :: forall a b. a -> Annotation b -> Annotation a
fmap :: (a -> b) -> Annotation a -> Annotation b
$cfmap :: forall a b. (a -> b) -> Annotation a -> Annotation b
Functor, (forall x. Annotation tag -> Rep (Annotation tag) x)
-> (forall x. Rep (Annotation tag) x -> Annotation tag)
-> Generic (Annotation tag)
forall x. Rep (Annotation tag) x -> Annotation tag
forall x. Annotation tag -> Rep (Annotation tag) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k (tag :: k) x. Rep (Annotation tag) x -> Annotation tag
forall k (tag :: k) x. Annotation tag -> Rep (Annotation tag) x
$cto :: forall k (tag :: k) x. Rep (Annotation tag) x -> Annotation tag
$cfrom :: forall k (tag :: k) x. Annotation tag -> Rep (Annotation tag) x
Generic)
  deriving newtype (String -> Annotation tag
(String -> Annotation tag) -> IsString (Annotation tag)
forall a. (String -> a) -> IsString a
forall k (tag :: k). String -> Annotation tag
fromString :: String -> Annotation tag
$cfromString :: forall k (tag :: k). String -> Annotation tag
IsString)

instance NFData (Annotation tag)

pattern Annotation :: Text -> Annotation tag
pattern $mAnnotation :: forall r k (tag :: k).
Annotation tag -> (Text -> r) -> (Void# -> r) -> r
Annotation ann <- AnnotationUnsafe ann

{-# COMPLETE Annotation :: Annotation #-}

instance Default (Annotation tag) where
  def :: Annotation tag
def = Annotation tag
forall k (tag :: k). Annotation tag
noAnn

--------------------------------------------------------------------------------
-- Annotation Set
--------------------------------------------------------------------------------

-- | An 'AnnotationSet' contains all the type/field/variable 'Annotation's
-- , with each group in order, associated with an entity.
-- Note that in its rendering/show instances the unnecessary annotations will be
-- omitted, as well as in some of the functions operating with it.
-- Necessary 'Annotation's are the ones strictly required for a consistent
-- representation.
-- In particular, for each group (t/f/v):
--   - if all annotations are 'noAnn' they are all omitted
--   - if one or more 'noAnn' follow a non-empty 'ann', they are omitted
--   - if one or more 'noAnn' precede a non-empty 'ann', they are kept
--   - every non-empty 'ann' is obviously kept
-- This is why order for each group is important as well as separation of
-- different groups of 'Annotation's.
data AnnotationSet = AnnotationSet
  { AnnotationSet -> [TypeAnn]
asTypes  :: [TypeAnn]
  , AnnotationSet -> [FieldAnn]
asFields :: [FieldAnn]
  , AnnotationSet -> [VarAnn]
asVars   :: [VarAnn]
  } deriving stock AnnotationSet -> AnnotationSet -> Bool
(AnnotationSet -> AnnotationSet -> Bool)
-> (AnnotationSet -> AnnotationSet -> Bool) -> Eq AnnotationSet
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AnnotationSet -> AnnotationSet -> Bool
$c/= :: AnnotationSet -> AnnotationSet -> Bool
== :: AnnotationSet -> AnnotationSet -> Bool
$c== :: AnnotationSet -> AnnotationSet -> Bool
Eq

instance Semigroup AnnotationSet where
  (AnnotationSet ts1 :: [TypeAnn]
ts1 fs1 :: [FieldAnn]
fs1 vs1 :: [VarAnn]
vs1) <> :: AnnotationSet -> AnnotationSet -> AnnotationSet
<> (AnnotationSet ts2 :: [TypeAnn]
ts2 fs2 :: [FieldAnn]
fs2 vs2 :: [VarAnn]
vs2) = $WAnnotationSet :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> AnnotationSet
AnnotationSet {..}
    where
      asTypes :: [TypeAnn]
asTypes  = [TypeAnn]
ts1 [TypeAnn] -> [TypeAnn] -> [TypeAnn]
forall a. Semigroup a => a -> a -> a
<> [TypeAnn]
ts2
      asFields :: [FieldAnn]
asFields = [FieldAnn]
fs1 [FieldAnn] -> [FieldAnn] -> [FieldAnn]
forall a. Semigroup a => a -> a -> a
<> [FieldAnn]
fs2
      asVars :: [VarAnn]
asVars   = [VarAnn]
vs1 [VarAnn] -> [VarAnn] -> [VarAnn]
forall a. Semigroup a => a -> a -> a
<> [VarAnn]
vs2

instance Monoid AnnotationSet where
  mempty :: AnnotationSet
mempty = AnnotationSet
emptyAnnSet

-- | An 'AnnotationSet' without any 'Annotation'.
emptyAnnSet :: AnnotationSet
emptyAnnSet :: AnnotationSet
emptyAnnSet = [TypeAnn] -> [FieldAnn] -> [VarAnn] -> AnnotationSet
AnnotationSet [] [] []

-- | An 'AnnotationSet' with only a single 'Annotation' (of any kind).
singleAnnSet :: forall tag. KnownAnnTag tag => Annotation tag -> AnnotationSet
singleAnnSet :: Annotation tag -> AnnotationSet
singleAnnSet an :: Annotation tag
an = [Annotation tag] -> AnnotationSet
forall tag. KnownAnnTag tag => [Annotation tag] -> AnnotationSet
singleGroupAnnSet [Annotation tag
an]

-- | An 'AnnotationSet' with several 'Annotation's of the same kind.
singleGroupAnnSet :: forall tag. KnownAnnTag tag => [Annotation tag] -> AnnotationSet
singleGroupAnnSet :: [Annotation tag] -> AnnotationSet
singleGroupAnnSet ans :: [Annotation tag]
ans = $WAnnotationSet :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> AnnotationSet
AnnotationSet {..}
  where
    asTypes :: [TypeAnn]
asTypes = case (Typeable tag, Typeable TypeTag) => Maybe (tag :~: TypeTag)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @tag @TypeTag of Just Refl -> [Annotation tag]
[TypeAnn]
ans; Nothing -> []
    asFields :: [FieldAnn]
asFields = case (Typeable tag, Typeable FieldTag) => Maybe (tag :~: FieldTag)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @tag @FieldTag of Just Refl -> [Annotation tag]
[FieldAnn]
ans; Nothing -> []
    asVars :: [VarAnn]
asVars = case (Typeable tag, Typeable VarTag) => Maybe (tag :~: VarTag)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @tag @VarTag of Just Refl -> [Annotation tag]
[VarAnn]
ans; Nothing -> []

-- | An 'AnnotationSet' built from all 3 kinds of 'Annotation'.
fullAnnSet :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> AnnotationSet
fullAnnSet :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> AnnotationSet
fullAnnSet asTypes :: [TypeAnn]
asTypes asFields :: [FieldAnn]
asFields asVars :: [VarAnn]
asVars = $WAnnotationSet :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> AnnotationSet
AnnotationSet {..}

-- | Returns 'True' if all 'Annotation's in the Set are unnecessary/empty/'noAnn'.
-- False otherwise.
isNoAnnSet :: AnnotationSet -> Bool
isNoAnnSet :: AnnotationSet -> Bool
isNoAnnSet annSet :: AnnotationSet
annSet = [TypeAnn] -> Bool
forall t. Container t => t -> Bool
null [TypeAnn]
asTypes Bool -> Bool -> Bool
&& [FieldAnn] -> Bool
forall t. Container t => t -> Bool
null [FieldAnn]
asFields Bool -> Bool -> Bool
&& [VarAnn] -> Bool
forall t. Container t => t -> Bool
null [VarAnn]
asVars
  where AnnotationSet {..} = AnnotationSet -> AnnotationSet
minimizeAnnSet AnnotationSet
annSet

-- | Returns the amount of 'Annotation's that are necessary for a consistent
-- representation. See 'AnnotationSet'.
minAnnSetSize :: AnnotationSet -> Int
minAnnSetSize :: AnnotationSet -> Int
minAnnSetSize annSet :: AnnotationSet
annSet = [TypeAnn] -> Int
forall t. Container t => t -> Int
length [TypeAnn]
asTypes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [FieldAnn] -> Int
forall t. Container t => t -> Int
length [FieldAnn]
asFields Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [VarAnn] -> Int
forall t. Container t => t -> Int
length [VarAnn]
asVars
  where AnnotationSet {..} = AnnotationSet -> AnnotationSet
minimizeAnnSet AnnotationSet
annSet

-- | Removes all unnecessary 'Annotation's. See 'AnnotationSet'.
minimizeAnnSet :: AnnotationSet -> AnnotationSet
minimizeAnnSet :: AnnotationSet -> AnnotationSet
minimizeAnnSet (AnnotationSet ts :: [TypeAnn]
ts fs :: [FieldAnn]
fs vs :: [VarAnn]
vs) = $WAnnotationSet :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> AnnotationSet
AnnotationSet {..}
  where
    asTypes :: [TypeAnn]
asTypes = [TypeAnn] -> [TypeAnn]
forall k (tag :: k). [Annotation tag] -> [Annotation tag]
trimEndNoAnn [TypeAnn]
ts
    asFields :: [FieldAnn]
asFields = [FieldAnn] -> [FieldAnn]
forall k (tag :: k). [Annotation tag] -> [Annotation tag]
trimEndNoAnn [FieldAnn]
fs
    asVars :: [VarAnn]
asVars = [VarAnn] -> [VarAnn]
forall k (tag :: k). [Annotation tag] -> [Annotation tag]
trimEndNoAnn [VarAnn]
vs

-- | Removes all unnecessary 'Annotation's from a list of the same type
trimEndNoAnn :: [Annotation tag] -> [Annotation tag]
trimEndNoAnn :: [Annotation tag] -> [Annotation tag]
trimEndNoAnn = (Element [Annotation tag] -> [Annotation tag] -> [Annotation tag])
-> [Annotation tag] -> [Annotation tag] -> [Annotation tag]
forall t b. Container t => (Element t -> b -> b) -> b -> t -> b
foldr (\a :: Element [Annotation tag]
a lst :: [Annotation tag]
lst -> if [Annotation tag] -> Bool
forall t. Container t => t -> Bool
null [Annotation tag]
lst Bool -> Bool -> Bool
&& Element [Annotation tag]
Annotation tag
a Annotation tag -> Annotation tag -> Bool
forall a. Eq a => a -> a -> Bool
== Annotation tag
forall k (tag :: k). Annotation tag
noAnn then [] else Element [Annotation tag]
Annotation tag
a Annotation tag -> [Annotation tag] -> [Annotation tag]
forall a. a -> [a] -> [a]
: [Annotation tag]
lst) []

--------------------------------------------------------------------------------
-- Rendering
--------------------------------------------------------------------------------

class Typeable (tag :: Kind.Type) => KnownAnnTag tag where
  annPrefix :: Text

instance KnownAnnTag tag => Show (Annotation tag) where
  show :: Annotation tag -> String
show = Bool -> Doc -> String
printDocS Bool
True (Doc -> String)
-> (Annotation tag -> Doc) -> Annotation tag -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderContext -> Annotation tag -> Doc
forall a. RenderDoc a => RenderContext -> a -> Doc
renderDoc RenderContext
doesntNeedParens

data TypeTag
data FieldTag
data VarTag
data SomeTag

data RootTag

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

-- | Root annotation was added in the Babylon, it looks the same as
-- field annotation, but has slightly different semantic and can be used
-- only in parameter 'ParameterType'.
type RootAnn = Annotation RootTag

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

instance KnownAnnTag tag => RenderDoc (Annotation tag) where
  renderDoc :: RenderContext -> Annotation tag -> Doc
renderDoc _ = Annotation tag -> Doc
forall tag. KnownAnnTag tag => Annotation tag -> Doc
renderAnn

instance KnownAnnTag tag => Buildable (Annotation tag) where
  build :: Annotation tag -> Builder
build = Annotation tag -> Builder
forall a. RenderDoc a => a -> Builder
buildRenderDoc

instance Show AnnotationSet where
  show :: AnnotationSet -> String
show = Bool -> Doc -> String
printDocS Bool
True (Doc -> String)
-> (AnnotationSet -> Doc) -> AnnotationSet -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderContext -> AnnotationSet -> Doc
forall a. RenderDoc a => RenderContext -> a -> Doc
renderDoc RenderContext
doesntNeedParens

instance RenderDoc AnnotationSet where
  renderDoc :: RenderContext -> AnnotationSet -> Doc
renderDoc _ (AnnotationSet {..}) =
    [TypeAnn] -> Doc
forall tag. KnownAnnTag tag => [Annotation tag] -> Doc
renderAnnGroup [TypeAnn]
asTypes Doc -> Doc -> Doc
<+> [FieldAnn] -> Doc
forall tag. KnownAnnTag tag => [Annotation tag] -> Doc
renderAnnGroup [FieldAnn]
asFields Doc -> Doc -> Doc
<+> [VarAnn] -> Doc
forall tag. KnownAnnTag tag => [Annotation tag] -> Doc
renderAnnGroup [VarAnn]
asVars

instance Buildable AnnotationSet where
  build :: AnnotationSet -> Builder
build = AnnotationSet -> Builder
forall a. RenderDoc a => a -> Builder
buildRenderDoc

-- | Renders a single 'Annotation', this is used in every rendering instance of it.
-- Note that this also renders empty ones/'noAnn's because a single 'Annotation'
-- does not have enough context to know if it can be omitted, use 'singleAnnSet'
-- if you want to hide it instead.
renderAnn :: forall tag. KnownAnnTag tag => Annotation tag -> Doc
renderAnn :: Annotation tag -> Doc
renderAnn (Annotation text :: Text
text) = Text -> Doc
textStrict (Text -> Doc) -> Text -> Doc
forall a b. (a -> b) -> a -> b
$ KnownAnnTag tag => Text
forall tag. KnownAnnTag tag => Text
annPrefix @tag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text

-- | Renders a list of 'Annotation's, omitting unnecessary empty ones/'noAnn'.
-- This is used (3 times) to render an 'AnnotationSet'.
renderAnnGroup :: KnownAnnTag tag => [Annotation tag] -> Doc
renderAnnGroup :: [Annotation tag] -> Doc
renderAnnGroup = [Doc] -> Doc
hsep ([Doc] -> Doc)
-> ([Annotation tag] -> [Doc]) -> [Annotation tag] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Annotation tag -> Doc) -> [Annotation tag] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Annotation tag -> Doc
forall tag. KnownAnnTag tag => Annotation tag -> Doc
renderAnn ([Annotation tag] -> [Doc])
-> ([Annotation tag] -> [Annotation tag])
-> [Annotation tag]
-> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Annotation tag] -> [Annotation tag]
forall k (tag :: k). [Annotation tag] -> [Annotation tag]
trimEndNoAnn

--------------------------------------------------------------------------------
-- Creation and conversions
--------------------------------------------------------------------------------

noAnn :: Annotation a
noAnn :: Annotation a
noAnn = Text -> Annotation a
forall k (tag :: k). Text -> Annotation tag
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 :: Text -> Annotation a
ann = (Text -> Annotation a)
-> (Annotation a -> Annotation a)
-> Either Text (Annotation a)
-> Annotation a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Annotation a
forall a. HasCallStack => Text -> a
error Annotation a -> Annotation a
forall a. a -> a
id (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

-- | 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 -> Either Text (Annotation a)
mkAnnotation text :: Text
text
  -- TODO [#48] these are special annotations and should not be always allowed
  | Text
Element [Text]
text Element [Text] -> [Text] -> Bool
forall t. (Container t, Eq (Element t)) => Element t -> t -> Bool
`elem` [Text]
specialVarAnns = Annotation a -> Either Text (Annotation a)
forall a b. b -> Either a b
Right (Annotation a -> Either Text (Annotation a))
-> Annotation a -> Either Text (Annotation a)
forall a b. (a -> b) -> a -> b
$ Text -> Annotation a
forall k (tag :: k). Text -> Annotation tag
AnnotationUnsafe Text
text
  | Text
text Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
specialFieldAnn = Annotation a -> Either Text (Annotation a)
forall a b. b -> Either a b
Right (Annotation a -> Either Text (Annotation a))
-> Annotation a -> Either Text (Annotation a)
forall a b. (a -> b) -> a -> b
$ Text -> Annotation a
forall k (tag :: k). Text -> Annotation tag
AnnotationUnsafe Text
text
  | Bool
otherwise = do
    Text
suffix <- case Text -> Maybe (Char, Text)
T.uncons Text
text of
      Just (h :: Char
h, tl :: Text
tl) | Char -> Bool
isValidAnnStart Char
h -> Text -> Either Text Text
forall a b. b -> Either a b
Right Text
tl
      Just (h :: Char
h, _) -> Text -> Either Text Text
forall a b. a -> Either a b
Left (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Text -> Char -> Text
T.snoc "Invalid first character: " Char
h
      _ -> Text -> Either Text Text
forall a b. b -> Either a b
Right ""
    Either Text (Annotation a)
-> (Char -> Either Text (Annotation a))
-> Maybe Char
-> Either Text (Annotation a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Annotation a -> Either Text (Annotation a)
forall a b. b -> Either a b
Right (Annotation a -> Either Text (Annotation a))
-> Annotation a -> Either Text (Annotation a)
forall a b. (a -> b) -> a -> b
$ Text -> Annotation a
forall k (tag :: k). Text -> Annotation tag
AnnotationUnsafe Text
text) (Text -> Either Text (Annotation a)
forall a b. a -> Either a b
Left (Text -> Either Text (Annotation a))
-> (Char -> Text) -> Char -> Either Text (Annotation a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Char -> Text
T.snoc "Invalid character: ") (Maybe Char -> Either Text (Annotation a))
-> Maybe Char -> Either Text (Annotation a)
forall a b. (a -> b) -> a -> b
$
      (Char -> Bool) -> Text -> Maybe Char
T.find (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isValidAnnBodyChar) Text
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 :: [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 :: 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 :: Char -> Bool
isValidAnnStart x :: Char
x = (Char -> Bool
isAscii Char
x Bool -> Bool -> Bool
&& (Char -> Bool
isAlpha Char
x Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
x)) Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_'

-- | 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 :: Char -> Bool
isValidAnnBodyChar x :: Char
x =
  Char -> Bool
isValidAnnStart Char
x Bool -> Bool -> Bool
|| (Char -> Bool
isAscii Char
x Bool -> Bool -> Bool
&& Char -> Bool
isNumber Char
x) Bool -> Bool -> Bool
||  Char
Element String
x Element String -> String -> Bool
forall t. (Container t, Eq (Element t)) => Element t -> t -> Bool
`elem` (".%@" :: String)

instance Semigroup VarAnn where
  Annotation a :: Text
a <> :: VarAnn -> VarAnn -> VarAnn
<> Annotation b :: Text
b
    | Text
a Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "" Bool -> Bool -> Bool
|| Text
b Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "" = Text -> VarAnn
forall k (a :: k). HasCallStack => Text -> Annotation a
ann (Text -> VarAnn) -> Text -> VarAnn
forall a b. (a -> b) -> a -> b
$ Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b
    | Bool
otherwise          = Text -> VarAnn
forall k (a :: k). HasCallStack => Text -> Annotation a
ann (Text -> VarAnn) -> Text -> VarAnn
forall a b. (a -> b) -> a -> b
$ Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b

instance Monoid VarAnn where
    mempty :: VarAnn
mempty = VarAnn
forall k (tag :: k). Annotation tag
noAnn

unifyAnn :: Annotation tag -> Annotation tag -> Maybe (Annotation tag)
unifyAnn :: Annotation tag -> Annotation tag -> Maybe (Annotation tag)
unifyAnn (Annotation ann1 :: Text
ann1) (Annotation ann2 :: Text
ann2)
  | Text
ann1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "" Bool -> Bool -> Bool
|| Text
ann2 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "" = Annotation tag -> Maybe (Annotation tag)
forall a. a -> Maybe a
Just (Annotation tag -> Maybe (Annotation tag))
-> Annotation tag -> Maybe (Annotation tag)
forall a b. (a -> b) -> a -> b
$ Text -> Annotation tag
forall k (a :: k). HasCallStack => Text -> Annotation a
ann (Text -> Annotation tag) -> Text -> Annotation tag
forall a b. (a -> b) -> a -> b
$ Text
ann1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ann2
  | Text
ann1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
ann2 = Annotation tag -> Maybe (Annotation tag)
forall a. a -> Maybe a
Just (Annotation tag -> Maybe (Annotation tag))
-> Annotation tag -> Maybe (Annotation tag)
forall a b. (a -> b) -> a -> b
$ Text -> Annotation tag
forall k (a :: k). HasCallStack => Text -> Annotation a
ann Text
ann1
  | Bool
otherwise  = Maybe (Annotation tag)
forall a. Maybe a
Nothing

ifAnnUnified :: Annotation tag -> Annotation tag -> Bool
ifAnnUnified :: Annotation tag -> Annotation tag -> Bool
ifAnnUnified a1 :: Annotation tag
a1 a2 :: Annotation tag
a2 = Maybe (Annotation tag) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Annotation tag) -> Bool) -> Maybe (Annotation tag) -> Bool
forall a b. (a -> b) -> a -> b
$ Annotation tag
a1 Annotation tag -> Annotation tag -> Maybe (Annotation tag)
forall k (tag :: k).
Annotation tag -> Annotation tag -> Maybe (Annotation tag)
`unifyAnn` Annotation tag
a2

disjoinVn :: VarAnn -> (VarAnn, VarAnn)
disjoinVn :: VarAnn -> (VarAnn, VarAnn)
disjoinVn (Annotation a :: Text
a) = case (Char -> Bool) -> Text -> Maybe Int
T.findIndex (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.') (Text -> Maybe Int) -> Text -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.reverse Text
a of
  Just ((Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
-) -> Int
pos) -> (Text -> VarAnn
forall k (a :: k). HasCallStack => Text -> Annotation a
ann (Text -> VarAnn) -> Text -> VarAnn
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.take Int
pos Text
a, Text -> VarAnn
forall k (a :: k). HasCallStack => Text -> Annotation a
ann (Text -> VarAnn) -> Text -> VarAnn
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Text
a)
  Nothing                 -> (VarAnn
forall k (tag :: k). Annotation tag
noAnn, Text -> VarAnn
forall k (a :: k). HasCallStack => Text -> Annotation a
ann Text
a)
  where
    n :: Int
n = Text -> Int
T.length Text
a

convAnn :: Annotation tag1 -> Annotation tag2
convAnn :: Annotation tag1 -> Annotation tag2
convAnn (Annotation a :: Text
a) = Text -> Annotation tag2
forall k (a :: k). HasCallStack => Text -> Annotation a
ann Text
a

pattern WithAnn :: Annotation tag -> Annotation tag
pattern $mWithAnn :: forall r k (tag :: k).
Annotation tag -> (Annotation tag -> r) -> (Void# -> r) -> r
WithAnn ann <- ann@(Annotation (toString -> _:_))

deriveJSON morleyAesonOptions ''Annotation
deriveLift ''Annotation