lens 4.0.4 → 4.0.5
raw patch · 12 files changed
+171/−55 lines, 12 filesdep ~base
Dependency ranges changed: base
Files
- .travis.yml +7/−7
- CHANGELOG.markdown +6/−0
- lens.cabal +1/−1
- src/Control/Lens/At.hs +13/−3
- src/Control/Lens/Empty.hs +2/−2
- src/Control/Lens/Getter.hs +1/−1
- src/Control/Lens/Internal/Exception.hs +2/−1
- src/Control/Lens/Iso.hs +19/−2
- src/Control/Lens/Plated.hs +7/−0
- src/Control/Lens/TH.hs +78/−18
- src/Data/Aeson/Lens.hs +0/−18
- tests/templates.hs +35/−2
.travis.yml view
@@ -3,6 +3,7 @@ env: - GHCVER=7.4.2 - GHCVER=7.6.3+ - GHCVER=7.8.1 - GHCVER=head # - > # GHCVER=7.4.2@@ -26,9 +27,9 @@ export CABAL=cabal else # Install the GHC we want from hvr's PPA- sudo add-apt-repository -y ppa:hvr/ghc- sudo apt-get update- sudo apt-get install cabal-install-1.18 ghc-$GHCVER+ travis_retry sudo add-apt-repository -y ppa:hvr/ghc+ travis_retry sudo apt-get update+ travis_retry sudo apt-get install cabal-install-1.18 ghc-$GHCVER happy export CABAL=cabal-1.18 export PATH=/opt/ghc/$GHCVER/bin:$PATH fi@@ -37,12 +38,11 @@ - $CABAL update # Update happy when building with GHC head- - | - if [ $GHCVER = "head" ]; then- $CABAL install happy+ - |+ if [ $GHCVER = "head" ] || [ $GHCVER = "7.8.1" ]; then+ $CABAL install happy alex export PATH=$HOME/.cabal/bin:$PATH fi- install: - $CABAL install --dependencies-only --enable-tests
CHANGELOG.markdown view
@@ -1,3 +1,9 @@+4.0.5+-----+* Added `bimapping` to `Control.Lens.Iso`+* Restored correct behavior of `makePrism` on types with a single constructor.+* `makeLenses` now generates `Getter`s and `Fold`s on universally quantified fields.+ 4.0.4 ----- * Made `declareFields` work again.
lens.cabal view
@@ -1,6 +1,6 @@ name: lens category: Data, Lenses, Generics-version: 4.0.4+version: 4.0.5 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE
src/Control/Lens/At.hs view
@@ -46,6 +46,7 @@ import Control.Lens.Setter import Control.Lens.Type import Control.Lens.Internal.TupleIxedTH (makeAllTupleIxed)+import Data.Aeson as Aeson import Data.Array.IArray as Array import Data.Array.Unboxed import Data.ByteString as StrictB@@ -90,7 +91,7 @@ type instance Index (IntMap a) = Int type instance Index (Map k a) = k type instance Index (HashMap k a) = k-type instance Index (Array i e) = i+type instance Index (Array.Array i e) = i type instance Index (UArray i e) = i type instance Index (Vector.Vector a) = Int type instance Index (Prim.Vector a) = Int@@ -104,6 +105,7 @@ type instance Index LazyT.Text = Int64 type instance Index StrictB.ByteString = Int type instance Index LazyB.ByteString = Int64+type instance Index Aeson.Value = StrictT.Text -- $setup -- >>> :set -XNoOverloadedStrings@@ -274,13 +276,13 @@ else pure m {-# INLINE ix #-} -type instance IxValue (Array i e) = e+type instance IxValue (Array.Array i e) = e -- | -- @ -- arr '!' i ≡ arr 'Control.Lens.Getter.^.' 'ix' i -- arr '//' [(i,e)] ≡ 'ix' i 'Control.Lens.Setter..~' e '$' arr -- @-instance Ix i => Ixed (Array i e) where+instance Ix i => Ixed (Array.Array i e) where ix i f arr | inRange (bounds arr) i = f (arr Array.! i) <&> \e -> arr Array.// [(i,e)] | otherwise = pure arr@@ -358,6 +360,14 @@ Nothing -> pure s Just (c, xs) -> f c <&> \d -> LazyB.append l (LazyB.cons d xs) {-# INLINE ix #-}+++type instance IxValue Aeson.Value = Aeson.Value+instance Ixed Aeson.Value where+ ix i f (Object o) = Object <$> ix i f o+ ix _ _ v = pure v+ {-# INLINE ix #-}+ -- | 'At' provides a 'Lens' that can be used to read,
src/Control/Lens/Empty.hs view
@@ -38,7 +38,7 @@ import Data.Vector.Unboxed as Unboxed import Data.Vector.Storable as Storable -#ifndef mingw32_HOST_OS+#if !defined(mingw32_HOST_OS) && !defined(ghcjs_HOST_OS) import GHC.Event #endif @@ -59,7 +59,7 @@ instance AsEmpty () instance AsEmpty Any instance AsEmpty All-#ifndef mingw32_HOST_OS+#if !defined(mingw32_HOST_OS) && !defined(ghcjs_HOST_OS) instance AsEmpty Event #endif instance (Eq a, Num a) => AsEmpty (Product a)
src/Control/Lens/Getter.hs view
@@ -432,7 +432,7 @@ iuses l = uses l .# Indexed {-# INLINE iuses #-} --- | View the value pointed to by a 'Getter' or 'Lens'.+-- | View the index and value of an 'IndexedGetter' or 'IndexedLens'. -- -- This is the same operation as 'iview' with the arguments flipped. --
src/Control/Lens/Internal/Exception.hs view
@@ -40,8 +40,9 @@ import Data.Proxy import Data.Typeable +-- This is needed because ghc 7.8-rc2 has Typeable1 as a type alias. #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707-type Typeable1 = Typeable+#define Typeable1 Typeable #endif ------------------------------------------------------------------------------
src/Control/Lens/Iso.hs view
@@ -58,6 +58,8 @@ , dimapping , lmapping , rmapping+ -- * Bifunctors+ , bimapping ) where import Control.Lens.Fold@@ -463,8 +465,8 @@ -- dimapping :: 'Profunctor' p => 'Iso'' s a -> 'Iso'' s' a' -> 'Iso'' (p a s') (p s a') -- @ dimapping :: Profunctor p => AnIso s t a b -> AnIso s' t' a' b' -> Iso (p a s') (p b t') (p s a') (p t b')-dimapping f g = withIso f $ \ s'a' b't' -> withIso g $ \ sa bt ->- iso (dimap s'a' sa) (dimap b't' bt)+dimapping f g = withIso f $ \ sa bt -> withIso g $ \ s'a' b't' ->+ iso (dimap sa s'a') (dimap bt b't') {-# INLINE dimapping #-} -- | Lift an 'Iso' contravariantly into the left argument of a 'Profunctor'.@@ -486,3 +488,18 @@ rmapping :: Profunctor p => AnIso s t a b -> Iso (p x s) (p y t) (p x a) (p y b) rmapping g = withIso g $ \ sa bt -> iso (rmap sa) (rmap bt) {-# INLINE rmapping #-}++------------------------------------------------------------------------------+-- Bifunctor+------------------------------------------------------------------------------++-- | Lift two 'Iso's into both arguments of a 'Bifunctor'.+--+-- @+-- bimapping :: 'Profunctor' p => 'Iso' s t a b -> 'Iso' s' t' a' b' -> 'Iso' (p s s') (p t t') (p a a') (p b b')+-- bimapping :: 'Profunctor' p => 'Iso'' s a -> 'Iso'' s' a' -> 'Iso'' (p s s') (p a a')+-- @+bimapping :: Bifunctor f => AnIso s t a b -> AnIso s' t' a' b' -> Iso (f s s') (f t t') (f a a') (f b b')+bimapping f g = withIso f $ \ sa bt -> withIso g $ \s'a' b't' ->+ iso (bimap sa s'a') (bimap bt b't')+{-# INLINE bimapping #-}
src/Control/Lens/Plated.hs view
@@ -88,6 +88,7 @@ import Control.Lens.Setter import Control.Lens.Traversal import qualified Language.Haskell.TH as TH+import Data.Aeson import Data.Data import Data.Data.Lens import Data.Monoid@@ -203,6 +204,12 @@ instance Plated (Tree a) where plate f (Node a as) = Node a <$> traverse f as++instance Plated Value where+ plate f (Object o) = Object <$> traverse f o+ plate f (Array a) = Array <$> traverse f a+ plate _ xs = pure xs+ {-# INLINE plate #-} {- Default uniplate instances -} instance Plated TH.Exp
src/Control/Lens/TH.hs view
@@ -60,6 +60,7 @@ , buildTraversals , handleSingletons , singletonIso+ , backwardIso , singletonRequired , createClass , createInstance@@ -116,6 +117,7 @@ | BuildTraversals | SingletonAndField | SingletonIso+ | BackwardIso | HandleSingletons | SingletonRequired | CreateClass@@ -154,6 +156,10 @@ singletonIso :: Lens' LensRules Bool singletonIso = lensFlags.contains SingletonIso +-- | When generating an 'Iso' put the field type as the "outer" type.+backwardIso :: Lens' LensRules Bool+backwardIso = lensFlags.contains BackwardIso+ -- | Expect a single constructor, single field newtype or data type. singletonRequired :: Lens' LensRules Bool singletonRequired = lensFlags.contains SingletonRequired@@ -282,6 +288,7 @@ & handleSingletons .~ True & singletonRequired .~ True & singletonAndField .~ True+ & backwardIso .~ True -- | Build lenses (and traversals) with a sensible default configuration. --@@ -588,11 +595,15 @@ makePrismsForCons dataDecl@(DataDecl _ _ _ _ [_]) = case constructors dataDecl of -- Iso promotion via tuples [NormalC dataConName xs] ->- makeIsoLenses isoRules dataDecl dataConName Nothing $ map (view _2) xs+ makeIsoLenses rules dataDecl dataConName Nothing $ map (view _2) xs [RecC dataConName xs] ->- makeIsoLenses isoRules dataDecl dataConName Nothing $ map (view _3) xs+ makeIsoLenses rules dataDecl dataConName Nothing $ map (view _3) xs _ -> fail "makePrismsForCons: A single-constructor data type is required"+ where+ rules = isoRules & lensIso .~ (Just . ('_':))+ & backwardIso .~ False+ makePrismsForCons dataDecl = concat <$> mapM (makePrismOrReviewForCon dataDecl canModifyTypeVar ) (constructors dataDecl) where@@ -826,8 +837,8 @@ m <- freshMap $ setOf typeVars tyArgs let aty = List.foldl' AppT (TupleT $ length partTy) partTy bty = substTypeVars m aty- cty = fullType dataDecl $ map (VarT . view name) tyArgs- dty = substTypeVars m cty+ sty = fullType dataDecl $ map (VarT . view name) tyArgs+ tty = substTypeVars m sty quantified = ForallT (tyArgs ++ substTypeVars m tyArgs) (dataContext dataDecl ++ substTypeVars m (dataContext dataDecl)) maybeIsoName = mkName <$> view lensIso cfg (nameBase dataConName)@@ -839,13 +850,18 @@ makeBody | lensOnly = makeLensBody | otherwise = makeIsoBody isoDecls <- flip (maybe (return [])) maybeIsoName $ \isoName -> do+ let backward = cfg^.backwardIso let decl = SigD isoName $ quantified $- if cfg^.simpleLenses || Map.null m- then isoCon' `apps` [aty,cty]- else isoCon `apps` [aty,bty,cty,dty]+ case (cfg^.simpleLenses || Map.null m, backward) of+ (True , False) -> isoCon' `apps` [sty,aty]+ (False, False) -> isoCon `apps` [sty,tty,aty,bty]+ (True , True ) -> isoCon' `apps` [aty,sty]+ (False, True ) -> isoCon `apps` [aty,bty,sty,tty] (ns, f) <- makeIsoFrom aty dataConName t <- makeIsoTo ns dataConName- body <- makeBody isoName f t+ body <- if backward+ then makeBody isoName f t+ else makeBody isoName t f #ifndef INLINING return $ if cfg^.generateSignatures then [decl, body] else [body] #else@@ -857,8 +873,8 @@ | (jfn /= maybeIsoName) && (isNothing maybeIsoName || cfg^.singletonAndField) -> do let decl = SigD lensName $ quantified $ if cfg^.simpleLenses || Map.null m- then isoCon' `apps` [cty,aty]- else isoCon `apps` [cty,dty,aty,bty]+ then isoCon' `apps` [sty,aty]+ else isoCon `apps` [sty,tty,aty,bty] (ns, f) <- makeIsoFrom aty dataConName t <- makeIsoTo ns dataConName body <- makeBody lensName t f@@ -871,6 +887,45 @@ _ -> return [] return $ isoDecls ++ accessorDecls +makeFieldGetterBody :: Bool -> Name -> [(Con, [Name])] -> Maybe Name -> Q Dec+makeFieldGetterBody isFold lensName conList maybeMethodName+ = case maybeMethodName of+ Just methodName -> do+ go <- newName "go"+ let expr = infixApp (varE methodName) (varE '(Prelude..)) (varE go)+ funD lensName [ clause [] (normalB expr) [funD go clauses] ]+ Nothing -> funD lensName clauses+ where+ clauses = map buildClause conList++ buildClause (con@RecC{}, fields) = do+ f <- newName "_f"+ vars <- for (con^..conNamedFields._1) $ \fld ->+ if fld `List.elem` fields+ then Just <$> newName ('_':(nameBase fld++""))+ else return Nothing+ let cpats = maybe wildP varP <$> vars -- Deconstruction+ fvals = map (appE (varE f) . varE) (catMaybes vars) -- Functor applications+ conName = con^.name++ expr+ | not isFold && length fields /= 1+ = appE (varE 'error) . litE . stringL+ $ show lensName ++ ": expected a single matching field in " ++ show conName ++ ", found " ++ show (length fields)+ | List.null fields+ = [| coerce (pure ()) |]+ | otherwise+ = let add x y = [| $x *> $y |]+ in [| coerce $(List.foldl1 add fvals) |]+ clause [varP f, conP conName cpats] (normalB expr) []++ -- Non-record are never the target of a generated field lens body+ buildClause (con, _fields) =+ -- clause: _ c@Con{} = expr+ -- expr: pure c+ clause [wildP, recP (con^.name) []] (normalB [| coerce (pure ()) |]) []++ makeFieldLensBody :: Bool -> Name -> [(Con, [Name])] -> Maybe Name -> Q Dec makeFieldLensBody isTraversal lensName conList maybeMethodName = case maybeMethodName of Just methodName -> do@@ -991,15 +1046,20 @@ else "The following constructors failed this criterion for the " ++ pprint lensName ++ " lens:" ] ++ map showCon conList - let decl = SigD lensName $ ForallT tvs' qs vars- where- vars- | aty == bty && cty == dty || cfg^.simpleLenses || isJust maybeClassName- = apps (ConT (if isTraversal then ''Traversal' else ''Lens')) [aty,cty]- | otherwise- = apps (ConT (if isTraversal then ''Traversal else ''Lens)) [aty,bty,cty,dty]+ let decl = SigD lensName+ $ case cty of+ ForallT innerTys innerCxt cty' ->+ ForallT (tvs'++innerTys) (qs++innerCxt)+ $ apps (ConT (if isTraversal then ''Fold else ''Getter)) [aty,cty']+ _ ->+ ForallT tvs' qs+ $ if aty == bty && cty == dty || cfg^.simpleLenses || isJust maybeClassName+ then apps (ConT (if isTraversal then ''Traversal' else ''Lens')) [aty,cty]+ else apps (ConT (if isTraversal then ''Traversal else ''Lens)) [aty,bty,cty,dty] - body <- makeFieldLensBody isTraversal lensName conList maybeMethodName+ body <- case cty of+ ForallT {} -> makeFieldGetterBody isTraversal lensName conList maybeMethodName+ _ -> makeFieldLensBody isTraversal lensName conList maybeMethodName #ifndef INLINING return $ if cfg^.generateSignatures then [decl, body] else [body] #else
src/Data/Aeson/Lens.hs view
@@ -34,7 +34,6 @@ , AsJSON(..) ) where -import Control.Applicative import Control.Lens import Data.Aeson import Data.Scientific@@ -329,20 +328,3 @@ Success y -> Right y; _ -> Left x {-# INLINE _JSON #-}----------------------------------------------------------------------------------- Orphan instances---------------------------------------------------------------------------------type instance Index Value = Text-type instance IxValue Value = Value--instance Ixed Value where- ix i = _Object.ix i- {-# INLINE ix #-}--instance Plated Value where- plate f (Object o) = Object <$> traverse f o- plate f (Array a) = Array <$> traverse f a- plate _ xs = pure xs- {-# INLINE plate #-}
tests/templates.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Rank2Types #-} {-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- |@@ -22,6 +23,7 @@ module Main where import Control.Lens+import Data.List (nub) -- import Test.QuickCheck (quickCheck) data Bar a b c = Bar { _baz :: (a, b) }@@ -150,10 +152,13 @@ data Banana = Banana Int String |] -- data Banana = Banana Int String--- banana :: Iso' (Int, String) Banana+-- _Banana :: Iso' Banana (Int, String) cavendish :: Banana-cavendish = view banana (4, "Cavendish")+cavendish = _Banana # (4, "Cavendish") +banana :: Iso' (Int, String) Banana+banana = from _Banana+ data family Family a b c #if __GLASGOW_HASKELL >= 706@@ -178,6 +183,34 @@ -- data Associated Int = AssociatedInt Double -- method = id -- mochi :: Iso' (Associated Int) Double++declareFields [d|+ data DeclaredFields f a+ = DeclaredField1 { declaredFieldsA :: f a , declaredFieldsB :: Int }+ | DeclaredField2 { declaredFieldsC :: String , declaredFieldsB :: Int }+ deriving (Show)+ |]++declaredFieldsUse1 :: [Bool]+declaredFieldsUse1 = view fieldsA (DeclaredField1 [True] 0)++declaredFieldsUse2 :: [DeclaredFields [] ()]+declaredFieldsUse2 = over (traverse.fieldsB) (+1) [DeclaredField1 [()] 0, DeclaredField2 "" 1]++data Rank2Tests+ = C1 { _r2length :: forall a. [a] -> Int+ , _r2nub :: forall a. Eq a=> [a] -> [a]+ }+ | C2 { _r2length :: forall a. [a] -> Int }++makeLenses ''Rank2Tests++useFold1 :: Maybe [Bool]+useFold1 = C1 length nub ^? r2nub . to ($ [False,True,True])+useFold2 :: Maybe [Bool]+useFold2 = C2 length ^? r2nub . to ($ [False,True,True])+useLength :: Int+useLength = C1 length nub ^. r2length . to ($ [False,True,True]) main :: IO () main = putStrLn "test/templates.hs: ok"