lens 3.8.1 → 3.8.2
raw patch · 14 files changed
+571/−59 lines, 14 filesdep +reflectiondep ~contravariantdep ~distributive
Dependencies added: reflection
Dependency ranges changed: contravariant, distributive
Files
- .travis.yml +1/−3
- CHANGELOG.markdown +7/−0
- lens.cabal +5/−3
- src/Control/Exception/Lens.hs +31/−1
- src/Control/Lens/Fold.hs +142/−11
- src/Control/Lens/Internal/Exception.hs +179/−0
- src/Control/Lens/Iso.hs +15/−0
- src/Control/Lens/Review.hs +22/−2
- src/Control/Lens/TH.hs +11/−10
- src/Control/Lens/Traversal.hs +31/−10
- src/Control/Monad/Error/Lens.hs +84/−4
- src/Numeric/Lens.hs +3/−3
- tests/templates.hs +17/−0
- travis/cabal-apt-install +23/−12
.travis.yml view
@@ -4,9 +4,7 @@ # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && cabal update # Try installing some of the build-deps with apt-get for speed.- - travis/cabal-apt-install --only-dependencies --force-reinstall $mode-- - sudo apt-get -q -y install hlint || cabal install hlint+ - travis/cabal-apt-install $mode install: - cabal configure -flib-Werror $mode
CHANGELOG.markdown view
@@ -1,3 +1,10 @@+3.8.2+-----+* Added a notion of `Handleable(handler, handler_)` to `Control.Exception.Lens` to facilitate constructing a `Handler` from an arbitrary `Fold` or `Prism`.+* Added a notion of `Handler` and `catches` to and `Control.Monad.Error.Lens` to mirror the `Control.Exception` and `Control.Monad.CatchIO` constructions.+* Added additional doctests and documentation.+* Improved error messages and support for types with arguments in `makeFields`.+ 3.8.1 ----- * Fixed a bug in `makeFields` in hierarchical modules.
lens.cabal view
@@ -1,6 +1,6 @@ name: lens category: Data, Lenses-version: 3.8.1+version: 3.8.2 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE@@ -167,9 +167,9 @@ comonad >= 3 && < 4, comonad-transformers >= 3 && < 4, comonads-fd >= 3 && < 4,- contravariant >= 0.2.0.2,+ contravariant >= 0.2.0.2 && < 1, containers >= 0.4.0 && < 0.6,- distributive >= 0.3,+ distributive >= 0.3 && < 1, filepath >= 1.2.0.0 && < 1.4, generic-deriving == 1.4.*, ghc-prim,@@ -179,6 +179,7 @@ parallel >= 3.1.0.1 && < 3.3, profunctors >= 3.2 && < 4, profunctor-extras >= 3.3 && < 4,+ reflection >= 1.1.6 && < 2, semigroupoids >= 3 && < 4, semigroups >= 0.8.4 && < 1, split == 0.2.*,@@ -208,6 +209,7 @@ Control.Lens.Internal.ByteString Control.Lens.Internal.Context Control.Lens.Internal.Deque+ Control.Lens.Internal.Exception Control.Lens.Internal.Fold Control.Lens.Internal.Getter Control.Lens.Internal.Indexed
src/Control/Exception/Lens.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE NoMonomorphismRestriction #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-}@@ -45,6 +46,8 @@ , throwingTo -- * Exceptions , exception+ -- * Exception Handlers+ , Handleable(..) -- ** IOExceptions , AsIOException(..) -- ** Arithmetic Exceptions@@ -90,6 +93,8 @@ , AsRecUpdError(..) -- ** Error Call , AsErrorCall(..)+ -- * Handling Exceptions+ , AsHandlingException(..) ) where import Control.Applicative@@ -98,12 +103,13 @@ import Control.Monad.CatchIO as CatchIO hiding (try, tryJust) import Control.Exception as Exception hiding (try, tryJust, catchJust) import Control.Lens+import Control.Lens.Internal.Exception import Data.Monoid import GHC.Conc (ThreadId) import Prelude ( asTypeOf, const, either, flip, id, maybe, undefined , ($), (.)- , Maybe(..), Either(..), Functor(..), String+ , Maybe(..), Either(..), Functor(..), String, IO ) {-# ANN module "HLint: ignore Use Control.Exception.catch" #-}@@ -849,8 +855,32 @@ {-# INLINE _ErrorCall #-} ------------------------------------------------------------------------------+-- HandlingException+------------------------------------------------------------------------------++-- | This exception is thrown by @lens@ when the user somehow manages to rethrow+-- an internal handling exception.+class (Profunctor p, Functor f) => AsHandlingException p f t where+ -- | There is no information carried in a 'HandlingException' exception.+ --+ -- @+ -- '_HandlingException' :: 'Iso'' 'HandlingException' ()+ -- '_HandlingException' :: 'Prism'' 'SomeException' ()+ -- @+ _HandlingException :: Overloaded' p f t ()++instance (Profunctor p, Functor f) => AsHandlingException p f HandlingException where+ _HandlingException = trivial HandlingException+ {-# INLINE _HandlingException #-}++instance (Choice p, Applicative f) => AsHandlingException p f SomeException where+ _HandlingException = exception.trivial HandlingException+ {-# INLINE _HandlingException #-}++------------------------------------------------------------------------------ -- Helper Functions ------------------------------------------------------------------------------ trivial :: t -> Iso' t () trivial t = const () `iso` const t+
src/Control/Lens/Fold.hs view
@@ -148,6 +148,7 @@ -- $setup -- >>> import Control.Lens+-- >>> import Data.Function -- >>> import Data.List.Lens -- >>> import Debug.SimpleReflect.Expr -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g)@@ -722,6 +723,10 @@ -- 'for_' ≡ 'forOf_' 'folded' -- @ --+-- >>> forOf_ both ("hello","world") putStrLn+-- hello+-- world+-- -- The rather specific signature of 'forOf_' allows it to be used as if the signature was any of: -- -- @@@ -746,6 +751,10 @@ -- 'sequenceA_' ≡ 'sequenceAOf_' 'folded' -- @ --+-- >>> sequenceAOf_ both (putStrLn "hello",putStrLn "world")+-- hello+-- world+-- -- @ -- 'sequenceAOf_' :: 'Functor' f => 'Getter' s (f a) -> s -> f () -- 'sequenceAOf_' :: 'Applicative' f => 'Fold' s (f a) -> s -> f ()@@ -760,6 +769,10 @@ -- | Map each target of a 'Fold' on a structure to a monadic action, evaluate these actions from left to right, and ignore the results. --+-- >>> mapMOf_ both putStrLn ("hello","world")+-- hello+-- world+-- -- @ -- 'Data.Foldable.mapM_' ≡ 'mapMOf_' 'folded' -- @@@ -778,6 +791,10 @@ -- | 'forMOf_' is 'mapMOf_' with two of its arguments flipped. --+-- >>> forMOf_ both ("hello","world") putStrLn+-- hello+-- world+-- -- @ -- 'Data.Foldable.forM_' ≡ 'forMOf_' 'folded' -- @@@ -796,6 +813,10 @@ -- | Evaluate each monadic action referenced by a 'Fold' on the structure from left to right, and ignore the results. --+-- >>> sequenceOf_ both (putStrLn "hello",putStrLn "world")+-- hello+-- world+-- -- @ -- 'Data.Foldable.sequence_' ≡ 'sequenceOf_' 'folded' -- @@@ -814,6 +835,12 @@ -- | The sum of a collection of actions, generalizing 'concatOf'. --+-- >>> asumOf both ("hello","world")+-- "helloworld"+--+-- >>> asumOf each (Nothing, Just "hello", Nothing)+-- Just "hello"+-- -- @ -- 'asum' ≡ 'asumOf' 'folded' -- @@@ -832,6 +859,12 @@ -- | The sum of a collection of actions, generalizing 'concatOf'. --+-- >>> msumOf both ("hello","world")+-- "helloworld"+--+-- >>> msumOf each (Nothing, Just "hello", Nothing)+-- Just "hello"+-- -- @ -- 'msum' ≡ 'msumOf' 'folded' -- @@@ -871,6 +904,12 @@ -- | Does the element not occur anywhere within a given 'Fold' of the structure? --+-- >>> notElemOf each 'd' ('a','b','c')+-- True+--+-- >>> notElemOf each 'a' ('a','b','c')+-- False+-- -- @ -- 'notElem' ≡ 'notElemOf' 'folded' -- @@@ -889,6 +928,9 @@ -- | Map a function over all the targets of a 'Fold' of a container and concatenate the resulting lists. --+-- >>> concatMapOf both (\x -> [x, x + 1]) (1,3)+-- [1,2,3,4]+-- -- @ -- 'concatMap' ≡ 'concatMapOf' 'folded' -- @@@ -937,6 +979,12 @@ -- >>> lengthOf _1 ("hello",()) -- 1 --+-- >>> lengthOf traverse [1..10]+-- 10+--+-- >>> lengthOf (traverse.traverse) [[1,2],[3,4],[5,6]]+-- 6+-- -- @ -- 'lengthOf' ('folded' '.' 'folded') :: 'Foldable' f => f (g a) -> 'Int' -- @@@ -961,6 +1009,18 @@ -- Note: if you get stack overflows due to this, you may want to use 'firstOf' instead, which can deal -- more gracefully with heavily left-biased trees. --+-- >>> Left 4 ^?_Left+-- Just 4+--+-- >>> Right 4 ^?_Left+-- Nothing+--+-- >>> "world" ^? ix 3+-- Just 'l'+--+-- >>> "world" ^? ix 20+-- Nothing+-- -- @ -- ('^?') ≡ 'flip' 'preview' -- @@@ -978,6 +1038,12 @@ -- | Perform an *UNSAFE* 'head' of a 'Fold' or 'Traversal' assuming that it is there. --+-- >>> Left 4 ^?! _Left+-- 4+--+-- >>> "world" ^?! ix 3+-- 'l'+-- -- @ -- ('^?!') :: s -> 'Getter' s a -> a -- ('^?!') :: s -> 'Fold' s a -> a@@ -996,6 +1062,15 @@ -- and gives you back access to the outermost 'Just' constructor more quickly, but may have worse -- constant factors. --+-- >>> firstOf traverse [1..10]+-- Just 1+--+-- >>> firstOf both (1,2)+-- Just 1+--+-- >>> firstOf ignored ()+-- Nothing+-- -- @ -- 'firstOf' :: 'Getter' s a -> s -> 'Maybe' a -- 'firstOf' :: 'Fold' s a -> s -> 'Maybe' a@@ -1014,6 +1089,15 @@ -- and gives you back access to the outermost 'Just' constructor more quickly, but may have worse -- constant factors. --+-- >>> lastOf traverse [1..10]+-- Just 10+--+-- >>> lastOf both (1,2)+-- Just 2+--+-- >>> lastOf ignored ()+-- Nothing+-- -- @ -- 'lastOf' :: 'Getter' s a -> s -> 'Maybe' a -- 'lastOf' :: 'Fold' s a -> s -> 'Maybe' a@@ -1038,6 +1122,15 @@ -- >>> nullOf _1 (1,2) -- False --+-- >>> nullOf ignored ()+-- True+--+-- >>> nullOf traverse []+-- True+--+-- >>> nullOf (element 20) [1..10]+-- True+-- -- @ -- 'nullOf' ('folded' '.' '_1' '.' 'folded') :: 'Foldable' f => f (g a, b) -> 'Bool' -- @@@ -1056,6 +1149,8 @@ -- | Returns 'True' if this 'Fold' or 'Traversal' has any targets in the given container. --+-- A more \"conversational\" alias for this combinator is 'has'.+-- -- Note: 'notNullOf' on a valid 'Iso', 'Lens' or 'Getter' should always return 'True'. -- -- @@@ -1067,6 +1162,15 @@ -- >>> notNullOf _1 (1,2) -- True --+-- >>> notNullOf traverse [1..10]+-- True+--+-- >>> notNullOf folded []+-- False+--+-- >>> notNullOf (element 20) [1..10]+-- False+-- -- @ -- 'notNullOf' ('folded' '.' '_1' '.' 'folded') :: 'Foldable' f => f (g a, b) -> 'Bool' -- @@@ -1086,6 +1190,15 @@ -- -- Note: 'maximumOf' on a valid 'Iso', 'Lens' or 'Getter' will always return 'Just' a value. --+-- >>> maximumOf traverse [1..10]+-- Just 10+--+-- >>> maximumOf traverse []+-- Nothing+--+-- >>> maximumOf (folded.filtered even) [1,4,3,6,7,9,2]+-- Just 6+-- -- @ -- 'maximum' ≡ 'fromMaybe' ('error' \"empty\") '.' 'maximumOf' 'folded' -- @@@ -1111,6 +1224,15 @@ -- -- Note: 'minimumOf' on a valid 'Iso', 'Lens' or 'Getter' will always return 'Just' a value. --+-- >>> minimumOf traverse [1..10]+-- Just 1+--+-- >>> minimumOf traverse []+-- Nothing+--+-- >>> minimumOf (folded.filtered even) [1,4,3,6,7,9,2]+-- Just 2+-- -- @ -- 'minimum' ≡ 'Data.Maybe.fromMaybe' ('error' \"empty\") '.' 'minimumOf' 'folded' -- @@@ -1139,6 +1261,9 @@ -- | Obtain the maximum element (if any) targeted by a 'Fold', 'Traversal', 'Lens', 'Iso', -- or 'Getter' according to a user supplied 'Ordering'. --+-- >>> maximumByOf traverse (compare `on` length) ["mustard","relish","ham"]+-- Just "mustard"+-- -- In the interest of efficiency, This operation has semantics more strict than strictly necessary. -- -- @@@ -1156,11 +1281,6 @@ maximumByOf l cmp = foldlOf' l mf Nothing where mf Nothing y = Just $! y mf (Just x) y = Just $! if cmp x y == GT then x else y---- maximumByOf :: Getting (Endo (Maybe a)) s t a b -> (a -> a -> Ordering) -> s -> Maybe a--- maximumByOf l cmp = foldrOf l step Nothing where--- step a Nothing = Just a--- step a (Just b) = Just (if cmp a b == GT then a else b) {-# INLINE maximumByOf #-} -- | Obtain the minimum element (if any) targeted by a 'Fold', 'Traversal', 'Lens', 'Iso'@@ -1168,6 +1288,9 @@ -- -- In the interest of efficiency, This operation has semantics more strict than strictly necessary. --+-- >>> minimumByOf traverse (compare `on` length) ["mustard","relish","ham"]+-- Just "ham"+-- -- @ -- 'minimumBy' cmp ≡ 'Data.Maybe.fromMaybe' ('error' \"empty\") '.' 'minimumByOf' 'folded' cmp -- @@@ -1183,17 +1306,18 @@ minimumByOf l cmp = foldlOf' l mf Nothing where mf Nothing y = Just $! y mf (Just x) y = Just $! if cmp x y == GT then y else x---- minimumByOf :: Getting (Endo (Maybe a)) s t a b -> (a -> a -> Ordering) -> s -> Maybe a--- minimumByOf l cmp = foldrOf l step Nothing where--- step a Nothing = Just a--- step a (Just b) = Just (if cmp a b == GT then b else a) {-# INLINE minimumByOf #-} -- | The 'findOf' function takes a 'Lens' (or 'Getter', 'Iso', 'Fold', or 'Traversal'), -- a predicate and a structure and returns the leftmost element of the structure -- matching the predicate, or 'Nothing' if there is no such element. --+-- >>> findOf each even (1,3,4,6)+-- Just 4+--+-- >>> findOf folded even [1,3,5,7]+-- Nothing+-- -- @ -- 'findOf' :: 'Getter' s a -> (a -> 'Bool') -> s -> 'Maybe' a -- 'findOf' :: 'Fold' s a -> (a -> 'Bool') -> s -> 'Maybe' a@@ -1203,7 +1327,8 @@ -- @ -- -- @--- 'ifindOf' l = 'findOf' l '.' 'Indexed'+-- 'Data.Foldable.find' ≡ 'findOf' 'folded'+-- 'ifindOf' l ≡ 'findOf' l '.' 'Indexed' -- @ -- -- A simpler version that didn't permit indexing, would be:@@ -1220,6 +1345,9 @@ -- to lenses and structures such that the 'Lens' views at least one element of -- the structure. --+-- >>> foldr1Of each (+) (1,2,3,4)+-- 10+-- -- @ -- 'foldr1Of' l f ≡ 'Prelude.foldr1' f '.' 'toListOf' l -- 'Data.Foldable.foldr1' ≡ 'foldr1Of' 'folded'@@ -1242,6 +1370,9 @@ -- | A variant of 'foldlOf' that has no base case and thus may only be applied to lenses and structures such -- that the 'Lens' views at least one element of the structure.+--+-- >>> foldl1Of each (+) (1,2,3,4)+-- 10 -- -- @ -- 'foldl1Of' l f ≡ 'Prelude.foldl1' f '.' 'toListOf' l
+ src/Control/Lens/Internal/Exception.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+#ifdef TRUSTWORTHY+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Control.Lens.Internal.Exception+-- Copyright : (C) 2013 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- This module uses dirty tricks to generate a 'Handler' from an arbitrary+-- 'Fold'.+----------------------------------------------------------------------------+module Control.Lens.Internal.Exception+ ( Handleable(..)+ , HandlingException(..)+ ) where++import Control.Exception as Exception+import Control.Lens.Fold+import Control.Lens.Getter+import Control.Monad.CatchIO as CatchIO+import Data.IORef+import Data.Monoid+import Data.Proxy+import Data.Reflection+import Data.Typeable+import System.IO.Unsafe++------------------------------------------------------------------------------+-- Handlers+------------------------------------------------------------------------------++-- | Both @MonadCatchIO-transformers@ and "Control.Exception" provide a 'Handler' type.+--+-- This lets us write combinators to build handlers that are agnostic about the choice of+-- which of these they use.+class Handleable e (m :: * -> *) (h :: * -> *) | h -> e m where+ -- | This builds a 'Handler' for just the targets of a given 'Control.Lens.Type.Prism' (or any 'Getter', really)+ --+ -- @+ -- 'catches' ... [ 'handler' 'Control.Exception.Lens._AssertionFailed' (\s -> print $ \"Assertion Failed\\n\" ++ s)+ -- , 'handler' 'Control.Exception.Lens._ErrorCall' (\s -> print $ \"Error\\n\" ++ s)+ -- ]+ -- @+ --+ -- This works ith both the 'Exception.Handler' type provided by @Control.Exception@:+ --+ -- @+ -- 'handler' :: 'Getter' 'SomeException' a -> (a -> 'IO' r) -> 'Exception.Handler' r+ -- 'handler' :: 'Fold' 'SomeException' a -> (a -> 'IO' r) -> 'Exception.Handler' r+ -- 'handler' :: 'Control.Lens.Prism.Prism'' 'SomeException' a -> (a -> 'IO' r) -> 'Exception.Handler' r+ -- 'handler' :: 'Control.Lens.Lens.Lens'' 'SomeException' a -> (a -> 'IO' r) -> 'Exception.Handler' r+ -- 'handler' :: 'Control.Lens.Traversal.Traversal'' 'SomeException' a -> (a -> 'IO' r) -> 'Exception.Handler' r+ -- @+ --+ -- and with the 'CatchIO.Handler' type provided by @Control.Monad.CatchIO@:+ --+ -- @+ -- 'handler' :: 'Getter' 'SomeException' a -> (a -> m r) -> 'CatchIO.Handler' m r+ -- 'handler' :: 'Fold' 'SomeException' a -> (a -> m r) -> 'CatchIO.Handler' m r+ -- 'handler' :: 'Control.Lens.Prism.Prism'' 'SomeException' a -> (a -> m r) -> 'CatchIO.Handler' m r+ -- 'handler' :: 'Control.Lens.Lens.Lens'' 'SomeException' a -> (a -> m r) -> 'CatchIO.Handler' m r+ -- 'handler' :: 'Control.Lens.Traversal.Traversal'' 'SomeException' a -> (a -> m r) -> 'CatchIO.Handler' m r+ -- @+ --+ -- and with the 'Control.Monad.Error.Lens.Handler' type provided by @Control.Monad.Error.Lens@:+ --+ -- @+ -- 'handler' :: 'Getter' e a -> (a -> m r) -> 'Control.Monad.Error.Lens.Handler' e m r+ -- 'handler' :: 'Fold' e a -> (a -> m r) -> 'Control.Monad.Error.Lens.Handler' e m r+ -- 'handler' :: 'Control.Lens.Prism.Prism'' e a -> (a -> m r) -> 'Control.Monad.Error.Lens.Handler' e m r+ -- 'handler' :: 'Control.Lens.Lens.Lens'' e a -> (a -> m r) -> 'Control.Monad.Error.Lens.Handler' e m r+ -- 'handler' :: 'Control.Lens.Traversal.Traversal'' e a -> (a -> m r) -> 'Control.Monad.Error.Lens.Handler' e m r+ -- @+ handler :: Getting (First a) e t a b -> (a -> m r) -> h r++ -- | This builds a 'Handler' for just the targets of a given 'Control.Lens.Prism.Prism' (or any 'Getter', really)+ -- that ignores its input and just recovers with the stated monadic action.+ --+ -- @+ -- 'catches' ... [ 'handler_' 'Control.Exception.Lens._NonTermination' ('return' \"looped\")+ -- , 'handler_' 'Control.Exception.Lens._StackOverflow' ('return' \"overflow\")+ -- ]+ -- @+ --+ -- This works with the 'Exception.Handler' type provided by @Control.Exception@:+ --+ -- @+ -- 'handler_' :: 'Getter' 'SomeException' a -> 'IO' r -> 'Exception.Handler' r+ -- 'handler_' :: 'Fold' 'SomeException' a -> 'IO' r -> 'Exception.Handler' r+ -- 'handler_' :: 'Control.Lens.Prism.Prism'' 'SomeException' a -> 'IO' r -> 'Exception.Handler' r+ -- 'handler_' :: 'Control.Lens.Lens.Lens'' 'SomeException' a -> 'IO' r -> 'Exception.Handler' r+ -- 'handler_' :: 'Control.Lens.Traversal.Traversal'' 'SomeException' a -> 'IO' r -> 'Exception.Handler' r+ -- @+ --+ -- and with the 'CatchIO.Handler' type provided by @Control.Monad.CatchIO@:+ --+ -- @+ -- 'handler_' :: 'Getter' 'SomeException' a -> m r -> 'CatchIO.Handler' m r+ -- 'handler_' :: 'Fold' 'SomeException' a -> m r -> 'CatchIO.Handler' m r+ -- 'handler_' :: 'Control.Lens.Prism.Prism'' 'SomeException' a -> m r -> 'CatchIO.Handler' m r+ -- 'handler_' :: 'Control.Lens.Lens.Lens'' 'SomeException' a -> m r -> 'CatchIO.Handler' m r+ -- 'handler_' :: 'Control.Lens.Traversal.Traversal'' 'SomeException' a -> m r -> 'CatchIO.Handler' m r+ -- @+ --+ -- and with the 'Control.Monad.Error.Lens.Handler' type provided by @Control.Monad.Error.Lens@:+ --+ -- @+ -- 'handler_' :: 'Getter' e a -> m r -> 'Control.Monad.Error.Lens.Handler' e m r+ -- 'handler_' :: 'Fold' e a -> m r -> 'Control.Monad.Error.Lens.Handler' e m r+ -- 'handler_' :: 'Control.Lens.Prism.Prism'' e a -> m r -> 'Control.Monad.Error.Lens.Handler' e m r+ -- 'handler_' :: 'Control.Lens.Lens.Lens'' e a -> m r -> 'Control.Monad.Error.Lens.Handler' e m r+ -- 'handler_' :: 'Control.Lens.Traversal.Traversal'' e a -> m r -> 'Control.Monad.Error.Lens.Handler' e m r+ -- @+ handler_ :: Getting (First a) e t a b -> m r -> h r+ handler_ l = handler l . const+ {-# INLINE handler_ #-}++instance Handleable SomeException IO Exception.Handler where+ handler = handlerIO++instance Handleable SomeException m (CatchIO.Handler m) where+ handler = handlerCatchIO++handlerIO :: forall t a b r. Getting (First a) SomeException t a b -> (a -> IO r) -> Exception.Handler r+handlerIO l f = reify (preview l) $ \ (_ :: Proxy s) -> Exception.Handler (\(Handling a :: Handling a s IO) -> f a)++handlerCatchIO :: forall m t a b r. Getting (First a) SomeException t a b -> (a -> m r) -> CatchIO.Handler m r+handlerCatchIO l f = reify (preview l) $ \ (_ :: Proxy s) -> CatchIO.Handler (\(Handling a :: Handling a s m) -> f a)++------------------------------------------------------------------------------+-- Helpers+------------------------------------------------------------------------------++-- | There was exception caused by abusing the internals of a 'Handler'.+data HandlingException = HandlingException deriving (Show,Typeable)++instance Exception HandlingException++-- | This supplies a globally unique set of IDs so we can hack around the default use of 'cast' in 'SomeException'+-- if someone, somehow, somewhere decides to reach in and catch and rethrow a 'Handling' exception by existentially+-- opening a 'Handler' that uses it.+supply :: IORef Int+supply = unsafePerformIO $ newIORef 0+{-# NOINLINE supply #-}++-- | This permits the construction of an \"impossible\" 'Control.Exception.Handler' that matches only if some function does.+newtype Handling a s (m :: * -> *) = Handling a++-- the m parameter exists simply to break the Typeable1 pattern, so we can provide this without overlap.+-- here we simply generate a fresh TypeRep so we'll fail to compare as equal to any other TypeRep.+instance Typeable (Handling a s m) where+ typeOf _ = unsafePerformIO $ do+ i <- atomicModifyIORef supply $ \a -> let a' = a + 1 in a' `seq` (a', a)+ return $ mkTyConApp (mkTyCon3 "lens" "Control.Lens.Internal.Exception" ("Handling" ++ show i)) []+ {-# INLINE typeOf #-}++-- The 'Handling' wrapper is uninteresting, and should never be thrown, so you won't get much benefit here.+instance Show (Handling a s m) where+ showsPrec d _ = showParen (d > 10) $ showString "Handling ..."+ {-# INLINE showsPrec #-}++instance Reifies s (SomeException -> Maybe a) => Exception (Handling a s m) where+ toException _ = SomeException HandlingException+ {-# INLINE toException #-}+ fromException = fmap Handling . reflect (Proxy :: Proxy s)+ {-# INLINE fromException #-}
src/Control/Lens/Iso.hs view
@@ -273,6 +273,12 @@ -- @ -- 'curried' = 'iso' 'curry' 'uncurry' -- @+--+-- >>> (fst^.curried) 3 4+-- 3+--+-- >>> view curried fst 3 4+-- 3 curried :: Iso ((a,b) -> c) ((d,e) -> f) (a -> b -> c) (d -> e -> f) curried = iso curry uncurry {-# INLINE curried #-}@@ -286,11 +292,17 @@ -- @ -- 'uncurried' = 'from' 'curried' -- @+--+-- >>> ((+)^.uncurried) (1,2)+-- 3 uncurried :: Iso (a -> b -> c) (d -> e -> f) ((a,b) -> c) ((d,e) -> f) uncurried = iso uncurry curry {-# INLINE uncurried #-} -- | The isomorphism for flipping a function.+--+-- >>>((,)^.flipped) 1 2+-- (2,1) flipped :: Iso (a -> b -> c) (a' -> b' -> c') (b -> a -> c) (b' -> a' -> c') flipped = iso flip flip {-# INLINE flipped #-}@@ -304,6 +316,9 @@ -- 'second' g '.' 'swapped' = 'swapped' '.' 'first' g -- 'bimap' f g '.' 'swapped' = 'swapped' '.' 'bimap' g f -- @+ --+ -- >>> (1,2)^.swapped+ -- (2,1) swapped :: Iso (p a b) (p c d) (p b a) (p d c) instance Swapped (,) where
src/Control/Lens/Review.hs view
@@ -81,6 +81,9 @@ -- >>> 5 ^.re _Left -- Left 5 --+-- >>> 6 ^.re (_Left.unto succ)+-- Left 7+-- -- @ -- 'review' ≡ 'view' '.' 're' -- 'reviews' ≡ 'views' '.' 're'@@ -100,11 +103,15 @@ -- -- @ -- 'review' ≡ 'view' '.' 're'+-- 'review' . 'unto' ≡ 'id' -- @ -- -- >>> review _Left "mustard" -- Left "mustard" --+-- >>> review (unto succ) 5+-- 6+-- -- Usually 'review' is used in the @(->)@ 'Monad' with a 'Prism' or 'Control.Lens.Iso.Iso', in which case it may be useful to think of -- it as having one of these more restricted type signatures: --@@ -129,11 +136,15 @@ -- -- @ -- 'reviews' ≡ 'views' '.' 're'+-- 'reviews' ('unto' f) g ≡ g '.' f -- @ -- -- >>> reviews _Left isRight "mustard" -- False --+-- >>> reviews (unto succ) (*2) 3+-- 8+-- -- Usually this function is used in the @(->)@ 'Monad' with a 'Prism' or 'Control.Lens.Iso.Iso', in which case it may be useful to think of -- it as having one of these more restricted type signatures: --@@ -155,11 +166,17 @@ -- | This can be used to turn an 'Control.Lens.Iso.Iso' or 'Prism' around and 'use' a value (or the current environment) through it the other way. ----- @'reuse' ≡ 'use' '.' 're'@+-- @+-- 'reuse' ≡ 'use' '.' 're'+-- 'reuse' '.' 'unto' ≡ 'gets'+-- @ -- -- >>> evalState (reuse _Left) 5 -- Left 5 --+-- >>> evalState (reuse (unto succ)) 5+-- 6+-- -- @ -- 'reuse' :: 'MonadState' a m => 'Prism'' s a -> m s -- 'reuse' :: 'MonadState' a m => 'Iso'' s a -> m s@@ -171,7 +188,10 @@ -- | This can be used to turn an 'Control.Lens.Iso.Iso' or 'Prism' around and 'use' the current state through it the other way, -- applying a function. ----- @'reuses' ≡ 'uses' '.' 're'@+-- @+-- 'reuses' ≡ 'uses' '.' 're'+-- 'reuses' ('unto' f) g ≡ 'gets' (g '.' f)+-- @ -- -- >>> evalState (reuses _Left isLeft) (5 :: Int) -- True
src/Control/Lens/TH.hs view
@@ -830,32 +830,33 @@ hasClassAndInstance :: FieldRules -> Name -> Q [Dec] hasClassAndInstance cfg src = do- TyConI (DataD _ _ _ [RecC _ rs] _) <- reify src+ c <- newName "c"+ e <- newName "e"+ TyConI (DataD _ _ vs [RecC _ rs] _) <- reify src fmap concat . forM (mkFields cfg rs) $ \(Field field _ fullLensName className lensName) -> do classHas <- classD (return []) className [ PlainTV c, PlainTV e ] [ FunDep [c] [e] ]- [ sigD lensName (appsT (conT ''Lens') [varT c, varT e])]-- VarI _ (AppT _ fieldType) _ _ <- reify field-+ [ sigD lensName (conT ''Lens' `appsT` [varT c, varT e])]+ fieldType <- do+ VarI _ t _ _ <- reify field+ case t of+ AppT _ fieldType -> return fieldType+ ForallT _ [] (AppT _ fieldType) -> return fieldType+ _ -> error "Cannot get fieldType" instanceHas <- instanceD (return [])- (conT className `appsT` [conT src, return fieldType])+ (conT className `appsT` [conT src `appsT` map (varT.view name) vs, return fieldType]) [ #ifdef INLINING inlinePragma lensName, #endif funD lensName [ clause [] (normalB (global fullLensName)) [] ] ]- classAlreadyExists <- isJust `fmap` lookupTypeName (show className) return (if classAlreadyExists then [instanceHas] else [classHas, instanceHas])-- where c = mkName "c"- e = mkName "e" -- | Make fields with the specified 'FieldRules'. makeFieldsWith :: FieldRules -> Name -> Q [Dec]
src/Control/Lens/Traversal.hs view
@@ -188,6 +188,12 @@ -- -- This function is only provided for consistency, 'id' is strictly more general. --+-- >>> traverseOf each print (1,2,3)+-- 1+-- 2+-- 3+-- ((),(),())+-- -- @ -- 'traverseOf' ≡ 'id' -- 'itraverseOf' l ≡ 'traverseOf' l '.' 'Indexed'@@ -211,8 +217,17 @@ -- | A version of 'traverseOf' with the arguments flipped, such that: --+-- >>> forOf each (1,2,3) print+-- 1+-- 2+-- 3+-- ((),(),())+--+-- This function is only provided for consistency, 'flip' is strictly more general.+-- -- @--- 'forOf' l ≡ 'flip' ('traverseOf' l)+-- 'forOf' ≡ 'flip'+-- 'forOf' ≡ 'flip' . 'traverseOf' -- @ -- -- @@@ -220,13 +235,7 @@ -- 'Control.Lens.Indexed.ifor' l s ≡ 'for' l s '.' 'Indexed' -- @ ----- This function is only provided for consistency, 'flip' is strictly more general.--- -- @--- 'forOf' ≡ 'flip'--- @------ @ -- 'forOf' :: 'Iso' s t a b -> s -> (a -> f b) -> f t -- 'forOf' :: 'Lens' s t a b -> s -> (a -> f b) -> f t -- 'forOf' :: 'Traversal' s t a b -> s -> (a -> f b) -> f t@@ -238,6 +247,9 @@ -- | Evaluate each action in the structure from left to right, and collect -- the results. --+-- >>> sequenceAOf both ([1,2],[3,4])+-- [(1,3),(1,4),(2,3),(2,4)]+-- -- @ -- 'sequenceA' ≡ 'sequenceAOf' 'traverse' ≡ 'traverse' 'id' -- 'sequenceAOf' l ≡ 'traverseOf' l 'id' ≡ l 'id'@@ -255,6 +267,9 @@ -- | Map each element of a structure targeted by a 'Lens' to a monadic action, -- evaluate these actions from left to right, and collect the results. --+-- >>> mapMOf both (\x -> [x, x + 1]) (1,3)+-- [(1,3),(1,4),(2,3),(2,4)]+-- -- @ -- 'mapM' ≡ 'mapMOf' 'traverse' -- 'imapMOf' l ≡ 'forM' l '.' 'Indexed'@@ -271,6 +286,9 @@ -- | 'forMOf' is a flipped version of 'mapMOf', consistent with the definition of 'forM'. --+-- >>> forMOf both (1,3) $ \x -> [x, x + 1]+-- [(1,3),(1,4),(2,3),(2,4)]+-- -- @ -- 'forM' ≡ 'forMOf' 'traverse' -- 'forMOf' l ≡ 'flip' ('mapMOf' l)@@ -288,6 +306,9 @@ -- | Sequence the (monadic) effects targeted by a 'Lens' in a container from left to right. --+-- >>> sequenceOf each ([1,2],[3,4],[5,6])+-- [(1,3,5),(1,3,6),(1,4,5),(1,4,6),(2,3,5),(2,3,6),(2,4,5),(2,4,6)]+-- -- @ -- 'sequence' ≡ 'sequenceOf' 'traverse' -- 'sequenceOf' l ≡ 'mapMOf' l 'id'@@ -307,12 +328,12 @@ -- -- Note: 'Data.List.transpose' handles ragged inputs more intelligently, but for non-ragged inputs: --+-- >>> transposeOf traverse [[1,2,3],[4,5,6]]+-- [[1,4],[2,5],[3,6]]+-- -- @ -- 'Data.List.transpose' ≡ 'transposeOf' 'traverse' -- @------ >>> transposeOf traverse [[1,2,3],[4,5,6]]--- [[1,4],[2,5],[3,6]] -- -- Since every 'Lens' is a 'Traversal', we can use this as a form of -- monadic strength as well:
src/Control/Monad/Error/Lens.hs view
@@ -1,7 +1,6 @@-{-# LANGUAGE CPP #-}-#ifdef TRUSTWORTHY-{-# LANGUAGE Trustworthy #-}-#endif+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Error.Lens@@ -20,13 +19,21 @@ , handling, handling_ -- * Trying , trying+ -- * Handlers+ , catches+ , Handler(..)+ , Handleable(..) -- * Throwing , throwing ) where +import Control.Applicative import Control.Lens+import Control.Lens.Internal.Exception import Control.Monad.Error+import Data.Functor.Plus import Data.Monoid+import Data.Semigroup (Semigroup(..)) ------------------------------------------------------------------------------ -- Catching@@ -114,6 +121,79 @@ -- @ trying :: MonadError e m => Getting (First a) e t a b -> m r -> m (Either a r) trying l m = catching l (liftM Right m) (return . Left)++------------------------------------------------------------------------------+-- Catches+------------------------------------------------------------------------------++-- |+-- This function exists to remedy a gap between the functionality of @Control.Exception@+-- and @Control.Monad.Error@. @Control.Exception@ supplies 'Control.Exception.catches' and+-- a notion of 'Control.Exception.Handler', which we duplicate here in a form suitable for+-- working with any 'MonadError' instance.+--+-- Sometimes you want to catch two different sorts of error. You could+-- do something like+--+-- @+-- f = 'handling' _Foo handleFoo ('handling' _Bar handleBar expr)+-- @+--+--+-- However, there are a couple of problems with this approach. The first is+-- that having two exception handlers is inefficient. However, the more+-- serious issue is that the second exception handler will catch exceptions+-- in the first, e.g. in the example above, if @handleFoo@ uses 'throwError'+-- then the second exception handler will catch it.+--+-- Instead, we provide a function 'catches', which would be used thus:+--+-- @+-- f = 'catches' expr [ 'handler' _Foo handleFoo+-- , 'handler' _Bar handleBar+-- ]+-- @+catches :: MonadError e m => m a -> [Handler e m a] -> m a+catches m hs = catchError m go where+ go e = foldr tryHandler (throwError e) hs where+ tryHandler (Handler ema amr) res = maybe res amr (ema e)++------------------------------------------------------------------------------+-- Handlers+------------------------------------------------------------------------------++-- | You need this when using 'catches'.+data Handler e m r = forall a. Handler (e -> Maybe a) (a -> m r)++instance Monad m => Functor (Handler e m) where+ fmap f (Handler ema amr) = Handler ema $ \a -> do+ r <- amr a+ return (f r)+ {-# INLINE fmap #-}++instance Monad m => Semigroup (Handler e m a) where+ (<>) = mappend+ {-# INLINE (<>) #-}++instance Monad m => Alt (Handler e m) where+ Handler ema amr <!> Handler emb bmr = Handler emab abmr where+ emab e = Left <$> ema e <|> Right <$> emb e+ abmr = either amr bmr+ {-# INLINE (<!>) #-}++instance Monad m => Plus (Handler e m) where+ zero = Handler (const Nothing) undefined+ {-# INLINE zero #-}++instance Monad m => Monoid (Handler e m a) where+ mempty = zero+ {-# INLINE mempty #-}+ mappend = (<!>)+ {-# INLINE mappend #-}++instance Handleable e m (Handler e m) where+ handler = Handler . preview+ {-# INLINE handler #-} ------------------------------------------------------------------------------ -- Throwing
src/Numeric/Lens.hs view
@@ -33,12 +33,12 @@ -- -- >>> 1767707668033969 ^. re (base 36) -- "helloworld"-base :: (Integral a, Show a) => a -> Prism' String a+base :: Integral a => a -> Prism' String a base b- | b < 2 || b > 36 = error ("base: Invalid base " ++ show b)+ | b < 2 || b > 36 = error ("base: Invalid base " ++ show (toInteger b)) | otherwise = prism intShow intRead where- intShow n = showSigned' (showIntAtBase b intToDigit') n ""+ intShow n = showSigned' (showIntAtBase (toInteger b) intToDigit') (toInteger n) "" intRead s = case readSigned' (readInt b (isDigit' b) digitToInt') s of
tests/templates.hs view
@@ -94,5 +94,22 @@ data Foo = Foo { _fooX, _fooY :: Int } makeClassy ''Foo ++data Dude a = Dude+ { _dudeLevel :: Int+ , _dudeAlias :: String+ , _dudeLife :: ()+ , _dudeThing :: a+ }+data Lebowski a = Lebowski+ { _lebowskiAlias :: String+ , _lebowskiLife :: Int+ , _lebowskiMansion :: String+ , _lebowskiThing :: Maybe a+ }++makeFields ''Dude+makeFields ''Lebowski+ main :: IO () main = putStrLn "test/templates.hs: ok"
travis/cabal-apt-install view
@@ -1,16 +1,27 @@-#!/bin/sh+#! /bin/bash set -eu -sudo apt-get -q update-sudo apt-get -q -y install dctrl-tools+APT="sudo apt-get -q -y"+CABAL_INSTALL_DEPS="cabal install --only-dependencies --force-reinstall" -# Try installing some of the build-deps with apt-get for speed.-eval "$(- printf '%s' "grep-aptavail -n -sPackage '(' -FFALSE -X FALSE ')'"- 2>/dev/null cabal install "$@" --dry-run -v | \- sed -nre "s/^([^ ]+)-[0-9.]+ \(.*$/ -o '(' -FPackage -X libghc-\1-dev ')'/p" | \- xargs -d'\n'-)" | sort -u | xargs -d'\n' sudo apt-get -q -y install -- libghc-quickcheck2-dev+$APT update+$APT install dctrl-tools -# Install whatever is still needed with cabal.-cabal install "$@"+# Find potential system packages to satisfy cabal dependencies+deps()+{+ local M='^\([^ ]\+\)-[0-9.]\+ (.*$'+ local G=' -o ( -FPackage -X libghc-\L\1\E-dev )'+ local E="$($CABAL_INSTALL_DEPS "$@" --dry-run -v 2> /dev/null \+ | sed -ne "s/$M/$G/p" | sort -u)"+ grep-aptavail -n -sPackage \( -FNone -X None \) $E | sort -u+}++$APT install $(deps "$@") libghc-quickcheck2-dev # QuickCheck is special+$CABAL_INSTALL_DEPS "$@" # Install the rest via Hackage++if ! $APT install hlint ; then+ $APT install $(deps hlint)+ cabal install hlint+fi+