Add optional record fields and shortcuts

cardano-foundation · Sep 6, 2023 · 4011d83 · 4011d83
1 parent c58c0c5
commit 4011d83
Show file tree

Hide file tree

Showing 4 changed files with 78 additions and 14 deletions.
diff --git a/lib/fine-types/fine-types.cabal b/lib/fine-types/fine-types.cabal
@@ -95,6 +95,7 @@ test-suite unit
     , hspec ^>= 2.11.0
     , pretty-simple
     , QuickCheck
+    , text
     , tree-diff
   main-is:
     Spec.hs

diff --git a/lib/fine-types/src/Language/FineTypes/Export/OpenAPI/Value/FromJSON.hs b/lib/fine-types/src/Language/FineTypes/Export/OpenAPI/Value/FromJSON.hs
@@ -69,8 +69,25 @@ parseProductN :: [(FieldName, Typ)] -> Parser Value
 parseProductN fs = parsing "Product" $ onObject $ \obj -> do
     fmap Product $ forM fs $ \(f, t) -> do
         case lookup (keyFromString f) obj of
-            Nothing -> fail $ "missing field " <> f
-            Just v -> parseTyp t v
+            Nothing ->
+                case hasDefault t of
+                    Nothing -> fail $ "missing field " <> f
+                    Just d -> pure d
+            Just v -> case shortcut t of
+                Just (t', amend) -> amend <$> parseTyp t' v
+                Nothing -> parseTyp t v
+
+hasDefault :: Typ -> Maybe Value
+hasDefault = \case
+    Typ.One Typ.Option _ -> Just $ One $ Option Nothing
+    Typ.One Typ.Sequence _ -> Just $ One $ Sequence []
+    Typ.One Typ.PowerSet _ -> Just $ One $ PowerSet Set.empty
+    _ -> Nothing
+
+shortcut :: Typ -> Maybe (Typ, Value -> Value)
+shortcut = \case
+    Typ.One Typ.Option t -> Just (t, One . Option . Just)
+    _ -> Nothing
 
 parseTwo :: Typ.OpTwo -> Typ -> Typ -> Parser Value
 parseTwo = \case

diff --git a/lib/fine-types/src/Language/FineTypes/Typ/Gen.hs b/lib/fine-types/src/Language/FineTypes/Typ/Gen.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TupleSections #-}
 
 module Language.FineTypes.Typ.Gen where
 
@@ -214,15 +215,22 @@ shrinkTyp = \case
     Zero _ -> []
     One _ typ -> typ : shrinkTyp typ
     Two _ typ1 typ2 -> typ1 : typ2 : shrinkTyp typ1 ++ shrinkTyp typ2
-    ProductN fields -> map snd fields
-    SumN constructors -> map snd constructors
+    ProductN fields ->
+        map snd fields
+            <> (ProductN <$> shrinkList shrinkNamed fields)
+    SumN constructors ->
+        map snd constructors
+            <> (SumN <$> shrinkList shrinkNamed constructors)
     Var _ -> []
     Abstract -> []
     Constrained typ c ->
         [typ]
             <> [Constrained typ' c | typ' <- shrinkTyp typ]
             <> [Constrained typ c' | c' <- shrinkConstraint c]
 
+shrinkNamed :: (t, Typ) -> [(t, Typ)]
+shrinkNamed (f, t) = (f,) <$> shrinkTyp t
+
 shrinkConstraint :: Constraint -> [Constraint]
 shrinkConstraint = shrinkList shrinkConstraint1
 

diff --git a/lib/fine-types/test/Language/FineTypes/Export/OpenAPI/ValueSpec.hs b/lib/fine-types/test/Language/FineTypes/Export/OpenAPI/ValueSpec.hs
@@ -1,10 +1,12 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Language.FineTypes.Export.OpenAPI.ValueSpec where
 
 import Prelude
 
 import Control.Exception (assert)
+import Data.Text (Text)
 import Language.FineTypes.Export.OpenAPI.Value.FromJSON (jsonToValue)
 import Language.FineTypes.Export.OpenAPI.Value.ToJSON (jsonFromValue)
 import Language.FineTypes.Typ
@@ -20,21 +22,56 @@ import Language.FineTypes.Value (Value, hasTyp)
 import Language.FineTypes.Value.Gen (genTypValue)
 import Test.Hspec (Spec, describe, shouldBe)
 import Test.Hspec.QuickCheck (prop)
-import Test.QuickCheck (Gen, classify, forAll, suchThat)
+import Test.QuickCheck
+    ( Gen
+    , Property
+    , classify
+    , counterexample
+    , forAll
+    , suchThat
+    )
+import Text.Pretty.Simple (pShow)
+
+import qualified Data.Text.Lazy as TL
+import qualified Language.FineTypes.Typ as Typ
+
+defaultOption :: Typ
+defaultOption = ProductN [("a", Typ.One Typ.Option (Typ.Zero Typ.Text))]
 
 roundTrip :: Typ -> Value -> Either String Value
 roundTrip t = jsonToValue t . jsonFromValue t
 
+singleRoundtrip :: Typ -> Either a Value -> Property
+singleRoundtrip typ evalue =
+    classify (depth typ > 3) "3-deep" $ do
+        case evalue of
+            Left _ -> error "should not happen"
+            Right value ->
+                assert (hasTyp value typ)
+                    $ roundTrip typ value `shouldBe` Right value
+
 roundTripProp :: String -> (Typ -> Bool) -> Spec
-roundTripProp s f = prop ("should roundtrip " <> s)
-    $ forAll (genValue f)
-    $ \(typ, evalue) ->
-        classify (depth typ > 3) "3-deep" $ do
-            case evalue of
-                Left _ -> error "should not happen"
-                Right value ->
-                    assert (hasTyp value typ)
-                        $ roundTrip typ value `shouldBe` Right value
+roundTripProp s f =
+    prop ("should roundtrip " <> s)
+        $ forAll (genValue f)
+        $ uncurry singleRoundtrip
+
+jsonInfo :: Typ -> Either a Value -> String
+jsonInfo typ (Right value) =
+    TL.unpack
+        $ pShow
+            ( ("type: " :: Text, typ)
+            , ("value: " :: Text, value)
+            , ("json: " :: Text, jsonFromValue typ value)
+            )
+jsonInfo _ (Left _) = "error"
+
+roundTripSpecial :: String -> Typ -> Spec
+roundTripSpecial s typ = prop ("should roundtrip " <> s)
+    $ forAll (genTypValue typ)
+    $ \evalue ->
+        counterexample (jsonInfo typ evalue)
+            $ singleRoundtrip typ evalue
 
 spec :: Spec
 spec = describe "JSON client" $ do
@@ -44,6 +81,7 @@ spec = describe "JSON client" $ do
     roundTripProp "ProductN" isProductN
     roundTripProp "SumN" isSumN
     roundTripProp "all together" concert
+    roundTripSpecial "defaultOption" defaultOption
 
 isZero :: Typ -> Bool
 isZero Zero{} = True