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