{-# LANGUAGE AllowAmbiguousTypes      #-}
{-# LANGUAGE ConstraintKinds          #-}
{-# LANGUAGE DataKinds                #-}
{-# LANGUAGE DerivingStrategies       #-}
{-# LANGUAGE FlexibleContexts         #-}
{-# LANGUAGE FlexibleInstances        #-}
{-# LANGUAGE GADTs                    #-}
{-# LANGUAGE MultiParamTypeClasses    #-}
{-# LANGUAGE PolyKinds                #-}
{-# LANGUAGE RankNTypes               #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# 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 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.Definition.Id (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 where
  NoDefinitions :: Definitions ts
  AddDefinition :: Definition t ts -> Definitions ts -> Definitions ts

deriving stock instance Show (Definitions ts)

-- | Add a schema definition to a registry.
addDefinition :: Definitions ts -> Definition t ts -> Definitions ts
addDefinition :: forall {k} (ts :: [*]) (t :: k).
Definitions ts -> Definition t ts -> Definitions ts
addDefinition Definitions ts
NoDefinitions Definition t ts
d       = Definition t ts -> Definitions ts -> Definitions ts
forall {k} (t :: k) (ts :: [*]).
Definition t ts -> Definitions ts -> Definitions ts
AddDefinition Definition t ts
d Definitions ts
forall (ts :: [*]). Definitions ts
NoDefinitions
addDefinition (AddDefinition Definition t ts
t Definitions ts
s) Definition t ts
d = Definition t ts -> Definitions ts -> Definitions ts
forall {k} (t :: k) (ts :: [*]).
Definition t ts -> Definitions ts -> Definitions ts
AddDefinition Definition t ts
d (Definition t ts -> Definitions ts -> Definitions ts
forall {k} (t :: k) (ts :: [*]).
Definition t ts -> Definitions ts -> Definitions 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)

{- |
  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 t ts = HasSchemaDefinition' t ts ts

type HasSchemaDefinition' :: Type -> [Type] -> [Type] -> Constraint
type family HasSchemaDefinition' n xs xs0 where
  HasSchemaDefinition' x (x ': xs) _ = ()
  HasSchemaDefinition' x (_ ': xs) xs0 = HasSchemaDefinition' x xs xs0
  HasSchemaDefinition' n xs xs0 =
    GHC.TypeError
      ( GHC.ShowType n
          GHC.:<>: GHC.Text " type was not found in the list of types having schema definitions: "
          GHC.:<>: GHC.ShowType xs0
      )