@@ -0,0 +1,75 @@
1+{-# LANGUAGE UndecidableSuperClasses #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE AllowAmbiguousTypes #-}
4+{-# LANGUAGE InstanceSigs #-}
5+
6+module Data.Schematic.Lens where
7+
8+import Data.Proxy
9+import Data.Schematic.Migration
10+import Data.Schematic.Schema
11+import Data.Vinyl
12+import Data.Vinyl.Functor
13+import Data.Vinyl.TypeLevel (Nat(..))
14+import GHC.TypeLits (Symbol)
15+
16+
17+-- | A partial relation that gives the index of a value in a list.
18+type family FIndex (r :: Symbol) (rs :: [(Symbol, Schema)]) :: Nat where
19+ FIndex r ( '(fn, s) ': rs) = 'Z
20+ FIndex r ( s ': rs) = 'S (FIndex r rs)
21+
22+class i ~ FIndex fn rs => FElem (fn :: Symbol) (rs :: [(Symbol, Schema)]) (i :: Nat) where
23+ type ByRevision fn rs i :: Schema
24+ flens
25+ :: Functor g
26+ => proxy fn
27+ -> (FieldRepr '(fn, (ByRevision fn rs i)) -> g (FieldRepr '(fn, (ByRevision fn rs i))))
28+ -> Rec FieldRepr rs
29+ -> g (Rec FieldRepr rs)
30+
31+ -- | For Vinyl users who are not using the @lens@ package, we provide a getter.
32+ fget
33+ :: proxy fn
34+ -> Rec FieldRepr rs
35+ -> FieldRepr '(fn, (ByRevision fn rs i))
36+
37+ -- | For Vinyl users who are not using the @lens@ package, we also provide a
38+ -- setter. In general, it will be unambiguous what field is being written to,
39+ -- and so we do not take a proxy argument here.
40+ fput
41+ :: FieldRepr '(fn, ByRevision fn rs i)
42+ -> Rec FieldRepr rs
43+ -> Rec FieldRepr rs
44+
45+instance FElem fn ('(fn, r) ': rs) 'Z where
46+ type ByRevision fn ('(fn, r) ': rs) 'Z = r
47+ flens _ f (x :& xs) = fmap (:& xs) (f x)
48+ {-# INLINE flens #-}
49+ fget k = getConst . flens k Const
50+ {-# INLINE fget #-}
51+ fput y = getIdentity . flens Proxy (\_ -> Identity y)
52+ {-# INLINE fput #-}
53+
54+instance (FIndex r (s ': rs) ~ 'S i, FElem r rs i) => FElem r (s ': rs) ('S i) where
55+ type ByRevision fn (s ': rs) ('S i) = ByRevision fn rs i
56+ flens p f (x :& xs) = fmap (x :&) (flens p f xs)
57+ {-# INLINE flens #-}
58+ fget k = getConst . flens k Const
59+ {-# INLINE fget #-}
60+ fput y = getIdentity . flens Proxy (\_ -> Identity y)
61+ {-# INLINE fput #-}
62+
63+type SchemaExample
64+ = 'SchemaObject
65+ '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))
66+ , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]
67+
68+type TestMigration =
69+ 'Migration "test_revision"
70+ '[ 'Diff '[ 'PKey "bar" ] ('Update ('SchemaText '[]))
71+ , 'Diff '[ 'PKey "foo" ] ('Update ('SchemaNumber '[])) ]
72+
73+type VS = 'Versioned SchemaExample '[ TestMigration ]
74+
75+type Ex = FIndex "initial" (AllVersions VS)