@@ -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 #-}
13+-----------------------------------------------------------------------------
15+-- Module : Data.Generic.Product.HasFieldAt
16+-- Copyright : (C) 2017 Toby Shaw
18+-- Maintainer : Toby Shaw <toby.shaw.96@gmail.com>
19+-- Stability : experimental
20+-- Portability : non-portable
22+-- Derive product items lenses generically.
24+-----------------------------------------------------------------------------
26+module Data.Generic.Product.HasFieldAt
30+ -- * Getter and setter functions
35+import Data.Generic.Internal.Lens
38+import Data.Kind (Type)
44+-- module Example where
46+-- import GHC.Generics
47+-- import Data.Generic.Product
49+-- data Human = Human String Int String
50+-- deriving (Generic, Show)
53+-- human = Human \"Tunyasz\" 50 \"London\"
57+-- | Get positional field
59+-- >>> getFieldAt @1 human
61+getFieldAt :: forall index a s. HasFieldAt index a s => s -> a
62+getFieldAt s = s ^. itemAt @index
64+-- | Set positional field
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)
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.
78+ -- = forall f. Functor f => (a -> f a) -> s -> f s
81+ -- >>> human & itemAt @1 .~ "Tamas"
82+ -- Human "Tamas" 50 "London"
85+-- | Fields are indexed from BaseIndex upwards.
88+-- | Instances are generated on the fly for all types that have the required
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
97+data Choice = GoLeft | GoRight
99+class GHasFieldAtProd offset index a b ret (w :: Choice) | offset index a b w -> ret where
100+ prodItemAt :: Lens' ((a :*: b) x) ret
102+instance (GHasFieldAt offset index f ret) => GHasFieldAtProd offset index f g ret 'GoLeft where
103+ prodItemAt = first . gItemAt @offset @index
105+instance (GHasFieldAt offset index g ret) => GHasFieldAtProd offset index f g ret 'GoRight where
106+ prodItemAt = second . gItemAt @offset @index
108+--------------------------------------------------------------------------------
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)
113+type family Choose f g :: Choice where
114+ Choose 'True _ = 'GoLeft
115+ Choose _ 'True = 'GoRight
116+ Choose _ _ = TypeError ('Text "Could not find type")
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 _ _)
124+ ContainsAt _ _ (S1 _ _)
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 _)
132+ ContainsAt offset index U1
134+ ContainsAt offset index V1
136+ ContainsAt offset index t = TypeError ('ShowType offset ':<>: 'Text " " ':<>: 'ShowType index)
138+-- | Returns the count of terminal nodes in the generic representation.
139+type family Size f :: Nat where
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
155+type family (a :: Bool) || (b :: Bool) :: Bool where
159+--------------------------------------------------------------------------------
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
166+ ( choice ~ (Search offset index s s')
167+ , offset' ~ Offset offset choice (Size s)
168+ , GHasFieldAtProd offset' index s s' a choice
170+ => GHasFieldAt offset index (s :*: s') a where
171+ gItemAt = prodItemAt @offset' @index @_ @_ @_ @choice
173+instance GHasFieldAt offset index (K1 R a) a where
174+ gItemAt f (K1 x) = fmap K1 (f x)
176+instance GHasFieldAt n n (S1 ('MetaSel m p f b) (Rec0 a)) a where
177+ gItemAt = lensM . gItemAt @n @n
179+instance GHasFieldAt offset index s a => GHasFieldAt offset index (M1 D c s) a where
180+ gItemAt = lensM . gItemAt @offset @index
182+instance GHasFieldAt offset index s a => GHasFieldAt offset index (M1 C c s) a where
183+ gItemAt = lensM . gItemAt @offset @index