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.Arrow
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 :: (ArrowApply r, ArrowApply w, c a) => AbstractLens r w c a
abstractId = AbstractLens id
afterGLens :: (ArrowApply r, ArrowApply w)
=> AbstractLens r w c a
-> GLens r w b a
-> AbstractLens r w c b
afterGLens (AbstractLens l) l' = AbstractLens (l . l')
get :: Category r => AbstractLens r w c a -> (forall x. c x => r a x -> b) -> b
get l f = runIdentity $ getM l (Identity . f)
set :: Arrow w => AbstractLens r w c a -> (forall x. c x => x) -> w a a
set l x = runIdentity $ setM l (Identity x)
modify :: Arrow w => AbstractLens r w c a -> (forall x. c x => w x x) -> w a a
modify l f = runIdentity $ modifyM l (Identity f)
getM :: (Monad m, Category r)
=> AbstractLens r w c a
-> (forall x. c x => r a x -> m b)
-> m b
getM (AbstractLens l) k = k (GLens.get l)
setM :: (Monad m, Arrow w)
=> AbstractLens r w c a -> (forall x. c x => m x) -> m (w a a)
setM (AbstractLens l) mx =
mx >>= \x -> return $ GLens.set l . arr (\a -> (x, a))
modifyM :: (Monad m, Arrow w)
=> AbstractLens r w c a -> (forall x. c x => m (w x x)) -> m (w a a)
modifyM (AbstractLens l) mf =
mf >>= \f -> return $ GLens.modify l . arr (\a -> (f, a))
type Path = [String]
class CLens r w c a where
default lens :: ( Generic a
, HasDatatypeInfo a
, ArrowApply r
, ArrowApply w
, c a
, Code a ~ '[xs]
, All (CLens r w c) xs
)
=> LensOptions -> Path -> Either String (AbstractLens r w c a)
lens :: LensOptions -> Path -> Either String (AbstractLens r w c a)
lens = glens
emptyPathOnly :: (ArrowApply r, ArrowApply w, c a)
=> LensOptions -> Path -> Either String (AbstractLens r w c a)
emptyPathOnly _ [] = Right $ abstractId
emptyPathOnly _ _ = Left "Trying to look inside abstract type"
data LensOptions = LensOptions {
lensOptionsMatch :: DatatypeName -> FieldName -> String -> Bool
}
defaultLensOptions :: LensOptions
defaultLensOptions = LensOptions {
lensOptionsMatch = const (==)
}
glens :: forall r w a c xs.
( ArrowApply r
, ArrowApply w
, Generic a
, HasDatatypeInfo a
, c a
, Code a ~ '[xs]
, All (CLens r w c) xs
)
=> LensOptions -> Path -> Either String (AbstractLens r w c a)
glens _ [] = Right $ abstractId
glens opts (p:ps) = liftM (`afterGLens` (GLens.sop . GLens.rep))
. glens' opts p ps
$ datatypeInfo (Proxy :: Proxy a)
glens' :: ( ArrowApply r
, ArrowApply w
, All (CLens r w c) xs
)
=> LensOptions -> String -> Path
-> DatatypeInfo '[xs]
-> Either String (AbstractLens r w c (NP I xs))
glens' opts p ps d =
glens'' opts ps (datatypeName d) p (hd (constructorInfo d))
glens'' :: forall r w c xs.
( ArrowApply r
, ArrowApply w
, All (CLens r w c) xs
)
=> LensOptions -> Path
-> DatatypeName -> String
-> ConstructorInfo xs
-> Either String (AbstractLens r w c (NP I xs))
glens'' _ _ _ _ (Constructor _) =
Left $ "Cannot compute lenses for non-record types"
glens'' _ _ _ _ (Infix _ _ _) =
Left $ "Cannot compute lenses for non-record types"
glens'' opts ps d p (Record _ fs) =
case matchingLenses of
[] -> Left $ "Unknown field " ++ show p ++ " of datatype " ++ show d
[l] -> l
_ -> Left $ "Invalid metadata for datatype " ++ show d
where
matchingLenses :: [Either String (AbstractLens r w c (NP I xs))]
matchingLenses = catMaybes . hcollapse $ hcliftA2 pl aux fs 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 (FieldInfo f) l = K $
if lensOptionsMatch opts d f p
then Just $ ((`afterGLens` l) `liftM` lens opts ps)
else Nothing
pl :: Proxy (CLens r w c)
pl = Proxy