[ADP-3182] report constraints in json schema (#37)

- [x] extend Constrained constructor to hold the var name. - [x] support Constrained typs in json schema rendering - [x] fix tests to reflect the new support ADP-3182
cardano-foundation · Sep 25, 2023 · 5eb98c2 · 5eb98c2
2 parents 651494f + 8182ad8
commit 5eb98c2
Show file tree

Hide file tree

Showing 12 changed files with 51 additions and 27 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/Haskell/Typ.hs b/lib/fine-types/src/Language/FineTypes/Export/Haskell/Typ.hs
@@ -201,7 +201,7 @@ typeFromTyp = go
         error "Nested Product is not supported by Haskell"
     go (SumN _) =
         error "Nested Sum is not supported by Haskell"
-    go (Constrained typ _) =
+    go (Constrained _ typ _) =
         -- FIXME: Emit a warning.
         -- TODO: Add Liquid Haskell support for top-level definitions? 😲
         -- Currently no good representation for comments / Liquid Haskell

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/Parser.hs b/lib/fine-types/src/Language/FineTypes/Parser.hs
@@ -40,6 +40,7 @@ import Language.FineTypes.Typ
     , Typ (..)
     , TypConst (..)
     , TypName
+    , VarName
     )
 import Text.Megaparsec
     ( ParseErrorBundle
@@ -169,11 +170,11 @@ mkDocumentedDeclaration doc1 name (DocumentedTyp typ fs cs) doc2 =
 
 constrained :: Parser Typ
 constrained = braces $ do
-    _ <- varName
+    v <- varName
     _ <- symbol ":"
     typ <- zeroVar
     _ <- symbol "|"
-    Constrained typ <$> constraint
+    Constrained v typ <$> constraint
 
 abstract :: Parser Typ
 abstract = Abstract <$ symbol "_"
@@ -379,8 +380,6 @@ fieldName =
     L.lexeme space
         $ many (C.alphaNumChar <|> satisfy (`elem` "_^-"))
 
-type VarName = String
-
 varName :: Parser VarName
 varName =
     L.lexeme space

diff --git a/lib/fine-types/src/Language/FineTypes/Typ.hs b/lib/fine-types/src/Language/FineTypes/Typ.hs
@@ -7,6 +7,7 @@ module Language.FineTypes.Typ
       TypName
     , ConstructorName
     , FieldName
+    , VarName
     , Typ (..)
     , TypConst (..)
     , OpOne (..)
@@ -33,6 +34,7 @@ import qualified Data.List as L
 type TypName = String
 type ConstructorName = String
 type FieldName = String
+type VarName = String
 
 -- | A 'Typ' describes a set of values.
 --
@@ -56,7 +58,7 @@ data Typ
     | -- | Disjoint union with constructor names.
       SumN [(ConstructorName, Typ)]
     | -- | A type with a value constraint
-      Constrained Typ Constraint
+      Constrained VarName Typ Constraint
     deriving (Eq, Ord, Show, Generic)
 
 instance ToExpr Typ
@@ -138,8 +140,8 @@ everywhere f = every
         ProductN [(n, every a) | (n, a) <- nas]
     recurse (SumN nas) =
         SumN [(n, every a) | (n, a) <- nas]
-    recurse (Constrained typ c) =
-        Constrained (every typ) c
+    recurse (Constrained v typ c) =
+        Constrained v (every typ) c
 
 -- | Summarise all nodes; top-down, left-to-right.
 everything :: (r -> r -> r) -> (Typ -> r) -> (Typ -> r)
@@ -159,7 +161,7 @@ everything combine f = recurse
         L.foldl' combine (f x) [recurse a | (_, a) <- nas]
     recurse x@(SumN nas) =
         L.foldl' combine (f x) [recurse a | (_, a) <- nas]
-    recurse x@(Constrained typ _) =
+    recurse x@(Constrained _ typ _) =
         f x `combine` recurse typ
 
 depth :: Typ -> Int
@@ -169,7 +171,7 @@ depth = \case
     Two _ a b -> 1 + max (depth a) (depth b)
     ProductN fields -> 1 + maximum (fmap (depth . snd) fields)
     SumN constructors -> 1 + maximum (fmap (depth . snd) constructors)
-    Constrained a _ -> depth a
+    Constrained _ a _ -> depth a
     Abstract -> 0
     Var _ -> 0
 

diff --git a/lib/fine-types/src/Language/FineTypes/Typ/Gen.hs b/lib/fine-types/src/Language/FineTypes/Typ/Gen.hs
@@ -143,7 +143,8 @@ genConstrainedTyp mode = do
     constraintDepth <- choose (1, 2)
     c <- genConstraint constraintDepth
     typ <- genTyp'
-    pure $ Constrained typ c
+    v <- genName
+    pure $ Constrained v typ c
   where
     complete = onComplete mode
     always = id
@@ -225,10 +226,10 @@ shrinkTyp = \case
             <> (SumN <$> shrinkList shrinkNamed constructors)
     Var _ -> []
     Abstract -> []
-    Constrained typ c ->
+    Constrained v typ c ->
         [typ]
-            <> [Constrained typ' c | typ' <- shrinkTyp typ]
-            <> [Constrained typ c' | c' <- shrinkConstraint c]
+            <> [Constrained v typ' c | typ' <- shrinkTyp typ]
+            <> [Constrained v typ c' | c' <- shrinkConstraint c]
 
 shrinkNamed :: (t, Typ) -> [(t, Typ)]
 shrinkNamed (f, t) = (f,) <$> shrinkTyp t

diff --git a/lib/fine-types/src/Language/FineTypes/Typ/PrettyPrinter.hs b/lib/fine-types/src/Language/FineTypes/Typ/PrettyPrinter.hs
@@ -29,6 +29,7 @@ import Language.FineTypes.Typ
     , Typ (..)
     , TypConst (..)
     , TypName
+    , VarName
     )
 import Prettyprinter
     ( Doc
@@ -58,7 +59,7 @@ requireParens = \case
     SumN _ -> False
     Var _ -> False
     Abstract -> False
-    Constrained _ _ -> False
+    Constrained{} -> False
 
 parens :: Doc ann -> Doc ann
 parens doc = encloseSep "(" ")" " " [doc]
@@ -69,12 +70,15 @@ withParens f x = if requireParens x then parens (f x) else f x
 prettyConstrainedTyp
     :: QueryDocumentation
     -> TypName
+    -> VarName
     -> Typ
     -> Constraint
     -> Doc ann
-prettyConstrainedTyp docs typname typ [] = prettyTyp docs typname typ
-prettyConstrainedTyp docs typname typ constraint =
-    "{ x :"
+prettyConstrainedTyp docs typname _v typ [] = prettyTyp docs typname typ
+prettyConstrainedTyp docs typname v typ constraint =
+    "{"
+        <+> pretty v
+        <+> ":"
         <+> prettyTyp docs typname typ
         <+> prettyText "|"
         <+> prettyConstraint constraint
@@ -154,7 +158,7 @@ prettyTyp docs typname = \case
     SumN constructors -> prettySumN docs typname constructors
     Var name -> pretty name
     Abstract -> prettyText "_"
-    Constrained typ c -> prettyConstrainedTyp docs typname typ c
+    Constrained v typ c -> prettyConstrainedTyp docs typname v typ c
   where
     prettyTyp' = prettyTyp docs typname
 

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*
   };