{-# 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)