diff --git a/CHANGES.txt b/CHANGES.txt new file mode 100644 --- /dev/null +++ b/CHANGES.txt @@ -0,0 +1,4 @@ +Changelog for record-hasfield + +1.0, released 2019-03-21 + Initial version diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Adam Gundry and Neil Mitchell 2018-2019. +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 Neil Mitchell 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,14 @@ +# record-hasfield [![Hackage version](https://img.shields.io/hackage/v/record-hasfield.svg?label=Hackage)](https://hackage.haskell.org/package/record-hasfield) [![Stackage version](https://www.stackage.org/package/record-hasfield/badge/nightly?label=Stackage)](https://www.stackage.org/package/record-hasfield) [![Build status](https://img.shields.io/travis/ndmitchell/record-hasfield/master.svg?label=Build)](https://travis-ci.org/ndmitchell/record-hasfield) + +This package provides a version of "GHC.Records" as it will be after the implementation of +[GHC proposal #42](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0042-record-set-field.rst), which reads: + +```haskell +-- | Constraint representing the fact that the field @x@ can be get and set on +-- the record type @r@ and has field type @a@. +class HasField x r a | x r -> a where + -- | Function to get and set a field in a record. + hasField :: r -> (a -> r, a) +``` + +In GHC these will be magically solved, but this package doesn't provide that. This package does provide extra helper functions for working with the `HasField` type class. 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/record-hasfield.cabal b/record-hasfield.cabal new file mode 100644 --- /dev/null +++ b/record-hasfield.cabal @@ -0,0 +1,45 @@ +cabal-version: >= 1.18 +build-type: Simple +name: record-hasfield +version: 1.0 +license: BSD3 +license-file: LICENSE +category: Development +author: Neil Mitchell +maintainer: Neil Mitchell +copyright: Adam Gundry and Neil Mitchell 2018-2019 +synopsis: A version of GHC.Records as available in future GHCs. +description: + This package provides a version of "GHC.Records" as it will be after the implementation of + , + plus some helper functions over it. +homepage: https://github.com/ndmitchell/record-hasfield#readme +bug-reports: https://github.com/ndmitchell/record-hasfield/issues +tested-with: GHC==8.6.4, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2 + +extra-doc-files: + CHANGES.txt + README.md + +source-repository head + type: git + location: https://github.com/ndmitchell/record-hasfield.git + +library + default-language: Haskell2010 + hs-source-dirs: src + build-depends: + base >= 4.4 && < 5 + + exposed-modules: + GHC.Records.Compat + GHC.Records.Extra + +test-suite record-hasfield-test + type: exitcode-stdio-1.0 + main-is: test/Test.hs + default-language: Haskell2010 + + build-depends: + base, + record-hasfield diff --git a/src/GHC/Records/Compat.hs b/src/GHC/Records/Compat.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Records/Compat.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE AllowAmbiguousTypes + , FunctionalDependencies + , ScopedTypeVariables + , PolyKinds + , TypeApplications + #-} + +-- | This module provides a version of "GHC.Records" as it will be after the implementation of +-- . +-- +-- In future GHC versions it will be an alias for "GHC.Records". +module GHC.Records.Compat + ( HasField(..) + , getField + , setField + ) where + +-- | Constraint representing the fact that the field @x@ can be get and set on +-- the record type @r@ and has field type @a@. This constraint will be solved +-- automatically, but manual instances may be provided as well. +-- +-- The function should satisfy the invariant: +-- +-- > uncurry ($) (hasField @x r) == r +class HasField x r a | x r -> a where + -- | Function to get and set a field in a record. + hasField :: r -> (a -> r, a) + +-- | Get a field in a record. +getField :: forall x r a . HasField x r a => r -> a +getField = snd . hasField @x + +-- | Set a field in a record. +setField :: forall x r a . HasField x r a => r -> a -> r +setField = fst . hasField @x diff --git a/src/GHC/Records/Extra.hs b/src/GHC/Records/Extra.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Records/Extra.hs @@ -0,0 +1,89 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE AllowAmbiguousTypes + , MultiParamTypeClasses + , ScopedTypeVariables + , PolyKinds + , TypeApplications + , FlexibleInstances + , UndecidableInstances + , DataKinds + , GADTs + , TupleSections + #-} + +-- | Extensions over a future version of "GHC.Records". +-- Provides the function 'modifyField' plus the orphan instances: +-- +-- * @HasField \'(x1,x2)@ for selecting first the @x1@ field, then the @x2@ field. +-- Available for @()@ and tuples up to arity 5. +-- +-- * @HasField \"_1\" (a,b) a@ for selecting the first compomnent of a pair, +-- plus similarly for all fields up of all tuples up to arity 5. +-- +-- Using these functions together you get: +-- +-- > modifyField @'("_1","_2") negate ((1,2),3,4,5) == ((1,-2),3,4,5) +module GHC.Records.Extra + ( module GHC.Records.Compat + , modifyField + ) where + +import GHC.Records.Compat + +-- | Modify a field in a record. +modifyField :: forall x r a . HasField x r a => r -> (a -> a) -> r +modifyField r f = gen $ f val + where (gen, val) = hasField @x r + +instance HasField '() a a where + hasField r = (id, r) + +instance (a1 ~ r2, HasField x1 r1 a1, HasField x2 r2 a2) => HasField '(x1, x2) r1 a2 where + hasField r = (gen1 . gen2, val2) + where + (gen1, val1) = hasField @x1 r + (gen2, val2) = hasField @x2 val1 + +instance (a1 ~ r2, a2 ~ r3, HasField x1 r1 a1, HasField x2 r2 a2, HasField x3 r3 a3) => + HasField '(x1, x2, x3) r1 a3 where + hasField = hasField @'(x1, '(x2, x3)) + +instance (a1 ~ r2, a2 ~ r3, a3 ~ r4, HasField x1 r1 a1, HasField x2 r2 a2, HasField x3 r3 a3, HasField x4 r4 a4) => + HasField '(x1, x2, x3, x4) r1 a4 where + hasField = hasField @'(x1, '(x2, x3, x4)) + +instance (a1 ~ r2, a2 ~ r3, a3 ~ r4, a4 ~ r5, HasField x1 r1 a1, HasField x2 r2 a2, HasField x3 r3 a3, HasField x4 r4 a4, HasField x5 r5 a5) => + HasField '(x1, x2, x3, x4, x5) r1 a5 where + hasField = hasField @'(x1, '(x2, x3, x4, x5)) + +instance HasField "_1" (a,b) a where + hasField (a,b) = ((,b), a) +instance HasField "_2" (a,b) b where + hasField (a,b) = ((a,), b) + +instance HasField "_1" (a,b,c) a where + hasField (a,b,c) = ((,b,c), a) +instance HasField "_2" (a,b,c) b where + hasField (a,b,c) = ((a,,c), b) +instance HasField "_3" (a,b,c) c where + hasField (a,b,c) = ((a,b,), c) + +instance HasField "_1" (a,b,c,d) a where + hasField (a,b,c,d) = ((,b,c,d), a) +instance HasField "_2" (a,b,c,d) b where + hasField (a,b,c,d) = ((a,,c,d), b) +instance HasField "_3" (a,b,c,d) c where + hasField (a,b,c,d) = ((a,b,,d), c) +instance HasField "_4" (a,b,c,d) d where + hasField (a,b,c,d) = ((a,b,c,), d) + +instance HasField "_1" (a,b,c,d,e) a where + hasField (a,b,c,d,e) = ((,b,c,d,e), a) +instance HasField "_2" (a,b,c,d,e) b where + hasField (a,b,c,d,e) = ((a,,c,d,e), b) +instance HasField "_3" (a,b,c,d,e) c where + hasField (a,b,c,d,e) = ((a,b,,d,e), c) +instance HasField "_4" (a,b,c,d,e) d where + hasField (a,b,c,d,e) = ((a,b,c,,e), d) +instance HasField "_5" (a,b,c,d,e) e where + hasField (a,b,c,d,e) = ((a,b,c,d,), e) diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE MultiParamTypeClasses + , TypeApplications + , DataKinds + , FlexibleInstances + #-} + +module Main(main) where + +import GHC.Records.Extra + +newtype Foo = Foo {foo :: Int} deriving (Show,Eq) +instance HasField "foo" Foo Int where + hasField r = (\x -> r{foo=x}, foo r) + +newtype Bar = Bar {bar :: Foo} deriving (Show,Eq) +instance HasField "bar" Bar Foo where + hasField r = (\x -> r{bar=x}, bar r) + +main :: IO () +main = do + let a === b = if a == b then putStr "." else fail $ "Mismatch: " ++ show a ++ " /= " ++ show b + modifyField @'("bar","foo") (Bar $ Foo 12) (*2) === Bar {bar = Foo {foo = 24}} + getField @"foo" (Foo 3) === 3 + setField @"_1" (1, True) 8 === (8, True) + modifyField @'("_1","_2") ((1,2),3,4,5) negate === ((1,-2),3,4,5) + putStrLn " success"