|
| 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. |
| 6 | +module Distribution.Compat.Lens ( |
| 7 | + -- * Types |
| 8 | + Lens, |
| 9 | + Lens', |
| 10 | + Traversal, |
| 11 | + Traversal', |
| 12 | + -- ** rank-1 types |
| 13 | + Getting, |
| 14 | + ASetter, |
| 15 | + -- * Getter |
| 16 | + view, |
| 17 | + -- * Setter |
| 18 | + set, |
| 19 | + over, |
| 20 | + -- * Fold |
| 21 | + toDListOf, |
| 22 | + toListOf, |
| 23 | + toSetOf, |
| 24 | + -- * Common lenses |
| 25 | + _1, _2, |
| 26 | + -- * Operators |
| 27 | + (&), |
| 28 | + (.~), (%~), |
| 29 | + (?~), |
| 30 | + -- * Cabal developer info |
| 31 | + -- $development |
| 32 | + ) where |
| 33 | + |
| 34 | +import Prelude() |
| 35 | +import Distribution.Compat.Prelude |
| 36 | + |
| 37 | +import Control.Applicative (Const (..)) |
| 38 | +import Data.Functor.Identity (Identity (..)) |
| 39 | + |
| 40 | +import qualified Distribution.Compat.DList as DList |
| 41 | +import qualified Data.Set as Set |
| 42 | + |
| 43 | +------------------------------------------------------------------------------- |
| 44 | +-- Types |
| 45 | +------------------------------------------------------------------------------- |
| 46 | + |
| 47 | +type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t |
| 48 | +type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t |
| 49 | + |
| 50 | +type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s |
| 51 | +type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s |
| 52 | + |
| 53 | +type Getting r s a = (a -> Const r a) -> s -> Const r s |
| 54 | +type ASetter s t a b = (a -> Identity b) -> s -> Identity t |
| 55 | + |
| 56 | +------------------------------------------------------------------------------- |
| 57 | +-- Getter |
| 58 | +------------------------------------------------------------------------------- |
| 59 | + |
| 60 | +view :: s -> Getting a s a -> a |
| 61 | +view s l = getConst (l Const s) |
| 62 | + |
| 63 | +------------------------------------------------------------------------------- |
| 64 | +-- Setter |
| 65 | +------------------------------------------------------------------------------- |
| 66 | + |
| 67 | +set :: ASetter s t a b -> b -> s -> t |
| 68 | +set l x = over l (const x) |
| 69 | + |
| 70 | +over :: ASetter s t a b -> (a -> b) -> s -> t |
| 71 | +over l f s = runIdentity (l (\x -> Identity (f x)) s) |
| 72 | + |
| 73 | +------------------------------------------------------------------------------- |
| 74 | +-- Fold |
| 75 | +------------------------------------------------------------------------------- |
| 76 | + |
| 77 | +toDListOf :: Getting (DList.DList a) s a -> s -> DList.DList a |
| 78 | +toDListOf l s = getConst (l (\x -> Const (DList.singleton x)) s) |
| 79 | + |
| 80 | +toListOf :: Getting (DList.DList a) s a -> s -> [a] |
| 81 | +toListOf l = DList.runDList . toDListOf l |
| 82 | + |
| 83 | +toSetOf :: Getting (Set.Set a) s a -> s -> Set.Set a |
| 84 | +toSetOf l s = getConst (l (\x -> Const (Set.singleton x)) s) |
| 85 | + |
| 86 | +------------------------------------------------------------------------------- |
| 87 | +-- Lens |
| 88 | +------------------------------------------------------------------------------- |
| 89 | + |
| 90 | +{- |
| 91 | +lens :: (s -> a) -> (s -> a -> s) -> Lens' s a |
| 92 | +lens sa sbt afb s = sbt s <$> afb (sa s) |
| 93 | +-} |
| 94 | + |
| 95 | +------------------------------------------------------------------------------- |
| 96 | +-- Common |
| 97 | +------------------------------------------------------------------------------- |
| 98 | + |
| 99 | +_1 :: Lens (a, c) (b, c) a b |
| 100 | +_1 f (a, c) = flip (,) c <$> f a |
| 101 | + |
| 102 | +_2 :: Lens (c, a) (c, b) a b |
| 103 | +_2 f (c, a) = (,) c <$> f a |
| 104 | + |
| 105 | +------------------------------------------------------------------------------- |
| 106 | +-- Operators |
| 107 | +------------------------------------------------------------------------------- |
| 108 | + |
| 109 | + |
| 110 | +-- | '&' is a reverse application operator |
| 111 | +(&) :: a -> (a -> b) -> b |
| 112 | +(&) = flip ($) |
| 113 | +{-# INLINE (&) #-} |
| 114 | +infixl 1 & |
| 115 | + |
| 116 | +infixr 4 .~, %~, ?~ |
| 117 | + |
| 118 | +(.~) :: ASetter s t a b -> b -> s -> t |
| 119 | +(.~) = set |
| 120 | +{-# INLINE (.~) #-} |
| 121 | + |
| 122 | +(?~) :: ASetter s t a (Maybe b) -> b -> s -> t |
| 123 | +l ?~ b = set l (Just b) |
| 124 | +{-# INLINE (?~) #-} |
| 125 | + |
| 126 | +(%~) :: ASetter s t a b -> (a -> b) -> s -> t |
| 127 | +(%~) = over |
| 128 | +{-# INLINE (%~) #-} |
| 129 | + |
| 130 | +------------------------------------------------------------------------------- |
| 131 | +-- Documentation |
| 132 | +------------------------------------------------------------------------------- |
| 133 | + |
| 134 | +-- $development |
| 135 | +-- |
| 136 | +-- We cannot depend on @template-haskell@, because Cabal is a boot library. |
| 137 | +-- This fact makes defining optics a manual task. Here is a small recipe to |
| 138 | +-- make the process less tedious. |
| 139 | +-- |
| 140 | +-- First start a repl with proper-lens dependency |
| 141 | +-- |
| 142 | +-- > cabal new-repl Cabal:lib:Cabal ??? |
| 143 | +-- |
| 144 | +-- or |
| 145 | +-- |
| 146 | +-- > stack ghci Cabal:lib --package lens |
| 147 | +-- |
| 148 | +-- Then enable Template Haskell and the dumping of splices: |
| 149 | +-- |
| 150 | +-- > :set -XTemplateHaskell -ddump-slices |
| 151 | +-- |
| 152 | +-- Now we can derive lenses, load appropriate modules: |
| 153 | +-- |
| 154 | +-- > :m Control.Lens Distribution.PackageDescription |
| 155 | +-- |
| 156 | +-- and let Template Haskell do the job: |
| 157 | +-- |
| 158 | +-- > ; makeLensesWith (lensRules & lensField .~ mappingNamer return) ''GenericPackageDescription |
| 159 | +-- |
| 160 | +-- At this point, we will get unfancy splices looking like |
| 161 | +-- |
| 162 | +-- @ |
| 163 | +-- condBenchmarks :: |
| 164 | +-- 'Lens'' GenericPackageDescription [(UnqualComponentName, |
| 165 | +-- CondTree ConfVar [Dependency] Benchmark)] |
| 166 | +-- condBenchmarks |
| 167 | +-- f_a2UEg |
| 168 | +-- (GenericPackageDescription x1_a2UEh |
| 169 | +-- x2_a2UEi |
| 170 | +-- x3_a2UEj |
| 171 | +-- x4_a2UEk |
| 172 | +-- x5_a2UEl |
| 173 | +-- x6_a2UEm |
| 174 | +-- x7_a2UEn |
| 175 | +-- x8_a2UEo) |
| 176 | +-- = fmap |
| 177 | +-- (\\ y1_a2UEp |
| 178 | +-- -> GenericPackageDescription |
| 179 | +-- x1_a2UEh |
| 180 | +-- x2_a2UEi |
| 181 | +-- x3_a2UEj |
| 182 | +-- x4_a2UEk |
| 183 | +-- x5_a2UEl |
| 184 | +-- x6_a2UEm |
| 185 | +-- x7_a2UEn |
| 186 | +-- y1_a2UEp) |
| 187 | +-- (f_a2UEg x8_a2UEo) |
| 188 | +-- {-\# INLINE condBenchmarks \#-} |
| 189 | +-- @ |
| 190 | +-- |
| 191 | +-- yet they can be cleaned up with e.g. VIM magic regexp and @hindent@: |
| 192 | +-- |
| 193 | +-- > :%s/\v(\w+)_\w+/\1/g |
| 194 | +-- > :%!hindent --indent-size 4 --line-length 200 |
| 195 | +-- |
| 196 | +-- Resulting into |
| 197 | +-- |
| 198 | +-- @ |
| 199 | +-- condBenchmarks :: 'Lens'' GenericPackageDescription [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] |
| 200 | +-- condBenchmarks f (GenericPackageDescription x1 x2 x3 x4 x5 x6 x7 x8) = |
| 201 | +-- fmap (\\y1 -> GenericPackageDescription x1 x2 x3 x4 x5 x6 x7 y1) (f x8) |
| 202 | +-- {-\# INLINE condBenchmarks \#-} |
| 203 | +-- @ |
0 commit comments