├── .github └── workflows │ └── haskell.yml ├── .gitignore ├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── cabal.project ├── generic-override-aeson ├── CHANGELOG.md ├── LICENSE ├── README.md ├── generic-override-aeson.cabal ├── src │ └── Data │ │ └── Override │ │ ├── Aeson.hs │ │ └── Aeson │ │ └── Options │ │ └── Internal.hs └── test │ ├── LispCaseAeson.hs │ └── Test.hs ├── generic-override ├── CHANGELOG.md ├── LICENSE ├── README.md ├── generic-override.cabal ├── src │ └── Data │ │ ├── Override.hs │ │ └── Override │ │ ├── Instances.hs │ │ └── Internal.hs └── test │ ├── Encode.hs │ └── Test.hs ├── stack.yaml └── stack.yaml.lock /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: 4 | push: 5 | branches: [ master ] 6 | pull_request: 7 | branches: [ master ] 8 | 9 | jobs: 10 | build: 11 | 12 | runs-on: ubuntu-latest 13 | 14 | steps: 15 | - uses: actions/checkout@v2 16 | - uses: actions/setup-haskell@v1 17 | with: 18 | ghc-version: '8.10.3' 19 | cabal-version: '3.2' 20 | 21 | - name: Cache 22 | uses: actions/cache@v1 23 | env: 24 | cache-name: cache-cabal 25 | with: 26 | path: ~/.cabal 27 | key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} 28 | restore-keys: | 29 | ${{ runner.os }}-build-${{ env.cache-name }}- 30 | ${{ runner.os }}-build- 31 | ${{ runner.os }}- 32 | 33 | - name: Install dependencies 34 | run: | 35 | cabal update 36 | cabal build --only-dependencies --enable-tests --enable-benchmarks all 37 | - name: Build 38 | run: cabal build --enable-tests --enable-benchmarks all 39 | - name: Run tests 40 | run: cabal test all 41 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ 3 | *.swp 4 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Mostly adapted from https://docs.haskellstack.org/en/stable/travis_ci/ 2 | sudo: false 3 | 4 | cache: 5 | directories: 6 | - $HOME/.stack 7 | 8 | before_install: 9 | # Download and unpack the stack executable 10 | - mkdir -p ~/.local/bin 11 | - export PATH=$HOME/.local/bin:$PATH 12 | - travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 13 | 14 | install: 15 | - travis_wait stack --no-terminal --skip-ghc-check setup 16 | - travis_wait stack --no-terminal --skip-ghc-check test --only-snapshot 17 | 18 | script: 19 | - make ci 20 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Estatico Studios LLC (c) 2020 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Estatico Studios LLC nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: default sync build test clean ci 2 | 3 | default: sync build test 4 | 5 | sync: 6 | ./tools/sync 7 | 8 | # Build all targets, including tests. 9 | build: sync 10 | stack test --no-run-tests --pedantic 11 | 12 | # Runs the test suite. 13 | test: build 14 | stack test --pedantic 15 | 16 | # Clean build artifacts 17 | clean: 18 | stack clean 19 | 20 | # Used in the 'script' portion of .travis.yml 21 | ci: 22 | ./tools/sync --validate 23 | stack --no-terminal --skip-ghc-check test --pedantic 24 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # generic-override 2 | 3 | [![Build](https://img.shields.io/travis/estatico/generic-override.svg?logo=travis)](http://travis-ci.org/estatico/generic-override) 4 | 5 | | Library | Version | 6 | | ---------------------- | ------- | 7 | | generic-override | [![generic-override](https://img.shields.io/hackage/v/generic-override.svg?logo=haskell&color=blueviolet)](https://hackage.haskell.org/package/generic-override) | 8 | | generic-override-aeson | [![generic-override-aeson](https://img.shields.io/hackage/v/generic-override-aeson.svg?logo=haskell&color=blueviolet)](https://hackage.haskell.org/package/generic-override-aeson) | 9 | 10 | ------------------------- 11 | 12 | For the associated blog post describing how this works, see 13 | [Overriding Type Class Instances](http://caryrobbins.com/dev/overriding-type-class-instances-2/). 14 | 15 | ------------------------- 16 | 17 | This library provides the ability to override instances used by generic derivation. 18 | 19 | ## Example 20 | 21 | ```haskell 22 | -- Needed for constructing our 'Override' type in the DerivingVia clause. 23 | import Data.Override (Override(Override), As) 24 | -- Provides aeson support for generic-override (lives in generic-override-aeson). 25 | import Data.Override.Aeson () 26 | -- Basic imports we need for the example. 27 | import Data.Aeson (ToJSON(toJSON)) 28 | import Data.Text (Text) 29 | import qualified Data.Text as Text 30 | 31 | -- | A simple record type. We'll use generic derivation for the 'ToJSON' instance 32 | -- but override the instances used by derivation for the 'String' and 'baz' 33 | -- fields. 34 | data MyRec = MyRec 35 | { foo :: Int 36 | , bar :: String 37 | , baz :: Text 38 | } deriving stock (Show, Eq, Generic) 39 | deriving (ToJSON) 40 | via Override MyRec 41 | '[ -- Derive the 'String' field via 'CharArray'. 42 | String `As` CharArray 43 | -- Derive the 'baz' field via 'Uptext'. 44 | , "baz" `As` Uptext 45 | ] 46 | 47 | -- | Newtype wrapper to override 'ToJSON Text' instances with ones that 48 | -- encode the 'Text' as uppercase. 49 | newtype Uptext = Uptext { unUptext :: Text } 50 | 51 | instance ToJSON Uptext where 52 | toJSON = toJSON . Text.toUpper . unUptext 53 | 54 | -- | Newtype wrapper to override 'ToJSON String' instances with ones that 55 | -- encode the 'String' as a JSON array of characters. 56 | newtype CharArray = CharArray { unCharArray :: String } 57 | 58 | instance ToJSON CharArray where 59 | toJSON = toJSON . map (:[]) . unCharArray 60 | ``` 61 | 62 | Let's serialize an example `MyRec` to JSON - 63 | 64 | ```haskell 65 | % ghci 66 | > :{ 67 | Data.ByteString.Lazy.Char8.putStrLn 68 | $ Data.Aeson.encode 69 | $ Data.Aeson.toJSON MyRec { foo = 12, bar = "hi", baz = "bye" } 70 | :} 71 | {"foo":12,"bar":["h","i"],"baz":"BYE"} 72 | ``` 73 | 74 | For more examples, see the test suites in - 75 | * [generic-override](https://github.com/estatico/generic-override/blob/master/generic-override/test/Test.hs). 76 | * [generic-override-aeson](https://github.com/estatico/generic-override/blob/master/generic-override-aeson/test/Test.hs). 77 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: */*.cabal 2 | -------------------------------------------------------------------------------- /generic-override-aeson/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog for generic-override-aeson 2 | 3 | ## 0.4.0.0 4 | 5 | * Add `WithAesonOptions` support 6 | * Bumping dependency bounds to support generic-override 0.4 7 | * Because this version of generic-override no longer uses `Overridden` under 8 | the hood, this solves a problem where `omitNothingFields` had no effect 9 | due to aeson's incoherent `Maybe` instance not being solved. The new 10 | encoding solves this problem and `omitNothingFields` works as expected. 11 | 12 | ## 0.3.0.0 13 | 14 | * Bumping dependency bounds to support generic-override 0.3 15 | 16 | ## 0.0.0.2 17 | 18 | * Bumping dependency bounds to support aeson 1.5 19 | 20 | ## 0.0.0.0 21 | 22 | * Initial release 23 | -------------------------------------------------------------------------------- /generic-override-aeson/LICENSE: -------------------------------------------------------------------------------- 1 | ../LICENSE -------------------------------------------------------------------------------- /generic-override-aeson/README.md: -------------------------------------------------------------------------------- 1 | ../README.md -------------------------------------------------------------------------------- /generic-override-aeson/generic-override-aeson.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.4. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: generic-override-aeson 8 | version: 0.4.0.0 9 | synopsis: Provides orphan instances necessary for integrating generic-override and aeson 10 | description: Please see the README on GitHub at 11 | category: Generics 12 | homepage: https://github.com/estatico/generic-override#readme 13 | bug-reports: https://github.com/estatico/generic-override/issues 14 | author: Cary Robbins 15 | maintainer: carymrobbins@gmail.com 16 | copyright: 2020 Estatico Studios LLC 17 | license: BSD3 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | CHANGELOG.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/estatico/generic-override 27 | 28 | library 29 | exposed-modules: 30 | Data.Override.Aeson 31 | Data.Override.Aeson.Options.Internal 32 | other-modules: 33 | Paths_generic_override_aeson 34 | hs-source-dirs: 35 | src 36 | ghc-options: -Wall 37 | build-depends: 38 | aeson >=1.4 && <3 39 | , base >=4.7 && <5 40 | , generic-override >= 0.4.0.0 && < 0.5 41 | default-language: Haskell2010 42 | 43 | test-suite generic-override-aeson-test 44 | type: exitcode-stdio-1.0 45 | main-is: Test.hs 46 | other-modules: 47 | LispCaseAeson 48 | Paths_generic_override_aeson 49 | hs-source-dirs: 50 | test 51 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 52 | build-depends: 53 | aeson >=1.4 && <3 54 | , base >=4.7 && <5 55 | , generic-override 56 | , generic-override-aeson 57 | , hspec 58 | , text 59 | default-language: Haskell2010 60 | -------------------------------------------------------------------------------- /generic-override-aeson/src/Data/Override/Aeson.hs: -------------------------------------------------------------------------------- 1 | -- | The public, stable @generic-override-aeson@ API. 2 | -- Provides orphan instances for 'Override' as well as customization 3 | -- for aeson's 'Options' when using @DerivingVia@. 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE MonoLocalBinds #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | {-# OPTIONS_GHC -fno-warn-orphans #-} 8 | module Data.Override.Aeson 9 | ( WithAesonOptions(..) 10 | , AesonOption(..) 11 | ) where 12 | 13 | import Data.Aeson 14 | import Data.Override (Override(..)) 15 | import Data.Override.Aeson.Options.Internal (AesonOption(..), WithAesonOptions(..)) 16 | import GHC.Generics (Generic, Rep) 17 | 18 | instance 19 | ( Generic (Override a xs) 20 | , GToJSON Zero (Rep (Override a xs)) 21 | , GToEncoding Zero (Rep (Override a xs)) 22 | ) => ToJSON (Override a xs) 23 | 24 | instance 25 | ( Generic (Override a xs) 26 | , GFromJSON Zero (Rep (Override a xs)) 27 | ) => FromJSON (Override a xs) 28 | -------------------------------------------------------------------------------- /generic-override-aeson/src/Data/Override/Aeson/Options/Internal.hs: -------------------------------------------------------------------------------- 1 | -- | This is the internal generic-override-aeson API and should be considered 2 | -- unstable and subject to change. In general, you should prefer to use the 3 | -- public, stable API provided by "Data.Override.Aeson". 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | module Data.Override.Aeson.Options.Internal where 13 | 14 | import Data.Aeson 15 | import Data.Coerce (coerce) 16 | import Data.Proxy (Proxy(..)) 17 | import GHC.Generics (Generic, Rep) 18 | import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) 19 | 20 | import qualified Data.Aeson as Aeson 21 | 22 | -- | Use with @DerivingVia@ to override Aeson @Options@ with a type-level 23 | -- list of 'AesonOption'. 24 | newtype WithAesonOptions (a :: *) (options :: [AesonOption]) = WithAesonOptions a 25 | 26 | instance 27 | ( ApplyAesonOptions options 28 | , Generic a 29 | , Aeson.GToJSON Aeson.Zero (Rep a) 30 | , Aeson.GToEncoding Aeson.Zero (Rep a) 31 | ) => ToJSON (WithAesonOptions a options) 32 | where 33 | toJSON = coerce $ genericToJSON @a $ applyAesonOptions (Proxy @options) defaultOptions 34 | toEncoding = coerce $ genericToEncoding @a $ applyAesonOptions (Proxy @options) defaultOptions 35 | 36 | instance 37 | ( ApplyAesonOptions options 38 | , Generic a 39 | , Aeson.GFromJSON Aeson.Zero (Rep a) 40 | ) => FromJSON (WithAesonOptions a options) 41 | where 42 | parseJSON = coerce $ genericParseJSON @a $ applyAesonOptions (Proxy @options) defaultOptions 43 | 44 | -- | Provides a type-level subset of fields from 'Options' 45 | data AesonOption = 46 | AllNullaryToStringTag Bool -- ^ Equivalient to @'allNullaryToStringTag' = b@ 47 | | OmitNothingFields -- ^ Equivalient to @'omitNothingFields' = True@ 48 | | SumEncodingTaggedObject Symbol Symbol -- ^ Equivalient to @'sumEncoding' = 'TaggedObject' k v@ 49 | | SumEncodingUntaggedValue -- ^ Equivalient to @'sumEncoding' = 'UntaggedValue'@ 50 | | SumEncodingObjectWithSingleField -- ^ Equivalient to @'sumEncoding' = 'ObjectWithSingleField'@ 51 | | SumEncodingTwoElemArray -- ^ Equivalient to @'sumEncoding' = 'TwoElemArray'@ 52 | | UnwrapUnaryRecords -- ^ Equivalient to @'unwrapUnaryRecords' = True@ 53 | | TagSingleConstructors -- ^ Equivalient to @'tagSingleConstructors' = True@ 54 | 55 | -- | Updates 'Options' given a type-level list of 'AesonOption'. 56 | class ApplyAesonOptions (options :: [AesonOption]) where 57 | applyAesonOptions :: Proxy options -> Options -> Options 58 | 59 | instance ApplyAesonOptions '[] where 60 | applyAesonOptions _ = id 61 | 62 | instance 63 | ( ApplyAesonOption option 64 | , ApplyAesonOptions options 65 | ) => ApplyAesonOptions (option ': options) 66 | where 67 | applyAesonOptions _ = 68 | applyAesonOption (Proxy @option) . (applyAesonOptions (Proxy @options)) 69 | 70 | -- | Updates 'Options' given a single type-level 'AesonOption'. 71 | class ApplyAesonOption (option :: AesonOption) where 72 | applyAesonOption :: Proxy option -> Options -> Options 73 | 74 | instance ApplyAesonOption ('AllNullaryToStringTag 'True) where 75 | applyAesonOption _ o = o { allNullaryToStringTag = True } 76 | 77 | instance ApplyAesonOption ('AllNullaryToStringTag 'False) where 78 | applyAesonOption _ o = o { allNullaryToStringTag = False } 79 | 80 | instance ApplyAesonOption 'OmitNothingFields where 81 | applyAesonOption _ o = o { omitNothingFields = True } 82 | 83 | instance (KnownSymbol k, KnownSymbol v) => ApplyAesonOption ('SumEncodingTaggedObject k v) where 84 | applyAesonOption _ o = o { sumEncoding = TaggedObject (symbolVal (Proxy @k)) (symbolVal (Proxy @v)) } 85 | 86 | instance ApplyAesonOption 'SumEncodingUntaggedValue where 87 | applyAesonOption _ o = o { sumEncoding = UntaggedValue } 88 | 89 | instance ApplyAesonOption 'SumEncodingObjectWithSingleField where 90 | applyAesonOption _ o = o { sumEncoding = ObjectWithSingleField } 91 | 92 | instance ApplyAesonOption 'SumEncodingTwoElemArray where 93 | applyAesonOption _ o = o { sumEncoding = TwoElemArray } 94 | 95 | instance ApplyAesonOption 'UnwrapUnaryRecords where 96 | applyAesonOption _ o = o { unwrapUnaryRecords = True } 97 | 98 | instance ApplyAesonOption 'TagSingleConstructors where 99 | applyAesonOption _ o = o { tagSingleConstructors = True } 100 | -------------------------------------------------------------------------------- /generic-override-aeson/test/LispCaseAeson.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | module LispCaseAeson where 4 | 5 | import Data.Aeson (ToJSON, FromJSON) 6 | import GHC.Generics (Generic, Rep) 7 | import qualified Data.Aeson as Aeson 8 | import qualified Data.Char as Char 9 | 10 | newtype LispCase a = LispCase a 11 | 12 | viaLispCaseAesonOptions :: Aeson.Options 13 | viaLispCaseAesonOptions = 14 | Aeson.defaultOptions 15 | { Aeson.fieldLabelModifier = \s -> do 16 | c <- s 17 | if Char.isUpper c then ['-', Char.toLower c] else [c] 18 | } 19 | 20 | instance 21 | ( Generic a 22 | , Aeson.GToJSON Aeson.Zero (Rep a) 23 | , Aeson.GToEncoding Aeson.Zero (Rep a) 24 | ) => ToJSON (LispCase a) 25 | where 26 | toJSON (LispCase a) = Aeson.genericToJSON viaLispCaseAesonOptions a 27 | toEncoding (LispCase a) = Aeson.genericToEncoding viaLispCaseAesonOptions a 28 | 29 | instance 30 | ( Generic a 31 | , Aeson.GFromJSON Aeson.Zero (Rep a) 32 | ) => FromJSON (LispCase a) 33 | where 34 | parseJSON v = LispCase <$> Aeson.genericParseJSON viaLispCaseAesonOptions v 35 | -------------------------------------------------------------------------------- /generic-override-aeson/test/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | {-# LANGUAGE DeriveGeneric #-} 6 | {-# LANGUAGE DerivingStrategies #-} 7 | {-# LANGUAGE DerivingVia #-} 8 | {-# LANGUAGE DuplicateRecordFields #-} 9 | {-# LANGUAGE FlexibleInstances #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE QuasiQuotes #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TypeApplications #-} 14 | {-# LANGUAGE TypeOperators #-} 15 | module Main where 16 | 17 | import Data.Aeson (FromJSON(parseJSON), Result(Success), ToJSON(toJSON), Value, fromJSON) 18 | import Data.Aeson.QQ.Simple (aesonQQ) 19 | import Data.Override (Override(Override), As, At, With) 20 | import Data.Override.Aeson (AesonOption(..), WithAesonOptions(..)) 21 | import Data.Text (Text) 22 | import GHC.Generics (Generic) 23 | import LispCaseAeson (LispCase(LispCase)) 24 | import Test.Hspec 25 | import Text.Read (readMaybe) 26 | 27 | import qualified Data.Text as Text 28 | 29 | main :: IO () 30 | main = hspec do 31 | describe "Override ToJSON machinery" do 32 | it "Rec1" testRec1 33 | it "Rec2" testRec2 34 | it "Rec3" testRec3 35 | it "Rec4" testRec4 36 | it "Rec5" testRec5 37 | it "Rec6" testRec6 38 | it "Rec7" testRec6 39 | it "Sum1" testSum1 40 | it "Options1" testOptions1 41 | 42 | newtype Uptext = Uptext { unUptext :: Text } 43 | 44 | instance ToJSON Uptext where 45 | toJSON = toJSON . Text.toUpper . unUptext 46 | 47 | newtype Shown a = Shown { unShown :: a } 48 | 49 | instance (Show a) => ToJSON (Shown a) where 50 | toJSON = toJSON . show . unShown 51 | instance (Read a) => FromJSON (Shown a) where 52 | parseJSON v = do 53 | s <- parseJSON v 54 | case readMaybe s of 55 | Nothing -> fail "read: no parse" 56 | Just a -> pure $ Shown a 57 | 58 | newtype CharArray s = CharArray { unCharArray :: s } 59 | deriving stock (Functor) 60 | 61 | instance ToJSON (CharArray String) where 62 | toJSON = toJSON . map (:[]) . unCharArray 63 | 64 | instance FromJSON (CharArray String) where 65 | parseJSON v = do 66 | cs :: [String] <- parseJSON v 67 | pure $ CharArray $ concat cs 68 | 69 | instance ToJSON (CharArray Text) where 70 | toJSON = toJSON . fmap Text.unpack 71 | 72 | -- | Overriding instances by type. 73 | data Rec1 = Rec1 74 | { foo :: Int 75 | , bar :: String 76 | , baz :: Text 77 | } deriving stock (Show, Eq, Generic) 78 | deriving (ToJSON) 79 | via Override Rec1 80 | '[ Text `As` Uptext 81 | , Int `As` Shown Int 82 | ] 83 | 84 | testRec1 :: IO () 85 | testRec1 = do 86 | toJSON Rec1 { foo = 12, bar = "hi", baz = "bye" } 87 | `shouldBe` [aesonQQ| 88 | { 89 | "foo": "12", 90 | "bar": "hi", 91 | "baz": "BYE" 92 | } 93 | |] 94 | 95 | -- | Overriding instances by field name. 96 | data Rec2 = Rec2 97 | { foo :: Int 98 | , bar :: Text 99 | , baz :: Text 100 | } deriving stock (Show, Eq, Generic) 101 | deriving (ToJSON) 102 | via Override Rec2 103 | '[ "baz" `As` CharArray Text 104 | , "bar" `As` Uptext 105 | ] 106 | 107 | testRec2 :: IO () 108 | testRec2 = do 109 | toJSON Rec2 { foo = 12, bar = "hi", baz = "bye" } 110 | `shouldBe` [aesonQQ| 111 | { 112 | "foo": 12, 113 | "bar": "HI", 114 | "baz": ["b", "y", "e"] 115 | } 116 | |] 117 | 118 | -- | Overriding instances by type and field name. 119 | data Rec3 = Rec3 120 | { foo :: Int 121 | , bar :: String 122 | , baz :: Text 123 | } deriving stock (Show, Eq, Generic) 124 | deriving (ToJSON) 125 | via Override Rec3 126 | '[ String `As` CharArray String 127 | , "foo" `As` Shown Int 128 | , Text `As` Uptext 129 | ] 130 | 131 | testRec3 :: IO () 132 | testRec3 = do 133 | toJSON Rec3 { foo = 12, bar = "hi", baz = "bye" } 134 | `shouldBe` [aesonQQ| 135 | { 136 | "foo": "12", 137 | "bar": ["h", "i"], 138 | "baz": "BYE" 139 | } 140 | |] 141 | 142 | -- | Overriding instance by type and field name; first match wins. 143 | -- In this case, 'foo' and 'bar' use 'CharArray Text' and 'baz' uses 'Uptext'. 144 | data Rec4 = Rec4 145 | { foo :: Text 146 | , bar :: Text 147 | , baz :: Text 148 | } deriving stock (Show, Eq, Generic) 149 | deriving (ToJSON) 150 | via Override Rec4 151 | '[ "baz" `As` Uptext 152 | , Text `As` CharArray Text 153 | ] 154 | 155 | testRec4 :: IO () 156 | testRec4 = do 157 | toJSON Rec4 { foo = "go", bar = "hi", baz = "bye" } 158 | `shouldBe` [aesonQQ| 159 | { 160 | "foo": ["g", "o"], 161 | "bar": ["h", "i"], 162 | "baz": "BYE" 163 | } 164 | |] 165 | 166 | -- We can compose an 'Override' with another deriving-via newtype, 'LispCase'. 167 | data Rec5 = Rec5 168 | { fooBar :: Int 169 | , baz :: Text 170 | , quuxSpamEggs :: String 171 | } deriving stock (Show, Eq, Generic) 172 | deriving (ToJSON) 173 | via LispCase (Override Rec5 174 | '[ "fooBar" `As` Shown Int 175 | , Text `As` Uptext 176 | , "quuxSpamEggs" `As` CharArray String 177 | ]) 178 | 179 | testRec5 :: IO () 180 | testRec5 = do 181 | toJSON Rec5 { fooBar = 1, baz = "hi", quuxSpamEggs = "bye" } 182 | `shouldBe` [aesonQQ| 183 | { 184 | "foo-bar": "1", 185 | "baz": "HI", 186 | "quux-spam-eggs": ["b", "y", "e"] 187 | } 188 | |] 189 | 190 | -- Test 'Override' for both 'ToJSON' and 'FromJSON'. 191 | data Rec6 = Rec6 192 | { foo :: Int 193 | , bar :: String 194 | , baz :: Text 195 | } deriving stock (Show, Eq, Generic) 196 | deriving (ToJSON, FromJSON) 197 | via Override Rec6 198 | '[ "foo" `As` Shown Int 199 | , String `As` CharArray String 200 | ] 201 | 202 | testRec6 :: IO () 203 | testRec6 = do 204 | Rec6 { foo = 1, bar = "hi", baz = "bye" } 205 | `shouldRoundtripAs` [aesonQQ| 206 | { 207 | "foo": "1", 208 | "bar": ["h", "i"], 209 | "baz": "bye" 210 | } 211 | |] 212 | 213 | -- Test 'Override' for both 'ToJSON' and 'FromJSON'. 214 | data Rec7 = Rec7 215 | { foo :: Int 216 | , bar :: String 217 | , baz :: Text 218 | } deriving stock (Show, Eq, Generic) 219 | deriving (ToJSON, FromJSON) 220 | via Override Rec7 221 | '[ "foo" `With` Shown 222 | , String `With` CharArray 223 | ] 224 | 225 | testRec7 :: IO () 226 | testRec7 = do 227 | Rec7 { foo = 1, bar = "hi", baz = "bye" } 228 | `shouldRoundtripAs` [aesonQQ| 229 | { 230 | "foo": "1", 231 | "bar": ["h", "i"], 232 | "baz": "bye" 233 | } 234 | |] 235 | 236 | newtype Reverse a = Reverse [a] 237 | 238 | instance (ToJSON a) => ToJSON (Reverse a) where 239 | toJSON (Reverse xs) = toJSON $ reverse xs 240 | 241 | instance (FromJSON a) => FromJSON (Reverse a) where 242 | parseJSON = fmap (Reverse . reverse) . parseJSON 243 | 244 | newtype Not = Not Bool 245 | 246 | instance ToJSON Not where 247 | toJSON (Not b) = toJSON $ not b 248 | 249 | instance FromJSON Not where 250 | parseJSON = fmap (Not . not) . parseJSON 251 | 252 | data Sum1 a = 253 | Sum1List [a] 254 | | Sum1Trip a Char Bool 255 | | Sum1Null 256 | deriving stock (Show, Eq, Generic) 257 | deriving (ToJSON, FromJSON) 258 | via Override (Sum1 a) 259 | '[ At "Sum1List" 0 (Reverse a) 260 | , At "Sum1Trip" 2 Not 261 | ] 262 | 263 | testSum1 :: IO () 264 | testSum1 = do 265 | Sum1List ['a', 'b'] `shouldRoundtripAs` [aesonQQ| 266 | { 267 | "tag": "Sum1List", 268 | "contents": "ba" 269 | } 270 | |] 271 | Sum1Trip 'a' 'b' True `shouldRoundtripAs` [aesonQQ| 272 | { 273 | "tag": "Sum1Trip", 274 | "contents": ["a", "b", false] 275 | } 276 | |] 277 | Sum1Null @Char `shouldRoundtripAs` [aesonQQ| 278 | { 279 | "tag": "Sum1Null" 280 | } 281 | |] 282 | 283 | 284 | data Options1 = 285 | Options1A { foo :: Maybe Int, bar :: String } 286 | | Options1B Options1BBody 287 | | Options1C 288 | deriving stock (Eq, Show, Generic) 289 | deriving (FromJSON, ToJSON) 290 | via Override Options1 291 | '[ "foo" `As` Maybe (Shown Int) 292 | ] `WithAesonOptions` 293 | '[ 'OmitNothingFields 294 | , 'SumEncodingTaggedObject "type" "data" 295 | ] 296 | 297 | data Options1BBody = Options1BBody { baz :: Int } 298 | deriving stock (Eq, Show, Generic) 299 | deriving anyclass (FromJSON, ToJSON) 300 | 301 | testOptions1 :: IO () 302 | testOptions1 = do 303 | Options1A { foo = Nothing, bar = "boo" } 304 | `shouldRoundtripAs` [aesonQQ| { "type": "Options1A", "bar": "boo" } |] 305 | Options1A { foo = Just 1, bar = "boo" } 306 | `shouldRoundtripAs` [aesonQQ| { "type": "Options1A", "foo": "1", "bar": "boo" } |] 307 | Options1B Options1BBody { baz = 2 } 308 | `shouldRoundtripAs` [aesonQQ| { "type": "Options1B", "data": { "baz": 2 } } |] 309 | Options1C 310 | `shouldRoundtripAs` [aesonQQ| { "type": "Options1C" } |] 311 | 312 | shouldRoundtripAs 313 | :: (ToJSON a, FromJSON a, Eq a, Show a, HasCallStack) 314 | => a -> Value -> IO () 315 | shouldRoundtripAs x j = do 316 | toJSON x `shouldBe` j 317 | fromJSON j `shouldBe` Success x 318 | -------------------------------------------------------------------------------- /generic-override/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog for generic-override 2 | 3 | ## 0.4.0.0 4 | 5 | * `At` support for overriding by constructor name and parameter index 6 | * Simplify encoding by removing `Overridden` 7 | * Implementation of `Generic` derivation a la `GOverride` now use `INLINE` 8 | 9 | ## 0.3.0.0 10 | 11 | * `Override` support for sum types 12 | * `As` support for higher kinds up (up to arity 10) 13 | 14 | ## 0.2.0.0 15 | 16 | * Instances for Eq, Ord, Semigroup, Monoid 17 | * Added With combinator 18 | 19 | ## 0.0.0.0 20 | 21 | * Initial release 22 | -------------------------------------------------------------------------------- /generic-override/LICENSE: -------------------------------------------------------------------------------- 1 | ../LICENSE -------------------------------------------------------------------------------- /generic-override/README.md: -------------------------------------------------------------------------------- 1 | ../README.md -------------------------------------------------------------------------------- /generic-override/generic-override.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.33.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 826716a7af5af9e3b3ed5bc07a6a669bc1e91c109f50eff9799be1d50aaa881a 8 | 9 | name: generic-override 10 | version: 0.4.0.0 11 | synopsis: Provides functionality for overriding instances for generic derivation 12 | description: Please see the README on GitHub at 13 | category: Generics 14 | homepage: https://github.com/estatico/generic-override#readme 15 | bug-reports: https://github.com/estatico/generic-override/issues 16 | author: Cary Robbins 17 | maintainer: carymrobbins@gmail.com 18 | copyright: 2020 Estatico Studios LLC 19 | license: BSD3 20 | license-file: LICENSE 21 | build-type: Simple 22 | extra-source-files: 23 | README.md 24 | CHANGELOG.md 25 | 26 | source-repository head 27 | type: git 28 | location: https://github.com/estatico/generic-override 29 | 30 | library 31 | exposed-modules: 32 | Data.Override 33 | Data.Override.Instances 34 | Data.Override.Internal 35 | other-modules: 36 | Paths_generic_override 37 | hs-source-dirs: 38 | src 39 | ghc-options: -Wall 40 | build-depends: 41 | base >=4.7 && <5 42 | default-language: Haskell2010 43 | 44 | test-suite generic-override-test 45 | type: exitcode-stdio-1.0 46 | main-is: Test.hs 47 | other-modules: 48 | Encode 49 | Paths_generic_override 50 | hs-source-dirs: 51 | test 52 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 53 | build-depends: 54 | base >=4.7 && <5 55 | , generic-override 56 | , hspec 57 | default-language: Haskell2010 58 | -------------------------------------------------------------------------------- /generic-override/src/Data/Override.hs: -------------------------------------------------------------------------------- 1 | -- | The public, stable generic-override API. 2 | module Data.Override 3 | ( Override(Override) 4 | , As 5 | , At 6 | , With 7 | ) where 8 | 9 | import Data.Override.Internal (Override(Override), As, At, With) 10 | import Data.Override.Instances () 11 | -------------------------------------------------------------------------------- /generic-override/src/Data/Override/Instances.hs: -------------------------------------------------------------------------------- 1 | -- | Instances for some classes from @base@. 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MonoLocalBinds #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | {-# OPTIONS_GHC -fno-warn-orphans #-} 8 | module Data.Override.Instances () where 9 | 10 | import Data.Function (on) 11 | import Data.Override.Internal (Override) 12 | import GHC.Generics (Generic(Rep, from, to)) 13 | 14 | -- The @foo `on` from'@ idiom is taken from @generic-data@ by Li-yao Xia. 15 | from' :: Generic a => a -> Rep a () 16 | from' = from 17 | 18 | to' :: Generic a => Rep a () -> a 19 | to' = to 20 | 21 | -- Eq 22 | 23 | instance 24 | ( Generic (Override a xs) 25 | , Eq (Rep (Override a xs) ()) 26 | ) => Eq (Override a xs) 27 | where 28 | (==) = (==) `on` from' 29 | 30 | -- Ord 31 | 32 | instance 33 | ( Generic (Override a xs) 34 | , Ord (Rep (Override a xs) ()) 35 | ) => Ord (Override a xs) 36 | where 37 | compare = compare `on` from' 38 | 39 | -- Semigroup 40 | 41 | instance 42 | ( Generic (Override a xs) 43 | , Semigroup (Rep (Override a xs) ()) 44 | ) => Semigroup (Override a xs) 45 | where 46 | x <> y = to (from' x <> from' y) 47 | 48 | -- Monoid 49 | 50 | instance 51 | ( Generic (Override a xs) 52 | , Monoid (Rep (Override a xs) ()) 53 | ) => Monoid (Override a xs) 54 | where 55 | mempty = to' mempty 56 | x `mappend` y = to (from' x `mappend` from' y) 57 | -------------------------------------------------------------------------------- /generic-override/src/Data/Override/Internal.hs: -------------------------------------------------------------------------------- 1 | -- | This is the internal generic-override API and should be considered 2 | -- unstable and subject to change. In general, you should prefer to use the 3 | -- public, stable API provided by "Data.Override". 4 | {-# LANGUAGE AllowAmbiguousTypes #-} 5 | {-# LANGUAGE ConstraintKinds #-} 6 | {-# LANGUAGE DataKinds #-} 7 | {-# LANGUAGE DerivingStrategies #-} 8 | {-# LANGUAGE FlexibleContexts #-} 9 | {-# LANGUAGE FlexibleInstances #-} 10 | {-# LANGUAGE InstanceSigs #-} 11 | {-# LANGUAGE KindSignatures #-} 12 | {-# LANGUAGE LambdaCase #-} 13 | {-# LANGUAGE MultiParamTypeClasses #-} 14 | {-# LANGUAGE PolyKinds #-} 15 | {-# LANGUAGE QuantifiedConstraints #-} 16 | {-# LANGUAGE RankNTypes #-} 17 | {-# LANGUAGE ScopedTypeVariables #-} 18 | {-# LANGUAGE TypeApplications #-} 19 | {-# LANGUAGE TypeFamilies #-} 20 | {-# LANGUAGE TypeOperators #-} 21 | {-# LANGUAGE UndecidableInstances #-} 22 | module Data.Override.Internal where 23 | 24 | import Data.Coerce (Coercible, coerce) 25 | import GHC.Generics 26 | import GHC.TypeLits (type (+), Nat, Symbol) 27 | 28 | -- | The feature of this library. For use with DerivingVia. 29 | -- Apply it to a type @a@ and supply a type-level list of instance 30 | -- overrides @xs@. 31 | newtype Override a (xs :: [*]) = Override a 32 | 33 | -- | Unwrap an 'Override' value. 34 | unOverride :: Override a xs -> a 35 | unOverride (Override a) = a 36 | 37 | -- | Construct an 'Override' using a proxy of overrides. 38 | override :: a -> proxy xs -> Override a xs 39 | override a _ = Override a 40 | 41 | -- | Used to construct a type-level override. Usually used infix. 42 | -- The @o@ should target either the type to override or the field 43 | -- name as a 'Symbol' to override. 44 | -- 45 | -- If specifying a type, it can be one of no arity 46 | -- (e.g. 'Int') or one with arity (e.g. 'Either') up to 10 type parameters. 47 | -- When specifying a type, the @o@ and @n@ types should have the same kind; 48 | -- otherwise, the rule will not match. 49 | data As (o :: k) n 50 | 51 | -- | Used to wrap a field into a something of kind @* -> *@, for example another newtype. 52 | data With (o :: k) (w :: * -> *) 53 | 54 | -- | Used to construct a type-level override for the given constructor 55 | -- name @c@ and parameter index @p@. 56 | data At (c :: Symbol) (p :: Nat) (n :: *) 57 | 58 | instance 59 | ( Generic a 60 | , GOverride xs (Rep a) 61 | ) => Generic (Override a xs) 62 | where 63 | type Rep (Override a xs) = OverrideRep EmptyInspect xs (Rep a) 64 | from = overrideFrom @EmptyInspect @xs . from . unOverride 65 | to = Override . to . overrideTo @EmptyInspect @xs 66 | 67 | -- | Shorthand for the starting point of 'GOverride''. 68 | -- 69 | -- You generally shouldn't need this. If GHC asks you to add it as 70 | -- a constraint, prefer using the instance @Generic (Override a xs)@ instead, 71 | -- which may require @MonoLocalBinds@. 72 | type GOverride = GOverride' EmptyInspect 73 | 74 | -- | Type class used to build the 'Generic' instance for 'Override'. 75 | -- 76 | -- You generally shouldn't need this. If GHC asks you to add it as 77 | -- a constraint, prefer using the instance @Generic (Override a xs)@ instead, 78 | -- which may require @MonoLocalBinds@. 79 | class GOverride' (i :: Inspect) (xs :: [*]) (f :: * -> *) where 80 | type OverrideRep i xs f :: * -> * 81 | overrideFrom :: f x -> OverrideRep i xs f x 82 | overrideTo :: OverrideRep i xs f x -> f x 83 | 84 | instance (GOverride' i xs f) => GOverride' i xs (M1 D c f) where 85 | type OverrideRep i xs (M1 D c f) = M1 D c (OverrideRep i xs f) 86 | overrideFrom (M1 x) = M1 (overrideFrom @i @xs x) 87 | {-# INLINE overrideFrom #-} 88 | 89 | overrideTo (M1 x) = M1 (overrideTo @i @xs x) 90 | {-# INLINE overrideTo #-} 91 | 92 | instance 93 | ( GOverride' ('Inspect ('Just conName) ms mp) xs f 94 | ) => GOverride' ('Inspect ignore ms mp) xs 95 | (M1 C ('MetaCons conName conFixity conIsRecord) f) 96 | where 97 | type OverrideRep ('Inspect ignore ms mp) xs 98 | (M1 C ('MetaCons conName conFixity conIsRecord) f) = 99 | M1 C 100 | ('MetaCons conName conFixity conIsRecord) 101 | (OverrideRep ('Inspect ('Just conName) ms mp) xs f) 102 | 103 | overrideFrom (M1 x) = M1 (overrideFrom @('Inspect ('Just conName) ms mp) @xs x) 104 | {-# INLINE overrideFrom #-} 105 | 106 | overrideTo (M1 x) = M1 (overrideTo @('Inspect ('Just conName) ms mp) @xs x) 107 | {-# INLINE overrideTo #-} 108 | 109 | instance 110 | ( GOverride' ('Inspect mc ms ('Just 0)) xs f 111 | , GOverride' ('Inspect mc ms ('Just 1)) xs g 112 | ) => GOverride' ('Inspect mc ms 'Nothing) xs (f :*: g) 113 | where 114 | type OverrideRep ('Inspect mc ms 'Nothing) xs (f :*: g) = 115 | OverrideRep ('Inspect mc ms ('Just 0)) xs f 116 | :*: OverrideRep ('Inspect mc ms ('Just 1)) xs g 117 | 118 | overrideFrom (f :*: g) = 119 | overrideFrom @('Inspect mc ms ('Just 0)) @xs f 120 | :*: overrideFrom @('Inspect mc ms ('Just 1)) @xs g 121 | {-# INLINE overrideFrom #-} 122 | 123 | overrideTo (f :*: g) = 124 | overrideTo @('Inspect mc ms ('Just 0)) @xs f 125 | :*: overrideTo @('Inspect mc ms ('Just 1)) @xs g 126 | {-# INLINE overrideTo #-} 127 | 128 | instance 129 | ( GOverride' ('Inspect mc ms ('Just p)) xs f 130 | , GOverride' ('Inspect mc ms ('Just (p + 1))) xs g 131 | ) => GOverride' ('Inspect mc ms ('Just p)) xs (f :*: g) 132 | where 133 | type OverrideRep ('Inspect mc ms ('Just p)) xs (f :*: g) = 134 | OverrideRep ('Inspect mc ms ('Just p)) xs f 135 | :*: OverrideRep ('Inspect mc ms ('Just (p + 1))) xs g 136 | 137 | overrideFrom (f :*: g) = 138 | overrideFrom @('Inspect mc ms ('Just p)) @xs f 139 | :*: overrideFrom @('Inspect mc ms ('Just (p + 1))) @xs g 140 | {-# INLINE overrideFrom #-} 141 | 142 | overrideTo (f :*: g) = 143 | overrideTo @('Inspect mc ms ('Just p)) @xs f 144 | :*: overrideTo @('Inspect mc ms ('Just (p + 1))) @xs g 145 | {-# INLINE overrideTo #-} 146 | 147 | instance 148 | ( GOverride' i xs f 149 | , GOverride' i xs g 150 | ) => GOverride' i xs (f :+: g) 151 | where 152 | type OverrideRep i xs (f :+: g) = OverrideRep i xs f :+: OverrideRep i xs g 153 | 154 | overrideFrom = \case 155 | L1 f -> L1 $ overrideFrom @i @xs f 156 | R1 g -> R1 $ overrideFrom @i @xs g 157 | {-# INLINE overrideFrom #-} 158 | 159 | overrideTo = \case 160 | L1 f -> L1 $ overrideTo @i @xs f 161 | R1 g -> R1 $ overrideTo @i @xs g 162 | {-# INLINE overrideTo #-} 163 | 164 | instance 165 | ( GOverride' ('Inspect mc selName mp) xs f 166 | ) => GOverride' ('Inspect mc ignore mp) xs (M1 S ('MetaSel selName selSU selSS selDS) f) 167 | where 168 | type OverrideRep ('Inspect mc ignore mp) xs (M1 S ('MetaSel selName selSU selSS selDS) f) = 169 | M1 S ('MetaSel selName selSU selSS selDS) (OverrideRep ('Inspect mc selName mp) xs f) 170 | 171 | overrideFrom (M1 x) = M1 (overrideFrom @('Inspect mc selName mp) @xs x) 172 | {-# INLINE overrideFrom #-} 173 | 174 | overrideTo (M1 x) = M1 (overrideTo @('Inspect mc selName mp) @xs x) 175 | {-# INLINE overrideTo #-} 176 | 177 | instance 178 | ( Coercible a (Using ('Inspect mc ms ('Just 0)) a xs) 179 | ) => GOverride' ('Inspect mc ms 'Nothing) xs (K1 R a) 180 | where 181 | type OverrideRep ('Inspect mc ms 'Nothing) xs (K1 R a) = 182 | K1 R (Using ('Inspect mc ms ('Just 0)) a xs) 183 | 184 | overrideFrom (K1 a) = K1 (coerce a :: Using ('Inspect mc ms ('Just 0)) a xs) 185 | {-# INLINE overrideFrom #-} 186 | 187 | overrideTo (K1 u) = K1 (coerce u :: a) 188 | {-# INLINE overrideTo #-} 189 | 190 | instance 191 | ( Coercible a (Using ('Inspect mc ms ('Just p)) a xs) 192 | ) => GOverride' ('Inspect mc ms ('Just p)) xs (K1 R a) 193 | where 194 | type OverrideRep ('Inspect mc ms ('Just p)) xs (K1 R a) = 195 | K1 R (Using ('Inspect mc ms ('Just p)) a xs) 196 | 197 | overrideFrom (K1 a) = K1 (coerce a :: Using ('Inspect mc ms ('Just p)) a xs) 198 | {-# INLINE overrideFrom #-} 199 | 200 | overrideTo (K1 u) = K1 (coerce u :: a) 201 | {-# INLINE overrideTo #-} 202 | 203 | instance GOverride' i xs U1 where 204 | type OverrideRep i xs U1 = U1 205 | overrideFrom U1 = U1 206 | {-# INLINE overrideFrom #-} 207 | 208 | overrideTo U1 = U1 209 | {-# INLINE overrideTo #-} 210 | 211 | data Inspect = 212 | Inspect 213 | (Maybe Symbol) -- ^ Constructor name 214 | (Maybe Symbol) -- ^ Selector name 215 | (Maybe Nat) -- ^ Selector index 216 | 217 | type EmptyInspect = 'Inspect 'Nothing 'Nothing 'Nothing 218 | 219 | -- | Type family used to determine which override from @xs@ 220 | -- to replace @a@ with, if any. The @ms@ holds the field name 221 | -- for @a@, if applicable. 222 | type family Using (i :: Inspect) (a :: *) (xs :: [*]) where 223 | -- No matching override found. 224 | Using i a '[] = a 225 | 226 | -- Override the matching field. 227 | Using ('Inspect mc ('Just o) mp) a (As o n ': xs) = n 228 | Using ('Inspect mc ('Just o) mp) a (With o w ': xs) = w a 229 | 230 | -- Override the matching type. 231 | Using i a (With a w ': xs) = w a 232 | 233 | -- Override the matching type (arity 0-10). 234 | Using i a (As a n ': xs) = n 235 | Using i (f a0) (As f g ': xs) = g a0 236 | Using i (f a0 a1) (As f g ': xs) = g a0 a1 237 | Using i (f a0 a1 a2) (As f g ': xs) = g a0 a1 a2 238 | Using i (f a0 a1 a2 a3) (As f g ': xs) = g a0 a1 a2 a3 239 | Using i (f a0 a1 a2 a3 a4) (As f g ': xs) = g a0 a1 a2 a3 a4 240 | Using i (f a0 a1 a2 a3 a4 a5) (As f g ': xs) = g a0 a1 a2 a3 a4 a5 241 | Using i (f a0 a1 a2 a3 a4 a5 a6) (As f g ': xs) = g a0 a1 a2 a3 a4 a5 a6 242 | Using i (f a0 a1 a2 a3 a4 a5 a6 a7) (As f g ': xs) = g a0 a1 a2 a3 a4 a5 a6 a7 243 | Using i (f a0 a1 a2 a3 a4 a5 a6 a7 a8) (As f g ': xs) = g a0 a1 a2 a3 a4 a5 a6 a7 a8 244 | Using i (f a0 a1 a2 a3 a4 a5 a6 a7 a8 a9) (As f g ': xs) = g a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 245 | 246 | -- Override the matching constructor parameter. 247 | Using ('Inspect ('Just c) ms ('Just p)) a (At c p n ': xs) = n 248 | 249 | -- No match on this override, recurse. 250 | Using i a (x ': xs) = Using i a xs 251 | -------------------------------------------------------------------------------- /generic-override/test/Encode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE TypeSynonymInstances #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | module Encode where 14 | 15 | import Data.List (intercalate) 16 | import Data.Override (Override) 17 | import GHC.Generics 18 | 19 | class Encode a where 20 | encode :: a -> String 21 | default encode :: (Generic a, GEncode (Rep a)) => a -> String 22 | encode = gencode . from 23 | 24 | instance 25 | ( Generic (Override a xs) 26 | , GEncode (Rep (Override a xs)) 27 | ) => Encode (Override a xs) 28 | 29 | class GEncode f where 30 | gencode :: f a -> String 31 | 32 | instance (GEncode f) => GEncode (M1 D x f) where 33 | gencode (M1 f) = gencode f 34 | 35 | instance (GEncode f, Constructor c) => GEncode (M1 C c f) where 36 | gencode m@(M1 f) = conName m <> ":" <> gencode f 37 | 38 | instance (GEncode f, GEncode g) => GEncode (f :*: g) where 39 | gencode (f :*: g) = gencode f <> "," <> gencode g 40 | 41 | instance (GEncode f, GEncode g) => GEncode (f :+: g) where 42 | gencode = \case 43 | L1 f -> gencode f 44 | R1 g -> gencode g 45 | 46 | instance (GEncode f, Selector s) => GEncode (M1 S s f) where 47 | gencode m@(M1 f) = 48 | if null (selName m) then 49 | gencode f 50 | else 51 | selName m <> "=" <> gencode f 52 | 53 | instance (Encode a) => GEncode (K1 R a) where 54 | gencode (K1 a) = encode a 55 | 56 | instance GEncode U1 where 57 | gencode _ = "" 58 | 59 | instance Encode Int where 60 | encode = show 61 | 62 | instance Encode Char where 63 | encode = pure 64 | 65 | -- | Create an overlapping instance to verify that overriding with 66 | -- 'ListOf' avoids this instance. 67 | instance {-# OVERLAPPING #-} Encode String where 68 | encode = id 69 | 70 | deriving via (ListOf a) instance (Encode a) => Encode [a] 71 | 72 | newtype ListOf a = ListOf { unListOf :: [a] } 73 | 74 | instance (Encode a) => Encode (ListOf a) where 75 | encode = intercalate "," . map encode . unListOf 76 | -------------------------------------------------------------------------------- /generic-override/test/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE DerivingVia #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | module Main where 9 | 10 | import Data.Monoid (Any(..)) 11 | import Data.Override (Override(..), As, At) 12 | import Encode (Encode(encode), ListOf(..)) 13 | import GHC.Generics (Generic) 14 | import Test.Hspec 15 | 16 | main :: IO () 17 | main = hspec do 18 | describe "Override" do 19 | describe "Semigroup" do 20 | it "Rec1" testRec1'Semigroup 21 | describe "Monoid" do 22 | it "Rec1" testRec1'Monoid 23 | describe "Eq" do 24 | it "Rec2" testRec2'Eq 25 | it "Sum1" testSum1'Eq 26 | describe "Ord" do 27 | it "Rec2" testRec2'Ord 28 | describe "Encode" do 29 | it "Sum1" testSum1'Encode 30 | it "Sum2" testSum2'Encode 31 | it "Sum3" testSum3'Encode 32 | it "Sum4" testSum4'Encode 33 | it "Sum5" testSum5'Encode 34 | 35 | -- | Overriding instances by type. 36 | data Rec1 = Rec1 37 | { foo :: String 38 | , bar :: Bool 39 | } deriving stock (Show, Eq, Generic) 40 | deriving (Semigroup, Monoid) 41 | via Override Rec1 42 | '[ Bool `As` Any 43 | ] 44 | 45 | testRec1'Semigroup :: IO () 46 | testRec1'Semigroup = do 47 | Rec1 { foo = "a", bar = False } 48 | <> Rec1 { foo = "b", bar = True } 49 | `shouldBe` Rec1 { foo = "ab", bar = True } 50 | 51 | testRec1'Monoid :: IO () 52 | testRec1'Monoid = do 53 | mempty `shouldBe` Rec1 { foo = "", bar = False } 54 | Rec1 { foo = "a", bar = False } 55 | `mappend` Rec1 { foo = "b", bar = True } 56 | `shouldBe` Rec1 { foo = "ab", bar = True } 57 | 58 | data Rec2 = Rec2 String Int 59 | deriving stock (Show, Generic) 60 | deriving (Eq, Ord) via (Override Rec2 '[String `As` ByLength]) 61 | 62 | newtype ByLength = ByLength { byLength :: String } 63 | deriving (Show) 64 | 65 | instance Eq ByLength where 66 | ByLength x == ByLength y = length x == length y 67 | 68 | instance Ord ByLength where 69 | ByLength x <= ByLength y = length x <= length y 70 | 71 | testRec2'Eq :: IO () 72 | testRec2'Eq = do 73 | (Rec2 "foo" 0 == Rec2 "bar" 0) `shouldBe` True 74 | (Rec2 "foo" 0 == Rec2 "bar" 1) `shouldBe` False 75 | (Rec2 "" 0 == Rec2 "bar" 0) `shouldBe` False 76 | 77 | testRec2'Ord :: IO () 78 | testRec2'Ord = do 79 | (Rec2 "foo" 0 <= Rec2 "bar" 0) `shouldBe` True 80 | (Rec2 "foo" 1 <= Rec2 "bar" 0) `shouldBe` False 81 | (Rec2 "" 0 >= Rec2 "bar" 0) `shouldBe` False 82 | 83 | -- | Override support for sum types. 84 | data Sum1 = Sum1String String | Sum1Int Int 85 | deriving stock (Show, Generic) 86 | deriving (Eq) via (Override Sum1 '[String `As` ByLength]) 87 | deriving (Encode) via (Override Sum1 '[String `As` ListOf Char]) 88 | 89 | testSum1'Eq :: IO () 90 | testSum1'Eq = do 91 | (Sum1String "foo" == Sum1String "bar") `shouldBe` True 92 | (Sum1Int 3 == Sum1Int 3) `shouldBe` True 93 | (Sum1String "foo" == Sum1String "ba") `shouldBe` False 94 | (Sum1String "foo" == Sum1Int 3) `shouldBe` False 95 | (Sum1Int 3 == Sum1Int 2) `shouldBe` False 96 | 97 | testSum1'Encode :: IO () 98 | testSum1'Encode = do 99 | encode (Sum1String "foo") `shouldBe` "Sum1String:f,o,o" 100 | encode (Sum1Int 1) `shouldBe` "Sum1Int:1" 101 | 102 | -- | Override using 'As' which includes a type variable. 103 | data Sum2 a = Sum2List [a] | Sum2Null 104 | deriving stock (Show, Eq, Generic) 105 | deriving (Encode) via (Override (Sum2 a) '[[a] `As` ListOf a]) 106 | 107 | testSum2'Encode :: IO () 108 | testSum2'Encode = do 109 | encode (Sum2List [1, 2, 3 :: Int]) `shouldBe` "Sum2List:1,2,3" 110 | encode (Sum2Null @Int) `shouldBe` "Sum2Null:" 111 | 112 | -- | Override using 'As' which uses a kind of @* -> *@. Convenient 113 | -- so you don't have to apply the type parameter. 114 | data Sum3 a = Sum3List [a] | Sum3Null 115 | deriving stock (Show, Eq, Generic) 116 | deriving (Encode) via (Override (Sum3 a) '[[] `As` ListOf]) 117 | 118 | testSum3'Encode :: IO () 119 | testSum3'Encode = do 120 | encode (Sum3List [1, 2, 3 :: Int]) `shouldBe` "Sum3List:1,2,3" 121 | encode (Sum3Null @Int) `shouldBe` "Sum3Null:" 122 | 123 | -- | Override using 'At' which includes a type variable. 124 | data Sum4 a = Sum4List [a] | Sum4String String 125 | deriving stock (Show, Eq, Generic) 126 | deriving (Encode) 127 | via Override (Sum4 a) 128 | '[ At "Sum4List" 0 (ListOf a) 129 | ] 130 | 131 | testSum4'Encode :: IO () 132 | testSum4'Encode = do 133 | encode (Sum4List [1, 2, 3 :: Int]) `shouldBe` "Sum4List:1,2,3" 134 | encode (Sum4List "foo") `shouldBe` "Sum4List:f,o,o" 135 | encode (Sum4String @Char "foo") `shouldBe` "Sum4String:foo" 136 | 137 | -- | Override using 'At' which uses a kind of @* -> *@. 138 | data Sum5 a = Sum5String String | Sum5List Char [a] 139 | deriving stock (Show, Eq, Generic) 140 | deriving (Encode) 141 | via Override (Sum5 a) 142 | '[ At "Sum5List" 1 (ListOf a) 143 | ] 144 | 145 | testSum5'Encode :: IO () 146 | testSum5'Encode = do 147 | encode (Sum5List 'a' [1, 2, 3 :: Int]) `shouldBe` "Sum5List:a,1,2,3" 148 | encode (Sum5List 'a' "foo") `shouldBe` "Sum5List:a,f,o,o" 149 | encode (Sum5String @Char "foo") `shouldBe` "Sum5String:foo" 150 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.12 2 | 3 | packages: 4 | - ./generic-override 5 | - ./generic-override-aeson 6 | 7 | pvp-bounds: both 8 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 545658 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/12.yaml 11 | sha256: 26b807457213126d26b595439d705dc824dbb7618b0de6b900adc2bf6a059406 12 | original: lts-14.12 13 | --------------------------------------------------------------------------------