{-# LANGUAGE AllowAmbiguousTypes      #-}
{-# LANGUAGE DataKinds                #-}
{-# LANGUAGE DerivingStrategies       #-}
{-# LANGUAGE FlexibleContexts         #-}
{-# LANGUAGE FlexibleInstances        #-}
{-# LANGUAGE GADTs                    #-}
{-# LANGUAGE MultiParamTypeClasses    #-}
{-# LANGUAGE PolyKinds                #-}
{-# LANGUAGE RankNTypes               #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications         #-}
{-# LANGUAGE TypeFamilies             #-}
{-# LANGUAGE TypeOperators            #-}
{-# LANGUAGE UndecidableInstances     #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}

-- | This module provides a functionality to derive and reference schema definitions.
module PlutusTx.Blueprint.Definition.Internal (
  Definitions (..),
  Definition (..),
  definition,
  definitionRef,
  addDefinition,
  definitionsToMap,
  HasSchemaDefinition,
) where

import Prelude

import Data.Kind (Constraint, Type)
import Data.Map (Map)
import Data.Map qualified as Map
import GHC.TypeLits qualified as GHC
import PlutusTx.Blueprint.Class (HasSchema, schema)
import PlutusTx.Blueprint.Definition.Id (AsDefinitionId (..), DefinitionId)
import PlutusTx.Blueprint.Schema (Schema (..))

-- | A schema definition of a type @t@ with a list of referenced types @ts@.
data Definition t ts = MkDefinition DefinitionId (Schema ts)
  deriving stock (Int -> Definition t ts -> ShowS
[Definition t ts] -> ShowS
Definition t ts -> String
(Int -> Definition t ts -> ShowS)
-> (Definition t ts -> String)
-> ([Definition t ts] -> ShowS)
-> Show (Definition t ts)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (t :: k) (ts :: [*]). Int -> Definition t ts -> ShowS
forall k (t :: k) (ts :: [*]). [Definition t ts] -> ShowS
forall k (t :: k) (ts :: [*]). Definition t ts -> String
$cshowsPrec :: forall k (t :: k) (ts :: [*]). Int -> Definition t ts -> ShowS
showsPrec :: Int -> Definition t ts -> ShowS
$cshow :: forall k (t :: k) (ts :: [*]). Definition t ts -> String
show :: Definition t ts -> String
$cshowList :: forall k (t :: k) (ts :: [*]). [Definition t ts] -> ShowS
showList :: [Definition t ts] -> ShowS
Show)

-- | A registry of schema definitions.
data Definitions (ts :: [Type]) where
  NoDefinitions :: Definitions '[]
  AddDefinition :: Definition t ts -> Definitions ts -> Definitions (t ': ts)

deriving stock instance Show (Definitions ts)

-- | Add a schema definition to a registry.
addDefinition :: Definitions ts -> Definition t ts -> Definitions (t ': ts)
addDefinition :: forall (ts :: [*]) t.
Definitions ts -> Definition t ts -> Definitions (t : ts)
addDefinition Definitions ts
NoDefinitions Definition t ts
d       = Definition t ts -> Definitions ts -> Definitions (t : ts)
forall t (ts :: [*]).
Definition t ts -> Definitions ts -> Definitions (t : ts)
AddDefinition Definition t ts
d Definitions ts
Definitions '[]
NoDefinitions
addDefinition (AddDefinition Definition t ts
t Definitions ts
s) Definition t ts
d = Definition t ts -> Definitions ts -> Definitions (t : ts)
forall t (ts :: [*]).
Definition t ts -> Definitions ts -> Definitions (t : ts)
AddDefinition Definition t ts
d (Definition t ts -> Definitions ts -> Definitions (t : ts)
forall t (ts :: [*]).
Definition t ts -> Definitions ts -> Definitions (t : ts)
AddDefinition Definition t ts
t Definitions ts
s)

definitionsToMap :: Definitions ts -> (forall xs. Schema xs -> v) -> Map DefinitionId v
definitionsToMap :: forall (ts :: [*]) v.
Definitions ts
-> (forall (xs :: [*]). Schema xs -> v) -> Map DefinitionId v
definitionsToMap Definitions ts
NoDefinitions forall (xs :: [*]). Schema xs -> v
_k = Map DefinitionId v
forall k a. Map k a
Map.empty
definitionsToMap (AddDefinition (MkDefinition DefinitionId
defId Schema ts
v) Definitions ts
s) forall (xs :: [*]). Schema xs -> v
k =
  DefinitionId -> v -> Map DefinitionId v -> Map DefinitionId v
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert DefinitionId
defId (Schema ts -> v
forall (xs :: [*]). Schema xs -> v
k Schema ts
v) (Definitions ts
-> (forall (xs :: [*]). Schema xs -> v) -> Map DefinitionId v
forall (ts :: [*]) v.
Definitions ts
-> (forall (xs :: [*]). Schema xs -> v) -> Map DefinitionId v
definitionsToMap Definitions ts
s Schema xs -> v
forall (xs :: [*]). Schema xs -> v
k)

-- | Construct a schema definition.
definition :: forall t ts. (AsDefinitionId t, HasSchema t ts) => Definition t ts
definition :: forall t (ts :: [*]).
(AsDefinitionId t, HasSchema t ts) =>
Definition t ts
definition = DefinitionId -> Schema ts -> Definition t ts
forall {k} (t :: k) (ts :: [*]).
DefinitionId -> Schema ts -> Definition t ts
MkDefinition (forall a. AsDefinitionId a => DefinitionId
forall {k} (a :: k). AsDefinitionId a => DefinitionId
definitionId @t) (forall t (referencedTypes :: [*]).
HasSchema t referencedTypes =>
Schema referencedTypes
schema @t)

-- | Construct a schema that is a reference to a schema definition.
definitionRef :: forall t ts. (AsDefinitionId t, HasSchemaDefinition t ts) => Schema ts
definitionRef :: forall t (ts :: [*]).
(AsDefinitionId t, HasSchemaDefinition t ts) =>
Schema ts
definitionRef = DefinitionId -> Schema ts
forall (referencedTypes :: [*]).
DefinitionId -> Schema referencedTypes
SchemaDefinitionRef (forall a. AsDefinitionId a => DefinitionId
forall {k} (a :: k). AsDefinitionId a => DefinitionId
definitionId @t)

{- |
  A constraint that checks if a schema definition is present in a list of schema definitions.
  Gives a user-friendly error message if the schema definition is not found.
-}
type HasSchemaDefinition :: Type -> k -> Constraint
type family HasSchemaDefinition n xs where
  HasSchemaDefinition x (x ': xs) = ()
  HasSchemaDefinition x (_ ': xs) = HasSchemaDefinition x xs
  HasSchemaDefinition n xs =
    GHC.TypeError
      ( GHC.ShowType n
          GHC.:<>: GHC.Text " type was not found in the list of types having schema definitions."
      )