lens 5.1.1 → 5.3.6
raw patch · 60 files changed
Files
- .hlint.yaml +1/−0
- CHANGELOG.markdown +132/−0
- README.markdown +1/−1
- benchmarks/folds.hs +12/−0
- benchmarks/plated.hs +7/−7
- examples/lens-examples.cabal +13/−8
- lens-properties/lens-properties.cabal +9/−3
- lens.cabal +36/−29
- src/Control/Exception/Lens.hs +72/−61
- src/Control/Lens.hs +2/−2
- src/Control/Lens/At.hs +39/−16
- src/Control/Lens/Combinators.hs +12/−0
- src/Control/Lens/Cons.hs +107/−2
- src/Control/Lens/Each.hs +10/−0
- src/Control/Lens/Empty.hs +14/−0
- src/Control/Lens/Equality.hs +6/−3
- src/Control/Lens/Extras.hs +1/−1
- src/Control/Lens/Fold.hs +63/−13
- src/Control/Lens/Getter.hs +7/−7
- src/Control/Lens/Internal/Deque.hs +6/−2
- src/Control/Lens/Internal/Doctest.hs +43/−0
- src/Control/Lens/Internal/FieldTH.hs +68/−39
- src/Control/Lens/Internal/Iso.hs +8/−0
- src/Control/Lens/Internal/PrismTH.hs +1/−1
- src/Control/Lens/Internal/TH.hs +39/−25
- src/Control/Lens/Iso.hs +5/−0
- src/Control/Lens/Lens.hs +49/−8
- src/Control/Lens/Operators.hs +18/−0
- src/Control/Lens/Plated.hs +12/−7
- src/Control/Lens/Reified.hs +11/−11
- src/Control/Lens/Setter.hs +23/−5
- src/Control/Lens/TH.hs +102/−94
- src/Control/Lens/Traversal.hs +1/−1
- src/Control/Lens/Type.hs +7/−2
- src/Control/Lens/Unsound.hs +2/−2
- src/Control/Lens/Wrapped.hs +31/−11
- src/Control/Lens/Zoom.hs +12/−0
- src/Control/Monad/Error/Lens.hs +18/−18
- src/Control/Parallel/Strategies/Lens.hs +5/−5
- src/Control/Seq/Lens.hs +3/−3
- src/Data/Array/Lens.hs +2/−2
- src/Data/Bits/Lens.hs +33/−33
- src/Data/ByteString/Lazy/Lens.hs +3/−3
- src/Data/ByteString/Lens.hs +2/−2
- src/Data/ByteString/Strict/Lens.hs +3/−3
- src/Data/Complex/Lens.hs +6/−6
- src/Data/Data/Lens.hs +2/−6
- src/Data/Dynamic/Lens.hs +6/−6
- src/Data/IntSet/Lens.hs +9/−9
- src/Data/Sequence/Lens.hs +3/−3
- src/Data/Tree/Lens.hs +2/−2
- src/Data/Vector/Lens.hs +5/−5
- src/Language/Haskell/TH/Lens.hs +325/−9
- src/Numeric/Lens.hs +2/−2
- src/System/FilePath/Lens.hs +24/−24
- tests/BigRecord.hs +65/−0
- tests/T1024.hs +31/−0
- tests/hunit.hs +161/−43
- tests/properties.hs +29/−30
- tests/templates.hs +26/−0
.hlint.yaml view
@@ -16,6 +16,7 @@ - ignore: {name: Use list comprehension, within: [Control.Lens.Internal.FieldTH]} - ignore: {name: Use fmap, within: [Control.Exception.Lens, Control.Lens.Internal.Zoom, Control.Lens.Zoom, Control.Lens.Indexed, Control.Lens.Fold, Control.Monad.Error.Lens,Control.Lens.Setter]} # Needed to support pre-AMP GHC-7.8 - ignore: {name: Use uncurry}+- ignore: {name: Fuse concatMap/<&>, within: [Control.Lens.Internal.FieldTH]} - fixity: "infixr 9 ..." - fixity: "infixl 1 &~"
CHANGELOG.markdown view
@@ -1,3 +1,135 @@+5.3.6 [2026.01.10]+------------------+* Allow building with `template-haskell-2.24.*` (GHC 9.14).+* Add `_SpecialiseEP` to `Language.Haskell.TH.Lens` (when building with+ `template-haskell-2.24.*`/GHC 9.14 or later).++5.3.5 [2025.06.17]+------------------+* Replace `test-framework` with `tasty` in the test suite.++5.3.4 [2025.03.03]+------------------+* Reduce the arity of `foldr1Of`, `foldl1Of`, `foldrOf'`, `foldlOf'`,+ `foldr1Of'`, `foldl1Of'`, `foldrMOf`, and `foldlMOf` so that GHC is more+ eager to inline them. On a simple benchmark involving `sumOf` (defined in+ terms of `foldlOf'`), this improves performance by 8x.+* Add `Ixed`, `Cons`, `Each`, `AsEmpty`, `Reversing`, and `Rewrapped` instances+ for strict boxed vectors when building with `vector-0.13.2` or later.+* Add an `AsEmpty` instance for primitive `Vector`s.++5.3.3 [2024.12.28]+------------------+* Add `makeFieldsId`, which generates overloaded field accessors using the+ same names as the underlying fields. This is intended for use with the+ `NoFieldSelectors` and `DuplicateRecordFields` language extensions.++ Also add `classIdFields :: LensRules` and `classIdNamer :: FieldNamer`, both+ of which use the same naming rules as `makeFieldsId`.+* Update the `Prism`s in `Language.Haskell.TH.Lens` to reflect additions to+ `template-haskell-2.23.0.0`:+ * Add an `_OrP` `Prism` for the `Pat` data type.+ * Add `_ForallE`, `_ForallVisE`, and `_ConstrainedE` `Prism`s for the `Exp`+ data type.++5.3.2 [2024.05.12]+------------------+* Define the following lenses that perform an operation and result the old+ result:+ * `(<<<>:~)` (prepend to the front via `(<>)` and return the old result)+ * `(<<<|~)` (prepend to the front via `(<|)` and return the old result)+ * `(<<|>~)` (append to the back via `(|>)` and return the old result)++ Each of these also has a variant that end with `=` instead of `~` (e.g.,+ `(<<<>:=)`) for working in a `MonadState` setting.+* Re-export `(<>:~)`, `(<<>:~)`, `(<|~)`, `(<<|~)`, `(|>~)`, and `(<|>~)` (as+ well as their variants which end with `=` instead of `~`, and their variants+ which return the old result) from `Control.Lens.Operators`.++5.3.1 [2024.05.05]+------------------+* Add a `Magnify` instance for the CPS variant of `RWST` when building with+ `mtl-2.3` or later.++5.3 [2024.05.04]+----------------+* Allow building with GHC 9.10.+* Update the `Prism`s in `Language.Haskell.TH.Lens` to reflect additions to+ `template-haskell-2.22.0.0`:+ * The `_InfixD` `Prism` now focuses on `(Fixity, NamespaceSpecifier, Name)`+ when building with `template-haskell-2.22.0.0` or later.+ * Add `Prism`s for the newly introduced `NamespaceSpecifier` data type.+ * Add `_TypeP` and `_InvisP` `Prism`s for the `Pat` data type.+ * Add a `_TypeE` `Prism` for the `Exp` data type.+ * Add a `_SCCP` `Prism` for the `Pragma` data type.+* Add the following `Setter`s for prepending and appending elements:+ * `(<>:~)`: prepend an element to the front via `(<>)`.+ * `(<<>:~)`: prepend an element to the front via `(<>)` and return the result.+ * `(<|~)`: cons an element to the front via `(<|)`.+ * `(<<|~)`: cons an element to the front via `(<|)` and return the result.+ * `(|>~)`: snoc an element to the back via `(|>)`.+ * `(<|>~)`: snoc an element to the back via `(|>)` and return the result.++ Each of these also has a variant that end with `=` instead of `~` (e.g.,+ `(<>:=)`) for working in a `MonadState` setting.++5.2.3 [2023.08.24]+------------------+* Allow building with GHC 9.8.+* Add new `Prism`s to `Language.Haskell.TH.Lens` to reflect recent additions to+ `template-haskell`:+ * `_GetFieldE` and `_ProjectionE` `Prism`s for the `Exp` data type, whose+ corresponding data constructors were introduced in+ `template-haskell-2.18.*`.+ * `_TypedBracketE` and `_TypedSpliceE` `Prism`s for the `Exp` data type, whose+ corresponding data constructors were introduced in+ `template-haskell-2.21.*`.+ * `_BndrReq` and `_BndrInvis` `Prism`s for the `BndrVis` data type, which was+ added in `template-haskell-2.21.*`.+* Add a `generateRecordSyntax` option to `Control.Lens.TH`, which controls+ whether to generate lenses using record update syntax or not. By default, this+ option is disabled.+* Fix a bug in which the `declare*` Template Haskell functions would fail if a+ data type's field has a type that is defined in the same Template Haskell+ quotation.+* Add `altOf`, which collects targets into any `Alternative`.++5.2.2 [2023.03.18]+------------------+* Fix a bug in which calling `ix i` (where `i` is a negative number) on `Text`+ or `ByteString` would return the `Just` the first character instead of+ returning `Nothing`.++5.2.1 [2023.02.27]+------------------+* Allow building with GHC 9.6.+* Allow building with GHC backends where `HTYPE_SIG_ATOMIC_T` is not defined,+ such as the WASM backend.+* Support building with `th-abstraction-0.5.*`.+* Define `_TypeDataD` in `Language.Haskell.TH.Lens` when building with+ `template-haskell-2.20.0.0` (GHC 9.6) or later.++5.2 [2022.08.11]+----------------+* Allow building with GHC 9.4.+* The type of `universeOf` has changed:++ ```diff+ -universeOf :: Getting [a] a a -> a -> [a]+ +universeOf :: Getting (Endo [a]) a a -> a -> [a]+ ```++ In many cases, using `Endo [a]` over `[a]` improves performance. Most call+ sites to `universeOf` will not be affected by this change, although you may+ need to update your code if you define your own combinators in terms of+ `universeOf`.+* Allow `makeWrapped` to accept the names of data constructors. This way,+ `makeWrapped` can be used with data family instances, much like other+ functions in `Control.Lens.TH`.+* Define `_OpaqueP`, `_DefaultD`, `_LamCasesE`, `_PromotedInfixT`, and+ `_PromotedUInfixT` in `Language.Haskell.TH.Lens` when building with+ `template-haskell-2.19.0.0` (GHC 9.4) or later.+ 5.1.1 [2022.05.17] ------------------ * Add `Data.HashSet.Lens.hashMap`, an `Iso` between a `HashSet a` and a
README.markdown view
@@ -9,7 +9,7 @@ The [FAQ](https://github.com/ekmett/lens/wiki/FAQ), which provides links to a large number of different resources for learning about lenses and an overview of the [derivation](https://github.com/ekmett/lens/wiki/Derivation) of these types can be found on the [Lens Wiki](https://github.com/ekmett/lens/wiki) along with a brief [overview](https://github.com/ekmett/lens/wiki/Overview) and some [examples](https://github.com/ekmett/lens/wiki/Examples). -Documentation is available through [github](http://ekmett.github.com/lens/frames.html) (for HEAD) or [hackage](http://hackage.haskell.org/package/lens) for the current and preceding releases.+Documentation is available through [github](https://ekmett.github.io/lens/frames.html) (for HEAD) or [hackage](http://hackage.haskell.org/package/lens) for the current and preceding releases. Field Guide -----------
benchmarks/folds.hs view
@@ -31,6 +31,10 @@ [ bench "native" $ nf (V.toList . V.indexed) v , bench "itraversed" $ nf (itoListOf itraversed) v ]+ , bgroup "sum"+ [ bench "native" $ whnf V.sum v+ , bench "each" $ whnf (sumOf each) v+ ] ] , bgroup "unboxed-vector" [ bgroup "toList"@@ -41,6 +45,10 @@ [ bench "native" $ nf (U.toList . U.indexed) u , bench "vTraverse" $ nf (itoListOf vectorTraverse) u ]+ , bgroup "sum"+ [ bench "native" $ whnf U.sum u+ , bench "each" $ whnf (sumOf each) u+ ] ] , bgroup "sequence" [ bgroup "toList"@@ -71,6 +79,10 @@ , bgroup "itoList" [ bench "native" $ nf (zip [(0::Int)..]) l , bench "itraversed" $ nf (itoListOf itraversed) l+ ]+ , bgroup "sum"+ [ bench "native" $ whnf sum l+ , bench "each" $ whnf (sumOf each) l ] ] , bgroup "map"
benchmarks/plated.hs view
@@ -4,13 +4,6 @@ {-# OPTIONS_GHC -funbox-strict-fields #-} module Main (main) where -#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif--import Prelude ()-import Prelude.Compat- import Control.Lens import Control.DeepSeq import Criterion.Main@@ -70,6 +63,8 @@ , 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+ , bench "universeOf plate fibExpr" $ nf (universeOf plate) fibExpr+ , bench "universeOf Data.uniplate fibExpr" $ nf (universeOf Data.uniplate) fibExpr #ifdef BENCHMARK_UNIPLATE , bench "Direct.universe" $ nf (map Uni.universe) testsExpr , bench "DataOnly.universe" $ nf (map UniDataOnly.universe) testsExpr@@ -78,3 +73,8 @@ 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 ""]++fibExpr :: Expr+fibExpr = go 11 where+ go :: Int -> Expr+ go n = if n <= 1 then Val 1 else Add (go (n - 1)) (go (n - 2))
examples/lens-examples.cabal view
@@ -23,11 +23,17 @@ , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2- , GHC == 9.2.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.7+ , GHC == 9.8.4+ , GHC == 9.10.3+ , GHC == 9.12.2+ , GHC == 9.14.1 source-repository head type: git- location: git://github.com/ekmett/lens.git+ location: https://github.com/ekmett/lens.git flag pong default: True@@ -39,10 +45,9 @@ Turtle build-depends: aeson,- base >= 4.5 && < 5,- bytestring >= 0.9.1.10 && < 0.12,+ base >= 4.9 && < 5,+ bytestring >= 0.9.1.10 && < 0.13, data-default-class,- ghc-prim, lens default-language: Haskell2010 ghc-options: -Wall@@ -52,12 +57,12 @@ buildable: False build-depends:- base >= 4.5 && < 5,- containers >= 0.4 && < 0.7,+ base >= 4.9 && < 5,+ containers >= 0.4 && < 0.9, gloss >= 1.12 && < 1.14, lens, mtl >= 2.0.1 && < 2.4,- random >= 1.0 && < 1.2,+ random >= 1.0 && < 1.4, streams >= 3.3 && < 4 main-is: Pong.hs default-language: Haskell2010
lens-properties/lens-properties.cabal view
@@ -20,7 +20,13 @@ , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2- , GHC == 9.2.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.7+ , GHC == 9.8.4+ , GHC == 9.10.3+ , GHC == 9.12.2+ , GHC == 9.14.1 extra-source-files: .hlint.yaml@@ -28,13 +34,13 @@ source-repository head type: git- location: git://github.com/ekmett/lens.git+ location: https://github.com/ekmett/lens.git library build-depends: base >= 4.9 && < 5, lens >= 4 && < 6,- QuickCheck >= 2.4 && < 2.15,+ QuickCheck >= 2.4 && < 2.18, transformers >= 0.2 && < 0.7 exposed-modules:
lens.cabal view
@@ -1,6 +1,6 @@ name: lens category: Data, Lenses, Generics-version: 5.1.1+version: 5.3.6 license: BSD2 cabal-version: 1.18 license-file: LICENSE@@ -19,7 +19,13 @@ , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2- , GHC == 9.2.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.7+ , GHC == 9.8.4+ , GHC == 9.10.3+ , GHC == 9.12.2+ , GHC == 9.14.1 synopsis: Lenses, Folds and Traversals description: This package comes \"Batteries Included\" with many useful lenses for the types@@ -32,7 +38,7 @@ . An overview, with a large number of examples can be found in the <https://github.com/ekmett/lens#lens-lenses-folds-and-traversals README>. .- An introductory video on the style of code used in this library by Simon Peyton Jones is available from <http://skillsmatter.com/podcast/scala/lenses-compositional-data-access-and-manipulation Skills Matter>.+ An introductory video on the style of code used in this library by Simon Peyton Jones is available from <https://archive.org/details/lenses-compositional-data-access-and-manipulation-simon-peyton-jones-at-haskell- Internet Archive>. . A video on how to use lenses and how they are constructed is available on <http://youtu.be/cefnmjtAolY?hd=1 youtube>. .@@ -48,9 +54,7 @@ With some signatures simplified, the core of the hierarchy of lens-like constructions looks like: . .- <<http://i.imgur.com/ALlbPRa.png>>- .- <images/Hierarchy.png (Local Copy)>+ <<https://raw.githubusercontent.com/ekmett/lens/master/images/Hierarchy.png>> . You can compose any two elements of the hierarchy above using @(.)@ from the @Prelude@, and you can use any element of the hierarchy as any type it linked to above it.@@ -171,39 +175,37 @@ library build-depends: array >= 0.5.0.0 && < 0.6,- assoc >= 1.0.2 && < 1.1,+ assoc >= 1.0.2 && < 1.2, base >= 4.9 && < 5, base-orphans >= 0.5.2 && < 1, bifunctors >= 5.5.7 && < 6,- bytestring >= 0.10.4.0 && < 0.12,+ bytestring >= 0.10.4.0 && < 0.13, call-stack >= 0.1 && < 0.5, comonad >= 5.0.7 && < 6,- containers >= 0.5.5.1 && < 0.7,+ containers >= 0.5.5.1 && < 0.9, contravariant >= 1.4 && < 2, distributive >= 0.5.1 && < 1, exceptions >= 0.8.2.1 && < 1,- filepath >= 1.2.0.0 && < 1.5,+ filepath >= 1.2.0.0 && < 1.6, free >= 5.1.5 && < 6,- ghc-prim,- hashable >= 1.2.7.0 && < 1.5,+ hashable >= 1.2.7.0 && < 1.6, indexed-traversable >= 0.1 && < 0.2, indexed-traversable-instances >= 0.1 && < 0.2, kan-extensions >= 5 && < 6, mtl >= 2.2.1 && < 2.4,- parallel >= 3.2.1.0 && < 3.3,+ parallel >= 3.2.1.0 && < 3.4, profunctors >= 5.5.2 && < 6, reflection >= 2.1 && < 3,- semigroupoids >= 5.0.1 && < 6,- strict >= 0.4 && < 0.5,+ semigroupoids >= 5.0.1 && < 7,+ strict >= 0.4 && < 0.6, tagged >= 0.8.6 && < 1,- template-haskell >= 2.11.1.0 && < 2.19,- text >= 1.2.3.0 && < 2.1,- th-abstraction >= 0.4.1 && < 0.5,- these >= 1.1.1.1 && < 1.2,+ template-haskell >= 2.11.1.0 && < 2.25,+ text >= 1.2.3.0 && < 2.2,+ th-abstraction >= 0.4.1 && < 0.8,+ these >= 1.1.1.1 && < 1.3, transformers >= 0.5.0.0 && < 0.7,- transformers-compat >= 0.5.0.4 && < 1, unordered-containers >= 0.2.10 && < 0.3,- vector >= 0.12.1.2 && < 0.13+ vector >= 0.12.1.2 && < 0.14 -- Control.Lens as the first module, so cabal repl loads it. exposed-modules:@@ -227,6 +229,7 @@ Control.Lens.Internal.Context Control.Lens.Internal.CTypes Control.Lens.Internal.Deque+ Control.Lens.Internal.Doctest Control.Lens.Internal.Exception Control.Lens.Internal.FieldTH Control.Lens.Internal.PrismTH@@ -324,9 +327,13 @@ type: exitcode-stdio-1.0 main-is: templates.hs other-modules:+ BigRecord T799 T917 T972+ if impl(ghc >= 9.2)+ other-modules:+ T1024 ghc-options: -Wall -threaded hs-source-dirs: tests default-language: Haskell2010@@ -357,9 +364,9 @@ build-depends: base, lens,- QuickCheck >= 2.4,- test-framework >= 0.6,- test-framework-quickcheck2 >= 0.2,+ QuickCheck >= 2.4,+ tasty >= 1.4 && < 1.6,+ tasty-quickcheck >= 0.10 && < 0.12, transformers test-suite hunit@@ -375,11 +382,12 @@ build-depends: base, containers,- HUnit >= 1.2, lens, mtl,- test-framework >= 0.6,- test-framework-hunit >= 0.2+ text,+ bytestring,+ tasty >= 1.4 && < 1.6,+ tasty-hunit >= 0.10 && < 0.11 -- We need this dummy test-suite to add simple-reflect to the install plan --@@ -391,7 +399,7 @@ hs-source-dirs: tests default-language: Haskell2010 - build-depends: base, deepseq, simple-reflect >= 0.3.1+ build-depends: base <5, deepseq, simple-reflect >= 0.3.1 -- Basic benchmarks for the uniplate-style combinators benchmark plated@@ -402,7 +410,6 @@ default-language: Haskell2010 build-depends: base,- base-compat >=0.11.0 && <0.13, comonad, criterion, deepseq,
src/Control/Exception/Lens.hs view
@@ -29,7 +29,7 @@ -- be found in "System.IO.Error.Lens". -- -- The combinators in this module have been generalized to work with--- 'MonadCatch' instead of just 'IO'. This enables them to be used+-- 'MonadCatch' instead of just 'Prelude.IO'. This enables them to be used -- more easily in 'Monad' transformer stacks. ---------------------------------------------------------------------------- module Control.Exception.Lens@@ -166,21 +166,27 @@ , Bool(..) ) --- $setup--- >>> :set -XNoOverloadedStrings--- >>> import Control.Lens--- >>> import Control.Applicative--- >>> :m + Control.Exception Control.Monad Data.List Prelude+{-+$setup+>>> :set -XNoOverloadedStrings+>>> :set -XScopedTypeVariables+>>> import Control.Lens+>>> import Control.Applicative+>>> :m + Control.Exception Control.Monad Data.List Prelude+#if MIN_VERSION_base(4,20,0)+>>> :m + Control.Exception.Context+#endif+-} ------------------------------------------------------------------------------ -- Exceptions as Prisms ------------------------------------------------------------------------------ --- | Traverse the strongly typed 'Exception' contained in 'SomeException' where the type of your function matches--- the desired 'Exception'.+-- | Traverse the strongly typed t'Exception' contained in 'SomeException' where the type of your function matches+-- the desired t'Exception'. -- -- @--- 'exception' :: ('Applicative' f, 'Exception' a)+-- 'exception' :: ('Applicative' f, t'Exception' a) -- => (a -> f a) -> 'SomeException' -> f 'SomeException' -- @ exception :: Exception a => Prism' SomeException a@@ -195,7 +201,7 @@ -- Catching ------------------------------------------------------------------------------ --- | Catch exceptions that match a given 'Prism' (or any 'Fold', really).+-- | Catch exceptions that match a given t'Prism' (or any t'Fold', really). -- -- >>> catching _AssertionFailed (assert False (return "uncaught")) $ \ _ -> return "caught" -- "caught"@@ -205,16 +211,16 @@ -- 'catching' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> (a -> m r) -> m r--- 'catching' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> m r -> (a -> m r) -> m r--- 'catching' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> m r -> (a -> m r) -> m r+-- 'catching' :: 'MonadCatch' m => t'Getter' 'SomeException' a -> m r -> (a -> m r) -> m r+-- 'catching' :: 'MonadCatch' m => t'Fold' 'SomeException' a -> m r -> (a -> m r) -> m r -- @ catching :: MonadCatch m => Getting (First a) SomeException a -> m r -> (a -> m r) -> m r catching l = catchJust (preview l) {-# INLINE catching #-} --- | Catch exceptions that match a given 'Prism' (or any 'Getter'), discarding+-- | Catch exceptions that match a given t'Prism' (or any t'Getter'), discarding -- the information about the match. This is particularly useful when you have--- a @'Prism'' e ()@ where the result of the 'Prism' or 'Fold' isn't+-- a @'Prism'' e ()@ where the result of the t'Prism' or t'Fold' isn't -- particularly valuable, just the fact that it matches. -- -- >>> catching_ _AssertionFailed (assert False (return "uncaught")) $ return "caught"@@ -225,8 +231,8 @@ -- 'catching_' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> m r -> m r -- 'catching_' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> m r -> m r -- 'catching_' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> m r -> m r--- 'catching_' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> m r -> m r -> m r--- 'catching_' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> m r -> m r -> m r+-- 'catching_' :: 'MonadCatch' m => t'Getter' 'SomeException' a -> m r -> m r -> m r+-- 'catching_' :: 'MonadCatch' m => t'Fold' 'SomeException' a -> m r -> m r -> m r -- @ catching_ :: MonadCatch m => Getting (First a) SomeException a -> m r -> m r -> m r catching_ l a b = catchJust (preview l) a (const b)@@ -247,8 +253,8 @@ -- 'handling' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> (a -> m r) -> m r -> m r--- 'handling' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> (a -> m r) -> m r -> m r--- 'handling' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> (a -> m r) -> m r -> m r+-- 'handling' :: 'MonadCatch' m => t'Fold' 'SomeException' a -> (a -> m r) -> m r -> m r+-- 'handling' :: 'MonadCatch' m => t'Getter' 'SomeException' a -> (a -> m r) -> m r -> m r -- @ handling :: MonadCatch m => Getting (First a) SomeException a -> (a -> m r) -> m r -> m r handling l = flip (catching l)@@ -265,8 +271,8 @@ -- 'handling_' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> m r -> m r -- 'handling_' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> m r -> m r -- 'handling_' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> m r -> m r--- 'handling_' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> m r -> m r -> m r--- 'handling_' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> m r -> m r -> m r+-- 'handling_' :: 'MonadCatch' m => t'Getter' 'SomeException' a -> m r -> m r -> m r+-- 'handling_' :: 'MonadCatch' m => t'Fold' 'SomeException' a -> m r -> m r -> m r -- @ handling_ :: MonadCatch m => Getting (First a) SomeException a -> m r -> m r -> m r handling_ l = flip (catching_ l)@@ -276,17 +282,17 @@ -- Trying ------------------------------------------------------------------------------ --- | A variant of 'Control.Exception.try' that takes a 'Prism' (or any 'Fold') to select which+-- | A variant of 'Control.Exception.try' that takes a t'Prism' (or any t'Fold') 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.+-- t'Exception' does not match the predicate, it is re-thrown. -- -- @ -- 'trying' :: 'MonadCatch' m => 'Prism'' 'SomeException' a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> m ('Either' a r)--- 'trying' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> m r -> m ('Either' a r)--- 'trying' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> m r -> m ('Either' a r)+-- 'trying' :: 'MonadCatch' m => t'Getter' 'SomeException' a -> m r -> m ('Either' a r)+-- 'trying' :: 'MonadCatch' m => t'Fold' 'SomeException' a -> m r -> m ('Either' a r) -- @ trying :: MonadCatch m => Getting (First a) SomeException a -> m r -> m (Either a r) trying l = tryJust (preview l)@@ -299,8 +305,8 @@ -- 'trying_' :: 'MonadCatch' m => 'Lens'' 'SomeException' a -> m r -> m (Maybe r) -- 'trying_' :: 'MonadCatch' m => 'Traversal'' 'SomeException' a -> m r -> m (Maybe r) -- 'trying_' :: 'MonadCatch' m => 'Iso'' 'SomeException' a -> m r -> m (Maybe r)--- 'trying_' :: 'MonadCatch' m => 'Getter' 'SomeException' a -> m r -> m (Maybe r)--- 'trying_' :: 'MonadCatch' m => 'Fold' 'SomeException' a -> m r -> m (Maybe r)+-- 'trying_' :: 'MonadCatch' m => t'Getter' 'SomeException' a -> m r -> m (Maybe r)+-- 'trying_' :: 'MonadCatch' m => t'Fold' 'SomeException' a -> m r -> m (Maybe r) -- @ trying_ :: MonadCatch m => Getting (First a) SomeException a -> m r -> m (Maybe r) trying_ l m = preview _Right `liftM` trying l m@@ -310,8 +316,8 @@ -- Throwing ------------------------------------------------------------------------------ --- | Throw an 'Exception' described by a 'Prism'. Exceptions may be thrown from--- purely functional code, but may only be caught within the 'IO' 'Monad'.+-- | Throw an t'Exception' described by a t'Prism'. Exceptions may be thrown from+-- purely functional code, but may only be caught within the 'Prelude.IO' 'Monad'. -- -- @ -- 'throwing' l ≡ 'reviews' l 'throw'@@ -331,15 +337,15 @@ -- @ -- data MyError = Foo | Bar -- makePrisms ''MyError--- 'throwing_' _Foo :: 'MonadError' MyError m => m a+-- 'throwing_' _Foo :: 'Control.Monad.Error.Class.MonadError' MyError m => m a -- @ throwing_ :: AReview SomeException () -> m x throwing_ l = throwing l () {-# INLINE throwing_ #-} --- | A variant of 'throwing' that can only be used within the 'IO' 'Monad'--- (or any other 'MonadCatch' instance) to throw an 'Exception' described--- by a 'Prism'.+-- | A variant of 'throwing' that can only be used within the 'Prelude.IO' 'Monad'+-- (or any other 'MonadCatch' instance) to throw an t'Exception' described+-- by a t'Prism'. -- -- Although 'throwingM' has a type that is a specialization of the type of -- 'throwing', the two functions are subtly different:@@ -349,10 +355,10 @@ -- 'throwingM' l e \`seq\` x ≡ x -- @ ----- The first example will cause the 'Exception' @e@ to be raised, whereas the--- second one won't. In fact, 'throwingM' will only cause an 'Exception' to+-- The first example will cause the t'Exception' @e@ to be raised, whereas the+-- second one won't. In fact, 'throwingM' will only cause an t'Exception' to -- be raised when it is used within the 'MonadCatch' instance. The 'throwingM'--- variant should be used in preference to 'throwing' to raise an 'Exception'+-- variant should be used in preference to 'throwing' to raise an t'Exception' -- within the 'Monad' because it guarantees ordering with respect to other -- monadic operations, whereas 'throwing' does not. --@@ -368,7 +374,7 @@ throwingM l = reviews l throwM {-# INLINE throwingM #-} --- | 'throwingTo' raises an 'Exception' specified by a 'Prism' in the target thread.+-- | 'throwingTo' raises an t'Exception' specified by a t'Prism' in the target thread. -- -- @ -- 'throwingTo' thread l ≡ 'reviews' l ('throwTo' thread)@@ -386,14 +392,14 @@ -- Mapping ---------------------------------------------------------------------------- --- | This 'Setter' can be used to purely map over the 'Exception's an+-- | This t'Setter' can be used to purely map over the t'Exception's an -- arbitrary expression might throw; it is a variant of 'mapException' in -- the same way that 'mapped' is a variant of 'fmap'. -- -- > 'mapException' ≡ 'over' 'mappedException' -- -- This view that every Haskell expression can be regarded as carrying a bag--- of 'Exception's is detailed in “A Semantics for Imprecise Exceptions” by+-- of t'Exception's is detailed in “A Semantics for Imprecise Exceptions” by -- Peyton Jones & al. at PLDI ’99. -- -- The following maps failed assertions to arithmetic overflow:@@ -405,7 +411,7 @@ {-# INLINE mappedException #-} -- | This is a type restricted version of 'mappedException', which avoids--- the type ambiguity in the input 'Exception' when using 'set'.+-- the type ambiguity in the input t'Exception' when using 'set'. -- -- The following maps any exception to arithmetic overflow: --@@ -419,14 +425,14 @@ -- IOException ---------------------------------------------------------------------------- --- | Exceptions that occur in the 'IO' 'Monad'. An 'IOException' records a+-- | Exceptions that occur in the 'Prelude.IO' 'Monad'. An 'IOException' records a -- more specific error type, a descriptive string and maybe the handle that was -- used when the error was flagged. -- -- Due to their richer structure relative to other exceptions, these have -- a more carefully overloaded signature. class AsIOException t where- -- | Unfortunately the name 'ioException' is taken by @base@ for+ -- | Unfortunately the name 'GHC.IO.Exception.ioException' is taken by @base@ for -- throwing IOExceptions. -- -- @@@ -674,15 +680,21 @@ -- @ __AssertionFailed :: Prism' t AssertionFailed - -- | This 'Exception' contains provides information about what assertion failed in the 'String'.- --+ {- | This t'Exception' contains provides information about what assertion failed in the 'String'.++ @+ '_AssertionFailed' :: 'Prism'' 'AssertionFailed' 'String'+ '_AssertionFailed' :: 'Prism'' 'SomeException' 'String'+ @++#if MIN_VERSION_base(4,20,0)+ >>> handling exception (\ (ExceptionWithContext ctxt (_ :: AssertionFailed)) -> "caught" <$ guard ("<interactive>" `isInfixOf` displayExceptionContext ctxt) ) $ assert False (return "uncaught")+ "caught"+#else -- >>> handling _AssertionFailed (\ xs -> "caught" <$ guard ("<interactive>" `isInfixOf` xs) ) $ assert False (return "uncaught") -- "caught"- --- -- @- -- '_AssertionFailed' :: 'Prism'' 'AssertionFailed' 'String'- -- '_AssertionFailed' :: 'Prism'' 'SomeException' 'String'- -- @+#endif+ -} _AssertionFailed :: Prism' t String _AssertionFailed = __AssertionFailed._AssertionFailed {-# INLINE _AssertionFailed #-}@@ -732,7 +744,7 @@ pattern AsyncException_ e <- (preview _AsyncException -> Just e) where AsyncException_ e = review _AsyncException e --- | The current thread's stack exceeded its limit. Since an 'Exception' has+-- | The current thread's stack exceeded its limit. Since an t'Exception' has -- been raised, the thread's stack will certainly be below its limit again, -- but the programmer should take remedial action immediately. --@@ -755,7 +767,7 @@ -- -- Notes: ----- * It is undefined which thread receives this 'Exception'.+-- * It is undefined which thread receives this t'Exception'. -- -- * GHC currently does not throw 'HeapOverflow' exceptions. --@@ -773,7 +785,7 @@ pattern HeapOverflow_ <- (has _HeapOverflow -> True) where HeapOverflow_ = review _HeapOverflow () --- | This 'Exception' is raised by another thread calling+-- | This t'Exception' is raised by another thread calling -- 'Control.Concurrent.killThread', or by the system if it needs to terminate -- the thread for some reason. --@@ -791,7 +803,7 @@ pattern ThreadKilled_ <- (has _ThreadKilled -> True) where ThreadKilled_ = review _ThreadKilled () --- | This 'Exception' is raised by default in the main thread of the program when+-- | This t'Exception' is raised by default in the main thread of the program when -- the user requests to terminate the program via the usual mechanism(s) -- (/e.g./ Control-C in the console). --@@ -824,7 +836,7 @@ -- @ __NonTermination :: Prism' t NonTermination - -- | There is no additional information carried in a 'NonTermination' 'Exception'.+ -- | There is no additional information carried in a 'NonTermination' t'Exception'. -- -- @ -- '_NonTermination' :: 'Prism'' 'NonTermination' ()@@ -867,7 +879,7 @@ -- @ __NestedAtomically :: Prism' t NestedAtomically - -- | There is no additional information carried in a 'NestedAtomically' 'Exception'.+ -- | There is no additional information carried in a 'NestedAtomically' t'Exception'. -- -- @ -- '_NestedAtomically' :: 'Prism'' 'NestedAtomically' ()@@ -911,7 +923,7 @@ -- @ __BlockedIndefinitelyOnMVar :: Prism' t BlockedIndefinitelyOnMVar - -- | There is no additional information carried in a 'BlockedIndefinitelyOnMVar' 'Exception'.+ -- | There is no additional information carried in a 'BlockedIndefinitelyOnMVar' t'Exception'. -- -- @ -- '_BlockedIndefinitelyOnMVar' :: 'Prism'' 'BlockedIndefinitelyOnMVar' ()@@ -955,7 +967,7 @@ -- @ __BlockedIndefinitelyOnSTM :: Prism' t BlockedIndefinitelyOnSTM - -- | There is no additional information carried in a 'BlockedIndefinitelyOnSTM' 'Exception'.+ -- | There is no additional information carried in a 'BlockedIndefinitelyOnSTM' t'Exception'. -- -- @ -- '_BlockedIndefinitelyOnSTM' :: 'Prism'' 'BlockedIndefinitelyOnSTM' ()@@ -989,7 +1001,7 @@ ---------------------------------------------------------------------------- -- | There are no runnable threads, so the program is deadlocked. The--- 'Deadlock' 'Exception' is raised in the main thread only.+-- 'Deadlock' t'Exception' is raised in the main thread only. class AsDeadlock t where -- | -- @@@ -998,7 +1010,7 @@ -- @ __Deadlock :: Prism' t Deadlock - -- | There is no information carried in a 'Deadlock' 'Exception'.+ -- | There is no information carried in a 'Deadlock' t'Exception'. -- -- @ -- '_Deadlock' :: 'Prism'' 'Deadlock' ()@@ -1304,7 +1316,7 @@ __AllocationLimitExceeded :: Prism' t AllocationLimitExceeded -- | There is no additional information carried in an- -- 'AllocationLimitExceeded' 'Exception'.+ -- 'AllocationLimitExceeded' t'Exception'. -- -- @ -- '_AllocationLimitExceeded' :: 'Prism'' 'AllocationLimitExceeded' ()@@ -1425,7 +1437,7 @@ -- HandlingException ------------------------------------------------------------------------------ --- | This 'Exception' is thrown by @lens@ when the user somehow manages to rethrow+-- | This t'Exception' is thrown by @lens@ when the user somehow manages to rethrow -- an internal 'HandlingException'. class AsHandlingException t where -- |@@ -1470,4 +1482,3 @@ trivial :: t -> Iso' t () trivial t = const () `iso` const t-
src/Control/Lens.hs view
@@ -14,7 +14,7 @@ -- -- @ -- import Control.Lens--- +-- -- data FooBar a -- = Foo { _x :: ['Int'], _y :: a } -- | Bar { _x :: ['Int'] }@@ -25,7 +25,7 @@ -- -- @ -- x :: 'Lens'' (FooBar a) ['Int']--- y :: 'Traversal' (FooBar a) (FooBar b) a b+-- y :: t'Traversal' (FooBar a) (FooBar b) a b -- @ -- -- You can then access the value of @_x@ with ('^.'), the value of @_y@ –
src/Control/Lens/At.hs view
@@ -85,6 +85,9 @@ import qualified Data.Vector.Storable as Storable import qualified Data.Vector.Unboxed as Unboxed import Data.Vector.Unboxed (Unbox)+#if MIN_VERSION_vector(0,13,2)+import qualified Data.Vector.Strict as VectorStrict+#endif import Data.Word import Foreign.Storable (Storable) @@ -113,6 +116,9 @@ type instance Index (Prim.Vector a) = Int type instance Index (Storable.Vector a) = Int type instance Index (Unboxed.Vector a) = Int+#if MIN_VERSION_vector(0,13,2)+type instance Index (VectorStrict.Vector a) = Int+#endif type instance Index (Complex a) = Int type instance Index (Identity a) = () type instance Index (Maybe a) = ()@@ -396,37 +402,54 @@ | otherwise = pure v {-# INLINE ix #-} +#if MIN_VERSION_vector(0,13,2)+type instance IxValue (VectorStrict.Vector a) = a+instance Ixed (VectorStrict.Vector a) where+ ix i f v+ | 0 <= i && i < VectorStrict.length v = f (v VectorStrict.! i) <&> \a -> v VectorStrict.// [(i, a)]+ | otherwise = pure v+ {-# INLINE ix #-}+#endif+ type instance IxValue StrictT.Text = Char instance Ixed StrictT.Text where- ix e f s = case StrictT.splitAt e s of- (l, mr) -> case StrictT.uncons mr of- Nothing -> pure s- Just (c, xs) -> f c <&> \d -> StrictT.concat [l, StrictT.singleton d, xs]+ ix e f s + | e < 0 = pure s+ | otherwise = case StrictT.splitAt e s of+ (l, mr) -> case StrictT.uncons mr of+ Nothing -> pure s+ Just (c, xs) -> f c <&> \d -> StrictT.concat [l, StrictT.singleton d, xs] {-# INLINE ix #-} type instance IxValue LazyT.Text = Char instance Ixed LazyT.Text where- ix e f s = case LazyT.splitAt e s of- (l, mr) -> case LazyT.uncons mr of- Nothing -> pure s- Just (c, xs) -> f c <&> \d -> LazyT.append l (LazyT.cons d xs)+ ix e f s + | e < 0 = pure s+ | otherwise = case LazyT.splitAt e s of+ (l, mr) -> case LazyT.uncons mr of+ Nothing -> pure s+ Just (c, xs) -> f c <&> \d -> LazyT.append l (LazyT.cons d xs) {-# INLINE ix #-} type instance IxValue StrictB.ByteString = Word8 instance Ixed StrictB.ByteString where- ix e f s = case StrictB.splitAt e s of- (l, mr) -> case StrictB.uncons mr of- Nothing -> pure s- Just (c, xs) -> f c <&> \d -> StrictB.concat [l, StrictB.singleton d, xs]+ ix e f s + | e < 0 = pure s+ | otherwise = case StrictB.splitAt e s of+ (l, mr) -> case StrictB.uncons mr of+ Nothing -> pure s+ Just (c, xs) -> f c <&> \d -> StrictB.concat [l, StrictB.singleton d, xs] {-# INLINE ix #-} type instance IxValue LazyB.ByteString = Word8 instance Ixed LazyB.ByteString where -- TODO: we could be lazier, returning each chunk as it is passed- ix e f s = case LazyB.splitAt e s of- (l, mr) -> case LazyB.uncons mr of- Nothing -> pure s- Just (c, xs) -> f c <&> \d -> LazyB.append l (LazyB.cons d xs)+ ix e f s + | e < 0 = pure s+ | otherwise = case LazyB.splitAt e s of+ (l, mr) -> case LazyB.uncons mr of+ Nothing -> pure s+ Just (c, xs) -> f c <&> \d -> LazyB.append l (LazyB.cons d xs) {-# INLINE ix #-}
src/Control/Lens/Combinators.hs view
@@ -139,6 +139,18 @@ , (<?=) , (<>~) , (<>=)+ , (<>:~)+ , (<>:=)+ , (<<>:~)+ , (<<>:=)+ , (<|~)+ , (<|=)+ , (<<|~)+ , (<<|=)+ , (|>~)+ , (|>=)+ , (<|>~)+ , (<|>=) , (%@~) , (%@=) , (:>)
src/Control/Lens/Cons.hs view
@@ -27,6 +27,7 @@ , cons , uncons , _head, _tail+ , (<|~), (<|=), (<<|~), (<<|=), (<<<|~), (<<<|=) , pattern (:<) -- * Snoc , Snoc(..)@@ -34,14 +35,17 @@ , snoc , unsnoc , _init, _last+ , (|>~), (|>=), (<|>~), (<|>=), (<<|>~), (<<|>=) , pattern (:>) ) where import Control.Lens.Equality (simply) import Control.Lens.Fold+import Control.Lens.Lens import Control.Lens.Prism import Control.Lens.Review+import Control.Lens.Setter import Control.Lens.Tuple import Control.Lens.Type import qualified Data.ByteString as StrictB@@ -60,8 +64,12 @@ import qualified Data.Vector.Primitive as Prim import Data.Vector.Unboxed (Unbox) import qualified Data.Vector.Unboxed as Unbox+#if MIN_VERSION_vector(0,13,2)+import qualified Data.Vector.Strict as VectorStrict+#endif import Data.Word import Control.Applicative (ZipList(..))+import Control.Monad.State.Class as State import Prelude -- $setup@@ -77,6 +85,8 @@ infixr 5 <|, `cons` infixl 5 |>, `snoc`+infixr 4 <|~, |>~, <<|~, <|>~, <<<|~, <<|>~+infix 4 <|=, |>=, <<|=, <|>=, <<<|=, <<|>= pattern (:<) :: Cons b b a a => a -> b -> b pattern (:<) a s <- (preview _Cons -> Just (a,s)) where@@ -173,6 +183,15 @@ else Right (Unbox.unsafeHead v, Unbox.unsafeTail v) {-# INLINE _Cons #-} +#if MIN_VERSION_vector(0,13,2)+instance Cons (VectorStrict.Vector a) (VectorStrict.Vector b) a b where+ _Cons = prism (uncurry VectorStrict.cons) $ \v ->+ if VectorStrict.null v+ then Left VectorStrict.empty+ else Right (VectorStrict.unsafeHead v, VectorStrict.unsafeTail v)+ {-# INLINE _Cons #-}+#endif+ -- | 'cons' an element onto a container. -- -- This is an infix alias for 'cons'.@@ -323,6 +342,49 @@ _tail = _Cons._2 {-# INLINE _tail #-} +-- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' using @('<|')@.+--+-- >>> (["world"], ["lens"]) & _1 <|~ "hello"+-- (["hello","world"],["lens"])+(<|~) :: Cons b b a a => ASetter s t b b -> a -> s -> t+l <|~ n = over l (n <|)+{-# INLINE (<|~) #-}++-- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' using @('<|')@.+(<|=) :: (MonadState s m, Cons b b a a) => ASetter s s b b -> a -> m ()+l <|= a = State.modify (l <|~ a)+{-# INLINE (<|=) #-}++-- | ('<|') a value onto the target of a 'Lens' and return the result.+--+-- When you do not need the result of the operation, ('Control.Lens.Cons.<|~') is more flexible.+(<<|~) :: Cons b b a a => LensLike ((,) b) s t b b -> a -> s -> (b, t)+l <<|~ m = l <%~ (m <|)+{-# INLINE (<<|~) #-}++-- | ('<|') a value onto the target of a 'Lens' and return the /old/ result.+--+-- When you do not need the result of the operation, ('Control.Lens.Cons.<|~') is more flexible.+(<<<|~) :: Cons b b a a => LensLike' ((,) b) s b -> a -> s -> (b, s)+l <<<|~ m = l <<%~ (m <|)+{-# INLINE (<<<|~) #-}++-- | ('<|') a value onto the target of a 'Lens' into your 'Monad'\'s state and+-- return the result.+--+-- When you do not need the result of the operation, ('Control.Lens.Cons.<|=') is more flexible.+(<<|=) :: (MonadState s m, Cons b b a a) => LensLike ((,) b) s s b b -> a -> m b+l <<|= r = l <%= (r <|)+{-# INLINE (<<|=) #-}++-- | ('<|') a value onto the target of a 'Lens' into your 'Monad'\'s state and+-- return the /old/ result.+--+-- When you do not need the result of the operation, ('Control.Lens.Cons.<|=') is more flexible.+(<<<|=) :: (MonadState s m, Cons b b a a) => LensLike ((,) b) s s b b -> a -> m b+l <<<|= r = l <<%= (r <|)+{-# INLINE (<<<|=) #-}+ ------------------------------------------------------------------------------ -- Snoc ------------------------------------------------------------------------------@@ -492,7 +554,7 @@ _last = _Snoc._2 {-# INLINE _last #-} --- | 'snoc' an element onto the end of a container.+-- | 'snoc' an element onto a container. -- -- This is an infix alias for 'snoc'. --@@ -508,7 +570,7 @@ (|>) = curry (simply review _Snoc) {-# INLINE (|>) #-} --- | 'snoc' an element onto the end of a container.+-- | 'snoc' an element onto a container. -- -- >>> snoc (Seq.fromList []) a -- fromList [a]@@ -538,3 +600,46 @@ unsnoc :: Snoc s s a a => s -> Maybe (s, a) unsnoc = simply preview _Snoc {-# INLINE unsnoc #-}++-- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' using @('|>')@.+--+-- >>> (["world"], ["lens"]) & _1 |>~ "hello"+-- (["world","hello"],["lens"])+(|>~) :: Snoc b b a a => ASetter s t b b -> a -> s -> t+l |>~ n = over l (|> n)+{-# INLINE (|>~) #-}++-- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' using @('|>')@.+(|>=) :: (MonadState s m, Snoc b b a a) => ASetter s s b b -> a -> m ()+l |>= a = State.modify (l |>~ a)+{-# INLINE (|>=) #-}++-- | ('|>') a value onto the target of a 'Lens' and return the result.+--+-- When you do not need the result of the operation, ('Control.Lens.Cons.|>~') is more flexible.+(<|>~) :: Snoc b b p p => LensLike ((,) b) s t b b -> p -> s -> (b, t)+l <|>~ m = l <%~ (|> m)+{-# INLINE (<|>~) #-}++-- | ('|>') a value onto the target of a 'Lens' and return the /old/ result.+--+-- When you do not need the result of the operation, ('Control.Lens.Cons.|>~') is more flexible.+(<<|>~) :: Snoc b b p p => LensLike' ((,) b) s b -> p -> s -> (b, s)+l <<|>~ m = l <<%~ (|> m)+{-# INLINE (<<|>~) #-}++-- | ('|>') a value onto the target of a 'Lens' into your 'Monad'\'s state and+-- return the result.+--+-- When you do not need the result of the operation, ('Control.Lens.Cons.|>=') is more flexible.+(<|>=) :: (MonadState s m, Snoc b b p p) => LensLike ((,) b) s s b b -> p -> m b+l <|>= r = l <%= (|> r)+{-# INLINE (<|>=) #-}++-- | ('|>') a value onto the target of a 'Lens' into your 'Monad'\'s state and+-- return the /old/ result.+--+-- When you do not need the result of the operation, ('Control.Lens.Cons.|>=') is more flexible.+(<<|>=) :: (MonadState s m, Snoc b b p p) => LensLike ((,) b) s s b b -> p -> m b+l <<|>= r = l <<%= (|> r)+{-# INLINE (<<|>=) #-}
src/Control/Lens/Each.hs view
@@ -54,6 +54,9 @@ import qualified Data.Vector.Storable as Storable import Data.Vector.Storable (Storable) import qualified Data.Vector.Unboxed as Unboxed+#if MIN_VERSION_vector(0,13,2)+import qualified Data.Vector.Strict as VectorStrict+#endif import Data.Vector.Unboxed (Unbox) import Data.Word import qualified Data.Strict as S@@ -194,6 +197,13 @@ instance (Unbox a, Unbox b) => Each (Unboxed.Vector a) (Unboxed.Vector b) a b where each = vectorTraverse {-# INLINE each #-}++#if MIN_VERSION_vector(0,13,2)+-- | @'each' :: 'Traversal' ('Vector.Vector' a) ('Vector.Vector' b) a b@+instance Each (VectorStrict.Vector a) (VectorStrict.Vector b) a b where+ each = vectorTraverse+ {-# INLINE each #-}+#endif -- | @'each' :: 'Traversal' 'StrictT.Text' 'StrictT.Text' 'Char' 'Char'@ instance (a ~ Char, b ~ Char) => Each StrictT.Text StrictT.Text a b where
src/Control/Lens/Empty.hs view
@@ -53,6 +53,10 @@ import qualified Data.Vector.Unboxed as Unboxed import Data.Vector.Unboxed (Unbox) import qualified Data.Vector.Storable as Storable+import qualified Data.Vector.Primitive as Prim+#if MIN_VERSION_vector(0,13,2)+import qualified Data.Vector.Strict as VectorStrict+#endif import Foreign.Storable (Storable) #if !defined(mingw32_HOST_OS) && !defined(ghcjs_HOST_OS)@@ -161,9 +165,19 @@ _Empty = nearly Unboxed.empty Unboxed.null {-# INLINE _Empty #-} +instance Prim.Prim a => AsEmpty (Prim.Vector a) where+ _Empty = nearly Prim.empty Prim.null+ {-# INLINE _Empty #-}+ instance Storable a => AsEmpty (Storable.Vector a) where _Empty = nearly Storable.empty Storable.null {-# INLINE _Empty #-}++#if MIN_VERSION_vector(0,13,2)+instance AsEmpty (VectorStrict.Vector a) where+ _Empty = nearly VectorStrict.empty VectorStrict.null+ {-# INLINE _Empty #-}+#endif instance AsEmpty (Seq.Seq a) where _Empty = nearly Seq.empty Seq.null
src/Control/Lens/Equality.hs view
@@ -3,9 +3,14 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeInType #-} {-# LANGUAGE Trustworthy #-} +#if __GLASGOW_HASKELL__ >= 806+{-# LANGUAGE PolyKinds #-}+#else+{-# LANGUAGE TypeInType #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Equality@@ -144,8 +149,6 @@ -- -- @fromLeibniz' :: (forall f. f s -> f a) -> Equality' s a@ fromLeibniz' :: (s :~: s -> s :~: a) -> Equality' s a--- Note: even though its type signature mentions (:~:), this function works just--- fine in base versions before 4.7.0; it just requires a polymorphic argument! fromLeibniz' f = case f Refl of Refl -> id {-# INLINE fromLeibniz' #-}
src/Control/Lens/Extras.hs view
@@ -22,7 +22,7 @@ -- >>> import Control.Lens -- >>> import Numeric.Lens (hex) --- | Check to see if this 'Prism' matches.+-- | Check to see if this t'Prism' matches. -- -- >>> is _Left (Right 12) -- False
src/Control/Lens/Fold.hs view
@@ -74,6 +74,7 @@ , foldMapOf, foldOf , foldrOf, foldlOf , toListOf, toNonEmptyOf+ , altOf , anyOf, allOf, noneOf , andOf, orOf , productOf, sumOf@@ -162,7 +163,7 @@ import Data.Int (Int64) import Data.List (intercalate) import Data.Maybe (fromMaybe)-import Data.Monoid (First (..), All (..), Any (..))+import Data.Monoid (First (..), All (..), Alt (..), Any (..)) import Data.Reflection import qualified Data.Semigroup as Semi@@ -196,8 +197,8 @@ -- -- This can be useful to lift operations from @Data.List@ and elsewhere into a 'Fold'. ----- >>> [1,2,3,4]^..folding tail--- [2,3,4]+-- >>> [1,2,3,4]^..folding reverse+-- [4,3,2,1] folding :: Foldable f => (s -> f a) -> Fold s a folding sfa agb = phantom . traverse_ agb . sfa {-# INLINE folding #-}@@ -638,11 +639,37 @@ -- 'toNonEmptyOf' :: 'Lens'' s a -> s -> NonEmpty a -- 'toNonEmptyOf' :: 'Iso'' s a -> s -> NonEmpty a -- 'toNonEmptyOf' :: 'Traversal1'' s a -> s -> NonEmpty a--- 'toNonEmptyOf' :: 'Prism'' s a -> s -> NonEmpty a -- @ toNonEmptyOf :: Getting (NonEmptyDList a) s a -> s -> NonEmpty a toNonEmptyOf l = flip getNonEmptyDList [] . foldMapOf l (NonEmptyDList #. (:|)) +-- | Calls 'pure' on the target of a 'Lens', 'Getter', or 'Iso'.+--+-- Calls 'pure' on the targets of a 'Traversal', 'Fold', or 'Prism', and+-- combines them with '<|>' (or `empty` if none). Intuitively, it collects+-- targets into an 'Alternative' until the container fills up or it runs out of+-- targets, whichever comes first.+--+-- Generalizes 'toListOf' and '(^?)'.+--+-- >>> altOf both ("hello", "world") :: [String]+-- ["hello","world"]+-- >>> altOf both ("hello", "world") :: Maybe String+-- Just "hello"+--+-- @+-- 'altOf' :: Applicative f => 'Lens'' s a -> s -> f a+-- 'altOf' :: Applicative f => 'Getter' s a -> s -> f a+-- 'altOf' :: Applicative f => 'Iso'' s a -> s -> f a+--+-- 'altOf' :: Alternative f => 'Traversal'' s a -> s -> f a+-- 'altOf' :: Alternative f => 'Fold' s a -> s -> f a+-- 'altOf' :: Alternative f => 'Prism'' s a -> s -> f a+-- @+altOf :: Applicative f => Getting (Alt f a) s a -> s -> f a+altOf l = getAlt #. views l (Alt #. pure)+{-# INLINE altOf #-}+ -- | A convenient infix (flipped) version of 'toListOf'. -- -- >>> [[1,2],[3]]^..id@@ -1727,8 +1754,9 @@ -- 'foldr1Of' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ foldr1Of :: HasCallStack => Getting (Endo (Maybe a)) s a -> (a -> a -> a) -> s -> a-foldr1Of l f xs = fromMaybe (error "foldr1Of: empty structure")- (foldrOf l mf Nothing xs) where+-- See: NOTE: [Inlining and arity]+foldr1Of l f = fromMaybe (error "foldr1Of: empty structure")+ . foldrOf l mf Nothing where mf x my = Just $ case my of Nothing -> x Just y -> f x y@@ -1753,7 +1781,8 @@ -- 'foldl1Of' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ foldl1Of :: HasCallStack => Getting (Dual (Endo (Maybe a))) s a -> (a -> a -> a) -> s -> a-foldl1Of l f xs = fromMaybe (error "foldl1Of: empty structure") (foldlOf l mf Nothing xs) where+-- See: NOTE: [Inlining and arity]+foldl1Of l f = fromMaybe (error "foldl1Of: empty structure") . foldlOf l mf Nothing where mf mx y = Just $ case mx of Nothing -> y Just x -> f x y@@ -1773,7 +1802,8 @@ -- 'foldrOf'' :: 'Traversal'' s a -> (a -> r -> r) -> r -> s -> r -- @ foldrOf' :: Getting (Dual (Endo (Endo r))) s a -> (a -> r -> r) -> r -> s -> r-foldrOf' l f z0 xs = foldlOf l f' (Endo id) xs `appEndo` z0+-- See: NOTE: [Inlining and arity]+foldrOf' l f z0 = \xs -> foldlOf l f' (Endo id) xs `appEndo` z0 where f' (Endo k) x = Endo $ \ z -> k $! f x z {-# INLINE foldrOf' #-} @@ -1791,7 +1821,8 @@ -- 'foldlOf'' :: 'Traversal'' s a -> (r -> a -> r) -> r -> s -> r -- @ foldlOf' :: Getting (Endo (Endo r)) s a -> (r -> a -> r) -> r -> s -> r-foldlOf' l f z0 xs = foldrOf l f' (Endo id) xs `appEndo` z0+-- See: NOTE: [Inlining and arity]+foldlOf' l f z0 = \xs -> foldrOf l f' (Endo id) xs `appEndo` z0 where f' x (Endo k) = Endo $ \z -> k $! f z x {-# INLINE foldlOf' #-} @@ -1811,7 +1842,8 @@ -- 'foldr1Of'' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ foldr1Of' :: HasCallStack => Getting (Dual (Endo (Endo (Maybe a)))) s a -> (a -> a -> a) -> s -> a-foldr1Of' l f xs = fromMaybe (error "foldr1Of': empty structure") (foldrOf' l mf Nothing xs) where+-- See: NOTE: [Inlining and arity]+foldr1Of' l f = fromMaybe (error "foldr1Of': empty structure") . foldrOf' l mf Nothing where mf x Nothing = Just $! x mf x (Just y) = Just $! f x y {-# INLINE foldr1Of' #-}@@ -1832,7 +1864,8 @@ -- 'foldl1Of'' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ foldl1Of' :: HasCallStack => Getting (Endo (Endo (Maybe a))) s a -> (a -> a -> a) -> s -> a-foldl1Of' l f xs = fromMaybe (error "foldl1Of': empty structure") (foldlOf' l mf Nothing xs) where+-- See: NOTE: [Inlining and arity]+foldl1Of' l f = fromMaybe (error "foldl1Of': empty structure") . foldlOf' l mf Nothing where mf Nothing y = Just $! y mf (Just x) y = Just $! f x y {-# INLINE foldl1Of' #-}@@ -1854,7 +1887,8 @@ foldrMOf :: Monad m => Getting (Dual (Endo (r -> m r))) s a -> (a -> r -> m r) -> r -> s -> m r-foldrMOf l f z0 xs = foldlOf l f' return xs z0+-- See: NOTE: [Inlining and arity]+foldrMOf l f z0 = \xs -> foldlOf l f' return xs z0 where f' k x z = f x z >>= k {-# INLINE foldrMOf #-} @@ -1875,9 +1909,25 @@ foldlMOf :: Monad m => Getting (Endo (r -> m r)) s a -> (r -> a -> m r) -> r -> s -> m r-foldlMOf l f z0 xs = foldrOf l f' return xs z0+-- See: NOTE: [Inlining and arity]+foldlMOf l f z0 = \xs -> foldrOf l f' return xs z0 where f' x k z = f z x >>= k {-# INLINE foldlMOf #-}++-- NOTE: [Inlining and arity]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- GHC uses the following inlining heuristic: a function body is inlined if+-- all its arguments on the LHS are applied. So the following two definitions+-- are not equivalent from the inliner's PoV:+--+-- > foldlOf' l f z0 xs = ...+-- > foldlOf' l f z0 = \xs -> ...+--+-- GHC will be less eager to inline the first one and this results in+-- worse code. For example, a simple list summation using `sumOf` will be 8x slower+-- with the first version.+ -- | Check to see if this 'Fold' or 'Traversal' matches 1 or more entries. --
src/Control/Lens/Getter.hs view
@@ -4,7 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Trustworthy #-} --- Disable the warnings generated by 'to', 'ito', 'like', 'ilike'.+-- Disable the warnings generated by 'Control.Lens.Getter.to', 'ito', 'like', 'ilike'. -- These functions are intended to produce 'Getters'. Without this constraint -- users would get warnings when annotating types at uses of these functions. {-# OPTIONS_GHC -Wno-redundant-constraints #-}@@ -108,11 +108,11 @@ -- | Build an (index-preserving) 'Getter' from an arbitrary Haskell function. -- -- @--- 'to' f '.' 'to' g ≡ 'to' (g '.' f)+-- 'Control.Lens.Getter.to' f '.' 'Control.Lens.Getter.to' g ≡ 'Control.Lens.Getter.to' (g '.' f) -- @ -- -- @--- a '^.' 'to' f ≡ f a+-- a '^.' 'Control.Lens.Getter.to' f ≡ f a -- @ -- -- >>> a ^.to f@@ -128,7 +128,7 @@ -- 5 -- -- @--- 'to' :: (s -> a) -> 'IndexPreservingGetter' s a+-- 'Control.Lens.Getter.to' :: (s -> a) -> 'IndexPreservingGetter' s a -- @ to :: (Profunctor p, Contravariant f) => (s -> a) -> Optic' p f s a to k = dimap k (contramap k)@@ -148,7 +148,7 @@ -- @ -- 'like' a '.' 'like' b ≡ 'like' b -- a '^.' 'like' b ≡ b--- a '^.' 'like' b ≡ a '^.' 'to' ('const' b)+-- a '^.' 'like' b ≡ a '^.' 'Control.Lens.Getter.to' ('const' b) -- @ -- -- This can be useful as a second case 'failing' a 'Fold'@@ -205,7 +205,7 @@ -- at a monoidal value. -- -- @--- 'view' '.' 'to' ≡ 'id'+-- 'view' '.' 'Control.Lens.Getter.to' ≡ 'id' -- @ -- -- >>> view (to f) a@@ -250,7 +250,7 @@ -- 'Control.Lens.Traversal.Traversal'. -- -- @--- 'views' l f ≡ 'view' (l '.' 'to' f)+-- 'views' l f ≡ 'view' (l '.' 'Control.Lens.Getter.to' f) -- @ -- -- >>> views (to f) g a
src/Control/Lens/Internal/Deque.hs view
@@ -193,7 +193,9 @@ if lf + lr == 0 then Left empty else Right $ case f of- [] -> (head r, empty)+ [] -> case r of+ y:_ -> (y, empty)+ [] -> error "Control.Lens.Internal.Deque._Cons: Internal check failed" (x:xs) -> (x, check (lf - 1) xs lr r) {-# INLINE _Cons #-} @@ -202,6 +204,8 @@ if lf + lr == 0 then Left empty else Right $ case r of- [] -> (empty, head f)+ [] -> case f of+ y:_ -> (empty, y)+ [] -> error "Control.Lens.Internal.Deque._Snoc: Internal check failed" (x:xs) -> (check lf f (lr - 1) xs, x) {-# INLINE _Snoc #-}
+ src/Control/Lens/Internal/Doctest.hs view
@@ -0,0 +1,43 @@+-- | This module exists for the sole purpose of redefining the 'head' and 'tail'+-- functions (which are normally provided by the 'Prelude') so that they can be+-- used in the doctests of 'Data.Data.Lens'.+--+-- The 'head' and 'tail' functions are partial, and as of GHC 9.8, there is a+-- @-Wx-partial@ warning (implied by @-Wall@) that triggers any time you use+-- either of these functions. This is a fairly reasonable default in most+-- settings, but there are a handful of doctests in 'Data.Data.Lens' that do in+-- fact rely on 'head' and 'tail' being partial functions. These doctests+-- demonstrate that various functions in 'Data.Data.Lens' can recover from+-- exceptions that are thrown due to partiality (see, for instance, the @upon@+-- function).+--+-- One possible workaround would be to disable @-Wx-partial@. We don't want to+-- disable the warning for /all/ code in @lens@, however—we only want to+-- disable it for a particular group of doctests. It is rather tricky to achieve+-- this level of granularity, unfortunately. This is because tools like+-- @cabal-docspec@ rely on GHCi to work, and the statefulness of GHCi's @:set@+-- command means that disabling @-Wx-partial@ might leak into other modules'+-- doctests, which we don't want.+--+-- Instead, we opt to redefine our own versions of 'head' and 'tail' here, which+-- do not trigger any @-Wx-partial@ warnings, and use them in the+-- 'Data.Data.Lens' doctests. This has no impact on anyone reading the doctests,+-- as these functions will look indistinguishable from the 'head' and 'tail'+-- functions in the 'Prelude'. One consequence of this design is that we must+-- export the 'Control.Lens.Internal.Doctest' module, as GHCi (and therefore+-- @cabal-docspec@) won't be able to import it otherwise. Despite this technical+-- oddity, this module should be thought of as internal to @lens@.+module Control.Lens.Internal.Doctest+ ( head+ , tail+ ) where++import Prelude hiding (head, tail)++head :: [a] -> a+head (x:_) = x+head [] = error "head: empty list"++tail :: [a] -> [a]+tail (_:xs) = xs+tail [] = error "tail: empty list"
src/Control/Lens/Internal/FieldTH.hs view
@@ -1,5 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-}+#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE TemplateHaskellQuotes #-}+#else+{-# LANGUAGE TemplateHaskell #-}+#endif #ifdef TRUSTWORTHY # if MIN_VERSION_template_haskell(2,12,0) {-# LANGUAGE Safe #-}@@ -34,6 +39,7 @@ import Control.Lens.At import Control.Lens.Fold+import Control.Lens.Indexed import Control.Lens.Internal.TH import Control.Lens.Internal.Prelude import Control.Lens.Lens@@ -50,7 +56,7 @@ import qualified Language.Haskell.TH.Datatype as D import qualified Language.Haskell.TH.Datatype.TyVarBndr as D import Data.Maybe (fromMaybe,isJust,maybeToList)-import Data.List (nub, findIndices)+import Data.List (nub) import Data.Either (partitionEithers) import Data.Semigroup (Any (..)) import Data.Set.Lens@@ -84,7 +90,7 @@ fieldCons <- traverse normalizeConstructor cons let allFields = toListOf (folded . _2 . folded . _1 . folded) fieldCons let defCons = over normFieldLabels (expandName allFields) fieldCons- allDefs = setOf (normFieldLabels . folded) defCons+ allDefs = setOf (normFieldLabels . folded . _1) defCons T.sequenceA (Map.fromSet (buildScaffold rules s defCons) allDefs) let defs = Map.toList perDef@@ -104,8 +110,8 @@ normFieldLabels = traverse . _2 . traverse . _1 -- Map a (possibly missing) field's name to zero-to-many optic definitions- expandName :: [Name] -> Maybe Name -> [DefName]- expandName allFields = concatMap (_fieldToDef rules tyName allFields) . maybeToList+ expandName :: [Name] -> Maybe Name -> [(DefName, Maybe Name)]+ expandName allFields mName = (\x -> (x, mName)) <$> (maybeToList mName >>= _fieldToDef rules tyName allFields) -- | Normalized the Con type into a uniform positional representation, -- eliminating the variance between records, infix constructors, and normal@@ -141,15 +147,15 @@ -- type of clauses to generate and the type to annotate the declaration -- with. buildScaffold ::- LensRules ->- Type {- ^ outer type -} ->- [(Name, [([DefName], Type)])] {- ^ normalized constructors -} ->- DefName {- ^ target definition -} ->- Q (OpticType, OpticStab, [(Name, Int, [Int])])+ LensRules ->+ Type {- ^ outer type -} ->+ [(Name, [([(DefName, Maybe Name)], Type)])] {- ^ normalized constructors -} ->+ DefName {- ^ target definition -} ->+ Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]) {- ^ optic type, definition type, field count, target fields -} buildScaffold rules s cons defName = - do (s',t,a,b) <- buildStab s (concatMap snd consForDef)+ do (s',t,a,b) <- buildStab s (concatMap snd (consForDef <&> _2 . mapped . _Right %~ snd)) let defType | Just (_,cx,a') <- preview _ForallT a =@@ -184,29 +190,27 @@ return (opticType, defType, scaffolds) where- consForDef :: [(Name, [Either Type Type])]+ consForDef :: [(Name, [Either Type (Maybe Name, Type)])] consForDef = over (mapped . _2 . mapped) categorize cons - scaffolds :: [(Name, Int, [Int])]- scaffolds = [ (n, length ts, rightIndices ts) | (n,ts) <- consForDef ]-- rightIndices :: [Either Type Type] -> [Int]- rightIndices = findIndices (has _Right)+ scaffolds :: [(Name, Int, [(Maybe Name, Int)])]+ scaffolds = [ (n, length ts, (\(a, b) -> (b, a)) <$> ts ^@.. folded <. _Right . _1) | (n,ts) <- consForDef ] -- Right: types for this definition -- Left : other types- categorize :: ([DefName], Type) -> Either Type Type- categorize (defNames, t)- | defName `elem` defNames = Right t- | otherwise = Left t+ categorize :: ([(DefName, Maybe Name)], Type) -> Either Type (Maybe Name, Type)+ categorize (defNames, t) =+ case lookup defName defNames of+ Just c -> Right (c, t)+ Nothing -> Left t lensCase :: Bool lensCase = all (\x -> lengthOf (_2 . folded . _Right) x == 1) consForDef isoCase :: Bool isoCase = case scaffolds of- [(_,1,[0])] -> True- _ -> False+ [(_,1,[(_, 0)])] -> True+ _ -> False data OpticStab = OpticStab Name Type Type Type Type@@ -301,7 +305,7 @@ -- used to enable the resulting lenses to be used on a bottom value. makeFieldOptic :: LensRules ->- (DefName, (OpticType, OpticStab, [(Name, Int, [Int])])) ->+ (DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])) -> HasFieldClasses [Dec] makeFieldOptic rules (defName, (opticType, defType, cons)) = do locals <- get@@ -342,7 +346,7 @@ Name -> Name -> Type {- ^ Outer 's' type -} ->- [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] ->+ [(DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))] -> HasFieldClasses [Dec] makeClassyDriver rules className methodName s defs = T.sequenceA (cls ++ inst) @@ -357,13 +361,13 @@ Name -> Name -> Type {- ^ Outer 's' type -} ->- [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] ->+ [(DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))] -> DecQ makeClassyClass className methodName s defs = do let ss = map (stabToS . view (_2 . _2)) defs (sub,s') <- unifyTypes (s : ss) c <- newName "c"- let vars = D.freeVariablesWellScoped [s']+ let vars = D.changeTVFlags bndrReq $ D.freeVariablesWellScoped [s'] varNames = map D.tvName vars fd | null vars = [] | otherwise = [FunDep [c] varNames]@@ -390,7 +394,7 @@ Name -> Name -> Type {- ^ Outer 's' type -} ->- [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] ->+ [(DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))] -> HasFieldClasses Dec makeClassyInstance rules className methodName s defs = do methodss <- traverse (makeFieldOptic rules') defs@@ -433,7 +437,16 @@ containsTypeFamilies = go <=< D.resolveTypeSynonyms where- go (ConT nm) = has (_FamilyI . _1 . _TypeFamilyD) <$> reify nm+ go :: Type -> Q Bool+ go (ConT nm) =+ -- Note that the call to `reify` can fail if `nm` is not yet defined.+ -- (This can actually happen if `nm` is declared in a Template Haskell+ -- quote.) If this fails, there is no way to tell if the type contains+ -- type families, so we recover and conservatively assume that is does not+ -- contain any.+ recover+ (pure False)+ (has (_FamilyI . _1 . _TypeFamilyD) <$> reify nm) go ty = or <$> traverse go (ty ^.. plate) -- We want to catch type families, but not *data* families. See #799.@@ -456,20 +469,21 @@ ------------------------------------------------------------------------ -makeFieldClauses :: LensRules -> OpticType -> [(Name, Int, [Int])] -> [ClauseQ]+makeFieldClauses :: LensRules -> OpticType -> [(Name, Int, [(Maybe Name, Int)])] -> [ClauseQ] makeFieldClauses rules opticType cons = case opticType of IsoType -> [ makeIsoClause conName | (conName, _, _) <- cons ] - GetterType -> [ makeGetterClause conName fieldCount fields+ GetterType -> [ makeGetterClause conName fieldCount (snd <$> fields) | (conName, fieldCount, fields) <- cons ] - LensType -> [ makeFieldOpticClause conName fieldCount fields irref+ LensType -> [ makeFieldOpticClause conName fieldCount fields irref recSyn | (conName, fieldCount, fields) <- cons ] where irref = _lazyPatterns rules && length cons == 1+ recSyn = _recordSyntax rules && length cons == 1 @@ -492,16 +506,20 @@ makeGetterClause conName fieldCount fields = do f <- newName "f" xs <- newNames "x" (length fields)+ xs' <-+ case xs of+ (x:xs') -> pure (x :| xs')+ [] -> fail "makeGetterClause: Internal check failed" let pats (i:is) (y:ys) | i `elem` fields = varP y : pats is ys | otherwise = wildP : pats is (y:ys) pats is _ = map (const wildP) is - fxs = [ appE (varE f) (varE x) | x <- xs ]+ (fx :| fxs) = fmap (appE (varE f) . varE) xs' body = foldl (\a b -> appsE [varE apValName, a, b])- (appE (varE phantomValName) (head fxs))- (tail fxs)+ (appE (varE phantomValName) fx)+ fxs -- clause f (Con x1..xn) = coerce (f x1) <*> ... <*> f xn clause [varP f, conP conName (pats [0..fieldCount - 1] xs)]@@ -511,15 +529,25 @@ -- | Build a clause that updates the field at the given indexes -- When irref is 'True' the value with me matched with an irrefutable -- pattern. This is suitable for Lens and Traversal construction-makeFieldOpticClause :: Name -> Int -> [Int] -> Bool -> ClauseQ-makeFieldOpticClause conName fieldCount [] _ =+makeFieldOpticClause :: Name -> Int -> [(Maybe Name, Int)] -> Bool -> Bool -> ClauseQ+makeFieldOpticClause conName fieldCount [] _ _ = makePureClause conName fieldCount-makeFieldOpticClause conName fieldCount (field:fields) irref =+makeFieldOpticClause _ _ [(Just fieldName, _)] _ True =+ do f <- newName "f"+ r <- newName "r"+ x <- newName "x"+ let body = appsE [ [| fmap |]+ , lamE [varP x] (recUpdE (varE r) [(,) fieldName <$> varE x])+ , varE f `appE` (varE fieldName `appE` varE r)+ ]+ clause [varP f, varP r] (normalB body) []+makeFieldOpticClause conName fieldCount ((_, field):fieldsWithNames) irref _ = do f <- newName "f" xs <- newNames "x" fieldCount- ys <- newNames "y" (1 + length fields)+ ys <- newNames "y" (1 + length fieldsWithNames) - let xs' = foldr (\(i,x) -> set (ix i) x) xs (zip (field:fields) ys)+ let fields = snd <$> fieldsWithNames+ xs' = foldr (\(i,x) -> set (ix i) x) xs (zip (field:fields) ys) mkFx i = appE (varE f) (varE (xs !! i)) @@ -625,6 +653,7 @@ , _allowIsos :: Bool , _allowUpdates :: Bool -- ^ Allow Lens/Traversal (otherwise Getter/Fold) , _lazyPatterns :: Bool+ , _recordSyntax :: Bool , _fieldToDef :: FieldNamer -- ^ Type Name -> Field Names -> Target Field Name -> Definition Names , _classyLenses :: ClassyNamer
src/Control/Lens/Internal/Iso.hs view
@@ -33,6 +33,9 @@ import qualified Data.Vector.Storable as Storable import qualified Data.Vector.Unboxed as Unbox import Data.Vector.Unboxed (Unbox)+#if MIN_VERSION_vector(0,13,2)+import qualified Data.Vector.Strict as VectorStrict+#endif import qualified Data.Sequence as Seq import Data.Sequence (Seq) import Foreign.Storable (Storable)@@ -100,3 +103,8 @@ instance Storable a => Reversing (Storable.Vector a) where reversing = Storable.reverse++#if MIN_VERSION_vector(0,13,2)+instance Reversing (VectorStrict.Vector a) where+ reversing = VectorStrict.reverse+#endif
src/Control/Lens/Internal/PrismTH.hs view
@@ -433,7 +433,7 @@ ] cons' = map (over nconName prismName) cons- vs = D.freeVariablesWellScoped [t]+ vs = D.changeTVFlags bndrReq $ D.freeVariablesWellScoped [t] vNames = map D.tvName vs fds r | null vs = []
src/Control/Lens/Internal/TH.hs view
@@ -20,7 +20,13 @@ -- Portability : non-portable -- -----------------------------------------------------------------------------module Control.Lens.Internal.TH where+module Control.Lens.Internal.TH+ ( module Control.Lens.Internal.TH+#if MIN_VERSION_template_haskell(2,21,0) || MIN_VERSION_th_abstraction(0,6,0)+ , D.TyVarBndrVis+ , D.bndrReq+#endif+ ) where import Control.Lens.Iso import Control.Lens.Prism@@ -98,32 +104,30 @@ datatypeTypeKinded :: D.DatatypeInfo -> Type datatypeTypeKinded di = foldl AppT (ConT (D.datatypeName di))- $ dropSigsIfNonDataFam+ $ dropSigsIfNonDataFam di $ D.datatypeInstTypes di- where- {-- In an effort to prevent users from having to enable KindSignatures every- time that they use lens' TH functionality, we strip off reified kind- annotations from when: - 1. The kind of a type does not contain any kind variables. If it *does*- contain kind variables, we want to preserve them so that we can generate- type signatures that preserve the dependency order of kind and type- variables. (The data types in test/T917.hs contain examples where this- is important.) This will require enabling `PolyKinds`, but since- `PolyKinds` implies `KindSignatures`, we can at least accomplish two- things at once.- 2. The data type is not an instance of a data family. We make an exception- for data family instances, since the presence or absence of a kind- annotation can be the difference between typechecking or not.- (See T917DataFam in tests/T917.hs for an example.) Moreover, the- `TypeFamilies` extension implies `KindSignatures`.- -}- dropSigsIfNonDataFam :: [Type] -> [Type]- dropSigsIfNonDataFam- | isDataFamily (D.datatypeVariant di) = id- | otherwise = map dropSig-+-- | In an effort to prevent users from having to enable KindSignatures every+-- time that they use lens' TH functionality, we strip off reified kind+-- annotations from when:+--+-- 1. The kind of a type does not contain any kind variables. If it *does*+-- contain kind variables, we want to preserve them so that we can generate+-- type signatures that preserve the dependency order of kind and type+-- variables. (The data types in test/T917.hs contain examples where this+-- is important.) This will require enabling `PolyKinds`, but since+-- `PolyKinds` implies `KindSignatures`, we can at least accomplish two+-- things at once.+-- 2. The data type is not an instance of a data family. We make an exception+-- for data family instances, since the presence or absence of a kind+-- annotation can be the difference between typechecking or not.+-- (See T917DataFam in tests/T917.hs for an example.) Moreover, the+-- `TypeFamilies` extension implies `KindSignatures`.+dropSigsIfNonDataFam :: D.DatatypeInfo -> [Type] -> [Type]+dropSigsIfNonDataFam di+ | isDataFamily (D.datatypeVariant di) = id+ | otherwise = map dropSig+ where dropSig :: Type -> Type dropSig (SigT t k) | null (D.freeVariables k) = t dropSig t = t@@ -156,6 +160,16 @@ isDataFamily D.Newtype = False isDataFamily D.DataInstance = True isDataFamily D.NewtypeInstance = True+#if MIN_VERSION_th_abstraction(0,5,0)+isDataFamily D.TypeData = False+#endif++#if !(MIN_VERSION_template_haskell(2,21,0)) && !(MIN_VERSION_th_abstraction(0,6,0))+type TyVarBndrVis = D.TyVarBndr_ ()++bndrReq :: ()+bndrReq = ()+#endif ------------------------------------------------------------------------ -- TH-quoted names
src/Control/Lens/Iso.hs view
@@ -5,7 +5,12 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE Trustworthy #-}++#if __GLASGOW_HASKELL__ >= 806+{-# LANGUAGE PolyKinds #-}+#else {-# LANGUAGE TypeInType #-}+#endif #include "lens-common.h"
src/Control/Lens/Lens.hs view
@@ -6,7 +6,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Trustworthy #-}++#if __GLASGOW_HASKELL__ >= 806+{-# LANGUAGE PolyKinds #-}+#else {-# LANGUAGE TypeInType #-}+#endif #include "lens-common.h" @@ -82,18 +87,18 @@ -- * Setting Functionally with Passthrough , (<%~), (<+~), (<-~), (<*~), (<//~) , (<^~), (<^^~), (<**~)- , (<||~), (<&&~), (<<>~)+ , (<||~), (<&&~), (<<>~), (<<>:~) , (<<%~), (<<.~), (<<?~), (<<+~), (<<-~), (<<*~) , (<<//~), (<<^~), (<<^^~), (<<**~)- , (<<||~), (<<&&~), (<<<>~)+ , (<<||~), (<<&&~), (<<<>~), (<<<>:~) -- * Setting State with Passthrough , (<%=), (<+=), (<-=), (<*=), (<//=) , (<^=), (<^^=), (<**=)- , (<||=), (<&&=), (<<>=)+ , (<||=), (<&&=), (<<>=), (<<>:=) , (<<%=), (<<.=), (<<?=), (<<+=), (<<-=), (<<*=) , (<<//=), (<<^=), (<<^^=), (<<**=)- , (<<||=), (<<&&=), (<<<>=)+ , (<<||=), (<<&&=), (<<<>=), (<<<>:=) , (<<~) -- * Cloning Lenses@@ -158,10 +163,10 @@ -- >>> let setter :: Expr -> Expr -> Expr; setter = fun "setter" infixl 8 ^#-infixr 4 %%@~, <%@~, <<%@~, %%~, <+~, <*~, <-~, <//~, <^~, <^^~, <**~, <&&~, <||~, <<>~, <%~, <<%~, <<.~, <<?~, <#~, #~, #%~, <#%~, #%%~- , <<+~, <<-~, <<*~, <<//~, <<^~, <<^^~, <<**~, <<||~, <<&&~, <<<>~-infix 4 %%@=, <%@=, <<%@=, %%=, <+=, <*=, <-=, <//=, <^=, <^^=, <**=, <&&=, <||=, <<>=, <%=, <<%=, <<.=, <<?=, <#=, #=, #%=, <#%=, #%%=- , <<+=, <<-=, <<*=, <<//=, <<^=, <<^^=, <<**=, <<||=, <<&&=, <<<>=+infixr 4 %%@~, <%@~, <<%@~, %%~, <+~, <*~, <-~, <//~, <^~, <^^~, <**~, <&&~, <||~, <<>~, <<>:~, <%~, <<%~, <<.~, <<?~, <#~, #~, #%~, <#%~, #%%~+ , <<+~, <<-~, <<*~, <<//~, <<^~, <<^^~, <<**~, <<||~, <<&&~, <<<>~, <<<>:~+infix 4 %%@=, <%@=, <<%@=, %%=, <+=, <*=, <-=, <//=, <^=, <^^=, <**=, <&&=, <||=, <<>=, <<>:=, <%=, <<%=, <<.=, <<?=, <#=, #=, #%=, <#%=, #%%=+ , <<+=, <<-=, <<*=, <<//=, <<^=, <<^^=, <<**=, <<||=, <<&&=, <<<>=, <<<>:= infixr 2 <<~ infixl 1 ??, &~ @@ -1186,6 +1191,42 @@ (<<>=) :: (MonadState s m, Semigroup r) => LensLike' ((,)r) s r -> r -> m r l <<>= r = l <%= (<> r) {-# INLINE (<<>=) #-}++-- | ('<>') a 'Semigroup' value onto the front of the target of a 'Lens' and+-- return the result.+-- However, unlike ('<<>~'), it is prepended to the head side.+--+-- When you do not need the result of the operation, ('Control.Lens.Setter.<>:~') is more flexible.+(<<>:~) :: Semigroup m => LensLike ((,) m) s t m m -> m -> s -> (m, t)+l <<>:~ m = l <%~ (m <>)+{-# INLINE (<<>:~) #-}++-- | ('<>') a 'Semigroup' value onto the front of the target of a 'Lens' and+-- return the /old/ result.+-- However, unlike ('<<>~'), it is prepended to the head side.+--+-- When you do not need the result of the operation, ('Control.Lens.Setter.<>:~') is more flexible.+(<<<>:~) :: Semigroup m => LensLike' ((,) m) s m -> m -> s -> (m, s)+l <<<>:~ m = l <<%~ (m <>)+{-# INLINE (<<<>:~) #-}++-- | ('<>') a 'Semigroup' value onto the front of the target of a 'Lens' into+-- your 'Monad''s state and return the result.+-- However, unlike ('<<>='), it is prepended to the head side.+--+-- When you do not need the result of the operation, ('Control.Lens.Setter.<>:=') is more flexible.+(<<>:=) :: (MonadState s m, Semigroup r) => LensLike' ((,) r) s r -> r -> m r+l <<>:= r = l <%= (r <>)+{-# INLINE (<<>:=) #-}++-- | ('<>') a 'Semigroup' value onto the front of the target of a 'Lens' into+-- your 'Monad''s state and return the /old/ result.+-- However, unlike ('<<<>='), it is prepended to the head side.+--+-- When you do not need the result of the operation, ('Control.Lens.Setter.<>:=') is more flexible.+(<<<>:=) :: (MonadState s m, Semigroup r) => LensLike' ((,) r) s r -> r -> m r+l <<<>:= r = l <<%= (r <>)+{-# INLINE (<<<>:=) #-} ------------------------------------------------------------------------------ -- Arrow operators
src/Control/Lens/Operators.hs view
@@ -18,6 +18,18 @@ -- * "Control.Lens.Cons" (<|) , (|>)+ , (<|~)+ , (<|=)+ , (<<|~)+ , (<<|=)+ , (<<<|~)+ , (<<<|=)+ , (|>~)+ , (|>=)+ , (<|>~)+ , (<|>=)+ , (<<|>~)+ , (<<|>=) -- * "Control.Lens.Fold" , (^..) , (^?)@@ -62,6 +74,7 @@ , (<<||~) , (<<&&~) , (<<<>~)+ , (<<<>:~) , (<%=) , (<+=) , (<-=)@@ -85,9 +98,12 @@ , (<<||=) , (<<&&=) , (<<<>=)+ , (<<<>:=) , (<<~) , (<<>~) , (<<>=)+ , (<<>:~)+ , (<<>:=) , (<%@~) , (<<%@~) , (%%@~)@@ -141,6 +157,8 @@ , (<?=) , (<>~) , (<>=)+ , (<>:~)+ , (<>:=) , (.@~) , (.@=) , (%@~)
src/Control/Lens/Plated.hs view
@@ -385,13 +385,18 @@ -- @ -- 'universeOf' :: 'Fold' a a -> a -> [a] -- @-universeOf :: Getting [a] a a -> a -> [a]-universeOf l = go where- go a = a : foldMapOf l go a+universeOf :: Getting (Endo [a]) a a -> a -> [a]+universeOf l = \x -> appEndo (universeOf' l x) [] {-# INLINE universeOf #-} +universeOf' :: Getting (Endo [a]) a a -> a -> Endo [a]+universeOf' l = go where+ go a = Endo (a :) <> foldMapOf l go a+{-# INLINE universeOf' #-}++ -- | Given a 'Fold' that knows how to find 'Plated' parts of a container retrieve them and all of their descendants, recursively.-universeOn :: Plated a => Getting [a] s a -> s -> [a]+universeOn :: Plated a => Getting (Endo [a]) s a -> s -> [a] universeOn b = universeOnOf b plate {-# INLINE universeOn #-} @@ -401,8 +406,8 @@ -- @ -- 'toListOf' l ≡ 'universeOnOf' l 'ignored' -- @-universeOnOf :: Getting [a] s a -> Getting [a] a a -> s -> [a]-universeOnOf b = foldMapOf b . universeOf+universeOnOf :: Getting (Endo [a]) s a -> Getting (Endo [a]) a a -> s -> [a]+universeOnOf b = \p x -> appEndo (foldMapOf b (universeOf' p) x) [] {-# INLINE universeOnOf #-} -- | Fold over all transitive descendants of a 'Plated' container, including itself.@@ -675,7 +680,7 @@ -- -- @ -- 'composOpMonoid' ≡ 'foldMapOf' 'plate'--- 'composOpMPlus' f ≡ 'msumOf' ('plate' '.' 'to' f)+-- 'composOpMPlus' f ≡ 'msumOf' ('plate' '.' 'Control.Lens.Getter.to' f) -- 'composOp' ≡ 'descend' ≡ 'over' 'plate' -- 'composOpM' ≡ 'descendM' ≡ 'mapMOf' 'plate' -- 'composOpM_' ≡ 'descendM_' ≡ 'mapMOf_' 'plate'
src/Control/Lens/Reified.hs view
@@ -50,7 +50,7 @@ -- Lens ------------------------------------------------------------------------------ --- | Reify a 'Lens' so it can be stored safely in a container.+-- | Reify a t'Lens' so it can be stored safely in a container. newtype ReifiedLens s t a b = Lens { runLens :: Lens s t a b } -- | @@@ -62,7 +62,7 @@ -- IndexedLens ------------------------------------------------------------------------------ --- | Reify an 'IndexedLens' so it can be stored safely in a container.+-- | Reify an t'IndexedLens' so it can be stored safely in a container. newtype ReifiedIndexedLens i s t a b = IndexedLens { runIndexedLens :: IndexedLens i s t a b } -- | @@@ -74,7 +74,7 @@ -- IndexedTraversal ------------------------------------------------------------------------------ --- | Reify an 'IndexedTraversal' so it can be stored safely in a container.+-- | Reify an t'IndexedTraversal' so it can be stored safely in a container. newtype ReifiedIndexedTraversal i s t a b = IndexedTraversal { runIndexedTraversal :: IndexedTraversal i s t a b } -- | @@@ -86,7 +86,7 @@ -- Traversal ------------------------------------------------------------------------------ --- | A form of 'Traversal' that can be stored monomorphically in a container.+-- | A form of t'Traversal' that can be stored monomorphically in a container. newtype ReifiedTraversal s t a b = Traversal { runTraversal :: Traversal s t a b } -- | @@@ -98,7 +98,7 @@ -- Getter ------------------------------------------------------------------------------ --- | Reify a 'Getter' so it can be stored safely in a container.+-- | Reify a t'Getter' so it can be stored safely in a container. -- -- This can also be useful when combining getters in novel ways, as -- 'ReifiedGetter' is isomorphic to '(->)' and provides similar instances.@@ -249,7 +249,7 @@ -- IndexedGetter ------------------------------------------------------------------------------ --- | Reify an 'IndexedGetter' so it can be stored safely in a container.+-- | Reify an t'IndexedGetter' so it can be stored safely in a container. newtype ReifiedIndexedGetter i s a = IndexedGetter { runIndexedGetter :: IndexedGetter i s a } instance Profunctor (ReifiedIndexedGetter i) where@@ -289,7 +289,7 @@ -- Fold ------------------------------------------------------------------------------ --- | Reify a 'Fold' so it can be stored safely in a container.+-- | Reify a t'Fold' so it can be stored safely in a container. -- -- This can also be useful for creatively combining folds as -- @'ReifiedFold' s@ is isomorphic to @ReaderT s []@ and provides similar@@ -490,7 +490,7 @@ -- Setter ------------------------------------------------------------------------------ --- | Reify a 'Setter' so it can be stored safely in a container.+-- | Reify a t'Setter' so it can be stored safely in a container. newtype ReifiedSetter s t a b = Setter { runSetter :: Setter s t a b } -- | @@@ -502,7 +502,7 @@ -- IndexedSetter ------------------------------------------------------------------------------ --- | Reify an 'IndexedSetter' so it can be stored safely in a container.+-- | Reify an t'IndexedSetter' so it can be stored safely in a container. newtype ReifiedIndexedSetter i s t a b = IndexedSetter { runIndexedSetter :: IndexedSetter i s t a b } @@ -515,7 +515,7 @@ -- Iso ------------------------------------------------------------------------------ --- | Reify an 'Iso' so it can be stored safely in a container.+-- | Reify an t'Iso' so it can be stored safely in a container. newtype ReifiedIso s t a b = Iso { runIso :: Iso s t a b } -- | @@@ -527,7 +527,7 @@ -- Prism ------------------------------------------------------------------------------ --- | Reify a 'Prism' so it can be stored safely in a container.+-- | Reify a t'Prism' so it can be stored safely in a container. newtype ReifiedPrism s t a b = Prism { runPrism :: Prism s t a b } -- | @
src/Control/Lens/Setter.hs view
@@ -49,11 +49,11 @@ , over , set , (.~), (%~)- , (+~), (-~), (*~), (//~), (^~), (^^~), (**~), (||~), (<>~), (&&~), (<.~), (?~), (<?~)+ , (+~), (-~), (*~), (//~), (^~), (^^~), (**~), (||~), (<>~), (<>:~), (&&~), (<.~), (?~), (<?~) -- * State Combinators , assign, modifying , (.=), (%=)- , (+=), (-=), (*=), (//=), (^=), (^^=), (**=), (||=), (<>=), (&&=), (<.=), (?=), (<?=)+ , (+=), (-=), (*=), (//=), (^=), (^^=), (**=), (||=), (<>=), (<>:=), (&&=), (<.=), (?=), (<?=) , (<~) -- * Writer Combinators , scribe@@ -80,8 +80,8 @@ import Control.Arrow import Control.Comonad-import Control.Lens.Internal.Prelude import Control.Lens.Internal.Indexed+import Control.Lens.Internal.Prelude import Control.Lens.Internal.Setter import Control.Lens.Type import Control.Monad (liftM)@@ -105,8 +105,8 @@ -- >>> let setter :: Expr -> Expr -> Expr; setter = fun "setter" -- >>> :set -XNoOverloadedStrings -infixr 4 %@~, .@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, <.~, ?~, <?~-infix 4 %@=, .@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, ||=, %=, <.=, ?=, <?=+infixr 4 %@~, .@~, .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, <>:~, ||~, %~, <.~, ?~, <?~+infix 4 %@=, .@=, .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, <>=, <>:=, ||=, %=, <.=, ?=, <?= infixr 2 <~ ------------------------------------------------------------------------------@@ -1069,6 +1069,24 @@ (<>=) :: (MonadState s m, Semigroup a) => ASetter' s a -> a -> m () l <>= a = State.modify (l <>~ a) {-# INLINE (<>=) #-}++-- | Modify the target of a 'Semigroup' value by using @('<>')@.+-- However, unlike '<>~', it is prepend to the head side.+--+-- >>> ["world"] & id <>:~ ["hello"]+-- ["hello","world"]+--+-- >>> (["world"], ["lens"]) & _1 <>:~ ["hello"]+-- (["hello","world"],["lens"])+(<>:~) :: Semigroup b => ASetter s t b b -> b -> s -> t+l <>:~ n = over l (n <>)+{-# INLINE (<>:~) #-}++-- | Modify the target(s) of a 'Lens'', 'Iso', 'Setter' or 'Traversal' by using @('<>')@.+-- However, unlike '<>=', it is prepend to the head side.+(<>:=) :: (MonadState s m, Semigroup a) => ASetter' s a -> a -> m ()+l <>:= a = State.modify (l <>:~ a)+{-# INLINE (<>:=) #-} ----------------------------------------------------------------------------- -- Writer Operations
src/Control/Lens/TH.hs view
@@ -28,6 +28,7 @@ , makeClassy, makeClassyFor, makeClassy_ , makeFields , makeFieldsNoPrefix+ , makeFieldsId -- ** Prisms , makePrisms , makeClassyPrisms@@ -58,6 +59,7 @@ , classUnderscoreNoPrefixFields , underscoreFields , abbreviatedFields+ , classIdFields -- ** LensRules configuration accessors , lensField , FieldNamer@@ -69,6 +71,7 @@ , generateSignatures , generateUpdateableOptics , generateLazyPatterns+ , generateRecordSyntax -- ** FieldNamers , underscoreNoPrefixNamer , lookingupNamer@@ -77,6 +80,7 @@ , classUnderscoreNoPrefixNamer , underscoreNamer , abbreviatedNamer+ , classIdNamer ) where import Prelude ()@@ -88,7 +92,6 @@ import Control.Lens.Getter import Control.Lens.Lens import Control.Lens.Setter-import Control.Lens.Tuple import Control.Lens.Traversal import Control.Lens.Internal.Prelude as Prelude import Control.Lens.Internal.TH@@ -104,15 +107,10 @@ import Data.Maybe (maybeToList) import qualified Data.Set as Set import Data.Set (Set)-import Data.Set.Lens import Data.Traversable hiding (mapM) import Language.Haskell.TH.Datatype-import Language.Haskell.TH.Datatype.TyVarBndr as D import Language.Haskell.TH.Lens import Language.Haskell.TH.Lib-#if MIN_VERSION_template_haskell(2,15,0)-import Language.Haskell.TH.Ppr (pprint)-#endif import Language.Haskell.TH.Syntax hiding (lift) -- | Generate "simple" optics even when type-changing optics are possible.@@ -166,6 +164,10 @@ generateLazyPatterns f r = fmap (\x -> r { _lazyPatterns = x}) (f (_lazyPatterns r)) +generateRecordSyntax :: Lens' LensRules Bool+generateRecordSyntax f r =+ fmap (\x -> r {_recordSyntax = x}) (f (_recordSyntax r))+ -- | Create the class if the constructor is 'Control.Lens.Type.Simple' and the -- 'lensClass' rule matches. createClass :: Lens' LensRules Bool@@ -191,6 +193,7 @@ , _allowIsos = True , _allowUpdates = True , _lazyPatterns = False+ , _recordSyntax = False , _classyLenses = const Nothing , _fieldToDef = underscoreNoPrefixNamer }@@ -232,6 +235,7 @@ , _allowIsos = False -- generating Isos would hinder "subtyping" , _allowUpdates = True , _lazyPatterns = False+ , _recordSyntax = False , _classyLenses = \n -> case nameBase n of x:xs -> Just (mkName ("Has" ++ x:xs), mkName (toLower x:xs))@@ -446,7 +450,9 @@ -- | Build 'Control.Lens.Wrapped.Wrapped' instance for each newtype. declareWrapped :: DecsQ -> DecsQ declareWrapped = declareWith $ \dec -> do- maybeDecs <- liftDeclare (makeWrappedForDec dec)+ maybeDecs <- liftDeclare $ do+ inf <- normalizeDec dec+ makeWrappedForDatatypeInfo inf forM_ maybeDecs emit return dec @@ -466,14 +472,6 @@ -- Internal TH Implementation ----------------------------------------------------------------------------- --- | Transform @NewtypeD@s declarations to @DataD@s and @NewtypeInstD@s to--- @DataInstD@s.-deNewtype :: Dec -> Dec-deNewtype (NewtypeD ctx tyName args kind c d) = DataD ctx tyName args kind [c] d-deNewtype (NewtypeInstD ctx tyName args kind c d) = DataInstD ctx tyName args kind [c] d-deNewtype d = d-- -- | Given a set of names, build a map from those names to a set of fresh names -- based on them. freshMap :: Set Name -> Q (Map Name Name)@@ -484,96 +482,39 @@ apps = Prelude.foldl AppT -makeDataDecl :: Dec -> Maybe DataDecl-makeDataDecl dec = case deNewtype dec of- DataD ctx tyName args _ cons _ -> Just DataDecl- { dataContext = ctx- , tyConName = Just tyName- , dataParameters = args- , fullType = apps $ ConT tyName- , constructors = cons- }-#if MIN_VERSION_template_haskell(2,15,0)- DataInstD ctx _ fnArgs _ cons _-#else- DataInstD ctx familyName args _ cons _-#endif- -> Just DataDecl- { dataContext = ctx- , tyConName = Nothing- , dataParameters = map D.plainTV vars- , fullType = \tys -> apps (ConT familyName) $- substType (Map.fromList $ zip vars tys) args- , constructors = cons- }- where- -- The list of "type parameters" to a data family instance is not- -- explicitly specified in the source. Here we define it to be- -- the set of distinct type variables that appear in the LHS. e.g.- --- -- data instance F a Int (Maybe (a, b)) = G- --- -- has 2 type parameters: a and b.- vars = toList $ setOf typeVars args--#if MIN_VERSION_template_haskell(2,15,0)- (familyName, args) =- case unfoldType fnArgs of- (ConT familyName', args') -> (familyName', args')- (_, _) -> error $ "Illegal data instance LHS: " ++ pprint fnArgs-#endif- _ -> Nothing---- | A data, newtype, data instance or newtype instance declaration.-data DataDecl = DataDecl- { dataContext :: Cxt -- ^ Datatype context.- , tyConName :: Maybe Name- -- ^ Type constructor name, or Nothing for a data family instance.- , dataParameters :: [TyVarBndrUnit] -- ^ List of type parameters- , fullType :: [Type] -> Type- -- ^ Create a concrete record type given a substitution to- -- 'detaParameters'.- , constructors :: [Con] -- ^ Constructors- -- , derivings :: [Name] -- currently not needed- }--- -- | Build 'Wrapped' instance for a given newtype makeWrapped :: Name -> DecsQ makeWrapped nm = do- inf <- reify nm- case inf of- TyConI decl -> do- maybeDecs <- makeWrappedForDec decl- maybe (fail "makeWrapped: Unsupported data type") return maybeDecs- _ -> fail "makeWrapped: Expected the name of a newtype or datatype"+ inf <- reifyDatatype nm+ maybeDecs <- makeWrappedForDatatypeInfo inf+ maybe (fail "makeWrapped: Unsupported data type") return maybeDecs -makeWrappedForDec :: Dec -> Q (Maybe [Dec])-makeWrappedForDec decl = case makeDataDecl decl of- Just dataDecl | [con] <- constructors dataDecl- , [field] <- toListOf (conFields._2) con- -> do wrapped <- makeWrappedInstance dataDecl con field- rewrapped <- makeRewrappedInstance dataDecl- return (Just [rewrapped, wrapped])- _ -> return Nothing+makeWrappedForDatatypeInfo :: DatatypeInfo -> Q (Maybe [Dec])+makeWrappedForDatatypeInfo dataInfo@(DatatypeInfo{datatypeCons = cons})+ | [conInfo@(ConstructorInfo{constructorFields = fields})] <- cons+ , [field] <- fields+ = do wrapped <- makeWrappedInstance dataInfo conInfo field+ rewrapped <- makeRewrappedInstance dataInfo+ return (Just [rewrapped, wrapped]) -makeRewrappedInstance :: DataDecl -> DecQ-makeRewrappedInstance dataDecl = do+ | otherwise = return Nothing +makeRewrappedInstance :: DatatypeInfo -> DecQ+makeRewrappedInstance dataInfo = do+ t <- varT <$> newName "t" - let typeArgs = map (view name) (dataParameters dataDecl)+ let typeArgs = map (view name) (datatypeVars dataInfo) typeArgs' <- do m <- freshMap (Set.fromList typeArgs) return (substTypeVars m typeArgs) -- Con a b c...- let appliedType = return (fullType dataDecl (map VarT typeArgs))+ let appliedType = return (applyDatatypeToArgs dataInfo (map VarT typeArgs)) -- Con a' b' c'...- appliedType' = return (fullType dataDecl (map VarT typeArgs'))+ appliedType' = return (applyDatatypeToArgs dataInfo (map VarT typeArgs')) -- Con a' b' c'... ~ t eq = AppT. AppT EqualityT <$> appliedType' <*> t@@ -584,14 +525,14 @@ -- instance (Con a' b' c'... ~ t) => Rewrapped (Con a b c...) t instanceD (cxt [eq]) klass [] -makeWrappedInstance :: DataDecl-> Con -> Type -> DecQ-makeWrappedInstance dataDecl con fieldType = do+makeWrappedInstance :: DatatypeInfo -> ConstructorInfo -> Type -> DecQ+makeWrappedInstance dataInfo conInfo fieldType = do - let conName = view name con- let typeArgs = toListOf typeVars (dataParameters dataDecl)+ let conName = constructorName conInfo+ let typeArgs = toListOf typeVars (datatypeVars dataInfo) -- Con a b c...- let appliedType = fullType dataDecl (map VarT typeArgs)+ let appliedType = applyDatatypeToArgs dataInfo (map VarT typeArgs) -- type Unwrapped (Con a b c...) = $fieldType let unwrappedATF = tySynInstDCompat unwrappedTypeName Nothing@@ -611,6 +552,23 @@ -- _Wrapped' = iso (\(Con x) -> x) Con instanceD (cxt []) klass [unwrappedATF, isoMethod] +-- | Apply the 'datatypeName' of a 'DatatypeInfo' to some argument 'Type's,+-- which are used to instantiate its 'datatypeVars'.+applyDatatypeToArgs :: DatatypeInfo -> [Type] -> Type+applyDatatypeToArgs di@(DatatypeInfo { datatypeName = nm+ , datatypeVars = vars+ , datatypeInstTypes = instTypes+ }) args =+ apps (ConT nm) $+ -- Drop kind signatures if possible to reduce the likelihood of needing to+ -- enable KindSignatures. The likelihood is already quite small, however.+ -- This function is only used for the benefit of {make,declare}Wrapped, and+ -- one needs to enable TypeFamilies in order for the generated code to+ -- typecheck. Since TypeFamilies implies KindSignatures, dropping kind+ -- signatures is probably not required, but better to be safe then sorry.+ dropSigsIfNonDataFam di $+ applySubstitution (Map.fromList (zip (map tvName vars) args)) instTypes+ overHead :: (a -> a) -> [a] -> [a] overHead _ [] = [] overHead f (x:xs) = f x : xs@@ -679,6 +637,19 @@ methodName = fieldUnprefixed return (MethodName (mkName className) (mkName methodName)) +-- | Field rules for fields whose names are to be used verbatim, with no+-- prefixes, no underscores, no transformations of any kind.+classIdFields :: LensRules+classIdFields =+ defaultFieldRules & lensField .~ classIdNamer++-- | A 'FieldNamer' for 'classIdFields'.+classIdNamer :: FieldNamer+classIdNamer _ _ field = [MethodName (mkName className) (mkName fieldName)]+ where+ fieldName = nameBase field+ className = "Has" ++ overHead toUpper fieldName+ -- | Field rules fields in the form @ prefixFieldname or _prefixFieldname @ -- If you want all fields to be lensed, then there is no reason to use an @_@ before the prefix. -- If any of the record fields leads with an @_@ then it is assume a field without an @_@ should not have a lens created.@@ -789,6 +760,42 @@ makeFieldsNoPrefix :: Name -> DecsQ makeFieldsNoPrefix = makeFieldOptics classUnderscoreNoPrefixFields +-- | Generate overloaded field accessors, using exactly the same names as the+-- underlying fields. Intended for use with the @NoFieldSelectors@ and+-- @DuplicateRecordFields@ language extensions.+--+-- As an example:+--+-- @+-- data Foo a = Foo { x :: 'Int', y :: a }+-- newtype Bar = Bar { x :: 'Char' }+-- makeFieldsId ''Foo+-- makeFieldsId ''Bar+-- @+--+-- will create classes+--+-- @+-- class HasX s a | s -> a where+-- x :: Lens' s a+-- class HasY s a | s -> a where+-- y :: Lens' s a+-- @+--+-- together with instances+--+-- @+-- instance HasX (Foo a) Int+-- instance HasY (Foo a) a where+-- instance HasX Bar Char where+-- @+--+-- @+-- makeFieldsId = 'makeLensesWith' 'classIdFields'+-- @+makeFieldsId :: Name -> DecsQ+makeFieldsId = makeFieldOptics classIdFields+ defaultFieldRules :: LensRules defaultFieldRules = LensRules { _simpleLenses = True@@ -797,6 +804,7 @@ , _allowIsos = False -- generating Isos would hinder field class reuse , _allowUpdates = True , _lazyPatterns = False+ , _recordSyntax = False , _classyLenses = const Nothing , _fieldToDef = camelCaseNamer }
src/Control/Lens/Traversal.hs view
@@ -162,7 +162,7 @@ import Data.Semigroup.Traversable import Data.Semigroup.Bitraversable import Data.Tuple (swap)-import GHC.Magic (inline)+import GHC.Exts (inline) -- $setup -- >>> :set -XNoOverloadedStrings -XFlexibleContexts
src/Control/Lens/Type.hs view
@@ -5,8 +5,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeInType #-} {-# LANGUAGE Trustworthy #-}++#if __GLASGOW_HASKELL__ >= 806+{-# LANGUAGE PolyKinds #-}+#else+{-# LANGUAGE TypeInType #-}+#endif ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Type@@ -230,7 +235,7 @@ type IndexedTraversal1 i s t a b = forall p f. (Indexable i p, Apply f) => p a (f b) -> s -> f t type IndexedTraversal1' i s a = IndexedTraversal1 i s s a a --- | An 'IndexPreservingLens' leaves any index it is composed with alone.+-- | An 'IndexPreservingTraversal' leaves any index it is composed with alone. type IndexPreservingTraversal s t a b = forall p f. (Conjoined p, Applicative f) => p a (f b) -> p s (f t) -- | @
src/Control/Lens/Unsound.hs view
@@ -18,7 +18,7 @@ -- Portability : Rank2Types -- -- One commonly asked question is: can we combine two lenses,--- @`Lens'` a b@ and @`Lens'` a c@ into @`Lens'` a (b, c)@.+-- @'Lens'' a b@ and @'Lens'' a c@ into @'Lens'' a (b, c)@. -- This is fair thing to ask, but such operation is unsound in general. -- See `lensProduct`. --@@ -39,7 +39,7 @@ -- >>> import Control.Lens -- | A lens product. There is no law-abiding way to do this in general.--- Result is only a valid 'Lens' if the input lenses project disjoint parts of+-- Result is only a valid t'Lens' if the input lenses project disjoint parts of -- the structure @s@. Otherwise "you get what you put in" law -- -- @
src/Control/Lens/Wrapped.hs view
@@ -30,7 +30,7 @@ -- Stability : experimental -- Portability : Rank2, MPTCs, fundeps ----- The 'Wrapped' class provides similar functionality as @Control.Newtype@,+-- The t'Wrapped' class provides similar functionality as @Control.Newtype@, -- from the @newtype@ package, but in a more convenient and efficient form. -- -- There are a few functions from @newtype@ that are not provided here, because@@ -150,6 +150,9 @@ import Data.Set (Set) import Data.Tagged import qualified Data.Vector as Vector+#if MIN_VERSION_vector(0,13,2)+import qualified Data.Vector.Strict as VectorStrict+#endif import qualified Data.Vector.Primitive as Prim import Data.Vector.Primitive (Prim) import qualified Data.Vector.Unboxed as Unboxed@@ -169,7 +172,7 @@ -- >>> import Data.Foldable (foldMap) -- >>> import Data.Monoid (Sum (..), Product (..), All (..), Any (..)) --- | 'Wrapped' provides isomorphisms to wrap and unwrap newtypes or+-- | t'Wrapped' provides isomorphisms to wrap and unwrap newtypes or -- data types with one constructor. class Wrapped s where type Unwrapped s :: Type@@ -568,14 +571,14 @@ -- * unordered-containers --- | Use @'wrapping' 'HashMap.fromList'@. Unwrapping returns some permutation of the list.+-- | Use @'_Wrapping' 'HashMap.fromList'@. Unwrapping returns some permutation of the list. instance (t ~ HashMap k' a', Hashable k, Eq k) => Rewrapped (HashMap k a) t instance (Hashable k, Eq k) => Wrapped (HashMap k a) where type Unwrapped (HashMap k a) = [(k, a)] _Wrapped' = iso HashMap.toList HashMap.fromList {-# INLINE _Wrapped' #-} --- | Use @'wrapping' 'HashSet.fromList'@. Unwrapping returns some permutation of the list.+-- | Use @'_Wrapping' 'HashSet.fromList'@. Unwrapping returns some permutation of the list. instance (t ~ HashSet a', Hashable a, Eq a) => Rewrapped (HashSet a) t instance (Hashable a, Eq a) => Wrapped (HashSet a) where type Unwrapped (HashSet a) = [a]@@ -584,28 +587,28 @@ -- * containers --- | Use @'wrapping' 'IntMap.fromList'@. unwrapping returns a /sorted/ list.+-- | Use @'_Wrapping' 'IntMap.fromList'@. unwrapping returns a /sorted/ list. instance (t ~ IntMap a') => Rewrapped (IntMap a) t instance Wrapped (IntMap a) where type Unwrapped (IntMap a) = [(Int, a)] _Wrapped' = iso IntMap.toAscList IntMap.fromList {-# INLINE _Wrapped' #-} --- | Use @'wrapping' 'IntSet.fromList'@. unwrapping returns a /sorted/ list.+-- | Use @'_Wrapping' 'IntSet.fromList'@. unwrapping returns a /sorted/ list. instance (t ~ IntSet) => Rewrapped IntSet t instance Wrapped IntSet where type Unwrapped IntSet = [Int] _Wrapped' = iso IntSet.toAscList IntSet.fromList {-# INLINE _Wrapped' #-} --- | Use @'wrapping' 'Map.fromList'@. unwrapping returns a /sorted/ list.+-- | Use @'_Wrapping' 'Map.fromList'@. unwrapping returns a /sorted/ list. instance (t ~ Map k' a', Ord k) => Rewrapped (Map k a) t instance Ord k => Wrapped (Map k a) where type Unwrapped (Map k a) = [(k, a)] _Wrapped' = iso Map.toAscList Map.fromList {-# INLINE _Wrapped' #-} --- | Use @'wrapping' 'Set.fromList'@. unwrapping returns a /sorted/ list.+-- | Use @'_Wrapping' 'Set.fromList'@. unwrapping returns a /sorted/ list. instance (t ~ Set a', Ord a) => Rewrapped (Set a) t instance Ord a => Wrapped (Set a) where type Unwrapped (Set a) = [a]@@ -676,6 +679,14 @@ _Wrapped' = iso Storable.toList Storable.fromList {-# INLINE _Wrapped' #-} +#if MIN_VERSION_vector(0,13,2)+instance (t ~ Vector.Vector a') => Rewrapped (VectorStrict.Vector a) t+instance Wrapped (VectorStrict.Vector a) where+ type Unwrapped (VectorStrict.Vector a) = [a]+ _Wrapped' = iso VectorStrict.toList VectorStrict.fromList+ {-# INLINE _Wrapped' #-}+#endif+ -- * semigroupoids instance (t ~ WrappedApplicative f' a') => Rewrapped (WrappedApplicative f a) t@@ -873,7 +884,11 @@ #endif getErrorCall :: ErrorCall -> String+#if MIN_VERSION_base(4,21,0)+getErrorCall (ErrorCall x) = x+#else getErrorCall (ErrorCallWithLocation x _) = x+#endif {-# INLINE getErrorCall #-} getRecUpdError :: RecUpdError -> String@@ -1000,7 +1015,12 @@ instance Rewrapped CSigAtomic t instance Wrapped CSigAtomic where- type Unwrapped CSigAtomic = HTYPE_SIG_ATOMIC_T+ type Unwrapped CSigAtomic =+#if defined(HTYPE_SIG_ATOMIC_T)+ HTYPE_SIG_ATOMIC_T+#else+ Int32+#endif _Wrapped' = iso (\(CSigAtomic x) -> x) CSigAtomic {-# INLINE _Wrapped' #-} @@ -1268,10 +1288,10 @@ # endif #endif --- | Given the constructor for a 'Wrapped' type, return a+-- | Given the constructor for a t'Wrapped' type, return a -- deconstructor that is its inverse. ----- Assuming the 'Wrapped' instance is legal, these laws hold:+-- Assuming the t'Wrapped' instance is legal, these laws hold: -- -- @ -- 'op' f '.' f ≡ 'id'
src/Control/Lens/Zoom.hs view
@@ -46,6 +46,9 @@ import Control.Monad.Trans.Writer.Strict as Strict import Control.Monad.Trans.RWS.Lazy as Lazy import Control.Monad.Trans.RWS.Strict as Strict+#if MIN_VERSION_mtl(2,3,0)+import Control.Monad.Trans.RWS.CPS as CPS+#endif import Control.Monad.Trans.Except import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe@@ -102,6 +105,9 @@ type instance Magnified ((->)b) = Const type instance Magnified (Strict.RWST a w s m) = EffectRWS w s m type instance Magnified (Lazy.RWST a w s m) = EffectRWS w s m+#if MIN_VERSION_mtl(2,3,0)+type instance Magnified (CPS.RWST a w s m) = EffectRWS w s m+#endif type instance Magnified (IdentityT m) = Magnified m ------------------------------------------------------------------------------@@ -273,6 +279,12 @@ instance (Monad m, Monoid w) => Magnify (Lazy.RWST b w s m) (Lazy.RWST a w s m) b a where magnify l (Lazy.RWST m) = Lazy.RWST $ getEffectRWS #. l (EffectRWS #. m) {-# INLINE magnify #-}++#if MIN_VERSION_mtl(2,3,0)+instance (Monad m, Monoid w, MonadReader b (CPS.RWST b w s m)) => Magnify (CPS.RWST b w s m) (CPS.RWST a w s m) b a where+ magnify l m = CPS.rwsT $ getEffectRWS #. l (EffectRWS #. CPS.runRWST m)+ {-# INLINE magnify #-}+#endif instance Magnify m n b a => Magnify (IdentityT m) (IdentityT n) b a where magnify l (IdentityT m) = IdentityT (magnify l m)
src/Control/Monad/Error/Lens.hs view
@@ -44,23 +44,23 @@ -- Catching ------------------------------------------------------------------------------ --- | Catch exceptions that match a given 'Prism' (or any 'Getter', really).+-- | Catch exceptions that match a given t'Prism' (or any t'Getter', really). -- -- @ -- 'catching' :: 'MonadError' e m => 'Prism'' e a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadError' e m => 'Lens'' e a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadError' e m => 'Traversal'' e a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadError' e m => 'Iso'' e a -> m r -> (a -> m r) -> m r--- 'catching' :: 'MonadError' e m => 'Getter' e a -> m r -> (a -> m r) -> m r--- 'catching' :: 'MonadError' e m => 'Fold' e a -> m r -> (a -> m r) -> m r+-- 'catching' :: 'MonadError' e m => t'Getter' e a -> m r -> (a -> m r) -> m r+-- 'catching' :: 'MonadError' e m => t'Fold' e a -> m r -> (a -> m r) -> m r -- @ catching :: MonadError e m => Getting (M.First a) e a -> m r -> (a -> m r) -> m r catching l = catchJust (preview l) {-# INLINE catching #-} --- | Catch exceptions that match a given 'Prism' (or any 'Getter'), discarding+-- | Catch exceptions that match a given t'Prism' (or any t'Getter'), discarding -- the information about the match. This is particularly useful when you have--- a @'Prism'' e ()@ where the result of the 'Prism' or 'Fold' isn't+-- a @'Prism'' e ()@ where the result of the t'Prism' or t'Fold' isn't -- particularly valuable, just the fact that it matches. -- -- @@@ -68,8 +68,8 @@ -- 'catching_' :: 'MonadError' e m => 'Lens'' e a -> m r -> m r -> m r -- 'catching_' :: 'MonadError' e m => 'Traversal'' e a -> m r -> m r -> m r -- 'catching_' :: 'MonadError' e m => 'Iso'' e a -> m r -> m r -> m r--- 'catching_' :: 'MonadError' e m => 'Getter' e a -> m r -> m r -> m r--- 'catching_' :: 'MonadError' e m => 'Fold' e a -> m r -> m r -> m r+-- 'catching_' :: 'MonadError' e m => t'Getter' e a -> m r -> m r -> m r+-- 'catching_' :: 'MonadError' e m => t'Fold' e a -> m r -> m r -> m r -- @ catching_ :: MonadError e m => Getting (M.First a) e a -> m r -> m r -> m r catching_ l a b = catchJust (preview l) a (const b)@@ -87,8 +87,8 @@ -- 'handling' :: 'MonadError' e m => 'Lens'' e a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadError' e m => 'Traversal'' e a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadError' e m => 'Iso'' e a -> (a -> m r) -> m r -> m r--- 'handling' :: 'MonadError' e m => 'Fold' e a -> (a -> m r) -> m r -> m r--- 'handling' :: 'MonadError' e m => 'Getter' e a -> (a -> m r) -> m r -> m r+-- 'handling' :: 'MonadError' e m => t'Fold' e a -> (a -> m r) -> m r -> m r+-- 'handling' :: 'MonadError' e m => t'Getter' e a -> (a -> m r) -> m r -> m r -- @ handling :: MonadError e m => Getting (M.First a) e a -> (a -> m r) -> m r -> m r handling l = flip (catching l)@@ -102,8 +102,8 @@ -- 'handling_' :: 'MonadError' e m => 'Lens'' e a -> m r -> m r -> m r -- 'handling_' :: 'MonadError' e m => 'Traversal'' e a -> m r -> m r -> m r -- 'handling_' :: 'MonadError' e m => 'Iso'' e a -> m r -> m r -> m r--- 'handling_' :: 'MonadError' e m => 'Getter' e a -> m r -> m r -> m r--- 'handling_' :: 'MonadError' e m => 'Fold' e a -> m r -> m r -> m r+-- 'handling_' :: 'MonadError' e m => t'Getter' e a -> m r -> m r -> m r+-- 'handling_' :: 'MonadError' e m => t'Fold' e a -> m r -> m r -> m r -- @ handling_ :: MonadError e m => Getting (M.First a) e a -> m r -> m r -> m r handling_ l = flip (catching_ l)@@ -113,16 +113,16 @@ -- Trying ------------------------------------------------------------------------------ --- | 'trying' takes a 'Prism' (or any 'Getter') to select which exceptions are caught--- If the 'Exception' does not match the predicate, it is re-thrown.+-- | 'trying' takes a t'Prism' (or any t'Getter') to select which exceptions are caught+-- If the exception does not match the predicate, it is re-thrown. -- -- @ -- 'trying' :: 'MonadError' e m => 'Prism'' e a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadError' e m => 'Lens'' e a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadError' e m => 'Traversal'' e a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadError' e m => 'Iso'' e a -> m r -> m ('Either' a r)--- 'trying' :: 'MonadError' e m => 'Getter' e a -> m r -> m ('Either' a r)--- 'trying' :: 'MonadError' e m => 'Fold' e a -> m r -> m ('Either' a r)+-- 'trying' :: 'MonadError' e m => t'Getter' e a -> m r -> m ('Either' a r)+-- 'trying' :: 'MonadError' e m => t'Fold' e a -> m r -> m ('Either' a r) -- @ trying :: MonadError e m => Getting (M.First a) e a -> m r -> m (Either a r) trying l m = catching l (liftM Right m) (return . Left)@@ -206,13 +206,13 @@ -- Throwing ------------------------------------------------------------------------------ --- | Throw an 'Exception' described by a 'Prism'.+-- | Throw an exception described by a t'Prism'. -- -- @'throwing' l ≡ 'reviews' l 'throwError'@ -- -- @--- 'throwing' :: 'MonadError' e m => 'Prism'' e t -> t -> a--- 'throwing' :: 'MonadError' e m => 'Iso'' e t -> t -> a+-- 'throwing' :: 'MonadError' e m => 'Prism'' e t -> t -> m a+-- 'throwing' :: 'MonadError' e m => 'Iso'' e t -> t -> m a -- @ throwing :: MonadError e m => AReview e t -> t -> m x throwing l = reviews l throwError
src/Control/Parallel/Strategies/Lens.hs view
@@ -14,7 +14,7 @@ -- Stability : provisional -- Portability : portable ----- A 'Lens' or 'Traversal' can be used to take the role of 'Traversable' in+-- A t'Lens' or t'Traversal' can be used to take the role of 'Traversable' in -- @Control.Parallel.Strategies@, enabling those combinators to work with -- monomorphic containers. ----------------------------------------------------------------------------@@ -28,7 +28,7 @@ import Control.Lens import Control.Parallel.Strategies --- | Evaluate the targets of a 'Lens' or 'Traversal' into a data structure+-- | Evaluate the targets of a t'Lens' or t'Traversal' into a data structure -- according to the given 'Strategy'. -- -- @@@ -45,7 +45,7 @@ evalOf l = l {-# INLINE evalOf #-} --- | Evaluate the targets of a 'Lens' or 'Traversal' according into a+-- | Evaluate the targets of a t'Lens' or t'Traversal' according into a -- data structure according to a given 'Strategy' in parallel. -- -- @'parTraversable' = 'parOf' 'traverse'@@@ -59,7 +59,7 @@ parOf l s = l (rparWith s) {-# INLINE parOf #-} --- | Transform a 'Lens', 'Fold', 'Getter', 'Setter' or 'Traversal' to+-- | Transform a t'Lens', t'Fold', t'Getter', t'Setter' or t'Traversal' to -- first evaluates its argument according to a given 'Strategy' /before/ proceeding. -- -- @@@ -69,7 +69,7 @@ after s l f = l f $| s {-# INLINE after #-} --- | Transform a 'Lens', 'Fold', 'Getter', 'Setter' or 'Traversal' to+-- | Transform a t'Lens', t'Fold', t'Getter', t'Setter' or t'Traversal' to -- evaluate its argument according to a given 'Strategy' /in parallel with/ evaluating. -- -- @
src/Control/Seq/Lens.hs view
@@ -7,7 +7,7 @@ -- Stability : provisional -- Portability : portable ----- A 'Fold' can be used to take the role of 'Foldable' in @Control.Seq@.+-- A t'Fold' can be used to take the role of 'Foldable' in @Control.Seq@. ---------------------------------------------------------------------------- module Control.Seq.Lens ( seqOf@@ -17,8 +17,8 @@ import Control.Seq import Data.Monoid --- | Evaluate the elements targeted by a 'Lens', 'Traversal', 'Iso',--- 'Getter' or 'Fold' according to the given strategy.+-- | Evaluate the elements targeted by a t'Lens', t'Traversal', t'Iso',+-- t'Getter' or t'Fold' according to the given strategy. -- -- @'seqFoldable' = 'seqOf' 'folded'@ seqOf :: Getting (Endo [a]) s a -> Strategy a -> Strategy s
src/Data/Array/Lens.hs view
@@ -18,10 +18,10 @@ import Control.Lens import Data.Array.IArray hiding (index) --- | This 'setter' can be used to derive a new 'IArray' from an old 'IAarray' by+-- | This t'Setter' can be used to derive a new 'IArray' from an old 'IArray' by -- applying a function to each of the indices to look it up in the old 'IArray'. ----- This is a /contravariant/ 'Setter'.+-- This is a /contravariant/ t'Setter'. -- -- @ -- 'ixmap' ≡ 'over' '.' 'ixmapped'
src/Data/Bits/Lens.hs view
@@ -37,31 +37,31 @@ infixr 4 .|.~, .&.~, <.|.~, <.&.~, <<.|.~, <<.&.~ infix 4 .|.=, .&.=, <.|.=, <.&.=, <<.|.=, <<.&.= --- | Bitwise '.|.' the target(s) of a 'Lens' or 'Setter'.+-- | Bitwise '.|.' the target(s) of a t'Lens' or t'Setter'. -- -- >>> _2 .|.~ 6 $ ("hello",3) -- ("hello",7) -- -- @--- ('.|.~') :: 'Bits' a => 'Setter' s t a a -> a -> s -> t--- ('.|.~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> t--- ('.|.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> t--- ('.|.~') :: ('Data.Monoid.Monoid' a, 'Bits' a) => 'Traversal' s t a a -> a -> s -> t+-- ('.|.~') :: 'Bits' a => t'Setter' s t a a -> a -> s -> t+-- ('.|.~') :: 'Bits' a => t'Iso' s t a a -> a -> s -> t+-- ('.|.~') :: 'Bits' a => t'Lens' s t a a -> a -> s -> t+-- ('.|.~') :: ('Data.Monoid.Monoid' a, 'Bits' a) => t'Traversal' s t a a -> a -> s -> t -- @ (.|.~):: Bits a => ASetter s t a a -> a -> s -> t l .|.~ n = over l (.|. n) {-# INLINE (.|.~) #-} --- | Bitwise '.&.' the target(s) of a 'Lens' or 'Setter'.+-- | Bitwise '.&.' the target(s) of a t'Lens' or t'Setter'. -- -- >>> _2 .&.~ 7 $ ("hello",254) -- ("hello",6) -- -- @--- ('.&.~') :: 'Bits' a => 'Setter' s t a a -> a -> s -> t--- ('.&.~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> t--- ('.&.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> t--- ('.&.~') :: ('Data.Monoid.Monoid' a, 'Bits' a) => 'Traversal' s t a a -> a -> s -> t+-- ('.&.~') :: 'Bits' a => t'Setter' s t a a -> a -> s -> t+-- ('.&.~') :: 'Bits' a => t'Iso' s t a a -> a -> s -> t+-- ('.&.~') :: 'Bits' a => t'Lens' s t a a -> a -> s -> t+-- ('.&.~') :: ('Data.Monoid.Monoid' a, 'Bits' a) => t'Traversal' s t a a -> a -> s -> t -- @ (.&.~) :: Bits a => ASetter s t a a -> a -> s -> t l .&.~ n = over l (.&. n)@@ -82,7 +82,7 @@ l .&.= a = modify (l .&.~ a) {-# INLINE (.&.=) #-} --- | Modify the target(s) of a 'Lens'', 'Setter' or 'Traversal' by computing its bitwise '.|.' with another value.+-- | Modify the target(s) of a 'Lens'', t'Setter' or t'Traversal' by computing its bitwise '.|.' with another value. -- -- >>> execState (do _1 .|.= 15; _2 .|.= 3) (7,7) -- (15,7)@@ -97,31 +97,31 @@ l .|.= a = modify (l .|.~ a) {-# INLINE (.|.=) #-} --- | Bitwise '.|.' the target(s) of a 'Lens' (or 'Traversal'), returning the result+-- | Bitwise '.|.' the target(s) of a t'Lens' (or t'Traversal'), returning the result -- (or a monoidal summary of all of the results). -- -- >>> _2 <.|.~ 6 $ ("hello",3) -- (7,("hello",7)) -- -- @--- ('<.|.~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> (a, t)--- ('<.|.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> (a, t)--- ('<.|.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => 'Traversal' s t a a -> a -> s -> (a, t)+-- ('<.|.~') :: 'Bits' a => t'Iso' s t a a -> a -> s -> (a, t)+-- ('<.|.~') :: 'Bits' a => t'Lens' s t a a -> a -> s -> (a, t)+-- ('<.|.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => t'Traversal' s t a a -> a -> s -> (a, t) -- @ (<.|.~):: Bits a => LensLike ((,) a) s t a a -> a -> s -> (a, t) l <.|.~ n = l <%~ (.|. n) {-# INLINE (<.|.~) #-} --- | Bitwise '.&.' the target(s) of a 'Lens' or 'Traversal', returning the result+-- | Bitwise '.&.' the target(s) of a t'Lens' or t'Traversal', returning the result -- (or a monoidal summary of all of the results). -- -- >>> _2 <.&.~ 7 $ ("hello",254) -- (6,("hello",6)) -- -- @--- ('<.&.~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> (a, t)--- ('<.&.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> (a, t)--- ('<.&.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => 'Traversal' s t a a -> a -> s -> (a, t)+-- ('<.&.~') :: 'Bits' a => t'Iso' s t a a -> a -> s -> (a, t)+-- ('<.&.~') :: 'Bits' a => t'Lens' s t a a -> a -> s -> (a, t)+-- ('<.&.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => t'Traversal' s t a a -> a -> s -> (a, t) -- @ (<.&.~) :: Bits a => LensLike ((,) a) s t a a -> a -> s -> (a, t) l <.&.~ n = l <%~ (.&. n)@@ -141,7 +141,7 @@ l <.&.= b = l <%= (.&. b) {-# INLINE (<.&.=) #-} --- | Modify the target(s) of a 'Lens'', (or 'Traversal') by computing its bitwise '.|.' with another value,+-- | Modify the target(s) of a 'Lens'', (or t'Traversal') by computing its bitwise '.|.' with another value, -- returning the result (or a monoidal summary of all of the results traversed). -- -- >>> runState (_1 <.|.= 7) (28,0)@@ -155,7 +155,7 @@ l <.|.= b = l <%= (.|. b) {-# INLINE (<.|.=) #-} --- | Bitwise '.&.' the target(s) of a 'Lens' or 'Traversal', and return the+-- | Bitwise '.&.' the target(s) of a t'Lens' or t'Traversal', and return the -- original value, or a monoidal summary of the original values. -- -- When you do not need the old value, ('.&.~') is more flexible.@@ -164,15 +164,15 @@ -- (254,("hello",6)) -- -- @--- ('<<.&.~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> (a, t)--- ('<<.&.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> (a, t)--- ('<<.&.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => 'Traversal' s t a a -> a -> s -> (a, t)+-- ('<<.&.~') :: 'Bits' a => t'Iso' s t a a -> a -> s -> (a, t)+-- ('<<.&.~') :: 'Bits' a => t'Lens' s t a a -> a -> s -> (a, t)+-- ('<<.&.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => t'Traversal' s t a a -> a -> s -> (a, t) -- @ (<<.&.~) :: Bits a => Optical' (->) q ((,)a) s a -> a -> q s (a, s) l <<.&.~ b = l $ \a -> (a, a .&. b) {-# INLINE (<<.&.~) #-} --- | Bitwise '.|.' the target(s) of a 'Lens' or 'Traversal', and return the+-- | Bitwise '.|.' the target(s) of a t'Lens' or t'Traversal', and return the -- original value, or a monoidal summary of the original values. -- -- When you do not need the old value, ('.|.~') is more flexible.@@ -181,9 +181,9 @@ -- (3,("hello",7)) -- -- @--- ('<<.|.~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> (a, t)--- ('<<.|.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> (a, t)--- ('<<.|.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => 'Traversal' s t a a -> a -> s -> (a, t)+-- ('<<.|.~') :: 'Bits' a => t'Iso' s t a a -> a -> s -> (a, t)+-- ('<<.|.~') :: 'Bits' a => t'Lens' s t a a -> a -> s -> (a, t)+-- ('<<.|.~') :: ('Bits' a, 'Data.Monoid.Monoid' a) => t'Traversal' s t a a -> a -> s -> (a, t) -- @ (<<.|.~) :: Bits a => Optical' (->) q ((,)a) s a -> a -> q s (a, s) l <<.|.~ b = l $ \a -> (a, a .|. b)@@ -223,9 +223,9 @@ l <<.|.= b = l %%= \a -> (a, a .|. b) {-# INLINE (<<.|.=) #-} --- | This 'Lens' can be used to access the value of the nth bit in a number.+-- | This t'Lens' can be used to access the value of the nth bit in a number. ----- @'bitAt' n@ is only a legal 'Lens' into @b@ if @0 '<=' n '<' 'bitSize' ('undefined' :: b)@.+-- @'bitAt' n@ is only a legal t'Lens' into @b@ if @0 '<=' n '<' 'bitSize' ('undefined' :: b)@. -- -- >>> 16^.bitAt 4 -- True@@ -244,7 +244,7 @@ -- | Get the nth byte, counting from the low end. ----- @'byteAt' n@ is a legal 'Lens' into @b@ iff @0 '<=' n '<' 'div' ('bitSize' ('undefined' :: b)) 8@+-- @'byteAt' n@ is a legal t'Lens' into @b@ iff @0 '<=' n '<' 'div' ('bitSize' ('undefined' :: b)) 8@ -- -- >>> (0xff00 :: Word16)^.byteAt 0 -- 0@@ -271,7 +271,7 @@ -- >>> toListOf bits (5 :: Word8) -- [True,False,True,False,False,False,False,False] ----- If you supply this an 'Integer', the result will be an infinite 'Traversal', which+-- If you supply this an 'Integer', the result will be an infinite t'Traversal', which -- can be productively consumed, but not reassembled. bits :: (Num b, Bits b) => IndexedTraversal' Int b Bool bits f b = foldr step 0 <$> traverse g bs where@@ -289,7 +289,7 @@ -- >>> toListOf bytewise (1312301580 :: Word32) -- [12,34,56,78] ----- If you supply this an 'Integer', the result will be an infinite 'Traversal',+-- If you supply this an 'Integer', the result will be an infinite t'Traversal', -- which can be productively consumed, but not reassembled. -- -- Why isn't this function called @bytes@ to match 'bits'? Alas, there
src/Data/ByteString/Lazy/Lens.hs view
@@ -65,7 +65,7 @@ -- | Traverse the individual bytes in a 'ByteString'. ----- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion+-- This t'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:@@ -77,7 +77,7 @@ -- >>> anyOf bytes (== 0x80) (Char8.pack "hello") -- False ----- Note that when just using this as a 'Setter', @'setting' 'Data.ByteString.Lazy.map'@+-- Note that when just using this as a t'Setter', @'setting' 'Data.ByteString.Lazy.map'@ -- can be more efficient. bytes :: IndexedTraversal' Int64 ByteString Word8 bytes = traversedLazy@@ -122,7 +122,7 @@ -- When writing back to the 'ByteString' it is assumed that every 'Char' -- lies between @'\x00'@ and @'\xff'@. ----- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion+-- This t'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:
src/Data/ByteString/Lens.hs view
@@ -53,7 +53,7 @@ -- | Traverse each 'Word8' in a strict or lazy 'ByteString' -- --- -- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion+ -- This t'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:@@ -74,7 +74,7 @@ -- When writing back to the 'ByteString' it is assumed that every 'Char' -- lies between @'\x00'@ and @'\xff'@. --- -- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion+ -- This t'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:
src/Data/ByteString/Strict/Lens.hs view
@@ -63,7 +63,7 @@ -- | Traverse each 'Word8' in a 'ByteString'. ----- This 'Traversal' walks the 'ByteString' in a tree-like fashion+-- This t'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:@@ -75,7 +75,7 @@ -- >>> anyOf bytes (== 0x80) (Char8.pack "hello") -- False ----- Note that when just using this as a 'Setter', @'setting' 'Data.ByteString.map'@+-- Note that when just using this as a t'Setter', @'setting' 'Data.ByteString.map'@ -- can be more efficient. bytes :: IndexedTraversal' Int ByteString Word8 bytes = traversedStrictTree@@ -120,7 +120,7 @@ -- When writing back to the 'ByteString' it is assumed that every 'Char' -- lies between @'\x00'@ and @'\xff'@. ----- This 'Traversal' walks the 'ByteString' in a tree-like fashion+-- This t'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:
src/Data/Complex/Lens.hs view
@@ -67,7 +67,7 @@ _imagPart f (a :+ b) = (a :+) <$> f b {-# INLINE _imagPart #-} --- | This isn't /quite/ a legal 'Lens'. Notably the+-- | This isn't /quite/ a legal t'Lens'. Notably the -- -- @'view' l ('set' l b a) = b@ --@@ -76,7 +76,7 @@ -- which flips the 'phase' and retains a positive 'magnitude'. So don't do -- that! ----- Otherwise, this is a perfectly cromulent 'Lens'.+-- Otherwise, this is a perfectly cromulent t'Lens'. _polar :: RealFloat a => Iso' (Complex a) (a,a) _polar = iso polar (uncurry mkPolar) {-# INLINE _polar #-}@@ -96,14 +96,14 @@ -- >>> (10.0 :+ 20.0) & _magnitude *~ 2 -- 20.0 :+ 40.0 ----- This isn't /quite/ a legal 'Lens'. Notably the+-- This isn't /quite/ a legal t'Lens'. Notably the -- -- @'view' l ('set' l b a) = b@ -- -- law is violated when you set a negative 'magnitude'. This flips the 'phase' -- and retains a positive 'magnitude'. So don't do that! ----- Otherwise, this is a perfectly cromulent 'Lens'.+-- Otherwise, this is a perfectly cromulent t'Lens'. -- -- Setting the 'magnitude' of a zero 'Complex' number assumes the 'phase' is 0. _magnitude :: RealFloat a => Lens' (Complex a) a@@ -118,14 +118,14 @@ -- >>> (mkPolar 10 (2-pi) & _phase +~ pi & view _phase) ≈ 2 -- True ----- This isn't /quite/ a legal 'Lens'. Notably the+-- This isn't /quite/ a legal t'Lens'. Notably the -- -- @'view' l ('set' l b a) = b@ -- -- law is violated when you set a 'phase' outside the range @(-'pi', 'pi']@. -- The phase is always in that range when queried. So don't do that! ----- Otherwise, this is a perfectly cromulent 'Lens'.+-- Otherwise, this is a perfectly cromulent t'Lens'. _phase :: RealFloat a => Lens' (Complex a) a _phase f c = setPhase <$> f theta where setPhase theta' = c * cis (theta' - theta)
src/Data/Data/Lens.hs view
@@ -12,12 +12,6 @@ {-# LANGUAGE Trustworthy #-} #endif {-# OPTIONS_GHC -fno-full-laziness #-}-#if __GLASGOW_HASKELL__ >= 810--- Use -fbyte-code explicitly to ensure that -fobject-code isn't automatically--- implied on GHCi 8.10+ by the use of UnboxedTuples, as this breaks the--- doctests. See #874 for more details.-{-# OPTIONS_GHC -fbyte-code #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Data.Lens@@ -77,6 +71,8 @@ -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens+-- >>> import Control.Lens.Internal.Doctest+-- >>> import Prelude hiding (head, tail) ------------------------------------------------------------------------------- -- Generic Traversal
src/Data/Dynamic/Lens.hs view
@@ -22,16 +22,16 @@ import Control.Lens import Data.Dynamic --- | Any 'Dynamic' can be thrown as an 'Exception'+-- | Any t'Dynamic' can be thrown as an t'Exception' class AsDynamic t where- -- | This 'Prism' allows you to traverse the typed value contained in a- -- 'Dynamic' where the type required by your function matches that- -- of the contents of the 'Dynamic', or construct a 'Dynamic' value- -- out of whole cloth. It can also be used to catch or throw a 'Dynamic'+ -- | This t'Prism' allows you to traverse the typed value contained in a+ -- t'Dynamic' where the type required by your function matches that+ -- of the contents of the t'Dynamic', or construct a t'Dynamic' value+ -- out of whole cloth. It can also be used to catch or throw a t'Dynamic' -- value as 'SomeException'. -- -- @- -- '_Dynamic' :: 'Typeable' a => 'Prism'' 'Dynamic' a+ -- '_Dynamic' :: 'Typeable' a => 'Prism'' t'Dynamic' a -- '_Dynamic' :: 'Typeable' a => 'Prism'' 'SomeException' a -- @ _Dynamic :: Typeable a => Prism' t a
src/Data/IntSet/Lens.hs view
@@ -24,7 +24,7 @@ -- >>> import Control.Lens -- >>> import qualified Data.IntSet as IntSet --- | IntSet isn't Foldable, but this 'Fold' can be used to access the members of an 'IntSet'.+-- | IntSet isn't Foldable, but this t'Fold' can be used to access the members of an 'IntSet'. -- -- >>> sumOf members $ setOf folded [1,2,3,4] -- 10@@ -32,10 +32,10 @@ members = folding IntSet.toAscList {-# INLINE members #-} --- | This 'Setter' can be used to change the contents of an 'IntSet' by mapping+-- | This t'Setter' can be used to change the contents of an 'IntSet' by mapping -- the elements to new values. ----- Sadly, you can't create a valid 'Traversal' for a 'Set', because the number of+-- Sadly, you can't create a valid t'Traversal' for an 'IntSet', because the number of -- elements might change but you can manipulate it by reading using 'folded' and -- reindexing it via 'setmapped'. --@@ -45,7 +45,7 @@ setmapped = setting IntSet.map {-# INLINE setmapped #-} --- | Construct an 'IntSet' from a 'Getter', 'Fold', 'Traversal', 'Lens' or 'Iso'.+-- | Construct an 'IntSet' from a t'Getter', t'Fold', t'Traversal', t'Lens' or t'Iso'. -- -- >>> setOf folded [1,2,3,4] -- fromList [1,2,3,4]@@ -54,11 +54,11 @@ -- fromList [1,2,3] -- -- @--- 'setOf' :: 'Getter' s 'Int' -> s -> 'IntSet'--- 'setOf' :: 'Fold' s 'Int' -> s -> 'IntSet'--- 'setOf' :: 'Iso'' s 'Int' -> s -> 'IntSet'--- 'setOf' :: 'Lens'' s 'Int' -> s -> 'IntSet'--- 'setOf' :: 'Traversal'' s 'Int' -> s -> 'IntSet'+-- 'setOf' :: t'Getter' s 'Int' -> s -> 'IntSet'+-- 'setOf' :: t'Fold' s 'Int' -> s -> 'IntSet'+-- 'setOf' :: t'Iso'' s 'Int' -> s -> 'IntSet'+-- 'setOf' :: t'Lens'' s 'Int' -> s -> 'IntSet'+-- 'setOf' :: t'Traversal'' s 'Int' -> s -> 'IntSet' -- @ setOf :: Getting IntSet s Int -> s -> IntSet setOf l = views l IntSet.singleton
src/Data/Sequence/Lens.hs view
@@ -122,7 +122,7 @@ (m, r) -> itraverse (indexed f . (+i)) m <&> \n -> l >< n >< r {-# INLINE sliced #-} --- | Construct a 'Seq' from a 'Getter', 'Control.Lens.Fold.Fold', 'Control.Lens.Traversal.Traversal', 'Control.Lens.Lens.Lens' or 'Control.Lens.Iso.Iso'.+-- | Construct a 'Seq' from a t'Getter', 'Control.Lens.Fold.Fold', 'Control.Lens.Traversal.Traversal', 'Control.Lens.Lens.Lens' or 'Control.Lens.Iso.Iso'. -- -- >>> seqOf folded ["hello","world"] -- fromList ["hello","world"]@@ -131,8 +131,8 @@ -- fromList [1,2,3] -- -- @--- 'seqOf' :: 'Getter' s a -> s -> 'Seq' a--- 'seqOf' :: 'Fold' s a -> s -> 'Seq' a+-- 'seqOf' :: t'Getter' s a -> s -> 'Seq' a+-- 'seqOf' :: t'Fold' s a -> s -> 'Seq' a -- 'seqOf' :: 'Iso'' s a -> s -> 'Seq' a -- 'seqOf' :: 'Lens'' s a -> s -> 'Seq' a -- 'seqOf' :: 'Traversal'' s a -> s -> 'Seq' a
src/Data/Tree/Lens.hs view
@@ -27,7 +27,7 @@ -- >>> import Control.Lens -- >>> import Data.Tree --- | A 'Lens' that focuses on the root of a 'Tree'.+-- | A t'Lens' that focuses on the root of a 'Tree'. -- -- >>> view root $ Node 42 [] -- 42@@ -35,7 +35,7 @@ root f (Node a as) = (`Node` as) <$> f a {-# INLINE root #-} --- | A 'Lens' returning the direct descendants of the root of a 'Tree'+-- | A t'Lens' returning the direct descendants of the root of a 'Tree' -- -- @'view' 'branches' ≡ 'subForest'@ branches :: Lens' (Tree a) [Tree a]
src/Data/Vector/Lens.hs view
@@ -40,14 +40,14 @@ -- >>> import qualified Data.Vector as Vector -- >>> import Control.Lens --- | @sliced i n@ provides a 'Lens' that edits the @n@ elements starting--- at index @i@ from a 'Lens'.+-- | @sliced i n@ provides a t'Lens' that edits the @n@ elements starting+-- at index @i@ from a t'Lens'. ----- This is only a valid 'Lens' if you do not change the length of the+-- This is only a valid t'Lens' if you do not change the length of the -- resulting 'Vector'. -- -- Attempting to return a longer or shorter vector will result in--- violations of the 'Lens' laws.+-- violations of the t'Lens' laws. -- -- >>> Vector.fromList [1..10] ^. sliced 2 5 == Vector.fromList [3,4,5,6,7] -- True@@ -88,7 +88,7 @@ forced = iso V.force V.force {-# INLINE forced #-} --- | This 'Traversal' will ignore any duplicates in the supplied list+-- | This t'Traversal' will ignore any duplicates in the supplied list -- of indices. -- -- >>> toListOf (ordinals [1,3,2,5,9,10]) $ Vector.fromList [2,4..40]
src/Language/Haskell/TH/Lens.hs view
@@ -125,6 +125,12 @@ #if MIN_VERSION_template_haskell(2,15,0) , _ImplicitParamBindD #endif+#if MIN_VERSION_template_haskell(2,19,0)+ , _DefaultD+#endif+#if MIN_VERSION_template_haskell(2,20,0)+ , _TypeDataD+#endif #if MIN_VERSION_template_haskell(2,12,0) -- ** PatSynDir Prisms , _Unidir@@ -142,6 +148,12 @@ , _ForallC , _GadtC , _RecGadtC+#if MIN_VERSION_template_haskell(2,22,0)+ -- ** NamespaceSpecifier Prisms+ , _NoNamespaceSpecifier+ , _TypeNamespaceSpecifier+ , _DataNamespaceSpecifier+#endif -- ** Overlap Prisms ,_Overlappable ,_Overlapping@@ -182,6 +194,15 @@ #if MIN_VERSION_template_haskell(2,12,0) , _CompleteP #endif+#if MIN_VERSION_template_haskell(2,19,0)+ , _OpaqueP+#endif+#if MIN_VERSION_template_haskell(2,22,0)+ , _SCCP+#endif+#if MIN_VERSION_template_haskell(2,24,0)+ , _SpecialiseEP+#endif -- ** Inline Prisms , _NoInline , _Inline@@ -249,6 +270,25 @@ , _MDoE , _ImplicitParamVarE #endif+#if MIN_VERSION_template_haskell(2,18,0)+ , _GetFieldE+ , _ProjectionE+#endif+#if MIN_VERSION_template_haskell(2,19,0)+ , _LamCasesE+#endif+#if MIN_VERSION_template_haskell(2,21,0)+ , _TypedBracketE+ , _TypedSpliceE+#endif+#if MIN_VERSION_template_haskell(2,22,0)+ , _TypeE+#endif+#if MIN_VERSION_template_haskell(2,23,0)+ , _ForallE+ , _ForallVisE+ , _ConstrainedE+#endif -- ** Body Prisms , _GuardedB , _NormalB@@ -302,6 +342,13 @@ , _ListP , _SigP , _ViewP+#if MIN_VERSION_template_haskell(2,22,0)+ , _TypeP+ , _InvisP+#endif+#if MIN_VERSION_template_haskell(2,23,0)+ , _OrP+#endif -- ** Type Prisms , _ForallT , _AppT@@ -337,11 +384,20 @@ #if MIN_VERSION_template_haskell(2,17,0) , _MulArrowT #endif+#if MIN_VERSION_template_haskell(2,19,0)+ , _PromotedInfixT+ , _PromotedUInfixT+#endif #if MIN_VERSION_template_haskell(2,17,0) -- ** Specificity Prisms , _SpecifiedSpec , _InferredSpec #endif+#if MIN_VERSION_template_haskell(2,21,0)+ -- ** BndrVis Prisms+ , _BndrReq+ , _BndrInvis+#endif -- ** TyVarBndr Prisms , _PlainTV , _KindedTV@@ -373,6 +429,7 @@ import Control.Lens.Getter import Control.Lens.Setter import Control.Lens.Fold+import Control.Lens.Internal.TH import Control.Lens.Iso (Iso', iso) import Control.Lens.Lens import Control.Lens.Prism@@ -390,9 +447,11 @@ import Language.Haskell.TH.Syntax import Data.Word #if MIN_VERSION_template_haskell(2,15,0)-import Control.Lens.Internal.TH (unfoldType) import Data.Foldable as F (foldl') #endif+#if MIN_VERSION_template_haskell(2,18,0)+import Data.List.NonEmpty (NonEmpty)+#endif import Prelude -- | Has a 'Name'@@ -414,10 +473,18 @@ name f (InfixC l n r) = (\n' -> InfixC l n' r) <$> f n name f (ForallC bds ctx con) = ForallC bds ctx <$> name f con name f (GadtC ns argTys retTy) =- (\n -> GadtC [n] argTys retTy) <$> f (head ns)+ (\n -> GadtC [n] argTys retTy) <$> f (headGadtConName ns) name f (RecGadtC ns argTys retTy) =- (\n -> RecGadtC [n] argTys retTy) <$> f (head ns)+ (\n -> RecGadtC [n] argTys retTy) <$> f (headGadtConName ns) +-- @template-haskell@ maintains the invariant that the list of constructor+-- @Name@s in a 'GadtC' or 'RecGadtC' will always be non-empty.+headGadtConName :: [Name] -> Name+headGadtConName conNames =+ case conNames of+ conName:_ -> conName+ [] -> error "headGadtConName: Unexpected empty list of GADT constructor names"+ instance HasName Foreign where name f (ImportF cc saf str n ty) = (\n' -> ImportF cc saf str n' ty) <$> f n@@ -533,6 +600,14 @@ #if MIN_VERSION_template_haskell(2,17,0) typeVarsEx _ _ t@MulArrowT{} = pure t #endif+#if MIN_VERSION_template_haskell(2,19,0)+ typeVarsEx s f (PromotedInfixT t1 n t2) = PromotedInfixT <$> typeVarsEx s f t1+ <*> pure n+ <*> typeVarsEx s f t2+ typeVarsEx s f (PromotedUInfixT t1 n t2) = PromotedUInfixT <$> typeVarsEx s f t1+ <*> pure n+ <*> typeVarsEx s f t2+#endif instance HasTypeVars Con where typeVarsEx s f (NormalC n ts) = NormalC n <$> traverseOf (traverse . _2) (typeVarsEx s f) ts@@ -605,6 +680,10 @@ #if MIN_VERSION_template_haskell(2,17,0) substType _ t@MulArrowT{} = t #endif+#if MIN_VERSION_template_haskell(2,19,0)+ substType m (PromotedInfixT t1 n t2) = PromotedInfixT (substType m t1) n (substType m t2)+ substType m (PromotedUInfixT t1 n t2) = PromotedUInfixT (substType m t1) n (substType m t2)+#endif instance SubstType t => SubstType [t] where substType = map . substType@@ -731,7 +810,7 @@ g (TypeFamilyHead n _ _ _ ) = n s (TypeFamilyHead _ tvbs rs ia) n = TypeFamilyHead n tvbs rs ia -typeFamilyHeadTyVarBndrs :: Lens' TypeFamilyHead [TyVarBndrUnit]+typeFamilyHeadTyVarBndrs :: Lens' TypeFamilyHead [TyVarBndrVis] typeFamilyHeadTyVarBndrs = lens g s where g (TypeFamilyHead _ tvbs _ _ ) = tvbs s (TypeFamilyHead n _ rs ia) tvbs = TypeFamilyHead n tvbs rs ia@@ -858,7 +937,7 @@ remitter (ValD x y z) = Just (x, y, z) remitter _ = Nothing -_TySynD :: Prism' Dec (Name, [TyVarBndrUnit], Type)+_TySynD :: Prism' Dec (Name, [TyVarBndrVis], Type) _TySynD = prism' reviewer remitter where@@ -866,7 +945,7 @@ remitter (TySynD x y z) = Just (x, y, z) remitter _ = Nothing -_ClassD :: Prism' Dec (Cxt, Name, [TyVarBndrUnit], [FunDep], [Dec])+_ClassD :: Prism' Dec (Cxt, Name, [TyVarBndrVis], [FunDep], [Dec]) _ClassD = prism' reviewer remitter where@@ -882,6 +961,32 @@ remitter (InstanceD x y z w) = Just (x, y, z, w) remitter _ = Nothing +#if MIN_VERSION_template_haskell(2,22,0)+_NoNamespaceSpecifier :: Prism' NamespaceSpecifier ()+_NoNamespaceSpecifier+ = prism' reviewer remitter+ where+ reviewer () = NoNamespaceSpecifier+ remitter NoNamespaceSpecifier = Just ()+ remitter _ = Nothing++_TypeNamespaceSpecifier :: Prism' NamespaceSpecifier ()+_TypeNamespaceSpecifier+ = prism' reviewer remitter+ where+ reviewer () = TypeNamespaceSpecifier+ remitter TypeNamespaceSpecifier = Just ()+ remitter _ = Nothing++_DataNamespaceSpecifier :: Prism' NamespaceSpecifier ()+_DataNamespaceSpecifier+ = prism' reviewer remitter+ where+ reviewer () = DataNamespaceSpecifier+ remitter DataNamespaceSpecifier = Just ()+ remitter _ = Nothing+#endif+ _Overlappable :: Prism' Overlap () _Overlappable = prism' reviewer remitter where@@ -926,6 +1031,20 @@ remitter (ForeignD x) = Just x remitter _ = Nothing +-- |+-- @+-- _InfixD :: 'Prism'' 'Dec' ('Fixity', 'NamespaceSpecifier', 'Name') -- template-haskell-2.22++-- _InfixD :: 'Prism'' 'Dec' ('Fixity', 'Name') -- Earlier versions+-- @+#if MIN_VERSION_template_haskell(2,22,0)+_InfixD :: Prism' Dec (Fixity, NamespaceSpecifier, Name)+_InfixD+ = prism' reviewer remitter+ where+ reviewer (x, y, z) = InfixD x y z+ remitter (InfixD x y z) = Just (x, y, z)+ remitter _ = Nothing+#else _InfixD :: Prism' Dec (Fixity, Name) _InfixD = prism' reviewer remitter@@ -933,6 +1052,7 @@ reviewer (x, y) = InfixD x y remitter (InfixD x y) = Just (x, y) remitter _ = Nothing+#endif _PragmaD :: Prism' Dec Pragma _PragmaD@@ -1072,7 +1192,7 @@ -- _DataD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['TyVarBndrUnit'], 'Maybe' 'Kind', ['Con'], ['DerivClause']) -- template-haskell-2.12+ -- _DataD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', ['Con'], 'Cxt') -- Earlier versions -- @-_DataD :: DataPrism' [TyVarBndrUnit] [Con]+_DataD :: DataPrism' [TyVarBndrVis] [Con] _DataD = prism' reviewer remitter where@@ -1085,7 +1205,7 @@ -- _NewtypeD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['TyVarBndrUnit'], 'Maybe' 'Kind', 'Con', ['DerivClause']) -- template-haskell-2.12+ -- _NewtypeD :: 'Prism'' 'Dec' ('Cxt', 'Name', ['Type'], 'Maybe' 'Kind', 'Con', 'Cxt') -- Earlier versions -- @-_NewtypeD :: DataPrism' [TyVarBndrUnit] Con+_NewtypeD :: DataPrism' [TyVarBndrVis] Con _NewtypeD = prism' reviewer remitter where@@ -1093,7 +1213,7 @@ remitter (NewtypeD x y z w u v) = Just (x, y, z, w, u, v) remitter _ = Nothing -_DataFamilyD :: Prism' Dec (Name, [TyVarBndrUnit], Maybe Kind)+_DataFamilyD :: Prism' Dec (Name, [TyVarBndrVis], Maybe Kind) _DataFamilyD = prism' reviewer remitter where@@ -1137,6 +1257,26 @@ remitter _ = Nothing #endif +#if MIN_VERSION_template_haskell(2,19,0)+_DefaultD :: Prism' Dec [Type]+_DefaultD+ = prism' reviewer remitter+ where+ reviewer = DefaultD+ remitter (DefaultD x) = Just x+ remitter _ = Nothing+#endif++#if MIN_VERSION_template_haskell(2,20,0)+_TypeDataD :: Prism' Dec (Name, [TyVarBndrVis], Maybe Kind, [Con])+_TypeDataD+ = prism' reviewer remitter+ where+ reviewer (x, y, z, u) = TypeDataD x y z u+ remitter (TypeDataD x y z u) = Just (x, y, z, u)+ remitter _ = Nothing+#endif+ #if MIN_VERSION_template_haskell(2,12,0) _Unidir :: Prism' PatSynDir () _Unidir@@ -1462,6 +1602,36 @@ remitter _ = Nothing #endif +#if MIN_VERSION_template_haskell(2,19,0)+_OpaqueP :: Prism' Pragma Name+_OpaqueP+ = prism' reviewer remitter+ where+ reviewer = OpaqueP+ remitter (OpaqueP x) = Just x+ remitter _ = Nothing+#endif++#if MIN_VERSION_template_haskell(2,22,0)+_SCCP :: Prism' Pragma (Name, Maybe String)+_SCCP+ = prism' reviewer remitter+ where+ reviewer (x, y) = SCCP x y+ remitter (SCCP x y) = Just (x, y)+ remitter _ = Nothing+#endif++#if MIN_VERSION_template_haskell(2,24,0)+_SpecialiseEP :: Prism' Pragma (Maybe [TyVarBndr ()], [RuleBndr], Exp, Maybe Inline, Phases)+_SpecialiseEP+ = prism' reviewer remitter+ where+ reviewer (x, y, z, w, u) = SpecialiseEP x y z w u+ remitter (SpecialiseEP x y z w u) = Just (x, y, z, w, u)+ remitter _ = Nothing+#endif+ _NoInline :: Prism' Inline () _NoInline = prism' reviewer remitter@@ -1932,6 +2102,88 @@ remitter _ = Nothing #endif +#if MIN_VERSION_template_haskell(2,18,0)+_GetFieldE :: Prism' Exp (Exp, String)+_GetFieldE+ = prism' reviewer remitter+ where+ reviewer (x, y) = GetFieldE x y+ remitter (GetFieldE x y) = Just (x, y)+ remitter _ = Nothing++_ProjectionE :: Prism' Exp (NonEmpty String)+_ProjectionE+ = prism' reviewer remitter+ where+ reviewer = ProjectionE+ remitter (ProjectionE x) = Just x+ remitter _ = Nothing+#endif++#if MIN_VERSION_template_haskell(2,19,0)+_LamCasesE :: Prism' Exp [Clause]+_LamCasesE+ = prism' reviewer remitter+ where+ reviewer = LamCasesE+ remitter (LamCasesE x) = Just x+ remitter _ = Nothing+#endif++#if MIN_VERSION_template_haskell(2,21,0)+_TypedBracketE :: Prism' Exp Exp+_TypedBracketE+ = prism' reviewer remitter+ where+ reviewer = TypedBracketE+ remitter (TypedBracketE x) = Just x+ remitter _ = Nothing++_TypedSpliceE :: Prism' Exp Exp+_TypedSpliceE+ = prism' reviewer remitter+ where+ reviewer = TypedSpliceE+ remitter (TypedSpliceE x) = Just x+ remitter _ = Nothing+#endif++#if MIN_VERSION_template_haskell(2,22,0)+_TypeE :: Prism' Exp Type+_TypeE+ = prism' reviewer remitter+ where+ reviewer = TypeE+ remitter (TypeE x) = Just x+ remitter _ = Nothing+#endif++#if MIN_VERSION_template_haskell(2,23,0)+_ForallE :: Prism' Exp ([TyVarBndr Specificity], Exp)+_ForallE+ = prism' reviewer remitter+ where+ reviewer (x, y) = ForallE x y+ remitter (ForallE x y) = Just (x, y)+ remitter _ = Nothing++_ForallVisE :: Prism' Exp ([TyVarBndr ()], Exp)+_ForallVisE+ = prism' reviewer remitter+ where+ reviewer (x, y) = ForallVisE x y+ remitter (ForallVisE x y) = Just (x, y)+ remitter _ = Nothing++_ConstrainedE :: Prism' Exp ([Exp], Exp)+_ConstrainedE+ = prism' reviewer remitter+ where+ reviewer (x, y) = ConstrainedE x y+ remitter (ConstrainedE x y) = Just (x, y)+ remitter _ = Nothing+#endif+ _GuardedB :: Prism' Body [(Guard, Exp)] _GuardedB = prism' reviewer remitter@@ -2281,6 +2533,34 @@ remitter (ViewP x y) = Just (x, y) remitter _ = Nothing +#if MIN_VERSION_template_haskell(2,22,0)+_TypeP :: Prism' Pat Type+_TypeP+ = prism' reviewer remitter+ where+ reviewer = TypeP+ remitter (TypeP x) = Just x+ remitter _ = Nothing++_InvisP :: Prism' Pat Type+_InvisP+ = prism' reviewer remitter+ where+ reviewer = InvisP+ remitter (InvisP x) = Just x+ remitter _ = Nothing+#endif++#if MIN_VERSION_template_haskell(2,23,0)+_OrP :: Prism' Pat (NonEmpty Pat)+_OrP+ = prism' reviewer remitter+ where+ reviewer = OrP+ remitter (OrP x) = Just x+ remitter _ = Nothing+#endif+ _ForallT :: Prism' Type ([TyVarBndrSpec], Cxt, Type) _ForallT = prism' reviewer remitter@@ -2497,6 +2777,24 @@ remitter _ = Nothing #endif +#if MIN_VERSION_template_haskell(2,19,0)+_PromotedInfixT :: Prism' Type (Type, Name, Type)+_PromotedInfixT+ = prism' reviewer remitter+ where+ reviewer (x, y, z) = PromotedInfixT x y z+ remitter (PromotedInfixT x y z) = Just (x, y, z)+ remitter _ = Nothing++_PromotedUInfixT :: Prism' Type (Type, Name, Type)+_PromotedUInfixT+ = prism' reviewer remitter+ where+ reviewer (x, y, z) = PromotedUInfixT x y z+ remitter (PromotedUInfixT x y z) = Just (x, y, z)+ remitter _ = Nothing+#endif+ #if MIN_VERSION_template_haskell(2,17,0) _SpecifiedSpec :: Prism' Specificity () _SpecifiedSpec@@ -2512,6 +2810,24 @@ where reviewer () = InferredSpec remitter InferredSpec = Just ()+ remitter _ = Nothing+#endif++#if MIN_VERSION_template_haskell(2,21,0)+_BndrReq :: Prism' BndrVis ()+_BndrReq+ = prism' reviewer remitter+ where+ reviewer () = BndrReq+ remitter BndrReq = Just ()+ remitter _ = Nothing++_BndrInvis :: Prism' BndrVis ()+_BndrInvis+ = prism' reviewer remitter+ where+ reviewer () = BndrInvis+ remitter BndrInvis = Just () remitter _ = Nothing #endif
src/Numeric/Lens.hs view
@@ -42,10 +42,10 @@ -- >>> import Control.Lens -- >>> import Data.Monoid (Sum(..)) --- | This 'Prism' can be used to model the fact that every 'Integral'+-- | This t'Prism' can be used to model the fact that every t'Integral' -- type is a subset of 'Integer'. ----- Embedding through the 'Prism' only succeeds if the 'Integer' would pass+-- Embedding through the t'Prism' only succeeds if the 'Integer' would pass -- through unmodified when re-extracted. integral :: (Integral a, Integral b) => Prism Integer Integer a b integral = prism toInteger $ \ i -> let a = fromInteger i in
src/System/FilePath/Lens.hs view
@@ -61,10 +61,10 @@ -- True -- -- @--- ('</>~') :: 'Setter' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a--- ('</>~') :: 'Iso' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a--- ('</>~') :: 'Lens' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a--- ('</>~') :: 'Traversal' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a+-- ('</>~') :: t'Setter' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a+-- ('</>~') :: t'Iso' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a+-- ('</>~') :: t'Lens' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a+-- ('</>~') :: t'Traversal' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a -- @ (</>~) :: ASetter s t FilePath FilePath -> FilePath -> s -> t l </>~ n = over l (</> n)@@ -87,7 +87,7 @@ {-# INLINE (</>=) #-} --- | Add a path onto the end of the target of a 'Lens' and return the result+-- | Add a path onto the end of the target of a t'Lens' and return the result -- -- When you do not need the result of the operation, ('</>~') is more flexible. (<</>~) :: LensLike ((,)FilePath) s a FilePath FilePath -> FilePath -> s -> (FilePath, a)@@ -95,7 +95,7 @@ {-# INLINE (<</>~) #-} --- | Add a path onto the end of the target of a 'Lens' into+-- | Add a path onto the end of the target of a t'Lens' into -- your monad's state and return the result. -- -- When you do not need the result of the operation, ('</>=') is more flexible.@@ -104,7 +104,7 @@ {-# INLINE (<</>=) #-} --- | Add a path onto the end of the target of a 'Lens' and return the original+-- | Add a path onto the end of the target of a t'Lens' and return the original -- value. -- -- When you do not need the original value, ('</>~') is more flexible.@@ -112,7 +112,7 @@ l <<</>~ b = l $ \a -> (a, a </> b) {-# INLINE (<<</>~) #-} --- | Add a path onto the end of a target of a 'Lens' into your monad's state+-- | Add a path onto the end of a target of a t'Lens' into your monad's state -- and return the old value. -- -- When you do not need the result of the operation, ('</>=') is more flexible.@@ -126,10 +126,10 @@ -- ("hello.txt","world.txt") -- -- @--- ('<.>~') :: 'Setter' s a 'FilePath' 'FilePath' -> 'String' -> s -> a--- ('<.>~') :: 'Iso' s a 'FilePath' 'FilePath' -> 'String' -> s -> a--- ('<.>~') :: 'Lens' s a 'FilePath' 'FilePath' -> 'String' -> s -> a--- ('<.>~') :: 'Traversal' s a 'FilePath' 'FilePath' -> 'String' -> s -> a+-- ('<.>~') :: t'Setter' s a 'FilePath' 'FilePath' -> 'String' -> s -> a+-- ('<.>~') :: t'Iso' s a 'FilePath' 'FilePath' -> 'String' -> s -> a+-- ('<.>~') :: t'Lens' s a 'FilePath' 'FilePath' -> 'String' -> s -> a+-- ('<.>~') :: t'Traversal' s a 'FilePath' 'FilePath' -> 'String' -> s -> a -- @ (<.>~) :: ASetter s a FilePath FilePath -> String -> s -> a l <.>~ n = over l (<.> n)@@ -150,7 +150,7 @@ l <.>= b = State.modify (l <.>~ b) {-# INLINE (<.>=) #-} --- | Add an extension onto the end of the target of a 'Lens' and return the result+-- | Add an extension onto the end of the target of a t'Lens' and return the result -- -- >>> _1 <<.>~ "txt" $ ("hello","world") -- ("hello.txt",("hello.txt","world"))@@ -161,7 +161,7 @@ {-# INLINE (<<.>~) #-} --- | Add an extension onto the end of the target of a 'Lens' into+-- | Add an extension onto the end of the target of a t'Lens' into -- your monad's state and return the result. -- -- >>> evalState (_1 <<.>= "txt") ("hello","world")@@ -172,7 +172,7 @@ l <<.>= r = l <%= (<.> r) {-# INLINE (<<.>=) #-} --- | Add an extension onto the end of the target of a 'Lens' but+-- | Add an extension onto the end of the target of a t'Lens' but -- return the old value -- -- >>> _1 <<<.>~ "txt" $ ("hello","world")@@ -183,7 +183,7 @@ l <<<.>~ b = l $ \a -> (a, a <.> b) {-# INLINE (<<<.>~) #-} --- | Add an extension onto the end of the target of a 'Lens' into your monad's+-- | Add an extension onto the end of the target of a t'Lens' into your monad's -- state and return the old value. -- -- >>> runState (_1 <<<.>= "txt") ("hello","world")@@ -194,9 +194,9 @@ l <<<.>= b = l %%= \a -> (a, a <.> b) {-# INLINE (<<<.>=) #-} --- | A 'Lens' for reading and writing to the basename+-- | A t'Lens' for reading and writing to the basename ----- Note: This is 'not' a legal 'Lens' unless the outer 'FilePath' has both a directory+-- Note: This is /not/ a legal t'Lens' unless the outer 'FilePath' has both a directory -- and filename component and the generated basenames are not null and contain no directory -- separators. --@@ -207,9 +207,9 @@ {-# INLINE basename #-} --- | A 'Lens' for reading and writing to the directory+-- | A t'Lens' for reading and writing to the directory ----- Note: this is /not/ a legal 'Lens' unless the outer 'FilePath' already has a directory component,+-- Note: this is /not/ a legal t'Lens' unless the outer 'FilePath' already has a directory component, -- and generated directories are not null. -- -- >>> (("long" </> "path" </> "name.txt") ^. directory) == "long" </> "path"@@ -219,9 +219,9 @@ {-# INLINE directory #-} --- | A 'Lens' for reading and writing to the extension+-- | A t'Lens' for reading and writing to the extension ----- Note: This is /not/ a legal 'Lens', unless you are careful to ensure that generated+-- Note: This is /not/ a legal t'Lens', unless you are careful to ensure that generated -- extension 'FilePath' components are either null or start with 'System.FilePath.extSeparator' -- and do not contain any internal 'System.FilePath.extSeparator's. --@@ -234,9 +234,9 @@ {-# INLINE extension #-} --- | A 'Lens' for reading and writing to the full filename+-- | A t'Lens' for reading and writing to the full filename ----- Note: This is /not/ a legal 'Lens', unless you are careful to ensure that generated+-- Note: This is /not/ a legal t'Lens', unless you are careful to ensure that generated -- filename 'FilePath' components are not null and do not contain any -- elements of 'System.FilePath.pathSeparators's. --
+ tests/BigRecord.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE TemplateHaskell #-}++module BigRecord where++import Control.Lens++data Big = Big+ { _a0 :: Int , _a1 :: Int , _a2 :: Int , _a3 :: Int , _a4 :: Int , _a5 :: Int , _a6 :: Int , _a7 :: Int+ , _a8 :: Int , _a9 :: Int , _a10 :: Int , _a11 :: Int , _a12 :: Int , _a13 :: Int , _a14 :: Int , _a15 :: Int+ , _a16 :: Int , _a17 :: Int , _a18 :: Int , _a19 :: Int , _a20 :: Int , _a21 :: Int , _a22 :: Int , _a23 :: Int+ , _a24 :: Int , _a25 :: Int , _a26 :: Int , _a27 :: Int , _a28 :: Int , _a29 :: Int , _a30 :: Int , _a31 :: Int+ , _a32 :: Int , _a33 :: Int , _a34 :: Int , _a35 :: Int , _a36 :: Int , _a37 :: Int , _a38 :: Int , _a39 :: Int+ , _a40 :: Int , _a41 :: Int , _a42 :: Int , _a43 :: Int , _a44 :: Int , _a45 :: Int , _a46 :: Int , _a47 :: Int+ , _a48 :: Int , _a49 :: Int , _a50 :: Int , _a51 :: Int , _a52 :: Int , _a53 :: Int , _a54 :: Int , _a55 :: Int+ , _a56 :: Int , _a57 :: Int , _a58 :: Int , _a59 :: Int , _a60 :: Int , _a61 :: Int , _a62 :: Int , _a63 :: Int+ , _a64 :: Int , _a65 :: Int , _a66 :: Int , _a67 :: Int , _a68 :: Int , _a69 :: Int , _a70 :: Int , _a71 :: Int+ , _a72 :: Int , _a73 :: Int , _a74 :: Int , _a75 :: Int , _a76 :: Int , _a77 :: Int , _a78 :: Int , _a79 :: Int+ , _a80 :: Int , _a81 :: Int , _a82 :: Int , _a83 :: Int , _a84 :: Int , _a85 :: Int , _a86 :: Int , _a87 :: Int+ , _a88 :: Int , _a89 :: Int , _a90 :: Int , _a91 :: Int , _a92 :: Int , _a93 :: Int , _a94 :: Int , _a95 :: Int+ , _a96 :: Int , _a97 :: Int , _a98 :: Int , _a99 :: Int+ }++data Bigger = Bigger+ { _b0 :: Int , _b1 :: Int , _b2 :: Int , _b3 :: Int , _b4 :: Int , _b5 :: Int , _b6 :: Int , _b7 :: Int+ , _b8 :: Int , _b9 :: Int , _b10 :: Int , _b11 :: Int , _b12 :: Int , _b13 :: Int , _b14 :: Int , _b15 :: Int+ , _b16 :: Int , _b17 :: Int , _b18 :: Int , _b19 :: Int , _b20 :: Int , _b21 :: Int , _b22 :: Int , _b23 :: Int+ , _b24 :: Int , _b25 :: Int , _b26 :: Int , _b27 :: Int , _b28 :: Int , _b29 :: Int , _b30 :: Int , _b31 :: Int+ , _b32 :: Int , _b33 :: Int , _b34 :: Int , _b35 :: Int , _b36 :: Int , _b37 :: Int , _b38 :: Int , _b39 :: Int+ , _b40 :: Int , _b41 :: Int , _b42 :: Int , _b43 :: Int , _b44 :: Int , _b45 :: Int , _b46 :: Int , _b47 :: Int+ , _b48 :: Int , _b49 :: Int , _b50 :: Int , _b51 :: Int , _b52 :: Int , _b53 :: Int , _b54 :: Int , _b55 :: Int+ , _b56 :: Int , _b57 :: Int , _b58 :: Int , _b59 :: Int , _b60 :: Int , _b61 :: Int , _b62 :: Int , _b63 :: Int+ , _b64 :: Int , _b65 :: Int , _b66 :: Int , _b67 :: Int , _b68 :: Int , _b69 :: Int , _b70 :: Int , _b71 :: Int+ , _b72 :: Int , _b73 :: Int , _b74 :: Int , _b75 :: Int , _b76 :: Int , _b77 :: Int , _b78 :: Int , _b79 :: Int+ , _b80 :: Int , _b81 :: Int , _b82 :: Int , _b83 :: Int , _b84 :: Int , _b85 :: Int , _b86 :: Int , _b87 :: Int+ , _b88 :: Int , _b89 :: Int , _b90 :: Int , _b91 :: Int , _b92 :: Int , _b93 :: Int , _b94 :: Int , _b95 :: Int+ , _b96 :: Int , _b97 :: Int , _b98 :: Int , _b99 :: Int , _b100 :: Int , _b101 :: Int , _b102 :: Int , _b103 :: Int+ , _b104 :: Int , _b105 :: Int , _b106 :: Int , _b107 :: Int , _b108 :: Int , _b109 :: Int , _b110 :: Int , _b111 :: Int+ , _b112 :: Int , _b113 :: Int , _b114 :: Int , _b115 :: Int , _b116 :: Int , _b117 :: Int , _b118 :: Int , _b119 :: Int+ , _b120 :: Int , _b121 :: Int , _b122 :: Int , _b123 :: Int , _b124 :: Int , _b125 :: Int , _b126 :: Int , _b127 :: Int+ , _b128 :: Int , _b129 :: Int , _b130 :: Int , _b131 :: Int , _b132 :: Int , _b133 :: Int , _b134 :: Int , _b135 :: Int+ , _b136 :: Int , _b137 :: Int , _b138 :: Int , _b139 :: Int , _b140 :: Int , _b141 :: Int , _b142 :: Int , _b143 :: Int+ , _b144 :: Int , _b145 :: Int , _b146 :: Int , _b147 :: Int , _b148 :: Int , _b149 :: Int , _b150 :: Int , _b151 :: Int+ , _b152 :: Int , _b153 :: Int , _b154 :: Int , _b155 :: Int , _b156 :: Int , _b157 :: Int , _b158 :: Int , _b159 :: Int+ , _b160 :: Int , _b161 :: Int , _b162 :: Int , _b163 :: Int , _b164 :: Int , _b165 :: Int , _b166 :: Int , _b167 :: Int+ , _b168 :: Int , _b169 :: Int , _b170 :: Int , _b171 :: Int , _b172 :: Int , _b173 :: Int , _b174 :: Int , _b175 :: Int+ , _b176 :: Int , _b177 :: Int , _b178 :: Int , _b179 :: Int , _b180 :: Int , _b181 :: Int , _b182 :: Int , _b183 :: Int+ , _b184 :: Int , _b185 :: Int , _b186 :: Int , _b187 :: Int , _b188 :: Int , _b189 :: Int , _b190 :: Int , _b191 :: Int+ , _b192 :: Int , _b193 :: Int , _b194 :: Int , _b195 :: Int , _b196 :: Int , _b197 :: Int , _b198 :: Int , _b199 :: Int+ , _b200 :: Int , _b201 :: Int , _b202 :: Int , _b203 :: Int , _b204 :: Int , _b205 :: Int , _b206 :: Int , _b207 :: Int+ , _b208 :: Int , _b209 :: Int , _b210 :: Int , _b211 :: Int , _b212 :: Int , _b213 :: Int , _b214 :: Int , _b215 :: Int+ , _b216 :: Int , _b217 :: Int , _b218 :: Int , _b219 :: Int , _b220 :: Int , _b221 :: Int , _b222 :: Int , _b223 :: Int+ , _b224 :: Int , _b225 :: Int , _b226 :: Int , _b227 :: Int , _b228 :: Int , _b229 :: Int , _b230 :: Int , _b231 :: Int+ , _b232 :: Int , _b233 :: Int , _b234 :: Int , _b235 :: Int , _b236 :: Int , _b237 :: Int , _b238 :: Int , _b239 :: Int+ , _b240 :: Int , _b241 :: Int , _b242 :: Int , _b243 :: Int , _b244 :: Int , _b245 :: Int , _b246 :: Int , _b247 :: Int+ , _b248 :: Int , _b249 :: Int , _b250 :: Int , _b251 :: Int , _b252 :: Int , _b253 :: Int , _b254 :: Int , _b255 :: Int+ , _b256 :: Int , _b257 :: Int , _b258 :: Int , _b259 :: Int , _b260 :: Int , _b261 :: Int , _b262 :: Int , _b263 :: Int+ , _b264 :: Int , _b265 :: Int , _b266 :: Int , _b267 :: Int , _b268 :: Int , _b269 :: Int , _b270 :: Int , _b271 :: Int+ , _b272 :: Int , _b273 :: Int , _b274 :: Int , _b275 :: Int , _b276 :: Int , _b277 :: Int , _b278 :: Int , _b279 :: Int+ , _b280 :: Int , _b281 :: Int , _b282 :: Int , _b283 :: Int , _b284 :: Int , _b285 :: Int , _b286 :: Int , _b287 :: Int+ , _b288 :: Int , _b289 :: Int , _b290 :: Int , _b291 :: Int , _b292 :: Int , _b293 :: Int , _b294 :: Int , _b295 :: Int+ , _b296 :: Int , _b297 :: Int , _b298 :: Int , _b299 :: Int+ }++makeLensesWith (lensRules & generateRecordSyntax .~ True) ''Big+makeLensesWith (lensRules & generateRecordSyntax .~ True) ''Bigger
+ tests/T1024.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- | Test 'makeFieldsId', which requires NoFieldSelectors and+-- DuplicateRecordFields. This test consequently only works on GHC >= 9.2.+module T1024 where++import Control.Lens++data Taco = Taco+ { hardShell :: Bool+ , sauce :: Int+ , filling :: String+ }+data Burrito = Burrito+ { sauce :: Int+ , filling :: String+ }+makeFieldsId ''Taco+makeFieldsId ''Burrito++checkTacoHardShell :: Lens' Taco Bool+checkTacoHardShell = hardShell++checkBurritoFilling :: Lens' Burrito String+checkBurritoFilling = filling
tests/hunit.hs view
@@ -23,15 +23,18 @@ import Control.Lens import Control.Monad.State import Data.Char+import qualified Data.Text as StrictT+import qualified Data.Text.Lazy as LazyT+import qualified Data.ByteString as StrictB+import qualified Data.ByteString.Lazy as LazyB import qualified Data.List as List import qualified Data.Map as Map import Data.Map (Map) #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid #endif-import Test.Framework.Providers.HUnit-import Test.Framework-import Test.HUnit hiding (test)+import Test.Tasty (defaultMain, testGroup)+import Test.Tasty.HUnit ((@?=), testCase) data Point =@@ -227,16 +230,96 @@ test = points <<>= [ origin ] trig' = trig { _points = (trig & _points) <> [ origin ] } +case_prepend_to_record_field =+ (trig & points <>:~ [ origin ])+ @?= trig { _points = [ origin ] <> (trig & _points) }++case_prepend_to_state_record_field = do+ runState test trig @?= ((), trig')+ where+ test = points <>:= [ origin ]+ trig' = trig { _points = [ origin ] <> (trig & _points) }++case_prepend_to_record_field_and_access_new_value =+ (trig & points <<>:~ [ origin ])+ @?= ([ origin ] <> _points trig, trig { _points = [ origin ] <> (trig & _points) })++case_prepend_to_state_record_field_and_access_new_value = do+ runState test trig @?= ([ origin ] <> _points trig, trig')+ where+ test = points <<>:= [ origin ]+ trig' = trig { _points = [ origin ] <> (trig & _points) }++case_cons_to_record_field =+ (trig & points <|~ origin)+ @?= trig { _points = origin : (trig & _points) }++case_cons_to_state_record_field = do+ runState test trig @?= ((), trig')+ where+ test = points <|= origin+ trig' = trig { _points = origin : (trig & _points) }++case_cons_to_record_field_and_access_new_value =+ (trig & points <<|~ origin)+ @?= (origin : _points trig, trig { _points = origin : (trig & _points) })++case_cons_to_state_record_field_and_access_new_value =+ runState test trig @?= ([ origin ] <> _points trig, trig')+ where+ test = points <<|= origin+ trig' = trig { _points = origin : (trig & _points) }++case_snoc_to_record_field =+ (trig & points |>~ origin)+ @?= trig { _points = (trig & _points) `snoc` origin }++case_snoc_to_state_record_field = do+ runState test trig @?= ((), trig')+ where+ test = points |>= origin+ trig' = trig { _points = (trig & _points) `snoc` origin }++case_snoc_to_record_field_and_access_new_value =+ (trig & points <|>~ origin)+ @?= (_points trig `snoc` origin, trig { _points = (trig & _points) `snoc` origin })++case_snoc_to_state_record_field_and_access_new_value =+ runState test trig @?= (_points trig <> [ origin ], trig')+ where+ test = points <|>= origin+ trig' = trig { _points = (trig & _points) `snoc` origin }+ case_append_to_record_field_and_access_old_value =- (trig & points <<%~ (<>[origin]))+ (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])+ test = points <<<>= [ origin ] trig' = trig { _points = (trig & _points) <> [ origin ] } +case_cons_to_record_field_and_access_old_value =+ (trig & points <<<|~ origin)+ @?= (_points trig, trig { _points = origin : (trig & _points) })++case_cons_to_state_record_field_and_access_old_value =+ runState test trig @?= (_points trig, trig')+ where+ test = points <<<|= origin+ trig' = trig { _points = origin : (trig & _points) }++case_snoc_to_record_field_and_access_old_value =+ (trig & points <<|>~ origin)+ @?= (_points trig, trig { _points = (trig & _points) `snoc` origin })++case_snoc_to_state_record_field_and_access_old_value =+ runState test trig @?= (_points trig, trig')+ where+ test = points <<|>= origin+ trig' = trig { _points = (trig & _points) `snoc` origin }+ case_read_maybe_map_entry = trig^.labels.at origin @?= Just "Origin" case_read_maybe_state_map_entry =@@ -279,43 +362,78 @@ , Point { _x = 4, _y = 7 } , Point { _x = 8, _y = 0 } ] } +case_correct_indexing_strict_text =+ map (\i -> StrictT.pack "12" ^? ix i) [-1..2]+ @?= [Nothing, Just '1', Just '2', Nothing]++case_correct_indexing_lazy_text =+ map (\i -> LazyT.pack "12" ^? ix i) [-1..2]+ @?= [Nothing, Just '1', Just '2', Nothing]++case_correct_indexing_strict_bytestring =+ map (\i -> StrictB.pack [1,2] ^? ix i) [-1..2]+ @?= [Nothing, Just 1, Just 2, Nothing]++case_correct_indexing_lazy_bytestring =+ map (\i -> LazyB.pack [1,2] ^? ix i) [-1..2]+ @?= [Nothing, Just 1, Just 2, Nothing]+ main :: IO ()-main = defaultMain- [ testGroup "Main"- [ testCase "read record field" case_read_record_field- , testCase "read state record field" case_read_state_record_field- , testCase "read record field and apply function" case_read_record_field_and_apply_function- , testCase "read state record field and apply function" case_read_state_record_field_and_apply_function- , testCase "write record field" case_write_record_field- , testCase "write state record field" case_write_state_record_field- , testCase "write record field and access new value" case_write_record_field_and_access_new_value- , testCase "write state record field and access new value" case_write_state_record_field_and_access_new_value- , testCase "write record field and access old value" case_write_record_field_and_access_old_value- , testCase "write state record field and access old value" case_write_state_record_field_and_access_old_value- , testCase "modify record field" case_modify_record_field- , testCase "modify state record field" case_modify_state_record_field- , testCase "modify record field and access new value" case_modify_record_field_and_access_new_value- , testCase "modify state record field and access new value" case_modify_state_record_field_and_access_new_value- , testCase "modify record field and access old value" case_modify_record_field_and_access_old_value- , testCase "modify state record field and access old value" case_modify_state_record_field_and_access_old_value- , testCase "modify record field and access side result" case_modify_record_field_and_access_side_result- , testCase "increment record field" case_increment_record_field- , testCase "increment state record field" case_increment_state_record_field- , testCase "append to record field" case_append_to_record_field- , testCase "append to state record field" case_append_to_state_record_field- , testCase "append to record field and access new value" case_append_to_record_field_and_access_new_value- , testCase "append to state record field and access new value" case_append_to_state_record_field_and_access_new_value- , testCase "append to record field and access old value" case_append_to_record_field_and_access_old_value- , testCase "append to state record field and access old value" case_append_to_state_record_field_and_access_old_value- , testCase "read maybe map entry" case_read_maybe_map_entry- , testCase "read maybe state map entry" case_read_maybe_state_map_entry- , testCase "read map entry" case_read_map_entry- , testCase "read state map entry" case_read_state_map_entry- , testCase "modify map entry" case_modify_map_entry- , testCase "insert maybe map entry" case_insert_maybe_map_entry- , testCase "delete maybe map entry" case_delete_maybe_map_entry- , testCase "read list entry" case_read_list_entry- , testCase "write list entry" case_write_list_entry- , testCase "write through list entry" case_write_through_list_entry- ]+main = defaultMain $+ testGroup "Main"+ [ testCase "read record field" case_read_record_field+ , testCase "read state record field" case_read_state_record_field+ , testCase "read record field and apply function" case_read_record_field_and_apply_function+ , testCase "read state record field and apply function" case_read_state_record_field_and_apply_function+ , testCase "write record field" case_write_record_field+ , testCase "write state record field" case_write_state_record_field+ , testCase "write record field and access new value" case_write_record_field_and_access_new_value+ , testCase "write state record field and access new value" case_write_state_record_field_and_access_new_value+ , testCase "write record field and access old value" case_write_record_field_and_access_old_value+ , testCase "write state record field and access old value" case_write_state_record_field_and_access_old_value+ , testCase "modify record field" case_modify_record_field+ , testCase "modify state record field" case_modify_state_record_field+ , testCase "modify record field and access new value" case_modify_record_field_and_access_new_value+ , testCase "modify state record field and access new value" case_modify_state_record_field_and_access_new_value+ , testCase "modify record field and access old value" case_modify_record_field_and_access_old_value+ , testCase "modify state record field and access old value" case_modify_state_record_field_and_access_old_value+ , testCase "modify record field and access side result" case_modify_record_field_and_access_side_result+ , testCase "increment record field" case_increment_record_field+ , testCase "increment state record field" case_increment_state_record_field+ , testCase "append to record field" case_append_to_record_field+ , testCase "append to state record field" case_append_to_state_record_field+ , testCase "prepend to record field" case_prepend_to_record_field+ , testCase "prepend to state record field" case_prepend_to_state_record_field+ , testCase "cons to record field" case_cons_to_record_field+ , testCase "cons to state record field" case_cons_to_state_record_field+ , testCase "snoc to record field" case_snoc_to_record_field+ , testCase "snoc to state record field" case_snoc_to_state_record_field+ , testCase "append to record field and access new value" case_append_to_record_field_and_access_new_value+ , testCase "append to state record field and access new value" case_append_to_state_record_field_and_access_new_value+ , testCase "prepend to record field and access new value" case_prepend_to_record_field_and_access_new_value+ , testCase "prepend to state record field and access new value" case_prepend_to_state_record_field_and_access_new_value+ , testCase "cons to record field and access new value" case_cons_to_record_field_and_access_new_value+ , testCase "cons to state record field and access new value" case_cons_to_state_record_field_and_access_new_value+ , testCase "snoc to record field and access new value" case_snoc_to_record_field_and_access_new_value+ , testCase "snoc to state record field and access new value" case_snoc_to_state_record_field_and_access_new_value+ , testCase "append to record field and access old value" case_append_to_record_field_and_access_old_value+ , testCase "append to state record field and access old value" case_append_to_state_record_field_and_access_old_value+ , testCase "cons to record field and access old value" case_cons_to_record_field_and_access_old_value+ , testCase "cons to state record field and access old value" case_cons_to_state_record_field_and_access_old_value+ , testCase "snoc to record field and access old value" case_snoc_to_record_field_and_access_old_value+ , testCase "snoc to state record field and access old value" case_snoc_to_state_record_field_and_access_old_value+ , testCase "read maybe map entry" case_read_maybe_map_entry+ , testCase "read maybe state map entry" case_read_maybe_state_map_entry+ , testCase "read map entry" case_read_map_entry+ , testCase "read state map entry" case_read_state_map_entry+ , testCase "modify map entry" case_modify_map_entry+ , testCase "insert maybe map entry" case_insert_maybe_map_entry+ , testCase "delete maybe map entry" case_delete_maybe_map_entry+ , testCase "read list entry" case_read_list_entry+ , testCase "write list entry" case_write_list_entry+ , testCase "write through list entry" case_write_through_list_entry+ , testCase "correct indexing strict text" case_correct_indexing_strict_text+ , testCase "correct indexing lazy text" case_correct_indexing_lazy_text+ , testCase "correct indexing strict bytestring" case_correct_indexing_strict_bytestring+ , testCase "correct indexing lazy bytestring" case_correct_indexing_lazy_bytestring ]
tests/properties.hs view
@@ -26,8 +26,8 @@ import Control.Lens import Test.QuickCheck-import Test.Framework-import Test.Framework.Providers.QuickCheck2+import Test.Tasty (defaultMain, testGroup)+import Test.Tasty.QuickCheck (testProperty) import Data.Char (isAlphaNum, isAscii, toUpper) import qualified Data.Text.Strict.Lens as Text import GHC.Exts (Constraint)@@ -129,32 +129,31 @@ main :: IO ()-main = defaultMain- [ testGroup "Main"- [ testProperty "1" prop_1- , testProperty "2" prop_2- , testProperty "3" prop_3- , testProperty "4" prop_4- , testProperty "5" prop_5- , testProperty "6" prop_6- , testProperty "7" prop_7- , testProperty "8" prop_8- , testProperty "9" prop_9- , testProperty "10" prop_10- , testProperty "2 2" prop_2_2- , testProperty "mapped" prop_mapped- , testProperty "mapped mapped" prop_mapped_mapped- , testProperty "both" prop_both- , testProperty "traverseLeft" prop_traverseLeft- , testProperty "traverseRight" prop_traverseRight- , testProperty "simple" prop_simple- , testProperty " Left" prop__Left- , testProperty " Right" prop__Right- , testProperty " Just" prop__Just- , testProperty "prefixed" prop_prefixed- , testProperty "text" prop_text- , testProperty "base show" prop_base_show- , testProperty "base read" prop_base_read- , testProperty "base readFail" prop_base_readFail- ]+main = defaultMain $+ testGroup "Main"+ [ testProperty "1" prop_1+ , testProperty "2" prop_2+ , testProperty "3" prop_3+ , testProperty "4" prop_4+ , testProperty "5" prop_5+ , testProperty "6" prop_6+ , testProperty "7" prop_7+ , testProperty "8" prop_8+ , testProperty "9" prop_9+ , testProperty "10" prop_10+ , testProperty "2 2" prop_2_2+ , testProperty "mapped" prop_mapped+ , testProperty "mapped mapped" prop_mapped_mapped+ , testProperty "both" prop_both+ , testProperty "traverseLeft" prop_traverseLeft+ , testProperty "traverseRight" prop_traverseRight+ , testProperty "simple" prop_simple+ , testProperty " Left" prop__Left+ , testProperty " Right" prop__Right+ , testProperty " Just" prop__Just+ , testProperty "prefixed" prop_prefixed+ , testProperty "text" prop_text+ , testProperty "base show" prop_base_show+ , testProperty "base read" prop_base_read+ , testProperty "base readFail" prop_base_readFail ]
tests/templates.hs view
@@ -27,6 +27,7 @@ import Control.Lens -- import Test.QuickCheck (quickCheck)+import BigRecord () import T799 () import T917 () import T972 ()@@ -449,6 +450,31 @@ $(makeClassyPrisms ''T865) instance AsT866 T865 where _T866 = __T865 . _T866++-- {make,declare}Wrapped test cases for ordinary data types+newtype T997A a = MkT997A a+$(makeWrapped ''T997A)++$(declareWrapped [d|+ newtype T997B b = MkT997B b+ |])++-- {make,declare}Wrapped test cases for data family instances (#997)+data family T997FamA a+newtype instance T997FamA a = MkT997FamA a+$(makeWrapped 'MkT997FamA)++$(declareWrapped [d|+ data family T997FamB b+ newtype instance T997FamB b = MkT997FamB b+ |])++-- Ensure that a data type defined in a TH quote can have a field whose type+-- references another data type defined in the same quote (#1032)+declareFields [d|+ data T1032A = T1032A { t1032ASubB :: T1032B }+ data T1032B = T1032B { t1032BB :: Int }+ |] main :: IO () main = putStrLn "test/templates.hs: ok"