@@ -1,14 +1,16 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE FunctionalDependencies #-}
5−{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeApplications #-}
8+{-# LANGUAGE TypeApplications #-}
9−{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeInType #-}
10−{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE TypeOperators #-}
11−{-# LANGUAGE UndecidableInstances #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+{-# LANGUAGE UndecidableSuperClasses #-}
13-----------------------------------------------------------------------------
15-----------------------------------------------------------------------------
@@ -26,72 +28,94 @@
26module Data.Generics.Product.Fields
28module Data.Generics.Product.Fields
27 ( -- *Lenses
29 ( -- *Lenses
29− -- $example
31+ -- $setup
30 HasField (..)
32 HasField (..)
33import Data.Generics.Internal.Families
39import Data.Generics.Internal.Families
34import Data.Generics.Internal.Lens
40import Data.Generics.Internal.Lens
41+import Data.Generics.Internal.Void
35import Data.Generics.Product.Internal.Fields
42import Data.Generics.Product.Internal.Fields
37import Data.Kind (Constraint, Type)
44import Data.Kind (Constraint, Type)
38import GHC.Generics
45import GHC.Generics
39import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
46import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
47+import Data.Type.Bool (If)
41−-- $example
49+-- $setup
42−-- @
50+-- >>> :set -XTypeApplications
43−-- module Example where
51+-- >>> :set -XDataKinds
44−--
52+-- >>> :set -XDeriveGeneric
45−-- import Data.Generics.Product
53+-- >>> :set -XGADTs
54+-- >>> :set -XFlexibleContexts
46−-- import GHC.Generics
55+-- >>> import GHC.Generics
47−--
56+-- >>> :m +Data.Generics.Internal.Lens
57+-- >>> :m +Data.Function
48−-- data Human = Human
59+-- data Human a = Human
49−-- { name :: String
60+-- { name :: String
50−-- , age :: Int
61+-- , age :: Int
51−-- , address :: String
62+-- , address :: String
52−-- }
63+-- , other :: a
53−-- deriving (Generic, Show)
65+-- deriving (Generic, Show)
55−-- human :: Human
66+-- human :: Human Bool
56−-- human = Human \"Tunyasz\" 50 \"London\"
67+-- human = Human { name = "Tunyasz", age = 50, address = "London", other = False }
59-- |Records that have a field with a given name.
70-- |Records that have a field with a given name.
60−class HasField (field :: Symbol) a s | s field -> a where
71+class HasField (field :: Symbol) s t a b | s field b -> t, s field -> a where
61 -- |A lens that focuses on a field with a given name. Compatible with the
72 -- |A lens that focuses on a field with a given name. Compatible with the
62 -- lens package's 'Control.Lens.Lens' type.
73 -- lens package's 'Control.Lens.Lens' type.
64 -- >>> human ^. field @"age"
75 -- >>> human ^. field @"age"
66− -- >>> human & field @"name" .~ "Tamas"
67− -- Human {name = "Tamas", age = 50, address = "London"}
70− = fmap (flip (setField @field) s) (f (getField @field s))
74− -- >>> getField @"name" human
78+ -- If the field's type comes from a type parameter, it can be changed:
75− -- "Tunyasz"
79+ -- >>> :t human
76− getField :: s -> a
80+ -- human :: Human Bool
77− getField s = s ^. field @field
81+ -- >>> :t human & field @"other" .~ 42
82+ -- human & field @"other" .~ 42 :: Num b => Human b
83+ -- >>> human & field @"other" .~ 42
84+ -- Human {name = "Tunyasz", age = 50, address = "London", other = 42}
85+ field :: Lens s t a b
79− -- |Set 'field'
87+type HasField' field s a = HasField field s s a a
81− -- >>> setField @"age" (setField @"name" "Tamas" human) 30
82− -- Human {name = "Tamas", age = 30, address = "London"}
83− setField :: a -> s -> s
84− setField = set (field @field)
86− {-# MINIMAL field | setField, getField #-}
89+-- |
90+-- >>> getField @"age" human
92+getField :: forall f s a. HasField' f s a => s -> a
93+getField s = s ^. field @f
96+-- >>> setField @"age" 60 human
97+-- Human {name = "Tunyasz", age = 60, address = "London", other = False}
98+setField :: forall f s a. HasField' f s a => a -> s -> s
99+setField = set (field @f)
101+instance -- see Note [Changing type parameters]
89 ( Generic s
102 ( Generic s
90 , ErrorUnless field s (HasTotalFieldP field (Rep s))
103 , ErrorUnless field s (HasTotalFieldP field (Rep s))
107+ , GHasField' field (Rep s) a
108+ , GHasField' field (Rep s') a'
91− , GHasField field (Rep s) a
109+ , GHasField field (Rep s) (Rep t) a b
110+ , '(t', b') ~ If (IsParam a') '(Change s' (IndexOf a') b, P (IndexOf a') b) '(s', b)
92− ) => HasField field a s where
112+ ) => HasField field s t a b where
114+ field f s = ravel (repLens . gfield @field) f s
94− field = ravel (repLens . gfield @field)
116+-- See Note [Uncluttering type signatures]
117+instance {-# OVERLAPPING #-} HasField f Void Void Void Void where
96type family ErrorUnless (field :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where
120type family ErrorUnless (field :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where
97 ErrorUnless field s 'False
121 ErrorUnless field s 'False