lens 4.16 → 4.16.1

raw patch · 13 files changed

+170/−56 lines, 13 filesdep ~doctestsetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: doctest

API changes (from Hackage documentation)

Files

• .travis.yml +2/−3
• CHANGELOG.markdown +8/−0
• Setup.lhs +8/−9
• examples/Pong.hs +2/−1
• examples/lens-examples.cabal +1/−1
• lens.cabal +5/−4
• src/Control/Lens/Cons.hs +21/−0
• src/Control/Lens/Internal/FieldTH.hs +14/−1
• src/Control/Lens/Lens.hs +9/−3
• src/Control/Lens/Setter.hs +2/−1
• src/Control/Lens/Traversal.hs +74/−33
• tests/T799.hs +23/−0
• tests/templates.hs +1/−0

@@ -63,14 +63,13 @@     # env: TEST=--disable-tests BENCH=--disable-benchmarks       addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}}     - compiler: "ghc-8.4.1"-      env: GHCHEAD=true-      addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-8.4.1], sources: [hvr-ghc]}}+    # env: TEST=--disable-tests BENCH=--disable-benchmarks+      addons: {apt: {packages: [*apt_packages,cabal-install-2.2,ghc-8.4.1], sources: [hvr-ghc]}}     - compiler: "ghc-head"       env: GHCHEAD=true       addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-head], sources: [hvr-ghc]}}    allow_failures:-    - compiler: "ghc-8.4.1"     - compiler: "ghc-head"  before_install:

@@ -1,3 +1,11 @@+4.6.1 [2018.03.23]+------------------+* Re-export `(<&>)` from `Data.Functor` on `base-4.11` and later.+* Added `Cons` and `Snoc` instances for `Control.Applicative.ZipList`+* Fix a bug in which `makeFields` would generate equality constraints for+  field types involving data families, which are unnecessary.+* Improve the performance of `holesOf`.+ 4.16 [2018.01.28] ----------------- * The `Semigroup` instances for `Traversed` and `Sequenced` are now more

@@ -18,7 +18,7 @@  #if MIN_VERSION_cabal_doctest(1,0,0) -import Distribution.Extra.Doctest ( generateBuildModule )+import Distribution.Extra.Doctest ( doctestsUserHooks )  #else @@ -31,8 +31,8 @@ import Warning () #endif -generateBuildModule :: a -> b -> c -> d -> IO ()-generateBuildModule _ _ _ _ = return ()+doctestsUserHooks :: String -> UserHooks+doctestsUserHooks _ = simpleUserHooks  #endif @@ -44,13 +44,12 @@   destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)  main :: IO ()-main = defaultMainWithHooks simpleUserHooks-  { buildHook = \pkg lbi hooks flags -> do-     generateBuildModule "doctests" flags pkg lbi-     buildHook simpleUserHooks pkg lbi hooks flags-  , postHaddock = \args flags pkg lbi -> do+main = defaultMainWithHooks duh+  { postHaddock = \args flags pkg lbi -> do      copyFiles normal (haddockOutputDir flags pkg) [("images","Hierarchy.png")]-     postHaddock simpleUserHooks args flags pkg lbi+     postHaddock duh args flags pkg lbi   }+  where+    duh = doctestsUserHooks "doctests"  \end{code}

@@ -20,6 +20,7 @@ import Data.Set (Set, member, empty, insert, delete)  import Graphics.Gloss+import qualified Graphics.Gloss.Data.Point.Arithmetic as Pt import Graphics.Gloss.Interface.Pure.Game  import System.Random (randomRs, newStdGen)@@ -100,7 +101,7 @@ updateBall :: Float -> State Pong () updateBall time = do   (u, v) <- use ballSpeed-  ballPos += (time * u, time * v)+  ballPos %= (Pt.+ (time * u, time * v))    -- Make sure it doesn't leave the playing area   ballPos.both %= clamp ballRadius

@@ -32,7 +32,7 @@   build-depends:     base       >= 4.5   && < 5,     containers >= 0.4   && < 0.6,-    gloss      >= 1.7   && < 1.12,+    gloss      >= 1.12  && < 1.13,     lens,     mtl        >= 2.0.1 && < 2.3,     random     >= 1.0   && < 1.2

