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

-- | Michelson annotations in untyped model.

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

  -- * Annotation Set
  , AnnotationSet(..)
  , annsCount
  , emptyAnnSet
  , firstAnn
  , fullAnnSet
  , isNoAnnSet
  , minAnnSetSize
  , secondAnn
  , singleAnnSet
  , singleGroupAnnSet
  , minimizeAnnSet

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

  -- * Creation and conversions
  , noAnn
  , annQ
  , varAnnQ
  , fieldAnnQ
  , typeAnnQ
  , unsafeMkAnnotation
  , mkAnnotation
  , specialVarAnns
  , specialFieldAnn
  , isValidAnnStart
  , isValidAnnBodyChar
  , orAnn
  , unifyAnn
  , unifyPairFieldAnn
  , convergeVarAnns
  , ifAnnUnified
  , 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.Text as T
import Data.Typeable (eqT, (:~:)(..))
import Fmt (Buildable(build))
import Instances.TH.Lift ()
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Lift (deriveLift)
import qualified Language.Haskell.TH.Quote as TH
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 = UnsafeAnnotation { 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))
$cUnsafeAnnotation :: 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)

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 <- UnsafeAnnotation ann

{-# COMPLETE Annotation :: Annotation #-}

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

data VarAnns
  = OneVarAnn VarAnn
  | TwoVarAnns VarAnn VarAnn
  deriving stock ((forall x. VarAnns -> Rep VarAnns x)
-> (forall x. Rep VarAnns x -> VarAnns) -> Generic VarAnns
forall x. Rep VarAnns x -> VarAnns
forall x. VarAnns -> Rep VarAnns x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep VarAnns x -> VarAnns
$cfrom :: forall x. VarAnns -> Rep VarAnns x
Generic, Int -> VarAnns -> ShowS
[VarAnns] -> ShowS
VarAnns -> String
(Int -> VarAnns -> ShowS)
-> (VarAnns -> String) -> ([VarAnns] -> ShowS) -> Show VarAnns
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VarAnns] -> ShowS
$cshowList :: [VarAnns] -> ShowS
show :: VarAnns -> String
$cshow :: VarAnns -> String
showsPrec :: Int -> VarAnns -> ShowS
$cshowsPrec :: Int -> VarAnns -> ShowS
Show)
  deriving anyclass (VarAnns -> ()
(VarAnns -> ()) -> NFData VarAnns
forall a. (a -> ()) -> NFData a
rnf :: VarAnns -> ()
$crnf :: VarAnns -> ()
NFData)

--------------------------------------------------------------------------------
-- 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 [TypeAnn]
ts1 [FieldAnn]
fs1 [VarAnn]
vs1) <> :: AnnotationSet -> AnnotationSet -> AnnotationSet
<> (AnnotationSet [TypeAnn]
ts2 [FieldAnn]
fs2 [VarAnn]
vs2) = AnnotationSet :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> AnnotationSet
AnnotationSet {[VarAnn]
[FieldAnn]
[TypeAnn]
asVars :: [VarAnn]
asFields :: [FieldAnn]
asTypes :: [TypeAnn]
asVars :: [VarAnn]
asFields :: [FieldAnn]
asTypes :: [TypeAnn]
..}
    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 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 [Annotation tag]
ans = AnnotationSet :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> AnnotationSet
AnnotationSet {[VarAnn]
[FieldAnn]
[TypeAnn]
asVars :: [VarAnn]
asFields :: [FieldAnn]
asTypes :: [TypeAnn]
asVars :: [VarAnn]
asFields :: [FieldAnn]
asTypes :: [TypeAnn]
..}
  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 tag :~: TypeTag
Refl -> [Annotation tag]
[TypeAnn]
ans; Maybe (tag :~: TypeTag)
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 tag :~: FieldTag
Refl -> [Annotation tag]
[FieldAnn]
ans; Maybe (tag :~: FieldTag)
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 tag :~: VarTag
Refl -> [Annotation tag]
[VarAnn]
ans; Maybe (tag :~: VarTag)
Nothing -> []

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

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

