1{-# LANGUAGE RankNTypes #-}
2-- | This module provides very basic lens functionality, without extra dependencies.
3--
4-- For the documentation of the combinators see <http://hackage.haskell.org/package/lens lens> package.
5-- This module uses the same vocabulary.
6module Distribution.Compat.Lens (
7    -- * Types
8    Lens,
9    Lens',
10    Traversal,
11    Traversal',
12    -- ** LensLike
13    LensLike,
14    LensLike',
15    -- ** rank-1 types
16    Getting,
17    AGetter,
18    ASetter,
19    ALens,
20    ALens',
21    -- * Getter
22    view,
23    use,
24    getting,
25    -- * Setter
26    set,
27    over,
28    -- * Fold
29    toDListOf,
30    toListOf,
31    toSetOf,
32    -- * Lens
33    cloneLens,
34    aview,
35    -- * Common lenses
36    _1, _2,
37    -- * Operators
38    (&),
39    (^.),
40    (.~), (?~), (%~),
41    (.=), (?=), (%=),
42    (^#),
43    (#~), (#%~),
44    -- * Internal Comonads
45    Pretext (..),
46    -- * Cabal developer info
47    -- $development
48    ) where
49
50import Prelude()
51import Distribution.Compat.Prelude
52
53import Control.Monad.State.Class (MonadState (..), gets, modify)
54
55import qualified Distribution.Compat.DList as DList
56import qualified Data.Set as Set
57
58-------------------------------------------------------------------------------
59-- Types
60-------------------------------------------------------------------------------
61
62type LensLike  f s t a b = (a -> f b) -> s -> f t
63type LensLike' f s   a   = (a -> f a) -> s -> f s
64
65type Lens      s t a b = forall f. Functor f     => LensLike f s t a b
66type Traversal s t a b = forall f. Applicative f => LensLike f s t a b
67
68type Lens'      s a = Lens s s a a
69type Traversal' s a = Traversal s s a a
70
71type Getting r s a = LensLike (Const r) s s a a
72
73type AGetter s   a   = LensLike (Const a)     s s a a  -- this doesn't exist in 'lens'
74type ASetter s t a b = LensLike Identity      s t a b
75type ALens   s t a b = LensLike (Pretext a b) s t a b
76
77type ALens' s a = ALens s s a a
78
79-------------------------------------------------------------------------------
80-- Getter
81-------------------------------------------------------------------------------
82
83view :: Getting a s a -> s ->  a
84view l s = getConst (l Const s)
85{-# INLINE view #-}
86
87use :: MonadState s m => Getting a s a -> m a
88use l = gets (view l)
89{-# INLINE use #-}
90
91-- | @since 2.4
92--
93-- >>> (3 :: Int) ^. getting (+2) . getting show
94-- "5"
95getting :: (s -> a) -> Getting r s a
96getting k f = Const . getConst . f . k
97{-# INLINE getting #-}
98
99-------------------------------------------------------------------------------
100-- Setter
101-------------------------------------------------------------------------------
102
103set :: ASetter s t a  b -> b -> s -> t
104set l x = over l (const x)
105
106over :: ASetter s t a b -> (a -> b) -> s -> t
107over l f s = runIdentity (l (\x -> Identity (f x)) s)
108
109-------------------------------------------------------------------------------
110-- Fold
111-------------------------------------------------------------------------------
112
113toDListOf :: Getting (DList.DList a) s a -> s -> DList.DList a
114toDListOf l s = getConst (l (\x -> Const (DList.singleton x)) s)
115
116toListOf :: Getting (DList.DList a) s a -> s -> [a]
117toListOf l = DList.runDList . toDListOf l
118
119toSetOf  :: Getting (Set.Set a) s a -> s -> Set.Set a
120toSetOf l s = getConst (l (\x -> Const (Set.singleton x)) s)
121
122-------------------------------------------------------------------------------
123-- Lens
124-------------------------------------------------------------------------------
125
126aview :: ALens s t a b -> s -> a
127aview l = pretextPos  . l pretextSell
128{-# INLINE aview #-}
129
130{-
131lens :: (s -> a) -> (s -> a -> s) -> Lens' s a
132lens sa sbt afb s = sbt s <$> afb (sa s)
133-}
134
135-------------------------------------------------------------------------------
136-- Common
137-------------------------------------------------------------------------------
138
139_1 ::  Lens (a, c) (b, c) a b
140_1 f (a, c) = flip (,) c <$> f a
141
142_2 ::  Lens (c, a) (c, b) a b
143_2 f (c, a) = (,) c <$> f a
144
145-------------------------------------------------------------------------------
146-- Operators
147-------------------------------------------------------------------------------
148
149-- | '&' is a reverse application operator
150(&) :: a -> (a -> b) -> b
151(&) = flip ($)
152{-# INLINE (&) #-}
153infixl 1 &
154
155infixl 8 ^., ^#
156infixr 4 .~, %~, ?~
157infixr 4 #~, #%~
158infixr 4 .=, %=, ?=
159
160(^.) :: s -> Getting a s a -> a
161s ^. l = getConst (l Const s)
162{-# INLINE (^.) #-}
163
164(.~) :: ASetter s t a b -> b -> s -> t
165(.~) = set
166{-# INLINE (.~) #-}
167
168(?~) :: ASetter s t a (Maybe b) -> b -> s -> t
169l ?~ b = set l (Just b)
170{-# INLINE (?~) #-}
171
172(%~) :: ASetter s t a b -> (a -> b) -> s -> t
173(%~) = over
174{-# INLINE (%~) #-}
175
176(.=) :: MonadState s m => ASetter s s a b -> b -> m ()
177l .= b = modify (l .~ b)
178{-# INLINE (.=) #-}
179
180(?=) :: MonadState s m => ASetter s s a (Maybe b) -> b -> m ()
181l ?= b = modify (l ?~ b)
182{-# INLINE (?=) #-}
183
184(%=) :: MonadState s m => ASetter s s a b -> (a -> b) -> m ()
185l %= f = modify (l %~ f)
186{-# INLINE (%=) #-}
187
188(^#) :: s -> ALens s t a b -> a
189s ^# l = aview l s
190
191(#~) :: ALens s t a b -> b -> s -> t
192(#~) l b s = pretextPeek b (l pretextSell s)
193{-# INLINE (#~) #-}
194
195(#%~) :: ALens s t a b -> (a -> b) -> s -> t
196(#%~) l f s = pretextPeeks f (l pretextSell s)
197{-# INLINE (#%~) #-}
198
199pretextSell :: a -> Pretext a b b
200pretextSell a = Pretext (\afb -> afb a)
201{-# INLINE pretextSell #-}
202
203pretextPeeks :: (a -> b) -> Pretext a b t -> t
204pretextPeeks f (Pretext m) = runIdentity $ m (\x -> Identity (f x))
205{-# INLINE pretextPeeks #-}
206
207pretextPeek :: b -> Pretext a b t -> t
208pretextPeek b (Pretext m) = runIdentity $ m (\_ -> Identity b)
209{-# INLINE pretextPeek #-}
210
211pretextPos :: Pretext a b t -> a
212pretextPos (Pretext m) = getConst (m Const)
213{-# INLINE pretextPos #-}
214
215cloneLens :: Functor f => ALens s t a b -> LensLike f s t a b
216cloneLens l f s = runPretext (l pretextSell s) f
217{-# INLINE cloneLens #-}
218
219-------------------------------------------------------------------------------
220-- Comonads
221-------------------------------------------------------------------------------
222
223-- | @lens@ variant is also parametrised by profunctor.
224data Pretext a b t = Pretext { runPretext :: forall f. Functor f => (a -> f b) -> f t }
225
226instance Functor (Pretext a b) where
227    fmap f (Pretext pretext) = Pretext (\afb -> fmap f (pretext afb))
228
229-------------------------------------------------------------------------------
230-- Documentation
231-------------------------------------------------------------------------------
232
233-- $development
234--
235-- We cannot depend on @template-haskell@, because Cabal is a boot library.
236-- This fact makes defining optics a manual task. Here is a small recipe to
237-- make the process less tedious.
238--
239-- First start a repl
240--
241-- > cabal new-repl Cabal:hackage-tests
242--
243-- Because @--extra-package@ isn't yet implemented, we use a test-suite
244-- with @generics-sop@ dependency.
245--
246-- In the repl, we load a helper script:
247--
248-- > :l ../generics-sop-lens.hs
249--
250-- Now we are set up to derive lenses!
251--
252-- > :m +Distribution.Types.SourceRepo
253-- > putStr $ genericLenses (Proxy :: Proxy SourceRepo)
254--
255-- @
256-- repoKind :: Lens' SourceRepo RepoKind
257-- repoKind f s = fmap (\\x -> s { T.repoKind = x }) (f (T.repoKind s))
258-- \{-# INLINE repoKind #-\}
259-- ...
260-- @
261--
262-- /Note:/ You may need to adjust type-aliases, e.g. `String` to `FilePath`.
263