@@ -1,14 +1,16 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE FunctionalDependencies #-}
5−{-# LANGUAGE KindSignatures #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeApplications #-}
9−{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE TypeOperators #-}
11−{-# LANGUAGE UndecidableInstances #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FunctionalDependencies #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeInType #-}
11+{-# LANGUAGE TypeOperators #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+{-# LANGUAGE UndecidableSuperClasses #-}
1214
1315-----------------------------------------------------------------------------
1416-- |
@@ -26,72 +28,94 @@
2628module Data.Generics.Product.Fields
2729 ( -- *Lenses
2830
29− -- $example
31+ -- $setup
3032 HasField (..)
33+ , HasField'
34+
35+ , getField
36+ , setField
3137 ) where
3238
3339import Data.Generics.Internal.Families
3440import Data.Generics.Internal.Lens
41+import Data.Generics.Internal.Void
3542import Data.Generics.Product.Internal.Fields
3643
3744import Data.Kind (Constraint, Type)
3845import GHC.Generics
3946import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)
47+import Data.Type.Bool (If)
4048
41−-- $example
42−-- @
43−-- module Example where
44−--
45−-- import Data.Generics.Product
46−-- import GHC.Generics
47−--
48−-- data Human = Human
49−-- { name :: String
50−-- , age :: Int
51−-- , address :: String
52−-- }
53−-- deriving (Generic, Show)
54−--
55−-- human :: Human
56−-- human = Human \"Tunyasz\" 50 \"London\"
57−-- @
49+-- $setup
50+-- >>> :set -XTypeApplications
51+-- >>> :set -XDataKinds
52+-- >>> :set -XDeriveGeneric
53+-- >>> :set -XGADTs
54+-- >>> :set -XFlexibleContexts
55+-- >>> import GHC.Generics
56+-- >>> :m +Data.Generics.Internal.Lens
57+-- >>> :m +Data.Function
58+-- >>> :{
59+-- data Human a = Human
60+-- { name :: String
61+-- , age :: Int
62+-- , address :: String
63+-- , other :: a
64+-- }
65+-- deriving (Generic, Show)
66+-- human :: Human Bool
67+-- human = Human { name = "Tunyasz", age = 50, address = "London", other = False }
68+-- :}
5869
5970-- |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
6172 -- |A lens that focuses on a field with a given name. Compatible with the
6273 -- lens package's 'Control.Lens.Lens' type.
6374 --
6475 -- >>> human ^. field @"age"
6576 -- 50
66− -- >>> human & field @"name" .~ "Tamas"
67− -- Human {name = "Tamas", age = 50, address = "London"}
68− field :: Lens' s a
69− field f s
70− = fmap (flip (setField @field) s) (f (getField @field s))
71−
72− -- |Get 'field'
7377 --
74− -- >>> getField @"name" human
75− -- "Tunyasz"
76− getField :: s -> a
77− getField s = s ^. field @field
78+ -- If the field's type comes from a type parameter, it can be changed:
79+ -- >>> :t human
80+ -- human :: Human Bool
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
7886
79− -- |Set 'field'
80− --
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)
87+type HasField' field s a = HasField field s s a a
8588
86− {-# MINIMAL field | setField, getField #-}
89+-- |
90+-- >>> getField @"age" human
91+-- 50
92+getField :: forall f s a. HasField' f s a => s -> a
93+getField s = s ^. field @f
8794
88−instance
95+-- |
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)
100+
101+instance -- see Note [Changing type parameters]
89102 ( Generic s
90103 , ErrorUnless field s (HasTotalFieldP field (Rep s))
91− , GHasField field (Rep s) a
92− ) => HasField field a s where
104+ , Generic t
105+ , s' ~ Proxied s
106+ , Generic s'
107+ , GHasField' field (Rep s) a
108+ , 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)
111+ , t ~ UnProxied t'
112+ ) => HasField field s t a b where
113+
114+ field f s = ravel (repLens . gfield @field) f s
93115
94− field = ravel (repLens . gfield @field)
116+-- See Note [Uncluttering type signatures]
117+instance {-# OVERLAPPING #-} HasField f Void Void Void Void where
118+ field = undefined
95119
96120type family ErrorUnless (field :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where
97121 ErrorUnless field s 'False