module Generics.SOP.Lens.Computed (
AbstractLens(..)
, abstractId
, afterGLens
, get
, set
, modify
, getM
, setM
, modifyM
, Path
, CLens
, lens
, emptyPathOnly
, LensOptions(..)
, defaultLensOptions
) where
import Prelude hiding (id, (.))
import Control.Category
import Control.Monad
import Data.Functor.Identity
import Data.Maybe (catMaybes)
import Generics.SOP
import Generics.SOP.Lens (GLens)
import qualified Generics.SOP.Lens as GLens
data AbstractLens r w c a =
forall x. c x => AbstractLens (GLens r w a x)
abstractId :: (Monad r, c a) => AbstractLens r w c a
abstractId :: forall (r :: * -> *) (c :: * -> Constraint) a (w :: * -> *).
(Monad r, c a) =>
AbstractLens r w c a
abstractId = forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint) a x.
c x =>
GLens r w a x -> AbstractLens r w c a
AbstractLens forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
afterGLens ::
Monad r
=> AbstractLens r w c a
-> GLens r w b a
-> AbstractLens r w c b
afterGLens :: forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint) a b.
Monad r =>
AbstractLens r w c a -> GLens r w b a -> AbstractLens r w c b
afterGLens (AbstractLens GLens r w a x
l) GLens r w b a
l' = forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint) a x.
c x =>
GLens r w a x -> AbstractLens r w c a
AbstractLens (GLens r w a x
l forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. GLens r w b a
l')
get :: AbstractLens r w c a -> (forall x. c x => (a -> r x) -> b) -> b
get :: forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint) a b.
AbstractLens r w c a -> (forall x. c x => (a -> r x) -> b) -> b
get AbstractLens r w c a
l forall x. c x => (a -> r x) -> b
f = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint) a
(m :: * -> *) b.
AbstractLens r w c a -> (forall x. c x => (a -> r x) -> m b) -> m b
getM AbstractLens r w c a
l (forall a. a -> Identity a
Identity forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall x. c x => (a -> r x) -> b
f)
set :: Monad w => AbstractLens r w c a -> (forall x. c x => x) -> a -> w a
set :: forall (w :: * -> *) (r :: * -> *) (c :: * -> Constraint) a.
Monad w =>
AbstractLens r w c a -> (forall x. c x => x) -> a -> w a
set AbstractLens r w c a
l forall x. c x => x
x = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (w :: * -> *) (m :: * -> *) (r :: * -> *)
(c :: * -> Constraint) a.
(Monad w, Functor m) =>
AbstractLens r w c a -> (forall x. c x => m x) -> m (a -> w a)
setM AbstractLens r w c a
l (forall a. a -> Identity a
Identity forall x. c x => x
x)
modify :: AbstractLens r w c a -> (forall x. c x => x -> w x) -> a -> w a
modify :: forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint) a.
AbstractLens r w c a -> (forall x. c x => x -> w x) -> a -> w a
modify AbstractLens r w c a
l forall x. c x => x -> w x
f = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (r :: * -> *) (w :: * -> *)
(c :: * -> Constraint) a.
Functor m =>
AbstractLens r w c a
-> (forall x. c x => m (x -> w x)) -> m (a -> w a)
modifyM AbstractLens r w c a
l (forall a. a -> Identity a
Identity forall x. c x => x -> w x
f)
getM :: AbstractLens r w c a
-> (forall x. c x => (a -> r x) -> m b)
-> m b
getM :: forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint) a
(m :: * -> *) b.
AbstractLens r w c a -> (forall x. c x => (a -> r x) -> m b) -> m b
getM (AbstractLens GLens r w a x
l) forall x. c x => (a -> r x) -> m b
k = forall x. c x => (a -> r x) -> m b
k (forall (r :: * -> *) (w :: * -> *) a b. GLens r w a b -> a -> r b
GLens.get GLens r w a x
l)
setM ::
(Monad w, Functor m)
=> AbstractLens r w c a
-> (forall x. c x => m x)
-> m (a -> w a)
setM :: forall (w :: * -> *) (m :: * -> *) (r :: * -> *)
(c :: * -> Constraint) a.
(Monad w, Functor m) =>
AbstractLens r w c a -> (forall x. c x => m x) -> m (a -> w a)
setM (AbstractLens GLens r w a x
l) forall x. c x => m x
x = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (w :: * -> *) (r :: * -> *) a b.
Monad w =>
GLens r w a b -> b -> a -> w a
GLens.set GLens r w a x
l) forall x. c x => m x
x
modifyM ::
Functor m
=> AbstractLens r w c a
-> (forall x. c x => m (x -> w x))
-> m (a -> w a)
modifyM :: forall (m :: * -> *) (r :: * -> *) (w :: * -> *)
(c :: * -> Constraint) a.
Functor m =>
AbstractLens r w c a
-> (forall x. c x => m (x -> w x)) -> m (a -> w a)
modifyM (AbstractLens GLens r w a x
l) forall x. c x => m (x -> w x)
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (r :: * -> *) (w :: * -> *) a b.
GLens r w a b -> (b -> w b) -> a -> w a
GLens.modify GLens r w a x
l) forall x. c x => m (x -> w x)
f
type Path = [String]
class CLens r w c a where
lens :: LensOptions -> Path -> Either String (AbstractLens r w c a)
default lens :: ( HasDatatypeInfo a
, Monad r
, Monad w
, c a
, Code a ~ '[xs]
, All (CLens r w c) xs
)
=> LensOptions -> Path -> Either String (AbstractLens r w c a)
lens = forall (r :: * -> *) (w :: * -> *) a (c :: * -> Constraint)
(xs :: [*]).
(Monad r, Monad w, HasDatatypeInfo a, c a, Code a ~ '[xs],
All (CLens r w c) xs) =>
LensOptions -> Path -> Either FieldName (AbstractLens r w c a)
glens
emptyPathOnly ::
(Monad r, c a)
=> LensOptions -> Path -> Either String (AbstractLens r w c a)
emptyPathOnly :: forall (r :: * -> *) (c :: * -> Constraint) a (w :: * -> *).
(Monad r, c a) =>
LensOptions -> Path -> Either FieldName (AbstractLens r w c a)
emptyPathOnly LensOptions
_ [] = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (r :: * -> *) (c :: * -> Constraint) a (w :: * -> *).
(Monad r, c a) =>
AbstractLens r w c a
abstractId
emptyPathOnly LensOptions
_ Path
_ = forall a b. a -> Either a b
Left FieldName
"Trying to look inside abstract type"
data LensOptions = LensOptions {
LensOptions -> FieldName -> FieldName -> FieldName -> Bool
lensOptionsMatch :: DatatypeName -> FieldName -> String -> Bool
}
defaultLensOptions :: LensOptions
defaultLensOptions :: LensOptions
defaultLensOptions = LensOptions {
lensOptionsMatch :: FieldName -> FieldName -> FieldName -> Bool
lensOptionsMatch = forall a b. a -> b -> a
const forall a. Eq a => a -> a -> Bool
(==)
}
glens :: forall r w a c xs.
( Monad r
, Monad w
, HasDatatypeInfo a
, c a
, Code a ~ '[xs]
, All (CLens r w c) xs
)
=> LensOptions -> Path -> Either String (AbstractLens r w c a)
glens :: forall (r :: * -> *) (w :: * -> *) a (c :: * -> Constraint)
(xs :: [*]).
(Monad r, Monad w, HasDatatypeInfo a, c a, Code a ~ '[xs],
All (CLens r w c) xs) =>
LensOptions -> Path -> Either FieldName (AbstractLens r w c a)
glens LensOptions
_ [] = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (r :: * -> *) (c :: * -> Constraint) a (w :: * -> *).
(Monad r, c a) =>
AbstractLens r w c a
abstractId
glens LensOptions
opts (FieldName
p:Path
ps) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint) a b.
Monad r =>
AbstractLens r w c a -> GLens r w b a -> AbstractLens r w c b
`afterGLens` (forall (r :: * -> *) (w :: * -> *) (f :: * -> *) (xs :: [*]).
(Monad r, Monad w) =>
GLens r w (SOP f '[xs]) (NP f xs)
GLens.sop forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (r :: * -> *) (w :: * -> *) a.
(Monad r, Monad w, Generic a) =>
GLens r w a (Rep a)
GLens.rep))
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint)
(xs :: [*]).
(Monad r, Monad w, All (CLens r w c) xs) =>
LensOptions
-> FieldName
-> Path
-> DatatypeInfo '[xs]
-> Either FieldName (AbstractLens r w c (NP I xs))
glens' LensOptions
opts FieldName
p Path
ps
forall a b. (a -> b) -> a -> b
$ forall a (proxy :: * -> *).
HasDatatypeInfo a =>
proxy a -> DatatypeInfo (Code a)
datatypeInfo (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
glens' :: ( Monad r
, Monad w
, All (CLens r w c) xs
)
=> LensOptions -> String -> Path
-> DatatypeInfo '[xs]
-> Either String (AbstractLens r w c (NP I xs))
glens' :: forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint)
(xs :: [*]).
(Monad r, Monad w, All (CLens r w c) xs) =>
LensOptions
-> FieldName
-> Path
-> DatatypeInfo '[xs]
-> Either FieldName (AbstractLens r w c (NP I xs))
glens' LensOptions
opts FieldName
p Path
ps DatatypeInfo '[xs]
d =
forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint)
(xs :: [*]).
(Monad r, Monad w, All (CLens r w c) xs) =>
LensOptions
-> Path
-> FieldName
-> FieldName
-> ConstructorInfo xs
-> Either FieldName (AbstractLens r w c (NP I xs))
glens'' LensOptions
opts Path
ps (forall (xss :: [[*]]). DatatypeInfo xss -> FieldName
datatypeName DatatypeInfo '[xs]
d) FieldName
p (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))
glens'' :: forall r w c xs.
( Monad r
, Monad w
, All (CLens r w c) xs
)
=> LensOptions -> Path
-> DatatypeName -> String
-> ConstructorInfo xs
-> Either String (AbstractLens r w c (NP I xs))
glens'' :: forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint)
(xs :: [*]).
(Monad r, Monad w, All (CLens r w c) xs) =>
LensOptions
-> Path
-> FieldName
-> FieldName
-> ConstructorInfo xs
-> Either FieldName (AbstractLens r w c (NP I xs))
glens'' LensOptions
_ Path
_ FieldName
_ FieldName
_ (Constructor FieldName
_) =
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FieldName
"Cannot compute lenses for non-record types"
glens'' LensOptions
_ Path
_ FieldName
_ FieldName
_ (Infix FieldName
_ Associativity
_ Fixity
_) =
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FieldName
"Cannot compute lenses for non-record types"
glens'' LensOptions
opts Path
ps FieldName
d FieldName
p (Record FieldName
_ NP FieldInfo xs
fs) =
case [Either FieldName (AbstractLens r w c (NP I xs))]
matchingLenses of
[] -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FieldName
"Unknown field " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FieldName
show FieldName
p forall a. [a] -> [a] -> [a]
++ FieldName
" of datatype " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FieldName
show FieldName
d
[Either FieldName (AbstractLens r w c (NP I xs))
l] -> Either FieldName (AbstractLens r w c (NP I xs))
l
[Either FieldName (AbstractLens r w c (NP I xs))]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FieldName
"Invalid metadata for datatype " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FieldName
show FieldName
d
where
matchingLenses :: [Either String (AbstractLens r w c (NP I xs))]
matchingLenses :: [Either FieldName (AbstractLens r w c (NP I xs))]
matchingLenses = forall a. [Maybe a] -> [a]
catMaybes forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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 -> *) (f'' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a)
-> Prod h f xs
-> h f' xs
-> h f'' xs
hcliftA2 Proxy (CLens r w c)
pl forall a.
CLens r w c a =>
FieldInfo a
-> GLens r w (NP I xs) a
-> K (Maybe (Either FieldName (AbstractLens r w c (NP I xs)))) a
aux NP FieldInfo xs
fs forall (r :: * -> *) (w :: * -> *) (xs :: [*]).
(Monad r, Monad w, SListI xs) =>
NP (GLens r w (NP I xs)) xs
GLens.np
aux :: forall a. CLens r w c a
=> FieldInfo a
-> GLens r w (NP I xs) a
-> K (Maybe (Either String (AbstractLens r w c (NP I xs)))) a
aux :: forall a.
CLens r w c a =>
FieldInfo a
-> GLens r w (NP I xs) a
-> K (Maybe (Either FieldName (AbstractLens r w c (NP I xs)))) a
aux (FieldInfo FieldName
f) GLens r w (NP I xs) a
l = forall k a (b :: k). a -> K a b
K forall a b. (a -> b) -> a -> b
$
if LensOptions -> FieldName -> FieldName -> FieldName -> Bool
lensOptionsMatch LensOptions
opts FieldName
d FieldName
f FieldName
p
then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ((forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint) a b.
Monad r =>
AbstractLens r w c a -> GLens r w b a -> AbstractLens r w c b
`afterGLens` GLens r w (NP I xs) a
l) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (r :: * -> *) (w :: * -> *) (c :: * -> Constraint) a.
CLens r w c a =>
LensOptions -> Path -> Either FieldName (AbstractLens r w c a)
lens LensOptions
opts Path
ps)
else forall a. Maybe a
Nothing
pl :: Proxy (CLens r w c)
pl :: Proxy (CLens r w c)
pl = forall {k} (t :: k). Proxy t
Proxy