@@ -0,0 +1,184 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE Rank2Types #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+
13+-----------------------------------------------------------------------------
14+-- |
15+-- Module : Data.Generic.Product.HasFieldAt
16+-- Copyright : (C) 2017 Toby Shaw
17+-- License : BSD3
18+-- Maintainer : Toby Shaw <toby.shaw.96@gmail.com>
19+-- Stability : experimental
20+-- Portability : non-portable
21+--
22+-- Derive product items lenses generically.
23+--
24+-----------------------------------------------------------------------------
25+
26+module Data.Generic.Product.HasFieldAt
27+ ( -- * Lens
28+ -- $example
29+ HasFieldAt (..)
30+ -- * Getter and setter functions
31+ , getFieldAt
32+ , setFieldAt
33+ ) where
34+
35+import Data.Generic.Internal.Lens
36+
37+import GHC.TypeLits
38+import Data.Kind (Type)
39+import GHC.Generics
40+
41+-- $example
42+-- @
43+--
44+-- module Example where
45+--
46+-- import GHC.Generics
47+-- import Data.Generic.Product
48+--
49+-- data Human = Human String Int String
50+-- deriving (Generic, Show)
51+--
52+-- human :: Human
53+-- human = Human \"Tunyasz\" 50 \"London\"
54+--
55+-- @
56+
57+-- | Get positional field
58+--
59+-- >>> getFieldAt @1 human
60+-- "Tunyasz"
61+getFieldAt :: forall index a s. HasFieldAt index a s => s -> a
62+getFieldAt s = s ^. itemAt @index
63+
64+-- | Set positional field
65+--
66+-- >>> setFieldAt @2 (setField @1 "Tamas" human) 30
67+-- Human "Tamas" 30 "London"
68+setFieldAt :: forall index a s. HasFieldAt index a s => a -> s -> s
69+setFieldAt = set (itemAt @index)
70+
71+-- | Types that have a field at given position.
72+class HasFieldAt (index :: Nat) a s | s index -> a where
73+ -- ^ Lens focusing on a field at a given index.
74+ -- Compatible with the lens package.
75+ --
76+ -- @
77+ -- type Lens' s a
78+ -- = forall f. Functor f => (a -> f a) -> s -> f s
79+ -- @
80+ --
81+ -- >>> human & itemAt @1 .~ "Tamas"
82+ -- Human "Tamas" 50 "London"
83+ itemAt :: Lens' s a
84+
85+-- | Fields are indexed from BaseIndex upwards.
86+type BaseIndex = 1
87+
88+-- | Instances are generated on the fly for all types that have the required
89+-- positional field.
90+instance
91+ ( Generic s
92+ , ContainsAt BaseIndex index (Rep s) ~ 'True -- this is needed for the fundep
93+ , GHasFieldAt BaseIndex index (Rep s) a
94+ ) => HasFieldAt index a s where
95+ itemAt = repIso . gItemAt @BaseIndex @index
96+
97+data Choice = GoLeft | GoRight
98+
99+class GHasFieldAtProd offset index a b ret (w :: Choice) | offset index a b w -> ret where
100+ prodItemAt :: Lens' ((a :*: b) x) ret
101+
102+instance (GHasFieldAt offset index f ret) => GHasFieldAtProd offset index f g ret 'GoLeft where
103+ prodItemAt = first . gItemAt @offset @index
104+
105+instance (GHasFieldAt offset index g ret) => GHasFieldAtProd offset index f g ret 'GoRight where
106+ prodItemAt = second . gItemAt @offset @index
107+
108+--------------------------------------------------------------------------------
109+
110+type family Search offset index f g :: Choice where
111+ Search offset index f g = Choose (ContainsAt offset index f) (ContainsAt (offset + Size f) index g)
112+
113+type family Choose f g :: Choice where
114+ Choose 'True _ = 'GoLeft
115+ Choose _ 'True = 'GoRight
116+ Choose _ _ = TypeError ('Text "Could not find type")
117+
118+-- | Try find a field by position in the generic representation.
119+type family ContainsAt (offset :: Nat) (index :: Nat) f :: Bool where
120+ ContainsAt offset index (D1 m f)
121+ = ContainsAt offset index f
122+ ContainsAt n n (S1 _ _)
123+ = 'True
124+ ContainsAt _ _ (S1 _ _)
125+ = 'False
126+ ContainsAt offset index (f :*: g)
127+ = ContainsAt offset index f || ContainsAt (Size f + offset) index g
128+ ContainsAt offset index (C1 m f)
129+ = ContainsAt offset index f
130+ ContainsAt offset index (Rec0 _)
131+ = 'False
132+ ContainsAt offset index U1
133+ = 'False
134+ ContainsAt offset index V1
135+ = 'False
136+ ContainsAt offset index t = TypeError ('ShowType offset ':<>: 'Text " " ':<>: 'ShowType index)
137+
138+-- | Returns the count of terminal nodes in the generic representation.
139+type family Size f :: Nat where
140+ Size (D1 m f)
141+ = Size f
142+ Size (f :*: g)
143+ = Size f + Size g
144+ Size (C1 m f)
145+ = Size f
146+ Size t = 1
147+
148+-- | If traversing to the left, offset does not change.
149+-- If traversing to the right, offset is incremented by size of left subtree.
150+type family Offset (offset :: Nat) (choice :: Choice) (size :: Nat) :: Nat where
151+ Offset n 'GoLeft _ = n
152+ Offset n 'GoRight s = n + s
153+
154+-- | Type-level or
155+type family (a :: Bool) || (b :: Bool) :: Bool where
156+ 'True || _ = 'True
157+ _ || b = b
158+
159+--------------------------------------------------------------------------------
160+
161+-- | Like 'HasFieldAt', but on the generic representation
162+class GHasFieldAt (offset :: Nat) (index :: Nat) (s :: Type -> Type) a | offset index s -> a where
163+ gItemAt :: Lens' (s x) a
164+
165+instance
166+ ( choice ~ (Search offset index s s')
167+ , offset' ~ Offset offset choice (Size s)
168+ , GHasFieldAtProd offset' index s s' a choice
169+ )
170+ => GHasFieldAt offset index (s :*: s') a where
171+ gItemAt = prodItemAt @offset' @index @_ @_ @_ @choice
172+
173+instance GHasFieldAt offset index (K1 R a) a where
174+ gItemAt f (K1 x) = fmap K1 (f x)
175+
176+instance GHasFieldAt n n (S1 ('MetaSel m p f b) (Rec0 a)) a where
177+ gItemAt = lensM . gItemAt @n @n
178+
179+instance GHasFieldAt offset index s a => GHasFieldAt offset index (M1 D c s) a where
180+ gItemAt = lensM . gItemAt @offset @index
181+
182+instance GHasFieldAt offset index s a => GHasFieldAt offset index (M1 C c s) a where
183+ gItemAt = lensM . gItemAt @offset @index
184+