1-- | EXPERIMENTAL
2module Optics.View where
3
4import Control.Monad.Reader.Class
5import Control.Monad.State
6import Control.Monad.Writer
7import Data.Kind
8
9import Optics.Core
10
11-- | Generalized view (even more powerful than @view@ from the lens library).
12--
13-- View the value(s) pointed to by an optic.
14--
15-- The type of the result depends on the optic. You get:
16--
17--   * Exactly one result @a@ with 'Iso', 'Lens', 'ReversedPrism' and
18--   'Getter'.
19--
20--   * At most one result @Maybe a@ with 'Prism', 'AffineTraversal' and
21--   'AffineFold'.
22--
23--   * Monoidal summary of all results @Monoid a => a@ with 'Traversal'
24--   and 'Fold'.
25--
26-- When in doubt, use specific, flavour restricted versions. This function is
27-- mostly useful for things such as 'Optics.Passthrough.passthrough'.
28--
29class ViewableOptic k r where
30  type ViewResult k r :: Type
31  gview
32    :: MonadReader s m
33    => Optic' k is s r
34    -> m (ViewResult k r)
35  gviews
36    :: MonadReader s m
37    => Optic' k is s a
38    -> (a -> r)
39    -> m (ViewResult k r)
40
41instance ViewableOptic An_Iso r where
42  type ViewResult An_Iso r = r
43  gview    = asks . view
44  gviews o = asks . views o
45  {-# INLINE gview #-}
46  {-# INLINE gviews #-}
47
48instance ViewableOptic A_Lens r where
49  type ViewResult A_Lens r = r
50  gview    = asks . view
51  gviews o = asks . views o
52  {-# INLINE gview #-}
53  {-# INLINE gviews #-}
54
55instance ViewableOptic A_ReversedPrism r where
56  type ViewResult A_ReversedPrism r = r
57  gview    = asks . view
58  gviews o = asks . views o
59  {-# INLINE gview #-}
60  {-# INLINE gviews #-}
61
62instance ViewableOptic A_Getter r where
63  type ViewResult A_Getter r = r
64  gview    = asks . view
65  gviews o = asks . views o
66  {-# INLINE gview #-}
67  {-# INLINE gviews #-}
68
69instance ViewableOptic A_Prism r where
70  type ViewResult A_Prism r = Maybe r
71  gview    = asks . preview
72  gviews o = asks . previews o
73  {-# INLINE gview #-}
74  {-# INLINE gviews #-}
75
76instance ViewableOptic An_AffineTraversal r where
77  type ViewResult An_AffineTraversal r = Maybe r
78  gview    = asks . preview
79  gviews o = asks . previews o
80  {-# INLINE gview #-}
81  {-# INLINE gviews #-}
82
83instance ViewableOptic An_AffineFold r where
84  type ViewResult An_AffineFold r = Maybe r
85  gview    = asks . preview
86  gviews o = asks . previews o
87  {-# INLINE gview #-}
88  {-# INLINE gviews #-}
89
90instance Monoid r => ViewableOptic A_Traversal r where
91  type ViewResult A_Traversal r = r
92  gview    = asks . foldOf
93  gviews o = asks . foldMapOf o
94  {-# INLINE gview #-}
95  {-# INLINE gviews #-}
96
97instance Monoid r => ViewableOptic A_Fold r where
98  type ViewResult A_Fold r = r
99  gview    = asks . foldOf
100  gviews o = asks . foldMapOf o
101  {-# INLINE gview #-}
102  {-# INLINE gviews #-}
103
104-- | Use the target of a 'Lens', 'Iso', or 'Getter' in the current state, or use
105-- a summary of a 'Fold' or 'Traversal' that points to a monoidal value.
106--
107-- >>> evalState (guse _1) ('a','b')
108-- 'a'
109--
110-- >>> evalState (guse _2) ("hello","world")
111-- "world"
112--
113-- @since 0.2
114guse
115  :: (ViewableOptic k a, MonadState s m)
116  => Optic' k is s a
117  -> m (ViewResult k a)
118guse o = gets (gview o)
119{-# INLINE guse #-}
120
121-- | Use the target of a 'Lens', 'Iso' or 'Getter' in the current state, or use
122-- a summary of a 'Fold' or 'Traversal' that points to a monoidal value.
123--
124-- >>> evalState (guses _1 length) ("hello","world")
125-- 5
126--
127-- @since 0.2
128guses
129  :: (ViewableOptic k r, MonadState s m)
130  => Optic' k is s a
131  -> (a -> r)
132  -> m (ViewResult k r)
133guses o f = gets (gviews o f)
134{-# INLINE guses #-}
135
136-- | This is a generalized form of 'listen' that only extracts the portion of
137-- the log that is focused on by a 'Getter'. If given a 'Fold' or a 'Traversal'
138-- then a monoidal summary of the parts of the log that are visited will be
139-- returned.
140--
141-- @since 0.2
142glistening
143  :: (ViewableOptic k r, MonadWriter s m)
144  => Optic' k is s r
145  -> m a
146  -> m (a, ViewResult k r)
147glistening o m = do
148  (a, w) <- listen m
149  return (a, gview o w)
150{-# INLINE glistening #-}
151
152-- | This is a generalized form of 'listen' that only extracts the portion of
153-- the log that is focused on by a 'Getter'. If given a 'Fold' or a 'Traversal'
154-- then a monoidal summary of the parts of the log that are visited will be
155-- returned.
156--
157-- @since 0.2
158glistenings
159  :: (ViewableOptic k r, MonadWriter s m)
160  => Optic' k is s a
161  -> (a -> r)
162  -> m b
163  -> m (b, ViewResult k r)
164glistenings o f m = do
165  (a, w) <- listen m
166  return (a, gviews o f w)
167{-# INLINE glistenings #-}
168