generic-override-aeson (empty) → 0.0.0.0
raw patch · 5 files changed
+367/−0 lines, 5 filesdep +aesondep +basedep +generic-override
Dependencies added: aeson, base, generic-override, generic-override-aeson, hspec, text
Files
- LICENSE +30/−0
- generic-override-aeson.cabal +48/−0
- src/Data/Override/Aeson.hs +46/−0
- test/LispCaseAeson.hs +34/−0
- test/Test.hs +209/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Estatico Studios LLC (c) 2020++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 Estatico Studios LLC 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.
+ generic-override-aeson.cabal view
@@ -0,0 +1,48 @@+cabal-version: 1.12+name: generic-override-aeson+version: 0.0.0.0+license: BSD3+license-file: LICENSE+copyright: 2020 Estatico Studios LLC+maintainer: carymrobbins@gmail.com+author: Cary Robbins+homepage: https://github.com/estatico/generic-override#readme+bug-reports: https://github.com/estatico/generic-override/issues+synopsis: Provides orphan instances necessary for integrating generic-override and aeson+description:+ Please see the README on GitHub at <https://github.com/estatico/generic-override#readme>+category: Generics+build-type: Simple++source-repository head+ type: git+ location: https://github.com/estatico/generic-override++library+ exposed-modules:+ Data.Override.Aeson+ hs-source-dirs: src+ other-modules:+ Paths_generic_override_aeson+ default-language: Haskell2010+ build-depends:+ aeson >=1.4.5.0 && <1.5,+ base >=4.7 && <5,+ generic-override >=0.0.0.0 && <0.1++test-suite generic-override-aeson-test+ type: exitcode-stdio-1.0+ main-is: Test.hs+ hs-source-dirs: test+ other-modules:+ LispCaseAeson+ Paths_generic_override_aeson+ default-language: Haskell2010+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ aeson >=1.4.5.0 && <1.5,+ base >=4.7 && <5,+ generic-override >=0.0.0.0 && <0.1,+ generic-override-aeson -any,+ hspec >=2.7.1 && <2.8,+ text >=1.2.3.1 && <1.3
+ src/Data/Override/Aeson.hs view
@@ -0,0 +1,46 @@+-- | This module contains only orphan instances. It is only needed to+-- be imported where you are overriding instances for aeson generic derivation.++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.Override.Aeson where++import Data.Coerce (Coercible, coerce)+import Data.Override (Override, Overridden(Overridden), Using)+import GHC.Generics (Generic, Rep)+import qualified Data.Aeson as Aeson++instance+ ( Generic (Override a xs)+ , Aeson.GToJSON Aeson.Zero (Rep (Override a xs))+ , Aeson.GToEncoding Aeson.Zero (Rep (Override a xs))+ ) => Aeson.ToJSON (Override a xs)++instance+ ( Coercible a (Using ms a xs)+ , Aeson.ToJSON (Using ms a xs)+ ) => Aeson.ToJSON (Overridden ms a xs)+ where+ toJSON = Aeson.toJSON @(Using ms a xs) . coerce+ toEncoding = Aeson.toEncoding @(Using ms a xs) . coerce++instance+ ( Generic (Override a xs)+ , Aeson.GFromJSON Aeson.Zero (Rep (Override a xs))+ ) => Aeson.FromJSON (Override a xs)++instance+ ( Coercible a (Using ms a xs)+ , Aeson.FromJSON (Using ms a xs)+ ) => Aeson.FromJSON (Overridden ms a xs)+ where+ parseJSON = coerce . Aeson.parseJSON @(Using ms a xs)
+ test/LispCaseAeson.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+module LispCaseAeson where++import Data.Aeson (ToJSON, FromJSON)+import GHC.Generics (Generic, Rep)+import qualified Data.Aeson as Aeson+import qualified Data.Char as Char++newtype LispCase a = LispCase a++viaLispCaseAesonOptions :: Aeson.Options+viaLispCaseAesonOptions =+ Aeson.defaultOptions+ { Aeson.fieldLabelModifier = \s -> do+ c <- s+ if Char.isUpper c then ['-', Char.toLower c] else [c]+ }++instance+ ( Generic a+ , Aeson.GToJSON Aeson.Zero (Rep a)+ , Aeson.GToEncoding Aeson.Zero (Rep a)+ ) => ToJSON (LispCase a)+ where+ toJSON (LispCase a) = Aeson.genericToJSON viaLispCaseAesonOptions a+ toEncoding (LispCase a) = Aeson.genericToEncoding viaLispCaseAesonOptions a++instance+ ( Generic a+ , Aeson.GFromJSON Aeson.Zero (Rep a)+ ) => FromJSON (LispCase a)+ where+ parseJSON v = LispCase <$> Aeson.genericParseJSON viaLispCaseAesonOptions v
+ test/Test.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+module Main where++import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON), Result(Success), fromJSON)+import Data.Aeson.QQ.Simple (aesonQQ)+import Data.Override (Override(Override), As)+import Data.Override.Aeson ()+import Data.Text (Text)+import GHC.Generics (Generic)+import LispCaseAeson (LispCase(LispCase))+import qualified Data.Text as Text+import Test.Hspec+import Text.Read (readMaybe)++main :: IO ()+main = hspec do+ describe "Override ToJSON machinery" do+ it "Rec1" testRec1+ it "Rec2" testRec2+ it "Rec3" testRec3+ it "Rec4" testRec4+ it "Rec5" testRec5+ it "Rec6" testRec6++newtype Uptext = Uptext { unUptext :: Text }++instance ToJSON Uptext where+ toJSON = toJSON . Text.toUpper . unUptext++newtype Shown a = Shown { unShown :: a }++instance (Show a) => ToJSON (Shown a) where+ toJSON = toJSON . show . unShown++instance (Read a) => FromJSON (Shown a) where+ parseJSON v = do+ s <- parseJSON v+ case readMaybe s of+ Nothing -> fail "read: no parse"+ Just a -> pure $ Shown a++newtype CharArray s = CharArray { unCharArray :: s }+ deriving stock (Functor)++instance ToJSON (CharArray String) where+ toJSON = toJSON . map (:[]) . unCharArray++instance FromJSON (CharArray String) where+ parseJSON v = do+ cs :: [String] <- parseJSON v+ pure $ CharArray $ concat cs++instance ToJSON (CharArray Text) where+ toJSON = toJSON . fmap Text.unpack++-- | Overriding instances by type.+data Rec1 = Rec1+ { foo :: Int+ , bar :: String+ , baz :: Text+ } deriving stock (Show, Eq, Generic)+ deriving (ToJSON)+ via Override Rec1+ '[ Text `As` Uptext+ , Int `As` Shown Int+ ]++testRec1 :: IO ()+testRec1 = do+ let r = Rec1 { foo = 12, bar = "hi", baz = "bye" }+ toJSON r `shouldBe` [aesonQQ|+ {+ "foo": "12",+ "bar": "hi",+ "baz": "BYE"+ }+ |]++-- | Overriding instances by field name.+data Rec2 = Rec2+ { foo :: Int+ , bar :: Text+ , baz :: Text+ } deriving stock (Show, Eq, Generic)+ deriving (ToJSON)+ via Override Rec2+ '[ "baz" `As` CharArray Text+ , "bar" `As` Uptext+ ]++testRec2 :: IO ()+testRec2 = do+ let r = Rec2 { foo = 12, bar = "hi", baz = "bye" }+ toJSON r `shouldBe` [aesonQQ|+ {+ "foo": 12,+ "bar": "HI",+ "baz": ["b", "y", "e"]+ }+ |]++-- | Overriding instances by type and field name.+data Rec3 = Rec3+ { foo :: Int+ , bar :: String+ , baz :: Text+ } deriving stock (Show, Eq, Generic)+ deriving (ToJSON)+ via Override Rec3+ '[ String `As` CharArray String+ , "foo" `As` Shown Int+ , Text `As` Uptext+ ]++testRec3 :: IO ()+testRec3 = do+ let r = Rec3 { foo = 12, bar = "hi", baz = "bye" }+ toJSON r `shouldBe` [aesonQQ|+ {+ "foo": "12",+ "bar": ["h", "i"],+ "baz": "BYE"+ }+ |]++-- | Overriding instance by type and field name; first match wins.+-- In this case, 'foo' and 'bar' use 'CharArray Text' and 'baz' uses 'Uptext'.+data Rec4 = Rec4+ { foo :: Text+ , bar :: Text+ , baz :: Text+ } deriving stock (Show, Eq, Generic)+ deriving (ToJSON)+ via Override Rec4+ '[ "baz" `As` Uptext+ , Text `As` CharArray Text+ ]++testRec4 :: IO ()+testRec4 = do+ let r = Rec4 { foo = "go", bar = "hi", baz = "bye" }+ toJSON r `shouldBe` [aesonQQ|+ {+ "foo": ["g", "o"],+ "bar": ["h", "i"],+ "baz": "BYE"+ }+ |]++-- We can compose an 'Override' with another deriving-via newtype, 'LispCase'.+data Rec5 = Rec5+ { fooBar :: Int+ , baz :: Text+ , quuxSpamEggs :: String+ } deriving stock (Show, Eq, Generic)+ deriving (ToJSON)+ via LispCase (Override Rec5+ '[ "fooBar" `As` Shown Int+ , Text `As` Uptext+ , "quuxSpamEggs" `As` CharArray String+ ])++testRec5 :: IO ()+testRec5 = do+ let r = Rec5 { fooBar = 1, baz = "hi", quuxSpamEggs = "bye" }+ toJSON r `shouldBe` [aesonQQ|+ {+ "foo-bar": "1",+ "baz": "HI",+ "quux-spam-eggs": ["b", "y", "e"]+ }+ |]++-- Test 'Override' for both 'ToJSON' and 'FromJSON'.+data Rec6 = Rec6+ { foo :: Int+ , bar :: String+ , baz :: Text+ } deriving stock (Show, Eq, Generic)+ deriving (ToJSON, FromJSON)+ via Override Rec6+ '[ "foo" `As` Shown Int+ , String `As` CharArray String+ ]++testRec6 :: IO ()+testRec6 = do+ let r = Rec6 { foo = 1, bar = "hi", baz = "bye" }+ let j = [aesonQQ|+ {+ "foo": "1",+ "bar": ["h", "i"],+ "baz": "bye"+ }+ |]+ toJSON r `shouldBe` j+ fromJSON j `shouldBe` Success r