1{-# LANGUAGE CPP #-} 2{-# LANGUAGE TypeFamilies #-} 3{-# LANGUAGE FlexibleContexts #-} 4{-# LANGUAGE FlexibleInstances #-} 5{-# LANGUAGE UndecidableInstances #-} 6{-# LANGUAGE FunctionalDependencies #-} 7{-# LANGUAGE RankNTypes #-} 8{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} 9{-# LANGUAGE Trustworthy #-} 10 11#include "lens-common.h" 12 13------------------------------------------------------------------------------- 14-- | 15-- Module : Control.Lens.Zoom 16-- Copyright : (C) 2012-16 Edward Kmett 17-- License : BSD-style (see the file LICENSE) 18-- Maintainer : Edward Kmett <ekmett@gmail.com> 19-- Stability : provisional 20-- Portability : Rank2Types 21-- 22------------------------------------------------------------------------------- 23module Control.Lens.Zoom 24 ( Magnified 25 , Magnify(..) 26 , Zoom(..) 27 , Zoomed 28 ) where 29 30import Prelude () 31 32import Control.Lens.Getter 33import Control.Lens.Internal.Coerce 34import Control.Lens.Internal.Prelude 35import Control.Lens.Internal.Zoom 36import Control.Lens.Type 37import Control.Monad 38import Control.Monad.Reader as Reader 39import Control.Monad.State as State 40import Control.Monad.Trans.State.Lazy as Lazy 41import Control.Monad.Trans.State.Strict as Strict 42import Control.Monad.Trans.Writer.Lazy as Lazy 43import Control.Monad.Trans.Writer.Strict as Strict 44import Control.Monad.Trans.RWS.Lazy as Lazy 45import Control.Monad.Trans.RWS.Strict as Strict 46import Control.Monad.Trans.Error 47import Control.Monad.Trans.Except 48import Control.Monad.Trans.List 49import Control.Monad.Trans.Identity 50import Control.Monad.Trans.Maybe 51import Control.Monad.Trans.Free 52 53-- $setup 54-- >>> import Control.Lens 55-- >>> import Control.Monad.State as State 56-- >>> import Control.Monad.Reader as Reader 57-- >>> import qualified Data.Map as Map 58-- >>> import Debug.SimpleReflect.Expr as Expr 59-- >>> import Debug.SimpleReflect.Vars as Vars 60-- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f 61-- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g 62-- >>> let h :: Expr -> Expr -> Expr; h = Debug.SimpleReflect.Vars.h 63 64-- Chosen so that they have lower fixity than ('%='), and to match ('<~'). 65infixr 2 `zoom`, `magnify` 66 67------------------------------------------------------------------------------ 68-- Zoomed 69------------------------------------------------------------------------------ 70 71-- | This type family is used by 'Control.Lens.Zoom.Zoom' to describe the common effect type. 72type family Zoomed (m :: * -> *) :: * -> * -> * 73type instance Zoomed (Strict.StateT s z) = Focusing z 74type instance Zoomed (Lazy.StateT s z) = Focusing z 75type instance Zoomed (ReaderT e m) = Zoomed m 76type instance Zoomed (IdentityT m) = Zoomed m 77type instance Zoomed (Strict.RWST r w s z) = FocusingWith w z 78type instance Zoomed (Lazy.RWST r w s z) = FocusingWith w z 79type instance Zoomed (Strict.WriterT w m) = FocusingPlus w (Zoomed m) 80type instance Zoomed (Lazy.WriterT w m) = FocusingPlus w (Zoomed m) 81type instance Zoomed (ListT m) = FocusingOn [] (Zoomed m) 82type instance Zoomed (MaybeT m) = FocusingMay (Zoomed m) 83type instance Zoomed (ErrorT e m) = FocusingErr e (Zoomed m) 84type instance Zoomed (ExceptT e m) = FocusingErr e (Zoomed m) 85type instance Zoomed (FreeT f m) = FocusingFree f m (Zoomed m) 86 87------------------------------------------------------------------------------ 88-- Magnified 89------------------------------------------------------------------------------ 90 91-- | This type family is used by 'Control.Lens.Zoom.Magnify' to describe the common effect type. 92type family Magnified (m :: * -> *) :: * -> * -> * 93type instance Magnified (ReaderT b m) = Effect m 94type instance Magnified ((->)b) = Const 95type instance Magnified (Strict.RWST a w s m) = EffectRWS w s m 96type instance Magnified (Lazy.RWST a w s m) = EffectRWS w s m 97type instance Magnified (IdentityT m) = Magnified m 98 99------------------------------------------------------------------------------ 100-- Zoom 101------------------------------------------------------------------------------ 102 103-- | This class allows us to use 'zoom' in, changing the 'State' supplied by 104-- many different 'Control.Monad.Monad' transformers, potentially quite 105-- deep in a 'Monad' transformer stack. 106class (MonadState s m, MonadState t n) => Zoom m n s t | m -> s, n -> t, m t -> n, n s -> m where 107 -- | Run a monadic action in a larger 'State' than it was defined in, 108 -- using a 'Lens'' or 'Control.Lens.Traversal.Traversal''. 109 -- 110 -- This is commonly used to lift actions in a simpler 'State' 111 -- 'Monad' into a 'State' 'Monad' with a larger 'State' type. 112 -- 113 -- When applied to a 'Control.Lens.Traversal.Traversal'' over 114 -- multiple values, the actions for each target are executed sequentially 115 -- and the results are aggregated. 116 -- 117 -- This can be used to edit pretty much any 'Monad' transformer stack with a 'State' in it! 118 -- 119 -- >>> flip State.evalState (a,b) $ zoom _1 $ use id 120 -- a 121 -- 122 -- >>> flip State.execState (a,b) $ zoom _1 $ id .= c 123 -- (c,b) 124 -- 125 -- >>> flip State.execState [(a,b),(c,d)] $ zoom traverse $ _2 %= f 126 -- [(a,f b),(c,f d)] 127 -- 128 -- >>> flip State.runState [(a,b),(c,d)] $ zoom traverse $ _2 <%= f 129 -- (f b <> f d <> mempty,[(a,f b),(c,f d)]) 130 -- 131 -- >>> flip State.evalState (a,b) $ zoom both (use id) 132 -- a <> b 133 -- 134 -- @ 135 -- 'zoom' :: 'Monad' m => 'Lens'' s t -> 'StateT' t m a -> 'StateT' s m a 136 -- 'zoom' :: ('Monad' m, 'Monoid' c) => 'Control.Lens.Traversal.Traversal'' s t -> 'StateT' t m c -> 'StateT' s m c 137 -- 'zoom' :: ('Monad' m, 'Monoid' w) => 'Lens'' s t -> 'RWST' r w t m c -> 'RWST' r w s m c 138 -- 'zoom' :: ('Monad' m, 'Monoid' w, 'Monoid' c) => 'Control.Lens.Traversal.Traversal'' s t -> 'RWST' r w t m c -> 'RWST' r w s m c 139 -- 'zoom' :: ('Monad' m, 'Monoid' w, 'Error' e) => 'Lens'' s t -> 'ErrorT' e ('RWST' r w t m) c -> 'ErrorT' e ('RWST' r w s m) c 140 -- 'zoom' :: ('Monad' m, 'Monoid' w, 'Monoid' c, 'Error' e) => 'Control.Lens.Traversal.Traversal'' s t -> 'ErrorT' e ('RWST' r w t m) c -> 'ErrorT' e ('RWST' r w s m) c 141 -- ... 142 -- @ 143 zoom :: LensLike' (Zoomed m c) t s -> m c -> n c 144 145instance Monad z => Zoom (Strict.StateT s z) (Strict.StateT t z) s t where 146 zoom l (Strict.StateT m) = Strict.StateT $ unfocusing #. l (Focusing #. m) 147 {-# INLINE zoom #-} 148 149instance Monad z => Zoom (Lazy.StateT s z) (Lazy.StateT t z) s t where 150 zoom l (Lazy.StateT m) = Lazy.StateT $ unfocusing #. l (Focusing #. m) 151 {-# INLINE zoom #-} 152 153instance Zoom m n s t => Zoom (ReaderT e m) (ReaderT e n) s t where 154 zoom l (ReaderT m) = ReaderT (zoom l . m) 155 {-# INLINE zoom #-} 156 157instance Zoom m n s t => Zoom (IdentityT m) (IdentityT n) s t where 158 zoom l (IdentityT m) = IdentityT (zoom l m) 159 {-# INLINE zoom #-} 160 161instance (Monoid w, Monad z) => Zoom (Strict.RWST r w s z) (Strict.RWST r w t z) s t where 162 zoom l (Strict.RWST m) = Strict.RWST $ \r -> unfocusingWith #. l (FocusingWith #. m r) 163 {-# INLINE zoom #-} 164 165instance (Monoid w, Monad z) => Zoom (Lazy.RWST r w s z) (Lazy.RWST r w t z) s t where 166 zoom l (Lazy.RWST m) = Lazy.RWST $ \r -> unfocusingWith #. l (FocusingWith #. m r) 167 {-# INLINE zoom #-} 168 169instance (Monoid w, Zoom m n s t) => Zoom (Strict.WriterT w m) (Strict.WriterT w n) s t where 170 zoom l = Strict.WriterT . zoom (\afb -> unfocusingPlus #.. l (FocusingPlus #.. afb)) . Strict.runWriterT 171 {-# INLINE zoom #-} 172 173instance (Monoid w, Zoom m n s t) => Zoom (Lazy.WriterT w m) (Lazy.WriterT w n) s t where 174 zoom l = Lazy.WriterT . zoom (\afb -> unfocusingPlus #.. l (FocusingPlus #.. afb)) . Lazy.runWriterT 175 {-# INLINE zoom #-} 176 177instance Zoom m n s t => Zoom (ListT m) (ListT n) s t where 178 zoom l = ListT . zoom (\afb -> unfocusingOn . l (FocusingOn . afb)) . runListT 179 {-# INLINE zoom #-} 180 181instance Zoom m n s t => Zoom (MaybeT m) (MaybeT n) s t where 182 zoom l = MaybeT . liftM getMay . zoom (\afb -> unfocusingMay #.. l (FocusingMay #.. afb)) . liftM May . runMaybeT 183 {-# INLINE zoom #-} 184 185instance (Error e, Zoom m n s t) => Zoom (ErrorT e m) (ErrorT e n) s t where 186 zoom l = ErrorT . liftM getErr . zoom (\afb -> unfocusingErr #.. l (FocusingErr #.. afb)) . liftM Err . runErrorT 187 {-# INLINE zoom #-} 188 189instance Zoom m n s t => Zoom (ExceptT e m) (ExceptT e n) s t where 190 zoom l = ExceptT . liftM getErr . zoom (\afb -> unfocusingErr #.. l (FocusingErr #.. afb)) . liftM Err . runExceptT 191 {-# INLINE zoom #-} 192 193instance (Functor f, Zoom m n s t) => Zoom (FreeT f m) (FreeT f n) s t where 194 zoom l = FreeT . liftM (fmap (zoom l) . getFreed) . zoom (\afb -> unfocusingFree #.. l (FocusingFree #.. afb)) . liftM Freed . runFreeT 195 196------------------------------------------------------------------------------ 197-- Magnify 198------------------------------------------------------------------------------ 199 200-- TODO: instance Zoom m m a a => Zoom (ContT r m) (ContT r m) a a where 201 202-- | This class allows us to use 'magnify' part of the environment, changing the environment supplied by 203-- many different 'Monad' transformers. Unlike 'zoom' this can change the environment of a deeply nested 'Monad' transformer. 204-- 205-- Also, unlike 'zoom', this can be used with any valid 'Getter', but cannot be used with a 'Traversal' or 'Fold'. 206class (Magnified m ~ Magnified n, MonadReader b m, MonadReader a n) => Magnify m n b a | m -> b, n -> a, m a -> n, n b -> m where 207 -- | Run a monadic action in a larger environment than it was defined in, using a 'Getter'. 208 -- 209 -- This acts like 'Control.Monad.Reader.Class.local', but can in many cases change the type of the environment as well. 210 -- 211 -- This is commonly used to lift actions in a simpler 'Reader' 'Monad' into a 'Monad' with a larger environment type. 212 -- 213 -- This can be used to edit pretty much any 'Monad' transformer stack with an environment in it: 214 -- 215 -- >>> (1,2) & magnify _2 (+1) 216 -- 3 217 -- 218 -- >>> flip Reader.runReader (1,2) $ magnify _1 Reader.ask 219 -- 1 220 -- 221 -- >>> flip Reader.runReader (1,2,[10..20]) $ magnify (_3._tail) Reader.ask 222 -- [11,12,13,14,15,16,17,18,19,20] 223 -- 224 -- The type can be read as 225 -- 226 -- @ 227 -- magnify :: LensLike' (Magnified m c) a b -> m c -> n c 228 -- @ 229 -- 230 -- but the higher-rank constraints make it easier to apply @magnify@ to a 231 -- 'Getter' in highly-polymorphic code. 232 -- 233 -- @ 234 -- 'magnify' :: 'Getter' s a -> (a -> r) -> s -> r 235 -- 'magnify' :: 'Monoid' r => 'Fold' s a -> (a -> r) -> s -> r 236 -- @ 237 -- 238 -- @ 239 -- 'magnify' :: 'Monoid' w => 'Getter' s t -> 'RWS' t w st c -> 'RWS' s w st c 240 -- 'magnify' :: ('Monoid' w, 'Monoid' c) => 'Fold' s a -> 'RWS' a w st c -> 'RWS' s w st c 241 -- ... 242 -- @ 243 magnify :: ((Functor (Magnified m c), Contravariant (Magnified m c)) 244 => LensLike' (Magnified m c) a b) 245 -> m c -> n c 246 247 248instance Monad m => Magnify (ReaderT b m) (ReaderT a m) b a where 249 magnify l (ReaderT m) = ReaderT $ getEffect #. l (Effect #. m) 250 {-# INLINE magnify #-} 251 252-- | @ 253-- 'magnify' = 'views' 254-- @ 255instance Magnify ((->) b) ((->) a) b a where 256 magnify l = views l 257 {-# INLINE magnify #-} 258 259instance (Monad m, Monoid w) => Magnify (Strict.RWST b w s m) (Strict.RWST a w s m) b a where 260 magnify l (Strict.RWST m) = Strict.RWST $ getEffectRWS #. l (EffectRWS #. m) 261 {-# INLINE magnify #-} 262 263instance (Monad m, Monoid w) => Magnify (Lazy.RWST b w s m) (Lazy.RWST a w s m) b a where 264 magnify l (Lazy.RWST m) = Lazy.RWST $ getEffectRWS #. l (EffectRWS #. m) 265 {-# INLINE magnify #-} 266 267instance Magnify m n b a => Magnify (IdentityT m) (IdentityT n) b a where 268 magnify l (IdentityT m) = IdentityT (magnify l m) 269 {-# INLINE magnify #-} 270