diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for derivingvia-extras + +## 0.1.0.0 -- 2022-04-29 + +* First version. Added `On` for deriving non-structural instances on a particular record field. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2022, Baldur Blöndal + +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 Baldur Blöndal 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,39 @@ +# derivingvia-extras + +Miscellaneous via types, for use with `DerivingVia`. + +## `On` + +The type `On T "field"` derives non-structural instances for `T` by +comparing an evaluting it only at the record field `"field"`. + +```haskell +{-# Language DataKinds #-} +{-# Language DerivingVia #-} +{-# Language TypeOperators #-} + +import Deriving.On +import Data.Hashable + +data User = User + { name :: String + , age :: Int + , userID :: Integer + } + deriving (Eq, Ord, Hashable) + via User `On` "userID" +``` + +such that all other fields are ignored + +```haskell +>> alice = User "Alice" 50 0xDEADBEAF +>> bob = User "Bob" 20 0xDEADBEAF +>> +>> alice == bob +True +>> alice <= bob +True +>> hash alice == hash bob +True +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/derivingvia-extras.cabal b/derivingvia-extras.cabal new file mode 100644 --- /dev/null +++ b/derivingvia-extras.cabal @@ -0,0 +1,43 @@ +cabal-version: 2.0 +name: derivingvia-extras +build-type: Simple +version: 0.1.0.0 +license: BSD3 +license-file: LICENSE +category: Deriving, Utils +author: Baldur Blöndal +maintainer: Baldur Blöndal +bug-reports: https://github.com/Icelandjack/derivingvia-extras/issues +synopsis: DerivingVia extras - Miscellaneous /via/ types. +extra-source-files: + CHANGELOG.md + README.md +description: + Includes various functionality to use with 'DerivingVia'. + . + > -- >> alice = User "Alice" 50 0xDEADBEAF + > -- >> bob = User "Bob" 20 0xDEADBEAF + > -- >> + > -- >> alice == bob + > -- True + > -- >> hash alice == hash bob + > -- True + > data User = User + > { name :: String + > , age :: Int + > , userID :: Integer + > } + > deriving (Eq, Ord, Hashable) + > via User `On` "userID" + +source-repository head + type: git + location: https://github.com/Icelandjack/derivingvia-extras + +library + exposed-modules: + Deriving.On + hs-source-dirs: src + default-language: Haskell98 + build-depends: + base == 4.*, hashable -any diff --git a/src/Deriving/On.hs b/src/Deriving/On.hs new file mode 100644 --- /dev/null +++ b/src/Deriving/On.hs @@ -0,0 +1,66 @@ +{-# Language DataKinds #-} +{-# Language InstanceSigs #-} +{-# Language ScopedTypeVariables #-} +{-# Language StandaloneKindSignatures #-} +{-# Language TypeApplications #-} +{-# Language TypeOperators #-} +{-# Language UndecidableInstances #-} + +module Deriving.On (On(..)) where + +import Data.Function (on) +import Data.Hashable (Hashable(..)) +import Data.Kind (Type) +import Data.Ord (comparing) +import GHC.Records (HasField(..)) +import GHC.TypeLits (Symbol) + +-- | With 'DerivingVia': to derive non-structural instances. Specifies +-- what field to base instances on. +-- +-- The type @'On' User "userID"@ is compared and evaluated based only +-- on the @"userID"@ record field. This uses 'HasField' from +-- @GHC.Records@ to project the relevant component. +-- +-- @ +-- {-# Language DataKinds #-} +-- {-# Language DerivingVia #-} +-- {-# Language TypeOperators #-} +-- +-- import Deriving.On +-- import Data.Hashable +-- +-- data User = User +-- { name :: String +-- , age :: Int +-- , userID :: Integer +-- } +-- deriving (Eq, Ord, Hashable) +-- via User `On` "userID" +-- @ +-- +-- @ +-- >> alice = User "Alice" 50 0xDEADBEAF +-- >> bob = User "Bob" 20 0xDEADBEAF +-- >> +-- >> alice == bob +-- True +-- >> alice <= bob +-- True +-- >> hash alice == hash bob +-- True +-- @ +type On :: Type -> Symbol -> Type +newtype a `On` field = On a + +instance (HasField field a b, Eq b) => Eq (a `On` field) where + (==) :: a `On` field -> a `On` field -> Bool + On a1 == On a2 = ((==) `on` getField @field) a1 a2 + +instance (HasField field a b, Ord b) => Ord (a `On` field) where + compare :: a `On` field -> a `On` field -> Ordering + On a1 `compare` On a2 = comparing (getField @field) a1 a2 + +instance (HasField field a b, Hashable b) => Hashable (a `On` field) where + hashWithSalt :: Int -> a `On` field -> Int + hashWithSalt salt (On a) = hashWithSalt salt (getField @field a)