diff --git a/lib/fine-types/fine-types.cabal b/lib/fine-types/fine-types.cabal index d5b39b8e..9996b7ef 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/Haskell/Typ.hs b/lib/fine-types/src/Language/FineTypes/Export/Haskell/Typ.hs index a2abe354..7555c3d1 100644 --- 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 index c5ee48ba..cbfa1e02 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 cc9da860..8919d379 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/Parser.hs b/lib/fine-types/src/Language/FineTypes/Parser.hs index 700eb941..27071483 100644 --- 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 index aa0efc46..ee555e43 100644 --- 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 index 0dfccd4f..4711e591 100644 --- 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 index 53789a60..c3d2a7fe 100644 --- 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 index 98c2c80f..d3eb227b 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 90817641..052ee847 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 15f9ed61..3044e764 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 d0842594..c028268b 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* };