{-# LANGUAGE CPP              #-}
{-# LANGUAGE EmptyCase        #-}
{-# LANGUAGE LambdaCase       #-}
{-# LANGUAGE NamedFieldPuns   #-}
{-# LANGUAGE RecordWildCards  #-}
{-# LANGUAGE TemplateHaskell  #-}
{-# LANGUAGE TupleSections    #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns     #-}

module PlutusTx.Blueprint.TH where

import Prelude

import Data.Data (Data)
import Data.List (nub)
import Data.List.NonEmpty qualified as NE
import Data.Set (Set)
import Data.Text qualified as Text
import GHC.Natural (naturalToInteger)
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Datatype qualified as TH
import Numeric.Natural (Natural)
import PlutusPrelude (for, join, (<&>), (<<$>>))
import PlutusTx.Blueprint.Argument (ArgumentBlueprint (..))
import PlutusTx.Blueprint.Class (HasBlueprintSchema (..))
import PlutusTx.Blueprint.Definition.Internal (HasSchemaDefinition)
import PlutusTx.Blueprint.Definition.Unroll (HasBlueprintDefinition)
import PlutusTx.Blueprint.Parameter (ParameterBlueprint (..))
import PlutusTx.Blueprint.Purpose (Purpose)
import PlutusTx.Blueprint.Schema (ConstructorSchema (..), Schema (..))
import PlutusTx.Blueprint.Schema.Annotation (SchemaAnn (..), SchemaComment, SchemaDescription,
                                             SchemaInfo (..), SchemaTitle, annotationsToSchemaInfo,
                                             schemaDescriptionToString, schemaTitleToString)
import PlutusTx.IsData.TH (makeIsDataIndexed)

{- |
  Generate a 'ToData', 'FromData', 'UnsafeFromData', 'HasBlueprintSchema' instances for a type,
  using an explicit mapping of constructor names to indices.
  Use this for types where you need to keep the representation stable.
-}
makeIsDataSchemaIndexed :: TH.Name -> [(TH.Name, Natural)] -> TH.Q [TH.InstanceDec]
makeIsDataSchemaIndexed :: Name -> [(Name, Natural)] -> Q [InstanceDec]
makeIsDataSchemaIndexed Name
dataTypeName [(Name, Natural)]
indices = do
  [InstanceDec]
dataInstances <- Name -> [(Name, Int)] -> Q [InstanceDec]
makeIsDataIndexed Name
dataTypeName ((Natural -> Int) -> (Name, Natural) -> (Name, Int)
forall a b. (a -> b) -> (Name, a) -> (Name, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Name, Natural) -> (Name, Int))
-> [(Name, Natural)] -> [(Name, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Natural)]
indices)
  [InstanceDec]
hasSchemaInstance <- Name -> [(Name, Natural)] -> Q [InstanceDec]
makeHasSchemaInstance Name
dataTypeName [(Name, Natural)]
indices
  [InstanceDec] -> Q [InstanceDec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([InstanceDec] -> Q [InstanceDec])
-> [InstanceDec] -> Q [InstanceDec]
forall a b. (a -> b) -> a -> b
$ [InstanceDec]
hasSchemaInstance [InstanceDec] -> [InstanceDec] -> [InstanceDec]
forall a. [a] -> [a] -> [a]
++ [InstanceDec]
dataInstances

unstableMakeIsDataSchema :: TH.Name -> TH.Q [TH.Dec]
unstableMakeIsDataSchema :: Name -> Q [InstanceDec]
unstableMakeIsDataSchema Name
name = do
  DatatypeInfo
info <- Name -> Q DatatypeInfo
TH.reifyDatatype Name
name
  let defaultIndex :: [(Name, Natural)]
defaultIndex = [Name] -> [Natural] -> [(Name, Natural)]
forall a b. [a] -> [b] -> [(a, b)]
zip (ConstructorInfo -> Name
TH.constructorName (ConstructorInfo -> Name) -> [ConstructorInfo] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatatypeInfo -> [ConstructorInfo]
TH.datatypeCons DatatypeInfo
info) [Natural
0..]
  Name -> [(Name, Natural)] -> Q [InstanceDec]
makeIsDataSchemaIndexed Name
name [(Name, Natural)]
defaultIndex

makeHasSchemaInstance :: TH.Name -> [(TH.Name, Natural)] -> TH.Q [TH.InstanceDec]
makeHasSchemaInstance :: Name -> [(Name, Natural)] -> Q [InstanceDec]
makeHasSchemaInstance Name
dataTypeName [(Name, Natural)]
indices = do
  DatatypeInfo
dataTypeInfo <- Name -> Q DatatypeInfo
TH.reifyDatatype Name
dataTypeName
  let appliedType :: Type
appliedType = DatatypeInfo -> Type
TH.datatypeType DatatypeInfo
dataTypeInfo
  let nonOverlapInstance :: Cxt -> Type -> [InstanceDec] -> InstanceDec
nonOverlapInstance = Maybe Overlap -> Cxt -> Type -> [InstanceDec] -> InstanceDec
TH.InstanceD Maybe Overlap
forall a. Maybe a
Nothing

  -- Lookup indices for all constructors of a data type.
  [(ConstructorInfo, SchemaInfo, Natural)]
indexedCons :: [(TH.ConstructorInfo, SchemaInfo, Natural)] <- do
    [ConstructorInfo]
-> (ConstructorInfo -> Q (ConstructorInfo, SchemaInfo, Natural))
-> Q [(ConstructorInfo, SchemaInfo, Natural)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (DatatypeInfo -> [ConstructorInfo]
TH.datatypeCons DatatypeInfo
dataTypeInfo) ((ConstructorInfo -> Q (ConstructorInfo, SchemaInfo, Natural))
 -> Q [(ConstructorInfo, SchemaInfo, Natural)])
-> (ConstructorInfo -> Q (ConstructorInfo, SchemaInfo, Natural))
-> Q [(ConstructorInfo, SchemaInfo, Natural)]
forall a b. (a -> b) -> a -> b
$ \ConstructorInfo
ctorInfo -> do
      let ctorName :: Name
ctorName = ConstructorInfo -> Name
TH.constructorName ConstructorInfo
ctorInfo
      case Name -> [(Name, Natural)] -> Maybe Natural
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
ctorName [(Name, Natural)]
indices of
        Maybe Natural
Nothing -> String -> Q (ConstructorInfo, SchemaInfo, Natural)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (ConstructorInfo, SchemaInfo, Natural))
-> String -> Q (ConstructorInfo, SchemaInfo, Natural)
forall a b. (a -> b) -> a -> b
$ String
"No index given for constructor " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show (ConstructorInfo -> Name
TH.constructorName ConstructorInfo
ctorInfo)
        Just Natural
index -> do
          [SchemaAnn]
ctorSchemaAnns <- Name -> Q [SchemaAnn]
lookupSchemaAnns Name
ctorName
          SchemaInfo
schemaInfo <- [SchemaAnn] -> Q SchemaInfo
schemaInfoFromAnns [SchemaAnn]
ctorSchemaAnns
          (ConstructorInfo, SchemaInfo, Natural)
-> Q (ConstructorInfo, SchemaInfo, Natural)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConstructorInfo
ctorInfo, SchemaInfo
schemaInfo, Natural
index)

  let referencedTypes :: Type
referencedTypes = Name -> Type
TH.VarT (String -> Name
TH.mkName String
"referencedTypes")

  -- Generate constraints for the instance.
  let constraints :: Cxt
constraints =
        Cxt -> Cxt
forall a. Eq a => [a] -> [a]
nub (Cxt -> Cxt) -> ([Cxt] -> Cxt) -> [Cxt] -> Cxt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Cxt] -> Cxt
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([Cxt] -> Cxt) -> [Cxt] -> Cxt
forall a b. (a -> b) -> a -> b
$
          -- Every type in the constructor fields must have a schema definition.
          [ ( case Type
fieldType of
                TH.VarT {} -> (Name -> Cxt -> Type
TH.classPred ''HasBlueprintDefinition [Type
fieldType] Type -> Cxt -> Cxt
forall a. a -> [a] -> [a]
:)
                Type
_          -> Cxt -> Cxt
forall a. a -> a
id
            ) [ Name -> Cxt -> Type
TH.classPred ''HasSchemaDefinition [Type
fieldType, Type
referencedTypes] ]
          | (TH.ConstructorInfo{Cxt
constructorFields :: Cxt
constructorFields :: ConstructorInfo -> Cxt
constructorFields}, SchemaInfo
_info, Natural
_index) <- [(ConstructorInfo, SchemaInfo, Natural)]
indexedCons
          , Type
fieldType <- Cxt
constructorFields
          ]

  -- Generate a 'schema' function for the instance with one clause.
  InstanceDec
schemaPrag <- Name -> [Q Clause] -> Q InstanceDec
forall (m :: * -> *).
Quote m =>
Name -> [m Clause] -> m InstanceDec
TH.funD 'schema [Type -> [(ConstructorInfo, SchemaInfo, Natural)] -> Q Clause
mkSchemaClause Type
referencedTypes [(ConstructorInfo, SchemaInfo, Natural)]
indexedCons]
  -- Generate a pragma for the 'schema' function, making it inlinable.
  InstanceDec
schemaDecl <- Name -> Inline -> RuleMatch -> Phases -> Q InstanceDec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m InstanceDec
TH.pragInlD 'schema Inline
TH.Inlinable RuleMatch
TH.FunLike Phases
TH.AllPhases
  [InstanceDec] -> Q [InstanceDec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    -- Generate an instance declaration, e.g.:
    -- instance (constraints) => HasBlueprintSchema T referencedTypes where
    --   {-# INLINE schema #-}
    --   schema = ...
    [ Cxt -> Type -> [InstanceDec] -> InstanceDec
nonOverlapInstance
      Cxt
constraints
      (Name -> Cxt -> Type
TH.classPred ''HasBlueprintSchema [Type
appliedType, Type
referencedTypes])
      [InstanceDec
schemaPrag, InstanceDec
schemaDecl]
    ]
 where
  -- Lookup all annotations (SchemaTitle, SchemdDescription, SchemaComment) attached to a name.
  lookupSchemaAnns :: TH.Name -> TH.Q [SchemaAnn]
  lookupSchemaAnns :: Name -> Q [SchemaAnn]
lookupSchemaAnns Name
name = do
    [SchemaAnn]
title <- SchemaTitle -> SchemaAnn
MkSchemaAnnTitle (SchemaTitle -> SchemaAnn) -> Q [SchemaTitle] -> Q [SchemaAnn]
forall (f1 :: * -> *) (f2 :: * -> *) a b.
(Functor f1, Functor f2) =>
(a -> b) -> f1 (f2 a) -> f1 (f2 b)
<<$>> forall a. Data a => Name -> Q [a]
lookupAnn @SchemaTitle Name
name
    [SchemaAnn]
description <- SchemaDescription -> SchemaAnn
MkSchemaAnnDescription (SchemaDescription -> SchemaAnn)
-> Q [SchemaDescription] -> Q [SchemaAnn]
forall (f1 :: * -> *) (f2 :: * -> *) a b.
(Functor f1, Functor f2) =>
(a -> b) -> f1 (f2 a) -> f1 (f2 b)
<<$>> forall a. Data a => Name -> Q [a]
lookupAnn @SchemaDescription Name
name
    [SchemaAnn]
comment <- SchemaComment -> SchemaAnn
MkSchemaAnnComment (SchemaComment -> SchemaAnn) -> Q [SchemaComment] -> Q [SchemaAnn]
forall (f1 :: * -> *) (f2 :: * -> *) a b.
(Functor f1, Functor f2) =>
(a -> b) -> f1 (f2 a) -> f1 (f2 b)
<<$>> forall a. Data a => Name -> Q [a]
lookupAnn @SchemaComment Name
name
    [SchemaAnn] -> Q [SchemaAnn]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([SchemaAnn] -> Q [SchemaAnn]) -> [SchemaAnn] -> Q [SchemaAnn]
forall a b. (a -> b) -> a -> b
$ [SchemaAnn]
title [SchemaAnn] -> [SchemaAnn] -> [SchemaAnn]
forall a. [a] -> [a] -> [a]
++ [SchemaAnn]
description [SchemaAnn] -> [SchemaAnn] -> [SchemaAnn]
forall a. [a] -> [a] -> [a]
++ [SchemaAnn]
comment

  -- | Make SchemaInfo from a list of schema annotations, failing in case of ambiguity.
  schemaInfoFromAnns :: [SchemaAnn] -> TH.Q SchemaInfo
  schemaInfoFromAnns :: [SchemaAnn] -> Q SchemaInfo
schemaInfoFromAnns = (String -> Q SchemaInfo)
-> (SchemaInfo -> Q SchemaInfo)
-> Either String SchemaInfo
-> Q SchemaInfo
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Q SchemaInfo
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail SchemaInfo -> Q SchemaInfo
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String SchemaInfo -> Q SchemaInfo)
-> ([SchemaAnn] -> Either String SchemaInfo)
-> [SchemaAnn]
-> Q SchemaInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SchemaAnn] -> Either String SchemaInfo
annotationsToSchemaInfo

-- | Make a clause for the 'schema' function.
mkSchemaClause ::
  -- | The type for the 'HasBlueprintSchema' instance.
  TH.Type ->
  -- | The constructors of the type with their schema infos and indices.
  [(TH.ConstructorInfo, SchemaInfo, Natural)] ->
  -- | The clause for the 'schema' function.
  TH.ClauseQ
mkSchemaClause :: Type -> [(ConstructorInfo, SchemaInfo, Natural)] -> Q Clause
mkSchemaClause Type
ts [(ConstructorInfo, SchemaInfo, Natural)]
ctorIndexes =
  case [(ConstructorInfo, SchemaInfo, Natural)]
ctorIndexes of
    [] -> String -> Q Clause
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"At least one constructor index must be specified."
    [(ConstructorInfo, SchemaInfo, Natural)
ctorIndex] -> ExpQ -> Q Clause
mkBody ((ConstructorInfo, SchemaInfo, Natural) -> ExpQ
mkSchemaConstructor (ConstructorInfo, SchemaInfo, Natural)
ctorIndex)
    [(ConstructorInfo, SchemaInfo, Natural)]
_ -> ExpQ -> Q Clause
mkBody [|SchemaOneOf (NE.fromList $([ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
TH.listE (((ConstructorInfo, SchemaInfo, Natural) -> ExpQ)
-> [(ConstructorInfo, SchemaInfo, Natural)] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map (ConstructorInfo, SchemaInfo, Natural) -> ExpQ
mkSchemaConstructor [(ConstructorInfo, SchemaInfo, Natural)]
ctorIndexes)))|]
 where
  mkBody :: TH.ExpQ -> TH.ClauseQ
  mkBody :: ExpQ -> Q Clause
mkBody ExpQ
body = do
    let patterns :: [a]
patterns = []
    let whereDecls :: [a]
whereDecls = []
    [Q Pat] -> Q Body -> [Q InstanceDec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m InstanceDec] -> m Clause
TH.clause [Q Pat]
forall a. [a]
patterns (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
TH.normalB ExpQ
body) [Q InstanceDec]
forall a. [a]
whereDecls

  mkSchemaConstructor :: (TH.ConstructorInfo, SchemaInfo, Natural) -> TH.ExpQ
  mkSchemaConstructor :: (ConstructorInfo, SchemaInfo, Natural) -> ExpQ
mkSchemaConstructor (TH.ConstructorInfo{Cxt
[TyVarBndrUnit]
[FieldStrictness]
Name
ConstructorVariant
constructorName :: ConstructorInfo -> Name
constructorFields :: ConstructorInfo -> Cxt
constructorName :: Name
constructorVars :: [TyVarBndrUnit]
constructorContext :: Cxt
constructorFields :: Cxt
constructorStrictness :: [FieldStrictness]
constructorVariant :: ConstructorVariant
constructorContext :: ConstructorInfo -> Cxt
constructorStrictness :: ConstructorInfo -> [FieldStrictness]
constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
..}, SchemaInfo
info, Natural -> Integer
naturalToInteger -> Integer
ctorIndex) = do
    [Exp]
fields <- Cxt -> (Type -> ExpQ) -> Q [Exp]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Cxt
constructorFields ((Type -> ExpQ) -> Q [Exp]) -> (Type -> ExpQ) -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ \Type
t -> [|definitionRef @($(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t)) @($(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ts))|]
    [|SchemaConstructor info (MkConstructorSchema ctorIndex $(Exp -> ExpQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Exp] -> Exp
TH.ListE [Exp]
fields)))|]

deriveParameterBlueprint :: TH.Name -> Set Purpose -> TH.ExpQ
deriveParameterBlueprint :: Name -> Set Purpose -> ExpQ
deriveParameterBlueprint Name
tyName Set Purpose
purpose = do
  Maybe Text
title <- String -> Text
Text.pack (String -> Text) -> (SchemaTitle -> String) -> SchemaTitle -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaTitle -> String
schemaTitleToString (SchemaTitle -> Text) -> Q (Maybe SchemaTitle) -> Q (Maybe Text)
forall (f1 :: * -> *) (f2 :: * -> *) a b.
(Functor f1, Functor f2) =>
(a -> b) -> f1 (f2 a) -> f1 (f2 b)
<<$>> Name -> Q (Maybe SchemaTitle)
lookupSchemaTitle Name
tyName
  Maybe Text
description <- String -> Text
Text.pack (String -> Text)
-> (SchemaDescription -> String) -> SchemaDescription -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaDescription -> String
schemaDescriptionToString (SchemaDescription -> Text)
-> Q (Maybe SchemaDescription) -> Q (Maybe Text)
forall (f1 :: * -> *) (f2 :: * -> *) a b.
(Functor f1, Functor f2) =>
(a -> b) -> f1 (f2 a) -> f1 (f2 b)
<<$>> Name -> Q (Maybe SchemaDescription)
lookupSchemaDescription Name
tyName
  [| MkParameterBlueprint
      { parameterTitle = title
      , parameterDescription = description
      , parameterPurpose = purpose
      , parameterSchema = definitionRef @($(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
TH.conT Name
tyName))
      }
    |]

deriveArgumentBlueprint :: TH.Name -> Set Purpose -> TH.ExpQ
deriveArgumentBlueprint :: Name -> Set Purpose -> ExpQ
deriveArgumentBlueprint Name
tyName Set Purpose
purpose = do
  Maybe Text
title <- String -> Text
Text.pack (String -> Text) -> (SchemaTitle -> String) -> SchemaTitle -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaTitle -> String
schemaTitleToString (SchemaTitle -> Text) -> Q (Maybe SchemaTitle) -> Q (Maybe Text)
forall (f1 :: * -> *) (f2 :: * -> *) a b.
(Functor f1, Functor f2) =>
(a -> b) -> f1 (f2 a) -> f1 (f2 b)
<<$>> Name -> Q (Maybe SchemaTitle)
lookupSchemaTitle Name
tyName
  Maybe Text
description <- String -> Text
Text.pack (String -> Text)
-> (SchemaDescription -> String) -> SchemaDescription -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaDescription -> String
schemaDescriptionToString (SchemaDescription -> Text)
-> Q (Maybe SchemaDescription) -> Q (Maybe Text)
forall (f1 :: * -> *) (f2 :: * -> *) a b.
(Functor f1, Functor f2) =>
(a -> b) -> f1 (f2 a) -> f1 (f2 b)
<<$>> Name -> Q (Maybe SchemaDescription)
lookupSchemaDescription Name
tyName
  [| MkArgumentBlueprint
      { argumentTitle = title
      , argumentDescription = description
      , argumentPurpose = purpose
      , argumentSchema = definitionRef @($(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
TH.conT Name
tyName))
      }
    |]

----------------------------------------------------------------------------------------------------
-- TH Utilities ------------------------------------------------------------------------------------

lookupAnn :: (Data a) => TH.Name -> TH.Q [a]
lookupAnn :: forall a. Data a => Name -> Q [a]
lookupAnn = AnnLookup -> Q [a]
forall a. Data a => AnnLookup -> Q [a]
TH.reifyAnnotations (AnnLookup -> Q [a]) -> (Name -> AnnLookup) -> Name -> Q [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> AnnLookup
TH.AnnLookupName

lookupSchemaTitle :: TH.Name -> TH.Q (Maybe SchemaTitle)
lookupSchemaTitle :: Name -> Q (Maybe SchemaTitle)
lookupSchemaTitle Name
tyName = forall a. Data a => Name -> Q [a]
lookupAnn @SchemaTitle Name
tyName Q [SchemaTitle]
-> ([SchemaTitle] -> Maybe SchemaTitle) -> Q (Maybe SchemaTitle)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    [SchemaTitle
x] -> SchemaTitle -> Maybe SchemaTitle
forall a. a -> Maybe a
Just SchemaTitle
x
    [] -> Maybe SchemaTitle
forall a. Maybe a
Nothing
    [SchemaTitle]
_ -> String -> Maybe SchemaTitle
forall a. String -> Maybe a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Maybe SchemaTitle) -> String -> Maybe SchemaTitle
forall a b. (a -> b) -> a -> b
$ String
"Multiple SchemTitle annotations found for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
tyName

lookupSchemaDescription :: TH.Name -> TH.Q (Maybe SchemaDescription)
lookupSchemaDescription :: Name -> Q (Maybe SchemaDescription)
lookupSchemaDescription Name
tyName = forall a. Data a => Name -> Q [a]
lookupAnn @SchemaDescription Name
tyName Q [SchemaDescription]
-> ([SchemaDescription] -> Maybe SchemaDescription)
-> Q (Maybe SchemaDescription)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    [SchemaDescription
x] -> SchemaDescription -> Maybe SchemaDescription
forall a. a -> Maybe a
Just SchemaDescription
x
    [] -> Maybe SchemaDescription
forall a. Maybe a
Nothing
    [SchemaDescription]
_ -> String -> Maybe SchemaDescription
forall a. String -> Maybe a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Maybe SchemaDescription)
-> String -> Maybe SchemaDescription
forall a b. (a -> b) -> a -> b
$ String
"Multiple SchemaDescription annotations found for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
tyName