From 6a241d6cb7f1f224047c861f644383a84ab28c0c Mon Sep 17 00:00:00 2001 From: Tom Sydney Kerckhove Date: Thu, 21 Oct 2021 02:24:18 +0200 Subject: [PATCH] can't figure out choice --- .../src/Autodocodec/Aeson/Decode.hs | 13 +++++++++ .../src/Autodocodec/Aeson/Document.hs | 29 +++++++++++++++++-- .../src/Autodocodec/Aeson/Encode.hs | 2 ++ .../test/Autodocodec/Aeson/DocumentSpec.hs | 8 +++-- .../{bool => test_resources/bool.json} | 0 .../{text => test_resources/text.json} | 0 autodocodec/src/Autodocodec/Codec.hs | 8 +++++ 7 files changed, 54 insertions(+), 6 deletions(-) rename autodocodec-aeson/{bool => test_resources/bool.json} (100%) rename autodocodec-aeson/{text => test_resources/text.json} (100%) diff --git a/autodocodec-aeson/src/Autodocodec/Aeson/Decode.hs b/autodocodec-aeson/src/Autodocodec/Aeson/Decode.hs index f28cc6c..59842e4 100644 --- a/autodocodec-aeson/src/Autodocodec/Aeson/Decode.hs +++ b/autodocodec-aeson/src/Autodocodec/Aeson/Decode.hs @@ -4,6 +4,8 @@ module Autodocodec.Aeson.Decode where import Autodocodec +import Control.Applicative +import Control.Monad import Data.Aeson as JSON import Data.Aeson.Types as JSON @@ -21,6 +23,13 @@ parseJSONVia = flip go NumberCodec -> parseJSON value ObjectCodec c -> withObject "TODO" (\o -> goObject o c) value BimapCodec f _ c -> f <$> go value c + ChoiceCodec cs _ -> goChoice value cs + + goChoice :: JSON.Value -> [Codec void a] -> JSON.Parser a + goChoice value = \case + [] -> fail "No choices left." -- TODO better error + (c : cs) -> go value c <|> goChoice value cs + -- PureCodec a -> pure a -- ApCodec cf ca -> go value cf <*> go value ca -- AltCodecs cs -> case cs of @@ -32,6 +41,10 @@ parseJSONVia = flip go KeyCodec k c -> do value <- object_ JSON..: k go value c + -- EqObjectCodec o oc -> do + -- o' <- goObject object_ oc + -- guard (o == o') + -- pure o' BimapObjectCodec f _ oc -> f <$> goObject object_ oc PureObjectCodec a -> pure a ApObjectCodec ocf oca -> goObject object_ ocf <*> goObject object_ oca diff --git a/autodocodec-aeson/src/Autodocodec/Aeson/Document.hs b/autodocodec-aeson/src/Autodocodec/Aeson/Document.hs index ec9ddc4..90bed27 100644 --- a/autodocodec-aeson/src/Autodocodec/Aeson/Document.hs +++ b/autodocodec-aeson/src/Autodocodec/Aeson/Document.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -10,7 +11,8 @@ module Autodocodec.Aeson.Document where import Autodocodec import Autodocodec.Aeson.Decode import Autodocodec.Aeson.Encode -import Data.Aeson as JSON +import Data.Aeson (FromJSON (..), ToJSON (..)) +import qualified Data.Aeson as JSON import Data.Text (Text) import GHC.Generics (Generic) @@ -20,7 +22,9 @@ data JSONSchema | BoolSchema | StringSchema | NumberSchema - | ObjectSchema !JSONObjectSchema + | -- | ValueSchema JSON.Value + ObjectSchema !JSONObjectSchema + | ChoiceSchema ![JSONSchema] deriving (Show, Eq, Generic) data JSONObjectSchema @@ -30,7 +34,24 @@ data JSONObjectSchema deriving (Show, Eq, Generic) instance HasCodec JSONSchema where - codec = undefined + codec = + ChoiceCodec + ( [ bimapCodec + (const BoolSchema :: Text -> JSONSchema) + (const "boolean" :: JSONSchema -> Text) + (object (field "type" .== ("boolean" :: Text))) + ] :: + [Codec JSONSchema JSONSchema] + ) + ( ( \case + BoolSchema -> + bimapCodec + (const BoolSchema :: Text -> JSONSchema) + (const "boolean" :: JSONSchema -> Text) + (object (field "type" .== "boolean")) + ) :: + JSONSchema -> Codec JSONSchema JSONSchema + ) instance ToJSON JSONSchema where toJSON = toJSONViaCodec @@ -50,8 +71,10 @@ jsonSchemaVia = go BoolCodec -> BoolSchema StringCodec -> StringSchema NumberCodec -> NumberSchema + -- EqCodec _ c -> go c -- TODO maybe we want to show the specific value? ObjectCodec oc -> ObjectSchema (goObject oc) BimapCodec _ _ c -> go c + ChoiceCodec cs _ -> ChoiceSchema (map go cs) goObject :: ObjectCodec input output -> JSONObjectSchema goObject = \case diff --git a/autodocodec-aeson/src/Autodocodec/Aeson/Encode.hs b/autodocodec-aeson/src/Autodocodec/Aeson/Encode.hs index ef9448e..d5fc0a4 100644 --- a/autodocodec-aeson/src/Autodocodec/Aeson/Encode.hs +++ b/autodocodec-aeson/src/Autodocodec/Aeson/Encode.hs @@ -23,6 +23,7 @@ toJSONVia = flip go NumberCodec -> toJSON (a :: Scientific) ObjectCodec oc -> JSON.Object (goObject a oc) BimapCodec _ g c -> go (g a) c + ChoiceCodec _ c -> go a (c a) -- ApCodec _ _ -> error "Cannot toJSON Ap with non-object codecs." -- PureCodec _ -> error "Cannot toJSON a pure codec." -- AltCodecs _ -> error "Cannot toJSON an Alt codec." @@ -30,6 +31,7 @@ toJSONVia = flip go goObject :: a -> ObjectCodec a void -> JSON.Object goObject a = \case KeyCodec k c -> k JSON..= go a c + -- EqObjectCodec o oc -> goObject o oc PureObjectCodec _ -> error "Cannot toJSON a pure object codec." BimapObjectCodec _ g oc -> goObject (g a) oc ApObjectCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2 diff --git a/autodocodec-aeson/test/Autodocodec/Aeson/DocumentSpec.hs b/autodocodec-aeson/test/Autodocodec/Aeson/DocumentSpec.hs index fb24b1d..62e48e6 100644 --- a/autodocodec-aeson/test/Autodocodec/Aeson/DocumentSpec.hs +++ b/autodocodec-aeson/test/Autodocodec/Aeson/DocumentSpec.hs @@ -6,18 +6,20 @@ module Autodocodec.Aeson.DocumentSpec (spec) where import Autodocodec import Autodocodec.Aeson +import Data.Data import Data.GenValidity import Data.GenValidity.Text () import Data.Text (Text) import Test.Syd import Test.Syd.Aeson +import Test.Syd.Validity.Utils spec :: Spec spec = do jsonSchemaSpec @Bool "bool" jsonSchemaSpec @Text "text" -jsonSchemaSpec :: forall a. (Show a, Eq a, GenValid a, HasCodec a) => FilePath -> Spec +jsonSchemaSpec :: forall a. (Show a, Eq a, Typeable a, GenValid a, HasCodec a) => FilePath -> Spec jsonSchemaSpec filePath = do - it "outputs the same schema as before" $ - pureGoldenJSONValueFile filePath (jsonSchemaViaCodec @a) + it ("outputs the same schema as before for " <> nameOf @a) $ + pureGoldenJSONValueFile ("test_resources/" <> filePath <> ".json") (jsonSchemaViaCodec @a) diff --git a/autodocodec-aeson/bool b/autodocodec-aeson/test_resources/bool.json similarity index 100% rename from autodocodec-aeson/bool rename to autodocodec-aeson/test_resources/bool.json diff --git a/autodocodec-aeson/text b/autodocodec-aeson/test_resources/text.json similarity index 100% rename from autodocodec-aeson/text rename to autodocodec-aeson/test_resources/text.json diff --git a/autodocodec/src/Autodocodec/Codec.hs b/autodocodec/src/Autodocodec/Codec.hs index aaebe06..eba2578 100644 --- a/autodocodec/src/Autodocodec/Codec.hs +++ b/autodocodec/src/Autodocodec/Codec.hs @@ -39,6 +39,7 @@ data Codec input output where -- AltCodecs :: -- [Codec input output] -> -- Codec input output + ChoiceCodec :: [Codec oldInput output] -> (input -> Codec input oldOutput) -> Codec input output fmapCodec :: (oldOutput -> newOutput) -> Codec input oldOutput -> Codec input newOutput fmapCodec f = BimapCodec f id @@ -75,8 +76,12 @@ instance Functor (Codec input) where -- empty = emptyCodec -- (<|>) = orCodec +choice :: [Codec oldInput output] -> (input -> Codec input oldOutput) -> Codec input output +choice = ChoiceCodec + data ObjectCodec input output where KeyCodec :: Text -> Codec input output -> ObjectCodec input output + EqObjectCodec :: (Show newInput, Eq newInput) => newInput -> ObjectCodec oldInput output -> ObjectCodec newInput output PureObjectCodec :: output -> ObjectCodec input output BimapObjectCodec :: (oldOutput -> newOutput) -> (newInput -> oldInput) -> ObjectCodec oldInput oldOutput -> ObjectCodec newInput newOutput ApObjectCodec :: ObjectCodec input (output -> newOutput) -> ObjectCodec input output -> ObjectCodec input newOutput @@ -106,6 +111,9 @@ apObjectCodec = ApObjectCodec (.=) :: ObjectCodec oldInput output -> (newInput -> oldInput) -> ObjectCodec newInput output (.=) = flip comapObjectCodec +(.==) :: (Show newInput, Eq newInput) => ObjectCodec oldInput output -> newInput -> ObjectCodec newInput output +(.==) = flip EqObjectCodec + boolCodec :: Codec Bool Bool boolCodec = BoolCodec