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