1{-# LANGUAGE CPP #-} 2{-# LANGUAGE MultiParamTypeClasses #-} 3{-# LANGUAGE FunctionalDependencies #-} 4{-# LANGUAGE FlexibleContexts #-} 5{-# LANGUAGE FlexibleInstances #-} 6{-# LANGUAGE UndecidableInstances #-} 7{-# LANGUAGE ScopedTypeVariables #-} 8{-# LANGUAGE RankNTypes #-} 9{-# LANGUAGE TypeFamilies #-} 10{-# LANGUAGE KindSignatures #-} 11{-# LANGUAGE Trustworthy #-} 12 13-- This is needed because ErrorT is deprecated. 14{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} 15 16 17{- | 18Module : Lens.Micro.Mtl.Internal 19Copyright : (C) 2013-2016 Edward Kmett, 2015-2016 Artyom Kazak, 2018 Monadfix 20License : BSD-style (see the file LICENSE) 21 22This module lets you define your own instances of 'Zoom' and 'Magnify'. 23 24The warning from "Lens.Micro.Internal" applies to this module as well. Don't export functions that have 'Zoom' or 'Magnify' in their type signatures. If you absolutely need to define an instance (e.g. for internal use), only do it for your own types, because otherwise I might add an instance to one of the microlens packages later and if our instances are different it might lead to subtle bugs. 25-} 26module Lens.Micro.Mtl.Internal 27( 28 -- * Classes 29 Zoomed, 30 Zoom(..), 31 Magnified, 32 Magnify(..), 33 34 -- * Focusing (used for 'Zoom') 35 Focusing(..), 36 FocusingWith(..), 37 FocusingPlus(..), 38 FocusingOn(..), 39 FocusingMay(..), 40 FocusingErr(..), 41 42 -- * Effect (used for 'Magnify') 43 Effect(..), 44 EffectRWS(..), 45 46 -- * Utilities 47 May(..), 48 Err(..), 49) 50where 51 52 53import Control.Applicative 54import Control.Monad.Reader as Reader 55import Control.Monad.State as State 56import Control.Monad.Trans.State.Lazy as Lazy 57import Control.Monad.Trans.State.Strict as Strict 58import Control.Monad.Trans.Writer.Lazy as Lazy 59import Control.Monad.Trans.Writer.Strict as Strict 60import Control.Monad.Trans.RWS.Lazy as Lazy 61import Control.Monad.Trans.RWS.Strict as Strict 62import Control.Monad.Trans.Error 63import Control.Monad.Trans.Except 64import Control.Monad.Trans.List 65import Control.Monad.Trans.Identity 66import Control.Monad.Trans.Maybe 67-- microlens 68import Lens.Micro 69import Lens.Micro.Internal 70 71#if __GLASGOW_HASKELL__ < 710 72import Data.Monoid 73#endif 74 75 76------------------------------------------------------------------------------ 77-- Zoomed 78------------------------------------------------------------------------------ 79 80-- | This type family is used by 'Zoom' to describe the common effect type. 81type family Zoomed (m :: * -> *) :: * -> * -> * 82type instance Zoomed (Strict.StateT s z) = Focusing z 83type instance Zoomed (Lazy.StateT s z) = Focusing z 84type instance Zoomed (ReaderT e m) = Zoomed m 85type instance Zoomed (IdentityT m) = Zoomed m 86type instance Zoomed (Strict.RWST r w s z) = FocusingWith w z 87type instance Zoomed (Lazy.RWST r w s z) = FocusingWith w z 88type instance Zoomed (Strict.WriterT w m) = FocusingPlus w (Zoomed m) 89type instance Zoomed (Lazy.WriterT w m) = FocusingPlus w (Zoomed m) 90type instance Zoomed (ListT m) = FocusingOn [] (Zoomed m) 91type instance Zoomed (MaybeT m) = FocusingMay (Zoomed m) 92type instance Zoomed (ErrorT e m) = FocusingErr e (Zoomed m) 93type instance Zoomed (ExceptT e m) = FocusingErr e (Zoomed m) 94 95------------------------------------------------------------------------------ 96-- Focusing 97------------------------------------------------------------------------------ 98 99-- | Used by 'Zoom' to 'zoom' into 'Control.Monad.State.StateT'. 100newtype Focusing m s a = Focusing { unfocusing :: m (s, a) } 101 102instance Monad m => Functor (Focusing m s) where 103 fmap f (Focusing m) = Focusing $ do 104 (s, a) <- m 105 return (s, f a) 106 {-# INLINE fmap #-} 107 108instance (Monad m, Monoid s) => Applicative (Focusing m s) where 109 pure a = Focusing (return (mempty, a)) 110 {-# INLINE pure #-} 111 Focusing mf <*> Focusing ma = Focusing $ do 112 (s, f) <- mf 113 (s', a) <- ma 114 return (mappend s s', f a) 115 {-# INLINE (<*>) #-} 116 117------------------------------------------------------------------------------ 118-- FocusingWith 119------------------------------------------------------------------------------ 120 121-- | Used by 'Zoom' to 'zoom' into 'Control.Monad.RWS.RWST'. 122newtype FocusingWith w m s a = FocusingWith { unfocusingWith :: m (s, a, w) } 123 124instance Monad m => Functor (FocusingWith w m s) where 125 fmap f (FocusingWith m) = FocusingWith $ do 126 (s, a, w) <- m 127 return (s, f a, w) 128 {-# INLINE fmap #-} 129 130instance (Monad m, Monoid s, Monoid w) => Applicative (FocusingWith w m s) where 131 pure a = FocusingWith (return (mempty, a, mempty)) 132 {-# INLINE pure #-} 133 FocusingWith mf <*> FocusingWith ma = FocusingWith $ do 134 (s, f, w) <- mf 135 (s', a, w') <- ma 136 return (mappend s s', f a, mappend w w') 137 {-# INLINE (<*>) #-} 138 139------------------------------------------------------------------------------ 140-- FocusingPlus 141------------------------------------------------------------------------------ 142 143-- | Used by 'Zoom' to 'zoom' into 'Control.Monad.Writer.WriterT'. 144newtype FocusingPlus w k s a = FocusingPlus { unfocusingPlus :: k (s, w) a } 145 146instance Functor (k (s, w)) => Functor (FocusingPlus w k s) where 147 fmap f (FocusingPlus as) = FocusingPlus (fmap f as) 148 {-# INLINE fmap #-} 149 150instance Applicative (k (s, w)) => Applicative (FocusingPlus w k s) where 151 pure = FocusingPlus . pure 152 {-# INLINE pure #-} 153 FocusingPlus kf <*> FocusingPlus ka = FocusingPlus (kf <*> ka) 154 {-# INLINE (<*>) #-} 155 156------------------------------------------------------------------------------ 157-- FocusingOn 158------------------------------------------------------------------------------ 159 160-- | Used by 'Zoom' to 'zoom' into 'Control.Monad.Trans.Maybe.MaybeT' or 'Control.Monad.Trans.List.ListT'. 161newtype FocusingOn f k s a = FocusingOn { unfocusingOn :: k (f s) a } 162 163instance Functor (k (f s)) => Functor (FocusingOn f k s) where 164 fmap f (FocusingOn as) = FocusingOn (fmap f as) 165 {-# INLINE fmap #-} 166 167instance Applicative (k (f s)) => Applicative (FocusingOn f k s) where 168 pure = FocusingOn . pure 169 {-# INLINE pure #-} 170 FocusingOn kf <*> FocusingOn ka = FocusingOn (kf <*> ka) 171 {-# INLINE (<*>) #-} 172 173------------------------------------------------------------------------------ 174-- May 175------------------------------------------------------------------------------ 176 177-- | Make a 'Monoid' out of 'Maybe' for error handling. 178newtype May a = May { getMay :: Maybe a } 179 180instance Monoid a => Monoid (May a) where 181 mempty = May (Just mempty) 182 {-# INLINE mempty #-} 183#if !MIN_VERSION_base(4,11,0) 184 May Nothing `mappend` _ = May Nothing 185 _ `mappend` May Nothing = May Nothing 186 May (Just a) `mappend` May (Just b) = May (Just (mappend a b)) 187 {-# INLINE mappend #-} 188#else 189instance Semigroup a => Semigroup (May a) where 190 May Nothing <> _ = May Nothing 191 _ <> May Nothing = May Nothing 192 May (Just a) <> May (Just b) = May (Just (a <> b)) 193 {-# INLINE (<>) #-} 194#endif 195 196------------------------------------------------------------------------------ 197-- FocusingMay 198------------------------------------------------------------------------------ 199 200-- | Used by 'Zoom' to 'zoom' into 'Control.Monad.Error.ErrorT'. 201newtype FocusingMay k s a = FocusingMay { unfocusingMay :: k (May s) a } 202 203instance Functor (k (May s)) => Functor (FocusingMay k s) where 204 fmap f (FocusingMay as) = FocusingMay (fmap f as) 205 {-# INLINE fmap #-} 206 207instance Applicative (k (May s)) => Applicative (FocusingMay k s) where 208 pure = FocusingMay . pure 209 {-# INLINE pure #-} 210 FocusingMay kf <*> FocusingMay ka = FocusingMay (kf <*> ka) 211 {-# INLINE (<*>) #-} 212 213------------------------------------------------------------------------------ 214-- Err 215------------------------------------------------------------------------------ 216 217-- | Make a 'Monoid' out of 'Either' for error handling. 218newtype Err e a = Err { getErr :: Either e a } 219 220instance Monoid a => Monoid (Err e a) where 221 mempty = Err (Right mempty) 222 {-# INLINE mempty #-} 223#if !MIN_VERSION_base(4,11,0) 224 Err (Left e) `mappend` _ = Err (Left e) 225 _ `mappend` Err (Left e) = Err (Left e) 226 Err (Right a) `mappend` Err (Right b) = Err (Right (mappend a b)) 227 {-# INLINE mappend #-} 228#else 229instance Semigroup a => Semigroup (Err e a) where 230 Err (Left e) <> _ = Err (Left e) 231 _ <> Err (Left e) = Err (Left e) 232 Err (Right a) <> Err (Right b) = Err (Right (a <> b)) 233 {-# INLINE (<>) #-} 234#endif 235 236------------------------------------------------------------------------------ 237-- FocusingErr 238------------------------------------------------------------------------------ 239 240-- | Used by 'Zoom' to 'zoom' into 'Control.Monad.Error.ErrorT'. 241newtype FocusingErr e k s a = FocusingErr { unfocusingErr :: k (Err e s) a } 242 243instance Functor (k (Err e s)) => Functor (FocusingErr e k s) where 244 fmap f (FocusingErr as) = FocusingErr (fmap f as) 245 {-# INLINE fmap #-} 246 247instance Applicative (k (Err e s)) => Applicative (FocusingErr e k s) where 248 pure = FocusingErr . pure 249 {-# INLINE pure #-} 250 FocusingErr kf <*> FocusingErr ka = FocusingErr (kf <*> ka) 251 {-# INLINE (<*>) #-} 252 253------------------------------------------------------------------------------ 254-- Zoom 255------------------------------------------------------------------------------ 256 257infixr 2 `zoom` 258 259class (MonadState s m, MonadState t n) => Zoom m n s t | m -> s, n -> t, m t -> n, n s -> m where 260 {- | 261When you're in a state monad, this function lets you operate on a part of your state. For instance, if your state was a record containing a @position@ field, after zooming @position@ would become your whole state (and when you modify it, the bigger structure would be modified as well). 262 263(Your 'Lazy.State' \/ 'Lazy.StateT' or 'Lazy.RWS' \/ 'Lazy.RWST' can be anywhere in the stack, but you can't use 'zoom' with arbitrary 'MonadState' because it doesn't provide any methods to change the type of the state. See <https://github.com/ekmett/lens/issues/316 this issue> for details.) 264 265For the sake of the example, let's define some types first: 266 267@ 268data Position = Position { 269 _x, _y :: Int } 270 271data Player = Player { 272 _position :: Position, 273 ... } 274 275data Game = Game { 276 _player :: Player, 277 _obstacles :: [Position], 278 ... } 279 280concat \<$\> mapM makeLenses [''Position, ''Player, ''Game] 281@ 282 283Now, here's an action that moves the player north-east: 284 285@ 286moveNE :: 'Lazy.State' Game () 287moveNE = do 288 player.position.x 'Lens.Micro.Mtl.+=' 1 289 player.position.y 'Lens.Micro.Mtl.+=' 1 290@ 291 292With 'zoom', you can use @player.position@ to focus just on a part of the state: 293 294@ 295moveNE :: 'Lazy.State' Game () 296moveNE = do 297 'zoom' (player.position) $ do 298 x 'Lens.Micro.Mtl.+=' 1 299 y 'Lens.Micro.Mtl.+=' 1 300@ 301 302You can just as well use it for retrieving things out of the state: 303 304@ 305getCoords :: 'Lazy.State' Game (Int, Int) 306getCoords = 'zoom' (player.position) ((,) '<$>' 'Lens.Micro.Mtl.use' x '<*>' 'Lens.Micro.Mtl.use' y) 307@ 308 309Or more explicitly: 310 311@ 312getCoords = 'zoom' (player.position) $ do 313 x' <- 'Lens.Micro.Mtl.use' x 314 y' <- 'Lens.Micro.Mtl.use' y 315 return (x', y') 316@ 317 318When you pass a traversal to 'zoom', it'll work as a loop. For instance, here we move all obstacles: 319 320@ 321moveObstaclesNE :: 'Lazy.State' Game () 322moveObstaclesNE = do 323 'zoom' (obstacles.'each') $ do 324 x 'Lens.Micro.Mtl.+=' 1 325 y 'Lens.Micro.Mtl.+=' 1 326@ 327 328If the action returns a result, all results would be combined with '<>' – the same way they're combined when '^.' is passed a traversal. In this example, @moveObstaclesNE@ returns a list of old coordinates of obstacles in addition to moving them: 329 330@ 331moveObstaclesNE = do 332 xys <- 'zoom' (obstacles.'each') $ do 333 -- Get old coordinates. 334 x' <- 'Lens.Micro.Mtl.use' x 335 y' <- 'Lens.Micro.Mtl.use' y 336 -- Update them. 337 x 'Lens.Micro.Mtl..=' x' + 1 338 y 'Lens.Micro.Mtl..=' y' + 1 339 -- Return a single-element list with old coordinates. 340 return [(x', y')] 341 ... 342@ 343 344Finally, you might need to write your own instances of 'Zoom' if you use @newtype@d transformers in your monad stack. This can be done as follows: 345 346@ 347import "Lens.Micro.Mtl.Internal" 348 349type instance 'Zoomed' (MyStateT s m) = 'Zoomed' (StateT s m) 350 351instance Monad m =\> 'Zoom' (MyStateT s m) (MyStateT t m) s t where 352 'zoom' l (MyStateT m) = MyStateT ('zoom' l m) 353@ 354 -} 355 zoom :: LensLike' (Zoomed m c) t s -> m c -> n c 356 357instance Monad z => Zoom (Strict.StateT s z) (Strict.StateT t z) s t where 358 zoom l (Strict.StateT m) = Strict.StateT $ unfocusing #. l (Focusing #. m) 359 {-# INLINE zoom #-} 360 361instance Monad z => Zoom (Lazy.StateT s z) (Lazy.StateT t z) s t where 362 zoom l (Lazy.StateT m) = Lazy.StateT $ unfocusing #. l (Focusing #. m) 363 {-# INLINE zoom #-} 364 365instance Zoom m n s t => Zoom (ReaderT e m) (ReaderT e n) s t where 366 zoom l (ReaderT m) = ReaderT (zoom l . m) 367 {-# INLINE zoom #-} 368 369instance Zoom m n s t => Zoom (IdentityT m) (IdentityT n) s t where 370 zoom l (IdentityT m) = IdentityT (zoom l m) 371 {-# INLINE zoom #-} 372 373instance (Monoid w, Monad z) => Zoom (Strict.RWST r w s z) (Strict.RWST r w t z) s t where 374 zoom l (Strict.RWST m) = Strict.RWST $ \r -> unfocusingWith #. l (FocusingWith #. m r) 375 {-# INLINE zoom #-} 376 377instance (Monoid w, Monad z) => Zoom (Lazy.RWST r w s z) (Lazy.RWST r w t z) s t where 378 zoom l (Lazy.RWST m) = Lazy.RWST $ \r -> unfocusingWith #. l (FocusingWith #. m r) 379 {-# INLINE zoom #-} 380 381instance (Monoid w, Zoom m n s t) => Zoom (Strict.WriterT w m) (Strict.WriterT w n) s t where 382 zoom l = Strict.WriterT . zoom (\afb -> unfocusingPlus #. l (FocusingPlus #. afb)) . Strict.runWriterT 383 {-# INLINE zoom #-} 384 385instance (Monoid w, Zoom m n s t) => Zoom (Lazy.WriterT w m) (Lazy.WriterT w n) s t where 386 zoom l = Lazy.WriterT . zoom (\afb -> unfocusingPlus #. l (FocusingPlus #. afb)) . Lazy.runWriterT 387 {-# INLINE zoom #-} 388 389instance Zoom m n s t => Zoom (ListT m) (ListT n) s t where 390 zoom l = ListT . zoom (\afb -> unfocusingOn . l (FocusingOn . afb)) . runListT 391 {-# INLINE zoom #-} 392 393instance Zoom m n s t => Zoom (MaybeT m) (MaybeT n) s t where 394 zoom l = MaybeT . liftM getMay . zoom (\afb -> unfocusingMay #. l (FocusingMay #. afb)) . liftM May . runMaybeT 395 {-# INLINE zoom #-} 396 397instance (Error e, Zoom m n s t) => Zoom (ErrorT e m) (ErrorT e n) s t where 398 zoom l = ErrorT . liftM getErr . zoom (\afb -> unfocusingErr #. l (FocusingErr #. afb)) . liftM Err . runErrorT 399 {-# INLINE zoom #-} 400 401instance Zoom m n s t => Zoom (ExceptT e m) (ExceptT e n) s t where 402 zoom l = ExceptT . liftM getErr . zoom (\afb -> unfocusingErr #. l (FocusingErr #. afb)) . liftM Err . runExceptT 403 {-# INLINE zoom #-} 404 405-- TODO: instance Zoom m m a a => Zoom (ContT r m) (ContT r m) a a where 406 407------------------------------------------------------------------------------ 408-- Magnified 409------------------------------------------------------------------------------ 410 411-- | This type family is used by 'Magnify' to describe the common effect type. 412type family Magnified (m :: * -> *) :: * -> * -> * 413type instance Magnified (ReaderT b m) = Effect m 414type instance Magnified ((->)b) = Const 415type instance Magnified (Strict.RWST a w s m) = EffectRWS w s m 416type instance Magnified (Lazy.RWST a w s m) = EffectRWS w s m 417type instance Magnified (IdentityT m) = Magnified m 418 419------------------------------------------------------------------------------ 420-- Magnify 421------------------------------------------------------------------------------ 422 423infixr 2 `magnify` 424 425class (MonadReader b m, MonadReader a n) => Magnify m n b a | m -> b, n -> a, m a -> n, n b -> m where 426 {- | 427This is an equivalent of 'Reader.local' which lets you apply a getter to your environment instead of merely applying a function (and it also lets you change the type of the environment). 428 429@ 430'Reader.local' :: (r -> r) -> 'Reader.Reader' r a -> 'Reader.Reader' r a 431'magnify' :: Getter r x -> 'Reader.Reader' x a -> 'Reader.Reader' r a 432@ 433 434'magnify' works with 'Reader.Reader' \/ 'Reader.ReaderT', 'Lazy.RWS' \/ 'Lazy.RWST', and @(->)@. 435 436Here's an example of 'magnify' being used to work with a part of a bigger config. First, the types: 437 438@ 439data URL = URL { 440 _protocol :: Maybe String, 441 _path :: String } 442 443data Config = Config { 444 _base :: URL, 445 ... } 446 447makeLenses ''URL 448makeLenses ''Config 449@ 450 451Now, let's define a function which returns the base url: 452 453@ 454getBase :: 'Reader.Reader' Config String 455getBase = do 456 protocol \<- 'Data.Maybe.fromMaybe' \"https\" '<$>' 'Lens.Micro.Mtl.view' (base.protocol) 457 path \<- 'Lens.Micro.Mtl.view' (base.path) 458 return (protocol ++ path) 459@ 460 461With 'magnify', we can factor out @base@: 462 463@ 464getBase = 'magnify' base $ do 465 protocol \<- 'Data.Maybe.fromMaybe' \"https\" '<$>' 'Lens.Micro.Mtl.view' protocol 466 path \<- 'Lens.Micro.Mtl.view' path 467 return (protocol ++ path) 468@ 469 470This concludes the example. 471 472Finally, you should know writing instances of 'Magnify' for your own types can be done as follows: 473 474@ 475import "Lens.Micro.Mtl.Internal" 476 477type instance 'Magnified' (MyReaderT r m) = 'Magnified' (ReaderT r m) 478 479instance Monad m =\> 'Magnify' (MyReaderT r m) (MyReaderT t m) r t where 480 'magnify' l (MyReaderT m) = MyReaderT ('magnify' l m) 481@ 482 -} 483 magnify :: LensLike' (Magnified m c) a b -> m c -> n c 484 485instance Monad m => Magnify (ReaderT b m) (ReaderT a m) b a where 486 magnify l (ReaderT m) = ReaderT $ getEffect #. l (Effect #. m) 487 {-# INLINE magnify #-} 488 489instance Magnify ((->) b) ((->) a) b a where 490 magnify l f = Reader.asks (getConst #. l (Const #. f)) 491 {-# INLINE magnify #-} 492 493instance (Monad m, Monoid w) => Magnify (Strict.RWST b w s m) (Strict.RWST a w s m) b a where 494 magnify l (Strict.RWST m) = Strict.RWST $ getEffectRWS #. l (EffectRWS #. m) 495 {-# INLINE magnify #-} 496 497instance (Monad m, Monoid w) => Magnify (Lazy.RWST b w s m) (Lazy.RWST a w s m) b a where 498 magnify l (Lazy.RWST m) = Lazy.RWST $ getEffectRWS #. l (EffectRWS #. m) 499 {-# INLINE magnify #-} 500 501instance Magnify m n b a => Magnify (IdentityT m) (IdentityT n) b a where 502 magnify l (IdentityT m) = IdentityT (magnify l m) 503 {-# INLINE magnify #-} 504 505----------------------------------------------------------------------------- 506--- Effect 507------------------------------------------------------------------------------- 508 509-- | Wrap a monadic effect with a phantom type argument. 510newtype Effect m r a = Effect { getEffect :: m r } 511-- type role Effect representational nominal phantom 512 513instance Functor (Effect m r) where 514 fmap _ (Effect m) = Effect m 515 {-# INLINE fmap #-} 516 517instance (Monad m, Monoid r) => Monoid (Effect m r a) where 518 mempty = Effect (return mempty) 519 {-# INLINE mempty #-} 520#if !MIN_VERSION_base(4,11,0) 521 Effect ma `mappend` Effect mb = Effect (liftM2 mappend ma mb) 522 {-# INLINE mappend #-} 523#else 524instance (Monad m, Semigroup r) => Semigroup (Effect m r a) where 525 Effect ma <> Effect mb = Effect (liftM2 (<>) ma mb) 526 {-# INLINE (<>) #-} 527#endif 528 529instance (Monad m, Monoid r) => Applicative (Effect m r) where 530 pure _ = Effect (return mempty) 531 {-# INLINE pure #-} 532 Effect ma <*> Effect mb = Effect (liftM2 mappend ma mb) 533 {-# INLINE (<*>) #-} 534 535------------------------------------------------------------------------------ 536-- EffectRWS 537------------------------------------------------------------------------------ 538 539-- | Wrap a monadic effect with a phantom type argument. Used when magnifying 'Control.Monad.RWS.RWST'. 540newtype EffectRWS w st m s a = EffectRWS { getEffectRWS :: st -> m (s,st,w) } 541 542instance Functor (EffectRWS w st m s) where 543 fmap _ (EffectRWS m) = EffectRWS m 544 {-# INLINE fmap #-} 545 546instance (Monoid s, Monoid w, Monad m) => Applicative (EffectRWS w st m s) where 547 pure _ = EffectRWS $ \st -> return (mempty, st, mempty) 548 {-# INLINE pure #-} 549 EffectRWS m <*> EffectRWS n = EffectRWS $ \st -> m st >>= \ (s,t,w) -> n t >>= \ (s',u,w') -> return (mappend s s', u, mappend w w') 550 {-# INLINE (<*>) #-} 551