-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

module Lorentz.Entrypoints.Helpers
  ( ctorNameToAnn
  , ctorNameToEp
  , CanHaveEntrypoints
  , ShouldHaveEntrypoints (..)
  , RequireSumType
  ) where

import Morley.AsRPC (HasRPCRepr(..))
import Morley.Michelson.Typed.Haskell
import Morley.Michelson.Typed.T
import Morley.Michelson.Untyped (EpName, FieldAnn, epNameFromParamAnn, mkAnnotation)
import Morley.Util.Text
import Morley.Util.Type
import Morley.Util.TypeLits

ctorNameToAnn :: forall ctor. (KnownSymbol ctor, HasCallStack) => FieldAnn
ctorNameToAnn :: forall (ctor :: Symbol).
(KnownSymbol ctor, HasCallStack) =>
FieldAnn
ctorNameToAnn = Either Text FieldAnn -> FieldAnn
forall a b. (HasCallStack, Buildable a) => Either a b -> b
unsafe (Either Text FieldAnn -> FieldAnn)
-> (Text -> Either Text FieldAnn) -> Text -> FieldAnn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text FieldAnn
forall {k} (a :: k). Text -> Either Text (Annotation a)
mkAnnotation (Text -> Either Text FieldAnn)
-> (Text -> Text) -> Text -> Either Text FieldAnn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text
Text -> Text
headToLower (Text -> FieldAnn) -> Text -> FieldAnn
forall a b. (a -> b) -> a -> b
$ (forall (s :: Symbol). KnownSymbol s => Text
symbolValT' @ctor)

ctorNameToEp :: forall ctor. (KnownSymbol ctor, HasCallStack) => EpName
ctorNameToEp :: forall (ctor :: Symbol). (KnownSymbol ctor, HasCallStack) => EpName
ctorNameToEp =
  FieldAnn -> Maybe EpName
epNameFromParamAnn (forall (ctor :: Symbol).
(KnownSymbol ctor, HasCallStack) =>
FieldAnn
ctorNameToAnn @ctor)
  Maybe EpName -> EpName -> EpName
forall a. Maybe a -> a -> a
?: Text -> EpName
forall a. HasCallStack => Text -> a
error Text
"Empty constructor-entrypoint name"

-- | A special type which wraps over a primitive type and states that it has
-- entrypoints (one).
--
-- Assuming that any type can have entrypoints makes use of Lorentz entrypoints
-- too annoying, so for declaring entrypoints for not sum types we require an
-- explicit wrapper.
newtype ShouldHaveEntrypoints a = ShouldHaveEntrypoints { forall a. ShouldHaveEntrypoints a -> a
unHasEntrypoints :: a }
  deriving stock (forall x.
 ShouldHaveEntrypoints a -> Rep (ShouldHaveEntrypoints a) x)
-> (forall x.
    Rep (ShouldHaveEntrypoints a) x -> ShouldHaveEntrypoints a)
-> Generic (ShouldHaveEntrypoints a)
forall x.
Rep (ShouldHaveEntrypoints a) x -> ShouldHaveEntrypoints a
forall x.
ShouldHaveEntrypoints a -> Rep (ShouldHaveEntrypoints a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x.
Rep (ShouldHaveEntrypoints a) x -> ShouldHaveEntrypoints a
forall a x.
ShouldHaveEntrypoints a -> Rep (ShouldHaveEntrypoints a) x
$cto :: forall a x.
Rep (ShouldHaveEntrypoints a) x -> ShouldHaveEntrypoints a
$cfrom :: forall a x.
ShouldHaveEntrypoints a -> Rep (ShouldHaveEntrypoints a) x
Generic

deriving anyclass instance (WellTypedToT r) => IsoValue (ShouldHaveEntrypoints r)

instance HasRPCRepr a => HasRPCRepr (ShouldHaveEntrypoints a) where
  type AsRPC (ShouldHaveEntrypoints a) = ShouldHaveEntrypoints (AsRPC a)

-- | Used to understand whether a type can potentially declare any entrypoints.
type family CanHaveEntrypoints (p :: Type) :: Bool where
  CanHaveEntrypoints (ShouldHaveEntrypoints _) = 'True
  CanHaveEntrypoints p = CanHaveEntrypointsT (ToT p)

type family CanHaveEntrypointsT (t :: T) :: Bool where
  CanHaveEntrypointsT ('TOr _ _) = 'True
  CanHaveEntrypointsT _ = 'False

-- | Ensure that given type is a sum type.
--
-- This helps to prevent attempts to apply a function to, for instance, a pair.
type family RequireSumType (a :: Type) :: Constraint where
  RequireSumType a =
    FailUnless (CanHaveEntrypoints a)
       ('Text "Expected Michelson sum type" ':$$:
        'Text "In type `" ':<>: 'ShowType a ':<>: 'Text "`"
        )