-- | Removes all unnecessary 'Annotation's. See 'AnnotationSet'.
minimizeAnnSet :: AnnotationSet -> AnnotationSet
minimizeAnnSet :: AnnotationSet -> AnnotationSet
minimizeAnnSet (AnnotationSet [TypeAnn]
ts [FieldAnn]
fs [VarAnn]
vs) = AnnotationSet :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> AnnotationSet
AnnotationSet {[VarAnn]
[FieldAnn]
[TypeAnn]
asVars :: [VarAnn]
asFields :: [FieldAnn]
asTypes :: [TypeAnn]
asVars :: [VarAnn]
asFields :: [FieldAnn]
asTypes :: [TypeAnn]
..}
  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 (\Element [Annotation tag]
a [Annotation tag]
lst -> if [Annotation tag] -> Bool
forall t. Container t => t -> Bool
null [Annotation tag]
lst Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
&& 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) []

-- | Returns the number of annotations in 'AnnotationSet' for each type.
annsCount :: AnnotationSet -> (Int, Int, Int)
annsCount :: AnnotationSet -> (Int, Int, Int)
annsCount (AnnotationSet [TypeAnn]
tas [FieldAnn]
fas [VarAnn]
vas) = ([TypeAnn] -> Int
forall t. Container t => t -> Int
length [TypeAnn]
tas, [FieldAnn] -> Int
forall t. Container t => t -> Int
length [FieldAnn]
fas, [VarAnn] -> Int
forall t. Container t => t -> Int
length [VarAnn]
vas)

-- | Returns the first annotation in a list of annotations of a specific type
-- in 'AnnotationSet', or 'noAnn' if this list is empty.
firstAnn :: (KnownAnnTag tag) => AnnotationSet -> Annotation tag
firstAnn :: AnnotationSet -> Annotation tag
firstAnn = ([Annotation tag] -> Annotation tag)
-> AnnotationSet -> Annotation tag
forall tag.
KnownAnnTag tag =>
([Annotation tag] -> Annotation tag)
-> AnnotationSet -> Annotation tag
getAnn (\case [] -> Annotation tag
forall k (tag :: k). Annotation tag
noAnn; Annotation tag
a : [Annotation tag]
_ -> Annotation tag
a)

-- | Returns the second annotation in a list of annotations of a specific type
-- in 'AnnotationSet', or 'noAnn' if this list contains less than 2 elements.
secondAnn :: (KnownAnnTag tag) => AnnotationSet -> Annotation tag
secondAnn :: AnnotationSet -> Annotation tag
secondAnn = ([Annotation tag] -> Annotation tag)
-> AnnotationSet -> Annotation tag
forall tag.
KnownAnnTag tag =>
([Annotation tag] -> Annotation tag)
-> AnnotationSet -> Annotation tag
getAnn (\case [] -> Annotation tag
forall k (tag :: k). Annotation tag
noAnn; [Annotation tag
_] -> Annotation tag
forall k (tag :: k). Annotation tag
noAnn; Annotation tag
_ : Annotation tag
a : [Annotation tag]
_ -> Annotation tag
a)

-- | Retrieves an annotation of a specific type from 'AnnotationSet' using
-- the passed function.
getAnn :: forall tag. (KnownAnnTag tag)
       => ([Annotation tag] -> Annotation tag)
       -> AnnotationSet
       -> Annotation tag
getAnn :: ([Annotation tag] -> Annotation tag)
-> AnnotationSet -> Annotation tag
getAnn [Annotation tag] -> Annotation tag
getter AnnotationSet
annSet = 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 tag :~: TypeTag
Refl -> [Annotation tag] -> Annotation tag
getter ([Annotation tag] -> Annotation tag)
-> [Annotation tag] -> Annotation tag
forall a b. (a -> b) -> a -> b
$ AnnotationSet -> [TypeAnn]
asTypes AnnotationSet
annSet
  Maybe (tag :~: TypeTag)