@@ -1,6 +1,6 @@ name:          lens category:      Data, Lenses, Generics-version:       4.16+version:       4.16.1 license:       BSD2 cabal-version: >= 1.8 license-file:  LICENSE@@ -115,7 +115,7 @@  custom-setup   setup-depends:-    Cabal >= 1.10 && <2.1,+    Cabal >= 1.10 && <2.3,     base  >= 4.5 && <5,     cabal-doctest >= 1 && <1.1,     filepath@@ -207,7 +207,7 @@     semigroupoids             >= 5        && < 6,     semigroups                >= 0.8.4    && < 1,     tagged                    >= 0.4.4    && < 1,-    template-haskell          >= 2.4      && < 2.13,+    template-haskell          >= 2.4      && < 2.14,     th-abstraction            >= 0.2.1    && < 0.3,     text                      >= 0.11     && < 1.3,     transformers              >= 0.2      && < 0.6,@@ -342,6 +342,7 @@ test-suite templates   type: exitcode-stdio-1.0   main-is: templates.hs+  other-modules: T799   ghc-options: -Wall -threaded   hs-source-dirs: tests @@ -415,7 +416,7 @@       containers,       directory      >= 1.0,       deepseq,-      doctest        >= 0.11.4 && < 0.12 || >= 0.13 && < 0.14,+      doctest        >= 0.11.4 && < 0.12 || >= 0.13 && < 0.16,       filepath,       generic-deriving,       lens,

@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ScopedTypeVariables #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif@@ -50,6 +51,7 @@ import Control.Lens.Review import Control.Lens.Tuple import Control.Lens.Type+import Control.Lens.Internal.Coerce import qualified Data.ByteString      as StrictB import qualified Data.ByteString.Lazy as LazyB import           Data.Monoid@@ -66,6 +68,7 @@ import           Data.Vector.Unboxed (Unbox) import qualified Data.Vector.Unboxed as Unbox import           Data.Word+import           Control.Applicative (ZipList(..)) import           Prelude  #ifdef HLINT@@ -121,6 +124,15 @@     []     -> Left  []   {-# INLINE _Cons #-} +instance Cons (ZipList a) (ZipList b) a b where+  _Cons = withPrism listCons $ \listReview listPreview -> +    prism (coerce' listReview) (coerce' listPreview) where++    listCons :: Prism [a] [b] (a, [a]) (b, [b])+    listCons = _Cons++  {-# INLINE _Cons #-}+ instance Cons (Seq a) (Seq b) a b where   _Cons = prism (uncurry (Seq.<|)) $ \aas -> case viewl aas of     a Seq.:< as -> Right (a, as)@@ -344,6 +356,15 @@   _Snoc = prism (\(as,a) -> as Prelude.++ [a]) $ \aas -> if Prelude.null aas     then Left []     else Right (Prelude.init aas, Prelude.last aas)+  {-# INLINE _Snoc #-}++instance Snoc (ZipList a) (ZipList b) a b where+  _Snoc = withPrism listSnoc $ \listReview listPreview -> +    prism (coerce' listReview) (coerce' listPreview) where++    listSnoc :: Prism [a] [b] ([a], a) ([b], b)+    listSnoc = _Snoc+   {-# INLINE _Snoc #-}  instance Snoc (Seq a) (Seq b) a b where

@@ -33,6 +33,7 @@ import Control.Lens.At import Control.Lens.Fold import Control.Lens.Internal.TH+import Control.Lens.Lens import Control.Lens.Plated import Control.Lens.Prism import Control.Lens.Setter@@ -48,6 +49,7 @@ import Data.Maybe (isJust,maybeToList) import Data.List (nub, findIndices) import Data.Either (partitionEithers)+import Data.Semigroup import Data.Set.Lens import           Data.Map ( Map ) import           Data.Set ( Set )@@ -385,8 +387,19 @@    containsTypeFamilies = go <=< D.resolveTypeSynonyms     where-    go (ConT nm) = has _FamilyI <$> reify nm+    go (ConT nm) = has (_FamilyI . _1 . _TypeFamilyD) <$> reify nm     go ty = or <$> traverse go (ty ^.. plate)++    -- We want to catch type families, but not *data* families. See #799.+    _TypeFamilyD :: Getting Any Dec ()+    _TypeFamilyD = _OpenTypeFamilyD.united <> _ClosedTypeFamilyD.united+      where+#if !(MIN_VERSION_template_haskell(2,11,0))+      _OpenTypeFamilyD = _FamilyD . _1 . _TypeFam+#endif+#if !(MIN_VERSION_template_haskell(2,9,0))+      _ClosedTypeFamilyD = ignored+#endif    pickInstanceDec hasFamilies     | hasFamilies = do

