Merge pull request #4735 from phadej/types-lens

Add D.Types.PackageId.Lens and D.Types.Lens

Cabal/Cabal.cabal

@@ -290,6 +290,7 @@ library
   -- Lens functionality
   exposed-modules:
     Distribution.Compat.Lens
+    Distribution.Types.Lens
     Distribution.Types.Benchmark.Lens
     Distribution.Types.BuildInfo.Lens
     Distribution.Types.Executable.Lens
@@ -297,6 +298,7 @@ library
     Distribution.Types.GenericPackageDescription.Lens
     Distribution.Types.Library.Lens
     Distribution.Types.PackageDescription.Lens
+    Distribution.Types.PackageId.Lens
     Distribution.Types.SetupBuildInfo.Lens
     Distribution.Types.SourceRepo.Lens
     Distribution.Types.TestSuite.Lens

Cabal/Distribution/Compat/Lens.hs

@@ -11,6 +11,7 @@ module Distribution.Compat.Lens (
     Traversal',
     -- ** LensLike
     LensLike,
+    LensLike',
     -- ** rank-1 types
     Getting,
     AGetter,
@@ -26,8 +27,13 @@ module Distribution.Compat.Lens (
     toDListOf,
     toListOf,
     toSetOf,
+    -- * Lens
+    cloneLens,
+    aview,
     -- * Common lenses
     _1, _2,
+    non,
+    fromNon,
     -- * Operators
     (&),
     (^.), (.~), (%~),
@@ -52,7 +58,8 @@ import qualified Data.Set as Set
 -- Types
 -------------------------------------------------------------------------------
 
-type LensLike f s t a b = (a -> f b) -> s -> f t
+type LensLike  f s t a b = (a -> f b) -> s -> f t
+type LensLike' f s   a   = (a -> f a) -> s -> f s
 
 type Lens      s t a b = forall f. Functor f     => LensLike f s t a b
 type Traversal s t a b = forall f. Applicative f => LensLike f s t a b
@@ -72,8 +79,8 @@ type ALens' s a = ALens s s a a
 -- Getter
 -------------------------------------------------------------------------------
 
-view :: s -> Getting a s a -> a
-view s l = getConst (l Const s)
+view :: Getting a s a -> s ->  a
+view l s = getConst (l Const s)
 
 -------------------------------------------------------------------------------
 -- Setter
@@ -102,6 +109,9 @@ toSetOf l s = getConst (l (\x -> Const (Set.singleton x)) s)
 -- Lens
 -------------------------------------------------------------------------------
 
+aview :: ALens s t a b -> s -> a
+aview l = pretextPos  . l pretextSell
+{-# INLINE aview #-}
 {-
 lens :: (s -> a) -> (s -> a -> s) -> Lens' s a
 lens sa sbt afb s = sbt s <$> afb (sa s)
@@ -117,6 +127,24 @@ _1 f (a, c) = flip (,) c <$> f a
 _2 ::  Lens (c, a) (c, b) a b
 _2 f (c, a) = (,) c <$> f a
 
+-- | /Note:/ not an isomorphism here.
+non :: Eq a => a -> Lens' (Maybe a) a
+non def f s = wrap <$> f (unwrap s)
+  where
+    wrap x | x == def = Nothing
+    wrap x            = Just x
+
+    unwrap = fromMaybe def
+
+
+fromNon :: Eq a =>  a -> Lens' a (Maybe a)
+fromNon def f s = unwrap <$> f (wrap s)
+  where
+    wrap x | x == def = Nothing
+    wrap x            = Just x
+
+    unwrap = fromMaybe def
+
 -------------------------------------------------------------------------------
 -- Operators
 -------------------------------------------------------------------------------
@@ -147,7 +175,7 @@ l ?~ b = set l (Just b)
 {-# INLINE (%~) #-}
 
 (^#) :: s -> ALens s t a b -> a
-s ^# l = pretextPos (l pretextSell s)
+s ^# l = aview l s
 
 (#~) :: ALens s t a b -> b -> s -> t
 (#~) l b s = pretextPeek b (l pretextSell s)
@@ -173,6 +201,10 @@ pretextPos :: Pretext a b t -> a
 pretextPos (Pretext m) = getConst (m Const)
 {-# INLINE pretextPos #-}
 
+cloneLens :: Functor f => ALens s t a b -> LensLike f s t a b
+cloneLens l f s = runPretext (l pretextSell s) f
+{-# INLINE cloneLens #-}
+
 -------------------------------------------------------------------------------
 -- Comonads
 -------------------------------------------------------------------------------

Cabal/Distribution/Types/Executable/Lens.hs

@@ -7,7 +7,6 @@ import Distribution.Compat.Lens
 import Distribution.Compat.Prelude
 import Prelude ()
 
-import Distribution.Types.BuildInfo           (BuildInfo)
 import Distribution.Types.Executable          (Executable)
 import Distribution.Types.ExecutableScope     (ExecutableScope)
 import Distribution.Types.UnqualComponentName (UnqualComponentName)
@@ -26,6 +25,8 @@ exeScope :: Lens' Executable ExecutableScope
 exeScope f s = fmap (\x -> s { T.exeScope = x }) (f (T.exeScope s))
 {-# INLINE exeScope #-}
 
+{-
 buildInfo :: Lens' Executable BuildInfo
 buildInfo f s = fmap (\x -> s { T.buildInfo = x }) (f (T.buildInfo s))
 {-# INLINE buildInfo #-}
+-}

Cabal/Distribution/Types/Lens.hs

+module Distribution.Types.Lens (
+    module Distribution.Types.Benchmark.Lens,
+    module Distribution.Types.BuildInfo.Lens,
+    module Distribution.Types.Executable.Lens,
+    module Distribution.Types.ForeignLib.Lens,
+    module Distribution.Types.GenericPackageDescription.Lens,
+    module Distribution.Types.Library.Lens,
+    module Distribution.Types.PackageDescription.Lens,
+    module Distribution.Types.PackageId.Lens,
+    module Distribution.Types.SetupBuildInfo.Lens,
+    module Distribution.Types.SourceRepo.Lens,
+    module Distribution.Types.TestSuite.Lens,
+    ) where
+
+import Distribution.Types.Benchmark.Lens
+import Distribution.Types.BuildInfo.Lens
+import Distribution.Types.Executable.Lens
+import Distribution.Types.ForeignLib.Lens
+import Distribution.Types.GenericPackageDescription.Lens
+import Distribution.Types.Library.Lens
+import Distribution.Types.PackageDescription.Lens
+import Distribution.Types.PackageId.Lens
+import Distribution.Types.SetupBuildInfo.Lens
+import Distribution.Types.SourceRepo.Lens
+import Distribution.Types.TestSuite.Lens

Cabal/Distribution/Types/PackageId/Lens.hs

+module Distribution.Types.PackageId.Lens (
+    PackageIdentifier,
+    module Distribution.Types.PackageId.Lens,
+    ) where
+
+import Distribution.Compat.Lens
+import Distribution.Compat.Prelude
+import Prelude ()
+
+import Distribution.Types.PackageId   (PackageIdentifier)
+import Distribution.Types.PackageName (PackageName)
+import Distribution.Version           (Version)
+
+import qualified Distribution.Types.PackageId as T
+
+pkgName :: Lens' PackageIdentifier PackageName
+pkgName f s = fmap (\x -> s { T.pkgName = x }) (f (T.pkgName s))
+{-# INLINE pkgName #-}
+
+pkgVersion :: Lens' PackageIdentifier Version
+pkgVersion f s = fmap (\x -> s { T.pkgVersion = x }) (f (T.pkgVersion s))
+{-# INLINE pkgVersion #-}