diff --git a/lib/fine-types/fine-types.cabal b/lib/fine-types/fine-types.cabal index 048904f..1ecb0a0 100644 --- 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 index 11a92ba..cbfa1e0 100644 --- 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 index cc9da86..8919d37 100644 --- 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 index 98c2c80..d3eb227 100644 --- 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 index 9081764..052ee84 100644 --- 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 index 15f9ed6..3044e76 100644 --- 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 index d084259..c028268 100644 --- 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* };