@@ -142,9 +142,12 @@ import Data.Profunctor.Unsafe import Data.Void import Prelude-#if __GLASGOW_HASKELL__ >= 710+#if MIN_VERSION_base(4,8,0) import Data.Function ((&)) #endif+#if MIN_VERSION_base(4,11,0)+import Data.Functor ((<&>))+#endif  #ifdef HLINT {-# ANN module "HLint: ignore Use ***" #-}@@ -169,7 +172,7 @@ infix  4 %%@=, <%@=, <<%@=, %%=, <+=, <*=, <-=, <//=, <^=, <^^=, <**=, <&&=, <||=, <<>=, <%=, <<%=, <<.=, <<?=, <#=, #=, #%=, <#%=, #%%=        , <<+=, <<-=, <<*=, <<//=, <<^=, <<^^=, <<**=, <<||=, <<&&=, <<<>= infixr 2 <<~-infixl 1 <&>, ??, &~+infixl 1 ??, &~  ------------------------------------------------------------------------------- -- Lenses@@ -326,7 +329,7 @@ -------------------------------------------------------------------------------  -#if __GLASGOW_HASKELL__ < 710+#if !(MIN_VERSION_base(4,8,0)) -- | Passes the result of the left side to the function on the right side (forward pipe operator). -- -- This is the flipped version of ('$'), which is more common in languages like F# as (@|>@) where it is needed@@ -354,6 +357,7 @@ infixl 1 & #endif +#if !(MIN_VERSION_base(4,11,0)) -- | Infix flipped 'fmap'. -- -- @@@ -362,6 +366,8 @@ (<&>) :: Functor f => f a -> (a -> b) -> f b as <&> f = f <$> as {-# INLINE (<&>) #-}+infixl 1 <&>+#endif  -- | This is convenient to 'flip' argument order of composite functions defined as: --

@@ -196,7 +196,8 @@ -- | This 'setter' can be used to modify all of the values in a 'Monad'. -- -- You sometimes have to use this rather than 'mapped' -- due to--- temporary insanity 'Functor' is not a superclass of 'Monad'.+-- temporary insanity 'Functor' was not a superclass of 'Monad' until+-- GHC 7.10. -- -- @ -- 'liftM' ≡ 'over' 'lifted'

