Add Constrained typs to JSON schema rendering

cardano-foundation · Sep 25, 2023 · 8182ad8 · 8182ad8
1 parent 6acd4eb
commit 8182ad8
Show file tree

Hide file tree

Showing 7 changed files with 26 additions and 8 deletions.
diff --git a/lib/fine-types/fine-types.cabal b/lib/fine-types/fine-types.cabal
@@ -105,6 +105,7 @@ test-suite unit
   build-depends:
     , aeson
     , base
+    , bytestring
     , containers
     , deepseq
     , filepath

diff --git a/lib/fine-types/src/Language/FineTypes/Export/OpenAPI/Schema.hs b/lib/fine-types/src/Language/FineTypes/Export/OpenAPI/Schema.hs
@@ -53,16 +53,21 @@ import Language.FineTypes.Module
     , resolveVars
     )
 import Language.FineTypes.Typ
-    ( ConstructorName
+    ( Constraint
+    , ConstructorName
     , FieldName
     , OpOne (..)
     , OpTwo (..)
     , Typ (..)
     , TypConst (..)
     , TypName
+    , VarName
     , everything
     , everywhere
     )
+import Language.FineTypes.Typ.PrettyPrinter (prettyTyp)
+import Prettyprinter (layoutCompact)
+import Prettyprinter.Render.String (renderString)
 
 import qualified Data.HashMap.Strict.InsOrd as MH
 import qualified Data.Map as Map
@@ -104,8 +109,6 @@ supportsJSON =
     isSupportedTyp = everything (&&) isSupported
     isSupported (Two fun _ _) =
         fun `notElem` [PartialFunction, FiniteSupport]
-    isSupported Constrained{} =
-        False
     isSupported _ = True
 
 -- | Convert 'Typ' definitions to JSON.
@@ -203,8 +206,18 @@ schemaFromTyp = go
         schemaFromProductN fields
     go (SumN constructors) =
         schemaFromSumN constructors
-    go Constrained{} =
-        error "ConstrainedTyp is not supported by JSON schema"
+    go (Constrained v t c) =
+        schemaFromConstraint v t c
+
+schemaFromConstraint :: VarName -> Typ -> Constraint -> Schema
+schemaFromConstraint v t c = (schemaFromTyp t){_schemaFormat = Just format}
+  where
+    format =
+        T.pack
+            $ renderString
+            $ layoutCompact
+            $ prettyTyp (const mempty) "no-name"
+            $ Constrained v t c
 
 -- | Map a record type to a JSON schema.
 --

diff --git a/lib/fine-types/src/Language/FineTypes/Export/OpenAPI/Value/ToJSON.hs b/lib/fine-types/src/Language/FineTypes/Export/OpenAPI/Value/ToJSON.hs
@@ -60,6 +60,7 @@ jsonFromValue :: Typ -> Value -> JS.Value
 jsonFromValue = go
   where
     go :: Typ -> Value -> JS.Value
+    go (Typ.Constrained _ typ _) value = go typ value
     go (Typ.Two Typ.Product2 ta tb) (Product [a, b]) =
         JS.object ["0" .= go ta a, "1" .= go tb b]
     go (Typ.ProductN fields) (Product ps) =

diff --git a/lib/fine-types/src/Language/FineTypes/Value.hs b/lib/fine-types/src/Language/FineTypes/Value.hs
@@ -76,6 +76,8 @@ newtype TwoF a b
 
 -- | Check whether a 'Value' inhabits the given 'Typ'.
 hasTyp :: Value -> Typ -> Bool
+hasTyp z (Typ.Constrained _ t _) =
+    z `hasTyp` t
 hasTyp (Zero a) (Typ.Zero b) =
     typOf0 a == b
 hasTyp (Zero _) _ =

diff --git a/lib/fine-types/src/Language/FineTypes/Value/Gen.hs b/lib/fine-types/src/Language/FineTypes/Value/Gen.hs
@@ -119,6 +119,7 @@ genTypValue typ =
             ix <- lift $ choose (0, length constructors - 1)
             let (_cn, typ') = constructors !! ix
             Sum ix <$> exceptGenValue typ'
+        Typ.Constrained _ typ' _ -> genTypValue typ'
         typ' -> pure $ Left typ'
 
 genTypAndValue

diff --git a/lib/fine-types/test/Language/FineTypes/Export/OpenAPI/SchemaSpec.hs b/lib/fine-types/test/Language/FineTypes/Export/OpenAPI/SchemaSpec.hs
@@ -28,7 +28,7 @@ import Language.FineTypes.Typ
     )
 import Language.FineTypes.Typ.Gen
     ( Mode (Concrete)
-    , WithConstraints (WithoutConstraints)
+    , WithConstraints (..)
     )
 import Language.FineTypes.Value.Gen (genTypAndValue)
 import Test.Hspec
@@ -63,7 +63,7 @@ spec = do
                 ( genTypAndValue
                     (const True)
                     unsupported
-                    WithoutConstraints
+                    WithConstraints
                     Concrete
                     6
                 )

diff --git a/lib/fine-types/test/data/JsonUTxO.fine b/lib/fine-types/test/data/JsonUTxO.fine
@@ -20,7 +20,7 @@ DataHash = Bytes;
 Quantity = ℤ;
 
 Value =
-  { ada    : Quantity
+  { ada    : {x : Quantity | x > 0}
   , assets : Asset*
   };