lens 3.8.2 → 3.8.3
raw patch · 23 files changed
+453/−1049 lines, 23 filesdep ~base
Dependency ranges changed: base
Files
- .travis.yml +1/−1
- AUTHORS.markdown +2/−2
- CHANGELOG.markdown +7/−0
- benchmarks/alongside.hs +0/−109
- benchmarks/plated.hs +0/−78
- benchmarks/unsafe.hs +0/−63
- benchmarks/zipper.hs +0/−45
- lens.cabal +1/−1
- src/Control/Exception/Lens.hs +49/−28
- src/Control/Lens/Internal/Exception.hs +7/−7
- src/Control/Lens/Operators.hs +4/−0
- src/Control/Lens/Review.hs +30/−0
- src/Data/ByteString/Lazy/Lens.hs +70/−13
- src/Data/ByteString/Lens.hs +72/−12
- src/Data/ByteString/Strict/Lens.hs +69/−12
- src/Data/List/Lens.hs +30/−0
- src/Data/Text/Lazy/Lens.hs +45/−8
- src/Data/Text/Lens.hs +28/−6
- src/Data/Text/Strict/Lens.hs +38/−4
- tests/doctests.hsc +0/−71
- tests/hunit.hs +0/−279
- tests/properties.hs +0/−195
- tests/templates.hs +0/−115
.travis.yml view
@@ -22,7 +22,7 @@ - "\x0313lens\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" env:- - mode="--enable-tests" script="cabal test"+ - mode="--enable-tests" script="cabal test --show-details=always" # - mode="--enable-tests -fsafe" script="cabal test" # - mode="--enable-tests -fdump-splices" script="cabal test --show-details=always" # - mode="--enable-benchmarks -fdump-splices" script="cabal bench"
AUTHORS.markdown view
@@ -19,7 +19,7 @@ * [Simon Hengel](mailto:sol@typeful.net) [@sol](https://github.com/sol) * [@startling](https://github.com/startling) * [Mike Ledger](mailto:eleventynine@gmail.com) [@mikeplus64](https://github.com/mikeplus64)-* `nand` [@nandykins](https://github.com/nandykins)+* \`nand\` [@nandykins](https://github.com/nandykins) * [Adrian Keet](mailto:arkeet@gmail.com) [@arkeet](https://github.com/arkeet) * [Matvey B. Aksenov](mailto:matvey.aksenov@gmail.com) [@supki](https://github.com/supki) * [Eyal Lotem](mailto:eyal.lotem+github@gmail.com) [@Peaker](https://github.com/Peaker)@@ -31,7 +31,7 @@ * Ville Tirronen [@aleator](https://github.com/aleator) * [Mikhail Vorozhtsov](mailto:mikhail.vorozhtsov@gmail.com) [@mvv](https://github.com/mvv) * [Brent Yorgey](mailto:byorgey@gmail.com) [@byorgey](https://github.com/byorgey)-* [Dan Rosén](mailto:danr@fripost.org) [@danr](https://github.com/danr)+* [Dan Rosén](mailto:danr@chalmers.se) [@danr](https://github.com/danr) * Yair Chuchem [@yairchu](https://github.com/yairchu) * [Michael Thompson](mailto:what_is_it_to_do_anything@yahoo.com) [@michaelt](https://github.com/michaelt) * [John Wiegley](mailto:johnw@newartisans.com) [@jwiegley](https://github.com/jwiegley)
CHANGELOG.markdown view
@@ -1,3 +1,10 @@+3.8.3+-----+* Added `strippingSuffix` and `stripSuffix` to `Data.Data.Lens`+* Added `unpackedBytes` and `unpackedChars` to `Data.ByteString.*.Lens`+* Added `unpacked` to `Data.Text.*.Lens`+* Added `(#)` as an infix form of `review` to ease using a `Prism` like a smart constructor in `Control.Lens.Review`.+ 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`.
− benchmarks/alongside.hs
@@ -1,109 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-import Control.Applicative-import Control.Comonad-import Control.Comonad.Store.Class-import Control.Lens.Internal-import Control.Lens-import Criterion.Main-import Data.Functor.Compose-import Data.Functor.Identity---- | A finally encoded Store-newtype Experiment a b s = Experiment { runExperiment :: forall f. Functor f => (a -> f b) -> f s }--instance Functor (Experiment a b) where- fmap f (Experiment k) = Experiment (fmap f . k)- {-# INLINE fmap #-}--instance (a ~ b) => Comonad (Experiment a b) where- extract (Experiment m) = runIdentity (m Identity)- {-# INLINE extract #-}- duplicate = duplicateExperiment- {-# INLINE duplicate #-}---- | 'Experiment' is an indexed 'Comonad'.-duplicateExperiment :: Experiment a c s -> Experiment a b (Experiment b c s)-duplicateExperiment (Experiment m) = getCompose (m (Compose . fmap placebo . placebo))-{-# INLINE duplicateExperiment #-}---- | A trivial 'Experiment'.-placebo :: a -> Experiment a b b-placebo i = Experiment (\k -> k i)-{-# INLINE placebo #-}--instance (a ~ b) => ComonadStore a (Experiment a b) where- pos m = posExperiment m- peek d m = peekExperiment d m- peeks f m = runIdentity $ runExperiment m (\c -> Identity (f c))- experiment f m = runExperiment m f--posExperiment :: Experiment a b s -> a-posExperiment m = getConst (runExperiment m Const)-{-# INLINE posExperiment #-}--peekExperiment :: b -> Experiment a b s -> s-peekExperiment b m = runIdentity $ runExperiment m (\_ -> Identity b)-{-# INLINE peekExperiment #-}--trial :: Lens s t a b -> Lens s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b')-trial l r pfq (s,s') = fmap (\(b,t') -> (peekExperiment b x,t')) (getCompose (r (\a' -> Compose $ pfq (posExperiment x, a')) s'))- where x = l placebo s-{-# INLINE trial #-}--posContext :: Context a b s -> a-posContext (Context _ a) = a-{-# INLINE posContext #-}--peekContext :: b -> Context a b s -> s-peekContext b (Context f _) = f b-{-# INLINE peekContext #-}---- a version of alongside built with Context and product-half :: LensLike (Context a b) s t a b -> Lens s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b')-half l r pfq (s,s') = fmap (\(b,t') -> (peekContext b x,t')) (getCompose (r (\a' -> Compose $ pfq (posContext x, a')) s'))- where x = l (Context id) s-{-# INLINE half #-}---- alongside' :: Lens s t a b -> Lens s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b')--- {-# INLINE alongside'#-}--compound :: Lens s t a b- -> Lens s' t' a' b'- -> Lens (s,s') (t,t') (a,a') (b,b')-compound l r = lens (\(s, s') -> (view l s, view r s'))- (\(s, s') (t, t') -> (set l t s, set r t' s'))-{-# INLINE compound #-}--compound5 :: Lens s t a b- -> Lens s' t' a' b'- -> Lens s'' t'' a'' b''- -> Lens s''' t''' a''' b'''- -> Lens s'''' t'''' a'''' b''''- -> Lens (s, (s', (s'', (s''', s''''))))- (t, (t', (t'', (t''', t''''))))- (a, (a', (a'', (a''', a''''))))- (b, (b', (b'', (b''', b''''))))-compound5 l l' l'' l''' l''''- = lens (\(s, (s', (s'', (s''', s''''))))- -> (view l s, (view l' s', (view l'' s'', (view l''' s''', view l'''' s'''')))) )- (\(s, (s', (s'', (s''', s'''')))) (t, (t', (t'', (t''', t''''))))- -> (set l t s, (set l' t' s', (set l'' t'' s'', (set l''' t''' s''', set l'''' t'''' s'''')))) )--main = defaultMain- [ bench "alongside1" $ nf (view $ alongside _1 _2) (("hi", 1), (2, "there!"))- , bench "trial1" $ nf (view $ trial _1 _2) (("hi", 1), (2, "there!"))- , bench "half1" $ nf (view $ half _1 _2) (("hi", 1), (2, "there!"))- , bench "compound1" $ nf (view $ compound _1 _2) (("hi", 1), (2, "there!"))- , bench "alongside5" $ nf (view $ (alongside _1 (alongside _1 (alongside _1 (alongside _1 _1)))))- ((v,v),((v,v),((v,v),((v,v),(v,v)))))- , bench "trial5" $ nf (view $ (trial _1 (trial _1 (trial _1 (trial _1 _1)))))- ((v,v),((v,v),((v,v),((v,v),(v,v)))))- , bench "half5" $ nf (view $ (half _1 (half _1 (half _1 (half _1 _1)))))- ((v,v),((v,v),((v,v),((v,v),(v,v)))))- , bench "compound5" $ nf (view $ compound5 _1 _1 _1 _1 _1)- ((v,v),((v,v),((v,v),((v,v),(v,v)))))- ]- where v = 1 :: Int
− benchmarks/plated.hs
@@ -1,78 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}-import Control.Applicative-import Control.Lens-import Control.DeepSeq-import Criterion.Main-import Data.Data-import Data.Data.Lens as Data-#ifdef BENCHMARK_UNIPLATE-import qualified Data.Generics.Uniplate.Direct as Uni-import Data.Generics.Uniplate.Direct ((|*))-import qualified Data.Generics.Uniplate.DataOnly as UniDataOnly-#endif-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-import GHC.Generics-#else-import Generics.Deriving-#endif-import GHC.Generics.Lens as Generic--data Expr = Val !Int- | Var String- | Neg !Expr- | Add !Expr !Expr- | Sub !Expr !Expr- | Mul !Expr !Expr- | Div !Expr !Expr- deriving (Eq,Show,Data,Typeable,Generic)--instance NFData Expr where- rnf (Neg a) = rnf a- rnf (Add a b) = rnf a `seq` rnf b- rnf (Sub a b) = rnf a `seq` rnf b- rnf (Mul a b) = rnf a `seq` rnf b- rnf (Div a b) = rnf a `seq` rnf b- rnf (Val i) = rnf i- rnf (Var s) = rnf s--instance Plated Expr where- plate f (Neg a) = Neg <$> f a- plate f (Add a b) = Add <$> f a <*> f b- plate f (Sub a b) = Sub <$> f a <*> f b- plate f (Mul a b) = Mul <$> f a <*> f b- plate f (Div a b) = Div <$> f a <*> f b- plate _ t = pure t- {-# INLINE plate #-}--#ifdef BENCHMARK_UNIPLATE-instance Uni.Uniplate Expr where- uniplate (Neg a) = Uni.plate Neg |* a- uniplate (Add a b) = Uni.plate Add |* a |* b- uniplate (Sub a b) = Uni.plate Sub |* a |* b- uniplate (Mul a b) = Uni.plate Mul |* a |* b- uniplate (Div a b) = Uni.plate Div |* a |* b- uniplate (Val i) = Uni.plate (Val i)- uniplate (Var s) = Uni.plate (Var s)- {-# INLINE uniplate #-}-#endif--main :: IO ()-main = defaultMain- [ bench "universe" $ nf (map universe) testsExpr- , bench "universeOf plate" $ nf (map (universeOf plate)) testsExpr- , bench "universeOf Generic.tinplate" $ nf (map (universeOf Generic.tinplate)) testsExpr- , bench "universeOf Data.tinplate" $ nf (map (universeOf Data.tinplate)) testsExpr- , bench "universeOf Data.template" $ nf (map (universeOf Data.template)) testsExpr- , bench "universeOf Data.uniplate" $ nf (map (universeOf Data.uniplate)) testsExpr- , bench "universeOf (cloneTraversal plate)" $ nf (map (universeOf (cloneTraversal plate))) testsExpr-#ifdef BENCHMARK_UNIPLATE- , bench "Direct.universe" $ nf (map Uni.universe) testsExpr- , bench "DataOnly.universe" $ nf (map UniDataOnly.universe) testsExpr-#endif- ]--testsExpr :: [Expr]-testsExpr = [Val 3,Val 2,Val 6,Neg (Neg (Var "dus")),Mul (Div (Add (Val 4) (Var "kxm")) (Sub (Mul (Div (Var "") (Var "")) (Var "w")) (Var "ed"))) (Var "whpd"),Val 6,Val 4,Val 2,Var "a",Val 1,Div (Var "") (Val 0),Var "",Var "",Val (-3),Val 3,Sub (Var "") (Val 2),Neg (Var "dlp"),Div (Val 0) (Var "sd"),Val (-2),Val (-3),Var "g",Mul (Val 3) (Var "i"),Val 1,Var "ul",Div (Add (Var "") (Var "")) (Mul (Div (Val 0) (Neg (Val 0))) (Neg (Neg (Mul (Var "") (Val 0))))),Var "z",Sub (Neg (Add (Var "") (Val 0))) (Var ""),Neg (Sub (Mul (Val 0) (Val 2)) (Val 5)),Val 0,Val 0,Mul (Val (-4)) (Sub (Val 5) (Neg (Div (Div (Val 0) (Sub (Neg (Sub (Val (-3)) (Mul (Mul (Var "ap") (Val 3)) (Add (Add (Add (Var "owre") (Add (Add (Var "avj") (Val 3)) (Var "vhi"))) (Mul (Val 2) (Var "hak"))) (Val 2))))) (Var "nf"))) (Add (Sub (Val 5) (Sub (Var "pkjyh") (Val 2))) (Var "lsiu"))))),Var "u",Val 1,Neg (Add (Add (Var "") (Val 1)) (Sub (Add (Add (Val (-3)) (Mul (Val 1) (Var "pfe"))) (Var "yv")) (Mul (Var "") (Var "jfq")))),Val 2,Div (Div (Div (Div (Var "xrgykq") (Mul (Var "kyfu") (Val 2))) (Sub (Var "v") (Val 0))) (Sub (Val 6) (Val 2))) (Val 3),Var "",Var "",Add (Var "ob") (Sub (Mul (Neg (Val 2)) (Val 6)) (Add (Mul (Val 6) (Sub (Add (Var "wue") (Mul (Var "hgsuj") (Neg (Div (Var "hr") (Var "ozvsb"))))) (Sub (Var "j") (Div (Var "yeyhvq") (Val (-6)))))) (Var "b"))),Div (Add (Div (Div (Neg (Val 4)) (Var "")) (Var "yfx")) (Div (Sub (Var "") (Sub (Var "np") (Mul (Val 3) (Var "mxr")))) (Mul (Var "m") (Var "kkhbf")))) (Neg (Sub (Var "yie") (Val 1))),Neg (Var ""),Var "liuh",Var "pbqg",Var "",Neg (Div (Sub (Add (Val (-1)) (Var "onynvr")) (Neg (Var "tqjsay"))) (Add (Val 4) (Var "yorkb"))),Val 1,Add (Mul (Neg (Div (Val (-1)) (Var "u"))) (Sub (Var "") (Neg (Val 1)))) (Var "h"),Var "",Add (Mul (Sub (Var "em") (Val 0)) (Add (Val (-2)) (Val 1))) (Var ""),Add (Mul (Add (Div (Add (Val 0) (Mul (Mul (Var "e") (Add (Val 1) (Var ""))) (Neg (Neg (Div (Add (Div (Neg (Val 1)) (Div (Val (-1)) (Mul (Add (Div (Val (-1)) (Mul (Mul (Val 1) (Val 1)) (Mul (Var "t") (Val (-1))))) (Val 1)) (Val 1)))) (Add (Neg (Add (Val 0) (Var "k"))) (Mul (Neg (Div (Sub (Sub (Var "u") (Val 1)) (Val 1)) (Sub (Neg (Var "")) (Sub (Var "b") (Val (-1)))))) (Neg (Var ""))))) (Val 0)))))) (Val 0)) (Var "a")) (Var "")) (Val (-1)),Var "xijsnp",Div (Var "h") (Neg (Val 5)),Div (Var "dmzlh") (Add (Val 6) (Val (-2))),Neg (Add (Val 0) (Var "")),Add (Add (Add (Sub (Val 4) (Var "nfse")) (Var "o")) (Add (Val 2) (Div (Var "mtqdx") (Val (-3))))) (Val 3),Neg (Var "c"),Var "sr",Mul (Add (Sub (Neg (Val 1)) (Sub (Div (Add (Sub (Add (Sub (Sub (Var "gd") (Mul (Var "v") (Var "d"))) (Var "")) (Val 1)) (Add (Val 2) (Var ""))) (Var "kk")) (Div (Var "fw") (Add (Val 1) (Var "f")))) (Var ""))) (Val 2)) (Add (Neg (Div (Var "") (Val 0))) (Add (Var "") (Add (Var "s") (Add (Mul (Var "") (Val (-1))) (Val 1))))),Val 1,Var "",Sub (Var "vbnzahx") (Val (-5)),Var "nl",Val 0,Add (Mul (Neg (Mul (Var "") (Var "mvil"))) (Var "")) (Neg (Var "zxl")),Val (-3),Var "",Var "e",Add (Div (Sub (Val 0) (Add (Val 5) (Val 7))) (Mul (Var "") (Var "qz"))) (Val 4),Add (Val (-1)) (Neg (Var "lk")),Add (Add (Var "u") (Mul (Val 1) (Var "h"))) (Sub (Mul (Div (Val 1) (Div (Var "t") (Neg (Var "")))) (Var "")) (Mul (Val 1) (Neg (Div (Neg (Var "")) (Var ""))))),Val 0,Val 0,Val (-7),Mul (Var "") (Val 0),Mul (Add (Val (-6)) (Add (Val 2) (Sub (Div (Var "z") (Var "gbb")) (Var "vddnpsl")))) (Add (Add (Add (Var "") (Sub (Div (Val 3) (Neg (Div (Add (Var "cfvgz") (Add (Sub (Var "htd") (Sub (Var "mhbl") (Var "un"))) (Val 3))) (Val (-3))))) (Var ""))) (Val 5)) (Neg (Mul (Val 0) (Var "sufvvj")))),Sub (Div (Neg (Add (Add (Neg (Add (Var "") (Val 0))) (Var "")) (Sub (Val 0) (Val 0)))) (Val 0)) (Add (Neg (Div (Div (Add (Sub (Add (Add (Neg (Var "")) (Val 0)) (Val 0)) (Add (Neg (Add (Neg (Var "")) (Neg (Val 0)))) (Val 0))) (Div (Val 0) (Val 0))) (Val 0)) (Val 0))) (Var "")),Var "",Sub (Div (Val 0) (Div (Add (Val 1) (Neg (Div (Neg (Var "y")) (Val 0)))) (Var ""))) (Sub (Div (Var "t") (Var "")) (Neg (Var "s"))),Mul (Div (Sub (Var "") (Var "")) (Add (Val 0) (Sub (Div (Var "yr") (Neg (Var "o"))) (Val 1)))) (Var "u"),Var "odmn",Div (Var "uddqy") (Val 3),Var "",Sub (Val 2) (Neg (Val (-1))),Div (Mul (Var "sox") (Val (-3))) (Val (-3)),Var "qv",Var "xmbnts",Var "j",Mul (Val 6) (Mul (Var "fryndq") (Neg (Val 6))),Var "",Var "",Val (-1),Val 7,Add (Var "dg") (Val 1),Neg (Val 1),Val 0,Var "xnm",Sub (Div (Div (Var "miwi") (Var "mbh")) (Val 3)) (Val 3),Neg (Val (-4)),Var "ndubxoa",Var ""]
− benchmarks/unsafe.hs
@@ -1,63 +0,0 @@-{-# LANGUAGE BangPatterns #-}-module Main where--import Control.Lens-import Control.Lens.Internal-import Control.Exception--import Criterion.Main-import Criterion.Config--import GHC.Exts--overS :: ASetter s t a b -> (a -> b) -> s -> t-overS l f = runMutator . l (Mutator . f)-{-# INLINE overS #-}--mappedS :: ASetter [a] [b] a b-mappedS f = Mutator . map (runMutator . f)-{-# INLINE mappedS #-}--overU :: ASetter s t a b -> (a -> b) -> s -> t-overU = over-{-# INLINE overU #-}--mappedU :: ASetter [a] [b] a b-mappedU = mapped-{-# INLINE mappedU #-}----- Need to eta-expand for full inlining in the NOINLINE cases?--- Doesn't seem to make a difference, though.--mapSN :: (a -> b) -> [a] -> [b]-mapSN f l = overS mappedS f l-{-# NOINLINE mapSN #-}--mapSI :: (a -> b) -> [a] -> [b]-mapSI f = overS mappedS f-{-# INLINE mapSI #-}--mapUN :: (a -> b) -> [a] -> [b]-mapUN f l = overU mappedU f l-{-# NOINLINE mapUN #-}--mapUI :: (a -> b) -> [a] -> [b]-mapUI f = overU mappedU f-{-# INLINE mapUI #-}--main :: IO ()-main = do- let n = 1000- l = replicate n "hi"; f = length- --l = replicate n (); f = (\ _ -> ())- --l = replicate n (); f = (\ !_ -> ()) -- strange results- --l = replicate n (); f = lazy (\_ -> ())- defaultMainWith config (return ())- [ bench "map safe noinline" $ nf (mapSN f) l- , bench "map safe inline" $ nf (mapSI f) l- , bench "map unsafe noinline" $ nf (mapUN f) l- , bench "map unsafe inline" $ nf (mapUI f) l- ]- where- config = defaultConfig { cfgSamples = ljust 1000 }
− benchmarks/zipper.hs
@@ -1,45 +0,0 @@-module Main- ( main -- :: IO ()- ) where--import Control.Lens-import Criterion.Main--main :: IO ()-main = defaultMain- [ bgroup "rezip"- [ bench "rezip" $ nf tugAndRezip1 ['a'..'z']- , bench "farthest leftward" $ nf tugAndRezip2 ['a'..'z']- , bench "leftmost" $ nf tugAndRezip3 ['a'..'z']- , bench "tugTo" $ nf tugAndRezip4 ['a'..'z']- ]- , bgroup "zipper creation"- [ bench "over traverse id" $ nf (over traverse id) ['a'..'z']- , bench "zipper" $ nf zipTraverseRezip ['a'..'z']- ]- , bgroup "downward"- [ bench "downward _1" $ nf downwardAndRezip1 (['a'..'z'],['z'..'a'])- , bench "fromWithin" $ nf downwardAndRezip2 (['a'..'z'],['z'..'a'])- ]- ]---- What's the fastest rezip of all?-tugAndRezip1, tugAndRezip2, tugAndRezip3 :: String -> String-tugAndRezip1 xs = zipntugs 25 xs & focus .~ 'a' & rezip-tugAndRezip2 xs = zipntugs 25 xs & focus .~ 'b' & farthest leftward & rezip-tugAndRezip3 xs = zipntugs 25 xs & focus .~ 'c' & leftmost & rezip-tugAndRezip4 xs = zipntugs 25 xs & focus .~ 'd' & tugTo 0 & rezip--zipntugs i x = zipper x & fromWithin traverse & tugs rightward i---- How fast is creating and destroying a zipper compared to--- a regular traversal?-zipTraverseRezip x = zipper x & fromWithin traverse & rezip---- is 'downward' any faster than the composition of traverse?-downwardAndRezip1 :: (String, String) -> (String, String)-downwardAndRezip1 xs =- zipper xs & downward _1 & fromWithin traverse & focus .~ 'h' & rezip-downwardAndRezip2 :: (String, String) -> (String, String)-downwardAndRezip2 xs =- zipper xs & fromWithin (_1.traverse) & focus .~ 'g' & rezip
lens.cabal view
@@ -1,6 +1,6 @@ name: lens category: Data, Lenses-version: 3.8.2+version: 3.8.3 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE
src/Control/Exception/Lens.hs view
@@ -125,7 +125,7 @@ -- the desired 'Exception'. -- -- @--- exception :: ('Applicative' f, 'Exception' a, 'Exception' b)+-- 'exception' :: ('Applicative' f, 'Exception' a, 'Exception' b) -- => (a -> f b) -> 'SomeException' -> f 'SomeException' -- @ exception :: Exception a => Prism' SomeException a@@ -224,9 +224,9 @@ -- Trying ------------------------------------------------------------------------------ --- | A variant of 'CatchIO.try' that takes an 'Prism' (or any 'Getter') to select which--- exceptions are caught (c.f. 'tryJust', 'catchJust'). If the 'Exception' does--- not match the predicate, it is re-thrown.+-- | A variant of 'Control.Exception.try' that takes a 'Prism' (or any 'Getter') to select which+-- exceptions are caught (c.f. 'Control.Exception.tryJust', 'Control.Exception.catchJust'). If the+-- 'Exception' does not match the predicate, it is re-thrown. -- -- @ -- 'trying' :: 'MonadCatchIO' m => 'Prism'' 'SomeException' a -> m r -> m ('Either' a r)@@ -239,11 +239,11 @@ trying :: MonadCatchIO m => Getting (First a) SomeException t a b -> m r -> m (Either a r) trying l = tryJust (preview l) --- | A helper version of 'CatchIO.try' that doesn't needlessly require 'Functor'.+-- | A helper version of 'Control.Exception.try' that doesn't needlessly require 'Functor'. try :: (MonadCatchIO m, Exception e) => m a -> m (Either e a) try a = CatchIO.catch (liftM Right a) (return . Left) --- | A helper version of 'CatchIO.tryJust' that doesn't needlessly require 'Functor'.+-- | A helper version of 'Control.Exception.tryJust' that doesn't needlessly require 'Functor'. tryJust :: (MonadCatchIO m, Exception e) => (e -> Maybe b) -> m a -> m (Either b a) tryJust p a = do r <- try a@@ -260,7 +260,9 @@ -- | Throw an 'Exception' described by a 'Prism'. Exceptions may be thrown from -- purely functional code, but may only be caught within the 'IO' 'Monad'. ----- @'throwing' l ≡ 'reviews' l 'throw'@+-- @+-- 'throwing' l ≡ 'reviews' l 'throw'+-- @ -- -- @ -- 'throwing' :: 'Prism'' 'SomeException' t -> t -> a@@ -278,7 +280,7 @@ -- 'throwing', the two functions are subtly different: -- -- @--- 'throwing' l e \`seq\` x ≡ 'throwing' e+-- 'throwing' l e \`seq\` x ≡ 'throwing' e -- 'throwingM' l e \`seq\` x ≡ x -- @ --@@ -289,7 +291,9 @@ -- within the 'Monad' because it guarantees ordering with respect to other -- monadic operations, whereas 'throwing' does not. ----- @'throwingM' l ≡ 'reviews' l 'CatchIO.throw'@+-- @+-- 'throwingM' l ≡ 'reviews' l 'CatchIO.throw'+-- @ -- -- @ -- 'throwingM' :: 'MonadCatchIO' m => 'Prism'' 'SomeException' t -> t -> m a@@ -301,8 +305,9 @@ -- | 'throwingTo' raises an 'Exception' specified by a 'Prism' in the target thread. ----- @'throwingTo' thread l ≡ 'reviews' l ('throwTo' thread)@---+-- @+-- 'throwingTo' thread l ≡ 'reviews' l ('throwTo' thread)+-- @ -- -- @ -- 'throwingTo' :: 'ThreadId' -> 'Prism'' 'SomeException' t -> t -> m a@@ -363,7 +368,9 @@ -- | Handle arithmetic '_Overflow'. ----- @'_Overflow' ≡ '_ArithException' '.' '_Overflow'@+-- @+-- '_Overflow' ≡ '_ArithException' '.' '_Overflow'+-- @ -- -- @ -- '_Overflow' :: 'Prism'' 'ArithException' 'ArithException'@@ -377,7 +384,9 @@ -- | Handle arithmetic '_Underflow'. ----- @'_Underflow' ≡ '_ArithException' '.' '_Underflow'@+-- @+-- '_Underflow' ≡ '_ArithException' '.' '_Underflow'+-- @ -- -- @ -- '_Underflow' :: 'Prism'' 'ArithException' 'ArithException'@@ -391,7 +400,9 @@ -- | Handle arithmetic loss of precision. ----- @'_LossOfPrecision' ≡ '_ArithException' '.' '_LossOfPrecision'@+-- @+-- '_LossOfPrecision' ≡ '_ArithException' '.' '_LossOfPrecision'+-- @ -- -- @ -- '_LossOfPrecision' :: 'Prism'' 'ArithException' 'ArithException'@@ -405,7 +416,9 @@ -- | Handle division by zero. ----- @'_DivideByZero' ≡ '_ArithException' '.' '_DivideByZero'@+-- @+-- '_DivideByZero' ≡ '_ArithException' '.' '_DivideByZero'+-- @ -- -- @ -- '_DivideByZero' :: 'Prism'' 'ArithException' 'ArithException'@@ -419,7 +432,9 @@ -- | Handle exceptional _Denormalized floating point. ----- @'_Denormal' ≡ '_ArithException' '.' '_Denormal'@+-- @+-- '_Denormal' ≡ '_ArithException' '.' '_Denormal'+-- @ -- -- @ -- '_Denormal' :: 'Prism'' 'ArithException' 'ArithException'@@ -436,7 +451,9 @@ -- -- <http://haskell.1045720.n5.nabble.com/Data-Ratio-and-exceptions-td5711246.html> ----- @'_RatioZeroDenominator' ≡ '_ArithException' '.' '_RatioZeroDenominator'@+-- @+-- '_RatioZeroDenominator' ≡ '_ArithException' '.' '_RatioZeroDenominator'+-- @ -- -- @ -- '_RatioZeroDenominator' :: 'Prism'' 'ArithException' 'ArithException'@@ -474,7 +491,9 @@ -- | An attempt was made to index an array outside its declared bounds. ----- @'_IndexOutOfBounds' ≡ '_ArrayException' '.' '_IndexOutOfBounds'@+-- @+-- '_IndexOutOfBounds' ≡ '_ArrayException' '.' '_IndexOutOfBounds'+-- @ -- -- @ -- '_IndexOutOfBounds' :: 'Prism'' 'ArrayException' 'String'@@ -488,7 +507,9 @@ -- | An attempt was made to evaluate an element of an array that had not been initialized. ----- @'_UndefinedElement' ≡ '_ArrayException' '.' '_UndefinedElement'@+-- @+-- '_UndefinedElement' ≡ '_ArrayException' '.' '_UndefinedElement'+-- @ -- -- @ -- '_UndefinedElement' :: 'Prism'' 'ArrayException' 'String'@@ -506,7 +527,7 @@ -- | 'assert' was applied to 'Prelude.False'. class AsAssertionFailed p f t where- -- | This exception contains provides information about what assertion failed in the string.+ -- | This 'Exception' contains provides information about what assertion failed in the 'String'. -- -- >>> handling _AssertionFailed (\ xs -> "caught" <$ guard ("<interactive>" `isInfixOf` xs) ) $ assert False (return "uncaught") -- "caught"@@ -616,7 +637,7 @@ -- not to terminate. Note that there is no guarantee that the runtime system -- will notice whether any given computation is guaranteed to terminate or not. class (Profunctor p, Functor f) => AsNonTermination p f t where- -- | There is no additional information carried in a 'NonTermination' exception.+ -- | There is no additional information carried in a 'NonTermination' 'Exception'. -- -- @ -- '_NonTermination' :: 'Iso'' 'NonTermination' ()@@ -639,7 +660,7 @@ -- | Thrown when the program attempts to call atomically, from the -- 'Control.Monad.STM' package, inside another call to atomically. class (Profunctor p, Functor f) => AsNestedAtomically p f t where- -- | There is no additional information carried in a 'NestedAtomically' exception.+ -- | There is no additional information carried in a 'NestedAtomically' 'Exception'. -- -- @ -- '_NestedAtomically' :: 'Iso'' 'NestedAtomically' ()@@ -663,7 +684,7 @@ -- are no other references to the 'Control.Concurrent.MVar.MVar' so it can't -- ever continue. class (Profunctor p, Functor f) => AsBlockedIndefinitelyOnMVar p f t where- -- | There is no additional information carried in a 'BlockedIndefinitelyOnMVar' exception.+ -- | There is no additional information carried in a 'BlockedIndefinitelyOnMVar' 'Exception'. -- -- @ -- '_BlockedIndefinitelyOnMVar' :: 'Iso'' 'BlockedIndefinitelyOnMVar' ()@@ -687,7 +708,7 @@ -- but there are no other references to any TVars involved, so it can't ever -- continue. class (Profunctor p, Functor f) => AsBlockedIndefinitelyOnSTM p f t where- -- | There is no additional information carried in a 'BlockedIndefinitelyOnSTM' exception.+ -- | There is no additional information carried in a 'BlockedIndefinitelyOnSTM' 'Exception'. -- -- @ -- '_BlockedIndefinitelyOnSTM' :: 'Iso'' 'BlockedIndefinitelyOnSTM' ()@@ -710,7 +731,7 @@ -- | There are no runnable threads, so the program is deadlocked. The -- 'Deadlock' 'Exception' is raised in the main thread only. class (Profunctor p, Functor f) => AsDeadlock p f t where- -- | There is no information carried in a 'Deadlock' exception.+ -- | There is no information carried in a 'Deadlock' 'Exception'. -- -- @ -- '_Deadlock' :: 'Iso'' 'Deadlock' ()@@ -858,10 +879,10 @@ -- HandlingException ------------------------------------------------------------------------------ --- | This exception is thrown by @lens@ when the user somehow manages to rethrow--- an internal handling exception.+-- | This 'Exception' is thrown by @lens@ when the user somehow manages to rethrow+-- an internal 'HandlingException'. class (Profunctor p, Functor f) => AsHandlingException p f t where- -- | There is no information carried in a 'HandlingException' exception.+ -- | There is no information carried in a 'HandlingException'. -- -- @ -- '_HandlingException' :: 'Iso'' 'HandlingException' ()
src/Control/Lens/Internal/Exception.hs view
@@ -47,11 +47,11 @@ -- 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)+ -- | 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)+ -- 'catches' ... [ 'handler' 'Control.Exception.Lens._AssertionFailed' (\s -> 'print' '$' \"Assertion Failed\\n\" '++' s)+ -- , 'handler' 'Control.Exception.Lens._ErrorCall' (\s -> 'print' '$' \"Error\\n\" '++' s) -- ] -- @ --@@ -86,7 +86,7 @@ -- @ 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)+ -- | 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. -- -- @@@ -144,13 +144,13 @@ -- Helpers ------------------------------------------------------------------------------ --- | There was exception caused by abusing the internals of a 'Handler'.+-- | There was an '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+-- 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@@ -167,7 +167,7 @@ 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.+-- 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 #-}
src/Control/Lens/Operators.hs view
@@ -31,6 +31,9 @@ , (^?), (^@?) , (^?!), (^@?!) + -- * Reviewing+ , (#)+ -- * Common Operators -- ** Setting , (.~) , (.=)@@ -100,6 +103,7 @@ import Control.Lens.Getter import Control.Lens.Indexed import Control.Lens.Lens+import Control.Lens.Review import Control.Lens.Setter import Control.Lens.Zipper
src/Control/Lens/Review.hs view
@@ -24,6 +24,7 @@ , re , review, reviews , reuse, reuses+ , (#) -- * Reviewable Profunctors , Reviewable(..) ) where@@ -40,9 +41,12 @@ -- $setup -- >>> import Control.Lens+-- >>> import Numeric.Lens -- >>> let isLeft (Left _) = True; isLeft _ = False -- >>> let isRight (Right _) = True; isRight _ = False +infixr 9 #+ ------------------------------------------------------------------------------ -- Review ------------------------------------------------------------------------------@@ -130,6 +134,32 @@ review :: MonadReader b m => AReview s t a b -> m t review p = asks (runIdentity #. runReviewed #. p .# Reviewed .# Identity) {-# INLINE review #-}++-- | An infix alias for 'review'.+--+-- @+-- 'unto' f '#' x ≡ f x+-- l '#' x ≡ x '^.' 're' l+-- @+--+-- This is commonly used when using a 'Prism' as a smart constructor.+--+-- >>> _Left # 4+-- Left 4+--+-- But it can be used for any 'Prism'+--+-- >>> base 16 # 123+-- "7b"+--+-- @+-- ('#') :: 'Iso'' s a -> a -> s+-- ('#') :: 'Prism'' s a -> a -> s+-- ('#') :: 'Review'' s a -> a -> s+-- ('#') :: 'Equality'' s a -> a -> s+-- @+(#) :: AReview s t a b -> b -> t+(#) p = runIdentity #. runReviewed #. p .# Reviewed .# Identity -- | This can be used to turn an 'Control.Lens.Iso.Iso' or 'Prism' around and 'view' a value (or the current environment) through it the other way, -- applying a function.
src/Data/ByteString/Lazy/Lens.hs view
@@ -8,11 +8,11 @@ -- Stability : experimental -- Portability : non-portable ----- Lenses for lazy bytestrings+-- Lazy 'ByteString' lenses. ---------------------------------------------------------------------------- module Data.ByteString.Lazy.Lens- ( packedBytes, bytes- , packedChars, chars+ ( packedBytes, unpackedBytes, bytes+ , packedChars, unpackedChars, chars ) where import Control.Lens@@ -24,18 +24,45 @@ -- | 'Data.ByteString.Lazy.pack' (or 'Data.ByteString.Lazy.unpack') a list of bytes into a 'ByteString'. ----- @'Data.ByteString.Lazy.pack' x = x '^.' 'packedBytes'@+-- @+-- 'packedBytes' ≡ 'from' 'unpackedBytes'+-- 'Data.ByteString.pack' x ≡ x '^.' 'packedBytes'+-- 'Data.ByteString.unpack' x ≡ x '^.' 'from' 'packedBytes'+-- @ ----- @'Data.ByteString.Lazy.unpack' x = x '^.' 'from' 'packedBytes'@+-- >>> [104,101,108,108,111]^.packedBytes+-- "hello" packedBytes :: Iso' [Word8] ByteString packedBytes = iso Words.pack unpackLazy {-# INLINE packedBytes #-} +-- | 'Data.ByteString.Lazy.unpack' (or 'Data.ByteString.Lazy.pack') a 'ByteString' into a list of bytes+--+-- @+-- 'unpackedBytes' ≡ 'from' 'packedBytes'+-- 'Data.ByteString.unpack' x ≡ x '^.' 'unpackedBytes'+-- 'Data.ByteString.pack' x ≡ x '^.' 'from' 'unpackedBytes'+-- @+--+-- >>> "hello"^.packedChars.unpackedBytes+-- [104,101,108,108,111]+unpackedBytes :: Iso' ByteString [Word8]+unpackedBytes = from packedBytes+{-# INLINE unpackedBytes #-}+ -- | Traverse the individual bytes in a 'ByteString'. ----- @'bytes' = 'from' 'packedBytes' '.' 'itraversed'@+-- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion+-- enable zippers to seek to locations more quickly and accelerate+-- many monoidal queries, but up to associativity (and constant factors) it is+-- equivalent to the much slower: ----- @'anyOf' 'bytes' ('==' 0x80) :: 'ByteString' -> 'Bool'@+-- @+-- 'bytes' ≡ 'unpackedBytes' '.' 'traversed'+-- @+--+-- >>> anyOf bytes (== 0x80) (Char8.pack "hello")+-- False bytes :: IndexedTraversal' Int64 ByteString Word8 bytes = traversedLazy {-# INLINE bytes #-}@@ -43,23 +70,53 @@ -- | 'Data.ByteString.Lazy.Char8.pack' (or 'Data.ByteString.Lazy.Char8.unpack') a list of characters into a 'ByteString'. -- -- When writing back to the 'ByteString' it is assumed that every 'Char'--- lies between '\x00' and '\xff'.+-- lies between @'\x00'@ and @'\xff'@. ----- @'Data.ByteString.Lazy.Char8.pack' x = x '^.' 'packedChars'@+-- @+-- 'packedChars' ≡ 'from' 'unpackedChars'+-- 'Data.ByteString.Char8.pack' x ≡ x '^.' 'packedChars'+-- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'from' 'packedChars'+-- @ ----- @'Data.ByteString.Lazy.Char8.unpack' x = x '^.' 'from' 'packedChars'@+-- >>> "hello"^.packedChars.each.re (base 16 . enum).to (\x -> if length x == 1 then '0':x else x)+-- "68656c6c6f" packedChars :: Iso' String ByteString packedChars = iso Char8.pack unpackLazy8 {-# INLINE packedChars #-} +-- | 'Data.ByteString.Lazy.Char8.unpack' (or 'Data.ByteString.Lazy.Char8.pack') a list of characters into a 'ByteString'+--+-- When writing back to the 'ByteString' it is assumed that every 'Char'+-- lies between @'\x00'@ and @'\xff'@.+--+-- @+-- 'unpackedChars' ≡ 'from' 'packedChars'+-- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'unpackedChars'+-- 'Data.ByteString.Char8.pack' x ≡ x '^.' 'from' 'unpackedChars'+-- @+--+-- >>> [104,101,108,108,111]^.packedBytes.unpackedChars+-- "hello"+unpackedChars :: Iso' ByteString String+unpackedChars = from packedChars+{-# INLINE unpackedChars #-}+ -- | Traverse the individual bytes in a 'ByteString' as characters. -- -- When writing back to the 'ByteString' it is assumed that every 'Char'--- lies between '\x00' and '\xff'.+-- lies between @'\x00'@ and @'\xff'@. ----- @'chars' = 'from' 'packedChars' '.' 'itraversed'@+-- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion+-- enable zippers to seek to locations more quickly and accelerate+-- many monoidal queries, but up to associativity (and constant factors) it is+-- equivalent to: ----- @'anyOf' 'chars' ('==' \'c\') :: 'ByteString' -> 'Bool'@+-- @+-- 'chars' = 'unpackedChars' '.' 'traversed'+-- @+--+-- >>> anyOf chars (== 'h') "hello"+-- True chars :: IndexedTraversal' Int64 ByteString Char chars = traversedLazy8 {-# INLINE chars #-}
src/Data/ByteString/Lens.hs view
@@ -11,6 +11,8 @@ ---------------------------------------------------------------------------- module Data.ByteString.Lens ( IsByteString(..)+ , unpackedBytes+ , unpackedChars ) where import Control.Lens@@ -24,26 +26,40 @@ class IsByteString t where -- | 'Data.ByteString.pack' (or 'Data.ByteString.unpack') a list of bytes into a strict or lazy 'ByteString'. --- -- @'Data.ByteString.pack' x = x '^.' 'packedBytes'@- --- -- @'Data.ByteString.unpack' x = x '^.' 'from' 'packedBytes'@+ -- @+ -- 'Data.ByteString.pack' x ≡ x '^.' 'packedBytes'+ -- 'Data.ByteString.unpack' x ≡ x '^.' 'from' 'packedBytes'+ -- 'packedBytes' ≡ 'from' 'unpackedBytes'+ -- @ packedBytes :: Iso' [Word8] t -- | 'Data.ByteString.Char8.pack' (or 'Data.ByteString.Char8.unpack') a list of characters into a strict or lazy 'ByteString'. -- -- When writing back to the 'ByteString' it is assumed that every 'Char'- -- lies between '\x00' and '\xff'.- --- -- @'Data.ByteString.Char8.pack' x = x '^.' 'packedChars'@+ -- lies between @'\x00'@ and @'\xff'@. --- -- @'Data.ByteString.Char8.unpack' x = x '^.' 'from' 'packedChars'@+ -- @+ -- 'Data.ByteString.Char8.pack' x ≡ x '^.' 'packedChars'+ -- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'from' 'packedChars'+ -- 'packedChars' ≡ 'from' 'unpackedChars'+ -- @ packedChars :: Iso' String t -- | Traverse each 'Word8' in a strict or lazy 'ByteString' --- -- @'bytes' = 'from' 'packedBytes' '.' 'itraversed'@ --- -- @'anyOf' 'bytes' ('==' 0x80) :: 'ByteString' -> 'Bool'@+ -- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion+ -- enable zippers to seek to locations more quickly and accelerate+ -- many monoidal queries, but up to associativity (and constant factors) it is+ -- equivalent to the much slower:+ --+ -- @+ -- 'bytes' ≡ 'unpackedBytes' '.' 'traversed'+ -- @+ --+ -- @+ -- 'anyOf' 'bytes' ('==' 0x80) :: 'ByteString' -> 'Bool'+ -- @ bytes :: IndexedTraversal' Int t Word8 bytes = from packedBytes . traversed {-# INLINE bytes #-}@@ -51,14 +67,58 @@ -- | Traverse the individual bytes in a strict or lazy 'ByteString' as characters. -- -- When writing back to the 'ByteString' it is assumed that every 'Char'- -- lies between '\x00' and '\xff'.+ -- lies between @'\x00'@ and @'\xff'@. --- -- @'chars' = 'from' 'packedChars' '.' 'traverse'@+ -- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion+ -- enable zippers to seek to locations more quickly and accelerate+ -- many monoidal queries, but up to associativity (and constant factors) it is+ -- equivalent to the much slower: --- -- @'anyOf' 'chars' ('==' \'c\') :: 'ByteString' -> 'Bool'@+ -- @+ -- 'chars' ≡ 'unpackedChars' '.' 'traversed'+ -- @+ --+ -- @+ -- 'anyOf' 'chars' ('==' \'c\') :: 'ByteString' -> 'Bool'+ -- @ chars :: IndexedTraversal' Int t Char chars = from packedChars . traversed {-# INLINE chars #-}++-- | 'Data.ByteString.unpack' (or 'Data.ByteString.pack') a 'ByteString' into a list of bytes+--+-- @+-- 'unpackedBytes' ≡ 'from' 'packedBytes'+-- 'Data.ByteString.unpack' x ≡ x '^.' 'unpackedBytes'+-- 'Data.ByteString.pack' x ≡ x '^.' 'from' 'unpackedBytes'+-- @+--+-- @+-- 'unpackedBytes' :: 'Iso'' 'Data.ByteString.ByteString' ['Word8']+-- 'unpackedBytes' :: 'Iso'' 'Data.ByteString.Lazy.ByteString' ['Word8']+-- @+unpackedBytes :: IsByteString t => Iso' t [Word8]+unpackedBytes = from packedBytes+{-# INLINE unpackedBytes #-}++-- | 'Data.ByteString.Char8.unpack' (or 'Data.ByteString.Char8.pack') a list of characters into a strict (or lazy) 'ByteString'+--+-- When writing back to the 'ByteString' it is assumed that every 'Char'+-- lies between @'\x00'@ and @'\xff'@.+--+-- @+-- 'unpackedChars' ≡ 'from' 'packedChars'+-- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'unpackedChars'+-- 'Data.ByteString.Char8.pack' x ≡ x '^.' 'from' 'unpackedChars'+-- @+--+-- @+-- 'unpackedChars' :: 'Iso'' 'Data.ByteString.ByteString' 'String'+-- 'unpackedChars' :: 'Iso'' 'Data.ByteString.Lazy.ByteString' 'String'+-- @+unpackedChars :: IsByteString t => Iso' t String+unpackedChars = from packedChars+{-# INLINE unpackedChars #-} instance IsByteString Strict.ByteString where packedBytes = Strict.packedBytes
src/Data/ByteString/Strict/Lens.hs view
@@ -12,8 +12,8 @@ -- ---------------------------------------------------------------------------- module Data.ByteString.Strict.Lens- ( packedBytes, bytes- , packedChars, chars+ ( packedBytes, unpackedBytes, bytes+ , packedChars, unpackedChars, chars ) where import Control.Lens@@ -27,18 +27,45 @@ -- | 'Data.ByteString.pack' (or 'Data.ByteString.unpack') a list of bytes into a 'ByteString' ----- @'Data.ByteString.pack' x = x '^.' 'packedBytes'@+-- @+-- 'packedBytes' ≡ 'from' 'unpackedBytes'+-- 'Data.ByteString.pack' x ≡ x '^.' 'packedBytes'+-- 'Data.ByteString.unpack' x ≡ x '^.' 'from' 'packedBytes'+-- @ ----- @'Data.ByteString.unpack' x = x '^.' 'from' 'packedBytes'@+-- >>> [104,101,108,108,111]^.packedBytes+-- "hello" packedBytes :: Iso' [Word8] ByteString packedBytes = iso Words.pack unpackStrict {-# INLINE packedBytes #-} +-- | 'Data.ByteString.unpack' (or 'Data.ByteString.pack') a 'ByteString' into a list of bytes+--+-- @+-- 'unpackedBytes' ≡ 'from' 'packedBytes'+-- 'Data.ByteString.unpack' x ≡ x '^.' 'unpackedBytes'+-- 'Data.ByteString.pack' x ≡ x '^.' 'from' 'unpackedBytes'+-- @+--+-- >>> "hello"^.packedChars.unpackedBytes+-- [104,101,108,108,111]+unpackedBytes :: Iso' ByteString [Word8]+unpackedBytes = from packedBytes+{-# INLINE unpackedBytes #-}+ -- | Traverse each 'Word8' in a 'ByteString'. ----- @'bytes' = 'from' 'packedBytes' '.' 'itraversed'@+-- This 'Traversal' walks the 'ByteString' in a tree-like fashion+-- enable zippers to seek to locations in logarithmic time and accelerating+-- many monoidal queries, but up to associativity (and constant factors)+-- it is equivalent to the much slower: ----- @'anyOf' 'bytes' ('==' 0x80) :: 'ByteString' -> 'Bool'@+-- @+-- 'bytes' ≡ 'unpackedBytes' '.' 'traversed'+-- @+--+-- >>> anyOf bytes (== 0x80) (Char8.pack "hello")+-- False bytes :: IndexedTraversal' Int ByteString Word8 bytes = traversedStrictTree 0 {-# INLINE bytes #-}@@ -46,23 +73,53 @@ -- | 'Data.ByteString.Char8.pack' (or 'Data.ByteString.Char8.unpack') a list of characters into a 'ByteString' -- -- When writing back to the 'ByteString' it is assumed that every 'Char'--- lies between '\x00' and '\xff'.+-- lies between @'\x00'@ and @'\xff'@. ----- @'Data.ByteString.Char8.pack' x = x '^.' 'packedChars'@+-- @+-- 'packedChars' ≡ 'from' 'unpackedChars'+-- 'Data.ByteString.Char8.pack' x ≡ x '^.' 'packedChars'+-- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'from' 'packedChars'+-- @ ----- @'Data.ByteString.Char8.unpack' x = x '^.' 'from' 'packedChars'@+-- >>> "hello"^.packedChars.each.re (base 16 . enum).to (\x -> if length x == 1 then '0':x else x)+-- "68656c6c6f" packedChars :: Iso' String ByteString packedChars = iso Char8.pack unpackStrict8 {-# INLINE packedChars #-} +-- | 'Data.ByteString.Char8.unpack' (or 'Data.ByteString.Char8.pack') a list of characters into a 'ByteString'+--+-- When writing back to the 'ByteString' it is assumed that every 'Char'+-- lies between @'\x00'@ and @'\xff'@.+--+-- @+-- 'unpackedChars' ≡ 'from' 'packedChars'+-- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'unpackedChars'+-- 'Data.ByteString.Char8.pack' x ≡ x '^.' 'from' 'unpackedChars'+-- @+--+-- >>> [104,101,108,108,111]^.packedBytes.unpackedChars+-- "hello"+unpackedChars :: Iso' ByteString String+unpackedChars = from packedChars+{-# INLINE unpackedChars #-}+ -- | Traverse the individual bytes in a 'ByteString' as characters. -- -- When writing back to the 'ByteString' it is assumed that every 'Char'--- lies between '\x00' and '\xff'.+-- lies between @'\x00'@ and @'\xff'@. ----- @'chars' = 'from' 'packedChars' '.' 'traverse'@+-- This 'Traversal' walks the 'ByteString' in a tree-like fashion+-- enable zippers to seek to locations in logarithmic time and accelerating+-- many monoidal queries, but up to associativity (and constant factors)+-- it is equivalent to the much slower: ----- @'anyOf' 'chars' ('==' \'c\') :: 'ByteString' -> 'Bool'@+-- @+-- 'chars' = 'unpackedChars' '.' 'traverse'+-- @+--+-- >>> anyOf chars (== 'h') "hello"+-- True chars :: IndexedTraversal' Int ByteString Char chars = traversedStrictTree8 0 {-# INLINE chars #-}
src/Data/List/Lens.hs view
@@ -14,9 +14,12 @@ ---------------------------------------------------------------------------- module Data.List.Lens ( strippingPrefix+ , strippingSuffix, stripSuffix ) where +import Control.Monad (guard) import Control.Lens+import Data.Functor import Data.List -- $setup@@ -39,3 +42,30 @@ strippingPrefix :: Eq a => [a] -> Prism' [a] [a] strippingPrefix ps = prism' (ps ++) (stripPrefix ps) {-# INLINE strippingPrefix #-}++-- | A 'Prism' stripping a suffix from a list when used as a 'Traversal', or+-- prepending that prefix when run backwards:+--+-- >>> "review" ^? strippingSuffix "view"+-- Just "re"+--+-- >>> "review" ^? strippingSuffix "tire"+-- Nothing+--+-- >>> "hello"^.re (strippingSuffix ".o")+-- "hello.o"+strippingSuffix :: Eq a => [a] -> Prism' [a] [a]+strippingSuffix qs = prism' (++ qs) (stripSuffix qs)+{-# INLINE strippingSuffix #-}++stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]+stripSuffix qs xs0 = go xs0 zs+ where+ zs = drp qs xs0+ drp (_:ps) (_:xs) = drp ps xs+ drp [] xs = xs+ drp _ [] = []+ go (_:xs) (_:ys) = go xs ys+ go xs [] = zipWith const xs0 zs <$ guard (xs == qs)+ go [] _ = Nothing -- impossible+{-# INLINE stripSuffix #-}
src/Data/Text/Lazy/Lens.hs view
@@ -15,7 +15,7 @@ -- ---------------------------------------------------------------------------- module Data.Text.Lazy.Lens- ( packed+ ( packed, unpacked , text , builder ) where@@ -24,21 +24,47 @@ import Data.Text.Lazy import Data.Text.Lazy.Builder --- | Pack (or unpack) lazy 'Text'.+-- $setup+-- >>> :set -XOverloadedStrings++-- | This isomorphism can be used to 'pack' (or 'unpack') lazy 'Text'. --+-- >>> "hello"^.packed -- :: Text+-- "hello"+-- -- @--- 'pack' x = x '^.' 'packed'--- 'unpack' x = x '^.' 'from' 'packed'+-- 'pack' x ≡ x '^.' 'packed'+-- 'unpack' x ≡ x '^.' 'from' 'packed'+-- 'packed' ≡ 'from' 'unpacked' -- @ packed :: Iso' String Text packed = iso pack unpack {-# INLINE packed #-} +-- | This isomorphism can be used to 'unpack' (or 'pack') lazy 'Text'.+--+-- >>> "hello"^.unpacked -- :: String+-- "hello"+--+-- @+-- 'pack' x ≡ x '^.' 'from' 'unpacked'+-- 'unpack' x ≡ x '^.' 'packed'+-- @+--+-- This 'Iso' is provided for notational convenience rather than out of great need, since+--+-- @+-- 'unpacked' ≡ 'from' 'packed'+-- @+unpacked :: Iso' Text String+unpacked = iso unpack pack+{-# INLINE unpacked #-}+ -- | Convert between lazy 'Text' and 'Builder' . -- -- @--- 'fromLazyText' x = x '^.' 'builder'--- 'toLazyText' x = x '^.' 'from' 'builder'+-- 'fromLazyText' x ≡ x '^.' 'builder'+-- 'toLazyText' x ≡ x '^.' 'from' 'builder' -- @ builder :: Iso' Text Builder builder = iso fromLazyText toLazyText@@ -46,7 +72,18 @@ -- | Traverse the individual characters in a 'Text'. ----- > anyOf text (=='c') :: Text -> Bool+-- >>> anyOf text (=='c') "chello"+-- True+--+-- @+-- 'text' = 'unpacked' . 'traversed'+-- @+--+-- When the type is unambiguous, you can also use the more general 'each'.+--+-- @+-- 'text' ≡ 'each'+-- @ text :: IndexedTraversal' Int Text Char-text = from packed . itraversed+text = unpacked . traversed {-# INLINE text #-}
src/Data/Text/Lens.hs view
@@ -14,7 +14,7 @@ -- ---------------------------------------------------------------------------- module Data.Text.Lens- ( IsText(..)+ ( IsText(..), unpacked ) where import Control.Lens@@ -26,25 +26,47 @@ -- | Traversals for strict or lazy 'Text' class IsText t where- -- | 'pack' (or 'unpack') strict or lazy 'Text'.+ -- | This isomorphism can be used to 'pack' (or 'unpack') strict or lazy 'Text'. -- -- @- -- 'pack' x = x '^.' 'packed'- -- 'unpack' x = x '^.' 'from' 'packed'+ -- 'pack' x ≡ x '^.' 'packed'+ -- 'unpack' x ≡ x '^.' 'from' 'packed'+ -- 'packed' ≡ 'from' 'unpacked' -- @ packed :: Iso' String t -- | Convert between strict or lazy 'Text' and a 'Builder'. -- -- @- -- 'fromText' x = x '^.' 'builder'+ -- 'fromText' x ≡ x '^.' 'builder' -- @ builder :: Iso' t Builder -- | Traverse the individual characters in strict or lazy 'Text'.+ --+ -- @+ -- 'text' = 'unpacked' . 'traversed'+ -- @ text :: IndexedTraversal' Int t Char- text = from packed . itraversed+ text = unpacked . traversed {-# INLINE text #-}++-- | This isomorphism can be used to 'unpack' (or 'pack') both strict or lazy 'Text'.+--+-- @+-- 'unpack' x ≡ x '^.' 'unpacked'+-- 'pack' x ≡ x '^.' 'from' 'unpacked'+-- @+--+-- This 'Iso' is provided for notational convenience rather than out of great need, since+--+-- @+-- 'unpacked' ≡ 'from' 'packed'+-- @+--+unpacked :: IsText t => Iso' t String+unpacked = from packed+{-# INLINE unpacked #-} instance IsText Strict.Text where packed = Strict.packed
src/Data/Text/Strict/Lens.hs view
@@ -14,7 +14,7 @@ -- ---------------------------------------------------------------------------- module Data.Text.Strict.Lens- ( packed+ ( packed, unpacked , builder , text ) where@@ -24,16 +24,43 @@ import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder --- | 'pack' (or 'unpack') strict 'Text'.+-- $setup+-- >>> :set -XOverloadedStrings++-- | This isomorphism can be used to 'pack' (or 'unpack') strict 'Text'. --+--+-- >>> "hello"^.packed -- :: Text+-- "hello"+-- -- @ -- 'pack' x ≡ x '^.' 'packed' -- 'unpack' x ≡ x '^.' 'from' 'packed'+-- 'packed' ≡ 'from' 'unpacked'+-- 'packed' ≡ 'iso' 'pack' 'unpack' -- @ packed :: Iso' String Text packed = iso pack unpack {-# INLINE packed #-} +-- | This isomorphism can be used to 'unpack' (or 'pack') lazy 'Text'.+--+-- >>> "hello"^.unpacked -- :: String+-- "hello"+--+-- This 'Iso' is provided for notational convenience rather than out of great need, since+--+-- @+-- 'unpacked' ≡ 'from' 'packed'+-- @+--+-- @+-- 'pack' x ≡ x '^.' 'from' 'unpacked'+-- 'unpack' x ≡ x '^.' 'packed'+-- 'unpacked' ≡ 'iso' 'unpack' 'pack'+-- @+unpacked :: Iso' Text String+unpacked = iso unpack pack -- | Convert between strict 'Text' and 'Builder' . --@@ -47,8 +74,15 @@ -- | Traverse the individual characters in strict 'Text'. ----- >>> anyOf text (=='o') $ "hello"^.packed+-- >>> anyOf text (=='o') "hello" -- True+--+-- When the type is unambiguous, you can also use the more general 'each'.+--+-- @+-- 'text' ≡ 'unpacked' . 'traversed'+-- 'text' ≡ 'each'+-- @ text :: IndexedTraversal' Int Text Char-text = from packed . itraversed+text = unpacked . traversed {-# INLINE text #-}
− tests/doctests.hsc
@@ -1,71 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ForeignFunctionInterface #-}--------------------------------------------------------------------------------- |--- Module : Main (doctests)--- Copyright : (C) 2012-13 Edward Kmett--- License : BSD-style (see the file LICENSE)--- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ This module provides doctests for a project based on the actual versions--- of the packages it was built with. It requires a corresponding Setup.lhs--- to be added to the project-------------------------------------------------------------------------------module Main where--import Build_doctests (deps)-import Control.Applicative-import Control.Monad-import Data.List-import System.Directory-import System.FilePath-import Test.DocTest--##if defined(i386_HOST_ARCH)-##define USE_CP-import Control.Applicative-import Control.Exception-import Foreign.C.Types-foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool-foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt-##elif defined(x64_64_HOST_ARCH)-##define USE_CP-import Control.Applicative-import Control.Exception-import Foreign.C.Types-foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool-foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt-##endif---- | Run in a modified codepage where we can print UTF-8 values on Windows.-withUnicode :: IO a -> IO a-##ifdef USE_CP-withUnicode m = do- cp <- c_GetConsoleCP- (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp-##else-withUnicode m = m-##endif--main :: IO ()-main = withUnicode $ getSources >>= \sources -> doctest $- "-isrc"- : "-idist/build/autogen"- : "-optP-include"- : "-optPdist/build/autogen/cabal_macros.h"- : "-hide-all-packages"- : map ("-package="++) deps ++ sources--getSources :: IO [FilePath]-getSources = filter (isSuffixOf ".hs") <$> go "src"- where- go dir = do- (dirs, files) <- getFilesAndDirectories dir- (files ++) . concat <$> mapM go dirs--getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])-getFilesAndDirectories dir = do- c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir- (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c
− tests/hunit.hs
@@ -1,279 +0,0 @@-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}-{-# LANGUAGE TemplateHaskell #-}--------------------------------------------------------------------------------- |--- Module : Main (hunit)--- Copyright : (C) 2012-13 Edward Kmett--- License : BSD-style (see the file LICENSE)--- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ This module provides a simple hunit test suite for lens.------ The code attempts to enumerate common use cases rather than give an example--- of each available lens function. The tests here merely scratch the surface--- of what is possible using the lens package; there are a great many use cases--- (and lens functions) that aren't covered.-------------------------------------------------------------------------------module Main where--import Control.Lens-import Control.Monad.State-import Data.Char-import Data.List as List-import Data.Monoid-import Data.Map as Map-import Test.Framework.Providers.HUnit-import Test.Framework.TH-import Test.Framework-import Test.HUnit hiding (test)---data Point =- Point- { _x :: Int -- ^ X coordinate- , _y :: Int -- ^ Y coordinate- } deriving (Show, Eq, Ord)--makeLenses ''Point--data Box =- Box- { _low :: Point -- ^ The lowest used coordinates.- , _high :: Point -- ^ The highest used coordinates.- } deriving (Show, Eq)--makeLenses ''Box--data Polygon =- Polygon- { _points :: [ Point ]- , _labels :: Map Point String- , _box :: Box- } deriving (Show, Eq)--makeLenses ''Polygon--data Shape = SBox Box | SPolygon Polygon | SCircle Point Int | SVoid-makePrisms ''Shape--origin =- Point { _x = 0, _y = 0 }--vectorFrom fromPoint toPoint =- Point- { _x = toPoint^.x - fromPoint^.x- , _y = toPoint^.y - fromPoint^.y- }--trig =- Polygon- { _points = [ Point { _x = 0, _y = 0 }- , Point { _x = 4, _y = 7 }- , Point { _x = 8, _y = 0 } ]- , _labels = fromList [ (Point { _x = 0, _y = 0 }, "Origin")- , (Point { _x = 4, _y = 7 }, "Peak") ]- , _box = Box { _low = Point { _x = 0, _y = 0 }- , _high = Point { _x = 8, _y = 7 } }- }--case_read_record_field =- (trig^.box.high.y)- @?= 7--case_read_state_record_field =- runState test trig @?= (7, trig)- where- test = use $ box.high.y--case_read_record_field_and_apply_function =- (trig^.points.to last.to (vectorFrom origin).x)- @?= 8--case_read_state_record_field_and_apply_function =- runState test trig @?= (8, trig)- where test = use $ points.to last.to (vectorFrom origin).x--case_write_record_field =- (trig & box.high.y .~ 6)- @?= trig { _box = (trig & _box)- { _high = (trig & _box & _high)- { _y = 6 } } }--case_write_state_record_field = do- let trig' = trig { _box = (trig & _box)- { _high = (trig & _box & _high)- { _y = 6 } } }- runState test trig @?= ((), trig')- where- test = box.high.y .= 6--case_write_record_field_and_access_new_value =- (trig & box.high.y <.~ 6)- @?= (6, trig { _box = (trig & _box)- { _high = (trig & _box & _high)- { _y = 6 } } })--case_write_state_record_field_and_access_new_value = do- let trig' = trig { _box = (trig & _box)- { _high = (trig & _box & _high)- { _y = 6 } } }- runState test trig @?= (6, trig')- where- test = box.high.y <.= 6--case_write_record_field_and_access_old_value =- (trig & box.high.y <<.~ 6)- @?= (7, trig { _box = (trig & _box)- { _high = (trig & _box & _high)- { _y = 6 } } })--case_write_state_record_field_and_access_old_value = do- let trig' = trig { _box = (trig & _box)- { _high = (trig & _box & _high)- { _y = 6 } } }- runState test trig @?= (7, trig')- where- test = box.high.y <<.= 6--case_modify_record_field =- (trig & box.low.y %~ (+ 2))- @?= trig { _box = (trig & _box)- { _low = (trig & _box & _low)- { _y = ((trig & _box & _low & _y) + 2) } } }--case_modify_state_record_field = do- let trig' = trig { _box = (trig & _box)- { _low = (trig & _box & _low)- { _y = ((trig & _box & _low & _y) + 2) } } }- runState test trig @?= ((), trig')- where- test = box.low.y %= (+ 2)--case_modify_record_field_and_access_new_value =- (trig & box.low.y <%~ (+ 2))- @?= (2, trig { _box = (trig & _box)- { _low = (trig & _box & _low)- { _y = ((trig & _box & _low & _y) + 2) } } })--case_modify_state_record_field_and_access_new_value = do- let trig' = trig { _box = (trig & _box)- { _low = (trig & _box & _low)- { _y = ((trig & _box & _low & _y) + 2) } } }- runState test trig @?= (2, trig')- where- test = box.low.y <%= (+ 2)--case_modify_record_field_and_access_old_value =- (trig & box.low.y <<%~ (+ 2))- @?= (0, trig { _box = (trig & _box)- { _low = (trig & _box & _low)- { _y = ((trig & _box & _low & _y) + 2) } } })--case_modify_state_record_field_and_access_old_value = do- let trig' = trig { _box = (trig & _box)- { _low = (trig & _box & _low)- { _y = ((trig & _box & _low & _y) + 2) } } }- runState test trig @?= (0, trig')- where- test = box.low.y <<%= (+ 2)--case_modify_record_field_and_access_side_result = do- runState test trig @?= (8, trig')- where- test = box.high %%= modifyAndCompute- modifyAndCompute point =- (point ^. x, point & y +~ 2)- trig' = trig { _box = (trig & _box)- { _high = (trig & _box & _high)- { _y = ((trig & _box & _high & _y) + 2) } } }--case_increment_record_field =- (trig & box.low.y +~ 1) -- And similarly for -~ *~ //~ ^~ ^^~ **~ ||~ &&~- @?= trig { _box = (trig & _box)- { _low = (trig & _box & _low)- { _y = ((trig & _box & _low & _y) + 1) } } }--case_increment_state_record_field =- runState test trig @?= ((), trig')- where- test = box.low.y += 1- trig' = trig { _box = (trig & _box)- { _low = (trig & _box & _low)- { _y = ((trig & _box & _low & _y) + 1) } } }--case_append_to_record_field =- (trig & points <>~ [ origin ])- @?= trig { _points = (trig & _points) <> [ origin ] }--case_append_to_state_record_field = do- runState test trig @?= ((), trig')- where- test = points <>= [ origin ]- trig' = trig { _points = (trig & _points) <> [ origin ] }--case_append_to_record_field_and_access_new_value =- (trig & points <<>~ [ origin ])- @?= (_points trig <> [ origin ], trig { _points = (trig & _points) <> [ origin ] })--case_append_to_state_record_field_and_access_new_value = do- runState test trig @?= (_points trig <> [ origin ], trig')- where- test = points <<>= [ origin ]- trig' = trig { _points = (trig & _points) <> [ origin ] }--case_append_to_record_field_and_access_old_value =- (trig & points <<%~ (<>[origin]))- @?= (_points trig, trig { _points = (trig & _points) <> [ origin ] })--case_append_to_state_record_field_and_access_old_value = do- runState test trig @?= (_points trig, trig')- where- test = points <<%= (<>[origin])- trig' = trig { _points = (trig & _points) <> [ origin ] }--case_read_maybe_map_entry = trig^.labels.at origin @?= Just "Origin"--case_read_maybe_state_map_entry =- runState test trig @?= (Just "Origin", trig)- where test = use $ labels.at origin--case_read_map_entry = trig^.labels.ix origin @?= "Origin"--case_read_state_map_entry = runState test trig @?= ("Origin", trig)- where test = use $ labels.ix origin--case_modify_map_entry =- (trig & labels.ix origin %~ List.map toUpper)- @?= trig { _labels = fromList [ (Point { _x = 0, _y = 0 }, "ORIGIN")- , (Point { _x = 4, _y = 7 }, "Peak") ] }--case_insert_maybe_map_entry =- (trig & labels.at (Point { _x = 8, _y = 0 }) .~ Just "Right")- @?= trig { _labels = fromList [ (Point { _x = 0, _y = 0 }, "Origin")- , (Point { _x = 4, _y = 7 }, "Peak")- , (Point { _x = 8, _y = 0 }, "Right") ] }--case_delete_maybe_map_entry =- (trig & labels.at origin .~ Nothing)- @?= trig { _labels = fromList [ (Point { _x = 4, _y = 7 }, "Peak") ] }--case_read_list_entry =- (trig ^? points.element 0)- @?= Just origin--case_write_list_entry =- (trig & points.element 0 .~ Point { _x = 2, _y = 0 })- @?= trig { _points = [ Point { _x = 2, _y = 0 }- , Point { _x = 4, _y = 7 }- , Point { _x = 8, _y = 0 } ] }--case_write_through_list_entry =- (trig & points.element 0 . x .~ 2)- @?= trig { _points = [ Point { _x = 2, _y = 0 }- , Point { _x = 4, _y = 7 }- , Point { _x = 8, _y = 0 } ] }--main :: IO ()-main = defaultMain [$testGroupGenerator]
− tests/properties.hs
@@ -1,195 +0,0 @@-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ExtendedDefaultRules #-}-{-# LANGUAGE LiberalTypeSynonyms #-}-{-# LANGUAGE ScopedTypeVariables #-}--------------------------------------------------------------------------------- |--- Module : Main (properties)--- Copyright : (C) 2012-13 Edward Kmett--- License : BSD-style (see the file LICENSE)--- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : experimental--- Portability : non-portable------ This module provides a set of QuickCheck properties that can be run through--- test-framework to validate a number of expected behaviors of the library.-------------------------------------------------------------------------------module Main where---import Control.Applicative-import Control.Lens-import Test.QuickCheck-import Test.QuickCheck.Function-import Test.Framework.TH-import Test.Framework.Providers.QuickCheck2-import Data.Char (isAlphaNum, isAscii, toUpper)-import Data.Text.Strict.Lens-import Data.Maybe-import Data.List.Lens-import Data.Functor.Compose-import Numeric (showHex, showOct, showSigned)-import Numeric.Lens----- The first setter law:-setter_id :: Eq s => Setter' s a -> s -> Bool-setter_id l s = over l id s == s---- The second setter law:-setter_composition :: Eq s => Setter' s a -> s -> Fun a a -> Fun a a -> Bool-setter_composition l s (Fun _ f) (Fun _ g) = over l f (over l g s) == over l (f . g) s--lens_set_view :: Eq s => Lens' s a -> s -> Bool-lens_set_view l s = set l (view l s) s == s--lens_view_set :: Eq a => Lens' s a -> s -> a -> Bool-lens_view_set l s a = view l (set l a s) == a--setter_set_set :: Eq s => Setter' s a -> s -> a -> a -> Bool-setter_set_set l s a b = set l b (set l a s) == set l b s--iso_hither :: Eq s => Simple AnIso s a -> s -> Bool-iso_hither l s = s ^.cloneIso l.from l == s--iso_yon :: Eq a => Simple AnIso s a -> a -> Bool-iso_yon l a = a^.from l.cloneIso l == a--prism_yin :: Eq a => Prism' s a -> a -> Bool-prism_yin l a = preview l (review l a) == Just a--prism_yang :: Eq s => Prism' s a -> s -> Bool-prism_yang l s = maybe s (review l) (preview l s) == s--traverse_pure :: forall f s a. (Applicative f, Eq (f s)) => LensLike' f s a -> s -> Bool-traverse_pure l s = l pure s == (pure s :: f s)--traverse_pureMaybe :: Eq s => LensLike' Maybe s a -> s -> Bool-traverse_pureMaybe = traverse_pure--traverse_pureList :: Eq s => LensLike' [] s a -> s -> Bool-traverse_pureList = traverse_pure--traverse_compose :: (Applicative f, Applicative g, Eq (f (g s)))- => Traversal' s a -> (a -> g a) -> (a -> f a) -> s -> Bool-traverse_compose t f g s = (fmap (t f) . t g) s == (getCompose . t (Compose . fmap f . g)) s--isSetter :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Function a)- => Setter' s a -> Property-isSetter l = setter_id l .&. setter_composition l .&. setter_set_set l--isTraversal :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Function a)- => Traversal' s a -> Property-isTraversal l = isSetter l .&. traverse_pureMaybe l .&. traverse_pureList l- .&. do as <- arbitrary- bs <- arbitrary- t <- arbitrary- property $ traverse_compose l (\x -> as++[x]++bs)- (\x -> if t then Just x else Nothing)--isLens :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function a)- => Lens' s a -> Property-isLens l = lens_set_view l .&. lens_view_set l .&. isTraversal l--isIso :: (Arbitrary s, Arbitrary a, CoArbitrary s, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function s, Function a)- => Iso' s a -> Property-isIso l = iso_hither l .&. iso_yon l .&. isLens l .&. isLens (from l)--isPrism :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function a)- => Prism' s a -> Property-isPrism l = isTraversal l .&. prism_yin l .&. prism_yang l---- an illegal lens-bad :: Lens' (Int,Int) Int-bad f (a,b) = (,) b <$> f a--badIso :: Iso' Int Bool-badIso = iso even fromEnum---- Control.Lens.Type-prop_1 = isLens (_1 :: Lens' (Int,Double,()) Int)-prop_2 = isLens (_2 :: Lens' (Int,Bool) Bool)-prop_3 = isLens (_3 :: Lens' (Int,Bool,()) ())-prop_4 = isLens (_4 :: Lens' (Int,Bool,(),Maybe Int) (Maybe Int))-prop_5 = isLens (_5 :: Lens' ((),(),(),(),Int) Int)--prop_2_2 = isLens (_2._2 :: Lens' (Int,(Int,Bool),Double) Bool)---- prop_illegal_lens = expectFailure $ isLens bad--- prop_illegal_traversal = expectFailure $ isTraversal bad--- prop_illegal_setter = expectFailure $ isSetter bad--- prop_illegal_iso = expectFailure $ isIso badIso---- Control.Lens.Setter-prop_mapped = isSetter (mapped :: Setter' [Int] Int)-prop_mapped_mapped = isSetter (mapped.mapped :: Setter' [Maybe Int] Int)--prop_both = isTraversal (both :: Traversal' (Int,Int) Int)-prop_value (Fun _ k :: Fun Int Bool) = isTraversal (each.indices k :: Traversal' (Int, Int) Int)-prop_traverseLeft = isTraversal (_Left :: Traversal' (Either Int Bool) Int)-prop_traverseRight = isTraversal (_Right :: Traversal' (Either Int Bool) Bool)--prop_simple = isIso (simple :: Iso' Int Int)---prop_enum = isIso (enum :: Iso' Int Char)--prop__Left = isPrism (_Left :: Prism' (Either Int Bool) Int)-prop__Right = isPrism (_Right :: Prism' (Either Int Bool) Bool)-prop__Just = isPrism (_Just :: Prism' (Maybe Int) Int)---- Data.List.Lens-prop_strippingPrefix s = isPrism (strippingPrefix s :: Prism' String String)---- Data.Text.Lens-prop_text s = s^.packed.from packed == s---prop_text = isIso packed---- Numeric.Lens-prop_base_show (n :: Integer) =- conjoin [ show n == n ^. re (base 10)- , showSigned showOct 0 n "" == n ^. re (base 8)- , showSigned showHex 0 n "" == n ^. re (base 16)- ]-prop_base_read (n :: Integer) =- conjoin [ show n ^? base 10 == Just n- , showSigned showOct 0 n "" ^? base 8 == Just n- , showSigned showHex 0 n "" ^? base 16 == Just n- , map toUpper (showSigned showHex 0 n "") ^? base 16 == Just n- ]-prop_base_readFail (s :: String) =- forAll (choose (2,36)) $ \b ->- not isValid ==> s ^? base b == Nothing- where- isValid = (not . null) sPos && all isValidChar sPos- sPos = case s of { ('-':s') -> s'; _ -> s }- isValidChar c = isAscii c && isAlphaNum c---- Control.Lens.Zipper--prop_zipper_id (NonEmpty (s :: String)) =- (zipper s & fromWithin traverse & rezip) == s &&- over traverse id s == s--prop_zipper_Rightmost (NonEmpty (s :: String)) =- (zipper s & fromWithin traverse & rightmost & view focus) ==- (zipper s & fromWithin traverse & farthest rightward & view focus)--prop_zipper_Leftmost (NonEmpty (s :: String)) =- (zipper s & fromWithin traverse & leftmost & view focus) ==- (zipper s & fromWithin traverse & farthest leftward & view focus)--prop_zipper_Rightward_fails (NonEmpty (s :: String)) =- isNothing (zipper s & rightmost & rightward) &&- isNothing (zipper s & fromWithin traverse & rightmost & rightward)--prop_zipper_Leftward_fails (NonEmpty (s :: String)) =- isNothing (zipper s & leftmost & leftward) &&- isNothing (zipper s & fromWithin traverse & leftmost & leftward)--prop_zipper_tooth_id (NonEmpty (s :: String)) =- let z = zipper s in isJust (jerkTo (tooth z) z)--main :: IO ()-main = $defaultMainGenerator
− tests/templates.hs
@@ -1,115 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleInstances #-}--------------------------------------------------------------------------------- |--- Module : Main (templates)--- Copyright : (C) 2012-13 Edward Kmett--- License : BSD-style (see the file LICENSE)--- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : experimental--- Portability : non-portable------ This test suite validates that we are able to generate usable lenses with --- template haskell.------ The commented code summarizes what will be auto-generated below-------------------------------------------------------------------------------module Main where--import Control.Lens--- import Test.QuickCheck (quickCheck)--data Bar a b c = Bar { _baz :: (a, b) }-makeLenses ''Bar--- baz :: Lens (Bar a b c) (Bar a' b' c) (a,b) (a',b')--data Quux a b = Quux { _quaffle :: Int, _quartz :: Double }-makeLenses ''Quux--- quaffle :: Lens (Quux a b) (Quux a' b') Int Int--- quartz :: Lens (Quux a b) (Quux a' b') Double Double--data Quark a = Qualified { _gaffer :: a }- | Unqualified { _gaffer :: a, _tape :: a }-makeLenses ''Quark--- gaffer :: Simple Lens (Quark a) a--- tape :: Simple Traversal (Quark a) a--data Hadron a b = Science { _a1 :: a, _a2 :: a, _b :: b }-makeLenses ''Hadron--- a1 :: Simple Lens (Hadron a b) a--- a2 :: Simple Lens (Hadron a b) a--- b :: Lens (Hadron a b) (Hadron a b') b b'--data Perambulation a b- = Mountains { _terrain :: a, _altitude :: b }- | Beaches { _terrain :: a, _dunes :: a }-makeLenses ''Perambulation--- terrain :: Simple Lens (Perambulation a b) a--- altitude :: Traversal (Perambulation a b) (Parambulation a b') b b'--- dunes :: Simple Traversal (Perambulation a b) a-makeLensesFor [("_terrain", "allTerrain"), ("_dunes", "allTerrain")] ''Perambulation--- allTerrain :: Traversal (Perambulation a b) (Perambulation a' b) a a'--data LensCrafted a = Still { _still :: a }- | Works { _still :: a }-makeLenses ''LensCrafted--- still :: Lens (LensCrafted a) (LensCrafted b) a b--data Danger a = Zone { _highway :: a }- | Twilight-makeLensesWith (partialLenses .~ True $ buildTraversals .~ False $ lensRules) ''Danger--- highway :: Lens (Danger a) (Danger a') a a'--data Task a = Task- { taskOutput :: a -> IO ()- , taskState :: a- , taskStop :: IO ()- }--makeLensesFor [("taskOutput", "outputLens"), ("taskState", "stateLens"), ("taskStop", "stopLens")] ''Task--data Mono a = Mono { _monoFoo :: a, _monoBar :: Int }-makeClassy ''Mono--- class HasMono t where--- mono :: Simple Lens t Mono--- instance HasMono Mono where--- mono = id--- monoFoo :: HasMono t => Simple Lens t Int--- monoBar :: HasMono t => Simple Lens t Int--data Nucleosis = Nucleosis { _nuclear :: Mono Int }-makeClassy ''Nucleosis--- class HasNucleosis t where--- nucleosis :: Simple Lens t Nucleosis--- instance HasNucleosis Nucleosis--- nuclear :: HasNucleosis t => Simple Lens t Mono--instance HasMono Nucleosis Int where- mono = nuclear---- Dodek's example-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"