@@ -166,7 +166,6 @@ import Data.Reflection import Data.Semigroup.Traversable import Data.Semigroup.Bitraversable-import Data.Tagged import Data.Traversable import Data.Tuple (swap) import GHC.Magic (inline)@@ -505,7 +504,7 @@ {-# INLINE iloci #-}  ---------------------------------------------------------------------------------- Parts and Holes+-- Parts -------------------------------------------------------------------------------  -- | 'partsOf' turns a 'Traversal' into a 'Lens' that resembles an early version of the 'Data.Data.Lens.uniplate' (or 'Data.Data.Lens.biplate') type.@@ -601,36 +600,6 @@   (\f s -> let b = inline l sell s; (is, as) = unzip (pins b) in unsafeOuts b <$> indexed f (is :: [i]) as) {-# INLINE iunsafePartsOf' #-} --- | The one-level version of 'Control.Lens.Plated.contextsOf'. This extracts a list of the immediate children according to a given 'Traversal' as editable contexts.------ Given a context you can use 'Control.Comonad.Store.Class.pos' to see the values, 'Control.Comonad.Store.Class.peek' at what the structure would be like with an edited result, or simply 'extract' the original structure.------ @--- propChildren l x = 'toListOf' l x '==' 'map' 'Control.Comonad.Store.Class.pos' ('holesOf' l x)--- propId l x = 'all' ('==' x) ['extract' w | w <- 'holesOf' l x]--- @------ @--- 'holesOf' :: 'Iso'' s a                -> s -> ['Pretext'' (->) a s]--- 'holesOf' :: 'Lens'' s a               -> s -> ['Pretext'' (->) a s]--- 'holesOf' :: 'Traversal'' s a          -> s -> ['Pretext'' (->) a s]--- 'holesOf' :: 'IndexedLens'' i s a      -> s -> ['Pretext'' ('Indexed' i) a s]--- 'holesOf' :: 'IndexedTraversal'' i s a -> s -> ['Pretext'' ('Indexed' i) a s]--- @-holesOf :: forall p s t a. Conjoined p => Over p (Bazaar p a a) s t a a -> s -> [Pretext p a a t]-holesOf l s = unTagged-  ( conjoined-     (Tagged $ let-        f [] _ = []-        f (x:xs) g = Pretext (\xfy -> g . (:xs) <$> xfy x) : f xs (g . (x:))-      in f (ins b) (unsafeOuts b))-     (Tagged $ let-        f [] _ = []-        f (wx:xs) g = Pretext (\wxfy -> g . (:Prelude.map extract xs) <$> cosieve wxfy wx) : f xs (g . (extract wx:))-      in f (pins b) (unsafeOuts b))-    :: Tagged (p a b) [Pretext p a a t]-  ) where b = l sell s-{-# INLINE holesOf #-}  -- | This converts a 'Traversal' that you \"know\" will target one or more elements to a 'Lens'. It can -- also be used to transform a non-empty 'Fold' into a 'Getter'.@@ -699,7 +668,7 @@ {-# INLINE unsafeSingular #-}  --------------------------------------------------------------------------------- Internal functions used by 'partsOf', 'holesOf', etc.+-- Internal functions used by 'partsOf', etc. ------------------------------------------------------------------------------  ins :: Bizarre (->) w => w a b t -> [a]@@ -731,6 +700,78 @@ unconsWithDefault d []     = (d,[]) unconsWithDefault _ (x:xs) = (x,xs) {-# INLINE unconsWithDefault #-}+++-------------------------------------------------------------------------------+-- Holes+-------------------------------------------------------------------------------++-- | The one-level version of 'Control.Lens.Plated.contextsOf'. This extracts a+-- list of the immediate children according to a given 'Traversal' as editable+-- contexts.+--+-- Given a context you can use 'Control.Comonad.Store.Class.pos' to see the+-- values, 'Control.Comonad.Store.Class.peek' at what the structure would be+-- like with an edited result, or simply 'extract' the original structure.+--+-- @+-- propChildren l x = 'toListOf' l x '==' 'map' 'Control.Comonad.Store.Class.pos' ('holesOf' l x)+-- propId l x = 'all' ('==' x) ['extract' w | w <- 'holesOf' l x]+-- @+--+-- @+-- 'holesOf' :: 'Iso'' s a                -> s -> ['Pretext'' (->) a s]+-- 'holesOf' :: 'Lens'' s a               -> s -> ['Pretext'' (->) a s]+-- 'holesOf' :: 'Traversal'' s a          -> s -> ['Pretext'' (->) a s]+-- 'holesOf' :: 'IndexedLens'' i s a      -> s -> ['Pretext'' ('Indexed' i) a s]+-- 'holesOf' :: 'IndexedTraversal'' i s a -> s -> ['Pretext'' ('Indexed' i) a s]+-- @+holesOf :: Conjoined p+        => Over p (Bazaar p a a) s t a a -> s -> [Pretext p a a t]+holesOf f xs = flip appEndo [] . fst $+  runHoles (runBazaar (f sell xs) (cotabulate holeInOne)) id+{-# INLINE holesOf #-}++holeInOne :: forall p a t. (Corepresentable p, Category p)+          => Corep p a -> Holes t (Endo [Pretext p a a t]) a+holeInOne x = Holes $ \xt ->+    ( Endo (fmap xt (cosieve sell x) :)+    , cosieve (id :: p a a) x)+{-# INLINABLE holeInOne #-}++-- We are very careful to share as much structure as possible among+-- the results (in the common case where the traversal allows for such).+-- Note in particular the recursive knot in the implementation of <*>+-- for Holes. This sharing magic was inspired by Noah "Rampion" Easterly's+-- implementation of a related holes function: see+-- https://stackoverflow.com/a/49001904/1477667. The Holes type is+-- inspired by Roman Cheplyaka's answer to that same question.++newtype Holes t m x = Holes { runHoles :: (x -> t) -> (m, x) }++instance Functor (Holes t m) where+  fmap f xs = Holes $ \xt ->+    let+      (qf, qv) = runHoles xs (xt . f)+    in (qf, f qv)++instance Monoid m => Applicative (Holes t m) where+  pure x = Holes $ \_ -> (mempty, x)++  fs <*> xs = Holes $ \xt ->+    let+     (pf, pv) = runHoles fs (xt . ($ qv))+     (qf, qv) = runHoles xs (xt . pv)+    in (pf `mappend` qf, pv qv)++#if MIN_VERSION_base(4,10,0)+  liftA2 f xs ys = Holes $ \xt ->+    let+      (pf, pv) = runHoles xs (xt . flip f qv)+      (qf, qv) = runHoles ys (xt . f pv)+    in (pf `mappend` qf, f pv qv)+#endif+  ------------------------------------------------------------------------------ -- Traversals

@@ -0,0 +1,23 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+-- | Test 'makeFields' on a field whose type has a data family. Unlike for+-- type families, for data families we do not generate type equality+-- constraints, as they are not needed to avoid the issue in #754.+--+-- This tests that the fix for #799 is valid by putting this in a module in+-- which UndecidableInstances is not enabled.+module T799 where++import Control.Lens++data family DF a+newtype instance DF Int = FooInt Int++data Bar = Bar { _barFoo :: DF Int }+makeFields ''Bar++checkBarFoo :: Lens' Bar (DF Int)+checkBarFoo = foo

@@ -26,6 +26,7 @@  import Control.Lens -- import Test.QuickCheck (quickCheck)+import T799 ()  data Bar a b c = Bar { _baz :: (a, b) } makeLenses ''Bar