├── .gitignore ├── Setup.hs ├── ChangeLog.md ├── src └── GHC │ └── Generics │ ├── Omit.hs │ └── Omit │ └── Internal.hs ├── stack.yaml.lock ├── README.org ├── package.yaml ├── LICENSE ├── omit-generics.cabal ├── test └── Spec.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ 3 | TAGS -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for omit-generics 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /src/GHC/Generics/Omit.hs: -------------------------------------------------------------------------------- 1 | module GHC.Generics.Omit (Omit(..)) where 2 | 3 | import GHC.Generics.Omit.Internal 4 | -------------------------------------------------------------------------------- /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: 496112 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/15.yaml 11 | sha256: 86169722ad0056ffc9eacc157ef80ee21d7024f92c0d2961c89ccf432db230a3 12 | original: lts-15.15 13 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | * omit-generics 2 | =omit-generics= aims to make deriving ~Eq~ and ~Ord~ instances 3 | easier by giving the programmer control over what fields to ignore. 4 | 5 | This is best explained by an example: 6 | #+BEGIN_SRC haskell :multi-line t 7 | {-# LANGUAGE DataKinds #-} 8 | {-# LANGUAGE DeriveGeneric #-} 9 | {-# LANGUAGE DerivingStrategies #-} 10 | {-# LANGUAGE DerivingVia #-} 11 | 12 | import GHC.Generics 13 | import GHC.Generics.Omit 14 | 15 | data Person = Person { name :: String, age :: Int, metadata :: [String] } 16 | deriving stock Generic 17 | deriving Eq via (Omit '["age", "metadata"] Person) 18 | #+END_SRC 19 | 20 | 21 | Now, when we compare ~Person~ for equality, the ~age~ and ~metadata~ 22 | fields are ignored! 23 | 24 | #+BEGIN_SRC haskell 25 | Person "Steve" 43 ["loves cats"] == Person "Steve" 1 ["loves dogs", "is a baby"] 26 | > True 27 | #+END_SRC 28 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: omit-generics 2 | version: 0.1.0.0 3 | github: "githubuser/omit-generics" 4 | license: BSD3 5 | author: "Author name here" 6 | maintainer: "example@example.com" 7 | copyright: "2020 Author name here" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | 25 | library: 26 | source-dirs: src 27 | 28 | tests: 29 | omit-generics-test: 30 | main: Spec.hs 31 | source-dirs: test 32 | ghc-options: 33 | - -threaded 34 | - -rtsopts 35 | - -with-rtsopts=-N 36 | dependencies: 37 | - omit-generics 38 | - tasty 39 | - tasty-hunit 40 | - HUnit 41 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Reed Mullanix (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 Author name here 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 | -------------------------------------------------------------------------------- /omit-generics.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: 8563bf1d430861c6d4d74cea37491c067818a61bd3d23091011b7be10af07233 8 | 9 | name: omit-generics 10 | version: 0.1.0.0 11 | description: Please see the README on GitHub at 12 | homepage: https://github.com/githubuser/omit-generics#readme 13 | bug-reports: https://github.com/githubuser/omit-generics/issues 14 | author: Author name here 15 | maintainer: example@example.com 16 | copyright: 2020 Author name here 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/githubuser/omit-generics 27 | 28 | library 29 | exposed-modules: 30 | GHC.Generics.Omit 31 | GHC.Generics.Omit.Internal 32 | Lib 33 | other-modules: 34 | Paths_omit_generics 35 | hs-source-dirs: 36 | src 37 | build-depends: 38 | base >=4.7 && <5 39 | default-language: Haskell2010 40 | 41 | test-suite omit-generics-test 42 | type: exitcode-stdio-1.0 43 | main-is: Spec.hs 44 | other-modules: 45 | Paths_omit_generics 46 | hs-source-dirs: 47 | test 48 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 49 | build-depends: 50 | HUnit 51 | , base >=4.7 && <5 52 | , omit-generics 53 | , tasty 54 | , tasty-hunit 55 | default-language: Haskell2010 56 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE DerivingVia #-} 5 | module Main where 6 | 7 | import GHC.Generics 8 | import GHC.Generics.Omit 9 | 10 | import Test.Tasty 11 | import Test.Tasty.HUnit 12 | 13 | data TestData = TestData { ignored1 :: String, used :: Int, ignored2 :: [Int] } 14 | deriving stock Generic 15 | deriving Eq via (Omit '["ignored1", "ignored2"] TestData) 16 | 17 | basicRecords :: TestTree 18 | basicRecords = testGroup "Basic Records" 19 | [ testCase "ignores fields" $ assertBool "TestData not equal" (TestData "a" 1 [] == TestData "b" 1 [3]) 20 | , testCase "compares fields" $ assertBool "TestData equal" (TestData "a" 2 [] /= TestData "b" 1 [3]) 21 | ] 22 | 23 | data NestedData = NestedData { testData :: TestData, nonNested :: Maybe String } 24 | deriving stock Generic 25 | deriving Eq via (Omit '["nonNested"] NestedData) 26 | 27 | nestedTypes :: TestTree 28 | nestedTypes = testGroup "Nested Types" 29 | [ testCase "compares nested type" $ assertBool "NestedData not equal" (NestedData (TestData "a" 1 []) Nothing == NestedData (TestData "cc" 1 [4]) (Just "a")) 30 | ] 31 | 32 | data SumData = Sum1 { branch :: Int, otherBranch :: String } | Sum2 { branch :: Int } | Sum3 33 | deriving stock Generic 34 | deriving Eq via (Omit '["branch"] SumData) 35 | 36 | sumTypes :: TestTree 37 | sumTypes = testGroup "Sum Types" 38 | [ testCase "ignores fields" $ assertBool "SumData not equal" (Sum1 1 "a" == Sum1 2 "a") 39 | , testCase "compares branches" $ assertBool "SumData equal" (Sum1 1 "a" /= Sum2 2) 40 | ] 41 | 42 | main :: IO () 43 | main = defaultMain $ testGroup "Omit Eq" 44 | [ basicRecords 45 | , nestedTypes 46 | , sumTypes 47 | ] 48 | 49 | data Person = Person { name :: String, age :: Int, metadata :: [String] } 50 | deriving stock Generic 51 | deriving Eq via (Omit '["age", "metadata"] Person) 52 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-15.15 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | # extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=2.3" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /src/GHC/Generics/Omit/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE TypeSynonymInstances #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | {-| This is an internal module, which means that the API may change 14 | at any time. 15 | -} 16 | 17 | module GHC.Generics.Omit.Internal where 18 | 19 | import Data.Kind 20 | import Data.Proxy 21 | 22 | import GHC.Generics 23 | import GHC.TypeLits 24 | 25 | 26 | -------------------------------------------------------------------------------- 27 | -- Taken from the "singletons" package 28 | -------------------------------------------------------------------------------- 29 | 30 | -- | The singleton kind-indexed data family. 31 | data family Sing (a :: k) 32 | 33 | -- | A 'SingI' constraint is essentially an implicitly-passed singleton. 34 | class SingI (a :: k) where 35 | -- | Produce the singleton explicitly. You will likely need the @ScopedTypeVariables@ 36 | -- extension to use this method the way you want. 37 | sing :: Sing a 38 | 39 | -- | The 'SingKind' class is essentially a /kind/ class. It classifies all kinds 40 | -- for which singletons are defined. The class supports converting between a singleton 41 | -- type and the base (unrefined) type which it is built from. 42 | class SingKind k where 43 | -- | Get a base type from a proxy for the promoted kind. For example, 44 | -- @DemoteRep Bool@ will be the type @Bool@. 45 | type DemoteRep k :: Type 46 | 47 | -- | Convert a singleton to its unrefined version. 48 | fromSing :: Sing (a :: k) -> DemoteRep k 49 | 50 | -- | Singleton symbols 51 | data instance Sing (s :: Symbol) where 52 | SSym :: KnownSymbol s => Sing s 53 | 54 | instance KnownSymbol a => SingI a where sing = SSym 55 | 56 | instance SingKind Symbol where 57 | type DemoteRep Symbol = String 58 | fromSing (SSym :: Sing s) = symbolVal (Proxy :: Proxy s) 59 | 60 | -- | Singleton lists 61 | data instance Sing (fields :: [a]) where 62 | SNil :: Sing '[] 63 | SCons :: Sing a -> Sing as -> Sing (a ': as) 64 | 65 | instance SingI '[] where sing = SNil 66 | instance (SingI a, SingI as) => SingI (a ': as) where sing = SCons sing sing 67 | 68 | instance SingKind a => SingKind ([a]) where 69 | type DemoteRep [a] = [DemoteRep a] 70 | fromSing SNil = [] 71 | fromSing (SCons a as) = (fromSing a):(fromSing as) 72 | 73 | -- | Checks to see if a string is contained in a singleton list. 74 | singElem :: forall proxy fields. (SingI fields) => String -> proxy (fields :: [Symbol]) -> Bool 75 | singElem s proxy = elem s (fromSing (sing :: Sing fields)) 76 | 77 | -- | Class for generic equality that ignores all fields contained in the symbol list 78 | class GEq (fields :: [Symbol]) (f :: * -> *) where 79 | geq :: proxy fields -> f a -> f a -> Bool 80 | 81 | instance (GEq fields f, SingI fields, Selector c) => GEq fields (S1 c f) where 82 | geq p a b = singElem (selName a) p || (geq p (unM1 a) (unM1 b)) 83 | 84 | instance (GEq fields f, GEq fields g) => GEq fields (f :*: g) where 85 | geq p (f :*: g) (f' :*: g') = geq p f f' && geq p g g' 86 | 87 | instance (GEq fields f, GEq fields g) => GEq fields (f :+: g) where 88 | geq p (L1 f) (L1 f') = geq p f f' 89 | geq p (R1 g) (R1 g') = geq p g g' 90 | geq _ _ _ = False 91 | 92 | instance (GEq fields f) => GEq fields (D1 c f) where 93 | geq p (M1 a) (M1 b) = geq p a b 94 | 95 | instance (GEq fields f) => GEq fields (C1 c f) where 96 | geq p (M1 a) (M1 b) = geq p a b 97 | 98 | instance (Eq c) => GEq fields (K1 i c) where 99 | geq p (K1 c) (K1 c') = c == c' 100 | 101 | instance GEq fields U1 where 102 | geq p _ _ = True 103 | 104 | newtype Omit (s :: [Symbol]) a = Omit { unOmit :: a } 105 | 106 | instance (Generic a, GEq fields (Rep a)) => Eq (Omit fields a) where 107 | (Omit a) == (Omit b) = geq (Proxy :: Proxy fields) (from a) (from b) 108 | --------------------------------------------------------------------------------