Annotation.hs

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

{-# LANGUAGE UndecidableSuperClasses #-}

-- | Type and field annotations for Lorentz types.
module Lorentz.Annotation
  ( HasAnnotation (..)
  , GHasAnnotation (..)
  , gGetAnnotationNoField
  , insertTypeAnn
  ) where

import qualified GHC.Generics as G
import Named (NamedF)

import Lorentz.Entrypoints.Helpers (ctorNameToAnn)
import Michelson.Text
import Michelson.Typed
  (BigMap, ContractRef(..), EpAddress, KnownIsoT, Notes(..), Operation, ToT, insertTypeAnn,
  starNotes)
import Michelson.Typed.Haskell.Value (GValueType)
import Michelson.Untyped (FieldAnn, TypeAnn, ann, noAnn)
import Tezos.Address
import Tezos.Core
import Tezos.Crypto
import Util.TypeLits

-- | Use this in the instance of @HasAnnotation@ when field annotations
-- should not be generated.
gGetAnnotationNoField
    :: forall a. (GHasAnnotation (G.Rep a), GValueType (G.Rep a) ~ ToT a) => Notes (ToT a)
gGetAnnotationNoField = fst $ gGetAnnotation @(G.Rep a) False

-- | This class defines the type and field annotations for a given type. Right now
-- the type annotations come from names in a named field, and field annotations are
-- generated from the record fields.
class HasAnnotation a where
  getAnnotation :: Notes (ToT a)
  default getAnnotation
    :: (GHasAnnotation (G.Rep a), GValueType (G.Rep a) ~ ToT a) => Notes (ToT a)
  getAnnotation = fst $ gGetAnnotation @(G.Rep a) True

instance (HasAnnotation a, KnownSymbol name)
  => HasAnnotation (NamedF Identity a name) where
  getAnnotation = insertTypeAnn (symbolAnn @name) $ getAnnotation @a
    where
      symbolAnn :: forall s. KnownSymbol s => TypeAnn
      symbolAnn = ann $ symbolValT' @s

instance (HasAnnotation (Maybe a), KnownSymbol name)
  => HasAnnotation (NamedF Maybe a name) where
  getAnnotation = getAnnotation @(NamedF Identity (Maybe a) name)

-- Primitive instances
instance (HasAnnotation a) => HasAnnotation (Maybe a) where
  getAnnotation = NTOption noAnn (getAnnotation @a)

instance HasAnnotation ()

instance HasAnnotation Integer where
  getAnnotation = starNotes

instance HasAnnotation Natural where
  getAnnotation = starNotes

instance HasAnnotation MText where
  getAnnotation = starNotes

instance HasAnnotation Bool where
  getAnnotation = starNotes

instance HasAnnotation ByteString where
  getAnnotation = starNotes

instance HasAnnotation Mutez where
  getAnnotation = starNotes

instance HasAnnotation Address where
  getAnnotation = starNotes

instance HasAnnotation EpAddress where
  getAnnotation = starNotes

instance HasAnnotation KeyHash where
  getAnnotation = starNotes

instance HasAnnotation Timestamp where
  getAnnotation = starNotes

instance HasAnnotation PublicKey where
  getAnnotation = starNotes

instance HasAnnotation Signature where
  getAnnotation = starNotes

instance (HasAnnotation a) => HasAnnotation (ContractRef a) where
  getAnnotation = NTContract noAnn (getAnnotation @a)

instance (HasAnnotation k, HasAnnotation v) => HasAnnotation (Map k v) where
  getAnnotation = NTMap noAnn (getAnnotation @k) (getAnnotation @v)

instance (HasAnnotation k, HasAnnotation v) => HasAnnotation (BigMap k v) where
  getAnnotation = NTBigMap noAnn (getAnnotation @k) (getAnnotation @v)

instance (KnownIsoT v) => HasAnnotation (Set v) where
  getAnnotation = starNotes

instance (HasAnnotation a) => HasAnnotation [a] where
  getAnnotation = NTList noAnn (getAnnotation @a)

instance HasAnnotation Operation where
  getAnnotation = starNotes

instance (HasAnnotation a, HasAnnotation b) => HasAnnotation (a, b)
instance (HasAnnotation a, HasAnnotation b, HasAnnotation c) => HasAnnotation (a, b, c)
instance (HasAnnotation a, HasAnnotation b, HasAnnotation c, HasAnnotation d) => HasAnnotation (a, b, c, d)
instance (HasAnnotation a, HasAnnotation b, HasAnnotation c, HasAnnotation d, HasAnnotation e)
  => HasAnnotation (a, b, c, d, e)
instance (HasAnnotation a, HasAnnotation b, HasAnnotation c, HasAnnotation d, HasAnnotation e, HasAnnotation f)
  => HasAnnotation (a, b, c, d, e, f)
instance
  ( HasAnnotation a, HasAnnotation b, HasAnnotation c, HasAnnotation d, HasAnnotation e
  , HasAnnotation f, HasAnnotation g)
  => HasAnnotation (a, b, c, d, e, f, g)

-- | A Generic @HasAnnotation@ implementation
class GHasAnnotation a where
  -- | @Bool@ acts as a flag to determine whether or not field annotations
  -- should be set.
  gGetAnnotation :: Bool -> (Notes (GValueType a), FieldAnn)

instance GHasAnnotation G.U1 where
  gGetAnnotation _ = (starNotes, noAnn)

instance (GHasAnnotation x)
  => GHasAnnotation (G.M1 G.S ('G.MetaSel 'Nothing b c d) x)
  where
  gGetAnnotation b = gGetAnnotation @x b

instance (GHasAnnotation x, KnownSymbol a)
  => GHasAnnotation (G.M1 G.S ('G.MetaSel ('Just a) b c d) x)
  where
  gGetAnnotation b = case b of
    True -> (fst $ gGetAnnotation @x b, ctorNameToAnn @a)
    False -> (fst $ gGetAnnotation @x b, noAnn)

instance (GHasAnnotation x) => GHasAnnotation (G.M1 G.C i1 x) where
  gGetAnnotation b = gGetAnnotation @x b

instance (GHasAnnotation x) => GHasAnnotation (G.M1 G.D i1 x) where
  gGetAnnotation b = gGetAnnotation @x b

instance
    ( GHasAnnotation x
    , GHasAnnotation y
    )
  =>
    GHasAnnotation (x G.:+: y)
  where
  gGetAnnotation b =
    ( NTOr noAnn noAnn noAnn
        (fst $ gGetAnnotation @x b)
        (fst $ gGetAnnotation @y b )
    , noAnn
    )

instance
    ( GHasAnnotation x
    , GHasAnnotation y
    )
  =>
    GHasAnnotation (x G.:*: y)
  where
  gGetAnnotation b =
    let  (xTypeAnn, xFieldAnn) = gGetAnnotation @x b
         (yTypeAnn, yFieldAnn) = gGetAnnotation @y b
    in
      ( NTPair noAnn
          xFieldAnn yFieldAnn
          xTypeAnn yTypeAnn
      , noAnn
      )

instance (HasAnnotation x) => GHasAnnotation (G.Rec0 x) where
  gGetAnnotation _ = (getAnnotation @x, noAnn)