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