module Control.Lens
(
Lens
, LensFamily
, makeLenses
, makeLensesBy
, makeLensesFor
, lens
, iso
, clone
, getL, modL, setL
, (^.), (^$)
, (^%=), (^=), (^+=), (^-=), (^*=), (^/=), (^||=), (^&&=)
, access
, Focus(..)
, (%=), (~=), (%%=), (+=), (-=), (*=), (//=), (||=), (&&=)
, fstLens
, sndLens
, mapLens
, intMapLens
, setLens
, intSetLens
, Getter
, getting
, Setter
, SetterFamily
, setting
, IndexedStore(..)
, Focusing(..)
) where
import Control.Applicative
import Control.Monad (liftM)
import Control.Monad.State.Class
import qualified Control.Monad.Trans.State.Lazy as Lazy
import qualified Control.Monad.Trans.State.Strict as Strict
import Control.Monad.Trans.Reader
import Data.Char (toLower)
import Data.Functor.Identity
import Data.IntMap as IntMap
import Data.IntSet as IntSet
import Data.Map as Map
import Data.Set as Set
import Language.Haskell.TH
infixl 8 ^.
infixr 4 ^%=, ^=, ^+=, ^*=, ^-=, ^/=, ^&&=, ^||=
infix 4 ~=, %=, %%=, +=, -=, *=, //=, &&=, ||=
infixr 0 ^$
type Lens a b = forall f. Functor f => (b -> f b) -> a -> f a
type LensFamily a b c d = forall f. Functor f => (c -> f d) -> a -> f b
type Getter a b = forall x y z. (b -> Const z x) -> a -> Const z y
type Setter a b = (b -> Identity b) -> a -> Identity a
type SetterFamily a b c d = (c -> Identity d) -> a -> Identity b
lens :: Functor f => (a -> c) -> (d -> a -> b) -> (c -> f d) -> a -> f b
lens ac dab cfd a = (`dab` a) <$> cfd (ac a)
iso :: Functor f => (a -> c) -> (d -> b) -> (c -> f d) -> a -> f b
iso f g h a = g <$> h (f a )
getting :: (a -> c) -> (c -> Const r d) -> a -> Const r b
getting f g a = Const (getConst (g (f a)))
setting :: ((c -> d) -> a -> b) -> (c -> Identity d) -> a -> Identity b
setting f g a = Identity (f (runIdentity . g) a)
getL :: ((c -> Const c d) -> a -> Const c b) -> a -> c
getL l a = getConst (l Const a)
modL :: ((c -> Identity d) -> a -> Identity b) -> (c -> d) -> a -> b
modL l f a = runIdentity (l (Identity . f) a)
setL :: ((c -> Identity d) -> a -> Identity b) -> d -> a -> b
setL l d a = runIdentity (l (\_ -> Identity d) a)
(^$) :: ((c -> Const c d) -> a -> Const c b) -> a -> c
l ^$ a = getConst (l Const a)
(^.) :: a -> ((c -> Const c d) -> a -> Const c b) -> c
a ^. l = getConst (l Const a)
(^%=) :: ((c -> Identity d) -> a -> Identity b) -> (c -> d) -> a -> b
l ^%= f = runIdentity . l (Identity . f)
(^=) :: ((c -> Identity d) -> a -> Identity b) -> d -> a -> b
l ^= v = runIdentity . l (Identity . const v)
(^+=) :: Num c => ((c -> Identity c) -> a -> Identity a) -> c -> a -> a
l ^+= n = modL l (+ n)
(^*=) :: Num c => ((c -> Identity c) -> a -> Identity a) -> c -> a -> a
l ^-= n = modL l (`subtract` n)
(^-=) :: Num c => ((c -> Identity c) -> a -> Identity a) -> c -> a -> a
l ^*= n = modL l (* n)
(^/=) :: Fractional c => ((c -> Identity c) -> a -> Identity a) -> c -> a -> a
l ^/= n = modL l (/ n)
(^||=):: ((Bool -> Identity Bool) -> a -> Identity a) -> Bool -> a -> a
l ^||= n = modL l (|| n)
(^&&=) :: ((Bool -> Identity Bool) -> a -> Identity a) -> Bool -> a -> a
l ^&&= n = modL l (&& n)
data IndexedStore c d a = IndexedStore (d -> a) c
instance Functor (IndexedStore c d) where
fmap f (IndexedStore g c) = IndexedStore (f . g) c
clone :: Functor f => ((c -> IndexedStore c d d) -> a -> IndexedStore c d b) -> (c -> f d) -> a -> f b
clone f cfd a = case f (IndexedStore id) a of
IndexedStore db c -> db <$> cfd c
fstLens :: LensFamily (a,c) (b,c) a b
fstLens f (a,c) = (\b -> (b,c)) <$> f a
sndLens :: LensFamily (c,a) (c,b) a b
sndLens f (c,a) = (,) c <$> f a
mapLens :: Ord k => k -> Lens (Map k v) (Maybe v)
mapLens k f m = go <$> f (Map.lookup k m) where
go Nothing = Map.delete k m
go (Just v') = Map.insert k v' m
intMapLens :: Int -> Lens (IntMap v) (Maybe v)
intMapLens k f m = go <$> f (IntMap.lookup k m) where
go Nothing = IntMap.delete k m
go (Just v') = IntMap.insert k v' m
setLens :: Ord k => k -> Lens (Set k) Bool
setLens k f s = go <$> f (Set.member k s) where
go False = Set.delete k s
go True = Set.insert k s
intSetLens :: Int -> Lens IntSet Bool
intSetLens k f s = go <$> f (IntSet.member k s) where
go False = IntSet.delete k s
go True = IntSet.insert k s
access :: MonadState a m => ((c -> Const c d) -> a -> Const c b) -> m c
access l = gets (^. l)
newtype Focusing m c a = Focusing { unfocusing :: m (c, a) }
instance Monad m => Functor (Focusing m c) where
fmap f (Focusing m) = Focusing (liftM (fmap f) m)
class Focus st where
focus :: Monad m => ((b -> Focusing m c b) -> a -> Focusing m c a) -> st b m c -> st a m c
instance Focus Strict.StateT where
focus l (Strict.StateT m) = Strict.StateT $ \a -> unfocusing (l (Focusing . m) a)
instance Focus Lazy.StateT where
focus l (Lazy.StateT m) = Lazy.StateT $ \a -> unfocusing (l (Focusing . m) a)
instance Focus ReaderT where
focus l (ReaderT m) = ReaderT $ \a -> liftM undefined $ unfocusing $ l (\b -> Focusing $ (\c -> (c,b)) `liftM` m b) a
(~=) :: MonadState a m => Setter a b -> b -> m ()
l ~= b = modify (l ^= b)
(%=) :: MonadState a m => Setter a b -> (b -> b) -> m ()
l %= f = modify (l ^%= f)
(%%=) :: MonadState a m => ((b -> (c,b)) -> a -> (c,a)) -> (b -> (c, b)) -> m c
l %%= f = state (l f)
(+=) :: (MonadState a m, Num b) => Setter a b -> b -> m ()
l += b = modify $ l ^+= b
(-=) :: (MonadState a m, Num b) => Setter a b -> b -> m ()
l -= b = modify $ l ^-= b
(*=) :: (MonadState a m, Num b) => Setter a b -> b -> m ()
l *= b = modify $ l ^*= b
(//=) :: (MonadState a m, Fractional b) => Setter a b -> b -> m ()
l //= b = modify $ l ^/= b
(&&=):: MonadState a m => Setter a Bool -> Bool -> m ()
l &&= b = modify $ l ^&&= b
(||=) :: MonadState a m => Setter a Bool -> Bool -> m ()
l ||= b = modify $ l ^||= b
defaultNameTransform :: String -> Maybe String
defaultNameTransform ('_':c:rest) = Just $ toLower c : rest
defaultNameTransform _ = Nothing
type LensTypeInfo = (Name, [TyVarBndr])
type ConstructorFieldInfo = (Name, Strict, Type)
makeLensesBy ::
(String -> Maybe String)
-> Name -> Q [Dec]
makeLensesBy nameTransform datatype = do
typeInfo <- extractLensTypeInfo datatype
let derive1 = deriveLens nameTransform typeInfo
constructorFields <- extractConstructorFields datatype
concat <$> mapM derive1 constructorFields
extractLensTypeInfo :: Name -> Q LensTypeInfo
extractLensTypeInfo datatype = do
let datatypeStr = nameBase datatype
i <- reify datatype
return $ case i of
TyConI (DataD _ n ts _ _) -> (n, ts)
TyConI (NewtypeD _ n ts _ _) -> (n, ts)
_ -> error $ "Can't derive Lens for: " ++ datatypeStr ++ ", type name required."
extractConstructorFields :: Name -> Q [ConstructorFieldInfo]
extractConstructorFields datatype = do
let datatypeStr = nameBase datatype
i <- reify datatype
return $ case i of
TyConI (DataD _ _ _ [RecC _ fs] _) -> fs
TyConI (NewtypeD _ _ _ (RecC _ fs) _) -> fs
TyConI (DataD _ _ _ [_] _) -> error $ "Can't derive Lens without record selectors: " ++ datatypeStr
TyConI NewtypeD{} -> error $ "Can't derive Lens without record selectors: " ++ datatypeStr
TyConI TySynD{} -> error $ "Can't derive Lens for type synonym: " ++ datatypeStr
TyConI DataD{} -> error $ "Can't derive Lens for tagged union: " ++ datatypeStr
_ -> error $ "Can't derive Lens for: " ++ datatypeStr ++ ", type name required."
deriveLens :: (String -> Maybe String)
-> LensTypeInfo
-> ConstructorFieldInfo
-> Q [Dec]
deriveLens nameTransform ty field = case nameTransform (nameBase fieldName) of
Nothing -> return []
Just lensNameStr -> do
body <- deriveLensBody (mkName lensNameStr) fieldName
return [body]
where
(fieldName, _fieldStrict, _fieldType) = field
(_tyName, _tyVars) = ty
deriveLensBody :: Name -> Name -> Q Dec
deriveLensBody lensName fieldName = funD lensName [defLine]
where
a = mkName "a"
f = mkName "f"
defLine = clause pats (normalB body) []
pats = [varP f, varP a]
body = [| (\x -> $(record a fieldName [|x|]))
`fmap` $(appE (varE f) (appE (varE fieldName) (varE a)))
|]
record rec fld val = val >>= \v -> recUpdE (varE rec) [return (fld, v)]
makeLenses :: Name -> Q [Dec]
makeLenses = makeLensesBy defaultNameTransform
makeLensesFor :: [(String, String)] -> Name -> Q [Dec]
makeLensesFor fields = makeLensesBy (`Prelude.lookup` fields)