lens 4.15.3 → 4.15.4
raw patch · 24 files changed
+385/−227 lines, 24 filesdep +call-stackdep −hlintdep ~basedep ~doctestdep ~profunctorsnew-uploader
Dependencies added: call-stack
Dependencies removed: hlint
Dependency ranges changed: base, doctest, profunctors
Files
- .gitignore +1/−0
- .travis.yml +60/−71
- CHANGELOG.markdown +28/−1
- examples/lens-examples.cabal +1/−1
- lens.cabal +11/−27
- src/Control/Lens/Cons.hs +2/−0
- src/Control/Lens/Fold.hs +40/−12
- src/Control/Lens/Internal/FieldTH.hs +105/−37
- src/Control/Lens/Internal/List.hs +3/−0
- src/Control/Lens/Internal/PrismTH.hs +4/−2
- src/Control/Lens/Lens.hs +41/−7
- src/Control/Lens/Operators.hs +4/−0
- src/Control/Lens/Plated.hs +5/−1
- src/Control/Lens/Prism.hs +6/−4
- src/Control/Lens/Setter.hs +3/−3
- src/Control/Lens/TH.hs +20/−23
- src/Control/Lens/Traversal.hs +4/−2
- src/Control/Lens/Type.hs +1/−1
- src/Control/Lens/Zoom.hs +3/−3
- src/Data/HashSet/Lens.hs +0/−3
- src/Language/Haskell/TH/Lens.hs +5/−1
- src/Numeric/Lens.hs +6/−3
- tests/hlint.hs +0/−23
- tests/templates.hs +32/−2
.gitignore view
@@ -18,3 +18,4 @@ cabal.sandbox.config .stack-work/ codex.tags+.ghc.environment.*
.travis.yml view
@@ -1,98 +1,87 @@-# This file has been generated -- see https://github.com/hvr/multi-ghc-travis+# This Travis job script has been generated by a script via+#+# make_travis_yml_2.hs 'lens.cabal'+#+# For more information, see https://github.com/hvr/multi-ghc-travis+# language: c sudo: false +git:+ submodules: false # whether to recursively clone submodules+ cache: directories:- - $HOME/.cabsnap - $HOME/.cabal/packages+ - $HOME/.cabal/store before_cache: - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar+ # remove files that are regenerated by 'cabal update'+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx +addons:+ apt:+ packages: &apt_packages+ - ghc-ppa-tools+ - alex-3.1.7+ - happy-1.19.5+ matrix: include:- - env: CABALVER=1.24 GHCVER=8.2.1- compiler: ": #GHC 8.2.1"- addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.1,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=1.24 GHCVER=8.0.2- compiler: ": #GHC 8.0.2"- addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=1.24 GHCVER=7.10.3- compiler: ": #GHC 7.10.3"- addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.3,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=1.24 GHCVER=7.8.4- compiler: ": #GHC 7.8.4"- addons: {apt: {packages: [cabal-install-1.24,ghc-7.8.4,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=1.24 GHCVER=7.6.3- compiler: ": #GHC 7.6.3"- addons: {apt: {packages: [cabal-install-1.24,ghc-7.6.3,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=1.24 GHCVER=7.4.2- compiler: ": #GHC 7.4.2"- addons: {apt: {packages: [cabal-install-1.24,ghc-7.4.2,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=head GHCVER=head CABALFLAGS=--allow-newer- compiler: ": #GHC head"- addons: {apt: {packages: [cabal-install-head,ghc-head,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}-- allow_failures:- - env: CABALVER=head GHCVER=head CABALFLAGS=--allow-newer+ - compiler: "ghc-8.2.1"+ # env: TEST=--disable-tests BENCH=--disable-benchmarks+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.2.1], sources: [hvr-ghc]}}+ - compiler: "ghc-8.0.2"+ # env: TEST=--disable-tests BENCH=--disable-benchmarks+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.0.2], sources: [hvr-ghc]}}+ - compiler: "ghc-7.10.3"+ # env: TEST=--disable-tests BENCH=--disable-benchmarks+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.10.3], sources: [hvr-ghc]}}+ - compiler: "ghc-7.8.4"+ # env: TEST=--disable-tests BENCH=--disable-benchmarks+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.8.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.6.3"+ # env: TEST=--disable-tests BENCH=--disable-benchmarks+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.6.3], sources: [hvr-ghc]}}+ - compiler: "ghc-7.4.2"+ # env: TEST=--disable-tests BENCH=--disable-benchmarks+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.4.2], sources: [hvr-ghc]}} before_install:+ - HC=${CC} - unset CC - export HAPPYVER=1.19.5 - export ALEXVER=3.1.7- - export PATH=~/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/happy/$HAPPYVER/bin:/opt/alex/$ALEXVER/bin:$PATH+ - export HLINTVER=2.0.9+ - mkdir ~/.hlint+ - curl -L https://github.com/ndmitchell/hlint/releases/download/v$HLINTVER/hlint-$HLINTVER-x86_64-linux.tar.gz | tar -xz --strip-components=1 -C ~/.hlint+ - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:~/.hlint:~/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/happy/$HAPPYVER/bin:/opt/alex/$ALEXVER/bin:$PATH install: - cabal --version- - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"- - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];- then- zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >- $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;- fi- - travis_retry cabal update- - "sed -i 's/^jobs:.*$/jobs: 2/' $HOME/.cabal/config"- - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt- - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt--# check whether current requested install-plan matches cached package-db snapshot- - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;- then- echo "cabal build-cache HIT";- rm -rfv .ghc;- cp -a $HOME/.cabsnap/ghc $HOME/.ghc;- cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;- else- echo "cabal build-cache MISS";- rm -rf $HOME/.cabsnap;- mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;- cabal install --only-dependencies --enable-tests --enable-benchmarks;- fi--# snapshot package-db on cache miss- - if [ ! -d $HOME/.cabsnap ];- then- echo "snapshotting package-db to build-cache";- mkdir $HOME/.cabsnap;- cp -a $HOME/.ghc $HOME/.cabsnap/ghc;- cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;- fi+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"+ - BENCH=${BENCH---enable-benchmarks}+ - TEST=${TEST---enable-tests}+ - travis_retry cabal update -v+ - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config+ - rm -fv cabal.project.local+ - rm -f cabal.project.freeze+ - cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j # Here starts the actual work to be performed for the package under test; # any command which exits with a non-zero exit code causes the build to fail. script:- - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging- - cabal build # this builds all libraries and executables (including tests)- - cabal test- - cabal sdist # tests that a source-distribution can be generated--# Check that the resulting source distribution can be built & installed.-# If there are no other `.tar.gz` files in `dist`, this can be even simpler:-# `cabal install --force-reinstalls dist/*-*.tar.gz`- - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&- (cd dist && cabal install --force-reinstalls "$SRC_TGZ")+ - if [ -f configure.ac ]; then autoreconf -i; fi+ - rm -rf .ghc.environment.* dist/+ # build tests and benchmarks, run tests+ - cabal new-build -w ${HC} ${TEST} ${BENCH}+ - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH}; fi+ - hlint src --cpp-define=HLINT --cpp-ansi notifications: irc:
CHANGELOG.markdown view
@@ -1,4 +1,31 @@-next+4.15.4+----+* `makeFields` and `declareFields` are now smarter with respect to type+ families. Because GHC does not allow mentioning type families in instance+ heads, the Template Haskell machinery works around this restriction by+ instead generating instances of the form:++ ```haskell+ type family Fam a+ data Rec a = Rec { _recFam :: Fam a }+ makeFields ''Rec++ ===>++ instance (b ~ Fam a) => HasFam (Rec a) b where ...+ ```++ This requires enabling the `UndecidableInstances` extension, so this trick is+ only employed when a field's type contains a type family application.+* `declareFields` now avoids creating duplicate field classes that are shared+ among multiple datatypes within the same invocation.+* The Template Haskell machinery will no longer generate optics for fields+ whose types mention existentially quantified type variables.+* Add `HasCallStack` constraints to partial operations+* Reexport `(.@~)` and `(.@=)` from `Control.Lens.Operators`+* Support `doctest-0.13`++4.15.3 ---- * Generalized types of `transformMOf`, `transformOf`, `transformMOnOf`, `transformOnOf`, `rewriteMOf`, `rewriteOf`, `rewriteMOnOf` and `rewriteOnOf`.
examples/lens-examples.cabal view
@@ -30,7 +30,7 @@ build-depends: base, containers >= 0.4 && < 0.6,- gloss >= 1.7 && < 1.11,+ gloss >= 1.7 && < 1.12, lens, mtl >= 2.0.1 && < 2.3, random >= 1.0 && < 1.2
lens.cabal view
@@ -1,6 +1,6 @@ name: lens category: Data, Lenses, Generics-version: 4.15.3+version: 4.15.4 license: BSD2 cabal-version: >= 1.8 license-file: LICENSE@@ -12,7 +12,7 @@ copyright: Copyright (C) 2012-2016 Edward A. Kmett build-type: Custom -- build-tools: cpphs-tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1, GHC == 7.10.2, GHC == 8.0.2+tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1 synopsis: Lenses, Folds and Traversals description: This package comes \"Batteries Included\" with many useful lenses for the types@@ -148,11 +148,6 @@ default: False manual: True --- You can disable the hlint test suite with -f-test-hlint-flag test-hlint- default: True- manual: True- -- You can disable the doctests test suite with -f-test-doctests flag test-doctests default: True@@ -194,6 +189,7 @@ base-orphans >= 0.5.2 && < 1, bifunctors >= 5.1 && < 6, bytestring >= 0.9.1.10 && < 0.11,+ call-stack >= 0.1 && < 0.2, comonad >= 4 && < 6, contravariant >= 1.3 && < 2, containers >= 0.4.0 && < 0.6,@@ -206,7 +202,7 @@ exceptions >= 0.1.1 && < 1, mtl >= 2.0.1 && < 2.3, parallel >= 3.1.0.1 && < 3.3,- profunctors >= 5 && < 6,+ profunctors >= 5.2.1 && < 6, reflection >= 2.1 && < 3, semigroupoids >= 5 && < 6, semigroups >= 0.8.4 && < 1,@@ -395,10 +391,11 @@ -- Verify the results of the examples test-suite doctests- type: exitcode-stdio-1.0- main-is: doctests.hs- ghc-options: -Wall -threaded- hs-source-dirs: tests+ type: exitcode-stdio-1.0+ main-is: doctests.hs+ ghc-options: -Wall -threaded+ hs-source-dirs: tests+ x-doctest-options: --fast if flag(trustworthy) && impl(ghc>=7.2) other-extensions: Trustworthy@@ -413,9 +410,10 @@ containers, directory >= 1.0, deepseq,- doctest >= 0.11.1 && <0.12,+ doctest >= 0.11.4 && < 0.12 || >= 0.13 && < 0.14, filepath, generic-deriving,+ lens, mtl, nats, parallel,@@ -424,20 +422,6 @@ text, unordered-containers, vector--test-suite hlint- type: exitcode-stdio-1.0- main-is: hlint.hs- ghc-options: -w -threaded -rtsopts -with-rtsopts=-N- hs-source-dirs: tests-- if !flag(test-hlint)- buildable: False- else- build-depends:- base,- -- Bounds are in place due to https://github.com/ekmett/lens/issues/723- hlint >= 1.9.27 && < 2 || >= 2.0.1 -- Basic benchmarks for the uniplate-style combinators benchmark plated
src/Control/Lens/Cons.hs view
@@ -68,7 +68,9 @@ import Data.Word import Prelude +#ifdef HLINT {-# ANN module "HLint: ignore Eta reduce" #-}+#endif -- $setup -- >>> :set -XNoOverloadedStrings
src/Control/Lens/Fold.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ConstraintKinds #-} #ifndef MIN_VERSION_reflection #define MIN_VERSION_reflection(x,y,z) 1@@ -158,6 +159,7 @@ import Control.Monad as Monad import Control.Monad.Reader import Control.Monad.State+import Data.CallStack import Data.Foldable import Data.Functor.Apply import Data.Functor.Compose@@ -424,8 +426,29 @@ -- -- Note: Many uses of this combinator will yield something that meets the types, but not the laws of a valid -- 'Traversal' or 'IndexedTraversal'. The 'Traversal' and 'IndexedTraversal' laws are only satisfied if the--- new values you assign also pass the predicate! Otherwise subsequent traversals will visit fewer elements--- and 'Traversal' fusion is not sound.+-- new values you assign to the first target also does not pass the predicate! Otherwise subsequent traversals+-- will visit fewer elements and 'Traversal' fusion is not sound.+--+-- So for any traversal @t@ and predicate @p@, @`droppingWhile` p t@ may not be lawful, but+-- @(`Control.Lens.Traversal.dropping` 1 . `droppingWhile` p) t@ is. For example:+--+-- >>> let l :: Traversal' [Int] Int; l = droppingWhile (<= 1) traverse+-- >>> let l' :: Traversal' [Int] Int; l' = dropping 1 l+--+-- @l@ is not a lawful setter because @`Control.Lens.Setter.over` l f .+-- `Control.Lens.Setter.over` l g ≢ `Control.Lens.Setter.over` l (f . g)@:+--+-- >>> [1,2,3] & l .~ 0 & l .~ 4+-- [1,0,0]+-- >>> [1,2,3] & l .~ 4+-- [1,4,4]+--+-- @l'@ on the other hand behaves lawfully:+--+-- >>> [1,2,3] & l' .~ 0 & l' .~ 4+-- [1,2,4]+-- >>> [1,2,3] & l' .~ 4+-- [1,2,4] droppingWhile :: (Conjoined p, Profunctor q, Applicative f) => (a -> Bool) -> Optical p q (Compose (State Bool) f) s t a a@@ -1213,7 +1236,7 @@ -- ('^?!') :: s -> 'Iso'' s a -> a -- ('^?!') :: s -> 'Traversal'' s a -> a -- @-(^?!) :: s -> Getting (Endo a) s a -> a+(^?!) :: HasCallStack => s -> Getting (Endo a) s a -> a s ^?! l = foldrOf l const (error "(^?!): empty Fold") s {-# INLINE (^?!) #-} @@ -1653,7 +1676,7 @@ -- 'foldr1Of' :: 'Lens'' s a -> (a -> a -> a) -> s -> a -- 'foldr1Of' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @-foldr1Of :: Getting (Endo (Maybe a)) 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 mf x my = Just $ case my of@@ -1679,7 +1702,7 @@ -- 'foldl1Of' :: 'Lens'' s a -> (a -> a -> a) -> s -> a -- 'foldl1Of' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @-foldl1Of :: Getting (Dual (Endo (Maybe a))) 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 mf mx y = Just $ case mx of Nothing -> y@@ -1737,7 +1760,7 @@ -- 'foldr1Of'' :: 'Lens'' s a -> (a -> a -> a) -> s -> a -- 'foldr1Of'' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @-foldr1Of' :: Getting (Dual (Endo (Endo (Maybe a)))) 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 mf x Nothing = Just $! x mf x (Just y) = Just $! f x y@@ -1758,7 +1781,7 @@ -- 'foldl1Of'' :: 'Lens'' s a -> (a -> a -> a) -> s -> a -- 'foldl1Of'' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @-foldl1Of' :: Getting (Endo (Endo (Maybe a))) 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 mf Nothing y = Just $! y mf (Just x) y = Just $! f x y@@ -2495,7 +2518,7 @@ -- ('^@?!') :: s -> 'IndexedLens'' i s a -> (i, a) -- ('^@?!') :: s -> 'IndexedTraversal'' i s a -> (i, a) -- @-(^@?!) :: s -> IndexedGetting i (Endo (i, a)) s a -> (i, a)+(^@?!) :: HasCallStack => s -> IndexedGetting i (Endo (i, a)) s a -> (i, a) s ^@?! l = ifoldrOf l (\i x _ -> (i,x)) (error "(^@?!): empty Fold") s {-# INLINE (^@?!) #-} @@ -2564,7 +2587,7 @@ -- >>> [0,0,0,5,5,5]^..traversed.ifiltered (\i a -> i <= a) -- [0,5,5,5] ----- Compose with 'filtered' to filter another 'IndexedLens', 'IndexedIso', 'IndexedGetter', 'IndexedFold' (or 'IndexedTraversal') with+-- Compose with 'ifiltered' to filter another 'IndexedLens', 'IndexedIso', 'IndexedGetter', 'IndexedFold' (or 'IndexedTraversal') with -- access to both the value and the index. -- -- Note: As with 'filtered', this is /not/ a legal 'IndexedTraversal', unless you are very careful not to invalidate the predicate on the target!@@ -2581,6 +2604,10 @@ -- 'itakingWhile' :: (i -> a -> 'Bool') -> 'IndexedLens'' i s a -> 'IndexedFold' i s a -- 'itakingWhile' :: (i -> a -> 'Bool') -> 'IndexedGetter' i s a -> 'IndexedFold' i s a -- @+--+-- Note: Applying 'itakingWhile' to an 'IndexedLens' or 'IndexedTraversal' will still allow you to use it as a+-- pseudo-'IndexedTraversal', but if you change the value of any target to one where the predicate returns+-- 'False', then you will break the 'Traversal' laws and 'Traversal' fusion will no longer be sound. itakingWhile :: (Indexable i p, Profunctor q, Contravariant f, Applicative f) => (i -> a -> Bool) -> Optical' (Indexed i) q (Const (Endo (f s))) s a@@ -2598,9 +2625,10 @@ -- 'idroppingWhile' :: (i -> a -> 'Bool') -> 'IndexedGetter' i s a -> 'IndexedFold' i s a -- @ ----- Applying 'idroppingWhile' to an 'IndexedLens' or 'IndexedTraversal' will still allow you to use it as a--- pseudo-'IndexedTraversal', but if you change the value of the targets to ones where the predicate returns--- 'True', then you will break the 'Traversal' laws and 'Traversal' fusion will no longer be sound.+-- Note: As with `droppingWhile` applying 'idroppingWhile' to an 'IndexedLens' or 'IndexedTraversal' will still+-- allow you to use it as a pseudo-'IndexedTraversal', but if you change the value of the first target to one+-- where the predicate returns 'True', then you will break the 'Traversal' laws and 'Traversal' fusion will+-- no longer be sound. idroppingWhile :: (Indexable i p, Profunctor q, Applicative f) => (i -> a -> Bool) -> Optical (Indexed i) q (Compose (State Bool) f) s t a a
src/Control/Lens/Internal/FieldTH.hs view
@@ -1,7 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} #ifdef TRUSTWORTHY+# if MIN_VERSION_template_haskell(2,12,0)+{-# LANGUAGE Safe #-}+# else {-# LANGUAGE Trustworthy #-}+# endif #endif -----------------------------------------------------------------------------@@ -17,9 +21,13 @@ module Control.Lens.Internal.FieldTH ( LensRules(..)+ , FieldNamer , DefName(..)+ , ClassyNamer , makeFieldOptics , makeFieldOpticsForDec+ , makeFieldOpticsForDec'+ , HasFieldClasses ) where import Control.Lens.At@@ -33,6 +41,7 @@ import Control.Lens.Traversal import Control.Applicative import Control.Monad+import Control.Monad.State import Language.Haskell.TH.Lens import Language.Haskell.TH import qualified Language.Haskell.TH.Datatype as D@@ -47,7 +56,6 @@ import qualified Data.Traversable as T import Prelude - ------------------------------------------------------------------------ -- Field generation entry point ------------------------------------------------------------------------@@ -56,28 +64,30 @@ -- | Compute the field optics for the type identified by the given type name. -- Lenses will be computed when possible, Traversals otherwise. makeFieldOptics :: LensRules -> Name -> DecsQ-makeFieldOptics rules = makeFieldOpticsForDec' rules <=< D.reifyDatatype-+makeFieldOptics rules = (`evalStateT` Set.empty) . makeFieldOpticsForDatatype rules <=< D.reifyDatatype makeFieldOpticsForDec :: LensRules -> Dec -> DecsQ-makeFieldOpticsForDec rules = makeFieldOpticsForDec' rules <=< D.normalizeDec+makeFieldOpticsForDec rules = (`evalStateT` Set.empty) . makeFieldOpticsForDec' rules +makeFieldOpticsForDec' :: LensRules -> Dec -> HasFieldClasses [Dec]+makeFieldOpticsForDec' rules = makeFieldOpticsForDatatype rules <=< lift . D.normalizeDec --- | Compute the field optics for a deconstructed Dec+-- | Compute the field optics for a deconstructed datatype Dec -- When possible build an Iso otherwise build one optic per field.-makeFieldOpticsForDec' :: LensRules -> D.DatatypeInfo -> DecsQ-makeFieldOpticsForDec' rules info =- do 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- perDef <- T.sequenceA (fromSet (buildScaffold rules s defCons) allDefs)+makeFieldOpticsForDatatype :: LensRules -> D.DatatypeInfo -> HasFieldClasses [Dec]+makeFieldOpticsForDatatype rules info =+ do perDef <- lift $ do+ 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+ T.sequenceA (fromSet (buildScaffold rules s defCons) allDefs) let defs = Map.toList perDef case _classyLenses rules tyName of Just (className, methodName) -> makeClassyDriver rules className methodName s defs- Nothing -> do decss <- traverse (makeFieldOptic rules) defs+ Nothing -> do decss <- traverse (makeFieldOptic rules) defs return (concat decss) where@@ -96,14 +106,13 @@ -- | Normalized the Con type into a uniform positional representation, -- eliminating the variance between records, infix constructors, and normal -- constructors.------ For 'GadtC' and 'RecGadtC', the leftmost name is chosen. normalizeConstructor :: D.ConstructorInfo -> Q (Name, [(Maybe Name, Type)]) -- ^ constructor name, field name, field type normalizeConstructor con =- return (D.constructorName con, zip fieldNames (D.constructorFields con))+ return (D.constructorName con,+ zipWith checkForExistentials fieldNames (D.constructorFields con)) where fieldNames = case D.constructorVariant con of@@ -111,6 +120,16 @@ D.NormalConstructor -> repeat Nothing D.InfixConstructor -> repeat Nothing + -- Fields mentioning existentially quantified types are not+ -- elligible for TH generated optics.+ checkForExistentials _ fieldtype+ | any (\tv -> D.tvName tv `Set.member` used) unallowable+ = (Nothing, fieldtype)+ where+ used = setOf typeVars fieldtype+ unallowable = D.constructorVars con+ checkForExistentials fieldname fieldtype = (fieldname, fieldtype)+ data OpticType = GetterType | LensType | IsoType -- | Compute the positional location of the fields involved in@@ -236,17 +255,23 @@ makeFieldOptic :: LensRules -> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])])) ->- DecsQ-makeFieldOptic rules (defName, (opticType, defType, cons)) =- do cls <- mkCls- T.sequenceA (cls ++ sig ++ def)+ HasFieldClasses [Dec]+makeFieldOptic rules (defName, (opticType, defType, cons)) = do+ locals <- get+ addName+ lift $ do cls <- mkCls locals+ T.sequenceA (cls ++ sig ++ def) where- mkCls = case defName of- MethodName c n | _generateClasses rules ->- do classExists <- isJust <$> lookupTypeName (show c)- return (if classExists then [] else [makeFieldClass defType c n])- _ -> return []+ mkCls locals = case defName of+ MethodName c n | _generateClasses rules ->+ do classExists <- isJust <$> lookupTypeName (show c)+ return (if classExists || Set.member c locals then [] else [makeFieldClass defType c n])+ _ -> return [] + addName = case defName of+ MethodName c _ -> addFieldClassName c+ _ -> return ()+ sig = case defName of _ | not (_generateSigs rules) -> [] TopName n -> [sigD n (return (stabToType defType))]@@ -260,7 +285,6 @@ clauses = makeFieldClauses rules opticType cons - ------------------------------------------------------------------------ -- Classy class generator ------------------------------------------------------------------------@@ -272,11 +296,11 @@ Name -> Type {- ^ Outer 's' type -} -> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] ->- DecsQ+ HasFieldClasses [Dec] makeClassyDriver rules className methodName s defs = T.sequenceA (cls ++ inst) where- cls | _generateClasses rules = [makeClassyClass className methodName s defs]+ cls | _generateClasses rules = [lift $ makeClassyClass className methodName s defs] | otherwise = [] inst = [makeClassyInstance rules className methodName s defs]@@ -319,13 +343,13 @@ Name -> Type {- ^ Outer 's' type -} -> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] ->- DecQ+ HasFieldClasses Dec makeClassyInstance rules className methodName s defs = do methodss <- traverse (makeFieldOptic rules') defs - instanceD (cxt[]) (return instanceHead)- $ valD (varP methodName) (normalB (varE idValName)) []- : map return (concat methodss)+ lift $ instanceD (cxt[]) (return instanceHead)+ $ valD (varP methodName) (normalB (varE idValName)) []+ : map return (concat methodss) where instanceHead = className `conAppsT` (s : map VarT vars)@@ -349,11 +373,32 @@ s = mkName "s" a = mkName "a" +-- | Build an instance for a field. If the field’s type contains any type+-- families, will produce an equality constraint to avoid a type family+-- application in the instance head. makeFieldInstance :: OpticStab -> Name -> [DecQ] -> DecQ-makeFieldInstance defType className =- instanceD (cxt [])- (return (className `conAppsT` [stabToS defType, stabToA defType]))+makeFieldInstance defType className decs =+ containsTypeFamilies a >>= pickInstanceDec+ where+ s = stabToS defType+ a = stabToA defType + containsTypeFamilies = go <=< D.resolveTypeSynonyms+ where+ go (ConT nm) = has _FamilyI <$> reify nm+ go ty = or <$> traverse go (ty ^.. plate)++ pickInstanceDec hasFamilies+ | hasFamilies = do+ placeholder <- VarT <$> newName "a"+ mkInstanceDec+ [return (D.equalPred placeholder a)]+ [s, placeholder]+ | otherwise = mkInstanceDec [] [s, a]++ mkInstanceDec context headTys =+ instanceD (cxt context) (return (className `conAppsT` headTys)) decs+ ------------------------------------------------------------------------ -- Optic clause generators ------------------------------------------------------------------------@@ -533,18 +578,41 @@ , _allowIsos :: Bool , _allowUpdates :: Bool -- ^ Allow Lens/Traversal (otherwise Getter/Fold) , _lazyPatterns :: Bool- , _fieldToDef :: Name -> [Name] -> Name -> [DefName]+ , _fieldToDef :: FieldNamer -- ^ Type Name -> Field Names -> Target Field Name -> Definition Names- , _classyLenses :: Name -> Maybe (Name,Name)+ , _classyLenses :: ClassyNamer -- type name to class name and top method } +-- | The rule to create function names of lenses for data fields.+--+-- Although it's sometimes useful, you won't need the first two+-- arguments most of the time.+type FieldNamer = Name -- ^ Name of the data type that lenses are being generated for.+ -> [Name] -- ^ Names of all fields (including the field being named) in the data type.+ -> Name -- ^ Name of the field being named.+ -> [DefName] -- ^ Name(s) of the lens functions. If empty, no lens is created for that field. -- | Name to give to generated field optics. data DefName = TopName Name -- ^ Simple top-level definiton name | MethodName Name Name -- ^ makeFields-style class name and method name deriving (Show, Eq, Ord)++-- | The optional rule to create a class and method around a+-- monomorphic data type. If this naming convention is provided, it+-- generates a "classy" lens.+type ClassyNamer = Name -- ^ Name of the data type that lenses are being generated for.+ -> Maybe (Name, Name) -- ^ Names of the class and the main method it generates, respectively.++-- | Tracks the field class 'Name's that have been created so far. We consult+-- these so that we may avoid creating duplicate classes.++-- See #643 for more information.+type HasFieldClasses = StateT (Set Name) Q++addFieldClassName :: Name -> HasFieldClasses ()+addFieldClassName n = modify $ Set.insert n ------------------------------------------------------------------------ -- Miscellaneous utility functions
src/Control/Lens/Internal/List.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.List@@ -17,7 +18,9 @@ import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet +#ifdef HLINT {-# ANN module "HLint: ignore Redundant bracket" #-}+#endif -- | Return the the subset of given ordinals within a given bound -- and in order of the first occurrence seen.
src/Control/Lens/Internal/PrismTH.hs view
@@ -1,6 +1,10 @@ {-# LANGUAGE CPP #-} #ifdef TRUSTWORTHY+# if MIN_VERSION_template_haskell(2,12,0)+{-# LANGUAGE Safe #-}+# else {-# LANGUAGE Trustworthy #-}+# endif #endif #ifndef MIN_VERSION_template_haskell@@ -464,8 +468,6 @@ -- | Normalize a single 'Con' to its constructor name and field types.--- Because GADT syntax allows multiple constructors to be defined at--- the same time, this function can return multiple normalized results. normalizeCon :: D.ConstructorInfo -> NCon normalizeCon info = NCon (D.constructorName info) (D.tvName <$> D.constructorVars info)
src/Control/Lens/Lens.hs view
@@ -86,7 +86,7 @@ , (<%~), (<+~), (<-~), (<*~), (<//~) , (<^~), (<^^~), (<**~) , (<||~), (<&&~), (<<>~)- , (<<%~), (<<.~), (<<+~), (<<-~), (<<*~)+ , (<<%~), (<<.~), (<<?~), (<<+~), (<<-~), (<<*~) , (<<//~), (<<^~), (<<^^~), (<<**~) , (<<||~), (<<&&~), (<<<>~) @@ -94,7 +94,7 @@ , (<%=), (<+=), (<-=), (<*=), (<//=) , (<^=), (<^^=), (<**=) , (<||=), (<&&=), (<<>=)- , (<<%=), (<<.=), (<<+=), (<<-=), (<<*=)+ , (<<%=), (<<.=), (<<?=), (<<+=), (<<-=), (<<*=) , (<<//=), (<<^=), (<<^^=), (<<**=) , (<<||=), (<<&&=), (<<<>=) , (<<~)@@ -164,9 +164,9 @@ -- >>> let setter :: Expr -> Expr -> Expr; setter = fun "setter" infixl 8 ^#-infixr 4 %%@~, <%@~, <<%@~, %%~, <+~, <*~, <-~, <//~, <^~, <^^~, <**~, <&&~, <||~, <<>~, <%~, <<%~, <<.~, <#~, #~, #%~, <#%~, #%%~+infixr 4 %%@~, <%@~, <<%@~, %%~, <+~, <*~, <-~, <//~, <^~, <^^~, <**~, <&&~, <||~, <<>~, <%~, <<%~, <<.~, <<?~, <#~, #~, #%~, <#%~, #%%~ , <<+~, <<-~, <<*~, <<//~, <<^~, <<^^~, <<**~, <<||~, <<&&~, <<<>~-infix 4 %%@=, <%@=, <<%@=, %%=, <+=, <*=, <-=, <//=, <^=, <^^=, <**=, <&&=, <||=, <<>=, <%=, <<%=, <<.=, <#=, #=, #%=, <#%=, #%%=+infix 4 %%@=, <%@=, <<%@=, %%=, <+=, <*=, <-=, <//=, <^=, <^^=, <**=, <&&=, <||=, <<>=, <%=, <<%=, <<.=, <<?=, <#=, #=, #%=, <#%=, #%%= , <<+=, <<-=, <<*=, <<//=, <<^=, <<^^=, <<**=, <<||=, <<&&=, <<<>= infixr 2 <<~ infixl 1 <&>, ??, &~@@ -690,6 +690,23 @@ l <<.~ b = l $ \a -> (a, b) {-# INLINE (<<.~) #-} +-- | Replace the target of a 'Lens' with a 'Just' value, but return the old value.+--+-- If you do not need the old value ('Control.Lens.Setter.?~') is more flexible.+--+-- >>> import Data.Map as Map+-- >>> _2.at "hello" <<?~ "world" $ (42,Map.fromList [("goodnight","gracie")])+-- (Nothing,(42,fromList [("goodnight","gracie"),("hello","world")]))+--+-- @+-- ('<<?~') :: 'Iso' s t a ('Maybe' b) -> b -> s -> (a, t)+-- ('<<?~') :: 'Lens' s t a ('Maybe' b) -> b -> s -> (a, t)+-- ('<<?~') :: 'Traversal' s t a ('Maybe' b) -> b -> s -> (a, t)+-- @+(<<?~) :: LensLike ((,)a) s t a (Maybe b) -> b -> s -> (a, t)+l <<?~ b = l <<.~ Just b+{-# INLINE (<<?~) #-}+ -- | Increment the target of a numerically valued 'Lens' and return the old value. -- -- When you do not need the old value, ('Control.Lens.Setter.+~') is more flexible.@@ -1003,7 +1020,7 @@ -- | Modify the target of a 'Lens' into your 'Monad''s state by a user supplied -- function and return the /old/ value that was replaced. ----- When applied to a 'Control.Lens.Traversal.Traversal', it this will return a monoidal summary of all of the old values+-- When applied to a 'Control.Lens.Traversal.Traversal', this will return a monoidal summary of all of the old values -- present. -- -- When you do not need the result of the operation, ('Control.Lens.Setter.%=') is more flexible.@@ -1022,7 +1039,7 @@ -- | Replace the target of a 'Lens' into your 'Monad''s state with a user supplied -- value and return the /old/ value that was replaced. ----- When applied to a 'Control.Lens.Traversal.Traversal', it this will return a monoidal summary of all of the old values+-- When applied to a 'Control.Lens.Traversal.Traversal', this will return a monoidal summary of all of the old values -- present. -- -- When you do not need the result of the operation, ('Control.Lens.Setter..=') is more flexible.@@ -1030,11 +1047,28 @@ -- @ -- ('<<.=') :: 'MonadState' s m => 'Lens'' s a -> a -> m a -- ('<<.=') :: 'MonadState' s m => 'Control.Lens.Iso.Iso'' s a -> a -> m a--- ('<<.=') :: ('MonadState' s m, 'Monoid' t) => 'Control.Lens.Traversal.Traversal'' s a -> a -> m a+-- ('<<.=') :: ('MonadState' s m, 'Monoid' a) => 'Control.Lens.Traversal.Traversal'' s a -> a -> m a -- @ (<<.=) :: MonadState s m => LensLike ((,)a) s s a b -> b -> m a l <<.= b = l %%= \a -> (a,b) {-# INLINE (<<.=) #-}++-- | Replace the target of a 'Lens' into your 'Monad''s state with 'Just' a user supplied+-- value and return the /old/ value that was replaced.+--+-- When applied to a 'Control.Lens.Traversal.Traversal', this will return a monoidal summary of all of the old values+-- present.+--+-- When you do not need the result of the operation, ('Control.Lens.Setter.?=') is more flexible.+--+-- @+-- ('<<?=') :: 'MonadState' s m => 'Lens' s t a (Maybe b) -> b -> m a+-- ('<<?=') :: 'MonadState' s m => 'Control.Lens.Iso.Iso' s t a (Maybe b) -> b -> m a+-- ('<<?=') :: ('MonadState' s m, 'Monoid' a) => 'Control.Lens.Traversal.Traversal' s t a (Maybe b) -> b -> m a+-- @+(<<?=) :: MonadState s m => LensLike ((,)a) s s a (Maybe b) -> b -> m a+l <<?= b = l <<.= Just b+{-# INLINE (<<?=) #-} -- | Modify the target of a 'Lens' into your 'Monad''s state by adding a value -- and return the /old/ value that was replaced.
src/Control/Lens/Operators.hs view
@@ -51,6 +51,7 @@ , (<&&~) , (<<%~) , (<<.~)+ , (<<?~) , (<<+~) , (<<-~) , (<<*~)@@ -73,6 +74,7 @@ , (<&&=) , (<<%=) , (<<.=)+ , (<<?=) , (<<+=) , (<<-=) , (<<*=)@@ -139,6 +141,8 @@ , (<?=) , (<>~) , (<>=)+ , (.@~)+ , (.@=) , (%@~) , (%@=) ) where
src/Control/Lens/Plated.hs view
@@ -14,7 +14,11 @@ #endif #ifdef TRUSTWORTHY+# if MIN_VERSION_template_haskell(2,12,0)+{-# LANGUAGE Safe #-}+# else {-# LANGUAGE Trustworthy #-} -- template-haskell+# endif #endif #ifndef MIN_VERSION_template_haskell@@ -524,7 +528,7 @@ -- @ -- 'transformMOf' :: 'Monad' m => 'Traversal'' a a -> (a -> m a) -> a -> m a -- @-transformMOf :: Monad m => LensLike (WrappedMonad m) a b a b -> (b -> m b) -> a -> m b +transformMOf :: Monad m => LensLike (WrappedMonad m) a b a b -> (b -> m b) -> a -> m b transformMOf l f = go where go t = mapMOf l go t >>= f {-# INLINE transformMOf #-}
src/Control/Lens/Prism.hs view
@@ -70,7 +70,9 @@ #endif import Prelude +#ifdef HLINT {-# ANN module "HLint: ignore Use camelCase" #-}+#endif -- $setup -- >>> :set -XNoOverloadedStrings@@ -333,15 +335,15 @@ {-# INLINE only #-} --- | This 'Prism' compares for approximate equality with a given value and a predicate for testing, +-- | This 'Prism' compares for approximate equality with a given value and a predicate for testing, -- an example where the value is the empty list and the predicate checks that a list is empty (same -- as 'Control.Lens.Empty._Empty' with the 'Control.Lens.Empty.AsEmpty' list instance):--- +-- -- >>> nearly [] null # () -- [] -- >>> [1,2,3,4] ^? nearly [] null -- Nothing--- +-- -- @'nearly' [] 'Prelude.null' :: 'Prism'' [a] ()@ -- -- To comply with the 'Prism' laws the arguments you supply to @nearly a p@ are somewhat constrained.@@ -349,7 +351,7 @@ -- We assume @p x@ holds iff @x ≡ a@. Under that assumption then this is a valid 'Prism'. -- -- This is useful when working with a type where you can test equality for only a subset of its--- values, and the prism selects such a value. +-- values, and the prism selects such a value. nearly :: a -> (a -> Bool) -> Prism' a () nearly a p = prism' (\() -> a) $ guard . p
src/Control/Lens/Setter.hs view
@@ -106,9 +106,9 @@ -- >>> import Data.Map as Map -- >>> import Debug.SimpleReflect.Expr as Expr -- >>> import Debug.SimpleReflect.Vars as Vars--- >>> let f :: Expr -> Expr; f = Vars.f--- >>> let g :: Expr -> Expr; g = Vars.g--- >>> let h :: Expr -> Expr -> Expr; h = Vars.h+-- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f+-- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g+-- >>> let h :: Expr -> Expr -> Expr; h = Debug.SimpleReflect.Vars.h -- >>> let getter :: Expr -> Expr; getter = fun "getter" -- >>> let setter :: Expr -> Expr -> Expr; setter = fun "setter" -- >>> :set -XNoOverloadedStrings
src/Control/Lens/TH.hs view
@@ -1,7 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} #ifdef TRUSTWORTHY+# if MIN_VERSION_template_haskell(2,12,0)+{-# LANGUAGE Safe #-}+# else {-# LANGUAGE Trustworthy #-}+# endif #endif #ifndef MIN_VERSION_base@@ -86,7 +90,8 @@ #if !(MIN_VERSION_template_haskell(2,7,0)) import Control.Monad (ap) #endif-import qualified Control.Monad.Trans as Trans+import Control.Monad.Trans.Class+import Control.Monad.Trans.State import Control.Monad.Trans.Writer import Control.Lens.Fold import Control.Lens.Getter@@ -112,7 +117,7 @@ import Data.Traversable hiding (mapM) import Language.Haskell.TH import Language.Haskell.TH.Lens-import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Syntax hiding (lift) #ifdef HLINT {-# ANN module "HLint: ignore Eta reduce" #-}@@ -181,25 +186,10 @@ lensField :: Lens' LensRules FieldNamer lensField f r = fmap (\x -> r { _fieldToDef = x}) (f (_fieldToDef r)) --- | The rule to create function names of lenses for data fields.------ Although it's sometimes useful, you won't need the first two--- arguments most of the time.-type FieldNamer = Name -- ^ Name of the data type that lenses are being generated for.- -> [Name] -- ^ Names of all fields (including the field being named) in the data type.- -> Name -- ^ Name of the field being named.- -> [DefName] -- ^ Name(s) of the lens functions. If empty, no lens is created for that field.- -- | 'Lens'' to access the option for naming "classy" lenses. lensClass :: Lens' LensRules ClassyNamer lensClass f r = fmap (\x -> r { _classyLenses = x }) (f (_classyLenses r)) --- | The optional rule to create a class and method around a--- monomorphic data type. If this naming convention is provided, it--- generates a "classy" lens.-type ClassyNamer = Name -- ^ Name of the data type that lenses are being generated for.- -> Maybe (Name, Name) -- ^ Names of the class and the main method it generates, respectively.- -- | Rules for making fairly simple partial lenses, ignoring the special cases -- for isomorphisms and traversals, and not making any classes. -- It uses 'underscoreNoPrefixNamer'.@@ -460,13 +450,13 @@ -- @ declarePrisms :: DecsQ -> DecsQ declarePrisms = declareWith $ \dec -> do- emit =<< Trans.lift (makeDecPrisms True dec)+ emit =<< liftDeclare (makeDecPrisms True dec) return dec -- | Build 'Control.Lens.Wrapped.Wrapped' instance for each newtype. declareWrapped :: DecsQ -> DecsQ declareWrapped = declareWith $ \dec -> do- maybeDecs <- Trans.lift (makeWrappedForDec dec)+ maybeDecs <- liftDeclare (makeWrappedForDec dec) forM_ maybeDecs emit return dec @@ -479,7 +469,7 @@ -- off. declareLensesWith :: LensRules -> DecsQ -> DecsQ declareLensesWith rules = declareWith $ \dec -> do- emit =<< Trans.lift (makeFieldOpticsForDec rules dec)+ emit =<< lift (makeFieldOpticsForDec' rules dec) return $ stripFields dec -----------------------------------------------------------------------------@@ -838,12 +828,19 @@ declareWith :: (Dec -> Declare Dec) -> DecsQ -> DecsQ declareWith fun = (runDeclare . traverseDataAndNewtype fun =<<) --- | Monad for emitting top-level declarations as a side effect.-type Declare = WriterT (Endo [Dec]) Q+-- | Monad for emitting top-level declarations as a side effect. We also track+-- the set of field class 'Name's that have been created and consult them to+-- avoid creating duplicate classes. +-- See #463 for more information.+type Declare = WriterT (Endo [Dec]) (StateT (Set Name) Q)++liftDeclare :: Q a -> Declare a+liftDeclare = lift . lift+ runDeclare :: Declare [Dec] -> DecsQ runDeclare dec = do- (out, endo) <- runWriterT dec+ (out, endo) <- evalStateT (runWriterT dec) Set.empty return $ out ++ appEndo endo [] emit :: [Dec] -> Declare ()
src/Control/Lens/Traversal.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ConstraintKinds #-} #ifndef MIN_VERSION_containers #define MIN_VERSION_containers(x,y,z) 1@@ -144,6 +145,7 @@ import Control.Monad import Control.Monad.Trans.State.Lazy import Data.Bitraversable+import Data.CallStack #if __GLASGOW_HASKELL__ < 710 import Data.Foldable (Foldable) #endif@@ -656,7 +658,7 @@ -- 'singular' :: 'IndexedTraversal' i s t a a -> 'IndexedLens' i s t a a -- 'singular' :: 'IndexedFold' i s a -> 'IndexedGetter' i s a -- @-singular :: (Conjoined p, Functor f)+singular :: (HasCallStack, Conjoined p, Functor f) => Traversing p f s t a a -> Over p f s t a a singular l = conjoined@@ -682,7 +684,7 @@ -- 'unsafeSingular' :: 'IndexedTraversal' i s t a b -> 'IndexedLens' i s t a b -- 'unsafeSingular' :: 'IndexedFold' i s a -> 'IndexedGetter' i s a -- @-unsafeSingular :: (Conjoined p, Functor f)+unsafeSingular :: (HasCallStack, Conjoined p, Functor f) => Traversing p f s t a b -> Over p f s t a b unsafeSingular l = conjoined
src/Control/Lens/Type.hs view
@@ -301,7 +301,7 @@ -- @ -- -- @--- type 'Setter'' = 'Setter''+-- type 'Setter'' = 'Simple' 'Setter' -- @ type Setter' s a = Setter s s a a
src/Control/Lens/Zoom.hs view
@@ -63,9 +63,9 @@ -- >>> import Data.Map as Map -- >>> import Debug.SimpleReflect.Expr as Expr -- >>> import Debug.SimpleReflect.Vars as Vars--- >>> let f :: Expr -> Expr; f = Vars.f--- >>> let g :: Expr -> Expr; g = Vars.g--- >>> let h :: Expr -> Expr -> Expr; h = Vars.h+-- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f+-- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g+-- >>> let h :: Expr -> Expr -> Expr; h = Debug.SimpleReflect.Vars.h -- Chosen so that they have lower fixity than ('%='), and to match ('<~'). infixr 2 `zoom`, `magnify`
src/Data/HashSet/Lens.hs view
@@ -1,8 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-}-#ifdef TRUSTWORTHY-{-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : Data.HashSet.Lens
src/Language/Haskell/TH/Lens.hs view
@@ -1,6 +1,10 @@ {-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704+#if defined(__GLASGOW_HASKELL__)+# if MIN_VERSION_template_haskell(2,12,0)+{-# LANGUAGE Safe #-}+# else {-# LANGUAGE Trustworthy #-}+# endif #endif {-# LANGUAGE Rank2Types #-}
src/Numeric/Lens.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE Rank2Types #-} #if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE PatternSynonyms #-}@@ -34,6 +36,7 @@ ) where import Control.Lens+import Data.CallStack import Data.Char (chr, ord, isAsciiLower, isAsciiUpper, isDigit) import Data.Maybe (fromMaybe) import Numeric (readInt, showIntAtBase)@@ -67,7 +70,7 @@ -- -- >>> 1767707668033969 ^. re (base 36) -- "helloworld"-base :: Integral a => Int -> Prism' String a+base :: (HasCallStack, Integral a) => Int -> Prism' String a base b | b < 2 || b > 36 = error ("base: Invalid base " ++ show b) | otherwise = prism intShow intRead@@ -81,14 +84,14 @@ {-# INLINE base #-} -- | Like 'Data.Char.intToDigit', but handles up to base-36-intToDigit' :: Int -> Char+intToDigit' :: HasCallStack => Int -> Char intToDigit' i | i >= 0 && i < 10 = chr (ord '0' + i) | i >= 10 && i < 36 = chr (ord 'a' + i - 10) | otherwise = error ("intToDigit': Invalid int " ++ show i) -- | Like 'Data.Char.digitToInt', but handles up to base-36-digitToInt' :: Char -> Int+digitToInt' :: HasCallStack => Char -> Int digitToInt' c = fromMaybe (error ("digitToInt': Invalid digit " ++ show c)) (digitToIntMay c)
− tests/hlint.hs
@@ -1,23 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Main (hlint)--- Copyright : (C) 2013-2014 Edward Kmett--- License : BSD-style (see the file LICENSE)--- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ This module runs HLint on the lens source tree.-------------------------------------------------------------------------------module Main where--import Control.Monad-import Language.Haskell.HLint-import System.Environment-import System.Exit--main :: IO ()-main = do- args <- getArgs- hints <- hlint $ ["src", "--cpp-define=HLINT", "--cpp-ansi"] ++ args- unless (null hints) exitFailure
tests/templates.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- |@@ -58,7 +59,7 @@ checkA1 = a1 checkA2 :: Lens' (Hadron a b) a-checkA2 = a2 +checkA2 = a2 checkC :: Lens (Hadron a b) (Hadron a b') b b' checkC = c@@ -214,6 +215,24 @@ checkThing2 :: Lens' (Lebowski a) (Maybe a) checkThing2 = thing +type family Fam a+type instance Fam Int = String++data FamRec a = FamRec+ { _famRecThing :: Fam a+ , _famRecUniqueToFamRec :: Fam a+ }+makeFields ''FamRec++checkFamRecThing :: Lens' (FamRec a) (Fam a)+checkFamRecThing = thing++checkFamRecUniqueToFamRec :: Lens' (FamRec a) (Fam a)+checkFamRecUniqueToFamRec = uniqueToFamRec++checkFamRecView :: FamRec Int -> String+checkFamRecView = view thing+ data AbideConfiguration a = AbideConfiguration { _acLocation :: String , _acDuration :: Int@@ -237,7 +256,7 @@ checkThing3 = thing dudeDrink :: String-dudeDrink = (Dude 9 "El Duderino" () "white russian") ^. thing +dudeDrink = (Dude 9 "El Duderino" () "white russian") ^. thing lebowskiCarpet :: Maybe String lebowskiCarpet = (Lebowski "Mr. Lebowski" 0 "" (Just "carpet")) ^. thing abideAnnoyance :: String@@ -348,6 +367,17 @@ checkC0' :: Traversal' (DeclaredFields f a) String checkC0' = c0 #endif++declareFields [d|+ data Aardvark = Aardvark { aardvarkAlbatross :: Int }+ data Baboon = Baboon { baboonAlbatross :: Int }+ |]++checkAardvark :: Lens' Aardvark Int+checkAardvark = albatross++checkBaboon :: Lens' Baboon Int+checkBaboon = albatross data Rank2Tests = C1 { _r2length :: forall a. [a] -> Int