module Generics.SOP.Lens.Named (
LensName
, NamedLens(..)
, get
, modify
, set
, gnamedLenses
) where
import Generics.SOP
import Generics.SOP.Lens (GLens)
import qualified Generics.SOP.Lens as GLens
type LensName = String
data NamedLens a ctxt = forall b. ctxt b => NamedLens {
()
unNamedLens :: GLens I I a b
}
instance Show (NamedLens a ctxt) where
show :: NamedLens a ctxt -> String
show NamedLens a ctxt
_ = String
"<<NamedLens>"
get :: NamedLens a ctxt -> (forall b. ctxt b => b -> c) -> a -> c
get :: forall a (ctxt :: * -> Constraint) c.
NamedLens a ctxt -> (forall b. ctxt b => b -> c) -> a -> c
get (NamedLens GLens I I a b
l) forall b. ctxt b => b -> c
k = forall b. ctxt b => b -> c
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. I a -> a
unI forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: * -> *) (w :: * -> *) a b. GLens r w a b -> a -> r b
GLens.get GLens I I a b
l
modify :: NamedLens a ctxt -> (forall b. ctxt b => b -> b) -> a -> a
modify :: forall a (ctxt :: * -> Constraint).
NamedLens a ctxt -> (forall b. ctxt b => b -> b) -> a -> a
modify (NamedLens GLens I I a b
l) forall b. ctxt b => b -> b
f = forall a. I a -> a
unI forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: * -> *) (w :: * -> *) a b.
GLens r w a b -> (b -> w b) -> a -> w a
GLens.modify GLens I I a b
l (forall a. a -> I a
I forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. ctxt b => b -> b
f)
set :: NamedLens a ctxt -> (forall b. ctxt b => b) -> a -> a
set :: forall a (ctxt :: * -> Constraint).
NamedLens a ctxt -> (forall b. ctxt b => b) -> a -> a
set (NamedLens GLens I I a b
l) forall b. ctxt b => b
b = forall a. I a -> a
unI forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (w :: * -> *) (r :: * -> *) a b.
Monad w =>
GLens r w a b -> b -> a -> w a
GLens.set GLens I I a b
l forall b. ctxt b => b
b
gnamedLenses :: forall a ctxt xs.
(HasDatatypeInfo a, Code a ~ '[xs], All ctxt xs)
=> (DatatypeName -> ConstructorName -> LensName)
-> [(String, NamedLens a ctxt)]
gnamedLenses :: forall a (ctxt :: * -> Constraint) (xs :: [*]).
(HasDatatypeInfo a, Code a ~ '[xs], All ctxt xs) =>
(String -> ShowS) -> [(String, NamedLens a ctxt)]
gnamedLenses String -> ShowS
mkName = case forall {k} (xs :: [k]). SListI xs => SList xs
sList :: SList (Code a) of
SList (Code a)
SCons -> forall a b. [a] -> [b] -> [(a, b)]
zip (forall (xs :: [*]).
(String -> ShowS) -> DatatypeInfo '[xs] -> [String]
fieldNames String -> ShowS
mkName (forall a (proxy :: * -> *).
HasDatatypeInfo a =>
proxy a -> DatatypeInfo (Code a)
datatypeInfo Proxy a
pa))
(forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse forall a b. (a -> b) -> a -> b
$ forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
(xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
(f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcliftA Proxy ctxt
pc (forall k a (b :: k). a -> K a b
K forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (ctxt :: * -> Constraint) b.
ctxt b =>
GLens I I a b -> NamedLens a ctxt
NamedLens) NP (GLens I I a) xs
totalLenses)
where
totalLenses :: NP (GLens I I a) xs
totalLenses :: NP (GLens I I a) xs
totalLenses = forall (r :: * -> *) (w :: * -> *) a (xs :: [*]).
(Generic a, Code a ~ '[xs], Monad r, Monad w) =>
NP (GLens r w a) xs
GLens.glenses
pa :: Proxy a
pa :: Proxy a
pa = forall {k} (t :: k). Proxy t
Proxy
pc :: Proxy ctxt
pc :: Proxy ctxt
pc = forall {k} (t :: k). Proxy t
Proxy
fieldNames :: (DatatypeName -> FieldName -> LensName)
-> DatatypeInfo '[xs] -> [String]
fieldNames :: forall (xs :: [*]).
(String -> ShowS) -> DatatypeInfo '[xs] -> [String]
fieldNames String -> ShowS
mkName DatatypeInfo '[xs]
d =
forall (xs :: [*]). ShowS -> ConstructorInfo xs -> [String]
fieldNames' (String -> ShowS
mkName (forall (xss :: [[*]]). DatatypeInfo xss -> String
datatypeName DatatypeInfo '[xs]
d)) (forall {k} (f :: k -> *) (x :: k) (xs :: [k]). NP f (x : xs) -> f x
hd (forall (xss :: [[*]]). DatatypeInfo xss -> NP ConstructorInfo xss
constructorInfo DatatypeInfo '[xs]
d))
fieldNames' :: (FieldName -> LensName) -> ConstructorInfo xs -> [String]
fieldNames' :: forall (xs :: [*]). ShowS -> ConstructorInfo xs -> [String]
fieldNames' ShowS
_ (Constructor String
_) = forall a. HasCallStack => String -> a
error String
"not a record type"
fieldNames' ShowS
_ (Infix String
_ Associativity
_ Int
_) = forall a. HasCallStack => String -> a
error String
"not a record type"
fieldNames' ShowS
mkName (Record String
_ NP FieldInfo xs
fs) = forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse forall a b. (a -> b) -> a -> b
$ forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
(f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hliftA forall a. FieldInfo a -> K String a
aux NP FieldInfo xs
fs
where
aux :: FieldInfo a -> K String a
aux :: forall a. FieldInfo a -> K String a
aux (FieldInfo String
n) = forall k a (b :: k). a -> K a b
K (ShowS
mkName String
n)