From 312149899a0237428abbd820c01ed415199a00f0 Mon Sep 17 00:00:00 2001 From: Tom Sydney Kerckhove Date: Mon, 1 Nov 2021 18:42:32 +0100 Subject: [PATCH] deriving via example --- autodocodec-aeson/autodocodec-aeson.cabal | 1 + autodocodec-aeson/src/Autodocodec/Aeson.hs | 4 ++++ .../src/Autodocodec/Aeson/DerivingVia.hs | 14 +++++++++++ .../src/Autodocodec/Usage.hs | 23 +++++++++++++++++-- .../test/Autodocodec/Aeson/DocumentSpec.hs | 1 + .../test/Autodocodec/AesonSpec.hs | 1 + .../test/Autodocodec/Yaml/DocumentSpec.hs | 1 + .../test_resources/schema/via.json | 16 +++++++++++++ .../test_resources/schema/via.txt | 7 ++++++ autodocodec/autodocodec.cabal | 1 + autodocodec/src/Autodocodec.hs | 5 ++++ autodocodec/src/Autodocodec/DerivingVia.hs | 17 ++++++++++++++ 12 files changed, 89 insertions(+), 2 deletions(-) create mode 100644 autodocodec-aeson/src/Autodocodec/Aeson/DerivingVia.hs create mode 100644 autodocodec-api-usage/test_resources/schema/via.json create mode 100644 autodocodec-api-usage/test_resources/schema/via.txt create mode 100644 autodocodec/src/Autodocodec/DerivingVia.hs diff --git a/autodocodec-aeson/autodocodec-aeson.cabal b/autodocodec-aeson/autodocodec-aeson.cabal index 99c0de4..b3d3eea 100644 --- a/autodocodec-aeson/autodocodec-aeson.cabal +++ b/autodocodec-aeson/autodocodec-aeson.cabal @@ -24,6 +24,7 @@ library exposed-modules: Autodocodec.Aeson Autodocodec.Aeson.Decode + Autodocodec.Aeson.DerivingVia Autodocodec.Aeson.Document Autodocodec.Aeson.Encode other-modules: diff --git a/autodocodec-aeson/src/Autodocodec/Aeson.hs b/autodocodec-aeson/src/Autodocodec/Aeson.hs index 56fb85a..45f0173 100644 --- a/autodocodec-aeson/src/Autodocodec/Aeson.hs +++ b/autodocodec-aeson/src/Autodocodec/Aeson.hs @@ -1,11 +1,15 @@ +{-# OPTIONS_GHC -fno-warn-dodgy-exports #-} + module Autodocodec.Aeson ( -- * To makes sure we definitely export everything. module Autodocodec.Aeson.Decode, + module Autodocodec.Aeson.DerivingVia, module Autodocodec.Aeson.Document, module Autodocodec.Aeson.Encode, ) where import Autodocodec.Aeson.Decode +import Autodocodec.Aeson.DerivingVia () import Autodocodec.Aeson.Document import Autodocodec.Aeson.Encode diff --git a/autodocodec-aeson/src/Autodocodec/Aeson/DerivingVia.hs b/autodocodec-aeson/src/Autodocodec/Aeson/DerivingVia.hs new file mode 100644 index 0000000..2aa780c --- /dev/null +++ b/autodocodec-aeson/src/Autodocodec/Aeson/DerivingVia.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Autodocodec.Aeson.DerivingVia where + +import Autodocodec +import Autodocodec.Aeson.Decode +import Autodocodec.Aeson.Encode +import Data.Aeson + +instance HasCodec a => ToJSON (Autodocodec a) where + toJSON = toJSONViaCodec . unAutodocodec + +instance HasCodec a => FromJSON (Autodocodec a) where + parseJSON = fmap Autodocodec <$> parseJSONViaCodec diff --git a/autodocodec-api-usage/src/Autodocodec/Usage.hs b/autodocodec-api-usage/src/Autodocodec/Usage.hs index ba07ada..37cc48f 100644 --- a/autodocodec-api-usage/src/Autodocodec/Usage.hs +++ b/autodocodec-api-usage/src/Autodocodec/Usage.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -10,6 +11,7 @@ module Autodocodec.Usage where import Autodocodec +import Autodocodec.Aeson () import Control.Applicative import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as JSON @@ -32,8 +34,8 @@ data Fruit instance Validity Fruit instance GenValid Fruit where - genValid = genValidStructurally - shrinkValid = shrinkValidStructurally + genValid = genValidStructurallyWithoutExtraChecking + shrinkValid = shrinkValidStructurallyWithoutExtraFiltering instance HasCodec Fruit where codec = shownBoundedEnumCodec @@ -149,3 +151,20 @@ instance HasCodec Recursive where eitherCodec (codec @Int "base case") (object "Recurse" $ requiredField "recurse" "recursive case") + +data Via = Via {viaOne :: !Text, viaTwo :: !Text} + deriving stock (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via (Autodocodec Via) + +instance Validity Via + +instance GenValid Via where + genValid = genValidStructurallyWithoutExtraChecking + shrinkValid = shrinkValidStructurallyWithoutExtraFiltering + +instance HasCodec Via where + codec = + object "Via" $ + Via + <$> requiredField "one" "first field" .= viaOne + <*> requiredField "two" "second field" .= viaTwo diff --git a/autodocodec-api-usage/test/Autodocodec/Aeson/DocumentSpec.hs b/autodocodec-api-usage/test/Autodocodec/Aeson/DocumentSpec.hs index efe1aae..7e78ff1 100644 --- a/autodocodec-api-usage/test/Autodocodec/Aeson/DocumentSpec.hs +++ b/autodocodec-api-usage/test/Autodocodec/Aeson/DocumentSpec.hs @@ -55,6 +55,7 @@ spec = do jsonSchemaSpec @[Text] "list-text" jsonSchemaSpec @Example "example" jsonSchemaSpec @Recursive "recursive" + jsonSchemaSpec @Via "via" describe "JSONSchema" $ do genValidSpec @JSONSchema it "roundtrips through json and back" $ diff --git a/autodocodec-api-usage/test/Autodocodec/AesonSpec.hs b/autodocodec-api-usage/test/Autodocodec/AesonSpec.hs index c4ff7a2..d677a6b 100644 --- a/autodocodec-api-usage/test/Autodocodec/AesonSpec.hs +++ b/autodocodec-api-usage/test/Autodocodec/AesonSpec.hs @@ -53,6 +53,7 @@ spec = do aesonCodecSpec @Fruit aesonCodecSpec @Example aesonCodecSpec @Recursive + aesonCodecSpec @Via aesonCodecSpec :: forall a. (Show a, Eq a, Typeable a, GenValid a, ToJSON a, FromJSON a, HasCodec a) => Spec aesonCodecSpec = diff --git a/autodocodec-api-usage/test/Autodocodec/Yaml/DocumentSpec.hs b/autodocodec-api-usage/test/Autodocodec/Yaml/DocumentSpec.hs index 5a10231..17fc34a 100644 --- a/autodocodec-api-usage/test/Autodocodec/Yaml/DocumentSpec.hs +++ b/autodocodec-api-usage/test/Autodocodec/Yaml/DocumentSpec.hs @@ -50,6 +50,7 @@ spec = do yamlSchemaSpec @Fruit "fruit" yamlSchemaSpec @Example "example" yamlSchemaSpec @Recursive "recursive" + yamlSchemaSpec @Via "via" yamlSchemaSpec :: forall a. (Show a, Eq a, Typeable a, GenValid a, HasCodec a) => FilePath -> Spec yamlSchemaSpec filePath = do diff --git a/autodocodec-api-usage/test_resources/schema/via.json b/autodocodec-api-usage/test_resources/schema/via.json new file mode 100644 index 0000000..463fbfd --- /dev/null +++ b/autodocodec-api-usage/test_resources/schema/via.json @@ -0,0 +1,16 @@ +{ + "$comment": "Via", + "required": [ + "one", + "two" + ], + "type": "object", + "properties": { + "two": { + "type": "string" + }, + "one": { + "type": "string" + } + } +} \ No newline at end of file diff --git a/autodocodec-api-usage/test_resources/schema/via.txt b/autodocodec-api-usage/test_resources/schema/via.txt new file mode 100644 index 0000000..45b96ab --- /dev/null +++ b/autodocodec-api-usage/test_resources/schema/via.txt @@ -0,0 +1,7 @@ +# Via +one: # required + # first field +  +two: # required + # second field +  diff --git a/autodocodec/autodocodec.cabal b/autodocodec/autodocodec.cabal index 5186cc0..a39fa61 100644 --- a/autodocodec/autodocodec.cabal +++ b/autodocodec/autodocodec.cabal @@ -25,6 +25,7 @@ library Autodocodec Autodocodec.Class Autodocodec.Codec + Autodocodec.DerivingVia other-modules: Paths_autodocodec hs-source-dirs: diff --git a/autodocodec/src/Autodocodec.hs b/autodocodec/src/Autodocodec.hs index 4ed11b9..8f68034 100644 --- a/autodocodec/src/Autodocodec.hs +++ b/autodocodec/src/Autodocodec.hs @@ -68,14 +68,19 @@ module Autodocodec pureCodec, apCodec, + -- * Deriving Via + Autodocodec (..), + -- ** Internals you most likely don't need showCodecABit, -- * To make sure we definitely export everything module Autodocodec.Class, + module Autodocodec.DerivingVia, module Autodocodec.Codec, ) where import Autodocodec.Class import Autodocodec.Codec +import Autodocodec.DerivingVia diff --git a/autodocodec/src/Autodocodec/DerivingVia.hs b/autodocodec/src/Autodocodec/DerivingVia.hs new file mode 100644 index 0000000..47c1c3f --- /dev/null +++ b/autodocodec/src/Autodocodec/DerivingVia.hs @@ -0,0 +1,17 @@ +module Autodocodec.DerivingVia where + +-- | 'Autodocodec' is a wrapper to provide codec-based deriving strategies. +-- +-- === Example usage +-- +-- > data Via = Via {viaOne :: !Text, viaTwo :: !Text} +-- > deriving stock (Show, Eq, Generic) +-- > deriving (FromJSON, ToJSON) via (Autodocodec Via) +-- > +-- > instance HasCodec Via where +-- > codec = +-- > object "Via" $ +-- > Via +-- > <$> requiredField "one" "first field" .= viaOne +-- > <*> requiredField "two" "second field" .= viaTwo +newtype Autodocodec a = Autodocodec {unAutodocodec :: a}