diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for aeson-default-field + +## 0.1.0.0 -- 2024-10-08 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2024, Ondrej Palkovsky + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ondrej Palkovsky nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,58 @@ +## aeson-generic-default + +Type-level configuration of missing values for aeson FromJSON Generic parser. + +Using higher-kinded-types, Coercible and Generic instances it is possible to define +a class that can be configured by a type parameter to use custom field +parsers during parsing and only when the parsing is done, it can be coerced +to use normal types. + +```haskell +data ConfigFileT d = ConfigFile { + defaultEnabled :: DefaultField d (DefBool True) +, defaultDisabled :: DefaultField d (DefBool False) +, defaultText :: DefaultField d (DefText "default text") +, defaultInt :: DefaultField d (DefInt 42) +, defaultNegativeInt :: DefaultField d (DefNegativeInt 42) +, defaultRed :: DefaultField d (DefDefault Color) +, defaultBlue :: DefaultField d (DefDefaultConstant BlueDefault) +, normalField :: T.Text +, normalOptional :: Maybe Int +} deriving (Generic) +type ConfigFile = ConfigFileT Final + +instance FromJSON ConfigFile where + parseJSON = parseWithDefaults defaultOptions +``` + +The resulting `ConfigFile` type alias has a form of: + +```haskell +{ + defaultEnabled :: Bool +, defaultDisabled :: Bool +, defaultText :: Text +, defaultInt :: Int +, defaultNegativeInt :: Int +, defaultRed :: Color +, defaultBlue :: Color +, normalField :: T.Text +, normalOptional :: Maybe Int +} +``` + +The type-level configuration can be easily extended with newtypes, e.g. to create a full compatibility +layer with `singletons`: + +```haskell +newtype DefSing (a :: k) = DefSing (Demote k) deriving Generic +instance (SingI a, SingKind k, FromJSON (Demote k)) => FromJSON (DefSing (a :: k)) where + omittedField = Just $ DefSing $ fromSing (sing @a) + parseJSON v = DefSing <$> parseJSON v +``` + +And then the definition of the field can be for any singleton (e.g. Bool): + +```haskell +flag :: DefaultField d (DefSing True) +``` diff --git a/aeson-generic-default.cabal b/aeson-generic-default.cabal new file mode 100644 --- /dev/null +++ b/aeson-generic-default.cabal @@ -0,0 +1,79 @@ +cabal-version: 3.0 +name: aeson-generic-default +version: 0.1.0.0 +synopsis: Type-level default fields for aeson Generic FromJSON parser +description: Define default values for missing FromJSON object fields within field type declaration. + + It becomes handy e.g. for parsing yaml configuration files. The default values are mostly defined + directly at the type level so that the user doesn't have to write manual FromJSON instance. + +license: BSD-3-Clause +license-file: LICENSE +author: Ondrej Palkovsky +maintainer: palkovsky.ondrej@gmail.com +-- copyright: +category: Text, Web, JSON +build-type: Simple +extra-doc-files: CHANGELOG.md README.md +tested-with: GHC == 9.2.8, GHC == 9.6.5, GHC == 9.10.1 +homepage: https://github.com/ondrap/aeson-generic-default +bug-reports: https://github.com/ondrap/aeson-generic-default/issues + +common warnings + ghc-options: -Wall + +common extensions + default-extensions: + AllowAmbiguousTypes + DataKinds + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DerivingVia + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoMonomorphismRestriction + OverloadedStrings + OverloadedRecordDot + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeOperators + GADTs + PatternSynonyms + +library + import: warnings, extensions + exposed-modules: Data.Aeson.DefaultField + build-depends: + base >=4.16 && < 4.21, + aeson >= 2.2 && < 2.3, + data-default >= 0.7 && < 0.8, + text >= 2.0 && < 2.2 + hs-source-dirs: src + default-language: GHC2021 + +test-suite aeson-default-field-test + import: warnings, extensions + default-language: GHC2021 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base, + aeson-generic-default, + tasty, + tasty-hunit, + aeson, + text, + data-default diff --git a/src/Data/Aeson/DefaultField.hs b/src/Data/Aeson/DefaultField.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/DefaultField.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Data.Aeson.DefaultField +-- License : BSD-style +-- +-- Maintainer : palkovsky.ondrej@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Type-level default fields for aeson Generic FromJSON parser +-- + +module Data.Aeson.DefaultField ( + -- * How to use this library + -- $use + + -- * How to extend the library + -- $extend + + -- * Caveats + -- $caveats + + -- * Main field types and functions + DefaultField + , ParseStage(Final) + , parseWithDefaults + -- * Different basic types + , DefInt(..) + , DefNegativeInt(..) + , DefText(..) + , DefString(..) + , DefBool(..) + , DefDefault(..) + -- * Support for newtype default constants + , DefaultConstant(..) + , DefDefaultConstant(..) +) where + +import GHC.TypeLits (Nat, KnownNat, Symbol, KnownSymbol, natVal, symbolVal) +import Data.Aeson (FromJSON(..), genericParseJSON) +import qualified Data.Aeson as AE +import qualified Data.Text as T +import GHC.Generics +import Data.Kind (Type) +import Data.Coerce (Coercible, coerce) +import Data.Aeson.Types (Parser) +import Data.Proxy (Proxy(..)) +import Data.String (fromString) +import Data.Default (Default (def)) + +-- | Boolean default field +newtype DefBool (a :: Bool) = DefBool Bool + deriving (Generic) +instance FromJSON (DefBool True) where + omittedField = Just (DefBool True) + parseJSON v = DefBool <$> parseJSON v +instance FromJSON (DefBool False) where + omittedField = Just (DefBool False) + parseJSON v = DefBool <$> parseJSON v + +-- | Positive Int default field (only positive numbers are supported as type parameters) +newtype DefInt (num :: Nat) = DefInt Int + deriving (Generic) +instance KnownNat num => FromJSON (DefInt num) where + omittedField = Just (DefInt (fromIntegral $ natVal (Proxy @num))) + parseJSON v = DefInt <$> parseJSON v + +-- | Negative Int default field +newtype DefNegativeInt (num :: Nat) = DefNegativeInt Int + deriving (Generic) +instance KnownNat num => FromJSON (DefNegativeInt num) where + omittedField = Just (DefNegativeInt (negate $ fromIntegral $ natVal (Proxy @num))) + parseJSON v = DefNegativeInt <$> parseJSON v + +-- | Text default field +newtype DefText (x :: Symbol) = DefText T.Text + deriving (Generic) +instance KnownSymbol sym => FromJSON (DefText sym) where + omittedField = Just (DefText (fromString $ symbolVal (Proxy @sym))) + parseJSON v = DefText <$> parseJSON v + +-- | String default field +newtype DefString (x :: Symbol) = DefString String + deriving (Generic) +instance KnownSymbol sym => FromJSON (DefString sym) where + omittedField = Just (DefString (symbolVal (Proxy @sym))) + parseJSON v = DefString <$> parseJSON v + +-- | Default field using the "Default" class +newtype DefDefault a = DefDefault a + deriving (Generic) +instance (FromJSON a, Default a) => FromJSON (DefDefault a) where + omittedField = Just (DefDefault def) + parseJSON v = DefDefault <$> parseJSON v + + +-- | Default class for 'DefDefaultConstant' field configuration +class (Generic a, GNewtype (Rep a)) => DefaultConstant a where + defValue :: Proxy a -> EmbeddedType (Rep a) + +-- | Use 'DefaultConstant' type as a default value for a field. +-- +-- E.g. you cannot create a direct settings for real numbers; however, you can do this: +-- +-- > newtype Pi = Pi Double deriving Generic +-- > instance DefaultConstant Pi where +-- > defValue _ = 3.141592654 +-- > +-- > data MyObjectT d = MyObject { +-- > phaseAngle :: DefaultField d (DefDefaultConstant Pi) +-- > } deriving Generic +newtype DefDefaultConstant a = DefDefaultConstant (EmbeddedType (Rep a)) + deriving (Generic) +instance (DefaultConstant a, FromJSON (EmbeddedType (Rep a))) => FromJSON (DefDefaultConstant a) where + omittedField = Just (DefDefaultConstant $ defValue (Proxy @a)) + parseJSON v = DefDefaultConstant <$> parseJSON v + +-- | Kind for separating parsing with defaults and the final type +data ParseStage = + InsertDefaults -- ^ Use this type to instantiate the intermediate data type for parsing defaults + | Final -- ^ Use this type to instantiate the final data type (e.g. using the type alias) + +-- | Higher-kinded-type that either instantiates the field to a newtype that +-- decodes the default value if not present; or instantiates to the type +-- embedded in the newtype parameter +type family DefaultField (m :: ParseStage) a where + DefaultField InsertDefaults a = a + DefaultField Final a = EmbeddedType (Rep a) + +-- | Copied from newtype-generics package; this way we get the type inside the newtype +class GNewtype n where + type EmbeddedType n :: Type -- ^ Type function to retrieve the type embedded in the newtype +instance GNewtype (D1 d (C1 c (S1 s (K1 i a)))) where + type EmbeddedType (D1 d (C1 c (S1 s (K1 i a)))) = a + +-- | 'genericParseJSON' drop-in replacement +parseWithDefaults :: forall (o :: ParseStage -> Type) x. + (AE.GFromJSON AE.Zero (Rep (o InsertDefaults)) + , Generic (o InsertDefaults), Generic (o Final) + , Coercible (Rep (o InsertDefaults) x) (Rep (o Final) x) + ) + => AE.Options -> AE.Value -> Parser (o Final) +parseWithDefaults opts v = do + (dx :: o InsertDefaults) <- genericParseJSON opts v + return $ to @_ @x (coerce (from @_ @x dx)) + +-- $use +-- +-- @ +-- import Data.Aeson ( FromJSON(parseJSON), decode ) +-- import Data.Default ( Default(..) ) +-- import GHC.Generics (Generic) +-- import qualified Data.Text as T +-- import qualified Data.Aeson as AE +-- import Data.Aeson.DefaultField +-- +-- -- Define some custom datatype for json data +-- data Color = Red | Green | Blue deriving (Generic, 'FromJSON', Show) +-- +-- -- We may want a default instance for later use with 'DefDefault' +-- instance 'Default' Color where +-- def = Red +-- +-- -- Alternatively, we may create a separate default type that would be coerced back +-- -- to Color with 'DefDefaultConstant'. This allows for different default values +-- -- with the same type for different fields. +-- newtype BlueDefault = BlueDefault Color deriving Generic +-- instance 'DefaultConstant' BlueDefault where +-- defValue _ = Blue +-- +-- -- Simply create the data object we want to parse from the file; add a type parameter +-- -- so that we can use the type family magic to create 2 different type representations. +-- -- Normal fields act normally. Use 'DefaultField' with the appropriate settings +-- -- to configure the parsing of the missing fields. Null fields are NOT replaced +-- -- with the default value; only missing fields are. +-- data ConfigFileT d = ConfigFile { +-- defaultEnabled :: 'DefaultField' d ('DefBool' True) +-- , defaultDisabled :: 'DefaultField' d ('DefBool' False) +-- , defaultText :: 'DefaultField' d ('DefText' "default text") +-- , defaultInt :: 'DefaultField' d ('DefInt' 42) +-- , defaultNegativeInt :: 'DefaultField' d ('DefNegativeInt' 42) +-- , defaultRed :: 'DefaultField' d ('DefDefault' Color) +-- , defaultBlue :: 'DefaultField' d ('DefDefaultConstant' BlueDefault) +-- , normalField :: T.Text +-- , normalOptional :: Maybe Int +-- } deriving (Generic) +-- +-- -- Create a type alias so that we can (mostly) handle the type as if nothing special +-- -- was happening under the hood. +-- type ConfigFile = ConfigFileT 'Final' +-- deriving instance Show ConfigFile +-- +-- -- Create a custom parsing instance for the data object. +-- instance FromJSON ConfigFile where +-- parseJSON = 'parseWithDefaults' AE.defaultOptions{AE.rejectUnknownFields=True} +-- +-- @ +-- +-- >>> AE.decode "{\"defaultDisabled\":true,\"normalField\":\"text\"}" :: Maybe ConfigFile +-- >>> Just (ConfigFile { +-- defaultEnabled = True +-- , defaultDisabled = True +-- , defaultText = "default text" +-- , defaultInt = 42 +-- , defaultNegativeInt = -42 +-- , defaultRed = Red +-- , defaultBlue = Blue +-- , normalField = "text" +-- , normalOptional = Nothing} +-- ) + +-- $extend +-- +-- The provided 'DefText', 'DefInt', etc. newtypes should provide enough flexibility to configure the missing +-- fields for the objects. If a special type of configuration is needed, a /newtype/ +-- based on a final type must be created with 'Generic' and 'FromJSON' instances. +-- See the source code for examples. +-- +-- The default newtypes do not replace null value with the default value. You can create your own +-- types that behave differently. +-- +-- E.g. a configuration that would use the singletons package is: +-- +-- > newtype DefSing (a :: k) = DefSing (Demote k) deriving Generic +-- > instance (SingI a, SingKind k, FromJSON (Demote k)) => FromJSON (DefSing (a :: k)) where +-- > omittedField = Just $ DefSing $ fromSing (sing @a) +-- > parseJSON v = DefSing <$> parseJSON v +-- +-- The configuration would then be: +-- +-- > defaultBool :: DefaultField d (DefSing False) + +-- $caveats +-- +-- The final step in the parsing is coercing the structure with newtypes (e.g. 'DefBool') to +-- a structure with the final types (e.g. Bool). Unfortunately, the type families in Haskell +-- cause the type not to be directly coercible between the intermediate and the 'Final' stage. +-- However, it is possible through the Generic instances. +-- +-- This solution probably brings some performance degradation in the sense that the structure +-- must be recreated. Benchmark before use in performance-sensitive situations. diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,76 @@ +module Main (main) where + +import Test.Tasty +import Test.Tasty.HUnit +import qualified Data.Aeson as AE +import Data.Aeson.DefaultField +import GHC.Generics (Generic) +import Data.Default (Default(..)) +import qualified Data.Text as T +import Data.Aeson (FromJSON(..)) +import Data.Either (isLeft) + +data Color = Red | Green | Blue + deriving (Show, Eq, Generic, FromJSON) +instance Default Color where + def = Red + +newtype BlueDefault = BlueDefault Color deriving Generic +instance DefaultConstant BlueDefault where + defValue _ = Blue + +data ConfigFileT d = ConfigFile { + defaultEnabled :: DefaultField d (DefBool True) +, defaultDisabled :: DefaultField d (DefBool False) +, defaultText :: DefaultField d (DefText "default text") +, defaultInt :: DefaultField d (DefInt 42) +, defaultNegativeInt :: DefaultField d (DefNegativeInt 42) +, defaultRed :: DefaultField d (DefDefault Color) +, defaultBlue :: DefaultField d (DefDefaultConstant BlueDefault) +, normalField :: T.Text +, normalOptional :: Maybe Int +} deriving (Generic) + +type ConfigFile = ConfigFileT Final +deriving instance Show ConfigFile +deriving instance Eq ConfigFile +instance FromJSON ConfigFile where + parseJSON = parseWithDefaults AE.defaultOptions + + +main :: IO () +main = defaultMain $ testGroup "Tests" [ + testCase "Basic empty input" $ do + let decoded = AE.eitherDecode "{\"normalField\":\"input\"}" + expectedResult1 :: ConfigFile + expectedResult1 = ConfigFile { + defaultEnabled = True + , defaultDisabled = False + , defaultText = "default text" + , defaultInt = 42 + , defaultNegativeInt = -42 + , defaultRed = Red + , defaultBlue = Blue + , normalField = "input" + , normalOptional = Nothing + } + decoded @?= Right expectedResult1 + , testCase "Basic partial input" $ do + let decoded = AE.eitherDecode "{\"normalField\":\"input\", \"defaultEnabled\":false,\"defaultRed\":\"Green\", \"defaultNegativeInt\":2}" + expectedResult1 :: ConfigFile + expectedResult1 = ConfigFile { + defaultEnabled = False + , defaultDisabled = False + , defaultText = "default text" + , defaultInt = 42 + , defaultNegativeInt = 2 + , defaultRed = Green + , defaultBlue = Blue + , normalField = "input" + , normalOptional = Nothing + } + decoded @?= Right expectedResult1 + , testCase "Basic null input" $ do + let decoded = AE.eitherDecode "{\"normalField\":\"input\", \"defaultEnabled\":null}" :: Either String ConfigFile + assertBool "Should fail on null value in default field" (isLeft decoded) + ]