fail fast in case of duplicate annotations

IntersectMBO · Mar 14, 2024 · 396d119 · 396d119
1 parent 5820b9c
commit 396d119
Showing 1 changed file with 24 additions and 11 deletions.
diff --git a/plutus-tx/src/PlutusTx/Blueprint/TH.hs b/plutus-tx/src/PlutusTx/Blueprint/TH.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP              #-}
+{-# LANGUAGE EmptyCase        #-}
 {-# LANGUAGE LambdaCase       #-}
 {-# LANGUAGE NamedFieldPuns   #-}
 {-# LANGUAGE RecordWildCards  #-}
@@ -14,22 +15,22 @@ import Prelude
 import Data.Data (Data)
 import Data.List (nub)
 import Data.List.NonEmpty qualified as NE
-import Data.Maybe (listToMaybe)
 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, (<<$>>))
+import PlutusPrelude (for, (<&>), (<<$>>))
 import PlutusTx.Blueprint.Argument (ArgumentBlueprint (..))
 import PlutusTx.Blueprint.Class (HasSchema (..))
 import PlutusTx.Blueprint.Definition (HasSchemaDefinition)
 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)
+                                             SchemaInfo (..), SchemaTitle, annotationsToSchemaInfo,
+                                             schemaDescriptionToString, schemaTitleToString)
 import PlutusTx.IsData.TH (makeIsDataIndexed)
 
 {- |
@@ -123,23 +124,23 @@ mkSchemaClause ts ctorIndexes =
 
 deriveParameterBlueprint :: TH.Name -> Set Purpose -> TH.ExpQ
 deriveParameterBlueprint tyName purpose = do
-  title <- lookupAnn @SchemaTitle tyName
-  description <- lookupAnn @SchemaDescription tyName
+  title <- Text.pack . schemaTitleToString <<$>> lookupSchemaTitle tyName
+  description <- Text.pack . schemaDescriptionToString <<$>> lookupSchemaDescription tyName
   [| MkParameterBlueprint
-      { parameterTitle = listToMaybe (Text.pack . schemaTitleToString <$> title)
-      , parameterDescription = listToMaybe (Text.pack . schemaDescriptionToString <$> description)
+      { parameterTitle = title
+      , parameterDescription = description
       , parameterPurpose = purpose
       , parameterSchema = definitionRef @($(TH.conT tyName))
       }
     |]
 
 deriveArgumentBlueprint :: TH.Name -> Set Purpose -> TH.ExpQ
 deriveArgumentBlueprint tyName purpose = do
-  title <- lookupAnn @SchemaTitle tyName
-  description <- lookupAnn @SchemaDescription tyName
+  title <- Text.pack . schemaTitleToString <<$>> lookupSchemaTitle tyName
+  description <- Text.pack . schemaDescriptionToString <<$>> lookupSchemaDescription tyName
   [| MkArgumentBlueprint
-      { argumentTitle = listToMaybe (Text.pack . schemaTitleToString <$> title)
-      , argumentDescription = listToMaybe (Text.pack . schemaDescriptionToString <$> description)
+      { argumentTitle = title
+      , argumentDescription = description
       , argumentPurpose = purpose
       , argumentSchema = definitionRef @($(TH.conT tyName))
       }
@@ -150,3 +151,15 @@ deriveArgumentBlueprint tyName purpose = do
 
 lookupAnn :: (Data a) => TH.Name -> TH.Q [a]
 lookupAnn = TH.reifyAnnotations . TH.AnnLookupName
+
+lookupSchemaTitle :: TH.Name -> TH.Q (Maybe SchemaTitle)
+lookupSchemaTitle tyName = lookupAnn @SchemaTitle tyName <&> \case
+    [x] -> Just x
+    [] -> Nothing
+    _ -> fail $ "Multiple SchemTitle annotations found for " <> show tyName
+
+lookupSchemaDescription :: TH.Name -> TH.Q (Maybe SchemaDescription)
+lookupSchemaDescription tyName = lookupAnn @SchemaDescription tyName <&> \case
+    [x] -> Just x
+    [] -> Nothing
+    _ -> fail $ "Multiple SchemaDescription annotations found for " <> show tyName