Nothing -> 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 tag :~: FieldTag
Refl -> [Annotation tag] -> Annotation tag
getter ([Annotation tag] -> Annotation tag)
-> [Annotation tag] -> Annotation tag
forall a b. (a -> b) -> a -> b
$ AnnotationSet -> [FieldAnn]
asFields AnnotationSet
annSet
    Maybe (tag :~: FieldTag)
Nothing -> 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 tag :~: VarTag
Refl -> [Annotation tag] -> Annotation tag
getter ([Annotation tag] -> Annotation tag)
-> [Annotation tag] -> Annotation tag
forall a b. (a -> b) -> a -> b
$ AnnotationSet -> [VarAnn]
asVars AnnotationSet
annSet
      Maybe (tag :~: VarTag)
Nothing -> Text -> Annotation tag
forall a. HasCallStack => Text -> a
error Text
"Impossible"

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

class Typeable (tag :: 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

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

-- | Field annotation for the entire parameter.
type RootAnn = Annotation FieldTag

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

instance KnownAnnTag tag => RenderDoc (Annotation tag) where
  renderDoc :: RenderContext -> Annotation tag -> Doc
renderDoc RenderContext
_ = 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 RenderContext
_ (AnnotationSet {[VarAnn]
[FieldAnn]
[TypeAnn]
asVars :: [VarAnn]
asFields :: [FieldAnn]
asTypes :: [TypeAnn]
asVars :: AnnotationSet -> [VarAnn]
asFields :: AnnotationSet -> [FieldAnn]
asTypes :: AnnotationSet -> [TypeAnn]
..}) =
    [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 -> 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
UnsafeAnnotation Text
""

-- | Makes an `Annotation` from its textual value, prefix (%/@/:) excluded
-- Throws an error if the given `Text` contains invalid characters
unsafeMkAnnotation :: HasCallStack => Text -> Annotation a
unsafeMkAnnotation :: Text -> Annotation a
unsafeMkAnnotation = (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
  -- 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
UnsafeAnnotation 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
UnsafeAnnotation Text
text
  | Bool
otherwise = do
    Text
suffix <- case Text -> Maybe (Char, Text)
T.uncons Text
text of
      Just (Char
h, Text
tl) | Char -> Bool
isValidAnnStart Char
h -> Text -> Either Text Text
forall a b. b -> Either a b
Right Text
tl
      Just (Char
h, Text
_) -> 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
"Invalid first character: '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> OneItem Text -> Text
forall x. One x => OneItem x -> x
one Char
OneItem Text
h Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
      Maybe (Char, Text)
_ -> Text -> Either Text Text
forall a b. b -> Either a b
Right Text
""
    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
UnsafeAnnotation Text
text) (\Char
c -> Text -> Either Text (Annotation a)
forall a b. a -> Either a b
Left (Text -> Either Text (Annotation a))
-> Text -> Either Text (Annotation a)
forall a b. (a -> b) -> a -> b
$ Text
"Invalid character: '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> OneItem Text -> Text
forall x. One x => OneItem x -> x
one Char
OneItem Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'") (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

-- |
-- >>> :t [annQ|abc|]
-- ...
-- ... :: forall k (tag :: k). Annotation tag
annQ :: TH.QuasiQuoter
annQ :: QuasiQuoter
annQ = Maybe TypeQ -> QuasiQuoter
annQImpl Maybe TypeQ
forall a. Maybe a
Nothing

-- |
-- >>> :t [typeAnnQ|abc|]
-- ...
-- ... :: TypeAnn
typeAnnQ :: TH.QuasiQuoter
typeAnnQ :: QuasiQuoter
typeAnnQ = Maybe TypeQ -> QuasiQuoter
annQImpl (TypeQ -> Maybe TypeQ
forall a. a -> Maybe a
Just [t|TypeAnn|])

-- |
-- >>> :t [fieldAnnQ|abc|]
-- ...
-- ... :: FieldAnn
fieldAnnQ :: TH.QuasiQuoter
fieldAnnQ :: QuasiQuoter
fieldAnnQ = Maybe TypeQ -> QuasiQuoter
annQImpl (TypeQ -> Maybe TypeQ
forall a. a -> Maybe a
Just [t|FieldAnn|])

-- |
-- >>> :t [varAnnQ|abc|]
-- ...
-- ... :: VarAnn
varAnnQ :: TH.QuasiQuoter
varAnnQ :: QuasiQuoter
varAnnQ = Maybe TypeQ -> QuasiQuoter
annQImpl (TypeQ -> Maybe TypeQ
forall a. a -> Maybe a
Just [t|VarAnn|])

annQImpl :: Maybe TH.TypeQ -> TH.QuasiQuoter
annQImpl :: Maybe TypeQ -> QuasiQuoter
annQImpl Maybe TypeQ
annTypeMb = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> TypeQ)
-> (String -> Q [Dec])
-> QuasiQuoter
TH.QuasiQuoter
  {
    quoteExp :: String -> Q Exp
TH.quoteExp = \String
s ->
      case (Text -> Either Text (Annotation Any)
forall k (a :: k). Text -> Either Text (Annotation a)
mkAnnotation (Text -> Either Text (Annotation Any))
-> Text -> Either Text (Annotation Any)
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText @String String
s) of
        Left Text
err -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. ToString a => a -> String
toString Text
err
        Right Annotation Any
_ -> case Maybe TypeQ
annTypeMb of
          Maybe TypeQ
Nothing -> [e| (UnsafeAnnotation s) |]
          Just TypeQ
annType -> [e| (UnsafeAnnotation s :: $(annType)) |]
  , quotePat :: String -> Q Pat
TH.quotePat = \String
s ->
       case (Text -> Either Text (Annotation Any)
forall k (a :: k). Text -> Either Text (Annotation a)
mkAnnotation (Text -> Either Text (Annotation Any))
-> Text -> Either Text (Annotation Any)
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText @String String
s) of
         Left Text
err -> String -> Q Pat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Pat) -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. ToString a => a -> String
toString Text
err
         Right Annotation Any
_ -> case Maybe TypeQ
annTypeMb of
           Maybe TypeQ
Nothing -> [p| UnsafeAnnotation $(TH.litP $ TH.StringL s) |]
           Just TypeQ
annType -> [p| (UnsafeAnnotation $(TH.litP $ TH.StringL s) :: $(annType)) |]
  , quoteType :: String -> TypeQ
TH.quoteType = \String
_ -> String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot use this QuasiQuoter at type position"
  , quoteDec :: String -> Q [Dec]
TH.quoteDec = \String
_  -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot use this QuasiQuoter at declaration position"
  }

-- | 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 = [Text
"%%",Text
"%"]

-- | 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 = Text
"@"


-- | 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 Char
x = (Char -> Bool
isAscii Char
x Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
&& (Char -> Bool
isAlpha Char
x Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
|| Char -> Bool
isDigit Char
x)) Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'

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

instance Semigroup VarAnn where
  Annotation Text
a <> :: VarAnn -> VarAnn -> VarAnn
<> Annotation Text
b
    | Text
a Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"" Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
|| Text
b Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"" = Text -> VarAnn
forall k (tag :: k). Text -> Annotation tag
UnsafeAnnotation (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 (tag :: k). Text -> Annotation tag
UnsafeAnnotation (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 -> 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

-- | Returns the first annotation if it's not empty, or the second one otherwise.
--
-- > "a" `orAnn` "b" == "a"
-- > "a" `orAnn` ""  == "a"
-- > ""  `orAnn` "b" == "b"
-- > ""  `orAnn` ""  == ""
orAnn :: Annotation t -> Annotation t -> Annotation t
orAnn :: Annotation t -> Annotation t -> Annotation t
orAnn Annotation t
a Annotation t
b = Annotation t -> Annotation t -> Bool -> Annotation t
forall a. a -> a -> Bool -> a
bool Annotation t
a Annotation t
b (Annotation t
a Annotation t -> Annotation t -> Bool
forall a. Eq a => a -> a -> Bool
== Annotation t
forall a. Default a => a
def)

-- | Given two type or field annotations, attempt to converge them by joining
-- these annotations with the following rule:
-- 1. If either annotation is empty, an empty annotation is returned;
-- 2. If both annotations are equal, return this annotation;
-- 3. Otherwise, returns 'Nothing'.
--
-- This function is used primarily for type-checking and attempts to imitate the
-- reference implementation's observed behavior with annotations.
unifyAnn :: Annotation tag -> Annotation tag -> Maybe (Annotation tag)
unifyAnn :: Annotation tag -> Annotation tag -> Maybe (Annotation tag)
unifyAnn a :: Annotation tag
a@(Annotation Text
ann1) (Annotation Text
ann2)
  | Text
ann1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"" Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
|| Text
ann2 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"" = Annotation tag -> Maybe (Annotation tag)
forall a. a -> Maybe a
Just Annotation tag
forall k (tag :: k). Annotation tag
noAnn
  | 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
$ Annotation tag
a
  | Bool
otherwise  = Maybe (Annotation tag)
forall a. Maybe a
Nothing

-- | Given two field annotations where one of them is used in CAR or CDR,
-- attempt to converge them by joining these annotations with the following rule:
-- 1. If either annotation is empty, return the non-empty one (or empty if both are empty);
-- 2. If both annotations are equal, return this annotation;
-- 3. Otherwise, returns 'Nothing'.
--
-- This function is used primarily for type-checking and attempts to imitate the
-- reference implementation's observed behavior with field annotations when CAR
-- and CDR are used with pairs.
unifyPairFieldAnn :: FieldAnn -> FieldAnn -> Maybe FieldAnn
unifyPairFieldAnn :: FieldAnn -> FieldAnn -> Maybe FieldAnn
unifyPairFieldAnn a1 :: FieldAnn
a1@(Annotation Text
ann1) a2 :: FieldAnn
a2@(Annotation Text
ann2)
  | Text
ann1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"" Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
|| Text
ann2 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"" = FieldAnn -> Maybe FieldAnn
forall a. a -> Maybe a
Just (FieldAnn -> Maybe FieldAnn) -> FieldAnn -> Maybe FieldAnn
forall a b. (a -> b) -> a -> b
$ FieldAnn
a1 FieldAnn -> FieldAnn -> FieldAnn
forall k (t :: k). Annotation t -> Annotation t -> Annotation t
`orAnn` FieldAnn
a2
  | Text
ann1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
ann2 = FieldAnn -> Maybe FieldAnn
forall a. a -> Maybe a
Just FieldAnn
a1
  | Bool
otherwise = Maybe FieldAnn
forall a. Maybe a
Nothing

-- | Keeps an annotation if and only if the two of them are equal and returns an
-- empty annotation otherwise.
convergeVarAnns :: VarAnn -> VarAnn -> VarAnn
convergeVarAnns :: VarAnn -> VarAnn -> VarAnn
convergeVarAnns VarAnn
ann1 VarAnn
ann2
  | VarAnn
ann1 VarAnn -> VarAnn -> Bool
forall a. Eq a => a -> a -> Bool
== VarAnn
ann2 = VarAnn
ann1
  | Bool
otherwise    = VarAnn
forall k (tag :: k). Annotation tag
noAnn

ifAnnUnified :: Annotation tag -> Annotation tag -> Bool
ifAnnUnified :: Annotation tag -> Annotation tag -> Bool
ifAnnUnified Annotation tag
a1 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

convAnn :: Annotation tag1 -> Annotation tag2
convAnn :: Annotation tag1 -> Annotation tag2
convAnn (Annotation Text
a) = Text -> Annotation tag2
forall k (tag :: k). Text -> Annotation tag
UnsafeAnnotation 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