├── .github └── workflows │ ├── haskell-ci.yml │ └── hlint.yml ├── .gitignore ├── .gitmodules ├── .hlint.yaml ├── .vim.custom ├── AUTHORS.markdown ├── CHANGELOG.markdown ├── LICENSE ├── README.markdown ├── SUPPORT.markdown ├── Setup.lhs ├── benchmarks ├── alongside.hs ├── folds.hs ├── plated.hs ├── traversals.hs └── unsafe.hs ├── cabal.haskell-ci ├── cabal.project ├── examples ├── .hlint.yaml ├── Aeson.hs ├── LICENSE ├── Plates.hs ├── Pong.hs ├── Setup.lhs ├── Turtle.hs └── lens-examples.cabal ├── experimental ├── Control │ └── Lens │ │ ├── Format.hs │ │ └── Internal │ │ ├── Jacket.hs │ │ └── Zip.hs └── Data │ └── Text │ └── Encoding │ └── Lens.hs ├── images ├── Hierarchy.png └── overview.png ├── include └── lens-common.h ├── lens-properties ├── .hlint.yaml ├── CHANGELOG.markdown ├── LICENSE ├── Setup.hs ├── lens-properties.cabal └── src │ └── Control │ └── Lens │ └── Properties.hs ├── lens.cabal ├── scripts ├── DocTypes.hs ├── README.md ├── github-fetch-images ├── github-name-map ├── hackage-docs.sh ├── operators ├── run-gource ├── spellcheck └── stats ├── src ├── Control │ ├── Exception │ │ └── Lens.hs │ ├── Lens.hs │ ├── Lens │ │ ├── At.hs │ │ ├── Combinators.hs │ │ ├── Cons.hs │ │ ├── Each.hs │ │ ├── Empty.hs │ │ ├── Equality.hs │ │ ├── Extras.hs │ │ ├── Fold.hs │ │ ├── Getter.hs │ │ ├── Indexed.hs │ │ ├── Internal.hs │ │ ├── Internal │ │ │ ├── Bazaar.hs │ │ │ ├── ByteString.hs │ │ │ ├── CTypes.hs │ │ │ ├── Context.hs │ │ │ ├── Deque.hs │ │ │ ├── Doctest.hs │ │ │ ├── Exception.hs │ │ │ ├── FieldTH.hs │ │ │ ├── Fold.hs │ │ │ ├── Getter.hs │ │ │ ├── Indexed.hs │ │ │ ├── Instances.hs │ │ │ ├── Iso.hs │ │ │ ├── Level.hs │ │ │ ├── List.hs │ │ │ ├── Magma.hs │ │ │ ├── Prelude.hs │ │ │ ├── Prism.hs │ │ │ ├── PrismTH.hs │ │ │ ├── Profunctor.hs │ │ │ ├── Review.hs │ │ │ ├── Setter.hs │ │ │ ├── TH.hs │ │ │ └── Zoom.hs │ │ ├── Iso.hs │ │ ├── Lens.hs │ │ ├── Level.hs │ │ ├── Operators.hs │ │ ├── Plated.hs │ │ ├── Prism.hs │ │ ├── Profunctor.hs │ │ ├── Reified.hs │ │ ├── Review.hs │ │ ├── Setter.hs │ │ ├── TH.hs │ │ ├── Traversal.hs │ │ ├── Tuple.hs │ │ ├── Type.hs │ │ ├── Unsound.hs │ │ ├── Wrapped.hs │ │ └── Zoom.hs │ ├── Monad │ │ └── Error │ │ │ └── Lens.hs │ ├── Parallel │ │ └── Strategies │ │ │ └── Lens.hs │ └── Seq │ │ └── Lens.hs ├── Data │ ├── Array │ │ └── Lens.hs │ ├── Bits │ │ └── Lens.hs │ ├── ByteString │ │ ├── Lazy │ │ │ └── Lens.hs │ │ ├── Lens.hs │ │ └── Strict │ │ │ └── Lens.hs │ ├── Complex │ │ └── Lens.hs │ ├── Data │ │ └── Lens.hs │ ├── Dynamic │ │ └── Lens.hs │ ├── HashSet │ │ └── Lens.hs │ ├── IntSet │ │ └── Lens.hs │ ├── List │ │ └── Lens.hs │ ├── Map │ │ └── Lens.hs │ ├── Sequence │ │ └── Lens.hs │ ├── Set │ │ └── Lens.hs │ ├── Text │ │ ├── Lazy │ │ │ └── Lens.hs │ │ ├── Lens.hs │ │ └── Strict │ │ │ └── Lens.hs │ ├── Tree │ │ └── Lens.hs │ ├── Typeable │ │ └── Lens.hs │ └── Vector │ │ ├── Generic │ │ └── Lens.hs │ │ └── Lens.hs ├── GHC │ └── Generics │ │ └── Lens.hs ├── Language │ └── Haskell │ │ └── TH │ │ └── Lens.hs ├── Numeric │ ├── Lens.hs │ └── Natural │ │ └── Lens.hs └── System │ ├── Exit │ └── Lens.hs │ ├── FilePath │ └── Lens.hs │ └── IO │ └── Error │ └── Lens.hs └── tests ├── BigRecord.hs ├── T1024.hs ├── T799.hs ├── T917.hs ├── T972.hs ├── doctests.hs ├── hunit.hs ├── properties.hs └── templates.hs /.github/workflows/hlint.yml: -------------------------------------------------------------------------------- 1 | name: HLint 2 | on: 3 | - push 4 | - pull_request 5 | jobs: 6 | hlint: 7 | runs-on: ubuntu-latest 8 | 9 | steps: 10 | - name: Checkout repository 11 | uses: actions/checkout@v4 12 | 13 | - name: 'Set up HLint' 14 | uses: haskell-actions/hlint-setup@v2 15 | with: 16 | version: '3.8' 17 | 18 | - name: 'Run HLint (lens)' 19 | uses: haskell-actions/hlint-run@v2 20 | with: 21 | path: src/ 22 | fail-on: suggestion 23 | 24 | # https://github.com/haskell-actions/hlint-run/issues/12 25 | - name: 'HLint config (lens-properties)' 26 | run: | 27 | cp lens-properties/.hlint.yaml . 28 | 29 | - name: 'Run HLint (lens-properties)' 30 | uses: haskell-actions/hlint-run@v2 31 | with: 32 | path: lens-properties/src/ 33 | fail-on: suggestion 34 | 35 | - name: 'HLint config (examples)' 36 | run: | 37 | cp examples/.hlint.yaml . 38 | 39 | - name: 'Run HLint (examples)' 40 | uses: haskell-actions/hlint-run@v2 41 | with: 42 | path: examples/ 43 | fail-on: suggestion 44 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-newstyle/ 3 | .hsenv/ 4 | docs 5 | wiki 6 | TAGS 7 | tags 8 | wip 9 | .DS_Store 10 | .*.swp 11 | .*.swo 12 | *.o 13 | *.hi 14 | *~ 15 | *# 16 | cabal.project.local 17 | .cabal-sandbox/ 18 | cabal.sandbox.config 19 | .stack-work/ 20 | codex.tags 21 | .ghc.environment.* 22 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ekmett/lens/b44bdc6c7eca95cb111782075e4534c2c5098737/.gitmodules -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - arguments: [-XCPP, --cpp-ansi, --cpp-include=include] 2 | 3 | - ignore: {name: Reduce duplication} 4 | - ignore: {name: Redundant lambda} 5 | - ignore: {name: Use >=>} 6 | - ignore: {name: Use const} 7 | - ignore: {name: Use module export list} 8 | - ignore: {name: Use lambda-case} 9 | - ignore: {name: Use tuple-section} 10 | - ignore: {name: Use fewer imports} 11 | - ignore: {name: "Use :"} 12 | - ignore: {name: Use typeRep, within: [Control.Lens.Internal.Typeable, Control.Lens.Internal.Exception]} 13 | - ignore: {name: Eta reduce, within: [Control.Lens.At, Control.Lens.Zoom, Control.Lens.Equality, Control.Lens.Traversal]} # Breaks code 14 | - ignore: {name: Use id, within: [Control.Lens.Equality]} 15 | - ignore: {name: Use camelCase, within: [Control.Lens.Internal.TH]} 16 | - ignore: {name: Use list comprehension, within: [Control.Lens.Internal.FieldTH]} 17 | - 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 18 | - ignore: {name: Use uncurry} 19 | - ignore: {name: Fuse concatMap/<&>, within: [Control.Lens.Internal.FieldTH]} 20 | 21 | - fixity: "infixr 9 ..." 22 | - fixity: "infixl 1 &~" 23 | -------------------------------------------------------------------------------- /.vim.custom: -------------------------------------------------------------------------------- 1 | " Add the following to your .vimrc to automatically load this on startup 2 | 3 | " if filereadable(".vim.custom") 4 | " so .vim.custom 5 | " endif 6 | 7 | function StripTrailingWhitespace() 8 | let myline=line(".") 9 | let mycolumn = col(".") 10 | silent %s/ *$// 11 | call cursor(myline, mycolumn) 12 | endfunction 13 | 14 | " enable syntax highlighting 15 | syntax on 16 | 17 | " search for the tags file anywhere between here and / 18 | set tags=TAGS;/,codex.tags;/ 19 | 20 | " highlight tabs and trailing spaces 21 | set listchars=tab:‗‗,trail:‗ 22 | set list 23 | 24 | " f2 runs hasktags 25 | map :exec ":!hasktags -x -c --ignore src" 26 | 27 | " strip trailing whitespace before saving 28 | " au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() 29 | 30 | " rebuild hasktags after saving 31 | au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" 32 | -------------------------------------------------------------------------------- /AUTHORS.markdown: -------------------------------------------------------------------------------- 1 | Lens started as a one man project by 2 | 3 | * [Edward Kmett](mailto:ekmett@gmail.com) [@ekmett](https://github.com/ekmett) 4 | 5 | But it has been greatly enriched by opening it up to community development. 6 | 7 | Many people have contributed patches, documentation, wiki pages, bug reports, test cases and massive quantities of code to `lens` including (among others): 8 | 9 | * [Shachaf Ben-Kiki](mailto:shachaf@gmail.com) [@shachaf](https://github.com/shachaf) 10 | * Elliott Hird [@ehird](https://github.com/ehird) 11 | * [Johan Kiviniemi](mailto:lens@johan.kiviniemi.name) [@ion1](https://github.com/ion1) 12 | * [Bas Dirks](mailto:ik@basdirks.eu) [@basdirks](https://github.com/basdirks) 13 | * [Eric Mertens](mailto:emertens@gmail.com) [@glguy](https://github.com/glguy) 14 | * [Michael Sloan](mailto:mgsloan@gmail.com) [@mgsloan](https://github.com/mgsloan) 15 | * [Alexander Altman](mailto:alexanderaltman@me.com) [@phtariensflame](https://github.com/phtariensflame) 16 | * [Austin Seipp](mailto:mad.one@gmail.com) [@thoughtpolice](https://github.com/thoughtpolice) 17 | * [Dag Odenhall](mailto:dag.odenhall@gmail.com) [@dag](https://github.com/dag) 18 | * [Aristid Breitkreuz](mailto:aristidb+lens@gmail.com) [@aristidb](https://github.com/aristidb) 19 | * [Simon Hengel](mailto:sol@typeful.net) [@sol](https://github.com/sol) 20 | * [@startling](https://github.com/startling) 21 | * [Mike Ledger](mailto:eleventynine@gmail.com) [@mikeplus64](https://github.com/mikeplus64) 22 | * [Niklas Haas](mailto:niklas.haas@uni-ulm.de) [@nandykins](https://github.com/nandykins) 23 | * [Adrian Keet](mailto:arkeet@gmail.com) [@arkeet](https://github.com/arkeet) 24 | * [Matvey B. Aksenov](mailto:matvey.aksenov@gmail.com) [@supki](https://github.com/supki) 25 | * [Eyal Lotem](mailto:eyal.lotem+github@gmail.com) [@Peaker](https://github.com/Peaker) 26 | * [Oliver Charles](mailto:ollie@ocharles.org.uk) [@ocharles](https://github.com/ocharles) 27 | * Liyang HU [@liyang](https://github.com/liyang) 28 | * [Carter Schonwald](mailto:carter.schonwald@gmail.com) [@cartazio](https://github.com/cartazio) 29 | * [Mark Wright](mailto:gienah@gentoo.org) [@markwright](https://github.com/markwright) 30 | * [Nathan van Doorn](mailto:nvd1234@gmail.com) [@Taneb](https://github.com/Taneb) 31 | * Ville Tirronen [@aleator](https://github.com/aleator) 32 | * [Mikhail Vorozhtsov](mailto:mikhail.vorozhtsov@gmail.com) [@mvv](https://github.com/mvv) 33 | * [Brent Yorgey](mailto:byorgey@gmail.com) [@byorgey](https://github.com/byorgey) 34 | * [Dan Rosén](mailto:danr@chalmers.se) [@danr](https://github.com/danr) 35 | * Yair Chuchem [@yairchu](https://github.com/yairchu) 36 | * [Michael Thompson](mailto:what_is_it_to_do_anything@yahoo.com) [@michaelt](https://github.com/michaelt) 37 | * [John Wiegley](mailto:johnw@newartisans.com) [@jwiegley](https://github.com/jwiegley) 38 | * [Jonathan Fischoff](mailto:jfischoff@yahoo.com) [@jfischoff](https://github.com/jfischoff) 39 | * [Bradford Larsen](mailto:brad.larsen@gmail.com) [@bradlarsen](https://github.com/bradlarsen) 40 | * [Alex Mason](mailto:axman6@gmail.com) [@Axman6](https://github.com/Axman6) 41 | * [Ryan Scott](mailto:ryan.gl.scott@gmail.com) [@RyanGlScott](https://github.com/RyanGlScott) 42 | 43 | You can watch them carry on the quest for bragging rights in the [contributors graph](https://github.com/ekmett/lens/graphs/contributors). 44 | 45 | Omission from this list is by no means an attempt to discount your contributions! 46 | 47 | Thank you for all of your help! 48 | 49 | -Edward Kmett 50 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2012-2016 Edward Kmett 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 17 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 20 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 22 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 23 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 24 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 25 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 26 | POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /SUPPORT.markdown: -------------------------------------------------------------------------------- 1 | We currently maintain 2 versions of lens: 2 | 3 | We have committed to supporting the 3.7.x branch until GHC 7.8 is released. This version is at 3.7.6 as of the time of this writing. After GHC 7.8 is released we'll continue to 4 | support a version with GHC 7.4 support until the next major GHC release occurs. Practically this means that there should always be some version of lens in a supported configuration 5 | across the last 3 major GHC releases at all times -- counting GHC 7.2 as a technology preview rather than a major release. 6 | 7 | We also have committed to keeping the current version of lens up to date and building as part of [stackage](http://github.com/fpco/stackage). 8 | 9 | --Edward Kmett 10 | Fri Mar 29 16:11:41 EDT 2013 11 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | \begin{code} 2 | module Main (main) where 3 | import Distribution.Simple (defaultMain) 4 | main :: IO () 5 | main = defaultMain 6 | \end{code} 7 | -------------------------------------------------------------------------------- /benchmarks/alongside.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | module Main (main) where 7 | 8 | import Control.Applicative 9 | import Control.Comonad 10 | import Control.Comonad.Store.Class 11 | import Control.Lens.Internal 12 | import Control.Lens 13 | import Criterion.Main 14 | import Data.Functor.Compose 15 | 16 | -- | A finally encoded Store 17 | newtype Experiment a b s = Experiment { runExperiment :: forall f. Functor f => (a -> f b) -> f s } 18 | 19 | instance Functor (Experiment a b) where 20 | fmap f (Experiment k) = Experiment (fmap f . k) 21 | {-# INLINE fmap #-} 22 | 23 | instance (a ~ b) => Comonad (Experiment a b) where 24 | extract (Experiment m) = runIdentity (m Identity) 25 | {-# INLINE extract #-} 26 | duplicate = duplicateExperiment 27 | {-# INLINE duplicate #-} 28 | 29 | -- | 'Experiment' is an indexed 'Comonad'. 30 | duplicateExperiment :: Experiment a c s -> Experiment a b (Experiment b c s) 31 | duplicateExperiment (Experiment m) = getCompose (m (Compose . fmap placebo . placebo)) 32 | {-# INLINE duplicateExperiment #-} 33 | 34 | -- | A trivial 'Experiment'. 35 | placebo :: a -> Experiment a b b 36 | placebo i = Experiment (\k -> k i) 37 | {-# INLINE placebo #-} 38 | 39 | instance (a ~ b) => ComonadStore a (Experiment a b) where 40 | pos m = posExperiment m 41 | peek d m = peekExperiment d m 42 | peeks f m = runIdentity $ runExperiment m (\c -> Identity (f c)) 43 | experiment f m = runExperiment m f 44 | 45 | posExperiment :: Experiment a b s -> a 46 | posExperiment m = getConst (runExperiment m Const) 47 | {-# INLINE posExperiment #-} 48 | 49 | peekExperiment :: b -> Experiment a b s -> s 50 | peekExperiment b m = runIdentity $ runExperiment m (\_ -> Identity b) 51 | {-# INLINE peekExperiment #-} 52 | 53 | trial :: Lens s t a b -> Lens s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b') 54 | trial l r pfq (s,s') = fmap (\(b,t') -> (peekExperiment b x,t')) (getCompose (r (\a' -> Compose $ pfq (posExperiment x, a')) s')) 55 | where x = l placebo s 56 | {-# INLINE trial #-} 57 | 58 | posContext :: Context a b s -> a 59 | posContext (Context _ a) = a 60 | {-# INLINE posContext #-} 61 | 62 | peekContext :: b -> Context a b s -> s 63 | peekContext b (Context f _) = f b 64 | {-# INLINE peekContext #-} 65 | 66 | -- a version of alongside built with Context and product 67 | half :: LensLike (Context a b) s t a b -> Lens s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b') 68 | half l r pfq (s,s') = fmap (\(b,t') -> (peekContext b x,t')) (getCompose (r (\a' -> Compose $ pfq (posContext x, a')) s')) 69 | where x = l (Context id) s 70 | {-# INLINE half #-} 71 | 72 | -- alongside' :: Lens s t a b -> Lens s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b') 73 | -- {-# INLINE alongside'#-} 74 | 75 | compound :: Lens' s a 76 | -> Lens' s' a' 77 | -> Lens' (s,s') (a,a') 78 | compound l r = lens (\(s, s') -> (view l s, view r s')) 79 | (\(s, s') (t, t') -> (set l t s, set r t' s')) 80 | {-# INLINE compound #-} 81 | 82 | compound5 :: Lens' s a 83 | -> Lens' s' a' 84 | -> Lens' s'' a'' 85 | -> Lens' s''' a''' 86 | -> Lens' s'''' a'''' 87 | -> Lens' (s, (s', (s'', (s''', s'''')))) 88 | (a, (a', (a'', (a''', a'''')))) 89 | compound5 l l' l'' l''' l'''' 90 | = lens (\(s, (s', (s'', (s''', s'''')))) 91 | -> (view l s, (view l' s', (view l'' s'', (view l''' s''', view l'''' s'''')))) ) 92 | (\(s, (s', (s'', (s''', s'''')))) (t, (t', (t'', (t''', t'''')))) 93 | -> (set l t s, (set l' t' s', (set l'' t'' s'', (set l''' t''' s''', set l'''' t'''' s'''')))) ) 94 | 95 | main :: IO () 96 | main = defaultMain 97 | [ bench "alongside1" $ nf (view $ alongside _1 _2) (("hi", v), (w, "there!")) 98 | , bench "trial1" $ nf (view $ trial _1 _2) (("hi", v), (w, "there!")) 99 | , bench "half1" $ nf (view $ half _1 _2) (("hi", v), (w, "there!")) 100 | , bench "compound1" $ nf (view $ compound _1 _2) (("hi", v), (w, "there!")) 101 | , bench "alongside5" $ nf (view $ (alongside _1 (alongside _1 (alongside _1 (alongside _1 _1))))) 102 | ((v,v),((v,v),((v,v),((v,v),(v,v))))) 103 | , bench "trial5" $ nf (view $ (trial _1 (trial _1 (trial _1 (trial _1 _1))))) 104 | ((v,v),((v,v),((v,v),((v,v),(v,v))))) 105 | , bench "half5" $ nf (view $ (half _1 (half _1 (half _1 (half _1 _1))))) 106 | ((v,v),((v,v),((v,v),((v,v),(v,v))))) 107 | , bench "compound5" $ nf (view $ compound5 _1 _1 _1 _1 _1) 108 | ((v,v),((v,v),((v,v),((v,v),(v,v))))) 109 | ] 110 | where v = 1 :: Int 111 | w = 2 :: Int 112 | -------------------------------------------------------------------------------- /benchmarks/folds.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE BangPatterns #-} 5 | module Main (main) where 6 | 7 | import qualified Data.ByteString as BS 8 | import qualified Data.Foldable as F 9 | import qualified Data.HashMap.Lazy as HM 10 | import qualified Data.Map as M 11 | import qualified Data.Sequence as S 12 | import qualified Data.Vector as V 13 | import qualified Data.Vector.Unboxed as U 14 | 15 | import Data.Vector.Generic.Lens 16 | import Data.ByteString.Lens 17 | 18 | import Control.Lens 19 | import Criterion.Main 20 | import Criterion.Types 21 | 22 | main :: IO () 23 | main = defaultMainWith config 24 | [ 25 | bgroup "vector" 26 | [ bgroup "toList" 27 | [ bench "native" $ nf V.toList v 28 | , bench "each" $ nf (toListOf each) v 29 | ] 30 | , bgroup "itoList" 31 | [ bench "native" $ nf (V.toList . V.indexed) v 32 | , bench "itraversed" $ nf (itoListOf itraversed) v 33 | ] 34 | , bgroup "sum" 35 | [ bench "native" $ whnf V.sum v 36 | , bench "each" $ whnf (sumOf each) v 37 | ] 38 | ] 39 | , bgroup "unboxed-vector" 40 | [ bgroup "toList" 41 | [ bench "native" $ nf U.toList u 42 | , bench "each" $ nf (toListOf each) u 43 | ] 44 | , bgroup "itoList" 45 | [ bench "native" $ nf (U.toList . U.indexed) u 46 | , bench "vTraverse" $ nf (itoListOf vectorTraverse) u 47 | ] 48 | , bgroup "sum" 49 | [ bench "native" $ whnf U.sum u 50 | , bench "each" $ whnf (sumOf each) u 51 | ] 52 | ] 53 | , bgroup "sequence" 54 | [ bgroup "toList" 55 | [ bench "native" $ nf F.toList s 56 | , bench "each" $ nf (toListOf each) s 57 | ] 58 | , bgroup "itoList" 59 | [ bench "native" $ nf (F.toList . S.mapWithIndex (,)) s 60 | , bench "itraversed" $ nf (itoListOf itraversed) s 61 | ] 62 | ] 63 | , bgroup "bytestring" 64 | [ bgroup "toList" 65 | [ bench "native" $ nf BS.unpack b 66 | , bench "bytes" $ nf (toListOf bytes) b 67 | , bench "each" $ nf (toListOf each) b 68 | ] 69 | , bgroup "itoList" 70 | [ bench "native" $ nf (zip [(0::Int)..] . BS.unpack) b 71 | , bench "bytes" $ nf (itoListOf bytes) b 72 | ] 73 | ] 74 | , bgroup "list" 75 | [ bgroup "toList" 76 | [ bench "native" $ nf F.toList l 77 | , bench "each" $ nf (toListOf each) l 78 | ] 79 | , bgroup "itoList" 80 | [ bench "native" $ nf (zip [(0::Int)..]) l 81 | , bench "itraversed" $ nf (itoListOf itraversed) l 82 | ] 83 | , bgroup "sum" 84 | [ bench "native" $ whnf sum l 85 | , bench "each" $ whnf (sumOf each) l 86 | ] 87 | ] 88 | , bgroup "map" 89 | [ bgroup "toList" 90 | [ bench "native" $ nf F.toList m 91 | , bench "each" $ nf itoList m 92 | ] 93 | , bgroup "itoList" 94 | [ bench "native" $ nf (zip [(0::Int)..] . F.toList) m 95 | , bench "itraversed" $ nf (itoListOf itraversed) m 96 | ] 97 | ] 98 | , bgroup "hash map" 99 | [ bgroup "toList" 100 | [ bench "native" $ nf HM.keys h 101 | , bench "each" $ nf (toListOf each) h 102 | ] 103 | , bgroup "itoList" 104 | [ bench "native" $ nf HM.toList h 105 | , bench "itoList" $ nf itoList h 106 | , bench "itraversed" $ nf (itoListOf itraversed) h 107 | ] 108 | , bgroup "sum" 109 | [ bench "native" $ nf (sum . id . F.toList) h 110 | , bench "each" $ nf (sumOf each) h 111 | ] 112 | ] 113 | ] 114 | where 115 | config = defaultConfig { timeLimit = 1 } 116 | l = [0..10000] :: [Int] 117 | b = BS.pack $ map fromIntegral l 118 | h = HM.fromList $ zip l l 119 | m = M.fromList $ zip l l 120 | s = S.fromList l 121 | u = U.fromList l 122 | v = V.fromList l 123 | 124 | -------------------------------------------------------------------------------- /benchmarks/traversals.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | {-# LANGUAGE BangPatterns #-} 6 | {-# OPTIONS_GHC -Wno-orphans #-} 7 | module Main (main) where 8 | 9 | import qualified Data.ByteString as BS 10 | import qualified Data.HashMap.Strict as HM 11 | import qualified Data.Map as M 12 | import qualified Data.Sequence as S 13 | import qualified Data.Vector as V 14 | import qualified Data.Vector.Unboxed as U 15 | 16 | import Data.Vector.Generic.Lens 17 | import Data.ByteString.Lens 18 | 19 | import Control.Lens 20 | import Criterion.Main 21 | import Criterion.Types 22 | 23 | main :: IO () 24 | main = defaultMainWith config 25 | [ 26 | bgroup "vector" 27 | [ bgroup "map" 28 | [ bench "native" $ nf (V.map (+100)) v 29 | , bench "itraversed" $ nf (over itraversed (+100)) v 30 | ] 31 | , bgroup "imap" 32 | [ bench "native" $ nf (V.imap (\i x -> x + i +100)) v 33 | , bench "imap" $ nf (imap (\i x -> x + i +100)) v 34 | , bench "itraversed" $ nf (iover itraversed (\i x -> x + i +100)) v 35 | ] 36 | ] 37 | , bgroup "unboxed-vector" 38 | [ bgroup "map" 39 | [ bench "native" $ nf (U.map (+100)) u 40 | , bench "itraversed" $ nf (over each (+100)) u 41 | ] 42 | , bgroup "imap" 43 | [ bench "native" $ nf (U.imap (\i x -> x + i +100)) u 44 | , bench "itraversed" $ nf (iover vectorTraverse (\i x -> x + i) :: U.Vector Int -> U.Vector Int) u 45 | ] 46 | ] 47 | , bgroup "sequence" 48 | [ bgroup "map" 49 | [ bench "native" $ nf (fmap (+100)) s 50 | , bench "each" $ nf (over each (+100)) s 51 | ] 52 | , bgroup "imap" 53 | [ bench "native" $ nf (S.mapWithIndex (\i x -> x + i +100)) s 54 | , bench "imap" $ nf (imap (\i x -> x + i +100)) s 55 | ] 56 | ] 57 | , bgroup "bytestring" 58 | [ bgroup "map" 59 | [ bench "native" $ nf (BS.map (+100)) b 60 | , bench "each" $ nf (over each (+100)) b 61 | ] 62 | , bgroup "imap" 63 | [ 64 | bench "bytes" $ nf (iover bytes (\i x -> x + fromIntegral i +100)) b 65 | ] 66 | ] 67 | , bgroup "list" 68 | [ bgroup "map" 69 | [ bench "native" $ nf (map (+100)) l 70 | , bench "each" $ nf (over each (+100)) l 71 | ] 72 | , bgroup "imap" 73 | [ bench "imap" $ nf (imap (\i x -> x + i +100)) l 74 | ] 75 | ] 76 | , bgroup "map" 77 | [ bgroup "map" 78 | [ bench "native" $ nf (fmap (+100)) m 79 | , bench "each" $ nf (over each (+100)) m 80 | , bench "itraversed" $ nf (over itraversed (+100)) m 81 | ] 82 | , bgroup "imap" 83 | [ bench "native" $ nf (M.mapWithKey (\i x -> x + i +100)) m 84 | , bench "each" $ nf (imap (\i x -> x + i +100)) m 85 | ] 86 | ] 87 | , bgroup "hash map" 88 | [ bgroup "map" 89 | [ bench "native" $ nf (HM.map (+100)) h 90 | , bench "each" $ nf (over each (+100)) h 91 | ] 92 | , bgroup "imap" 93 | [ bench "native" $ nf (HM.mapWithKey (\i x -> x + i +100)) h 94 | , bench "imap" $ nf (imap (\i x -> x + i +100)) h 95 | ] 96 | ] 97 | ] 98 | where 99 | config = defaultConfig { timeLimit = 1 } 100 | l = [0..10000] :: [Int] 101 | xl = [0..100000] :: [Int] 102 | b = BS.pack $ map fromIntegral xl 103 | h = HM.fromList $ zip l l 104 | m = M.fromList $ zip l l 105 | s = S.fromList l 106 | u = U.fromList xl 107 | v = V.fromList l 108 | -------------------------------------------------------------------------------- /benchmarks/unsafe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | module Main (main) where 3 | 4 | import Control.Lens 5 | 6 | import Criterion.Main 7 | import Criterion.Types (Config(..)) 8 | 9 | overS :: ASetter s t a b -> (a -> b) -> s -> t 10 | overS l f = runIdentity . l (Identity . f) 11 | {-# INLINE overS #-} 12 | 13 | mappedS :: ASetter [a] [b] a b 14 | mappedS f = Identity . map (runIdentity . f) 15 | {-# INLINE mappedS #-} 16 | 17 | overU :: ASetter s t a b -> (a -> b) -> s -> t 18 | overU = over 19 | {-# INLINE overU #-} 20 | 21 | mappedU :: ASetter [a] [b] a b 22 | mappedU = mapped 23 | {-# INLINE mappedU #-} 24 | 25 | 26 | -- Need to eta-expand for full inlining in the NOINLINE cases? 27 | -- Doesn't seem to make a difference, though. 28 | 29 | mapSN :: (a -> b) -> [a] -> [b] 30 | mapSN f l = overS mappedS f l 31 | {-# NOINLINE mapSN #-} 32 | 33 | mapSI :: (a -> b) -> [a] -> [b] 34 | mapSI f = overS mappedS f 35 | {-# INLINE mapSI #-} 36 | 37 | mapUN :: (a -> b) -> [a] -> [b] 38 | mapUN f l = overU mappedU f l 39 | {-# NOINLINE mapUN #-} 40 | 41 | mapUI :: (a -> b) -> [a] -> [b] 42 | mapUI f = overU mappedU f 43 | {-# INLINE mapUI #-} 44 | 45 | main :: IO () 46 | main = do 47 | let n = 1000 48 | l = replicate n "hi"; f = length 49 | --l = replicate n (); f = (\ _ -> ()) 50 | --l = replicate n (); f = (\ !_ -> ()) -- strange results 51 | --l = replicate n (); f = lazy (\_ -> ()) 52 | defaultMainWith config 53 | [ bench "map safe noinline" $ nf (mapSN f) l 54 | , bench "map safe inline" $ nf (mapSI f) l 55 | , bench "map unsafe noinline" $ nf (mapUN f) l 56 | , bench "map unsafe inline" $ nf (mapUI f) l 57 | ] 58 | where 59 | config = defaultConfig { resamples = 1000 } 60 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | distribution: jammy 2 | no-tests-no-benchmarks: False 3 | unconstrained: False 4 | apt: freeglut3-dev 5 | -- irc-channels: irc.freenode.org#haskell-lens 6 | irc-if-in-origin-repo: True 7 | docspec: True 8 | -- We make heavy use of type namespace markers in the Haddocks (e.g., t'Lens') 9 | -- to work around https://github.com/haskell/haddock/issues/1608. These markers 10 | -- were first introduced in Haddock 2.23, bundled with GHC 8.8. Because old 11 | -- versions of Haddock do not gracefully handle these markers, we simply do not 12 | -- build the Haddocks on CI unless we are using GHC 8.8 or later. 13 | haddock: >=8.8 14 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | ./examples 3 | ./lens-properties 4 | -------------------------------------------------------------------------------- /examples/.hlint.yaml: -------------------------------------------------------------------------------- 1 | - arguments: [--cpp-ansi] 2 | 3 | - fixity: "infixr 9 ..." 4 | - fixity: "infixl 1 &~" 5 | -------------------------------------------------------------------------------- /examples/Aeson.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | -- | 4 | -- This is a small example of how to construct a projection for a third-party library like 5 | -- @aeson@. 6 | -- 7 | -- To test this: 8 | -- 9 | -- > doctest Aeson.hs 10 | module Aeson where 11 | 12 | import Control.Lens 13 | import Data.Aeson 14 | import Data.ByteString.Lazy (ByteString) 15 | 16 | -- $setup 17 | -- >>> import Control.Lens 18 | 19 | -- | 20 | -- >>> review aeson 5 21 | -- "5" 22 | -- >>> [1,2,3]^.re aeson 23 | -- "[1,2,3]" 24 | -- >>> let intPair = simple :: Iso' (Int,Int) (Int, Int) 25 | -- >>> aeson.intPair.both +~ 2 $ (2,3)^.re aeson 26 | -- "[4,5]" 27 | aeson, aeson' :: (FromJSON a, ToJSON a) => Prism' ByteString a 28 | aeson = prism' encode decode 29 | aeson' = prism' encode decode' 30 | -------------------------------------------------------------------------------- /examples/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2012 Edward Kmett 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the author nor the names of his contributors 17 | may be used to endorse or promote products derived from this software 18 | without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 21 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 24 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 26 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 27 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 28 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 29 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30 | POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /examples/Plates.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, DeriveGeneric, DeriveDataTypeable #-} 2 | module Plates where 3 | 4 | import Control.Lens 5 | import GHC.Generics 6 | import Data.Data 7 | 8 | data Expr = Var Int | Pos Expr String | Neg Expr | Add Expr Expr deriving (Eq,Ord,Show,Read,Generic,Data) 9 | data Stmt = Seq [Stmt] | Sel [Expr] | Let String Expr deriving (Eq,Ord,Show,Read,Generic,Data) 10 | 11 | instance Plated Expr where 12 | plate _ (Var x ) = pure (Var x) 13 | plate f (Pos x y) = Pos <$> f x <*> pure y 14 | plate f (Neg x ) = Neg <$> f x 15 | plate f (Add x y) = Add <$> f x <*> f y 16 | 17 | instance Plated Stmt where 18 | plate f (Seq xs) = Seq <$> traverse f xs 19 | plate _ (Sel xs) = pure (Sel xs) 20 | plate _ (Let x y) = pure (Let x y) 21 | 22 | exprs :: Traversal' Stmt Expr 23 | exprs f (Seq xs) = Seq <$> traverse (exprs f) xs 24 | exprs f (Sel xs) = Sel <$> traverse f xs 25 | exprs f (Let x y) = Let x <$> f y 26 | -------------------------------------------------------------------------------- /examples/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/runhaskell 2 | > module Main (main) where 3 | 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /examples/Turtle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | -- | A simple Turtle-graphics demonstration for modeling the location of a turtle. 4 | -- 5 | -- This is based on the code presented by Seth Tisue at the Boston Area Scala 6 | -- Enthusiasts meeting during his lens talk. 7 | -- 8 | -- Usage: 9 | -- 10 | -- > def & forward 10 & down & color .~ red % turn (pi/2) & forward 5 11 | module Turtle where 12 | 13 | import Control.Lens 14 | import Data.Default.Class 15 | 16 | data Point = Point 17 | { __x, __y :: Double 18 | } deriving (Eq,Show) 19 | 20 | makeClassy ''Point 21 | 22 | instance Default Point where 23 | def = Point def def 24 | 25 | data Color = Color 26 | { __r, __g, __b :: Int 27 | } deriving (Eq,Show) 28 | 29 | makeClassy ''Color 30 | 31 | red :: Color 32 | red = Color 255 0 0 33 | 34 | instance Default Color where 35 | def = Color def def def 36 | 37 | data Turtle = Turtle 38 | { _tPoint :: Point 39 | , _tColor :: Color 40 | , _heading :: Double 41 | , _penDown :: Bool 42 | } deriving (Eq,Show) 43 | 44 | makeClassy ''Turtle 45 | 46 | instance Default Turtle where 47 | def = Turtle def def def False 48 | 49 | instance HasPoint Turtle where 50 | point = tPoint 51 | 52 | instance HasColor Turtle where 53 | color = tColor 54 | 55 | forward :: Double -> Turtle -> Turtle 56 | forward d t = 57 | t & _y +~ d * cos (t^.heading) 58 | & _x +~ d * sin (t^.heading) 59 | 60 | turn :: Double -> Turtle -> Turtle 61 | turn d = heading +~ d 62 | 63 | up, down :: Turtle -> Turtle 64 | up = penDown .~ False 65 | down = penDown .~ True 66 | -------------------------------------------------------------------------------- /examples/lens-examples.cabal: -------------------------------------------------------------------------------- 1 | name: lens-examples 2 | category: Data, Lenses 3 | version: 0.1 4 | license: BSD3 5 | cabal-version: >= 1.10 6 | license-file: LICENSE 7 | author: Niklas Haas 8 | maintainer: Edward A. Kmett 9 | stability: provisional 10 | homepage: http://github.com/ekmett/lens/ 11 | bug-reports: http://github.com/ekmett/lens/issues 12 | copyright: Copyright (C) 2012 Edward A. Kmett 13 | synopsis: Lenses, Folds and Traversals 14 | description: Lenses, Folds and Traversals 15 | . 16 | Pong Example 17 | 18 | build-type: Simple 19 | tested-with: GHC == 8.0.2 20 | , GHC == 8.2.2 21 | , GHC == 8.4.4 22 | , GHC == 8.6.5 23 | , GHC == 8.8.4 24 | , GHC == 8.10.7 25 | , GHC == 9.0.2 26 | , GHC == 9.2.8 27 | , GHC == 9.4.8 28 | , GHC == 9.6.6 29 | , GHC == 9.8.4 30 | , GHC == 9.10.1 31 | , GHC == 9.12.1 32 | 33 | source-repository head 34 | type: git 35 | location: https://github.com/ekmett/lens.git 36 | 37 | flag pong 38 | default: True 39 | 40 | library 41 | exposed-modules: 42 | Aeson 43 | Plates 44 | Turtle 45 | build-depends: 46 | aeson, 47 | base >= 4.5 && < 5, 48 | bytestring >= 0.9.1.10 && < 0.13, 49 | data-default-class, 50 | ghc-prim, 51 | lens 52 | default-language: Haskell2010 53 | ghc-options: -Wall 54 | 55 | executable lens-pong 56 | if !flag(pong) 57 | buildable: False 58 | 59 | build-depends: 60 | base >= 4.5 && < 5, 61 | containers >= 0.4 && < 0.9, 62 | gloss >= 1.12 && < 1.14, 63 | lens, 64 | mtl >= 2.0.1 && < 2.4, 65 | random >= 1.0 && < 1.4, 66 | streams >= 3.3 && < 4 67 | main-is: Pong.hs 68 | default-language: Haskell2010 69 | ghc-options: -Wall 70 | -------------------------------------------------------------------------------- /experimental/Control/Lens/Format.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | #ifdef TRUSTWORTHY 7 | {-# LANGUAGE Trustworthy #-} 8 | #endif 9 | 10 | ----------------------------------------------------------------------------- 11 | -- | 12 | -- Module : Control.Lens.Format 13 | -- Copyright : (C) 2012 Edward Kmett 14 | -- License : BSD-style (see the file LICENSE) 15 | -- Maintainer : Edward Kmett 16 | -- Stability : experimental 17 | -- Portability : non-portable 18 | -- 19 | ---------------------------------------------------------------------------- 20 | module Control.Lens.Format 21 | ( 22 | -- * Formats 23 | Format 24 | , Formatting, Formatting' 25 | -- * Composable Formats 26 | , format 27 | , now 28 | , later 29 | , say 30 | -- * Implementation Details 31 | , Formattable(..) 32 | , Formatted(..) 33 | ) where 34 | 35 | import Control.Applicative 36 | import Control.Lens 37 | import Control.Lens.Internal 38 | import Control.Monad.Writer 39 | import Data.Distributive 40 | import Data.Monoid 41 | import Data.Profunctor.Unsafe 42 | import Data.Profunctor.Rep 43 | import Data.Coerce 44 | 45 | ------------------------------------------------------------------------------ 46 | -- Formattable 47 | ------------------------------------------------------------------------------ 48 | 49 | class Profunctor p => Formattable m p where 50 | formatted :: p a b -> p a (m -> b) 51 | 52 | instance Formattable m (->) where 53 | formatted ab a _ = ab a 54 | {-# INLINE formatted #-} 55 | 56 | instance (m ~ n, Monoid n) => Formattable n (Indexed m) where 57 | formatted (Indexed mab) = Indexed (\m a n -> mab (mappend m n) a) 58 | {-# INLINE formatted #-} 59 | 60 | ------------------------------------------------------------------------------ 61 | -- Reviewable 62 | ------------------------------------------------------------------------------ 63 | 64 | newtype Formatted m a b = Formatted { runFormatted :: m -> b } 65 | 66 | instance (m ~ n, Monoid n) => Formattable n (Formatted m) where 67 | formatted (Formatted mb) = Formatted (\m n -> mb (mappend m n)) 68 | {-# INLINE formatted #-} 69 | 70 | instance Reviewable (Formatted m) where 71 | retagged (Formatted m) = Formatted m 72 | 73 | instance Profunctor (Formatted m) where 74 | lmap _ (Formatted mb) = Formatted mb 75 | rmap bc (Formatted mb) = Formatted (bc . mb) 76 | Formatted mb .# _ = Formatted mb 77 | (#.) _ = coerce 78 | 79 | instance Corepresentable (Formatted m) where 80 | type Corep (Formatted m) = Const m 81 | cotabulate f = Formatted (f .# Const) 82 | corep (Formatted k) = k .# getConst 83 | 84 | instance Prismatic (Formatted m) where 85 | prismatic (Formatted k) = Formatted k 86 | 87 | ------------------------------------------------------------------------------ 88 | -- Formats 89 | ------------------------------------------------------------------------------ 90 | 91 | type Format m t b = forall p f. (Reviewable p, Formattable m p, Settable f) => Overloaded' p f t b 92 | 93 | type Formatting m n s t a b = Overloading (Formatted m) (Formatted n) Mutator s t a b 94 | 95 | type Formatting' m n t b = Formatting m n t t b b 96 | 97 | ------------------------------------------------------------------------------ 98 | -- Formattable 99 | ------------------------------------------------------------------------------ 100 | 101 | -- later :: (x -> m) -> (m -> b) -> m -> x -> b 102 | later :: (Formattable m p, Reviewable p, Distributive f) => (x -> m) -> Overloaded' p f (x -> b) b 103 | later f = unto (. f) . rmap distribute . formatted 104 | 105 | -- Monoid m => ((b -> b) -> m -> t) -> t 106 | format :: Monoid m => Formatting b m s t a b -> t 107 | format l = (runMutator #. runFormatted (l (Formatted Mutator))) mempty 108 | 109 | say :: (MonadWriter u m, Monoid v) => Formatting u v s t a (m ()) -> t 110 | say l = (runMutator #. runFormatted (l (Formatted (Mutator #. tell)))) mempty 111 | 112 | -- now :: m -> (m -> b) -> m -> b 113 | now :: Formattable m p => m -> Overloaded p f a b a b 114 | now m = rmap ($ m) . formatted 115 | 116 | {- 117 | lighter :: (Formattable m p, Reviewable p, Distributive f) => ((m -> b) -> t) -> Overloaded' p f t b 118 | lighter f = unto f . rmap distribute . formatted 119 | 120 | resume :: Formatting b m s t a b -> m -> t 121 | resume l = runMutator #. runFormatted (l (Formatted Mutator)) 122 | 123 | rip :: Monoid m => Overloading (Indexed n) (Indexed m) f s t a b -> (n -> a -> f b) -> s -> f t 124 | rip l f = runIndexed (l (Indexed f)) mempty 125 | 126 | rumble :: Monoid i => (Indexed j s (Mutator t) -> Indexed i a (Mutator b)) -> (j -> s -> t) -> a -> b 127 | rumble l f = runMutator #. runIndexed (l (Indexed (\i -> Mutator #. f i))) mempty 128 | 129 | litter :: (Formattable m p, Distributive f) => (x -> m) -> Overloaded p f a (x -> y) a y 130 | litter f = rmap (cotraverse (. f)) . formatted 131 | 132 | jcompose :: (Indexable i q, Indexable k p) => (i -> j -> k) -> (Indexed j s t -> q a b) -> p s t -> Indexed i a b 133 | jcompose ijk jab2ist kab = Indexed $ \i -> indexed (jab2ist (Indexed $ \j -> indexed kab (ijk i j))) i 134 | -} 135 | -------------------------------------------------------------------------------- /experimental/Data/Text/Encoding/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #ifdef TRUSTWORTHY 3 | {-# LANGUAGE Trustworthy #-} 4 | #endif 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Data.Text.Lens.Encoding 8 | -- Copyright : (C) 2013 Michael Thompson 9 | -- License : BSD-style (see the file LICENSE) 10 | -- Maintainer : Edward Kmett 11 | -- Stability : experimental 12 | -- Portability : non-portable 13 | -- 14 | ---------------------------------------------------------------------------- 15 | 16 | module Data.Text.Encoding.Lens where 17 | 18 | import Control.Lens 19 | import Data.ByteString 20 | import Data.Text 21 | import Data.Text.Encoding as T 22 | 23 | utf8 :: Iso' Text ByteString 24 | utf8 = iso encodeUtf8 decodeUtf8 25 | {-#INLINE utf8#-} 26 | 27 | utf16LE :: Iso' Text ByteString 28 | utf16LE = iso encodeUtf16LE decodeUtf16LE 29 | {-#INLINE utf16LE#-} 30 | 31 | utf16BE :: Iso' Text ByteString 32 | utf16BE = iso encodeUtf16BE decodeUtf16BE 33 | {-#INLINE utf16BE#-} 34 | 35 | utf32LE :: Iso' Text ByteString 36 | utf32LE = iso encodeUtf32LE decodeUtf32LE 37 | {-#INLINE utf32LE#-} 38 | 39 | utf32BE :: Iso' Text ByteString 40 | utf32BE = iso encodeUtf32BE decodeUtf32BE 41 | {-#INLINE utf32BE#-} 42 | -------------------------------------------------------------------------------- /images/Hierarchy.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ekmett/lens/b44bdc6c7eca95cb111782075e4534c2c5098737/images/Hierarchy.png -------------------------------------------------------------------------------- /images/overview.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ekmett/lens/b44bdc6c7eca95cb111782075e4534c2c5098737/images/overview.png -------------------------------------------------------------------------------- /include/lens-common.h: -------------------------------------------------------------------------------- 1 | #ifndef LENS_COMMON_H 2 | #define LENS_COMMON_H 3 | 4 | #if __GLASGOW_HASKELL__ >= 806 5 | # define KVS(kvs) kvs 6 | #else 7 | # define KVS(kvs) 8 | #endif 9 | 10 | #ifndef MIN_VERSION_base 11 | #define MIN_VERSION_base(x,y,z) 1 12 | #endif 13 | 14 | #ifndef MIN_VERSION_bytestring 15 | #define MIN_VERSION_bytestring(x,y,z) 1 16 | #endif 17 | 18 | #ifndef MIN_VERSION_containers 19 | #define MIN_VERSION_containers(x,y,z) 1 20 | #endif 21 | 22 | #ifndef MIN_VERSION_template_haskell 23 | #define MIN_VERSION_template_haskell(x,y,z) 1 24 | #endif 25 | 26 | #endif 27 | -------------------------------------------------------------------------------- /lens-properties/.hlint.yaml: -------------------------------------------------------------------------------- 1 | - arguments: [--cpp-ansi] 2 | - ignore: { name: Use camelCase } 3 | - fixity: "infixr 9 ..." 4 | - fixity: "infixl 1 &~" 5 | -------------------------------------------------------------------------------- /lens-properties/CHANGELOG.markdown: -------------------------------------------------------------------------------- 1 | next [????.??.??] 2 | ----------------- 3 | * Drop support for GHC 7.10 and older. 4 | 5 | 4.11.1 6 | ------ 7 | * Update version bounds. 8 | 9 | 4.0 10 | --- 11 | 12 | * Initial release containing the properties: 13 | * `isIso` 14 | * `isLens` 15 | * `isPrism` 16 | * `isSetter` 17 | * `isTraversal` 18 | -------------------------------------------------------------------------------- /lens-properties/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012-2014, Edward Kmett 2 | Copyright (c) 2014, Oliver Charles 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above 13 | copyright notice, this list of conditions and the following 14 | disclaimer in the documentation and/or other materials provided 15 | with the distribution. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 18 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 19 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 20 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 21 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 22 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 23 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 24 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 25 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 26 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /lens-properties/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /lens-properties/lens-properties.cabal: -------------------------------------------------------------------------------- 1 | name: lens-properties 2 | category: Data, Lenses 3 | version: 4.11.1 4 | license: BSD3 5 | cabal-version: >= 1.10 6 | license-file: LICENSE 7 | author: Edward Kmett and Oliver Charles 8 | maintainer: Edward Kmett 9 | stability: provisional 10 | homepage: http://github.com/ekmett/lens/ 11 | bug-reports: http://github.com/ekmett/lens/issues 12 | copyright: Copyright (C) 2012-2015 Edward A. Kmett, Copyright (C) 2014 Oliver Charles 13 | synopsis: QuickCheck properties for lens 14 | description: QuickCheck properties for lens. 15 | build-type: Simple 16 | tested-with: GHC == 8.0.2 17 | , GHC == 8.2.2 18 | , GHC == 8.4.4 19 | , GHC == 8.6.5 20 | , GHC == 8.8.4 21 | , GHC == 8.10.7 22 | , GHC == 9.0.2 23 | , GHC == 9.2.8 24 | , GHC == 9.4.8 25 | , GHC == 9.6.6 26 | , GHC == 9.8.4 27 | , GHC == 9.10.1 28 | , GHC == 9.12.1 29 | 30 | extra-source-files: 31 | .hlint.yaml 32 | CHANGELOG.markdown 33 | 34 | source-repository head 35 | type: git 36 | location: https://github.com/ekmett/lens.git 37 | 38 | library 39 | build-depends: 40 | base >= 4.9 && < 5, 41 | lens >= 4 && < 6, 42 | QuickCheck >= 2.4 && < 2.16, 43 | transformers >= 0.2 && < 0.7 44 | 45 | exposed-modules: 46 | Control.Lens.Properties 47 | 48 | hs-source-dirs: src 49 | ghc-options: -Wall 50 | default-language: Haskell2010 51 | -------------------------------------------------------------------------------- /lens-properties/src/Control/Lens/Properties.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | {-# LANGUAGE LiberalTypeSynonyms #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | -- | A collection of properties that can be tested with QuickCheck, to guarantee 5 | -- that you are working with valid 'Lens'es, 'Setter's, 'Traversal's, 'Iso's and 6 | -- 'Prism's. 7 | module Control.Lens.Properties 8 | ( isLens 9 | , isTraversal 10 | , isSetter 11 | , isIso 12 | , isPrism 13 | ) where 14 | 15 | import Control.Lens 16 | import Data.Functor.Compose 17 | import Test.QuickCheck 18 | 19 | -------------------------------------------------------------------------------- 20 | -- | A 'Setter' is only legal if the following 3 laws hold: 21 | -- 22 | -- 1. @set l y (set l x a) ≡ set l y a@ 23 | -- 24 | -- 2. @over l id ≡ id@ 25 | -- 26 | -- 3. @over l f . over l g ≡ over l (f . g)@ 27 | isSetter :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Function a) 28 | => Setter' s a -> Property 29 | isSetter l = setter_id l .&. setter_composition l .&. setter_set_set l 30 | 31 | 32 | -------------------------------------------------------------------------------- 33 | -- | A 'Traversal' is only legal if it is a valid 'Setter' (see 'isSetter' for 34 | -- what makes a 'Setter' valid), and the following laws hold: 35 | -- 36 | -- 1. @t pure ≡ pure@ 37 | -- 38 | -- 2. @fmap (t f) . t g ≡ getCompose . t (Compose . fmap f . g)@ 39 | isTraversal :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Function a) 40 | => Traversal' s a -> Property 41 | isTraversal l = isSetter l .&. traverse_pureMaybe l .&. traverse_pureList l 42 | .&. do as <- arbitrary 43 | bs <- arbitrary 44 | t <- arbitrary 45 | return $ traverse_compose l (\x -> as++[x]++bs) 46 | (\x -> if t then Just x else Nothing) 47 | 48 | 49 | -------------------------------------------------------------------------------- 50 | -- | A 'Lens' is only legal if it is a valid 'Traversal' (see 'isTraversal' for 51 | -- what this means), and if the following laws hold: 52 | -- 53 | -- 1. @view l (set l b a) ≡ b@ 54 | -- 55 | -- 2. @set l (view l a) a ≡ a@ 56 | -- 57 | -- 3. @set l c (set l b a) ≡ set l c a@ 58 | isLens :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function a) 59 | => Lens' s a -> Property 60 | isLens l = lens_set_view l .&. lens_view_set l .&. isTraversal l 61 | 62 | 63 | -------------------------------------------------------------------------------- 64 | isIso :: (Arbitrary s, Arbitrary a, CoArbitrary s, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function s, Function a) 65 | => Iso' s a -> Property 66 | isIso l = iso_hither l .&. iso_yon l .&. isLens l .&. isLens (from l) 67 | 68 | 69 | -------------------------------------------------------------------------------- 70 | isPrism :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function a) 71 | => Prism' s a -> Property 72 | isPrism l = isTraversal l .&. prism_yin l .&. prism_yang l 73 | 74 | 75 | -------------------------------------------------------------------------------- 76 | -- The first setter law: 77 | setter_id :: Eq s => Setter' s a -> s -> Bool 78 | setter_id l s = over l id s == s 79 | 80 | -- The second setter law: 81 | setter_composition :: Eq s => Setter' s a -> s -> Fun a a -> Fun a a -> Bool 82 | setter_composition l s (Fun _ f) (Fun _ g) = over l f (over l g s) == over l (f . g) s 83 | 84 | lens_set_view :: Eq s => Lens' s a -> s -> Bool 85 | lens_set_view l s = set l (view l s) s == s 86 | 87 | lens_view_set :: Eq a => Lens' s a -> s -> a -> Bool 88 | lens_view_set l s a = view l (set l a s) == a 89 | 90 | setter_set_set :: Eq s => Setter' s a -> s -> a -> a -> Bool 91 | setter_set_set l s a b = set l b (set l a s) == set l b s 92 | 93 | iso_hither :: Eq s => AnIso' s a -> s -> Bool 94 | iso_hither l s = s ^.cloneIso l.from l == s 95 | 96 | iso_yon :: Eq a => AnIso' s a -> a -> Bool 97 | iso_yon l a = a^.from l.cloneIso l == a 98 | 99 | prism_yin :: Eq a => Prism' s a -> a -> Bool 100 | prism_yin l a = preview l (review l a) == Just a 101 | 102 | prism_yang :: Eq s => Prism' s a -> s -> Bool 103 | prism_yang l s = maybe s (review l) (preview l s) == s 104 | 105 | traverse_pure :: forall f s a. (Applicative f, Eq (f s)) => LensLike' f s a -> s -> Bool 106 | traverse_pure l s = l pure s == (pure s :: f s) 107 | 108 | traverse_pureMaybe :: Eq s => LensLike' Maybe s a -> s -> Bool 109 | traverse_pureMaybe = traverse_pure 110 | 111 | traverse_pureList :: Eq s => LensLike' [] s a -> s -> Bool 112 | traverse_pureList = traverse_pure 113 | 114 | traverse_compose :: (Applicative f, Applicative g, Eq (f (g s))) 115 | => Traversal' s a -> (a -> g a) -> (a -> f a) -> s -> Bool 116 | traverse_compose t f g s = (fmap (t f) . t g) s == (getCompose . t (Compose . fmap f . g)) s 117 | -------------------------------------------------------------------------------- /scripts/DocTypes.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | 4 | import Text.Parsec 5 | import Data.Char 6 | import Control.Applicative ((<*)) 7 | import Control.Monad (guard) 8 | import Control.Lens 9 | import Data.Maybe 10 | import Data.Traversable 11 | import Data.Foldable 12 | import Data.List (isInfixOf, dropWhileEnd) 13 | import System.Environment 14 | import Language.Haskell.Exts 15 | import System.Process 16 | import Prelude hiding (concatMap, mapM, mapM_, concat, elem, notElem) 17 | import Debug.Trace 18 | 19 | imports = 20 | [ "Control.Applicative" 21 | , "Control.Applicative.Backwards (Backwards)" 22 | , "Control.Exception" 23 | , "Data.Typeable (Typeable)" 24 | , "Data.Dynamic (Dynamic)" 25 | , "Data.Dynamic.Lens" 26 | , "Data.Hashable (Hashable)" 27 | , "Data.HashSet (HashSet)" 28 | , "Data.Typeable.Lens" 29 | , "Control.Lens" 30 | , "Control.Lens.Internal" 31 | , "Control.Monad.RWS" 32 | , "Control.Monad.Reader" 33 | , "Control.Monad.State" 34 | , "Control.Monad.Trans.Error (Error,ErrorT)" 35 | , "Control.Monad.Writer" 36 | , "Data.Foldable (Foldable)" 37 | , "Data.ByteString.Lens" 38 | , "Data.Sequence (Seq)" 39 | , "Data.Vector (Vector)" 40 | , "Data.Void (Void)" 41 | , "Data.Word (Word8)" 42 | , "Data.Bits (Bits)" 43 | , "Data.Bits.Lens" 44 | , "Data.ByteString (ByteString)" 45 | , "Data.Set (Set)" 46 | , "Data.IntSet (IntSet)" 47 | , "Data.List.Split" 48 | , "Data.List.Split.Lens" 49 | , "Data.Set.Lens" 50 | , "qualified Control.Lens.Cons" 51 | , "qualified Control.Lens.Fold" 52 | , "qualified Control.Lens.Getter" 53 | , "qualified Control.Lens.Internal.Indexed" 54 | , "qualified Control.Lens.Iso" 55 | , "qualified Control.Lens.Prism" 56 | , "qualified Control.Lens.Setter" 57 | , "qualified Control.Lens.Traversal" 58 | , "qualified Control.Lens.Tuple" 59 | , "qualified Data.ByteString as StrictB" 60 | , "qualified Data.ByteString.Lazy as LazyB" 61 | , "qualified Data.ByteString.Lazy" 62 | , "qualified Data.Complex" 63 | , "Data.Complex (Complex)" 64 | , "Data.Array (Array, Ix)" 65 | , "Data.Map (Map)" 66 | , "Data.Functor.Identity (Identity)" 67 | , "qualified Data.Vector as Vector" 68 | , "qualified Data.Vector.Unboxed as Unboxed" 69 | , "qualified Data.Vector.Storable as Storable" 70 | , "Data.Vector.Primitive (Prim)" 71 | , "qualified Data.Vector.Primitive as Prim" 72 | , "Data.HashMap.Lazy (HashMap)" 73 | , "Data.Tree (Tree)" 74 | , "Foreign.Storable (Storable)" 75 | , "Data.Int (Int64)" 76 | , "qualified Data.Complex.Lens" 77 | , "qualified Data.List.Lens" 78 | , "qualified Data.Monoid" 79 | , "qualified Data.Text as StrictT" 80 | , "qualified Data.Text.Lazy as LazyT" 81 | , "qualified Data.Text" 82 | , "qualified Data.Text.Internal" 83 | , "qualified Data.Traversable" 84 | , "qualified Numeric.Natural" 85 | , "Data.Vector.Unboxed (Unbox)" 86 | ] 87 | 88 | usedExtensions = 89 | [ "Rank2Types" 90 | , "FlexibleContexts" 91 | ] 92 | 93 | valueBlacklist = 94 | [ "nat" 95 | , "fresh" 96 | , "singular" 97 | , "unsafeSingular" 98 | , "dropping" 99 | , "droppingWhile" 100 | , "idroppingWhile" 101 | , "taking" 102 | , "takingWhile" 103 | , "itakingWhile" 104 | ] 105 | 106 | fileBlacklist = 107 | [ "src/Control/Lens/TH.hs" 108 | ] 109 | 110 | myParserMode = defaultParseMode 111 | { extensions = glasgowExts 112 | , fixities = Just 113 | $ preludeFixities 114 | ++ [Fixity AssocRight 9 (UnQual (Symbol "#.")) 115 | ,Fixity AssocLeft 8 (UnQual (Symbol ".#")) 116 | ,Fixity AssocLeft 4 (UnQual (Symbol "<$")) 117 | ,Fixity AssocLeft 4 (UnQual (Symbol "<$>")) 118 | ,Fixity AssocLeft 4 (UnQual (Symbol "<*>")) 119 | ] 120 | } 121 | 122 | processCpp = readProcess "cpp" ["-P","-include","dist/build/autogen/cabal_macros.h","-DHLINT"] 123 | 124 | main :: IO () 125 | main = do 126 | fns <- getArgs 127 | let fns' = filter (`notElem` fileBlacklist) fns 128 | ms <- for fns' $ \fn -> do 129 | txt <- readFile fn 130 | nocpp <- processCpp txt 131 | case parseModuleWithComments myParserMode {parseFilename = fn} nocpp of 132 | ParseFailed srcloc err -> fail (fn ++ ": " ++ show srcloc ++ ": " ++ err) 133 | ParseOk (_m,comments) -> return comments 134 | 135 | putStr $ unlines $ 136 | map (\x -> "{-# LANGUAGE " ++ x ++ " #-}") usedExtensions 137 | ++ map ("import " ++) imports 138 | ++ iconcatMap (\i -> render i . asType) (concat ms) 139 | 140 | asType (Comment _ _ str) 141 | | "::" `isInfixOf` str = 142 | case cleanQuotes True (filterAts str) of 143 | Nothing -> error ("!"++str) 144 | Just clean -> case parseExp clean of 145 | ParseFailed _ err -> Left (str ++ " : " ++ err) 146 | ParseOk (ExpTypeSig _ e t) -> Right (e,t) 147 | ParseOk _ -> Left str 148 | | otherwise = Left str 149 | 150 | render _ (Left s) = [] 151 | render i (Right (l,r)) | prettyPrint l `elem` valueBlacklist = [] 152 | render i (Right (l,r)) = 153 | [ "check_" ++ show i ++ " :: " ++ prettyPrint r 154 | , "check_" ++ show i ++ args ++ " = " ++ prettyPrint (Paren l) ++ args 155 | ] 156 | where 157 | arity = typeArity r 158 | args = concatMap (\x -> [' ',x]) (take arity ['a'..'z']) 159 | 160 | typeArity (TyForall _ _ x) = typeArity x 161 | typeArity (TyFun _ x) = 1 + typeArity x 162 | typeArity _ = 0 163 | 164 | cleanQuotes True ('\'':xs) = quotedPart xs 165 | cleanQuotes False ('\'':xs) = fmap ('\'':) (cleanQuotes False xs) 166 | cleanQuotes _ (x:xs) = fmap (x:) (cleanQuotes (isEligible x) xs) 167 | cleanQuotes _ [] = Just [] 168 | 169 | isEligible '(' = True 170 | isEligible '[' = True 171 | isEligible ' ' = True 172 | isEligible _ = False 173 | 174 | quotedPart ('\'':'\'':xs) = fmap ('\'':) (cleanQuotes False xs) 175 | quotedPart ('\'':xs) = cleanQuotes False xs 176 | quotedPart (x:xs) 177 | | isEndEligible x = Nothing 178 | | otherwise = fmap (x:) (quotedPart xs) 179 | quotedPart [] = Nothing 180 | 181 | isEndEligible ')' = True 182 | isEndEligible ']' = True 183 | isEndEligible ' ' = True 184 | isEndEligible _ = False 185 | 186 | filterAts = dropWhileEnd (=='@') . dropWhileEnd isSpace . dropWhile (=='@') . dropWhile isSpace . dropWhile (=='|') . dropWhile isSpace 187 | -------------------------------------------------------------------------------- /scripts/README.md: -------------------------------------------------------------------------------- 1 | # Miscellaneous scripts related to the project 2 | 3 | ## Gource visualization 4 | 5 | ```console 6 | % mkdir /tmp/images 7 | % vi scripts/github-name-map 8 | % scripts/github-fetch-images \ 9 | https://github.com/ekmett/lens/graphs/contributors-data \ 10 | scripts/github-name-map /tmp/images 11 | % scripts/run-gource /tmp/images audio.ogg /tmp/lens-gource-"$(date +%Y%m%d)" 12 | ``` 13 | 14 | * `github-fetch-images` downloads avatar images for committers based on 15 | `github-name-map`. (TODO: list cabal dependencies; reduce them as well.) 16 | * `run-gource` runs [Gource][], [avconv][] and [MP4Box][] to generate a video. 17 | The audio input file must be at least as long as the resulting video. (TODO: 18 | can one make avconv loop the audio?) 19 | 20 | [Gource]: http://code.google.com/p/gource/ 21 | [avconv]: http://libav.org/avconv.html 22 | [MP4Box]: http://gpac.wp.mines-telecom.fr/mp4box/ 23 | 24 | ## Spellcheck 25 | 26 | ```console 27 | % scripts/spellcheck 28 | ``` 29 | 30 | * `spellcheck` grabs a list of files in the repository using Git and runs 31 | [Aspell][] against them. (TODO: only spellcheck comments from Haskell files.) 32 | 33 | [Aspell]: http://aspell.net/ 34 | 35 | ## IRC Topic Stats 36 | 37 | ```console 38 | % scripts/stats 39 | ``` 40 | 41 | * Generates a fragment for the `#haskell-lens` channel topic summarising the 42 | number of `unsafeCoerce`s, doctests, operators and modules. 43 | 44 | ## 45 | 46 | ```console 47 | % scripts/operators 48 | ``` 49 | 50 | * Generate a list of operators defined under `src/Control/Lens/`, for 51 | pasting into the `hiding` clause of `Control.Lens.Combinators` and the 52 | export section of `Control.Lens.Operators`. 53 | -------------------------------------------------------------------------------- /scripts/github-fetch-images: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | 11 | {-# OPTIONS_GHC -fno-warn-orphans #-} 12 | 13 | module Main (main) where 14 | 15 | import Prelude hiding (catch) 16 | 17 | import Control.Applicative ((<$>)) 18 | import Control.Exception (IOException, catch) 19 | import Control.Lens 20 | import Control.Monad (forM_) 21 | import Control.Monad.IO.Class (liftIO) 22 | import Control.Monad.Trans.Resource (register) 23 | import Data.Aeson 24 | import Data.Conduit (ResourceT, ($$+-)) 25 | import Data.Conduit.Binary (sinkFile) 26 | import Data.Data (Data, Typeable) 27 | import Data.Data.Lens (uniplate) 28 | import Data.List (delete) 29 | import qualified Data.Map as Map 30 | import qualified Data.Text.Lens as T 31 | import Network.HTTP.Conduit 32 | import Network.HTTP.Types (hContentType, parseQuery, 33 | renderQuery) 34 | import Network.Socket (withSocketsDo) 35 | import System.Environment (getArgs, getProgName) 36 | import System.Exit (exitFailure) 37 | import System.FilePath (()) 38 | import System.IO (hPutStrLn, stderr) 39 | import System.Posix.Files (createSymbolicLink, removeLink, 40 | rename) 41 | 42 | -- Evil orphan instance. 43 | deriving instance Data Value 44 | 45 | data Env = Env { envManager :: Manager 46 | , envLookupNames :: String -> Maybe [String] 47 | , envOutputDir :: String 48 | } 49 | deriving (Typeable) 50 | 51 | data Author = Author { authorLogin :: String 52 | , authorImageURI :: String 53 | } 54 | deriving (Eq, Ord, Show, Read, Typeable, Data) 55 | 56 | main :: IO () 57 | main = withSocketsDo . withManager $ \man -> do 58 | args <- liftIO getArgs 59 | case args of 60 | [jsonUri, nameMapPath, outputDir] -> do 61 | namesList <- liftIO $ readIO =<< readFile nameMapPath 62 | 63 | liftIO $ putStrLn ("Downloading: " ++ show jsonUri) 64 | jsonReq <- parseUrl jsonUri 65 | jsonData <- responseBody <$> httpLbs jsonReq man 66 | jsonDec <- either fail return (eitherDecode jsonData) 67 | 68 | let namesMap = Map.fromList namesList 69 | env = Env { envManager = man 70 | , envLookupNames = (`Map.lookup` namesMap) 71 | , envOutputDir = outputDir 72 | } 73 | 74 | mapM_ (downloadImage env) (jsonAuthors jsonDec) 75 | 76 | _ -> liftIO $ do 77 | name <- getProgName 78 | hPutStrLn stderr . unlines 79 | $ [ "USAGE: " ++ name ++ " " 80 | , "" 81 | , "An example of JSON-URI: https://github.com/ekmett/lens/graphs/contributors-data" 82 | ] 83 | exitFailure 84 | 85 | jsonAuthors :: Value -> [Author] 86 | jsonAuthors val = 87 | [ Author (login ^. unpacked) (gravatar ^. unpacked) 88 | | Object obj <- universeOf uniplate val 89 | , String login <- obj ^.. ix "login" 90 | , String gravatar <- obj ^.. ix "gravatar" 91 | ] 92 | where 93 | unpacked = from T.packed 94 | 95 | downloadImage :: Env -> Author -> ResourceT IO () 96 | downloadImage (Env {..}) (Author {..}) = 97 | case envLookupNames authorLogin of 98 | Nothing -> 99 | liftIO $ hPutStrLn stderr ("Unrecognized login: " ++ show authorLogin) 100 | 101 | Just names -> do 102 | liftIO $ putStrLn ("Downloading: " ++ show loginBase ++ ", " ++ show names) 103 | 104 | req <- modImageReq <$> parseUrl authorImageURI 105 | Response _ _ headers src <- http req envManager 106 | 107 | suffix <- 108 | case lookup hContentType headers of 109 | Just "image/jpeg" -> return ".jpeg" 110 | Just "image/png" -> return ".png" 111 | t -> fail ("Unhandled Content-Type: " ++ show t) 112 | 113 | let loginImage = loginBase ++ suffix 114 | loginImageD = loginBaseD ++ suffix 115 | loginImageTempD = loginImageD ++ tempSuffix 116 | 117 | -- Download. 118 | _ <- register $ unlinkIfExists loginImageTempD 119 | src $$+- sinkFile loginImageTempD 120 | 121 | liftIO $ do 122 | unlinkIfExists loginImageD 123 | rename loginImageTempD loginImageD 124 | 125 | -- Delete potential old versions with other suffixes. 126 | forM_ (delete suffix suffixes) $ \otherSuf -> do 127 | unlinkIfExists (loginBaseD ++ otherSuf) 128 | forM_ names $ \name -> unlinkIfExists (envOutputDir name ++ otherSuf) 129 | 130 | -- Link names to the login. 131 | forM_ names $ \name -> do 132 | let nameD = envOutputDir name ++ suffix 133 | unlinkIfExists nameD 134 | createSymbolicLink loginImage nameD 135 | where 136 | loginBase = "github-" ++ authorLogin 137 | loginBaseD = envOutputDir loginBase 138 | suffixes = [".jpeg", ".png"] 139 | tempSuffix = ".temp" 140 | 141 | unlinkIfExists path = 142 | removeLink path `catch` \(_ :: IOException) -> return () 143 | 144 | -- | Change/set the image size to 512 and the fallback image to identicon. 145 | modImageReq :: Request m -> Request m 146 | modImageReq req = 147 | req & zipper 148 | 149 | -- Request m :-> ByteString 150 | & downward (lens queryString (\req' qs -> req' { queryString = qs })) 151 | 152 | -- ByteString :<-> Map ByteString (Maybe ByteString) 153 | & downward (iso parseQuery (renderQuery False) . wrapping Map.fromList) 154 | 155 | & focus . at "s" ?~ Just "512" 156 | & focus . at "d" ?~ Just "identicon" 157 | 158 | & rezip 159 | -------------------------------------------------------------------------------- /scripts/github-name-map: -------------------------------------------------------------------------------- 1 | [ ("aristidb", ["Aristid Breitkreuz"]) 2 | , ("arkeet", ["Adrian Keet"]) 3 | , ("byorgey", ["Brent Yorgey"]) 4 | , ("cartazio", ["Carter Tazio Schonwald"]) 5 | , ("dag", ["Dag Odenhall"]) 6 | , ("danr", ["Dan Rosén"]) 7 | , ("ehird", ["Elliott Hird"]) 8 | , ("ekmett", ["Edward A. Kmett", "Edward Kmett"]) 9 | , ("glguy", ["Eric Mertens"]) 10 | , ("ion1", ["Johan Kiviniemi"]) 11 | , ("liyang", ["Liyang HU"]) 12 | , ("mgsloan", ["mgsloan", "Michael Sloan"]) 13 | , ("michaelt", ["Michael Thompson"]) 14 | , ("mvv", ["Mikhail Vorozhtsov"]) 15 | , ("nandykins", ["nand"]) 16 | , ("ocharles", ["Oliver Charles"]) 17 | , ("Peaker", ["Eyal Lotem"]) 18 | , ("pthariensflame", ["Alexander Altman"]) 19 | , ("shachaf", ["shachaf", "Shachaf Ben-Kiki"]) 20 | , ("sol", ["Simon Hengel"]) 21 | , ("startling", ["startling"]) 22 | , ("supki", ["Matvey Aksenov"]) 23 | , ("Taneb", ["Taneb"]) 24 | , ("thoughtpolice", ["Austin Seipp"]) 25 | , ("yairchu", ["Yair Chuchem"]) 26 | ] 27 | -------------------------------------------------------------------------------- /scripts/hackage-docs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Run this script in the top-level of your package directory 4 | # (where the .cabal file is) to compile documentation and 5 | # upload it to hackage. 6 | 7 | # Requirements: 8 | # cabal-install-1.24 (for --for-hackage) 9 | # haddock-2.23 (for the hyperlinked source and identifier namespacing) 10 | 11 | set -e 12 | 13 | dir=$(mktemp -d dist-docs.XXXXXX) 14 | trap 'rm -r "$dir"' EXIT 15 | 16 | cabal configure --builddir="$dir" 17 | cabal haddock --builddir="$dir" --for-hackage --haddock-option=--hyperlinked-source 18 | cabal upload --publish -d $dir/*-docs.tar.gz 19 | -------------------------------------------------------------------------------- /scripts/operators: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | 3 | cd "$(git rev-parse --show-toplevel)" 4 | 5 | heading() 6 | { 7 | declare -g MODULE 8 | test "$1" = "$MODULE" && return 9 | echo " -- * \"$1\"" 10 | MODULE="$1" 11 | } 12 | test "$1" != "-h" && heading() { echo -n ; } # default to no headings 13 | 14 | INDENT=" " 15 | git grep --basic-regexp '^(.\+)\s*::' src/Control/Lens/ \ 16 | | sed -e 's#^src/\(.*\)\.hs:\(.*\S\)\s*::.*$#\1 \2#' \ 17 | | while read FILE OPER ; do 18 | heading "${FILE////.}" 19 | echo "$INDENT$OPER" 20 | INDENT=" , " 21 | done 22 | 23 | -------------------------------------------------------------------------------- /scripts/run-gource: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | set -eu 3 | 4 | image_dir="$1"; shift 5 | audio="$1"; shift 6 | base="$1"; shift 7 | 8 | gource --viewport '1920x1080!' --stop-at-end --seconds-per-day 2 \ 9 | --user-image-dir "$image_dir" --multi-sampling --no-vsync \ 10 | --max-user-speed 100 --hide mouse,progress --output-ppm-stream - \ 11 | --output-framerate 30 | \ 12 | avconv -y \ 13 | -r:v 30 -f:v image2pipe -codec:v ppm -i:v - \ 14 | -i:a "$audio" \ 15 | -codec:v libx264 -pre:v ultrafast -crf:v 18 -codec:a copy \ 16 | -threads auto -shortest "$base.temp.mp4" 17 | 18 | MP4Box -inter 500 -tmp "$(dirname "$base")" "$base.temp.mp4" 19 | 20 | mv -f "$base.temp.mp4" "$base.mp4" 21 | -------------------------------------------------------------------------------- /scripts/spellcheck: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -eu 3 | 4 | # The <() is a bashism. 5 | xargs -a <(git ls-tree -r -z --name-only --full-name HEAD) -0 -n 1 -t -- \ 6 | aspell check --lang=en --encoding=UTF-8 --run-together --dont-backup -- 7 | -------------------------------------------------------------------------------- /scripts/stats: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | 3 | g() { local D="$1" && shift ; git grep --basic-regexp "$@" "$D" | wc -l ; } 4 | cd "$(git rev-parse --show-toplevel)" 5 | 6 | doc="$(g src -e '--\s\+>>>\s\+[^:]' --and --not -e '--\s\+>>>\s\+\(import\|let\)' \ 7 | --or -e '--\s\+>>>\s\+let\s\+.*\')" 8 | opsLens="$(g src/Control/Lens '^(.\+)\s*::')" 9 | opsAll="$(g src '^(.\+)\s*::')" 10 | mod="$(find src -name '*.hs' | wc -l)" 11 | 12 | echo "doctests: $doc | operators: $opsAll (Control.Lens: $opsLens) | modules: $mod" 13 | 14 | -------------------------------------------------------------------------------- /src/Control/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Control.Lens 5 | -- Copyright : (C) 2012-16 Edward Kmett 6 | -- License : BSD-style (see the file LICENSE) 7 | -- Maintainer : Edward Kmett 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | -- 11 | -- Usage: 12 | -- 13 | -- You can derive lenses automatically for many data types: 14 | -- 15 | -- @ 16 | -- import Control.Lens 17 | -- 18 | -- data FooBar a 19 | -- = Foo { _x :: ['Int'], _y :: a } 20 | -- | Bar { _x :: ['Int'] } 21 | -- 'makeLenses' ''FooBar 22 | -- @ 23 | -- 24 | -- This defines the following lenses: 25 | -- 26 | -- @ 27 | -- x :: 'Lens'' (FooBar a) ['Int'] 28 | -- y :: t'Traversal' (FooBar a) (FooBar b) a b 29 | -- @ 30 | -- 31 | -- You can then access the value of @_x@ with ('^.'), the value of @_y@ – 32 | -- with ('^?') or ('^?!') (since it can fail), set the values with ('.~'), 33 | -- modify them with ('%~'), and use almost any other combinator that is 34 | -- re-exported here on those fields. 35 | -- 36 | -- The combinators here have unusually specific type signatures, so for 37 | -- particularly tricky ones, the simpler type signatures you might want to 38 | -- pretend the combinators have are specified as well. 39 | -- 40 | -- More information on how to use lenses is available on the lens wiki: 41 | -- 42 | -- 43 | -- 44 | -- <> 45 | ---------------------------------------------------------------------------- 46 | module Control.Lens 47 | ( module Control.Lens.At 48 | , module Control.Lens.Cons 49 | , module Control.Lens.Each 50 | , module Control.Lens.Empty 51 | , module Control.Lens.Equality 52 | , module Control.Lens.Fold 53 | , module Control.Lens.Getter 54 | , module Control.Lens.Indexed 55 | , module Control.Lens.Iso 56 | , module Control.Lens.Lens 57 | , module Control.Lens.Level 58 | , module Control.Lens.Plated 59 | , module Control.Lens.Prism 60 | , module Control.Lens.Reified 61 | , module Control.Lens.Review 62 | , module Control.Lens.Setter 63 | #ifndef DISABLE_TEMPLATE_HASKELL 64 | , module Control.Lens.TH 65 | #endif 66 | , module Control.Lens.Traversal 67 | , module Control.Lens.Tuple 68 | , module Control.Lens.Type 69 | , module Control.Lens.Wrapped 70 | , module Control.Lens.Zoom 71 | ) where 72 | 73 | import Control.Lens.At 74 | import Control.Lens.Cons 75 | import Control.Lens.Each 76 | import Control.Lens.Empty 77 | import Control.Lens.Equality 78 | import Control.Lens.Fold 79 | import Control.Lens.Getter 80 | import Control.Lens.Indexed 81 | import Control.Lens.Iso 82 | import Control.Lens.Lens 83 | import Control.Lens.Level 84 | import Control.Lens.Plated 85 | import Control.Lens.Prism 86 | import Control.Lens.Reified 87 | import Control.Lens.Review 88 | import Control.Lens.Setter 89 | #ifndef DISABLE_TEMPLATE_HASKELL 90 | import Control.Lens.TH 91 | #endif 92 | import Control.Lens.Traversal 93 | import Control.Lens.Tuple 94 | import Control.Lens.Type 95 | import Control.Lens.Wrapped 96 | import Control.Lens.Zoom 97 | -------------------------------------------------------------------------------- /src/Control/Lens/Combinators.hs: -------------------------------------------------------------------------------- 1 | {-# Language CPP #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Control.Lens.Combinators 5 | -- Copyright : (C) 2013-16 Edward Kmett 6 | -- License : BSD-style (see the file LICENSE) 7 | -- Maintainer : Edward Kmett 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | -- 11 | -- This lets the subset of users who vociferously disagree about the full 12 | -- scope and set of operators that should be exported from lens to not have 13 | -- to look at any operator with which they disagree. 14 | -- 15 | -- > import Control.Lens.Combinators 16 | -------------------------------------------------------------------------------- 17 | module Control.Lens.Combinators 18 | ( module Control.Lens 19 | ) where 20 | 21 | import Control.Lens hiding 22 | ( (<|) 23 | , (|>) 24 | , (^..) 25 | , (^?) 26 | , (^?!) 27 | , (^@..) 28 | , (^@?) 29 | , (^@?!) 30 | , (^.) 31 | , (^@.) 32 | , (<.) 33 | , (.>) 34 | , (<.>) 35 | , (%%~) 36 | , (%%=) 37 | , (&) 38 | , (&~) 39 | , (<&>) 40 | , (??) 41 | , (<%~) 42 | , (<+~) 43 | , (<-~) 44 | , (<*~) 45 | , (~) 63 | , (<%=) 64 | , (<+=) 65 | , (<-=) 66 | , (<*=) 67 | , (=) 85 | , (<<~) 86 | , (<<>~) 87 | , (<<>=) 88 | , (<%@~) 89 | , (<<%@~) 90 | , (%%@~) 91 | , (%%@=) 92 | , (<%@=) 93 | , (<<%@=) 94 | , (.@=) 95 | , (.@~) 96 | , (^#) 97 | , (#~) 98 | , (#%~) 99 | , (#%%~) 100 | , (#=) 101 | , (#%=) 102 | , (<#%~) 103 | , (<#%=) 104 | , (#%%=) 105 | , (<#~) 106 | , (<#=) 107 | , (...) 108 | , (#) 109 | , (%~) 110 | , (.~) 111 | , (?~) 112 | , (<.~) 113 | , (~) 141 | , (<>=) 142 | , (<>:~) 143 | , (<>:=) 144 | , (<<>:~) 145 | , (<<>:=) 146 | , (<|~) 147 | , (<|=) 148 | , (<<|~) 149 | , (<<|=) 150 | , (|>~) 151 | , (|>=) 152 | , (<|>~) 153 | , (<|>=) 154 | , (%@~) 155 | , (%@=) 156 | , (:>) 157 | , (:<) 158 | ) 159 | -------------------------------------------------------------------------------- /src/Control/Lens/Equality.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE Rank2Types #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE Trustworthy #-} 7 | 8 | #if __GLASGOW_HASKELL__ >= 806 9 | {-# LANGUAGE PolyKinds #-} 10 | #else 11 | {-# LANGUAGE TypeInType #-} 12 | #endif 13 | 14 | ----------------------------------------------------------------------------- 15 | -- | 16 | -- Module : Control.Lens.Equality 17 | -- Copyright : (C) 2012-16 Edward Kmett 18 | -- License : BSD-style (see the file LICENSE) 19 | -- Maintainer : Edward Kmett 20 | -- Stability : provisional 21 | -- Portability : Rank2Types 22 | -- 23 | ---------------------------------------------------------------------------- 24 | module Control.Lens.Equality 25 | ( 26 | -- * Type Equality 27 | Equality, Equality' 28 | , AnEquality, AnEquality' 29 | , (:~:)(..) 30 | , runEq 31 | , substEq 32 | , mapEq 33 | , fromEq 34 | , simply 35 | -- * The Trivial Equality 36 | , simple 37 | -- * 'Iso'-like functions 38 | , equality 39 | , equality' 40 | , withEquality 41 | , underEquality 42 | , overEquality 43 | , fromLeibniz 44 | , fromLeibniz' 45 | , cloneEquality 46 | -- * Implementation Details 47 | , Identical(..) 48 | ) where 49 | 50 | import Control.Lens.Type 51 | import Data.Proxy (Proxy) 52 | import Data.Type.Equality ((:~:)(..)) 53 | import GHC.Exts (TYPE) 54 | import Data.Kind (Type) 55 | 56 | -- $setup 57 | -- >>> import Control.Lens 58 | 59 | #include "lens-common.h" 60 | 61 | ----------------------------------------------------------------------------- 62 | -- Equality 63 | ----------------------------------------------------------------------------- 64 | 65 | -- | Provides witness that @(s ~ a, b ~ t)@ holds. 66 | data Identical a b s t where 67 | Identical :: Identical a b a b 68 | 69 | -- | When you see this as an argument to a function, it expects an 'Equality'. 70 | type AnEquality s t a b = Identical a (Proxy b) a (Proxy b) -> Identical a (Proxy b) s (Proxy t) 71 | 72 | -- | A 'Simple' 'AnEquality'. 73 | type AnEquality' s a = AnEquality s s a a 74 | 75 | -- | Extract a witness of type 'Equality'. 76 | runEq :: AnEquality s t a b -> Identical s t a b 77 | runEq l = case l Identical of Identical -> Identical 78 | {-# INLINE runEq #-} 79 | 80 | -- | Substituting types with 'Equality'. 81 | substEq :: forall s t a b rep (r :: TYPE rep). 82 | AnEquality s t a b -> ((s ~ a, t ~ b) => r) -> r 83 | substEq l = case runEq l of 84 | Identical -> \r -> r 85 | {-# INLINE substEq #-} 86 | 87 | -- | We can use 'Equality' to do substitution into anything. 88 | mapEq :: forall k1 k2 (s :: k1) (t :: k2) (a :: k1) (b :: k2) (f :: k1 -> Type) . AnEquality s t a b -> f s -> f a 89 | mapEq l r = substEq l r 90 | {-# INLINE mapEq #-} 91 | 92 | -- | 'Equality' is symmetric. 93 | fromEq :: AnEquality s t a b -> Equality b a t s 94 | fromEq l = substEq l id 95 | {-# INLINE fromEq #-} 96 | 97 | -- | This is an adverb that can be used to modify many other 'Lens' combinators to make them require 98 | -- simple lenses, simple traversals, simple prisms or simple isos as input. 99 | simply :: forall p f s a rep (r :: TYPE rep). 100 | (Optic' p f s a -> r) -> Optic' p f s a -> r 101 | simply = id 102 | {-# INLINE simply #-} 103 | 104 | -- | Composition with this isomorphism is occasionally useful when your 'Lens', 105 | -- 'Control.Lens.Traversal.Traversal' or 'Iso' has a constraint on an unused 106 | -- argument to force that argument to agree with the 107 | -- type of a used argument and avoid @ScopedTypeVariables@ or other ugliness. 108 | simple :: Equality' a a 109 | simple = id 110 | {-# INLINE simple #-} 111 | 112 | cloneEquality :: AnEquality s t a b -> Equality s t a b 113 | cloneEquality an = substEq an id 114 | {-# INLINE cloneEquality #-} 115 | 116 | -- | Construct an 'Equality' from explicit equality evidence. 117 | equality :: s :~: a -> b :~: t -> Equality s t a b 118 | equality Refl Refl = id 119 | {-# INLINE equality #-} 120 | 121 | -- | A 'Simple' version of 'equality' 122 | equality' :: a :~: b -> Equality' a b 123 | equality' Refl = id 124 | {-# INLINE equality' #-} 125 | 126 | -- | Recover a "profunctor lens" form of equality. Reverses 'fromLeibniz'. 127 | overEquality :: AnEquality s t a b -> p a b -> p s t 128 | overEquality an = substEq an id 129 | {-# INLINE overEquality #-} 130 | 131 | -- | The opposite of working 'overEquality' is working 'underEquality'. 132 | underEquality :: AnEquality s t a b -> p t s -> p b a 133 | underEquality an = substEq an id 134 | {-# INLINE underEquality #-} 135 | 136 | -- | Convert a "profunctor lens" form of equality to an equality. Reverses 137 | -- 'overEquality'. 138 | -- 139 | -- The type should be understood as 140 | -- 141 | -- @fromLeibniz :: (forall p. p a b -> p s t) -> Equality s t a b@ 142 | fromLeibniz :: (Identical a b a b -> Identical a b s t) -> Equality s t a b 143 | fromLeibniz f = case f Identical of Identical -> id 144 | {-# INLINE fromLeibniz #-} 145 | 146 | -- | Convert Leibniz equality to equality. Reverses 'mapEq' in 'Simple' cases. 147 | -- 148 | -- The type should be understood as 149 | -- 150 | -- @fromLeibniz' :: (forall f. f s -> f a) -> Equality' s a@ 151 | fromLeibniz' :: (s :~: s -> s :~: a) -> Equality' s a 152 | fromLeibniz' f = case f Refl of Refl -> id 153 | {-# INLINE fromLeibniz' #-} 154 | 155 | -- | A version of 'substEq' that provides explicit, rather than implicit, 156 | -- equality evidence. 157 | withEquality :: forall s t a b rep (r :: TYPE rep). 158 | AnEquality s t a b -> (s :~: a -> b :~: t -> r) -> r 159 | withEquality an = substEq an (\f -> f Refl Refl) 160 | {-# INLINE withEquality #-} 161 | -------------------------------------------------------------------------------- /src/Control/Lens/Extras.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.List.Lens 4 | -- Copyright : (C) 2012-16 Edward Kmett 5 | -- License : BSD-style (see the file LICENSE) 6 | -- Maintainer : Edward Kmett 7 | -- Stability : provisional 8 | -- Portability : portable 9 | -- 10 | -- A few extra names that didn't make it into Control.Lens. 11 | -- 12 | ---------------------------------------------------------------------------- 13 | module Control.Lens.Extras 14 | ( is 15 | , module Data.Data.Lens 16 | ) where 17 | 18 | import Control.Lens 19 | import Data.Data.Lens 20 | 21 | -- $setup 22 | -- >>> import Control.Lens 23 | -- >>> import Numeric.Lens (hex) 24 | 25 | -- | Check to see if this t'Prism' matches. 26 | -- 27 | -- >>> is _Left (Right 12) 28 | -- False 29 | -- 30 | -- >>> is hex "3f79" 31 | -- True 32 | is :: APrism s t a b -> s -> Bool 33 | is k = not . isn't k 34 | {-# INLINE is #-} 35 | -------------------------------------------------------------------------------- /src/Control/Lens/Internal.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Control.Lens.Internal 4 | -- Copyright : (C) 2012-16 Edward Kmett 5 | -- License : BSD-style (see the file LICENSE) 6 | -- Maintainer : Edward Kmett 7 | -- Stability : experimental 8 | -- Portability : Rank2Types 9 | -- 10 | -- These are some of the explicit 'Functor' instances that leak into the 11 | -- type signatures of @Control.Lens@. You shouldn't need to import this 12 | -- module directly for most use-cases. 13 | -- 14 | ---------------------------------------------------------------------------- 15 | module Control.Lens.Internal 16 | ( module Control.Lens.Internal.Bazaar 17 | , module Control.Lens.Internal.Context 18 | , module Control.Lens.Internal.Fold 19 | , module Control.Lens.Internal.Getter 20 | , module Control.Lens.Internal.Indexed 21 | , module Control.Lens.Internal.Iso 22 | , module Control.Lens.Internal.Level 23 | , module Control.Lens.Internal.Magma 24 | , module Control.Lens.Internal.Prism 25 | , module Control.Lens.Internal.Review 26 | , module Control.Lens.Internal.Setter 27 | , module Control.Lens.Internal.Zoom 28 | ) where 29 | 30 | import Control.Lens.Internal.Bazaar 31 | import Control.Lens.Internal.Context 32 | import Control.Lens.Internal.Fold 33 | import Control.Lens.Internal.Getter 34 | import Control.Lens.Internal.Indexed 35 | import Control.Lens.Internal.Instances () 36 | import Control.Lens.Internal.Iso 37 | import Control.Lens.Internal.Level 38 | import Control.Lens.Internal.Magma 39 | import Control.Lens.Internal.Prism 40 | import Control.Lens.Internal.Review 41 | import Control.Lens.Internal.Setter 42 | import Control.Lens.Internal.Zoom 43 | -------------------------------------------------------------------------------- /src/Control/Lens/Internal/CTypes.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Control.Lens.Internal.CTypes 4 | -- Copyright : (C) 2012-2016 Edward Kmett, (C) 2017 Ryan Scott 5 | -- License : BSD-style (see the file LICENSE) 6 | -- Maintainer : Edward Kmett 7 | -- Stability : experimental 8 | -- Portability : non-portable 9 | -- 10 | -- In "Control.Lens.Wrapped", we need to muck around with the internals of the 11 | -- newtypes in "Foreign.C.Types". Unfortunately, the exact types used varies 12 | -- wildly from platform to platform, so trying to manage the imports necessary 13 | -- to bring these types in scope can be unwieldy. 14 | -- 15 | -- To make things easier, we use this module as a way to import everything 16 | -- carte blanche that might be used internally in "Foreign.C.Types". For 17 | -- now, this consists of all the exports from the "Data.Int" and "Data.Word" 18 | -- modules, as well as the 'Ptr' type. 19 | ---------------------------------------------------------------------------- 20 | module Control.Lens.Internal.CTypes 21 | ( module Data.Int 22 | , Ptr 23 | , module Data.Word 24 | ) where 25 | 26 | import Data.Int 27 | import Data.Word 28 | import Foreign.Ptr (Ptr) 29 | -------------------------------------------------------------------------------- /src/Control/Lens/Internal/Doctest.hs: -------------------------------------------------------------------------------- 1 | -- | This module exists for the sole purpose of redefining the 'head' and 'tail' 2 | -- functions (which are normally provided by the 'Prelude') so that they can be 3 | -- used in the doctests of 'Data.Data.Lens'. 4 | -- 5 | -- The 'head' and 'tail' functions are partial, and as of GHC 9.8, there is a 6 | -- @-Wx-partial@ warning (implied by @-Wall@) that triggers any time you use 7 | -- either of these functions. This is a fairly reasonable default in most 8 | -- settings, but there are a handful of doctests in 'Data.Data.Lens' that do in 9 | -- fact rely on 'head' and 'tail' being partial functions. These doctests 10 | -- demonstrate that various functions in 'Data.Data.Lens' can recover from 11 | -- exceptions that are thrown due to partiality (see, for instance, the @upon@ 12 | -- function). 13 | -- 14 | -- One possible workaround would be to disable @-Wx-partial@. We don't want to 15 | -- disable the warning for /all/ code in @lens@, however—we only want to 16 | -- disable it for a particular group of doctests. It is rather tricky to achieve 17 | -- this level of granularity, unfortunately. This is because tools like 18 | -- @cabal-docspec@ rely on GHCi to work, and the statefulness of GHCi's @:set@ 19 | -- command means that disabling @-Wx-partial@ might leak into other modules' 20 | -- doctests, which we don't want. 21 | -- 22 | -- Instead, we opt to redefine our own versions of 'head' and 'tail' here, which 23 | -- do not trigger any @-Wx-partial@ warnings, and use them in the 24 | -- 'Data.Data.Lens' doctests. This has no impact on anyone reading the doctests, 25 | -- as these functions will look indistinguishable from the 'head' and 'tail' 26 | -- functions in the 'Prelude'. One consequence of this design is that we must 27 | -- export the 'Control.Lens.Internal.Doctest' module, as GHCi (and therefore 28 | -- @cabal-docspec@) won't be able to import it otherwise. Despite this technical 29 | -- oddity, this module should be thought of as internal to @lens@. 30 | module Control.Lens.Internal.Doctest 31 | ( head 32 | , tail 33 | ) where 34 | 35 | import Prelude hiding (head, tail) 36 | 37 | head :: [a] -> a 38 | head (x:_) = x 39 | head [] = error "head: empty list" 40 | 41 | tail :: [a] -> [a] 42 | tail (_:xs) = xs 43 | tail [] = error "tail: empty list" 44 | -------------------------------------------------------------------------------- /src/Control/Lens/Internal/Getter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Control.Lens.Internal.Getter 8 | -- Copyright : (C) 2012-2016 Edward Kmett 9 | -- License : BSD-style (see the file LICENSE) 10 | -- Maintainer : Edward Kmett 11 | -- Stability : provisional 12 | -- Portability : non-portable 13 | -- 14 | ---------------------------------------------------------------------------- 15 | module Control.Lens.Internal.Getter 16 | ( noEffect 17 | , AlongsideLeft(..) 18 | , AlongsideRight(..) 19 | ) where 20 | 21 | import Prelude () 22 | 23 | import Control.Lens.Internal.Prelude 24 | import Data.Bifoldable 25 | import Data.Bifunctor 26 | import Data.Bitraversable 27 | import Data.Semigroup.Foldable 28 | import Data.Semigroup.Traversable 29 | 30 | -- | The 'mempty' equivalent for a 'Contravariant' 'Applicative' 'Functor'. 31 | noEffect :: (Contravariant f, Applicative f) => f a 32 | noEffect = phantom $ pure () 33 | {-# INLINE noEffect #-} 34 | 35 | newtype AlongsideLeft f b a = AlongsideLeft { getAlongsideLeft :: f (a, b) } 36 | 37 | deriving instance Show (f (a, b)) => Show (AlongsideLeft f b a) 38 | deriving instance Read (f (a, b)) => Read (AlongsideLeft f b a) 39 | 40 | instance Functor f => Functor (AlongsideLeft f b) where 41 | fmap f = AlongsideLeft . fmap (first f) . getAlongsideLeft 42 | {-# INLINE fmap #-} 43 | 44 | instance Contravariant f => Contravariant (AlongsideLeft f b) where 45 | contramap f = AlongsideLeft . contramap (first f) . getAlongsideLeft 46 | {-# INLINE contramap #-} 47 | 48 | instance Foldable f => Foldable (AlongsideLeft f b) where 49 | foldMap f = foldMap (f . fst) . getAlongsideLeft 50 | {-# INLINE foldMap #-} 51 | 52 | instance Traversable f => Traversable (AlongsideLeft f b) where 53 | traverse f (AlongsideLeft as) = AlongsideLeft <$> traverse (bitraverse f pure) as 54 | {-# INLINE traverse #-} 55 | 56 | instance Foldable1 f => Foldable1 (AlongsideLeft f b) where 57 | foldMap1 f = foldMap1 (f . fst) . getAlongsideLeft 58 | {-# INLINE foldMap1 #-} 59 | 60 | instance Traversable1 f => Traversable1 (AlongsideLeft f b) where 61 | traverse1 f (AlongsideLeft as) = AlongsideLeft <$> traverse1 (\(a,b) -> flip (,) b <$> f a) as 62 | {-# INLINE traverse1 #-} 63 | 64 | instance Functor f => Bifunctor (AlongsideLeft f) where 65 | bimap f g = AlongsideLeft . fmap (bimap g f) . getAlongsideLeft 66 | {-# INLINE bimap #-} 67 | 68 | instance Foldable f => Bifoldable (AlongsideLeft f) where 69 | bifoldMap f g = foldMap (bifoldMap g f) . getAlongsideLeft 70 | {-# INLINE bifoldMap #-} 71 | 72 | instance Traversable f => Bitraversable (AlongsideLeft f) where 73 | bitraverse f g (AlongsideLeft as) = AlongsideLeft <$> traverse (bitraverse g f) as 74 | {-# INLINE bitraverse #-} 75 | 76 | newtype AlongsideRight f a b = AlongsideRight { getAlongsideRight :: f (a, b) } 77 | 78 | deriving instance Show (f (a, b)) => Show (AlongsideRight f a b) 79 | deriving instance Read (f (a, b)) => Read (AlongsideRight f a b) 80 | 81 | instance Functor f => Functor (AlongsideRight f a) where 82 | fmap f (AlongsideRight x) = AlongsideRight (fmap (second f) x) 83 | {-# INLINE fmap #-} 84 | 85 | instance Contravariant f => Contravariant (AlongsideRight f a) where 86 | contramap f (AlongsideRight x) = AlongsideRight (contramap (second f) x) 87 | {-# INLINE contramap #-} 88 | 89 | instance Foldable f => Foldable (AlongsideRight f a) where 90 | foldMap f = foldMap (f . snd) . getAlongsideRight 91 | {-# INLINE foldMap #-} 92 | 93 | instance Traversable f => Traversable (AlongsideRight f a) where 94 | traverse f (AlongsideRight as) = AlongsideRight <$> traverse (bitraverse pure f) as 95 | {-# INLINE traverse #-} 96 | 97 | instance Foldable1 f => Foldable1 (AlongsideRight f a) where 98 | foldMap1 f = foldMap1 (f . snd) . getAlongsideRight 99 | {-# INLINE foldMap1 #-} 100 | 101 | instance Traversable1 f => Traversable1 (AlongsideRight f a) where 102 | traverse1 f (AlongsideRight as) = AlongsideRight <$> traverse1 (\(a,b) -> (,) a <$> f b) as 103 | {-# INLINE traverse1 #-} 104 | 105 | instance Functor f => Bifunctor (AlongsideRight f) where 106 | bimap f g = AlongsideRight . fmap (bimap f g) . getAlongsideRight 107 | {-# INLINE bimap #-} 108 | 109 | instance Foldable f => Bifoldable (AlongsideRight f) where 110 | bifoldMap f g = foldMap (bifoldMap f g) . getAlongsideRight 111 | {-# INLINE bifoldMap #-} 112 | 113 | instance Traversable f => Bitraversable (AlongsideRight f) where 114 | bitraverse f g (AlongsideRight as) = AlongsideRight <$> traverse (bitraverse f g) as 115 | {-# INLINE bitraverse #-} 116 | -------------------------------------------------------------------------------- /src/Control/Lens/Internal/Instances.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Control.Lens.Internal.Instances 4 | -- Copyright : (C) 2012-2016 Edward Kmett 5 | -- License : BSD-style (see the file LICENSE) 6 | -- Maintainer : Edward Kmett 7 | -- Stability : experimental 8 | -- Portability : non-portable 9 | -- 10 | -- This module includes orphan instances for @(,)@, 'Either' and 'Const' that 11 | -- should be supplied by base. These have moved to @semigroupoids@ as of 4.2. 12 | ---------------------------------------------------------------------------- 13 | module Control.Lens.Internal.Instances () where 14 | 15 | import Data.Orphans () 16 | import Data.Traversable.Instances () 17 | -------------------------------------------------------------------------------- /src/Control/Lens/Internal/Iso.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | #ifdef TRUSTWORTHY 4 | {-# LANGUAGE Trustworthy #-} 5 | #endif 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Control.Lens.Internal.Iso 9 | -- Copyright : (C) 2012-2016 Edward Kmett 10 | -- License : BSD-style (see the file LICENSE) 11 | -- Maintainer : Edward Kmett 12 | -- Stability : experimental 13 | -- Portability : non-portable 14 | -- 15 | ---------------------------------------------------------------------------- 16 | module Control.Lens.Internal.Iso 17 | ( Exchange(..) 18 | , Reversing(..) 19 | ) where 20 | 21 | import Data.Profunctor 22 | import Data.Profunctor.Unsafe 23 | 24 | import qualified Data.ByteString as StrictB 25 | import qualified Data.ByteString.Lazy as LazyB 26 | import Data.Coerce 27 | import qualified Data.List.NonEmpty as NonEmpty 28 | import qualified Data.Text as StrictT 29 | import qualified Data.Text.Lazy as LazyT 30 | import qualified Data.Vector as Vector 31 | import qualified Data.Vector.Primitive as Prim 32 | import Data.Vector.Primitive (Prim) 33 | import qualified Data.Vector.Storable as Storable 34 | import qualified Data.Vector.Unboxed as Unbox 35 | import Data.Vector.Unboxed (Unbox) 36 | #if MIN_VERSION_vector(0,13,2) 37 | import qualified Data.Vector.Strict as VectorStrict 38 | #endif 39 | import qualified Data.Sequence as Seq 40 | import Data.Sequence (Seq) 41 | import Foreign.Storable (Storable) 42 | 43 | ------------------------------------------------------------------------------ 44 | -- Isomorphism: Exchange 45 | ------------------------------------------------------------------------------ 46 | 47 | -- | This is used internally by the 'Control.Lens.Iso.Iso' code to provide 48 | -- efficient access to the two functions that make up an isomorphism. 49 | data Exchange a b s t = Exchange (s -> a) (b -> t) 50 | 51 | instance Functor (Exchange a b s) where 52 | fmap f (Exchange sa bt) = Exchange sa (f . bt) 53 | {-# INLINE fmap #-} 54 | 55 | instance Profunctor (Exchange a b) where 56 | dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt) 57 | {-# INLINE dimap #-} 58 | lmap f (Exchange sa bt) = Exchange (sa . f) bt 59 | {-# INLINE lmap #-} 60 | rmap f (Exchange sa bt) = Exchange sa (f . bt) 61 | {-# INLINE rmap #-} 62 | (#.) _ = coerce 63 | {-# INLINE (#.) #-} 64 | (.#) p _ = coerce p 65 | 66 | ------------------------------------------------------------------------------ 67 | -- Reversible 68 | ------------------------------------------------------------------------------ 69 | 70 | -- | This class provides a generalized notion of list reversal extended to other containers. 71 | class Reversing t where 72 | reversing :: t -> t 73 | 74 | instance Reversing [a] where 75 | reversing = Prelude.reverse 76 | 77 | instance Reversing (NonEmpty.NonEmpty a) where 78 | reversing = NonEmpty.reverse 79 | 80 | instance Reversing StrictB.ByteString where 81 | reversing = StrictB.reverse 82 | 83 | instance Reversing LazyB.ByteString where 84 | reversing = LazyB.reverse 85 | 86 | instance Reversing StrictT.Text where 87 | reversing = StrictT.reverse 88 | 89 | instance Reversing LazyT.Text where 90 | reversing = LazyT.reverse 91 | 92 | instance Reversing (Vector.Vector a) where 93 | reversing = Vector.reverse 94 | 95 | instance Reversing (Seq a) where 96 | reversing = Seq.reverse 97 | 98 | instance Prim a => Reversing (Prim.Vector a) where 99 | reversing = Prim.reverse 100 | 101 | instance Unbox a => Reversing (Unbox.Vector a) where 102 | reversing = Unbox.reverse 103 | 104 | instance Storable a => Reversing (Storable.Vector a) where 105 | reversing = Storable.reverse 106 | 107 | #if MIN_VERSION_vector(0,13,2) 108 | instance Reversing (VectorStrict.Vector a) where 109 | reversing = VectorStrict.reverse 110 | #endif 111 | -------------------------------------------------------------------------------- /src/Control/Lens/Internal/List.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | ------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Control.Lens.Internal.List 5 | -- Copyright : (C) 2014-2016 Edward Kmett and Eric Mertens 6 | -- License : BSD-style (see the file LICENSE) 7 | -- Maintainer : Edward Kmett 8 | -- Stability : provisional 9 | -- Portability : non-portable 10 | -- 11 | -- This module provides utility functions on lists used by the library 12 | -- implementation. 13 | ------------------------------------------------------------------------------- 14 | module Control.Lens.Internal.List 15 | ( ordinalNub 16 | , stripSuffix 17 | ) where 18 | 19 | import Control.Monad (guard) 20 | import Data.IntSet (IntSet) 21 | import qualified Data.IntSet as IntSet 22 | 23 | --- $setup 24 | --- >>> :set -XNoOverloadedStrings 25 | --- >>> import Control.Lens.Internal.List 26 | 27 | -- | Return the the subset of given ordinals within a given bound 28 | -- and in order of the first occurrence seen. 29 | -- 30 | -- Bound: @0 <= x < l@ 31 | -- 32 | -- >>> ordinalNub 3 [-1,2,1,4,2,3] 33 | -- [2,1] 34 | ordinalNub :: 35 | Int {- ^ strict upper bound -} -> 36 | [Int] {- ^ ordinals -} -> 37 | [Int] {- ^ unique, in-bound ordinals, in order seen -} 38 | ordinalNub l xs = foldr (ordinalNubHelper l) (const []) xs IntSet.empty 39 | 40 | ordinalNubHelper :: Int -> Int -> (IntSet -> [Int]) -> (IntSet -> [Int]) 41 | ordinalNubHelper l x next seen 42 | | outOfBounds || notUnique = next seen 43 | | otherwise = x : next (IntSet.insert x seen) 44 | where 45 | outOfBounds = x < 0 || l <= x 46 | notUnique = x `IntSet.member` seen 47 | 48 | -- | \(\mathcal{O}(\min(m,n))\). The 'stripSuffix' function drops the given 49 | -- suffix from a list. It returns 'Nothing' if the list did not end with the 50 | -- suffix given, or 'Just' the list after the suffix, if it does. 51 | -- 52 | -- >>> stripSuffix "bar" "foobar" 53 | -- Just "foo" 54 | -- 55 | -- >>> stripSuffix "foo" "foo" 56 | -- Just "" 57 | -- 58 | -- >>> stripSuffix "bar" "barfoo" 59 | -- Nothing 60 | -- 61 | -- >>> stripSuffix "foo" "barfoobaz" 62 | -- Nothing 63 | stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] 64 | stripSuffix qs xs0 = go xs0 zs 65 | where 66 | zs = drp qs xs0 67 | drp (_:ps) (_:xs) = drp ps xs 68 | drp [] xs = xs 69 | drp _ [] = [] 70 | go (_:xs) (_:ys) = go xs ys 71 | go xs [] = zipWith const xs0 zs <$ guard (xs == qs) 72 | go [] _ = Nothing -- impossible 73 | {-# INLINE stripSuffix #-} 74 | -------------------------------------------------------------------------------- /src/Control/Lens/Internal/Prelude.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Trustworthy #-} 3 | #include "lens-common.h" 4 | -- | Module which does most common imports (and related CPP) 5 | -- needed across the lens library. 6 | -- 7 | -- This module is intended to stay in other-modules of lens, 8 | -- perfectly we'd just use @base-compat-batteries@ 9 | -- and not reinvent the wheel. 10 | -- That's a reason why this module is different from 11 | -- other .Internal modules, which are exposed-modules. 12 | -- 13 | -- Also this is a "fat" Prelude, re-exporting commonly used, 14 | -- non conflicting symbols. 15 | -- 16 | module Control.Lens.Internal.Prelude 17 | ( module Prelude 18 | , Semigroup (..) 19 | , Monoid (..) 20 | , Foldable, foldMap, foldr, foldl, foldl', elem, null, length, traverse_ 21 | , Traversable (..) 22 | , Applicative (..) 23 | , (&), (<&>), (<$>), (<$) 24 | -- * Data types 25 | , ZipList (..) 26 | , NonEmpty (..) 27 | -- * Functors 28 | , Identity (..) 29 | , Compose (..) 30 | , Const (..) 31 | -- * Control.Applicative 32 | , Alternative (..), WrappedMonad (..) 33 | #if !MIN_VERSION_base(4,10,0) 34 | , liftA2 35 | #endif 36 | -- * Data.Coerce 37 | , Coercible, coerce 38 | -- * Data.Contravariant 39 | , Contravariant (..), phantom 40 | -- * Data.Monoid 41 | , Endo (..), Dual (..) 42 | -- * Data.Profunctor 43 | , Profunctor (..) 44 | , Choice (..), Cochoice (..) 45 | , Strong (..), Costrong (..) 46 | , Corepresentable (..) 47 | , Sieve (..), Cosieve (..) 48 | -- * Data.Proxy 49 | , Proxy (..) 50 | -- * Data.Tagged 51 | , Tagged (..) 52 | -- * Data.Void 53 | , Void, absurd 54 | -- * Data.Word 55 | , Word 56 | ) where 57 | 58 | import Prelude hiding 59 | ( userError -- hiding something always helps with CPP 60 | , Applicative (..) 61 | , Foldable (..) 62 | , Traversable (..) 63 | , Monoid (..) 64 | , (<$>), (<$) 65 | #if MIN_VERSION_base(4,13,0) 66 | , Semigroup (..) 67 | #endif 68 | , Word 69 | ) 70 | 71 | -- Prelude 72 | import Control.Applicative (Applicative (..), (<$>), (<$)) -- N.B. liftA2 73 | import Data.Foldable (Foldable, foldMap, elem, foldr, foldl, foldl', traverse_) -- N.B. we don't define Foldable instances, so this way is makes less CPP 74 | import Data.Monoid (Monoid (..)) 75 | import Data.Semigroup (Semigroup (..)) 76 | import Data.Traversable (Traversable (..)) 77 | import Data.Word (Word) 78 | 79 | -- Extras 80 | import Data.Function ((&)) 81 | import Data.Foldable (length, null) 82 | 83 | #if !MIN_VERSION_base(4,10,0) 84 | import Control.Applicative (liftA2) 85 | #endif 86 | 87 | #if MIN_VERSION_base(4,11,0) 88 | import Data.Functor ((<&>)) 89 | #endif 90 | 91 | import Control.Applicative (Alternative (..), Const (..), WrappedMonad (..), ZipList (..)) 92 | import Data.Coerce (Coercible, coerce) 93 | import Data.Functor.Compose (Compose (..)) 94 | import Data.Functor.Contravariant (Contravariant (..), phantom) 95 | import Data.Functor.Identity (Identity (..)) 96 | import Data.List.NonEmpty (NonEmpty (..)) 97 | import Data.Monoid (Endo (..), Dual (..)) 98 | import Data.Profunctor (Strong (..), Choice (..), Cochoice (..), Costrong (..)) 99 | import Data.Profunctor.Rep (Corepresentable (..)) -- N.B. no Representable 100 | import Data.Profunctor.Sieve (Sieve (..), Cosieve (..)) 101 | import Data.Profunctor.Unsafe (Profunctor (..)) 102 | import Data.Proxy (Proxy (..)) 103 | import Data.Tagged (Tagged (..)) 104 | import Data.Void (Void, absurd) 105 | 106 | -- TraversableWithIndex instances for tagged, vector and unordered-containers 107 | -- We import this here, so the instances propagate through all (most) of @lens@. 108 | import Data.Functor.WithIndex.Instances () 109 | 110 | #if !(MIN_VERSION_base(4,11,0)) 111 | -- | Infix flipped 'fmap'. 112 | -- 113 | -- @ 114 | -- ('<&>') = 'flip' 'fmap' 115 | -- @ 116 | (<&>) :: Functor f => f a -> (a -> b) -> f b 117 | as <&> f = f <$> as 118 | {-# INLINE (<&>) #-} 119 | infixl 1 <&> 120 | #endif 121 | -------------------------------------------------------------------------------- /src/Control/Lens/Internal/Prism.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Control.Lens.Internal.Prism 5 | -- Copyright : (C) 2012-2016 Edward Kmett 6 | -- License : BSD-style (see the file LICENSE) 7 | -- Maintainer : Edward Kmett 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | -- 11 | ---------------------------------------------------------------------------- 12 | module Control.Lens.Internal.Prism 13 | ( Market(..) 14 | , Market' 15 | ) where 16 | 17 | import Prelude () 18 | 19 | import Control.Lens.Internal.Prelude 20 | 21 | ------------------------------------------------------------------------------ 22 | -- Prism: Market 23 | ------------------------------------------------------------------------------ 24 | 25 | -- | This type is used internally by the 'Control.Lens.Prism.Prism' code to 26 | -- provide efficient access to the two parts of a 'Prism'. 27 | data Market a b s t = Market (b -> t) (s -> Either t a) 28 | 29 | -- | @type 'Market'' a s t = 'Market' a a s t@ 30 | type Market' a = Market a a 31 | 32 | instance Functor (Market a b s) where 33 | fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta) 34 | {-# INLINE fmap #-} 35 | 36 | instance Profunctor (Market a b) where 37 | dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f) 38 | {-# INLINE dimap #-} 39 | lmap f (Market bt seta) = Market bt (seta . f) 40 | {-# INLINE lmap #-} 41 | rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta) 42 | {-# INLINE rmap #-} 43 | 44 | (#.) _ = coerce 45 | {-# INLINE (#.) #-} 46 | (.#) p _ = coerce p 47 | {-# INLINE (.#) #-} 48 | 49 | instance Choice (Market a b) where 50 | left' (Market bt seta) = Market (Left . bt) $ \sc -> case sc of 51 | Left s -> case seta s of 52 | Left t -> Left (Left t) 53 | Right a -> Right a 54 | Right c -> Left (Right c) 55 | {-# INLINE left' #-} 56 | right' (Market bt seta) = Market (Right . bt) $ \cs -> case cs of 57 | Left c -> Left (Left c) 58 | Right s -> case seta s of 59 | Left t -> Left (Right t) 60 | Right a -> Right a 61 | {-# INLINE right' #-} 62 | -------------------------------------------------------------------------------- /src/Control/Lens/Internal/Profunctor.hs: -------------------------------------------------------------------------------- 1 | module Control.Lens.Internal.Profunctor 2 | ( WrappedPafb (..) 3 | ) where 4 | 5 | import Prelude () 6 | import Control.Lens.Internal.Prelude 7 | 8 | newtype WrappedPafb f p a b = WrapPafb { unwrapPafb :: p a (f b) } 9 | 10 | instance (Functor f, Profunctor p) => Profunctor (WrappedPafb f p) where 11 | dimap f g (WrapPafb p) = WrapPafb $ dimap f (fmap g) p 12 | 13 | instance (Applicative f, Choice p) => Choice (WrappedPafb f p) where 14 | left' (WrapPafb p) = WrapPafb $ rmap sequenceL $ left' p 15 | where 16 | sequenceL (Left a) = fmap Left a 17 | sequenceL (Right a) = pure $ Right a 18 | -------------------------------------------------------------------------------- /src/Control/Lens/Internal/Review.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Control.Lens.Internal.Review 9 | -- Copyright : (C) 2012-2016 Edward Kmett 10 | -- License : BSD-style (see the file LICENSE) 11 | -- Maintainer : Edward Kmett 12 | -- Stability : provisional 13 | -- Portability : non-portable 14 | -- 15 | ---------------------------------------------------------------------------- 16 | module Control.Lens.Internal.Review 17 | ( 18 | -- * Internal Classes 19 | Reviewable 20 | -- * Reviews 21 | , retagged 22 | ) where 23 | 24 | import Data.Bifunctor 25 | import Data.Profunctor 26 | import Data.Void 27 | 28 | -- | This class is provided mostly for backwards compatibility with lens 3.8, 29 | -- but it can also shorten type signatures. 30 | class (Profunctor p, Bifunctor p) => Reviewable p 31 | instance (Profunctor p, Bifunctor p) => Reviewable p 32 | 33 | ------------------------------------------------------------------------------ 34 | -- Review: Reviewed 35 | ------------------------------------------------------------------------------ 36 | 37 | -- | This is a profunctor used internally to implement "Review" 38 | -- 39 | -- It plays a role similar to that of 'Control.Lens.Internal.Getter.Accessor' 40 | -- or 'Const' do for "Control.Lens.Getter" 41 | retagged :: (Profunctor p, Bifunctor p) => p a b -> p s b 42 | retagged = first absurd . lmap absurd 43 | -------------------------------------------------------------------------------- /src/Control/Lens/Internal/Setter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | {-# LANGUAGE Trustworthy #-} 4 | 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Control.Lens.Internal.Setter 8 | -- Copyright : (C) 2012-2016 Edward Kmett 9 | -- License : BSD-style (see the file LICENSE) 10 | -- Maintainer : Edward Kmett 11 | -- Stability : provisional 12 | -- Portability : non-portable 13 | -- 14 | ---------------------------------------------------------------------------- 15 | module Control.Lens.Internal.Setter 16 | ( 17 | -- ** Setters 18 | Settable(..) 19 | ) where 20 | 21 | import Prelude () 22 | 23 | import Control.Applicative.Backwards 24 | import Control.Lens.Internal.Prelude 25 | import Data.Distributive 26 | 27 | ----------------------------------------------------------------------------- 28 | -- Settable 29 | ----------------------------------------------------------------------------- 30 | 31 | -- | Anything 'Settable' must be isomorphic to the 'Identity' 'Functor'. 32 | class (Applicative f, Distributive f, Traversable f) => Settable f where 33 | untainted :: f a -> a 34 | 35 | untaintedDot :: Profunctor p => p a (f b) -> p a b 36 | untaintedDot g = g `seq` rmap untainted g 37 | {-# INLINE untaintedDot #-} 38 | 39 | taintedDot :: Profunctor p => p a b -> p a (f b) 40 | taintedDot g = g `seq` rmap pure g 41 | {-# INLINE taintedDot #-} 42 | 43 | -- | So you can pass our 'Control.Lens.Setter.Setter' into combinators from other lens libraries. 44 | instance Settable Identity where 45 | untainted = runIdentity 46 | {-# INLINE untainted #-} 47 | untaintedDot = (runIdentity #.) 48 | {-# INLINE untaintedDot #-} 49 | taintedDot = (Identity #.) 50 | {-# INLINE taintedDot #-} 51 | 52 | -- | 'Control.Lens.Fold.backwards' 53 | instance Settable f => Settable (Backwards f) where 54 | untainted = untaintedDot forwards 55 | {-# INLINE untainted #-} 56 | 57 | instance (Settable f, Settable g) => Settable (Compose f g) where 58 | untainted = untaintedDot (untaintedDot getCompose) 59 | {-# INLINE untainted #-} 60 | 61 | -------------------------------------------------------------------------------- /src/Control/Lens/Level.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE Trustworthy #-} 5 | 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Control.Lens.Level 9 | -- Copyright : (C) 2012-16 Edward Kmett 10 | -- License : BSD-style (see the file LICENSE) 11 | -- Maintainer : Edward Kmett 12 | -- Stability : provisional 13 | -- Portability : Rank2Types 14 | -- 15 | -- This module provides combinators for breadth-first searching within 16 | -- arbitrary traversals. 17 | ---------------------------------------------------------------------------- 18 | module Control.Lens.Level 19 | ( Level 20 | , levels 21 | , ilevels 22 | ) where 23 | 24 | import Control.Applicative 25 | import Control.Lens.Internal.Bazaar 26 | import Control.Lens.Internal.Context 27 | import Control.Lens.Internal.Indexed 28 | import Control.Lens.Internal.Level 29 | import Control.Lens.Traversal 30 | import Control.Lens.Type 31 | import Data.Profunctor.Unsafe 32 | 33 | -- $setup 34 | -- >>> :set -XNoOverloadedStrings 35 | -- >>> import Control.Lens 36 | -- >>> import Data.Char 37 | 38 | levelIns :: BazaarT (->) f a b t -> [Level () a] 39 | levelIns = go 0 . (getConst #. bazaar (rmapConst (deepening ()))) where 40 | go k z = k `seq` runDeepening z k $ \ xs b -> 41 | xs : if b then (go $! k + 1) z else [] 42 | {-# INLINE levelIns #-} 43 | 44 | levelOuts :: BazaarT (->) f a b t -> [Level j b] -> t 45 | levelOuts bz = runFlows $ runBazaarT bz $ \ _ -> Flows $ \t -> case t of 46 | One _ a : _ -> a 47 | _ -> error "levelOuts: wrong shape" 48 | {-# INLINE levelOuts #-} 49 | 50 | -- | This provides a breadth-first 'Traversal' or 'Fold' of the individual 51 | -- 'levels' of any other 'Traversal' or 'Fold' via iterative deepening 52 | -- depth-first search. The levels are returned to you in a compressed format. 53 | -- 54 | -- This can permit us to extract the 'levels' directly: 55 | -- 56 | -- >>> ["hello","world"]^..levels (traverse.traverse) 57 | -- [Zero,Zero,One () 'h',Two 0 (One () 'e') (One () 'w'),Two 0 (One () 'l') (One () 'o'),Two 0 (One () 'l') (One () 'r'),Two 0 (One () 'o') (One () 'l'),One () 'd'] 58 | -- 59 | -- But we can also traverse them in turn: 60 | -- 61 | -- >>> ["hello","world"]^..levels (traverse.traverse).traverse 62 | -- "hewlolrold" 63 | -- 64 | -- We can use this to traverse to a fixed depth in the tree of ('<*>') used in the 'Traversal': 65 | -- 66 | -- >>> ["hello","world"] & taking 4 (levels (traverse.traverse)).traverse %~ toUpper 67 | -- ["HEllo","World"] 68 | -- 69 | -- Or we can use it to traverse the first @n@ elements in found in that 'Traversal' regardless of the depth 70 | -- at which they were found. 71 | -- 72 | -- >>> ["hello","world"] & taking 4 (levels (traverse.traverse).traverse) %~ toUpper 73 | -- ["HELlo","World"] 74 | -- 75 | -- The resulting 'Traversal' of the 'levels' which is indexed by the depth of each 'Level'. 76 | -- 77 | -- >>> ["dog","cat"]^@..levels (traverse.traverse) <. traverse 78 | -- [(2,'d'),(3,'o'),(3,'c'),(4,'g'),(4,'a'),(5,'t')] 79 | -- 80 | -- @ 81 | -- 'levels' :: 'Traversal' s t a b -> 'IndexedTraversal' 'Int' s t ('Level' () a) ('Level' () b) 82 | -- 'levels' :: 'Fold' s a -> 'IndexedFold' 'Int' s ('Level' () a) 83 | -- @ 84 | -- 85 | -- /Note:/ Internally this is implemented by using an illegal 'Applicative', as it extracts information 86 | -- in an order that violates the 'Applicative' laws. 87 | levels :: Applicative f 88 | => Traversing (->) f s t a b 89 | -> IndexedLensLike Int f s t (Level () a) (Level () b) 90 | levels l f s = levelOuts bz <$> traversed f (levelIns bz) where 91 | bz = l sell s 92 | {-# INLINE levels #-} 93 | 94 | -- This is only a temporary work around added to deal with a bug in an unreleased version 95 | -- of GHC 7.10. We should remove it as soon as we're able. 96 | rmapConst :: Profunctor p => p a b -> p a (Const b x) 97 | rmapConst p = Const #. p 98 | {-# INLINE rmapConst #-} 99 | 100 | ilevelIns :: BazaarT (Indexed i) f a b t -> [Level i a] 101 | ilevelIns = go 0 . (getConst #. bazaar (Indexed $ \ i -> rmapConst (deepening i))) where 102 | go k z = k `seq` runDeepening z k $ \ xs b -> 103 | xs : if b then (go $! k + 1) z else [] 104 | {-# INLINE ilevelIns #-} 105 | 106 | ilevelOuts :: BazaarT (Indexed i) f a b t -> [Level j b] -> t 107 | ilevelOuts bz = runFlows $ runBazaarT bz $ Indexed $ \ _ _ -> Flows $ \t -> case t of 108 | One _ a : _ -> a 109 | _ -> error "ilevelOuts: wrong shape" 110 | {-# INLINE ilevelOuts #-} 111 | 112 | -- | This provides a breadth-first 'Traversal' or 'Fold' of the individual 113 | -- levels of any other 'Traversal' or 'Fold' via iterative deepening depth-first 114 | -- search. The levels are returned to you in a compressed format. 115 | -- 116 | -- This is similar to 'levels', but retains the index of the original 'IndexedTraversal', so you can 117 | -- access it when traversing the levels later on. 118 | -- 119 | -- >>> ["dog","cat"]^@..ilevels (traversed<.>traversed).itraversed 120 | -- [((0,0),'d'),((0,1),'o'),((1,0),'c'),((0,2),'g'),((1,1),'a'),((1,2),'t')] 121 | -- 122 | -- The resulting 'Traversal' of the levels which is indexed by the depth of each 'Level'. 123 | -- 124 | -- >>> ["dog","cat"]^@..ilevels (traversed<.>traversed)<.>itraversed 125 | -- [((2,(0,0)),'d'),((3,(0,1)),'o'),((3,(1,0)),'c'),((4,(0,2)),'g'),((4,(1,1)),'a'),((5,(1,2)),'t')] 126 | -- 127 | -- @ 128 | -- 'ilevels' :: 'IndexedTraversal' i s t a b -> 'IndexedTraversal' 'Int' s t ('Level' i a) ('Level' i b) 129 | -- 'ilevels' :: 'IndexedFold' i s a -> 'IndexedFold' 'Int' s ('Level' i a) 130 | -- @ 131 | -- 132 | -- /Note:/ Internally this is implemented by using an illegal 'Applicative', as it extracts information 133 | -- in an order that violates the 'Applicative' laws. 134 | ilevels :: Applicative f 135 | => Traversing (Indexed i) f s t a b 136 | -> IndexedLensLike Int f s t (Level i a) (Level j b) 137 | ilevels l f s = ilevelOuts bz <$> traversed f (ilevelIns bz) where 138 | bz = l sell s 139 | {-# INLINE ilevels #-} 140 | -------------------------------------------------------------------------------- /src/Control/Lens/Operators.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Control.Lens.Operators 4 | -- Copyright : (C) 2012-16 Edward Kmett 5 | -- License : BSD-style (see the file LICENSE) 6 | -- Maintainer : Edward Kmett 7 | -- Stability : experimental 8 | -- Portability : non-portable 9 | -- 10 | -- This module exists for users who like to work with qualified imports 11 | -- but want access to the operators from Lens. 12 | -- 13 | -- > import qualified Control.Lens as L 14 | -- > import Control.Lens.Operators 15 | ---------------------------------------------------------------------------- 16 | module Control.Lens.Operators 17 | ( -- output from scripts/operators -h 18 | -- * "Control.Lens.Cons" 19 | (<|) 20 | , (|>) 21 | , (<|~) 22 | , (<|=) 23 | , (<<|~) 24 | , (<<|=) 25 | , (<<<|~) 26 | , (<<<|=) 27 | , (|>~) 28 | , (|>=) 29 | , (<|>~) 30 | , (<|>=) 31 | , (<<|>~) 32 | , (<<|>=) 33 | -- * "Control.Lens.Fold" 34 | , (^..) 35 | , (^?) 36 | , (^?!) 37 | , (^@..) 38 | , (^@?) 39 | , (^@?!) 40 | -- * "Control.Lens.Getter" 41 | , (^.) 42 | , (^@.) 43 | -- * "Control.Lens.Indexed" 44 | , (<.) 45 | , (.>) 46 | , (<.>) 47 | -- * "Control.Lens.Lens" 48 | , (%%~) 49 | , (%%=) 50 | , (&) 51 | , (&~) 52 | , (<&>) 53 | , (??) 54 | , (<%~) 55 | , (<+~) 56 | , (<-~) 57 | , (<*~) 58 | , (~) 77 | , (<<<>:~) 78 | , (<%=) 79 | , (<+=) 80 | , (<-=) 81 | , (<*=) 82 | , (=) 101 | , (<<<>:=) 102 | , (<<~) 103 | , (<<>~) 104 | , (<<>=) 105 | , (<<>:~) 106 | , (<<>:=) 107 | , (<%@~) 108 | , (<<%@~) 109 | , (%%@~) 110 | , (%%@=) 111 | , (<%@=) 112 | , (<<%@=) 113 | , (^#) 114 | , (#~) 115 | , (#%~) 116 | , (#%%~) 117 | , (#=) 118 | , (#%=) 119 | , (<#%~) 120 | , (<#%=) 121 | , (#%%=) 122 | , (<#~) 123 | , (<#=) 124 | -- * "Control.Lens.Plated" 125 | , (...) 126 | -- * "Control.Lens.Review" 127 | , (#) 128 | -- * "Control.Lens.Setter" 129 | , (%~) 130 | , (.~) 131 | , (?~) 132 | , (<.~) 133 | , (~) 159 | , (<>=) 160 | , (<>:~) 161 | , (<>:=) 162 | , (.@~) 163 | , (.@=) 164 | , (%@~) 165 | , (%@=) 166 | ) where 167 | 168 | import Control.Lens 169 | -------------------------------------------------------------------------------- /src/Control/Lens/Profunctor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | ------------------------------------------------------------------------------- 3 | -- | This module provides conversion functions between the optics defined in 4 | -- this library and 'Profunctor'-based optics. 5 | -- 6 | -- The goal of these functions is to provide an interoperability layer between 7 | -- the two styles of optics, and not to reimplement all the library in terms of 8 | -- 'Profunctor' optics. 9 | 10 | module Control.Lens.Profunctor 11 | ( -- * Profunctor optic 12 | OpticP 13 | 14 | -- * Conversion from Van Laarhoven optics 15 | , fromLens 16 | , fromIso 17 | , fromPrism 18 | , fromSetter 19 | , fromTraversal 20 | 21 | -- * Conversion to Van Laarhoven optics 22 | , toLens 23 | , toIso 24 | , toPrism 25 | , toSetter 26 | , toTraversal 27 | ) where 28 | 29 | import Prelude () 30 | 31 | import Control.Lens.Internal.Prelude 32 | import Control.Lens.Type (Optic, LensLike) 33 | import Control.Lens.Internal.Context (Context (..), sell) 34 | import Control.Lens.Internal.Profunctor (WrappedPafb (..)) 35 | import Control.Lens (ASetter, ATraversal, cloneTraversal, Settable) 36 | import Data.Profunctor (Star (..)) 37 | import Data.Profunctor.Mapping (Mapping (..)) 38 | import Data.Profunctor.Traversing (Traversing (..)) 39 | 40 | -- | Profunctor optic. 41 | type OpticP p s t a b = p a b -> p s t 42 | 43 | -------------------------------------------------------------------------------- 44 | -- Conversion from Van Laarhoven optics 45 | -------------------------------------------------------------------------------- 46 | 47 | -- | Converts a 'Control.Lens.Type.Lens' to a 'Profunctor'-based one. 48 | -- 49 | -- @ 50 | -- 'fromLens' :: 'Control.Lens.Type.Lens' s t a b -> LensP s t a b 51 | -- @ 52 | fromLens :: Strong p => LensLike (Context a b) s t a b -> OpticP p s t a b 53 | fromLens l p = 54 | dimap 55 | (\s -> let Context f a = l sell s in (f, a)) 56 | (uncurry id) 57 | (second' p) 58 | 59 | -- | Converts a 'Control.Lens.Type.Iso' to a 'Profunctor'-based one. 60 | -- 61 | -- @ 62 | -- 'fromIso' :: 'Control.Lens.Type.Iso' s t a b -> IsoP s t a b 63 | -- @ 64 | fromIso :: Profunctor p => Optic p Identity s t a b -> OpticP p s t a b 65 | fromIso p pab = rmap runIdentity (p (rmap Identity pab)) 66 | 67 | -- | Converts a 'Control.Lens.Type.Prism' to a 'Profunctor'-based one. 68 | -- 69 | -- @ 70 | -- 'fromPrism' :: 'Control.Lens.Type.Prism' s t a b -> PrismP s t a b 71 | -- @ 72 | fromPrism :: Choice p => Optic p Identity s t a b -> OpticP p s t a b 73 | fromPrism p pab = rmap runIdentity (p (rmap Identity pab)) 74 | 75 | -- | Converts a 'Control.Lens.Type.Setter' to a 'Profunctor'-based one. 76 | -- 77 | -- @ 78 | -- 'fromSetter' :: 'Control.Lens.Type.Setter' s t a b -> SetterP s t a b 79 | -- @ 80 | fromSetter :: Mapping p => ASetter s t a b -> OpticP p s t a b 81 | fromSetter s = roam s' 82 | where 83 | s' f = runIdentity . s (Identity . f) 84 | 85 | -- | Converts a 'Control.Lens.Type.Traversal' to a 'Profunctor'-based one. 86 | -- 87 | -- @ 88 | -- 'fromTraversal' :: 'Control.Lens.Type.Traversal' s t a b -> TraversalP s t a b 89 | -- @ 90 | fromTraversal :: Traversing p => ATraversal s t a b -> OpticP p s t a b 91 | fromTraversal l = wander (cloneTraversal l) 92 | 93 | -------------------------------------------------------------------------------- 94 | -- Conversion to Van Laarhoven optics 95 | -------------------------------------------------------------------------------- 96 | 97 | -- | Obtain a 'Control.Lens.Type.Prism' from a 'Profunctor'-based one. 98 | -- 99 | -- @ 100 | -- 'toPrism' :: PrismP s t a b -> 'Control.Lens.Type.Prism' s t a b 101 | -- @ 102 | toPrism :: (Choice p, Applicative f) => OpticP (WrappedPafb f p) s t a b -> Optic p f s t a b 103 | toPrism p = unwrapPafb . p . WrapPafb 104 | 105 | -- | Obtain a 'Control.Lens.Type.Iso' from a 'Profunctor'-based one. 106 | -- 107 | -- @ 108 | -- 'toIso' :: IsoP s t a b -> 'Control.Lens.Type.Iso' s t a b 109 | -- @ 110 | toIso :: (Profunctor p, Functor f) => OpticP (WrappedPafb f p) s t a b -> Optic p f s t a b 111 | toIso p = unwrapPafb . p . WrapPafb 112 | 113 | -- | Obtain a 'Control.Lens.Type.Lens' from a 'Profunctor'-based one. 114 | -- 115 | -- @ 116 | -- 'toLens' :: LensP s t a b -> 'Control.Lens.Type.Lens' s t a b 117 | -- @ 118 | toLens :: Functor f => OpticP (Star f) s t a b -> LensLike f s t a b 119 | toLens p = runStar . p . Star 120 | 121 | -- | Obtain a 'Control.Lens.Type.Setter' from a 'Profunctor'-based one. 122 | -- 123 | -- @ 124 | -- 'toSetter' :: SetterP s t a b -> 'Control.Lens.Type.Setter' s t a b 125 | -- @ 126 | toSetter :: Settable f => OpticP (Star f) s t a b -> LensLike f s t a b 127 | toSetter p = runStar . p . Star 128 | 129 | -- | Obtain a 'Control.Lens.Type.Traversal' from a 'Profunctor'-based one. 130 | -- 131 | -- @ 132 | -- 'toTraversal' :: TraversalP s t a b -> 'Control.Lens.Type.Traversal' s t a b 133 | -- @ 134 | toTraversal :: Applicative f => OpticP (Star f) s t a b -> LensLike f s t a b 135 | toTraversal p = runStar . p . Star 136 | -------------------------------------------------------------------------------- /src/Control/Lens/Unsound.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE Trustworthy #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | 9 | {-# OPTIONS_GHC -Wno-warnings-deprecations #-} 10 | 11 | ------------------------------------------------------------------------------- 12 | -- | 13 | -- Module : Control.Lens.Unsound 14 | -- Copyright : (C) 2012-16 Edward Kmett 15 | -- License : BSD-style (see the file LICENSE) 16 | -- Maintainer : Edward Kmett 17 | -- Stability : provisional 18 | -- Portability : Rank2Types 19 | -- 20 | -- One commonly asked question is: can we combine two lenses, 21 | -- @'Lens'' a b@ and @'Lens'' a c@ into @'Lens'' a (b, c)@. 22 | -- This is fair thing to ask, but such operation is unsound in general. 23 | -- See `lensProduct`. 24 | -- 25 | ------------------------------------------------------------------------------- 26 | module Control.Lens.Unsound 27 | ( 28 | lensProduct 29 | , prismSum 30 | , adjoin 31 | ) where 32 | 33 | import Control.Lens 34 | import Control.Lens.Internal.Prelude 35 | import Prelude () 36 | 37 | -- $setup 38 | -- >>> :set -XNoOverloadedStrings 39 | -- >>> import Control.Lens 40 | 41 | -- | A lens product. There is no law-abiding way to do this in general. 42 | -- Result is only a valid t'Lens' if the input lenses project disjoint parts of 43 | -- the structure @s@. Otherwise "you get what you put in" law 44 | -- 45 | -- @ 46 | -- 'Control.Lens.Getter.view' l ('Control.Lens.Setter.set' l v s) ≡ v 47 | -- @ 48 | -- 49 | -- is violated by 50 | -- 51 | -- >>> let badLens :: Lens' (Int, Char) (Int, Int); badLens = lensProduct _1 _1 52 | -- >>> view badLens (set badLens (1,2) (3,'x')) 53 | -- (2,2) 54 | -- 55 | -- but we should get @(1,2)@. 56 | -- 57 | -- Are you looking for 'Control.Lens.Lens.alongside'? 58 | -- 59 | lensProduct :: ALens' s a -> ALens' s b -> Lens' s (a, b) 60 | lensProduct l1 l2 f s = 61 | f (s ^# l1, s ^# l2) <&> \(a, b) -> s & l1 #~ a & l2 #~ b 62 | 63 | -- | A dual of `lensProduct`: a prism sum. 64 | -- 65 | -- The law 66 | -- 67 | -- @ 68 | -- 'Control.Lens.Fold.preview' l ('Control.Lens.Review.review' l b) ≡ 'Just' b 69 | -- @ 70 | -- 71 | -- breaks with 72 | -- 73 | -- >>> let badPrism :: Prism' (Maybe Char) (Either Char Char); badPrism = prismSum _Just _Just 74 | -- >>> preview badPrism (review badPrism (Right 'x')) 75 | -- Just (Left 'x') 76 | -- 77 | -- We put in 'Right' value, but get back 'Left'. 78 | -- 79 | -- Are you looking for 'Control.Lens.Prism.without'? 80 | -- 81 | prismSum :: APrism s t a b 82 | -> APrism s t c d 83 | -> Prism s t (Either a c) (Either b d) 84 | prismSum k k' = 85 | withPrism k $ \bt seta -> 86 | withPrism k' $ \dt setb -> 87 | prism (either bt dt) $ \s -> 88 | f (Left <$> seta s) (Right <$> setb s) 89 | where 90 | f a@(Right _) _ = a 91 | f (Left _) b = b 92 | 93 | -- | A generalization of `mappend`ing folds: A union of disjoint traversals. 94 | -- 95 | -- Traversing the same entry twice is illegal. 96 | -- 97 | -- Are you looking for 'Control.Lens.Traversal.failing'? 98 | -- 99 | adjoin :: Traversal' s a -> Traversal' s a -> Traversal' s a 100 | adjoin t1 t2 = 101 | lensProduct (partsOf t1) (partsOf t2) . both . each 102 | -------------------------------------------------------------------------------- /src/Control/Parallel/Strategies/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #ifdef TRUSTWORTHY 3 | {-# LANGUAGE Trustworthy #-} 4 | #endif 5 | 6 | #include "lens-common.h" 7 | 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Control.Parallel.Strategies.Lens 11 | -- Copyright : (C) 2012-2016 Edward Kmett 12 | -- License : BSD-style (see the file LICENSE) 13 | -- Maintainer : Edward Kmett 14 | -- Stability : provisional 15 | -- Portability : portable 16 | -- 17 | -- A t'Lens' or t'Traversal' can be used to take the role of 'Traversable' in 18 | -- @Control.Parallel.Strategies@, enabling those combinators to work with 19 | -- monomorphic containers. 20 | ---------------------------------------------------------------------------- 21 | module Control.Parallel.Strategies.Lens 22 | ( evalOf 23 | , parOf 24 | , after 25 | , throughout 26 | ) where 27 | 28 | import Control.Lens 29 | import Control.Parallel.Strategies 30 | 31 | -- | Evaluate the targets of a t'Lens' or t'Traversal' into a data structure 32 | -- according to the given 'Strategy'. 33 | -- 34 | -- @ 35 | -- 'evalTraversable' = 'evalOf' 'traverse' = 'traverse' 36 | -- 'evalOf' = 'id' 37 | -- @ 38 | -- 39 | -- @ 40 | -- 'evalOf' :: 'Lens'' s a -> 'Strategy' a -> 'Strategy' s 41 | -- 'evalOf' :: 'Traversal'' s a -> 'Strategy' a -> 'Strategy' s 42 | -- 'evalOf' :: (a -> 'Eval' a) -> s -> 'Eval' s) -> 'Strategy' a -> 'Strategy' s 43 | -- @ 44 | evalOf :: LensLike' Eval s a -> Strategy a -> Strategy s 45 | evalOf l = l 46 | {-# INLINE evalOf #-} 47 | 48 | -- | Evaluate the targets of a t'Lens' or t'Traversal' according into a 49 | -- data structure according to a given 'Strategy' in parallel. 50 | -- 51 | -- @'parTraversable' = 'parOf' 'traverse'@ 52 | -- 53 | -- @ 54 | -- 'parOf' :: 'Lens'' s a -> 'Strategy' a -> 'Strategy' s 55 | -- 'parOf' :: 'Traversal'' s a -> 'Strategy' a -> 'Strategy' s 56 | -- 'parOf' :: ((a -> 'Eval' a) -> s -> 'Eval' s) -> 'Strategy' a -> 'Strategy' s 57 | -- @ 58 | parOf :: LensLike' Eval s a -> Strategy a -> Strategy s 59 | parOf l s = l (rparWith s) 60 | {-# INLINE parOf #-} 61 | 62 | -- | Transform a t'Lens', t'Fold', t'Getter', t'Setter' or t'Traversal' to 63 | -- first evaluates its argument according to a given 'Strategy' /before/ proceeding. 64 | -- 65 | -- @ 66 | -- 'after' 'rdeepseq' 'traverse' :: 'Traversable' t => 'Strategy' a -> 'Strategy' [a] 67 | -- @ 68 | after :: Strategy s -> LensLike f s t a b -> LensLike f s t a b 69 | after s l f = l f $| s 70 | {-# INLINE after #-} 71 | 72 | -- | Transform a t'Lens', t'Fold', t'Getter', t'Setter' or t'Traversal' to 73 | -- evaluate its argument according to a given 'Strategy' /in parallel with/ evaluating. 74 | -- 75 | -- @ 76 | -- 'throughout' 'rdeepseq' 'traverse' :: 'Traversable' t => 'Strategy' a -> 'Strategy' [a] 77 | -- @ 78 | throughout :: Strategy s -> LensLike f s t a b -> LensLike f s t a b 79 | throughout s l f = l f $|| s 80 | {-# INLINE throughout #-} 81 | -------------------------------------------------------------------------------- /src/Control/Seq/Lens.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Control.Seq.Lens 4 | -- Copyright : (C) 2012-16 Edward Kmett 5 | -- License : BSD-style (see the file LICENSE) 6 | -- Maintainer : Edward Kmett 7 | -- Stability : provisional 8 | -- Portability : portable 9 | -- 10 | -- A t'Fold' can be used to take the role of 'Foldable' in @Control.Seq@. 11 | ---------------------------------------------------------------------------- 12 | module Control.Seq.Lens 13 | ( seqOf 14 | ) where 15 | 16 | import Control.Lens 17 | import Control.Seq 18 | import Data.Monoid 19 | 20 | -- | Evaluate the elements targeted by a t'Lens', t'Traversal', t'Iso', 21 | -- t'Getter' or t'Fold' according to the given strategy. 22 | -- 23 | -- @'seqFoldable' = 'seqOf' 'folded'@ 24 | seqOf :: Getting (Endo [a]) s a -> Strategy a -> Strategy s 25 | seqOf l s = seqList s . toListOf l 26 | {-# INLINE seqOf #-} 27 | -------------------------------------------------------------------------------- /src/Data/Array/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Array.Lens 5 | -- Copyright : (C) 2012-16 Edward Kmett 6 | -- License : BSD-style (see the file LICENSE) 7 | -- Maintainer : Edward Kmett 8 | -- Stability : provisional 9 | -- Portability : MPTCs, Rank2Types, LiberalTypeSynonyms 10 | -- 11 | ---------------------------------------------------------------------------- 12 | module Data.Array.Lens 13 | ( 14 | -- * Setters 15 | ixmapped 16 | ) where 17 | 18 | import Control.Lens 19 | import Data.Array.IArray hiding (index) 20 | 21 | -- | This t'Setter' can be used to derive a new 'IArray' from an old 'IArray' by 22 | -- applying a function to each of the indices to look it up in the old 'IArray'. 23 | -- 24 | -- This is a /contravariant/ t'Setter'. 25 | -- 26 | -- @ 27 | -- 'ixmap' ≡ 'over' '.' 'ixmapped' 28 | -- 'ixmapped' ≡ 'setting' '.' 'ixmap' 29 | -- 'over' ('ixmapped' b) f arr '!' i ≡ arr '!' f i 30 | -- 'bounds' ('over' ('ixmapped' b) f arr) ≡ b 31 | -- @ 32 | ixmapped :: (IArray a e, Ix i, Ix j) => (i,i) -> IndexPreservingSetter (a j e) (a i e) i j 33 | ixmapped i = setting $ ixmap i 34 | {-# INLINE ixmapped #-} 35 | -------------------------------------------------------------------------------- /src/Data/ByteString/Lazy/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | {-# LANGUAGE PatternSynonyms #-} 5 | 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Data.ByteString.Lazy.Lens 9 | -- Copyright : (C) 2012-2016 Edward Kmett 10 | -- License : BSD-style (see the file LICENSE) 11 | -- Maintainer : Edward Kmett 12 | -- Stability : experimental 13 | -- Portability : non-portable 14 | -- 15 | -- Lazy 'ByteString' lenses. 16 | ---------------------------------------------------------------------------- 17 | module Data.ByteString.Lazy.Lens 18 | ( packedBytes, unpackedBytes, bytes 19 | , packedChars, unpackedChars, chars 20 | , pattern Bytes 21 | , pattern Chars 22 | ) where 23 | 24 | import Control.Lens 25 | import Control.Lens.Internal.ByteString 26 | import Data.ByteString.Lazy (ByteString) 27 | import qualified Data.ByteString.Lazy as Words 28 | import qualified Data.ByteString.Lazy.Char8 as Char8 29 | import Data.Word (Word8) 30 | import Data.Int (Int64) 31 | 32 | -- $setup 33 | -- >>> :set -XOverloadedStrings 34 | -- >>> import Control.Lens 35 | -- >>> import Numeric.Lens 36 | -- >>> import qualified Data.ByteString.Lazy.Char8 as Char8 37 | 38 | -- | 'Data.ByteString.Lazy.pack' (or 'Data.ByteString.Lazy.unpack') a list of bytes into a 'ByteString'. 39 | -- 40 | -- @ 41 | -- 'packedBytes' ≡ 'from' 'unpackedBytes' 42 | -- 'Data.ByteString.pack' x ≡ x '^.' 'packedBytes' 43 | -- 'Data.ByteString.unpack' x ≡ x '^.' 'from' 'packedBytes' 44 | -- @ 45 | -- 46 | -- >>> [104,101,108,108,111]^.packedBytes == Char8.pack "hello" 47 | -- True 48 | packedBytes :: Iso' [Word8] ByteString 49 | packedBytes = iso Words.pack Words.unpack 50 | {-# INLINE packedBytes #-} 51 | 52 | -- | 'Data.ByteString.Lazy.unpack' (or 'Data.ByteString.Lazy.pack') a 'ByteString' into a list of bytes 53 | -- 54 | -- @ 55 | -- 'unpackedBytes' ≡ 'from' 'packedBytes' 56 | -- 'Data.ByteString.unpack' x ≡ x '^.' 'unpackedBytes' 57 | -- 'Data.ByteString.pack' x ≡ x '^.' 'from' 'unpackedBytes' 58 | -- @ 59 | -- 60 | -- >>> "hello"^.packedChars.unpackedBytes 61 | -- [104,101,108,108,111] 62 | unpackedBytes :: Iso' ByteString [Word8] 63 | unpackedBytes = from packedBytes 64 | {-# INLINE unpackedBytes #-} 65 | 66 | -- | Traverse the individual bytes in a 'ByteString'. 67 | -- 68 | -- This t'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion 69 | -- enable zippers to seek to locations more quickly and accelerate 70 | -- many monoidal queries, but up to associativity (and constant factors) it is 71 | -- equivalent to the much slower: 72 | -- 73 | -- @ 74 | -- 'bytes' ≡ 'unpackedBytes' '.' 'traversed' 75 | -- @ 76 | -- 77 | -- >>> anyOf bytes (== 0x80) (Char8.pack "hello") 78 | -- False 79 | -- 80 | -- Note that when just using this as a t'Setter', @'setting' 'Data.ByteString.Lazy.map'@ 81 | -- can be more efficient. 82 | bytes :: IndexedTraversal' Int64 ByteString Word8 83 | bytes = traversedLazy 84 | {-# INLINE bytes #-} 85 | 86 | -- | 'Data.ByteString.Lazy.Char8.pack' (or 'Data.ByteString.Lazy.Char8.unpack') a list of characters into a 'ByteString'. 87 | -- 88 | -- When writing back to the 'ByteString' it is assumed that every 'Char' 89 | -- lies between @'\x00'@ and @'\xff'@. 90 | -- 91 | -- @ 92 | -- 'packedChars' ≡ 'from' 'unpackedChars' 93 | -- 'Data.ByteString.Char8.pack' x ≡ x '^.' 'packedChars' 94 | -- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'from' 'packedChars' 95 | -- @ 96 | -- 97 | -- >>> "hello"^.packedChars.each.re (base 16 . enum).to (\x -> if Prelude.length x == 1 then '0':x else x) 98 | -- "68656c6c6f" 99 | packedChars :: Iso' String ByteString 100 | packedChars = iso Char8.pack Char8.unpack 101 | {-# INLINE packedChars #-} 102 | 103 | -- | 'Data.ByteString.Lazy.Char8.unpack' (or 'Data.ByteString.Lazy.Char8.pack') a list of characters into a 'ByteString' 104 | -- 105 | -- When writing back to the 'ByteString' it is assumed that every 'Char' 106 | -- lies between @'\x00'@ and @'\xff'@. 107 | -- 108 | -- @ 109 | -- 'unpackedChars' ≡ 'from' 'packedChars' 110 | -- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'unpackedChars' 111 | -- 'Data.ByteString.Char8.pack' x ≡ x '^.' 'from' 'unpackedChars' 112 | -- @ 113 | -- 114 | -- >>> [104,101,108,108,111]^.packedBytes.unpackedChars 115 | -- "hello" 116 | unpackedChars :: Iso' ByteString String 117 | unpackedChars = from packedChars 118 | {-# INLINE unpackedChars #-} 119 | 120 | -- | Traverse the individual bytes in a 'ByteString' as characters. 121 | -- 122 | -- When writing back to the 'ByteString' it is assumed that every 'Char' 123 | -- lies between @'\x00'@ and @'\xff'@. 124 | -- 125 | -- This t'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion 126 | -- enable zippers to seek to locations more quickly and accelerate 127 | -- many monoidal queries, but up to associativity (and constant factors) it is 128 | -- equivalent to: 129 | -- 130 | -- @ 131 | -- 'chars' = 'unpackedChars' '.' 'traversed' 132 | -- @ 133 | -- 134 | -- >>> anyOf chars (== 'h') "hello" 135 | -- True 136 | chars :: IndexedTraversal' Int64 ByteString Char 137 | chars = traversedLazy8 138 | {-# INLINE chars #-} 139 | 140 | pattern Bytes :: [Word8] -> ByteString 141 | pattern Bytes b <- (view unpackedBytes -> b) where 142 | Bytes b = review unpackedBytes b 143 | 144 | pattern Chars :: String -> ByteString 145 | pattern Chars b <- (view unpackedChars -> b) where 146 | Chars b = review unpackedChars b 147 | -------------------------------------------------------------------------------- /src/Data/ByteString/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | {-# LANGUAGE PatternSynonyms #-} 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Data.ByteString.Lens 8 | -- Copyright : (C) 2012-16 Edward Kmett 9 | -- License : BSD-style (see the file LICENSE) 10 | -- Maintainer : Edward Kmett 11 | -- Stability : experimental 12 | -- Portability : non-portable 13 | -- 14 | ---------------------------------------------------------------------------- 15 | module Data.ByteString.Lens 16 | ( IsByteString(..) 17 | , unpackedBytes 18 | , unpackedChars 19 | , pattern Bytes 20 | , pattern Chars 21 | ) where 22 | 23 | import Control.Lens 24 | import Data.Word (Word8) 25 | import qualified Data.ByteString as Strict 26 | import qualified Data.ByteString.Strict.Lens as Strict 27 | import qualified Data.ByteString.Lazy as Lazy 28 | import qualified Data.ByteString.Lazy.Lens as Lazy 29 | 30 | -- | Traversals for ByteStrings. 31 | class IsByteString t where 32 | -- | 'Data.ByteString.pack' (or 'Data.ByteString.unpack') a list of bytes into a strict or lazy 'ByteString'. 33 | -- 34 | -- @ 35 | -- 'Data.ByteString.pack' x ≡ x '^.' 'packedBytes' 36 | -- 'Data.ByteString.unpack' x ≡ x '^.' 'from' 'packedBytes' 37 | -- 'packedBytes' ≡ 'from' 'unpackedBytes' 38 | -- @ 39 | packedBytes :: Iso' [Word8] t 40 | 41 | -- | 'Data.ByteString.Char8.pack' (or 'Data.ByteString.Char8.unpack') a list of characters into a strict or lazy 'ByteString'. 42 | -- 43 | -- When writing back to the 'ByteString' it is assumed that every 'Char' 44 | -- lies between @'\x00'@ and @'\xff'@. 45 | -- 46 | -- @ 47 | -- 'Data.ByteString.Char8.pack' x ≡ x '^.' 'packedChars' 48 | -- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'from' 'packedChars' 49 | -- 'packedChars' ≡ 'from' 'unpackedChars' 50 | -- @ 51 | packedChars :: Iso' String t 52 | 53 | -- | Traverse each 'Word8' in a strict or lazy 'ByteString' 54 | -- 55 | -- 56 | -- This t'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion 57 | -- enable zippers to seek to locations more quickly and accelerate 58 | -- many monoidal queries, but up to associativity (and constant factors) it is 59 | -- equivalent to the much slower: 60 | -- 61 | -- @ 62 | -- 'bytes' ≡ 'unpackedBytes' '.' 'traversed' 63 | -- @ 64 | -- 65 | -- @ 66 | -- 'anyOf' 'bytes' ('==' 0x80) :: 'ByteString' -> 'Bool' 67 | -- @ 68 | bytes :: IndexedTraversal' Int t Word8 69 | bytes = from packedBytes . traversed 70 | {-# INLINE bytes #-} 71 | 72 | -- | Traverse the individual bytes in a strict or lazy 'ByteString' as characters. 73 | -- 74 | -- When writing back to the 'ByteString' it is assumed that every 'Char' 75 | -- lies between @'\x00'@ and @'\xff'@. 76 | -- 77 | -- This t'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion 78 | -- enable zippers to seek to locations more quickly and accelerate 79 | -- many monoidal queries, but up to associativity (and constant factors) it is 80 | -- equivalent to the much slower: 81 | -- 82 | -- @ 83 | -- 'chars' ≡ 'unpackedChars' '.' 'traversed' 84 | -- @ 85 | -- 86 | -- @ 87 | -- 'anyOf' 'chars' ('==' \'c\') :: 'ByteString' -> 'Bool' 88 | -- @ 89 | chars :: IndexedTraversal' Int t Char 90 | chars = from packedChars . traversed 91 | {-# INLINE chars #-} 92 | 93 | -- | 'Data.ByteString.unpack' (or 'Data.ByteString.pack') a 'ByteString' into a list of bytes 94 | -- 95 | -- @ 96 | -- 'unpackedBytes' ≡ 'from' 'packedBytes' 97 | -- 'Data.ByteString.unpack' x ≡ x '^.' 'unpackedBytes' 98 | -- 'Data.ByteString.pack' x ≡ x '^.' 'from' 'unpackedBytes' 99 | -- @ 100 | -- 101 | -- @ 102 | -- 'unpackedBytes' :: 'Iso'' 'Data.ByteString.ByteString' ['Word8'] 103 | -- 'unpackedBytes' :: 'Iso'' 'Data.ByteString.Lazy.ByteString' ['Word8'] 104 | -- @ 105 | unpackedBytes :: IsByteString t => Iso' t [Word8] 106 | unpackedBytes = from packedBytes 107 | {-# INLINE unpackedBytes #-} 108 | 109 | pattern Bytes :: IsByteString s => [Word8] -> s 110 | pattern Bytes b <- (view unpackedBytes -> b) where 111 | Bytes b = review unpackedBytes b 112 | 113 | pattern Chars :: IsByteString s => String -> s 114 | pattern Chars b <- (view unpackedChars -> b) where 115 | Chars b = review unpackedChars b 116 | 117 | -- | 'Data.ByteString.Char8.unpack' (or 'Data.ByteString.Char8.pack') a list of characters into a strict (or lazy) 'ByteString' 118 | -- 119 | -- When writing back to the 'ByteString' it is assumed that every 'Char' 120 | -- lies between @'\x00'@ and @'\xff'@. 121 | -- 122 | -- @ 123 | -- 'unpackedChars' ≡ 'from' 'packedChars' 124 | -- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'unpackedChars' 125 | -- 'Data.ByteString.Char8.pack' x ≡ x '^.' 'from' 'unpackedChars' 126 | -- @ 127 | -- 128 | -- @ 129 | -- 'unpackedChars' :: 'Iso'' 'Data.ByteString.ByteString' 'String' 130 | -- 'unpackedChars' :: 'Iso'' 'Data.ByteString.Lazy.ByteString' 'String' 131 | -- @ 132 | unpackedChars :: IsByteString t => Iso' t String 133 | unpackedChars = from packedChars 134 | {-# INLINE unpackedChars #-} 135 | 136 | instance IsByteString Strict.ByteString where 137 | packedBytes = Strict.packedBytes 138 | {-# INLINE packedBytes #-} 139 | packedChars = Strict.packedChars 140 | {-# INLINE packedChars #-} 141 | bytes = Strict.bytes 142 | {-# INLINE bytes #-} 143 | chars = Strict.chars 144 | {-# INLINE chars #-} 145 | 146 | instance IsByteString Lazy.ByteString where 147 | packedBytes = Lazy.packedBytes 148 | {-# INLINE packedBytes #-} 149 | packedChars = Lazy.packedChars 150 | {-# INLINE packedChars #-} 151 | bytes = from packedBytes . traversed 152 | {-# INLINE bytes #-} 153 | chars = from packedChars . traversed 154 | {-# INLINE chars #-} 155 | -------------------------------------------------------------------------------- /src/Data/ByteString/Strict/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | {-# LANGUAGE PatternSynonyms #-} 5 | 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Data.ByteString.Strict.Lens 9 | -- Copyright : (C) 2012-2016 Edward Kmett 10 | -- License : BSD-style (see the file LICENSE) 11 | -- Maintainer : Edward Kmett 12 | -- Stability : experimental 13 | -- Portability : non-portable 14 | -- 15 | ---------------------------------------------------------------------------- 16 | module Data.ByteString.Strict.Lens 17 | ( packedBytes, unpackedBytes, bytes 18 | , packedChars, unpackedChars, chars 19 | , pattern Bytes 20 | , pattern Chars 21 | ) where 22 | 23 | import Control.Lens 24 | import Control.Lens.Internal.ByteString 25 | import Data.ByteString (ByteString) 26 | import qualified Data.ByteString as Words 27 | import qualified Data.ByteString.Char8 as Char8 28 | import Data.Word 29 | 30 | -- $setup 31 | -- >>> :set -XOverloadedStrings 32 | -- >>> import Control.Lens 33 | -- >>> import Numeric.Lens 34 | -- >>> import qualified Data.ByteString.Char8 as Char8 35 | 36 | -- | 'Data.ByteString.pack' (or 'Data.ByteString.unpack') a list of bytes into a 'ByteString' 37 | -- 38 | -- @ 39 | -- 'packedBytes' ≡ 'from' 'unpackedBytes' 40 | -- 'Data.ByteString.pack' x ≡ x '^.' 'packedBytes' 41 | -- 'Data.ByteString.unpack' x ≡ x '^.' 'from' 'packedBytes' 42 | -- @ 43 | -- 44 | -- >>> [104,101,108,108,111]^.packedBytes 45 | -- "hello" 46 | packedBytes :: Iso' [Word8] ByteString 47 | packedBytes = iso Words.pack Words.unpack 48 | {-# INLINE packedBytes #-} 49 | 50 | -- | 'Data.ByteString.unpack' (or 'Data.ByteString.pack') a 'ByteString' into a list of bytes 51 | -- 52 | -- @ 53 | -- 'unpackedBytes' ≡ 'from' 'packedBytes' 54 | -- 'Data.ByteString.unpack' x ≡ x '^.' 'unpackedBytes' 55 | -- 'Data.ByteString.pack' x ≡ x '^.' 'from' 'unpackedBytes' 56 | -- @ 57 | -- 58 | -- >>> "hello"^.packedChars.unpackedBytes 59 | -- [104,101,108,108,111] 60 | unpackedBytes :: Iso' ByteString [Word8] 61 | unpackedBytes = from packedBytes 62 | {-# INLINE unpackedBytes #-} 63 | 64 | -- | Traverse each 'Word8' in a 'ByteString'. 65 | -- 66 | -- This t'Traversal' walks the 'ByteString' in a tree-like fashion 67 | -- enable zippers to seek to locations in logarithmic time and accelerating 68 | -- many monoidal queries, but up to associativity (and constant factors) 69 | -- it is equivalent to the much slower: 70 | -- 71 | -- @ 72 | -- 'bytes' ≡ 'unpackedBytes' '.' 'traversed' 73 | -- @ 74 | -- 75 | -- >>> anyOf bytes (== 0x80) (Char8.pack "hello") 76 | -- False 77 | -- 78 | -- Note that when just using this as a t'Setter', @'setting' 'Data.ByteString.map'@ 79 | -- can be more efficient. 80 | bytes :: IndexedTraversal' Int ByteString Word8 81 | bytes = traversedStrictTree 82 | {-# INLINE bytes #-} 83 | 84 | -- | 'Data.ByteString.Char8.pack' (or 'Data.ByteString.Char8.unpack') a list of characters into a 'ByteString' 85 | -- 86 | -- When writing back to the 'ByteString' it is assumed that every 'Char' 87 | -- lies between @'\x00'@ and @'\xff'@. 88 | -- 89 | -- @ 90 | -- 'packedChars' ≡ 'from' 'unpackedChars' 91 | -- 'Data.ByteString.Char8.pack' x ≡ x '^.' 'packedChars' 92 | -- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'from' 'packedChars' 93 | -- @ 94 | -- 95 | -- >>> "hello"^.packedChars.each.re (base 16 . enum).to (\x -> if Prelude.length x == 1 then '0':x else x) 96 | -- "68656c6c6f" 97 | packedChars :: Iso' String ByteString 98 | packedChars = iso Char8.pack Char8.unpack 99 | {-# INLINE packedChars #-} 100 | 101 | -- | 'Data.ByteString.Char8.unpack' (or 'Data.ByteString.Char8.pack') a list of characters into a 'ByteString' 102 | -- 103 | -- When writing back to the 'ByteString' it is assumed that every 'Char' 104 | -- lies between @'\x00'@ and @'\xff'@. 105 | -- 106 | -- @ 107 | -- 'unpackedChars' ≡ 'from' 'packedChars' 108 | -- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'unpackedChars' 109 | -- 'Data.ByteString.Char8.pack' x ≡ x '^.' 'from' 'unpackedChars' 110 | -- @ 111 | -- 112 | -- >>> [104,101,108,108,111]^.packedBytes.unpackedChars 113 | -- "hello" 114 | unpackedChars :: Iso' ByteString String 115 | unpackedChars = from packedChars 116 | {-# INLINE unpackedChars #-} 117 | 118 | -- | Traverse the individual bytes in a 'ByteString' as characters. 119 | -- 120 | -- When writing back to the 'ByteString' it is assumed that every 'Char' 121 | -- lies between @'\x00'@ and @'\xff'@. 122 | -- 123 | -- This t'Traversal' walks the 'ByteString' in a tree-like fashion 124 | -- enable zippers to seek to locations in logarithmic time and accelerating 125 | -- many monoidal queries, but up to associativity (and constant factors) 126 | -- it is equivalent to the much slower: 127 | -- 128 | -- @ 129 | -- 'chars' = 'unpackedChars' '.' 'traverse' 130 | -- @ 131 | -- 132 | -- >>> anyOf chars (== 'h') "hello" 133 | -- True 134 | chars :: IndexedTraversal' Int ByteString Char 135 | chars = traversedStrictTree8 136 | {-# INLINE chars #-} 137 | 138 | pattern Bytes :: [Word8] -> ByteString 139 | pattern Bytes b <- (view unpackedBytes -> b) where 140 | Bytes b = review unpackedBytes b 141 | 142 | pattern Chars :: String -> ByteString 143 | pattern Chars b <- (view unpackedChars -> b) where 144 | Chars b = review unpackedChars b 145 | -------------------------------------------------------------------------------- /src/Data/Complex/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | {-# LANGUAGE PatternSynonyms #-} 5 | 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Data.Complex.Lens 9 | -- Copyright : (C) 2012-16 Edward Kmett 10 | -- License : BSD-style (see the file LICENSE) 11 | -- Maintainer : Edward Kmett 12 | -- Stability : experimental 13 | -- Portability : non-portable 14 | -- 15 | -- Lenses and traversals for complex numbers 16 | -- 17 | ---------------------------------------------------------------------------- 18 | module Data.Complex.Lens 19 | ( _realPart 20 | , _imagPart 21 | , _polar 22 | , _magnitude 23 | , _phase 24 | , _conjugate 25 | -- * Pattern Synonyms 26 | , pattern Polar 27 | , pattern Real 28 | , pattern Imaginary 29 | , pattern Conjugate 30 | ) where 31 | 32 | import Prelude () 33 | 34 | import Control.Lens 35 | import Control.Lens.Internal.Prelude 36 | import Data.Complex 37 | 38 | -- $setup 39 | -- >>> import Control.Lens 40 | -- >>> import Data.Complex 41 | -- >>> import Debug.SimpleReflect 42 | -- >>> let { a ≈ b = abs (a - b) < 1e-6; infix 4 ≈ } 43 | 44 | -- | Access the 'realPart' of a 'Complex' number. 45 | -- 46 | -- >>> (a :+ b)^._realPart 47 | -- a 48 | -- 49 | -- >>> a :+ b & _realPart *~ 2 50 | -- a * 2 :+ b 51 | -- 52 | -- @'_realPart' :: 'Functor' f => (a -> f a) -> 'Complex' a -> f ('Complex' a)@ 53 | _realPart :: Lens' (Complex a) a 54 | _realPart f (a :+ b) = (:+ b) <$> f a 55 | {-# INLINE _realPart #-} 56 | 57 | -- | Access the 'imagPart' of a 'Complex' number. 58 | -- 59 | -- >>> (a :+ b)^._imagPart 60 | -- b 61 | -- 62 | -- >>> a :+ b & _imagPart *~ 2 63 | -- a :+ b * 2 64 | -- 65 | -- @'_imagPart' :: 'Functor' f => (a -> f a) -> 'Complex' a -> f ('Complex' a)@ 66 | _imagPart :: Lens' (Complex a) a 67 | _imagPart f (a :+ b) = (a :+) <$> f b 68 | {-# INLINE _imagPart #-} 69 | 70 | -- | This isn't /quite/ a legal t'Lens'. Notably the 71 | -- 72 | -- @'view' l ('set' l b a) = b@ 73 | -- 74 | -- law is violated when you set a 'polar' value with 0 'magnitude' and non-zero 75 | -- 'phase' as the 'phase' information is lost, or with a negative 'magnitude' 76 | -- which flips the 'phase' and retains a positive 'magnitude'. So don't do 77 | -- that! 78 | -- 79 | -- Otherwise, this is a perfectly cromulent t'Lens'. 80 | _polar :: RealFloat a => Iso' (Complex a) (a,a) 81 | _polar = iso polar (uncurry mkPolar) 82 | {-# INLINE _polar #-} 83 | 84 | pattern Polar :: RealFloat a => a -> a -> Complex a 85 | pattern Polar m theta <- (view _polar -> (m, theta)) where 86 | Polar m theta = review _polar (m, theta) 87 | 88 | pattern Real :: (Eq a, Num a) => a -> Complex a 89 | pattern Real r = r :+ 0 90 | 91 | pattern Imaginary :: (Eq a, Num a) => a -> Complex a 92 | pattern Imaginary i = 0 :+ i 93 | 94 | -- | Access the 'magnitude' of a 'Complex' number. 95 | -- 96 | -- >>> (10.0 :+ 20.0) & _magnitude *~ 2 97 | -- 20.0 :+ 40.0 98 | -- 99 | -- This isn't /quite/ a legal t'Lens'. Notably the 100 | -- 101 | -- @'view' l ('set' l b a) = b@ 102 | -- 103 | -- law is violated when you set a negative 'magnitude'. This flips the 'phase' 104 | -- and retains a positive 'magnitude'. So don't do that! 105 | -- 106 | -- Otherwise, this is a perfectly cromulent t'Lens'. 107 | -- 108 | -- Setting the 'magnitude' of a zero 'Complex' number assumes the 'phase' is 0. 109 | _magnitude :: RealFloat a => Lens' (Complex a) a 110 | _magnitude f c = setMag <$> f r 111 | where setMag r' | r /= 0 = c * (r' / r :+ 0) 112 | | otherwise = r' :+ 0 113 | r = magnitude c 114 | {-# INLINE _magnitude #-} 115 | 116 | -- | Access the 'phase' of a 'Complex' number. 117 | -- 118 | -- >>> (mkPolar 10 (2-pi) & _phase +~ pi & view _phase) ≈ 2 119 | -- True 120 | -- 121 | -- This isn't /quite/ a legal t'Lens'. Notably the 122 | -- 123 | -- @'view' l ('set' l b a) = b@ 124 | -- 125 | -- law is violated when you set a 'phase' outside the range @(-'pi', 'pi']@. 126 | -- The phase is always in that range when queried. So don't do that! 127 | -- 128 | -- Otherwise, this is a perfectly cromulent t'Lens'. 129 | _phase :: RealFloat a => Lens' (Complex a) a 130 | _phase f c = setPhase <$> f theta 131 | where setPhase theta' = c * cis (theta' - theta) 132 | theta = phase c 133 | {-# INLINE _phase #-} 134 | 135 | -- | Access the 'conjugate' of a 'Complex' number. 136 | -- 137 | -- >>> (2.0 :+ 3.0) & _conjugate . _imagPart -~ 1 138 | -- 2.0 :+ 4.0 139 | -- 140 | -- >>> (mkPolar 10.0 2.0 ^. _conjugate . _phase) ≈ (-2.0) 141 | -- True 142 | _conjugate :: RealFloat a => Iso' (Complex a) (Complex a) 143 | _conjugate = involuted conjugate 144 | {-# INLINE _conjugate #-} 145 | 146 | pattern Conjugate :: Num a => Complex a -> Complex a 147 | pattern Conjugate a <- (conjugate -> a) where 148 | Conjugate a = conjugate a 149 | -------------------------------------------------------------------------------- /src/Data/Dynamic/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Data.Dynamic.Lens 8 | -- Copyright : (C) 2012-2016 Edward Kmett 9 | -- License : BSD-style (see the file LICENSE) 10 | -- Maintainer : Edward Kmett 11 | -- Stability : experimental 12 | -- Portability : non-portable 13 | -- 14 | ---------------------------------------------------------------------------- 15 | module Data.Dynamic.Lens 16 | ( AsDynamic(..) 17 | , pattern Data.Dynamic.Lens.Dynamic 18 | ) where 19 | 20 | import Control.Exception 21 | import Control.Exception.Lens 22 | import Control.Lens 23 | import Data.Dynamic 24 | 25 | -- | Any t'Dynamic' can be thrown as an t'Exception' 26 | class AsDynamic t where 27 | -- | This t'Prism' allows you to traverse the typed value contained in a 28 | -- t'Dynamic' where the type required by your function matches that 29 | -- of the contents of the t'Dynamic', or construct a t'Dynamic' value 30 | -- out of whole cloth. It can also be used to catch or throw a t'Dynamic' 31 | -- value as 'SomeException'. 32 | -- 33 | -- @ 34 | -- '_Dynamic' :: 'Typeable' a => 'Prism'' t'Dynamic' a 35 | -- '_Dynamic' :: 'Typeable' a => 'Prism'' 'SomeException' a 36 | -- @ 37 | _Dynamic :: Typeable a => Prism' t a 38 | 39 | instance AsDynamic Dynamic where 40 | _Dynamic = prism' toDyn fromDynamic 41 | {-# INLINE _Dynamic #-} 42 | 43 | instance AsDynamic SomeException where 44 | _Dynamic = exception.prism' toDyn fromDynamic 45 | {-# INLINE _Dynamic #-} 46 | 47 | pattern Dynamic :: (AsDynamic s, Typeable a) => a -> s 48 | pattern Dynamic a <- (preview _Dynamic -> Just a) where 49 | Dynamic a = review _Dynamic a 50 | -------------------------------------------------------------------------------- /src/Data/HashSet/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.HashSet.Lens 5 | -- Copyright : (C) 2012-16 Edward Kmett 6 | -- License : BSD-style (see the file LICENSE) 7 | -- Maintainer : Edward Kmett 8 | -- Stability : provisional 9 | -- Portability : portable 10 | -- 11 | ---------------------------------------------------------------------------- 12 | module Data.HashSet.Lens 13 | ( setmapped 14 | , setOf 15 | , hashMap 16 | ) where 17 | 18 | import Control.Lens.Getter (Getting, views) 19 | import Control.Lens.Iso (iso) 20 | import Control.Lens.Setter (setting) 21 | import Control.Lens.Type 22 | import qualified Data.HashSet as HashSet 23 | import Data.HashSet (HashSet, fromMap, toMap) 24 | import Data.HashMap.Lazy (HashMap) 25 | import Data.Hashable 26 | 27 | -- $setup 28 | -- >>> :set -XNoOverloadedStrings 29 | -- >>> import Control.Lens 30 | 31 | -- | This 'Setter' can be used to change the type of a 'HashSet' by mapping 32 | -- the elements to new values. 33 | -- 34 | -- Sadly, you can't create a valid 'Traversal' for a 'Set', but you can 35 | -- manipulate it by reading using 'Control.Lens.Fold.folded' and reindexing it via 'setmapped'. 36 | setmapped :: (Eq j, Hashable j) => IndexPreservingSetter (HashSet i) (HashSet j) i j 37 | setmapped = setting HashSet.map 38 | {-# INLINE setmapped #-} 39 | 40 | -- | Construct a set from a 'Getter', 'Control.Lens.Fold.Fold', 'Control.Lens.Traversal.Traversal', 'Control.Lens.Lens.Lens' or 'Control.Lens.Iso.Iso'. 41 | -- 42 | -- @ 43 | -- 'setOf' :: 'Hashable' a => 'Getter' s a -> s -> 'HashSet' a 44 | -- 'setOf' :: ('Eq' a, 'Hashable' a) => 'Fold' s a -> s -> 'HashSet' a 45 | -- 'setOf' :: 'Hashable' a => 'Iso'' s a -> s -> 'HashSet' a 46 | -- 'setOf' :: 'Hashable' a => 'Lens'' s a -> s -> 'HashSet' a 47 | -- 'setOf' :: ('Eq' a, 'Hashable' a) => 'Traversal'' s a -> s -> 'HashSet' a 48 | -- @ 49 | setOf :: Hashable a => Getting (HashSet a) s a -> s -> HashSet a 50 | setOf l = views l HashSet.singleton 51 | {-# INLINE setOf #-} 52 | 53 | -- | An `Iso` between a `HashSet` and a `HashMap` with unit values. \(\mathcal{O}(1)\). 54 | hashMap :: Iso' (HashSet a) (HashMap a ()) 55 | hashMap = iso toMap fromMap 56 | -------------------------------------------------------------------------------- /src/Data/IntSet/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.IntSet.Lens 5 | -- Copyright : (C) 2012-16 Edward Kmett 6 | -- License : BSD-style (see the file LICENSE) 7 | -- Maintainer : Edward Kmett 8 | -- Stability : provisional 9 | -- Portability : portable 10 | -- 11 | ---------------------------------------------------------------------------- 12 | module Data.IntSet.Lens 13 | ( members 14 | , setmapped 15 | , setOf 16 | ) where 17 | 18 | import Control.Lens 19 | import qualified Data.IntSet as IntSet 20 | import Data.IntSet (IntSet) 21 | 22 | -- $setup 23 | -- >>> :set -XNoOverloadedStrings 24 | -- >>> import Control.Lens 25 | -- >>> import qualified Data.IntSet as IntSet 26 | 27 | -- | IntSet isn't Foldable, but this t'Fold' can be used to access the members of an 'IntSet'. 28 | -- 29 | -- >>> sumOf members $ setOf folded [1,2,3,4] 30 | -- 10 31 | members :: Fold IntSet Int 32 | members = folding IntSet.toAscList 33 | {-# INLINE members #-} 34 | 35 | -- | This t'Setter' can be used to change the contents of an 'IntSet' by mapping 36 | -- the elements to new values. 37 | -- 38 | -- Sadly, you can't create a valid t'Traversal' for an 'IntSet', because the number of 39 | -- elements might change but you can manipulate it by reading using 'folded' and 40 | -- reindexing it via 'setmapped'. 41 | -- 42 | -- >>> over setmapped (+1) (IntSet.fromList [1,2,3,4]) 43 | -- fromList [2,3,4,5] 44 | setmapped :: IndexPreservingSetter' IntSet Int 45 | setmapped = setting IntSet.map 46 | {-# INLINE setmapped #-} 47 | 48 | -- | Construct an 'IntSet' from a t'Getter', t'Fold', t'Traversal', t'Lens' or t'Iso'. 49 | -- 50 | -- >>> setOf folded [1,2,3,4] 51 | -- fromList [1,2,3,4] 52 | -- 53 | -- >>> setOf (folded._2) [("hello",1),("world",2),("!!!",3)] 54 | -- fromList [1,2,3] 55 | -- 56 | -- @ 57 | -- 'setOf' :: t'Getter' s 'Int' -> s -> 'IntSet' 58 | -- 'setOf' :: t'Fold' s 'Int' -> s -> 'IntSet' 59 | -- 'setOf' :: t'Iso'' s 'Int' -> s -> 'IntSet' 60 | -- 'setOf' :: t'Lens'' s 'Int' -> s -> 'IntSet' 61 | -- 'setOf' :: t'Traversal'' s 'Int' -> s -> 'IntSet' 62 | -- @ 63 | setOf :: Getting IntSet s Int -> s -> IntSet 64 | setOf l = views l IntSet.singleton 65 | {-# INLINE setOf #-} 66 | -------------------------------------------------------------------------------- /src/Data/List/Lens.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.List.Lens 4 | -- Copyright : (C) 2012-16 Edward Kmett 5 | -- License : BSD-style (see the file LICENSE) 6 | -- Maintainer : Edward Kmett 7 | -- Stability : provisional 8 | -- Portability : portable 9 | -- 10 | -- Traversals for manipulating parts of a list. 11 | -- 12 | -- Additional optics for manipulating lists are present more 13 | -- generically in this package. 14 | -- 15 | -- The 'Control.Lens.At.Ixed' class allows traversing the element at a 16 | -- specific list index. 17 | -- 18 | -- >>> [0..10] ^? ix 4 19 | -- Just 4 20 | -- 21 | -- >>> [0..5] & ix 4 .~ 2 22 | -- [0,1,2,3,2,5] 23 | -- 24 | -- >>> [0..10] ^? ix 14 25 | -- Nothing 26 | -- 27 | -- >>> [0..5] & ix 14 .~ 2 28 | -- [0,1,2,3,4,5] 29 | -- 30 | -- The 'Control.Lens.Cons.Cons' and 'Control.Lens.Empty.AsEmpty' 31 | -- classes provide 'Control.Lens.Prism.Prism's for list constructors. 32 | -- 33 | -- >>> [1..10] ^? _Cons 34 | -- Just (1,[2,3,4,5,6,7,8,9,10]) 35 | -- 36 | -- >>> [] ^? _Cons 37 | -- Nothing 38 | -- 39 | -- >>> [] ^? _Empty 40 | -- Just () 41 | -- 42 | -- >>> _Cons # (1, _Empty # ()) :: [Int] 43 | -- [1] 44 | -- 45 | -- Additionally, 'Control.Lens.Cons.Snoc' provides a 46 | -- 'Control.Lens.Prism.Prism' for accessing the end of a list. Note 47 | -- that this 'Control.Lens.Prism.Prism' always will need to traverse 48 | -- the whole list. 49 | -- 50 | -- >>> [1..5] ^? _Snoc 51 | -- Just ([1,2,3,4],5) 52 | -- 53 | -- >>> _Snoc # ([1,2],5) 54 | -- [1,2,5] 55 | -- 56 | -- An instance of 'Control.Lens.Plated.Plated' allows for finding 57 | -- locations in the list where a traversal matches. 58 | -- 59 | -- >>> [Nothing, Just 7, Just 3, Nothing] & deep (ix 0 . _Just) +~ 10 60 | -- [Nothing,Just 17,Just 3,Nothing] 61 | -- 62 | -- An instance of 'Control.Lens.Iso.Reversing' provides an 63 | -- 'Control.Lens.Iso.Iso' between a list and its reverse. 64 | -- 65 | -- >>> "live" & reversed %~ ('d':) 66 | -- "lived" 67 | -- 68 | -- It's possible to work under a prefix or suffix of a list using 69 | -- 'Control.Lens.Prism.Prefixed' and 'Control.Lens.Prism.Suffixed'. 70 | -- 71 | -- >>> "preview" ^? prefixed "pre" 72 | -- Just "view" 73 | -- 74 | -- >>> suffixed ".o" # "hello" 75 | -- "hello.o" 76 | -- 77 | -- At present, "Data.List.Lens" re-exports 'Prefixed' and 'Suffixed' for 78 | -- backwards compatibility, as 'prefixed' and 'suffixed' used to be top-level 79 | -- functions defined in this module. This may change in a future major release 80 | -- of @lens@. 81 | -- 82 | -- Finally, it's possible to traverse, fold over, and map over 83 | -- index-value pairs thanks to instances of 84 | -- 'Control.Lens.Indexed.TraversableWithIndex', 85 | -- 'Control.Lens.Indexed.FoldableWithIndex', and 86 | -- 'Control.Lens.Indexed.FunctorWithIndex'. 87 | -- 88 | -- >>> imap (,) "Hello" 89 | -- [(0,'H'),(1,'e'),(2,'l'),(3,'l'),(4,'o')] 90 | -- 91 | -- >>> ifoldMap replicate "Hello" 92 | -- "ellllloooo" 93 | -- 94 | -- >>> itraverse_ (curry print) "Hello" 95 | -- (0,'H') 96 | -- (1,'e') 97 | -- (2,'l') 98 | -- (3,'l') 99 | -- (4,'o') 100 | -- 101 | ---------------------------------------------------------------------------- 102 | module Data.List.Lens 103 | ( Prefixed(..) 104 | , Suffixed(..) 105 | , stripSuffix 106 | ) where 107 | 108 | import Control.Lens.Prism (Prefixed(..), Suffixed(..)) 109 | import Control.Lens.Internal.List (stripSuffix) 110 | 111 | --- $setup 112 | --- >>> :set -XNoOverloadedStrings 113 | --- >>> import Control.Lens 114 | -------------------------------------------------------------------------------- /src/Data/Map/Lens.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Copyright : (C) 2014-2016 Edward Kmett 4 | -- License : BSD-style (see the file LICENSE) 5 | -- Maintainer : Edward Kmett 6 | -- Stability : experimental 7 | -- Portability : non-portable 8 | -- 9 | -- One of most commonly-asked questions about this package is whether 10 | -- it provides lenses for working with 'Data.Map.Map'. It does, but their uses 11 | -- are perhaps obscured by their genericity. This module exists to provide 12 | -- documentation for them. 13 | -- 14 | -- 'Data.Map.Map' is an instance of 'Control.Lens.At.At', so we have a lenses 15 | -- on values at keys: 16 | -- 17 | -- >>> Map.fromList [(1, "world")] ^.at 1 18 | -- Just "world" 19 | -- 20 | -- >>> at 1 .~ Just "world" $ Map.empty 21 | -- fromList [(1,"world")] 22 | -- 23 | -- >>> at 0 ?~ "hello" $ Map.empty 24 | -- fromList [(0,"hello")] 25 | -- 26 | -- We can traverse, fold over, and map over key-value pairs in a 27 | -- 'Data.Map.Map', thanks to its 'Control.Lens.Indexed.TraversableWithIndex', 28 | -- 'Control.Lens.Indexed.FoldableWithIndex', and 29 | -- 'Control.Lens.Indexed.FunctorWithIndex' instances. 30 | -- 31 | -- >>> imap const $ Map.fromList [(1, "Venus")] 32 | -- fromList [(1,1)] 33 | -- 34 | -- >>> ifoldMap (\i _ -> Sum i) $ Map.fromList [(2, "Earth"), (3, "Mars")] 35 | -- Sum {getSum = 5} 36 | -- 37 | -- >>> itraverse_ (curry print) $ Map.fromList [(4, "Jupiter")] 38 | -- (4,"Jupiter") 39 | -- 40 | -- >>> itoList $ Map.fromList [(5, "Saturn")] 41 | -- [(5,"Saturn")] 42 | -- 43 | -- A related class, 'Control.Lens.At.Ixed', allows us to use 44 | -- 'Control.Lens.At.ix' to traverse a value at a particular key. 45 | -- 46 | -- >>> ix 2 %~ ("New " ++) $ Map.fromList [(2, "Earth")] 47 | -- fromList [(2,"New Earth")] 48 | -- 49 | -- >>> preview (ix 8) $ Map.empty 50 | -- Nothing 51 | -- 52 | -- Additionally, 'Data.Map.Map' has 'Control.Lens.Traversal.TraverseMin' and 53 | -- 'Control.Lens.Traversal.TraverseMax' instances, which let us traverse over 54 | -- the value at the least and greatest keys, respectively. 55 | -- 56 | -- >>> preview traverseMin $ Map.fromList [(5, "Saturn"), (6, "Uranus")] 57 | -- Just "Saturn" 58 | -- 59 | -- >>> preview traverseMax $ Map.fromList [(5, "Saturn"), (6, "Uranus")] 60 | -- Just "Uranus" 61 | -- 62 | ----------------------------------------------------------------------------- 63 | module Data.Map.Lens 64 | ( toMapOf 65 | ) where 66 | 67 | import Control.Lens.Getter ( IndexedGetting, iviews ) 68 | import qualified Data.Map as Map 69 | 70 | -- $setup 71 | -- >>> import Control.Lens 72 | -- >>> import Data.Monoid 73 | -- >>> import qualified Data.Map as Map 74 | -- >>> :set -XNoOverloadedStrings 75 | 76 | -- | Construct a map from a 'IndexedGetter', 'Control.Lens.Fold.IndexedFold', 'Control.Lens.Traversal.IndexedTraversal' or 'Control.Lens.Lens.IndexedLens' 77 | -- 78 | -- The construction is left-biased (see 'Data.Map.Lazy.union'), i.e. the first 79 | -- occurrences of keys in the fold or traversal order are preferred. 80 | -- 81 | -- >>> toMapOf folded ["hello", "world"] 82 | -- fromList [(0,"hello"),(1,"world")] 83 | -- 84 | -- >>> toMapOf (folded . ifolded) [('a',"alpha"),('b', "beta")] 85 | -- fromList [('a',"alpha"),('b',"beta")] 86 | -- 87 | -- >>> toMapOf (folded <.> folded) ["foo", "bar"] 88 | -- fromList [((0,0),'f'),((0,1),'o'),((0,2),'o'),((1,0),'b'),((1,1),'a'),((1,2),'r')] 89 | -- 90 | -- >>> toMapOf ifolded $ Map.fromList [('a', "hello"), ('b', "world")] 91 | -- fromList [('a',"hello"),('b',"world")] 92 | -- 93 | -- @ 94 | -- 'toMapOf' :: 'IndexedGetter' i s a -> s -> 'Map.Map' i a 95 | -- 'toMapOf' :: 'Ord' i => 'IndexedFold' i s a -> s -> 'Map.Map' i a 96 | -- 'toMapOf' :: 'IndexedLens'' i s a -> s -> 'Map.Map' i a 97 | -- 'toMapOf' :: 'Ord' i => 'IndexedTraversal'' i s a -> s -> 'Map.Map' i a 98 | -- @ 99 | toMapOf :: IndexedGetting i (Map.Map i a) s a -> s -> Map.Map i a 100 | toMapOf l = iviews l Map.singleton 101 | -------------------------------------------------------------------------------- /src/Data/Sequence/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Data.Sequence.Lens 6 | -- Copyright : (C) 2012-16 Edward Kmett 7 | -- License : BSD-style (see the file LICENSE) 8 | -- Maintainer : Edward Kmett 9 | -- Stability : experimental 10 | -- Portability : non-portable 11 | -- 12 | ---------------------------------------------------------------------------- 13 | module Data.Sequence.Lens 14 | ( viewL, viewR 15 | , sliced, slicedTo, slicedFrom 16 | , seqOf 17 | ) where 18 | 19 | import Control.Applicative 20 | import Control.Lens 21 | import Data.Monoid 22 | import qualified Data.Sequence as Seq 23 | import Data.Sequence (Seq, ViewL(EmptyL), ViewR(EmptyR), (><), viewl, viewr) 24 | import Prelude 25 | 26 | -- $setup 27 | -- >>> import Control.Lens 28 | -- >>> import qualified Data.Sequence as Seq 29 | -- >>> import Data.Sequence (ViewL(EmptyL), ViewR(EmptyR)) 30 | -- >>> import Debug.SimpleReflect.Expr 31 | -- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) 32 | -- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f 33 | -- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g 34 | 35 | -- * Sequence isomorphisms 36 | 37 | -- | A 'Seq' is isomorphic to a 'ViewL' 38 | -- 39 | -- @'viewl' m ≡ m '^.' 'viewL'@ 40 | -- 41 | -- >>> Seq.fromList [a,b,c] ^. viewL 42 | -- a :< fromList [b,c] 43 | -- 44 | -- >>> Seq.empty ^. viewL 45 | -- EmptyL 46 | -- 47 | -- >>> EmptyL ^. from viewL 48 | -- fromList [] 49 | -- 50 | -- >>> review viewL $ a Seq.:< Seq.fromList [b,c] 51 | -- fromList [a,b,c] 52 | viewL :: Iso (Seq a) (Seq b) (ViewL a) (ViewL b) 53 | viewL = iso viewl $ \ xs -> case xs of 54 | EmptyL -> mempty 55 | a Seq.:< as -> a Seq.<| as 56 | {-# INLINE viewL #-} 57 | 58 | -- | A 'Seq' is isomorphic to a 'ViewR' 59 | -- 60 | -- @'viewr' m ≡ m '^.' 'viewR'@ 61 | -- 62 | -- >>> Seq.fromList [a,b,c] ^. viewR 63 | -- fromList [a,b] :> c 64 | -- 65 | -- >>> Seq.empty ^. viewR 66 | -- EmptyR 67 | -- 68 | -- >>> EmptyR ^. from viewR 69 | -- fromList [] 70 | -- 71 | -- >>> review viewR $ Seq.fromList [a,b] Seq.:> c 72 | -- fromList [a,b,c] 73 | viewR :: Iso (Seq a) (Seq b) (ViewR a) (ViewR b) 74 | viewR = iso viewr $ \xs -> case xs of 75 | EmptyR -> mempty 76 | as Seq.:> a -> as Seq.|> a 77 | {-# INLINE viewR #-} 78 | 79 | -- | Traverse the first @n@ elements of a 'Seq' 80 | -- 81 | -- >>> Seq.fromList [a,b,c,d,e] ^.. slicedTo 2 82 | -- [a,b] 83 | -- 84 | -- >>> Seq.fromList [a,b,c,d,e] & slicedTo 2 %~ f 85 | -- fromList [f a,f b,c,d,e] 86 | -- 87 | -- >>> Seq.fromList [a,b,c,d,e] & slicedTo 10 .~ x 88 | -- fromList [x,x,x,x,x] 89 | slicedTo :: Int -> IndexedTraversal' Int (Seq a) a 90 | slicedTo n f m = case Seq.splitAt n m of 91 | (l,r) -> (>< r) <$> itraverse (indexed f) l 92 | {-# INLINE slicedTo #-} 93 | 94 | -- | Traverse all but the first @n@ elements of a 'Seq' 95 | -- 96 | -- >>> Seq.fromList [a,b,c,d,e] ^.. slicedFrom 2 97 | -- [c,d,e] 98 | -- 99 | -- >>> Seq.fromList [a,b,c,d,e] & slicedFrom 2 %~ f 100 | -- fromList [a,b,f c,f d,f e] 101 | -- 102 | -- >>> Seq.fromList [a,b,c,d,e] & slicedFrom 10 .~ x 103 | -- fromList [a,b,c,d,e] 104 | slicedFrom :: Int -> IndexedTraversal' Int (Seq a) a 105 | slicedFrom n f m = case Seq.splitAt n m of 106 | (l,r) -> (l ><) <$> itraverse (indexed f . (+n)) r 107 | {-# INLINE slicedFrom #-} 108 | 109 | -- | Traverse all the elements numbered from @i@ to @j@ of a 'Seq' 110 | -- 111 | -- >>> Seq.fromList [a,b,c,d,e] & sliced 1 3 %~ f 112 | -- fromList [a,f b,f c,d,e] 113 | 114 | -- >>> Seq.fromList [a,b,c,d,e] ^.. sliced 1 3 115 | -- [f b,f c] 116 | -- 117 | -- >>> Seq.fromList [a,b,c,d,e] & sliced 1 3 .~ x 118 | -- fromList [a,x,x,b,e] 119 | sliced :: Int -> Int -> IndexedTraversal' Int (Seq a) a 120 | sliced i j f s = case Seq.splitAt i s of 121 | (l,mr) -> case Seq.splitAt (j-i) mr of 122 | (m, r) -> itraverse (indexed f . (+i)) m <&> \n -> l >< n >< r 123 | {-# INLINE sliced #-} 124 | 125 | -- | Construct a 'Seq' from a t'Getter', 'Control.Lens.Fold.Fold', 'Control.Lens.Traversal.Traversal', 'Control.Lens.Lens.Lens' or 'Control.Lens.Iso.Iso'. 126 | -- 127 | -- >>> seqOf folded ["hello","world"] 128 | -- fromList ["hello","world"] 129 | -- 130 | -- >>> seqOf (folded._2) [("hello",1),("world",2),("!!!",3)] 131 | -- fromList [1,2,3] 132 | -- 133 | -- @ 134 | -- 'seqOf' :: t'Getter' s a -> s -> 'Seq' a 135 | -- 'seqOf' :: t'Fold' s a -> s -> 'Seq' a 136 | -- 'seqOf' :: 'Iso'' s a -> s -> 'Seq' a 137 | -- 'seqOf' :: 'Lens'' s a -> s -> 'Seq' a 138 | -- 'seqOf' :: 'Traversal'' s a -> s -> 'Seq' a 139 | -- @ 140 | seqOf :: Getting (Seq a) s a -> s -> Seq a 141 | seqOf l = views l Seq.singleton 142 | {-# INLINE seqOf #-} 143 | -------------------------------------------------------------------------------- /src/Data/Set/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | 4 | {-# LANGUAGE Trustworthy #-} 5 | 6 | #include "lens-common.h" 7 | 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Data.Set.Lens 11 | -- Copyright : (C) 2012-16 Edward Kmett 12 | -- License : BSD-style (see the file LICENSE) 13 | -- Maintainer : Edward Kmett 14 | -- Stability : provisional 15 | -- Portability : portable 16 | -- 17 | ---------------------------------------------------------------------------- 18 | module Data.Set.Lens 19 | ( setmapped 20 | , setOf 21 | ) where 22 | 23 | import Control.Lens.Getter ( Getting, views ) 24 | import Control.Lens.Setter ( setting ) 25 | import Control.Lens.Type 26 | import qualified Data.Set as Set 27 | import Data.Set (Set) 28 | 29 | 30 | -- $setup 31 | -- >>> :set -XNoOverloadedStrings 32 | -- >>> import Control.Lens 33 | -- >>> import qualified Data.Set as Set 34 | 35 | -- | This 'Setter' can be used to change the type of a 'Set' by mapping 36 | -- the elements to new values. 37 | -- 38 | -- Sadly, you can't create a valid 'Traversal' for a 'Set', but you can 39 | -- manipulate it by reading using 'Control.Lens.Fold.folded' and reindexing it via 'setmapped'. 40 | -- 41 | -- >>> over setmapped (+1) (Set.fromList [1,2,3,4]) 42 | -- fromList [2,3,4,5] 43 | setmapped :: Ord j => IndexPreservingSetter (Set i) (Set j) i j 44 | setmapped = setting Set.map 45 | {-# INLINE setmapped #-} 46 | 47 | -- | Construct a set from a 'Getter', 'Control.Lens.Fold.Fold', 'Control.Lens.Traversal.Traversal', 'Control.Lens.Lens.Lens' or 'Control.Lens.Iso.Iso'. 48 | -- 49 | -- >>> setOf folded ["hello","world"] 50 | -- fromList ["hello","world"] 51 | -- 52 | -- >>> setOf (folded._2) [("hello",1),("world",2),("!!!",3)] 53 | -- fromList [1,2,3] 54 | -- 55 | -- @ 56 | -- 'setOf' :: 'Getter' s a -> s -> 'Set' a 57 | -- 'setOf' :: 'Ord' a => 'Fold' s a -> s -> 'Set' a 58 | -- 'setOf' :: 'Iso'' s a -> s -> 'Set' a 59 | -- 'setOf' :: 'Lens'' s a -> s -> 'Set' a 60 | -- 'setOf' :: 'Ord' a => 'Traversal'' s a -> s -> 'Set' a 61 | -- @ 62 | setOf :: Getting (Set a) s a -> s -> Set a 63 | setOf l = views l Set.singleton 64 | {-# INLINE setOf #-} 65 | -------------------------------------------------------------------------------- /src/Data/Text/Lazy/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE PatternSynonyms #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Data.Text.Lazy.Lens 9 | -- Copyright : (C) 2012-2016 Edward Kmett 10 | -- License : BSD-style (see the file LICENSE) 11 | -- Maintainer : Edward Kmett 12 | -- Stability : experimental 13 | -- Portability : non-portable 14 | -- 15 | ---------------------------------------------------------------------------- 16 | module Data.Text.Lazy.Lens 17 | ( packed, unpacked 18 | , _Text 19 | , text 20 | , builder 21 | , utf8 22 | , pattern Text 23 | ) where 24 | 25 | import Control.Lens.Type 26 | import Control.Lens.Getter 27 | import Control.Lens.Fold 28 | import Control.Lens.Iso 29 | import Control.Lens.Prism 30 | import Control.Lens.Review 31 | import Control.Lens.Setter 32 | import Control.Lens.Traversal 33 | import Data.ByteString.Lazy (ByteString) 34 | import Data.Monoid 35 | import Data.Text.Lazy (Text) 36 | import qualified Data.Text.Lazy as Text 37 | import qualified Data.Text.Lazy.Builder as Builder 38 | import Data.Text.Lazy.Builder (Builder) 39 | import Data.Text.Lazy.Encoding 40 | 41 | -- $setup 42 | -- >>> :set -XOverloadedStrings 43 | -- >>> import Control.Lens 44 | -- >>> import qualified Data.ByteString.Lazy as ByteString 45 | 46 | -- | This isomorphism can be used to 'pack' (or 'unpack') lazy 'Text'. 47 | -- 48 | -- >>> "hello"^.packed -- :: Text 49 | -- "hello" 50 | -- 51 | -- @ 52 | -- 'pack' x ≡ x '^.' 'packed' 53 | -- 'unpack' x ≡ x '^.' 'from' 'packed' 54 | -- 'packed' ≡ 'from' 'unpacked' 55 | -- @ 56 | packed :: Iso' String Text 57 | packed = iso Text.pack Text.unpack 58 | {-# INLINE packed #-} 59 | 60 | -- | This isomorphism can be used to 'unpack' (or 'pack') lazy 'Text'. 61 | -- 62 | -- >>> "hello"^.unpacked -- :: String 63 | -- "hello" 64 | -- 65 | -- @ 66 | -- 'pack' x ≡ x '^.' 'from' 'unpacked' 67 | -- 'unpack' x ≡ x '^.' 'packed' 68 | -- @ 69 | -- 70 | -- This 'Iso' is provided for notational convenience rather than out of great need, since 71 | -- 72 | -- @ 73 | -- 'unpacked' ≡ 'from' 'packed' 74 | -- @ 75 | unpacked :: Iso' Text String 76 | unpacked = iso Text.unpack Text.pack 77 | {-# INLINE unpacked #-} 78 | 79 | -- | This is an alias for 'unpacked' that makes it clearer how to use it with @('#')@. 80 | -- 81 | -- @ 82 | -- '_Text' = 'from' 'packed' 83 | -- @ 84 | -- 85 | -- >>> _Text # "hello" -- :: Text 86 | -- "hello" 87 | _Text :: Iso' Text String 88 | _Text = from packed 89 | {-# INLINE _Text #-} 90 | 91 | -- | Convert between lazy 'Text' and 'Builder' . 92 | -- 93 | -- @ 94 | -- 'fromLazyText' x ≡ x '^.' 'builder' 95 | -- 'toLazyText' x ≡ x '^.' 'from' 'builder' 96 | -- @ 97 | builder :: Iso' Text Builder 98 | builder = iso Builder.fromLazyText Builder.toLazyText 99 | {-# INLINE builder #-} 100 | 101 | -- | Traverse the individual characters in a 'Text'. 102 | -- 103 | -- >>> anyOf text (=='c') "chello" 104 | -- True 105 | -- 106 | -- @ 107 | -- 'text' = 'unpacked' . 'traversed' 108 | -- @ 109 | -- 110 | -- When the type is unambiguous, you can also use the more general 'each'. 111 | -- 112 | -- @ 113 | -- 'text' ≡ 'each' 114 | -- @ 115 | -- 116 | -- Note that when just using this as a 'Setter', @'setting' 'Data.Text.Lazy.map'@ 117 | -- can be more efficient. 118 | text :: IndexedTraversal' Int Text Char 119 | text = unpacked . traversed 120 | {-# INLINE [0] text #-} 121 | 122 | {-# RULES 123 | "lazy text -> map" text = sets Text.map :: ASetter' Text Char; 124 | "lazy text -> imap" text = isets imapLazy :: AnIndexedSetter' Int Text Char; 125 | "lazy text -> foldr" text = foldring Text.foldr :: Getting (Endo r) Text Char; 126 | "lazy text -> ifoldr" text = ifoldring ifoldrLazy :: IndexedGetting Int (Endo r) Text Char; 127 | #-} 128 | 129 | imapLazy :: (Int -> Char -> Char) -> Text -> Text 130 | imapLazy f = snd . Text.mapAccumL (\i a -> i `seq` (i + 1, f i a)) 0 131 | {-# INLINE imapLazy #-} 132 | 133 | ifoldrLazy :: (Int -> Char -> a -> a) -> a -> Text -> a 134 | ifoldrLazy f z xs = Text.foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0 135 | {-# INLINE ifoldrLazy #-} 136 | 137 | -- | Encode\/Decode a lazy 'Text' to\/from lazy 'ByteString', via UTF-8. 138 | -- 139 | -- Note: This function does not decode lazily, as it must consume the entire 140 | -- input before deciding whether or not it fails. 141 | -- 142 | -- >>> ByteString.unpack (utf8 # "☃") 143 | -- [226,152,131] 144 | utf8 :: Prism' ByteString Text 145 | utf8 = prism' encodeUtf8 (preview _Right . decodeUtf8') 146 | {-# INLINE utf8 #-} 147 | 148 | pattern Text :: String -> Text 149 | pattern Text a <- (view _Text -> a) where 150 | Text a = review _Text a 151 | -------------------------------------------------------------------------------- /src/Data/Text/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | {-# LANGUAGE PatternSynonyms #-} 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Data.Text.Lens 9 | -- Copyright : (C) 2012-16 Edward Kmett 10 | -- License : BSD-style (see the file LICENSE) 11 | -- Maintainer : Edward Kmett 12 | -- Stability : experimental 13 | -- Portability : non-portable 14 | -- 15 | ---------------------------------------------------------------------------- 16 | module Data.Text.Lens 17 | ( IsText(..) 18 | , unpacked 19 | , _Text 20 | , pattern Text 21 | ) where 22 | 23 | import Control.Lens.Type 24 | import Control.Lens.Getter 25 | import Control.Lens.Review 26 | import Control.Lens.Iso 27 | import Control.Lens.Traversal 28 | import qualified Data.Text as Strict 29 | import qualified Data.Text.Strict.Lens as Strict 30 | import qualified Data.Text.Lazy as Lazy 31 | import qualified Data.Text.Lazy.Lens as Lazy 32 | import Data.Text.Lazy.Builder (Builder) 33 | 34 | -- $setup 35 | -- >>> import Control.Lens 36 | -- >>> import qualified Data.Text as Strict 37 | 38 | -- | Traversals for strict or lazy 'Text' 39 | class IsText t where 40 | -- | This isomorphism can be used to 'pack' (or 'unpack') strict or lazy 'Text'. 41 | -- 42 | -- @ 43 | -- 'pack' x ≡ x '^.' 'packed' 44 | -- 'unpack' x ≡ x '^.' 'from' 'packed' 45 | -- 'packed' ≡ 'from' 'unpacked' 46 | -- @ 47 | packed :: Iso' String t 48 | 49 | -- | Convert between strict or lazy 'Text' and a 'Builder'. 50 | -- 51 | -- @ 52 | -- 'fromText' x ≡ x '^.' 'builder' 53 | -- @ 54 | builder :: Iso' t Builder 55 | 56 | -- | Traverse the individual characters in strict or lazy 'Text'. 57 | -- 58 | -- @ 59 | -- 'text' = 'unpacked' . 'traversed' 60 | -- @ 61 | text :: IndexedTraversal' Int t Char 62 | text = unpacked . traversed 63 | {-# INLINE text #-} 64 | 65 | instance IsText String where 66 | packed = id 67 | {-# INLINE packed #-} 68 | text = traversed 69 | {-# INLINE text #-} 70 | builder = Lazy.packed . builder 71 | {-# INLINE builder #-} 72 | 73 | -- | This isomorphism can be used to 'unpack' (or 'pack') both strict or lazy 'Text'. 74 | -- 75 | -- @ 76 | -- 'unpack' x ≡ x '^.' 'unpacked' 77 | -- 'pack' x ≡ x '^.' 'from' 'unpacked' 78 | -- @ 79 | -- 80 | -- This 'Iso' is provided for notational convenience rather than out of great need, since 81 | -- 82 | -- @ 83 | -- 'unpacked' ≡ 'from' 'packed' 84 | -- @ 85 | -- 86 | unpacked :: IsText t => Iso' t String 87 | unpacked = from packed 88 | {-# INLINE unpacked #-} 89 | 90 | -- | This is an alias for 'unpacked' that makes it clearer how to use it with @('#')@. 91 | -- 92 | -- @ 93 | -- '_Text' = 'from' 'packed' 94 | -- @ 95 | -- 96 | -- >>> _Text # "hello" :: Strict.Text 97 | -- "hello" 98 | _Text :: IsText t => Iso' t String 99 | _Text = from packed 100 | {-# INLINE _Text #-} 101 | 102 | pattern Text :: IsText s => String -> s 103 | pattern Text a <- (view _Text -> a) where 104 | Text a = review _Text a 105 | 106 | instance IsText Strict.Text where 107 | packed = Strict.packed 108 | {-# INLINE packed #-} 109 | builder = Strict.builder 110 | {-# INLINE builder #-} 111 | text = Strict.text 112 | {-# INLINE text #-} 113 | 114 | instance IsText Lazy.Text where 115 | packed = Lazy.packed 116 | {-# INLINE packed #-} 117 | builder = Lazy.builder 118 | {-# INLINE builder #-} 119 | text = Lazy.text 120 | {-# INLINE text #-} 121 | 122 | -------------------------------------------------------------------------------- /src/Data/Text/Strict/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Data.Text.Strict.Lens 8 | -- Copyright : (C) 2012-2016 Edward Kmett 9 | -- License : BSD-style (see the file LICENSE) 10 | -- Maintainer : Edward Kmett 11 | -- Stability : experimental 12 | -- Portability : non-portable 13 | -- 14 | ---------------------------------------------------------------------------- 15 | module Data.Text.Strict.Lens 16 | ( packed, unpacked 17 | , builder 18 | , text 19 | , utf8 20 | , _Text 21 | , pattern Text 22 | ) where 23 | 24 | import Control.Lens.Type 25 | import Control.Lens.Getter 26 | import Control.Lens.Fold 27 | import Control.Lens.Iso 28 | import Control.Lens.Prism 29 | import Control.Lens.Review 30 | import Control.Lens.Setter 31 | import Control.Lens.Traversal 32 | import Data.ByteString (ByteString) 33 | import Data.Monoid 34 | import qualified Data.Text as Strict 35 | import Data.Text (Text) 36 | import Data.Text.Encoding 37 | import Data.Text.Lazy (toStrict) 38 | import qualified Data.Text.Lazy.Builder as Builder 39 | import Data.Text.Lazy.Builder (Builder) 40 | 41 | -- $setup 42 | -- >>> :set -XOverloadedStrings 43 | -- >>> import Control.Lens 44 | 45 | -- | This isomorphism can be used to 'pack' (or 'unpack') strict 'Text'. 46 | -- 47 | -- 48 | -- >>> "hello"^.packed -- :: Text 49 | -- "hello" 50 | -- 51 | -- @ 52 | -- 'pack' x ≡ x '^.' 'packed' 53 | -- 'unpack' x ≡ x '^.' 'from' 'packed' 54 | -- 'packed' ≡ 'from' 'unpacked' 55 | -- 'packed' ≡ 'iso' 'pack' 'unpack' 56 | -- @ 57 | packed :: Iso' String Text 58 | packed = iso Strict.pack Strict.unpack 59 | {-# INLINE packed #-} 60 | 61 | -- | This isomorphism can be used to 'unpack' (or 'pack') lazy 'Text'. 62 | -- 63 | -- >>> "hello"^.unpacked -- :: String 64 | -- "hello" 65 | -- 66 | -- This 'Iso' is provided for notational convenience rather than out of great need, since 67 | -- 68 | -- @ 69 | -- 'unpacked' ≡ 'from' 'packed' 70 | -- @ 71 | -- 72 | -- @ 73 | -- 'pack' x ≡ x '^.' 'from' 'unpacked' 74 | -- 'unpack' x ≡ x '^.' 'packed' 75 | -- 'unpacked' ≡ 'iso' 'unpack' 'pack' 76 | -- @ 77 | unpacked :: Iso' Text String 78 | unpacked = iso Strict.unpack Strict.pack 79 | {-# INLINE unpacked #-} 80 | 81 | -- | This is an alias for 'unpacked' that makes it more obvious how to use it with '#' 82 | -- 83 | -- >> _Text # "hello" -- :: Text 84 | -- "hello" 85 | _Text :: Iso' Text String 86 | _Text = unpacked 87 | {-# INLINE _Text #-} 88 | 89 | -- | Convert between strict 'Text' and 'Builder' . 90 | -- 91 | -- @ 92 | -- 'fromText' x ≡ x '^.' 'builder' 93 | -- 'toStrict' ('toLazyText' x) ≡ x '^.' 'from' 'builder' 94 | -- @ 95 | builder :: Iso' Text Builder 96 | builder = iso Builder.fromText (toStrict . Builder.toLazyText) 97 | {-# INLINE builder #-} 98 | 99 | -- | Traverse the individual characters in strict 'Text'. 100 | -- 101 | -- >>> anyOf text (=='o') "hello" 102 | -- True 103 | -- 104 | -- When the type is unambiguous, you can also use the more general 'each'. 105 | -- 106 | -- @ 107 | -- 'text' ≡ 'unpacked' . 'traversed' 108 | -- 'text' ≡ 'each' 109 | -- @ 110 | -- 111 | -- Note that when just using this as a 'Setter', @'setting' 'Data.Text.map'@ can 112 | -- be more efficient. 113 | text :: IndexedTraversal' Int Text Char 114 | text = unpacked . traversed 115 | {-# INLINE [0] text #-} 116 | 117 | {-# RULES 118 | "strict text -> map" text = sets Strict.map :: ASetter' Text Char; 119 | "strict text -> imap" text = isets imapStrict :: AnIndexedSetter' Int Text Char; 120 | "strict text -> foldr" text = foldring Strict.foldr :: Getting (Endo r) Text Char; 121 | "strict text -> ifoldr" text = ifoldring ifoldrStrict :: IndexedGetting Int (Endo r) Text Char; 122 | #-} 123 | 124 | imapStrict :: (Int -> Char -> Char) -> Text -> Text 125 | imapStrict f = snd . Strict.mapAccumL (\i a -> i `seq` (i + 1, f i a)) 0 126 | {-# INLINE imapStrict #-} 127 | 128 | ifoldrStrict :: (Int -> Char -> a -> a) -> a -> Text -> a 129 | ifoldrStrict f z xs = Strict.foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0 130 | {-# INLINE ifoldrStrict #-} 131 | 132 | -- | Encode\/Decode a strict 'Text' to\/from strict 'ByteString', via UTF-8. 133 | -- 134 | -- >>> utf8 # "☃" 135 | -- "\226\152\131" 136 | utf8 :: Prism' ByteString Text 137 | utf8 = prism' encodeUtf8 (preview _Right . decodeUtf8') 138 | {-# INLINE utf8 #-} 139 | 140 | pattern Text :: String -> Text 141 | pattern Text a <- (view _Text -> a) where 142 | Text a = review _Text a 143 | -------------------------------------------------------------------------------- /src/Data/Tree/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Data.Tree.Lens 7 | -- Copyright : (C) 2012-16 Edward Kmett 8 | -- License : BSD-style (see the file LICENSE) 9 | -- Maintainer : Edward Kmett 10 | -- Stability : provisional 11 | -- Portability : MTPCs 12 | -- 13 | ---------------------------------------------------------------------------- 14 | 15 | module Data.Tree.Lens 16 | ( root 17 | , branches 18 | ) where 19 | 20 | import Prelude () 21 | 22 | import Control.Lens.Internal.Prelude 23 | import Control.Lens 24 | import Data.Tree 25 | 26 | -- $setup 27 | -- >>> import Control.Lens 28 | -- >>> import Data.Tree 29 | 30 | -- | A t'Lens' that focuses on the root of a 'Tree'. 31 | -- 32 | -- >>> view root $ Node 42 [] 33 | -- 42 34 | root :: Lens' (Tree a) a 35 | root f (Node a as) = (`Node` as) <$> f a 36 | {-# INLINE root #-} 37 | 38 | -- | A t'Lens' returning the direct descendants of the root of a 'Tree' 39 | -- 40 | -- @'view' 'branches' ≡ 'subForest'@ 41 | branches :: Lens' (Tree a) [Tree a] 42 | branches f (Node a as) = Node a <$> f as 43 | {-# INLINE branches #-} 44 | -------------------------------------------------------------------------------- /src/Data/Typeable/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Data.Typeable.Lens 6 | -- Copyright : (C) 2012-16 Edward Kmett 7 | -- License : BSD-style (see the file LICENSE) 8 | -- Maintainer : Edward Kmett 9 | -- Stability : experimental 10 | -- Portability : Rank2Types 11 | -- 12 | ---------------------------------------------------------------------------- 13 | module Data.Typeable.Lens 14 | ( _cast 15 | , _gcast 16 | ) where 17 | 18 | import Prelude () 19 | 20 | import Control.Lens 21 | import Control.Lens.Internal.Prelude 22 | import Data.Maybe (fromMaybe) 23 | import Data.Typeable 24 | 25 | -- | A 'Traversal'' for working with a 'cast' of a 'Typeable' value. 26 | _cast :: (Typeable s, Typeable a) => Traversal' s a 27 | _cast f s = case cast s of 28 | Just a -> fromMaybe (error "_cast: recast failed") . cast <$> f a 29 | Nothing -> pure s 30 | {-# INLINE _cast #-} 31 | 32 | -- | A 'Traversal'' for working with a 'gcast' of a 'Typeable' value. 33 | _gcast :: (Typeable s, Typeable a) => Traversal' (c s) (c a) 34 | _gcast f s = case gcast s of 35 | Just a -> fromMaybe (error "_gcast: recast failed") . gcast <$> f a 36 | Nothing -> pure s 37 | {-# INLINE _gcast #-} 38 | -------------------------------------------------------------------------------- /src/Data/Vector/Generic/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | #ifdef TRUSTWORTHY 5 | {-# LANGUAGE Trustworthy #-} 6 | #endif 7 | 8 | #include "lens-common.h" 9 | 10 | ------------------------------------------------------------------------------- 11 | -- | 12 | -- Module : Data.Vector.Generic.Lens 13 | -- Copyright : (C) 2012-2016 Edward Kmett 14 | -- License : BSD-style (see the file LICENSE) 15 | -- Maintainer : Edward Kmett 16 | -- Stability : provisional 17 | -- Portability : non-portable 18 | -- 19 | -- This module provides lenses and traversals for working with generic 20 | -- vectors. 21 | ------------------------------------------------------------------------------- 22 | module Data.Vector.Generic.Lens 23 | ( toVectorOf 24 | -- * Isomorphisms 25 | , forced 26 | , vector 27 | , asStream 28 | , asStreamR 29 | , cloned 30 | , converted 31 | -- * Lenses 32 | , sliced 33 | -- * Traversal of individual indices 34 | , ordinals 35 | , vectorIx 36 | , vectorTraverse 37 | ) where 38 | 39 | import Prelude () 40 | 41 | import Control.Lens.Type 42 | import Control.Lens.Lens 43 | import Control.Lens.Getter 44 | import Control.Lens.Fold 45 | import Control.Lens.Iso 46 | import Control.Lens.Indexed 47 | import Control.Lens.Setter 48 | import Control.Lens.Traversal 49 | import Control.Lens.Internal.List (ordinalNub) 50 | import Control.Lens.Internal.Prelude 51 | import Data.Vector.Fusion.Bundle (Bundle) 52 | import qualified Data.Vector.Generic as V 53 | import Data.Vector.Generic (Vector) 54 | import Data.Vector.Generic.New (New) 55 | 56 | -- $setup 57 | -- >>> import qualified Data.Vector as Vector 58 | -- >>> import Control.Lens 59 | 60 | -- | @sliced i n@ provides a 'Lens' that edits the @n@ elements starting 61 | -- at index @i@ from a 'Lens'. 62 | -- 63 | -- This is only a valid 'Lens' if you do not change the length of the 64 | -- resulting 'Vector'. 65 | -- 66 | -- Attempting to return a longer or shorter vector will result in 67 | -- violations of the 'Lens' laws. 68 | -- 69 | -- >>> Vector.fromList [1..10] ^. sliced 2 5 == Vector.fromList [3,4,5,6,7] 70 | -- True 71 | -- 72 | -- >>> (Vector.fromList [1..10] & sliced 2 5 . mapped .~ 0) == Vector.fromList [1,2,0,0,0,0,0,8,9,10] 73 | -- True 74 | sliced :: Vector v a 75 | => Int -- ^ @i@ starting index 76 | -> Int -- ^ @n@ length 77 | -> Lens' (v a) (v a) 78 | sliced i n f v = f (V.slice i n v) <&> \ v0 -> v V.// zip [i..i+n-1] (V.toList v0) 79 | {-# INLINE sliced #-} 80 | 81 | -- | Similar to 'toListOf', but returning a 'Vector'. 82 | -- 83 | -- >>> (toVectorOf both (8,15) :: Vector.Vector Int) == Vector.fromList [8,15] 84 | -- True 85 | toVectorOf :: Vector v a => Getting (Endo [a]) s a -> s -> v a 86 | toVectorOf l s = V.fromList (toListOf l s) 87 | {-# INLINE toVectorOf #-} 88 | 89 | -- | Convert a list to a 'Vector' (or back.) 90 | -- 91 | -- >>> ([1,2,3] ^. vector :: Vector.Vector Int) == Vector.fromList [1,2,3] 92 | -- True 93 | -- 94 | -- >>> Vector.fromList [0,8,15] ^. from vector 95 | -- [0,8,15] 96 | vector :: (Vector v a, Vector v b) => Iso [a] [b] (v a) (v b) 97 | vector = iso V.fromList V.toList 98 | {-# INLINE vector #-} 99 | 100 | -- | Convert a 'Vector' to a finite 'Bundle' (or back.) 101 | asStream :: (Vector v a, Vector v b) => Iso (v a) (v b) (Bundle v a) (Bundle v b) 102 | asStream = iso V.stream V.unstream 103 | {-# INLINE asStream #-} 104 | 105 | -- | Convert a 'Vector' to a finite 'Bundle' from right to left (or 106 | -- back.) 107 | asStreamR :: (Vector v a, Vector v b) => Iso (v a) (v b) (Bundle v a) (Bundle v b) 108 | asStreamR = iso V.streamR V.unstreamR 109 | {-# INLINE asStreamR #-} 110 | 111 | -- | Convert a 'Vector' back and forth to an initializer that when run 112 | -- produces a copy of the 'Vector'. 113 | cloned :: Vector v a => Iso' (v a) (New v a) 114 | cloned = iso V.clone V.new 115 | {-# INLINE cloned #-} 116 | 117 | -- | Convert a 'Vector' to a version that doesn't retain any extra 118 | -- memory. 119 | forced :: Vector v a => Iso' (v a) (v a) 120 | forced = involuted V.force 121 | {-# INLINE forced #-} 122 | 123 | -- | This 'Traversal' will ignore any duplicates in the supplied list 124 | -- of indices. 125 | -- 126 | -- >>> toListOf (ordinals [1,3,2,5,9,10]) $ Vector.fromList [2,4..40] 127 | -- [4,8,6,12,20,22] 128 | ordinals :: Vector v a => [Int] -> IndexedTraversal' Int (v a) a 129 | ordinals is f v = fmap (v V.//) $ traverse (\i -> (,) i <$> indexed f i (v V.! i)) $ ordinalNub (V.length v) is 130 | {-# INLINE ordinals #-} 131 | 132 | -- | Like 'ix' but polymorphic in the vector type. 133 | vectorIx :: V.Vector v a => Int -> Traversal' (v a) a 134 | vectorIx i f v 135 | | 0 <= i && i < V.length v = f (v V.! i) <&> \a -> v V.// [(i, a)] 136 | | otherwise = pure v 137 | {-# INLINE vectorIx #-} 138 | 139 | -- | Indexed vector traversal for a generic vector. 140 | vectorTraverse :: (V.Vector v a, V.Vector w b) => IndexedTraversal Int (v a) (w b) a b 141 | vectorTraverse f v = V.fromListN (V.length v) <$> traversed f (V.toList v) 142 | {-# INLINE [0] vectorTraverse #-} 143 | 144 | {-# RULES 145 | "vectorTraverse -> mapped" vectorTraverse = sets V.map :: (V.Vector v a, V.Vector v b) => ASetter (v a) (v b) a b; 146 | "vectorTraverse -> imapped" vectorTraverse = isets V.imap :: (V.Vector v a, V.Vector v b) => AnIndexedSetter Int (v a) (v b) a b; 147 | "vectorTraverse -> foldr" vectorTraverse = foldring V.foldr :: V.Vector v a => Getting (Endo r) (v a) a; 148 | "vectorTraverse -> ifoldr" vectorTraverse = ifoldring V.ifoldr :: V.Vector v a => IndexedGetting Int (Endo r) (v a) a; 149 | #-} 150 | 151 | -- | Different vector implementations are isomorphic to each other. 152 | converted :: (Vector v a, Vector w a, Vector v b, Vector w b) => Iso (v a) (v b) (w a) (w b) 153 | converted = iso V.convert V.convert 154 | -------------------------------------------------------------------------------- /src/Data/Vector/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | #ifdef TRUSTWORTHY 6 | {-# LANGUAGE Trustworthy #-} 7 | #endif 8 | ------------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Data.Vector.Lens 11 | -- Copyright : (C) 2012-16 Edward Kmett 12 | -- License : BSD-style (see the file LICENSE) 13 | -- Maintainer : Edward Kmett 14 | -- Stability : provisional 15 | -- Portability : non-portable 16 | -- 17 | -- This module provides lenses and traversals for working with generic 18 | -- vectors. 19 | ------------------------------------------------------------------------------- 20 | module Data.Vector.Lens 21 | ( toVectorOf 22 | -- * Isomorphisms 23 | , vector 24 | , forced 25 | -- * Lenses 26 | , sliced 27 | -- * Traversal of individual indices 28 | , ordinals 29 | ) where 30 | 31 | import Prelude () 32 | 33 | import Control.Lens 34 | import Control.Lens.Internal.List (ordinalNub) 35 | import Control.Lens.Internal.Prelude 36 | import qualified Data.Vector as V 37 | import Data.Vector (Vector) 38 | 39 | -- $setup 40 | -- >>> import qualified Data.Vector as Vector 41 | -- >>> import Control.Lens 42 | 43 | -- | @sliced i n@ provides a t'Lens' that edits the @n@ elements starting 44 | -- at index @i@ from a t'Lens'. 45 | -- 46 | -- This is only a valid t'Lens' if you do not change the length of the 47 | -- resulting 'Vector'. 48 | -- 49 | -- Attempting to return a longer or shorter vector will result in 50 | -- violations of the t'Lens' laws. 51 | -- 52 | -- >>> Vector.fromList [1..10] ^. sliced 2 5 == Vector.fromList [3,4,5,6,7] 53 | -- True 54 | -- 55 | -- >>> (Vector.fromList [1..10] & sliced 2 5 . mapped .~ 0) == Vector.fromList [1,2,0,0,0,0,0,8,9,10] 56 | -- True 57 | sliced :: Int -- ^ @i@ starting index 58 | -> Int -- ^ @n@ length 59 | -> Lens' (Vector a) (Vector a) 60 | sliced i n f v = f (V.slice i n v) <&> \ v0 -> v V.// zip [i..i+n-1] (V.toList v0) 61 | {-# INLINE sliced #-} 62 | 63 | -- | Similar to 'toListOf', but returning a 'Vector'. 64 | -- 65 | -- >>> toVectorOf both (8,15) == Vector.fromList [8,15] 66 | -- True 67 | toVectorOf :: Getting (Endo [a]) s a -> s -> Vector a 68 | toVectorOf l s = V.fromList (toListOf l s) 69 | {-# INLINE toVectorOf #-} 70 | 71 | -- | Convert a list to a 'Vector' (or back) 72 | -- 73 | -- >>> [1,2,3] ^. vector == Vector.fromList [1,2,3] 74 | -- True 75 | -- 76 | -- >>> [1,2,3] ^. vector . from vector 77 | -- [1,2,3] 78 | -- 79 | -- >>> Vector.fromList [0,8,15] ^. from vector . vector == Vector.fromList [0,8,15] 80 | -- True 81 | vector :: Iso [a] [b] (Vector a) (Vector b) 82 | vector = iso V.fromList V.toList 83 | {-# INLINE vector #-} 84 | 85 | -- | Convert a 'Vector' to a version that doesn't retain any extra 86 | -- memory. 87 | forced :: Iso (Vector a) (Vector b) (Vector a) (Vector b) 88 | forced = iso V.force V.force 89 | {-# INLINE forced #-} 90 | 91 | -- | This t'Traversal' will ignore any duplicates in the supplied list 92 | -- of indices. 93 | -- 94 | -- >>> toListOf (ordinals [1,3,2,5,9,10]) $ Vector.fromList [2,4..40] 95 | -- [4,8,6,12,20,22] 96 | ordinals :: [Int] -> IndexedTraversal' Int (Vector a) a 97 | ordinals is f v = fmap (v V.//) $ traverse (\i -> (,) i <$> indexed f i (v V.! i)) $ ordinalNub (length v) is 98 | {-# INLINE ordinals #-} 99 | -------------------------------------------------------------------------------- /src/GHC/Generics/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyCase #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE MagicHash #-} 4 | {-# LANGUAGE Rank2Types #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : GHC.Generics.Lens 11 | -- Copyright : (C) 2012-16 Edward Kmett 12 | -- License : BSD-style (see the file LICENSE) 13 | -- Maintainer : Edward Kmett 14 | -- Stability : experimental 15 | -- Portability : GHC 16 | -- 17 | -- Note: @GHC.Generics@ exports a number of names that collide with @Control.Lens@. 18 | -- 19 | -- You can use hiding or imports to mitigate this to an extent, and the following imports, 20 | -- represent a fair compromise for user code: 21 | -- 22 | -- > import Control.Lens hiding (Rep) 23 | -- > import GHC.Generics hiding (from, to) 24 | -- 25 | -- You can use 'generic' to replace 'GHC.Generics.from' and 'GHC.Generics.to' from @GHC.Generics@, 26 | -- and probably won't be explicitly referencing 'Control.Lens.Representable.Rep' from @Control.Lens@ 27 | -- in code that uses generics. 28 | -- 29 | -- This module provides compatibility with older GHC versions by using the 30 | -- 31 | -- package. 32 | ---------------------------------------------------------------------------- 33 | module GHC.Generics.Lens 34 | ( 35 | generic 36 | , generic1 37 | , _V1 38 | , _U1 39 | , _Par1 40 | , _Rec1 41 | , _K1 42 | , _M1 43 | , _L1 44 | , _R1 45 | , _UAddr 46 | , _UChar 47 | , _UDouble 48 | , _UFloat 49 | , _UInt 50 | , _UWord 51 | ) where 52 | 53 | import Control.Lens 54 | import GHC.Exts (Char(..), Double(..), Float(..), 55 | Int(..), Ptr(..), Word(..)) 56 | import qualified GHC.Generics as Generic 57 | import GHC.Generics hiding (from, to) 58 | 59 | -- $setup 60 | -- >>> :set -XNoOverloadedStrings 61 | -- >>> import Control.Lens 62 | 63 | -- | Convert from the data type to its representation (or back) 64 | -- 65 | -- >>> "hello"^.generic.from generic :: String 66 | -- "hello" 67 | generic :: (Generic a, Generic b) => Iso a b (Rep a g) (Rep b h) 68 | generic = iso Generic.from Generic.to 69 | {-# INLINE generic #-} 70 | 71 | -- | Convert from the data type to its representation (or back) 72 | generic1 :: (Generic1 f, Generic1 g) => Iso (f a) (g b) (Rep1 f a) (Rep1 g b) 73 | generic1 = iso from1 to1 74 | {-# INLINE generic1 #-} 75 | 76 | _V1 :: Over p f (V1 s) (V1 t) a b 77 | _V1 _ = \case 78 | {-# INLINE _V1 #-} 79 | 80 | _U1 :: Iso (U1 p) (U1 q) () () 81 | _U1 = iso (const ()) (const U1) 82 | {-# INLINE _U1 #-} 83 | 84 | _Par1 :: Iso (Par1 p) (Par1 q) p q 85 | _Par1 = coerced 86 | {-# INLINE _Par1 #-} 87 | 88 | _Rec1 :: Iso (Rec1 f p) (Rec1 g q) (f p) (g q) 89 | _Rec1 = coerced 90 | {-# INLINE _Rec1 #-} 91 | 92 | _K1 :: Iso (K1 i c p) (K1 j d q) c d 93 | _K1 = coerced 94 | {-# INLINE _K1 #-} 95 | 96 | _M1 :: Iso (M1 i c f p) (M1 j d g q) (f p) (g q) 97 | _M1 = coerced 98 | {-# INLINE _M1 #-} 99 | 100 | _L1 :: Prism' ((f :+: g) a) (f a) 101 | _L1 = prism remitter reviewer 102 | where 103 | remitter = L1 104 | reviewer (L1 l) = Right l 105 | reviewer x = Left x 106 | {-# INLINE _L1 #-} 107 | 108 | -- | You can access fields of `data (f :*: g) p` by using its `Field1` and 109 | -- `Field2` instances. 110 | 111 | _R1 :: Prism' ((f :+: g) a) (g a) 112 | _R1 = prism remitter reviewer 113 | where 114 | remitter = R1 115 | reviewer (R1 l) = Right l 116 | reviewer x = Left x 117 | {-# INLINE _R1 #-} 118 | 119 | _UAddr :: Iso (UAddr p) (UAddr q) (Ptr c) (Ptr d) 120 | _UAddr = iso remitter reviewer 121 | where 122 | remitter (UAddr a) = Ptr a 123 | reviewer (Ptr a) = UAddr a 124 | {-# INLINE _UAddr #-} 125 | 126 | _UChar :: Iso (UChar p) (UChar q) Char Char 127 | _UChar = iso remitter reviewer 128 | where 129 | remitter (UChar c) = C# c 130 | reviewer (C# c) = UChar c 131 | {-# INLINE _UChar #-} 132 | 133 | _UDouble :: Iso (UDouble p) (UDouble q) Double Double 134 | _UDouble = iso remitter reviewer 135 | where 136 | remitter (UDouble d) = D# d 137 | reviewer (D# d) = UDouble d 138 | {-# INLINE _UDouble #-} 139 | 140 | _UFloat :: Iso (UFloat p) (UFloat q) Float Float 141 | _UFloat = iso remitter reviewer 142 | where 143 | remitter (UFloat f) = F# f 144 | reviewer (F# f) = UFloat f 145 | {-# INLINE _UFloat #-} 146 | 147 | _UInt :: Iso (UInt p) (UInt q) Int Int 148 | _UInt = iso remitter reviewer 149 | where 150 | remitter (UInt i) = I# i 151 | reviewer (I# i) = UInt i 152 | {-# INLINE _UInt #-} 153 | 154 | _UWord :: Iso (UWord p) (UWord q) Word Word 155 | _UWord = iso remitter reviewer 156 | where 157 | remitter (UWord w) = W# w 158 | reviewer (W# w) = UWord w 159 | {-# INLINE _UWord #-} 160 | -------------------------------------------------------------------------------- /src/Numeric/Natural/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# language RankNTypes #-} 2 | {-# language PatternGuards #-} 3 | {-# language ViewPatterns #-} 4 | {-# language PatternSynonyms #-} 5 | -------------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Numeric.Natural.Lens 8 | -- Copyright : (C) 2017 Edward Kmett 9 | -- License : BSD-style (see the file LICENSE) 10 | -- Maintainer : Edward Kmett 11 | -- Stability : provisional 12 | -- Portability : portable 13 | -- 14 | -- Useful tools for Gödel numbering. 15 | ------------------------------------------------------------------------------- 16 | module Numeric.Natural.Lens 17 | ( _Pair 18 | , _Sum 19 | , _Naturals 20 | , pattern Pair 21 | , pattern Sum 22 | , pattern Naturals 23 | ) where 24 | 25 | import Control.Lens 26 | import Numeric.Natural 27 | 28 | -- | The natural numbers are isomorphic to the product of the natural numbers with itself. 29 | -- 30 | -- @N = N*N@ 31 | _Pair :: Iso' Natural (Natural, Natural) 32 | _Pair = iso hither (uncurry yon) where 33 | yon 0 0 = 0 34 | yon m n = case quotRem m 2 of 35 | (q,r) -> r + 2 * yon n q -- rotation 36 | 37 | hither 0 = (0,0) 38 | hither n = case quotRem n 2 of 39 | (p,r) -> case hither p of 40 | (x,y) -> (r+2*y,x) -- rotation 41 | 42 | -- | The natural numbers are isomorphic to disjoint sums of natural numbers embedded as 43 | -- evens or odds. 44 | -- 45 | -- @N = 2*N@ 46 | _Sum :: Iso' Natural (Either Natural Natural) 47 | _Sum = iso hither yon where 48 | hither p = case quotRem p 2 of 49 | (q,0) -> Left q 50 | (q,1) -> Right q 51 | _ -> error "_Sum: impossible" 52 | yon (Left q) = 2*q 53 | yon (Right q) = 2*q+1 54 | 55 | -- | The natural numbers are isomorphic to lists of natural numbers 56 | _Naturals :: Iso' Natural [Natural] 57 | _Naturals = iso hither yon where 58 | hither 0 = [] 59 | hither n | (h, t) <- (n-1)^._Pair = h : hither t 60 | yon [] = 0 61 | yon (x:xs) = 1 + review _Pair (x, yon xs) 62 | 63 | -- | 64 | -- interleaves the bits of two natural numbers 65 | pattern Pair :: Natural -> Natural -> Natural 66 | pattern Pair x y <- (view _Pair -> (x,y)) where 67 | Pair x y = review _Pair (x,y) 68 | 69 | -- | 70 | -- @ 71 | -- Sum (Left q) = 2*q 72 | -- Sum (Right q) = 2*q+1 73 | -- @ 74 | pattern Sum :: Either Natural Natural -> Natural 75 | pattern Sum s <- (view _Sum -> s) where 76 | Sum s = review _Sum s 77 | 78 | -- | 79 | -- @ 80 | -- Naturals [] = 0 81 | -- Naturals (h:t) = 1 + Pair h (Naturals t) 82 | -- @ 83 | pattern Naturals :: [Natural] -> Natural 84 | pattern Naturals xs <- (view _Naturals -> xs) where 85 | Naturals xs = review _Naturals xs 86 | -------------------------------------------------------------------------------- /src/System/Exit/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE PatternSynonyms #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | 7 | ----------------------------------------------------------------------------- 8 | -- | 9 | -- Module : System.Exit.Lens 10 | -- Copyright : (C) 2013-16 Edward Kmett 11 | -- License : BSD-style (see the file LICENSE) 12 | -- Maintainer : Edward Kmett 13 | -- Stability : provisional 14 | -- Portability : Control.Exception 15 | -- 16 | -- These prisms can be used with the combinators in "Control.Exception.Lens". 17 | ---------------------------------------------------------------------------- 18 | module System.Exit.Lens 19 | ( AsExitCode(..) 20 | , _ExitFailure 21 | , _ExitSuccess 22 | , pattern ExitFailure_ 23 | , pattern ExitSuccess_ 24 | ) where 25 | 26 | import Prelude () 27 | 28 | import Control.Exception 29 | import Control.Exception.Lens 30 | import Control.Lens 31 | import Control.Lens.Internal.Prelude 32 | import System.Exit 33 | 34 | -- | Exit codes that a program can return with: 35 | class AsExitCode t where 36 | _ExitCode :: Prism' t ExitCode 37 | 38 | instance AsExitCode ExitCode where 39 | _ExitCode = id 40 | {-# INLINE _ExitCode #-} 41 | 42 | instance AsExitCode SomeException where 43 | _ExitCode = exception 44 | {-# INLINE _ExitCode #-} 45 | 46 | -- | indicates successful termination; 47 | -- 48 | -- @ 49 | -- '_ExitSuccess' :: 'Prism'' 'ExitCode' () 50 | -- '_ExitSuccess' :: 'Prism'' 'SomeException' () 51 | -- @ 52 | _ExitSuccess :: AsExitCode t => Prism' t () 53 | _ExitSuccess = _ExitCode . dimap seta (either id id) . right' . rmap (ExitSuccess <$) where 54 | seta ExitSuccess = Right () 55 | seta t = Left (pure t) 56 | {-# INLINE _ExitSuccess #-} 57 | 58 | 59 | -- | indicates program failure with an exit code. The exact interpretation of the code is operating-system dependent. In particular, some values may be prohibited (e.g. 0 on a POSIX-compliant system). 60 | -- 61 | -- @ 62 | -- '_ExitFailure' :: 'Prism'' 'ExitCode' 'Int' 63 | -- '_ExitFailure' :: 'Prism'' 'SomeException' 'Int' 64 | -- @ 65 | _ExitFailure :: AsExitCode t => Prism' t Int 66 | _ExitFailure = _ExitCode . dimap seta (either id id) . right' . rmap (fmap ExitFailure) where 67 | seta (ExitFailure i) = Right i 68 | seta t = Left (pure t) 69 | {-# INLINE _ExitFailure #-} 70 | 71 | pattern ExitSuccess_ :: AsExitCode s => s 72 | pattern ExitSuccess_ <- (has _ExitSuccess -> True) where 73 | ExitSuccess_ = review _ExitSuccess () 74 | 75 | pattern ExitFailure_ :: AsExitCode s => Int -> s 76 | pattern ExitFailure_ a <- (preview _ExitFailure -> Just a) where 77 | ExitFailure_ a = review _ExitFailure a 78 | -------------------------------------------------------------------------------- /src/System/IO/Error/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : System.IO.Error.Lens 7 | -- Copyright : (C) 2012-2016 Edward Kmett 8 | -- License : BSD-style (see the file LICENSE) 9 | -- Maintainer : Edward Kmett 10 | -- Stability : experimental 11 | -- Portability : Rank2Types 12 | -- 13 | ---------------------------------------------------------------------------- 14 | module System.IO.Error.Lens where 15 | 16 | import Control.Lens 17 | import GHC.IO.Exception 18 | import System.IO 19 | import Foreign.C.Types 20 | 21 | -- * IOException Lenses 22 | 23 | -- | Where the error happened. 24 | location :: Lens' IOException String 25 | location f s = f (ioe_location s) <&> \e -> s { ioe_location = e } 26 | {-# INLINE location #-} 27 | 28 | -- | Error type specific information. 29 | description :: Lens' IOException String 30 | description f s = f (ioe_description s) <&> \e -> s { ioe_description = e } 31 | {-# INLINE description #-} 32 | 33 | -- | The handle used by the action flagging this error. 34 | handle :: Lens' IOException (Maybe Handle) 35 | handle f s = f (ioe_handle s) <&> \e -> s { ioe_handle = e } 36 | {-# INLINE handle #-} 37 | 38 | -- | 'fileName' the error is related to. 39 | -- 40 | fileName :: Lens' IOException (Maybe FilePath) 41 | fileName f s = f (ioe_filename s) <&> \e -> s { ioe_filename = e } 42 | {-# INLINE fileName #-} 43 | 44 | -- | 'errno' leading to this error, if any. 45 | -- 46 | errno :: Lens' IOException (Maybe CInt) 47 | errno f s = f (ioe_errno s) <&> \e -> s { ioe_errno = e } 48 | {-# INLINE errno #-} 49 | 50 | ------------------------------------------------------------------------------ 51 | -- Error Types 52 | ------------------------------------------------------------------------------ 53 | 54 | -- | What type of error it is 55 | 56 | errorType :: Lens' IOException IOErrorType 57 | errorType f s = f (ioe_type s) <&> \e -> s { ioe_type = e } 58 | {-# INLINE errorType #-} 59 | 60 | -- * IOErrorType Prisms 61 | -- 62 | 63 | _AlreadyExists :: Prism' IOErrorType () 64 | _AlreadyExists = only AlreadyExists 65 | 66 | _NoSuchThing :: Prism' IOErrorType () 67 | _NoSuchThing = only NoSuchThing 68 | 69 | _ResourceBusy :: Prism' IOErrorType () 70 | _ResourceBusy = only ResourceBusy 71 | 72 | _ResourceExhausted :: Prism' IOErrorType () 73 | _ResourceExhausted = only ResourceExhausted 74 | 75 | _EOF :: Prism' IOErrorType () 76 | _EOF = only EOF 77 | 78 | _IllegalOperation :: Prism' IOErrorType () 79 | _IllegalOperation = only IllegalOperation 80 | 81 | _PermissionDenied :: Prism' IOErrorType () 82 | _PermissionDenied = only PermissionDenied 83 | 84 | _UserError :: Prism' IOErrorType () 85 | _UserError = only UserError 86 | 87 | _UnsatisfiedConstraints :: Prism' IOErrorType () 88 | _UnsatisfiedConstraints = only UnsatisfiedConstraints 89 | 90 | _SystemError :: Prism' IOErrorType () 91 | _SystemError = only SystemError 92 | 93 | _ProtocolError :: Prism' IOErrorType () 94 | _ProtocolError = only ProtocolError 95 | 96 | _OtherError :: Prism' IOErrorType () 97 | _OtherError = only OtherError 98 | 99 | _InvalidArgument :: Prism' IOErrorType () 100 | _InvalidArgument = only InvalidArgument 101 | 102 | _InappropriateType :: Prism' IOErrorType () 103 | _InappropriateType = only InappropriateType 104 | 105 | _HardwareFault :: Prism' IOErrorType () 106 | _HardwareFault = only HardwareFault 107 | 108 | _UnsupportedOperation :: Prism' IOErrorType () 109 | _UnsupportedOperation = only UnsupportedOperation 110 | 111 | _TimeExpired :: Prism' IOErrorType () 112 | _TimeExpired = only TimeExpired 113 | 114 | _ResourceVanished :: Prism' IOErrorType () 115 | _ResourceVanished = only ResourceVanished 116 | 117 | _Interrupted :: Prism' IOErrorType () 118 | _Interrupted = only Interrupted 119 | -------------------------------------------------------------------------------- /tests/BigRecord.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module BigRecord where 4 | 5 | import Control.Lens 6 | 7 | data Big = Big 8 | { _a0 :: Int , _a1 :: Int , _a2 :: Int , _a3 :: Int , _a4 :: Int , _a5 :: Int , _a6 :: Int , _a7 :: Int 9 | , _a8 :: Int , _a9 :: Int , _a10 :: Int , _a11 :: Int , _a12 :: Int , _a13 :: Int , _a14 :: Int , _a15 :: Int 10 | , _a16 :: Int , _a17 :: Int , _a18 :: Int , _a19 :: Int , _a20 :: Int , _a21 :: Int , _a22 :: Int , _a23 :: Int 11 | , _a24 :: Int , _a25 :: Int , _a26 :: Int , _a27 :: Int , _a28 :: Int , _a29 :: Int , _a30 :: Int , _a31 :: Int 12 | , _a32 :: Int , _a33 :: Int , _a34 :: Int , _a35 :: Int , _a36 :: Int , _a37 :: Int , _a38 :: Int , _a39 :: Int 13 | , _a40 :: Int , _a41 :: Int , _a42 :: Int , _a43 :: Int , _a44 :: Int , _a45 :: Int , _a46 :: Int , _a47 :: Int 14 | , _a48 :: Int , _a49 :: Int , _a50 :: Int , _a51 :: Int , _a52 :: Int , _a53 :: Int , _a54 :: Int , _a55 :: Int 15 | , _a56 :: Int , _a57 :: Int , _a58 :: Int , _a59 :: Int , _a60 :: Int , _a61 :: Int , _a62 :: Int , _a63 :: Int 16 | , _a64 :: Int , _a65 :: Int , _a66 :: Int , _a67 :: Int , _a68 :: Int , _a69 :: Int , _a70 :: Int , _a71 :: Int 17 | , _a72 :: Int , _a73 :: Int , _a74 :: Int , _a75 :: Int , _a76 :: Int , _a77 :: Int , _a78 :: Int , _a79 :: Int 18 | , _a80 :: Int , _a81 :: Int , _a82 :: Int , _a83 :: Int , _a84 :: Int , _a85 :: Int , _a86 :: Int , _a87 :: Int 19 | , _a88 :: Int , _a89 :: Int , _a90 :: Int , _a91 :: Int , _a92 :: Int , _a93 :: Int , _a94 :: Int , _a95 :: Int 20 | , _a96 :: Int , _a97 :: Int , _a98 :: Int , _a99 :: Int 21 | } 22 | 23 | data Bigger = Bigger 24 | { _b0 :: Int , _b1 :: Int , _b2 :: Int , _b3 :: Int , _b4 :: Int , _b5 :: Int , _b6 :: Int , _b7 :: Int 25 | , _b8 :: Int , _b9 :: Int , _b10 :: Int , _b11 :: Int , _b12 :: Int , _b13 :: Int , _b14 :: Int , _b15 :: Int 26 | , _b16 :: Int , _b17 :: Int , _b18 :: Int , _b19 :: Int , _b20 :: Int , _b21 :: Int , _b22 :: Int , _b23 :: Int 27 | , _b24 :: Int , _b25 :: Int , _b26 :: Int , _b27 :: Int , _b28 :: Int , _b29 :: Int , _b30 :: Int , _b31 :: Int 28 | , _b32 :: Int , _b33 :: Int , _b34 :: Int , _b35 :: Int , _b36 :: Int , _b37 :: Int , _b38 :: Int , _b39 :: Int 29 | , _b40 :: Int , _b41 :: Int , _b42 :: Int , _b43 :: Int , _b44 :: Int , _b45 :: Int , _b46 :: Int , _b47 :: Int 30 | , _b48 :: Int , _b49 :: Int , _b50 :: Int , _b51 :: Int , _b52 :: Int , _b53 :: Int , _b54 :: Int , _b55 :: Int 31 | , _b56 :: Int , _b57 :: Int , _b58 :: Int , _b59 :: Int , _b60 :: Int , _b61 :: Int , _b62 :: Int , _b63 :: Int 32 | , _b64 :: Int , _b65 :: Int , _b66 :: Int , _b67 :: Int , _b68 :: Int , _b69 :: Int , _b70 :: Int , _b71 :: Int 33 | , _b72 :: Int , _b73 :: Int , _b74 :: Int , _b75 :: Int , _b76 :: Int , _b77 :: Int , _b78 :: Int , _b79 :: Int 34 | , _b80 :: Int , _b81 :: Int , _b82 :: Int , _b83 :: Int , _b84 :: Int , _b85 :: Int , _b86 :: Int , _b87 :: Int 35 | , _b88 :: Int , _b89 :: Int , _b90 :: Int , _b91 :: Int , _b92 :: Int , _b93 :: Int , _b94 :: Int , _b95 :: Int 36 | , _b96 :: Int , _b97 :: Int , _b98 :: Int , _b99 :: Int , _b100 :: Int , _b101 :: Int , _b102 :: Int , _b103 :: Int 37 | , _b104 :: Int , _b105 :: Int , _b106 :: Int , _b107 :: Int , _b108 :: Int , _b109 :: Int , _b110 :: Int , _b111 :: Int 38 | , _b112 :: Int , _b113 :: Int , _b114 :: Int , _b115 :: Int , _b116 :: Int , _b117 :: Int , _b118 :: Int , _b119 :: Int 39 | , _b120 :: Int , _b121 :: Int , _b122 :: Int , _b123 :: Int , _b124 :: Int , _b125 :: Int , _b126 :: Int , _b127 :: Int 40 | , _b128 :: Int , _b129 :: Int , _b130 :: Int , _b131 :: Int , _b132 :: Int , _b133 :: Int , _b134 :: Int , _b135 :: Int 41 | , _b136 :: Int , _b137 :: Int , _b138 :: Int , _b139 :: Int , _b140 :: Int , _b141 :: Int , _b142 :: Int , _b143 :: Int 42 | , _b144 :: Int , _b145 :: Int , _b146 :: Int , _b147 :: Int , _b148 :: Int , _b149 :: Int , _b150 :: Int , _b151 :: Int 43 | , _b152 :: Int , _b153 :: Int , _b154 :: Int , _b155 :: Int , _b156 :: Int , _b157 :: Int , _b158 :: Int , _b159 :: Int 44 | , _b160 :: Int , _b161 :: Int , _b162 :: Int , _b163 :: Int , _b164 :: Int , _b165 :: Int , _b166 :: Int , _b167 :: Int 45 | , _b168 :: Int , _b169 :: Int , _b170 :: Int , _b171 :: Int , _b172 :: Int , _b173 :: Int , _b174 :: Int , _b175 :: Int 46 | , _b176 :: Int , _b177 :: Int , _b178 :: Int , _b179 :: Int , _b180 :: Int , _b181 :: Int , _b182 :: Int , _b183 :: Int 47 | , _b184 :: Int , _b185 :: Int , _b186 :: Int , _b187 :: Int , _b188 :: Int , _b189 :: Int , _b190 :: Int , _b191 :: Int 48 | , _b192 :: Int , _b193 :: Int , _b194 :: Int , _b195 :: Int , _b196 :: Int , _b197 :: Int , _b198 :: Int , _b199 :: Int 49 | , _b200 :: Int , _b201 :: Int , _b202 :: Int , _b203 :: Int , _b204 :: Int , _b205 :: Int , _b206 :: Int , _b207 :: Int 50 | , _b208 :: Int , _b209 :: Int , _b210 :: Int , _b211 :: Int , _b212 :: Int , _b213 :: Int , _b214 :: Int , _b215 :: Int 51 | , _b216 :: Int , _b217 :: Int , _b218 :: Int , _b219 :: Int , _b220 :: Int , _b221 :: Int , _b222 :: Int , _b223 :: Int 52 | , _b224 :: Int , _b225 :: Int , _b226 :: Int , _b227 :: Int , _b228 :: Int , _b229 :: Int , _b230 :: Int , _b231 :: Int 53 | , _b232 :: Int , _b233 :: Int , _b234 :: Int , _b235 :: Int , _b236 :: Int , _b237 :: Int , _b238 :: Int , _b239 :: Int 54 | , _b240 :: Int , _b241 :: Int , _b242 :: Int , _b243 :: Int , _b244 :: Int , _b245 :: Int , _b246 :: Int , _b247 :: Int 55 | , _b248 :: Int , _b249 :: Int , _b250 :: Int , _b251 :: Int , _b252 :: Int , _b253 :: Int , _b254 :: Int , _b255 :: Int 56 | , _b256 :: Int , _b257 :: Int , _b258 :: Int , _b259 :: Int , _b260 :: Int , _b261 :: Int , _b262 :: Int , _b263 :: Int 57 | , _b264 :: Int , _b265 :: Int , _b266 :: Int , _b267 :: Int , _b268 :: Int , _b269 :: Int , _b270 :: Int , _b271 :: Int 58 | , _b272 :: Int , _b273 :: Int , _b274 :: Int , _b275 :: Int , _b276 :: Int , _b277 :: Int , _b278 :: Int , _b279 :: Int 59 | , _b280 :: Int , _b281 :: Int , _b282 :: Int , _b283 :: Int , _b284 :: Int , _b285 :: Int , _b286 :: Int , _b287 :: Int 60 | , _b288 :: Int , _b289 :: Int , _b290 :: Int , _b291 :: Int , _b292 :: Int , _b293 :: Int , _b294 :: Int , _b295 :: Int 61 | , _b296 :: Int , _b297 :: Int , _b298 :: Int , _b299 :: Int 62 | } 63 | 64 | makeLensesWith (lensRules & generateRecordSyntax .~ True) ''Big 65 | makeLensesWith (lensRules & generateRecordSyntax .~ True) ''Bigger 66 | -------------------------------------------------------------------------------- /tests/T1024.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE NoFieldSelectors #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TypeSynonymInstances #-} 8 | 9 | -- | Test 'makeFieldsId', which requires NoFieldSelectors and 10 | -- DuplicateRecordFields. This test consequently only works on GHC >= 9.2. 11 | module T1024 where 12 | 13 | import Control.Lens 14 | 15 | data Taco = Taco 16 | { hardShell :: Bool 17 | , sauce :: Int 18 | , filling :: String 19 | } 20 | data Burrito = Burrito 21 | { sauce :: Int 22 | , filling :: String 23 | } 24 | makeFieldsId ''Taco 25 | makeFieldsId ''Burrito 26 | 27 | checkTacoHardShell :: Lens' Taco Bool 28 | checkTacoHardShell = hardShell 29 | 30 | checkBurritoFilling :: Lens' Burrito String 31 | checkBurritoFilling = filling 32 | -------------------------------------------------------------------------------- /tests/T799.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | -- | Test 'makeFields' on a field whose type has a data family. Unlike for 7 | -- type families, for data families we do not generate type equality 8 | -- constraints, as they are not needed to avoid the issue in #754. 9 | -- 10 | -- This tests that the fix for #799 is valid by putting this in a module in 11 | -- which UndecidableInstances is not enabled. 12 | module T799 where 13 | 14 | import Control.Lens 15 | 16 | data family DF a 17 | newtype instance DF Int = FooInt Int 18 | 19 | data Bar = Bar { _barFoo :: DF Int } 20 | makeFields ''Bar 21 | 22 | checkBarFoo :: Lens' Bar (DF Int) 23 | checkBarFoo = foo 24 | -------------------------------------------------------------------------------- /tests/T917.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | 10 | #if __GLASGOW_HASKELL__ < 806 11 | {-# LANGUAGE TypeInType #-} 12 | #endif 13 | module T917 where 14 | 15 | import Control.Lens 16 | import Data.Kind 17 | import Data.Proxy 18 | 19 | -- Like Data.Functor.Const, but redefined to ensure that it is poly-kinded 20 | -- across all versions of GHC, not just 8.0+ 21 | newtype Constant a (b :: k) = Constant a 22 | 23 | data T917OneA (a :: k -> Type) (b :: k -> Type) = MkT917OneA 24 | data T917OneB a b = MkT917OneB (T917OneA a (Const b)) 25 | $(makePrisms ''T917OneB) 26 | 27 | data T917TwoA (a :: k -> Type) (b :: k -> Type) = MkT917TwoA 28 | data T917TwoB a b = MkT917TwoB (T917TwoA a (Const b)) 29 | $(makeClassyPrisms ''T917TwoB) 30 | 31 | data family T917DataFam (a :: k) 32 | data instance T917DataFam (a :: Type) = MkT917DataFam { _unT917DataFam :: Proxy a } 33 | $(makeLenses 'MkT917DataFam) 34 | 35 | data T917GadtOne (a :: k) where 36 | MkT917GadtOne :: T917GadtOne (a :: Type) 37 | $(makePrisms ''T917GadtOne) 38 | 39 | data T917GadtTwo (a :: k) where 40 | MkT917GadtTwo :: T917GadtTwo (a :: Type) 41 | $(makePrisms ''T917GadtTwo) 42 | -------------------------------------------------------------------------------- /tests/T972.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | #if __GLASGOW_HASKELL__ < 806 6 | {-# LANGUAGE TypeInType #-} 7 | #endif 8 | module T972 where 9 | 10 | import Control.Lens 11 | import Data.Proxy 12 | 13 | newtype Arc s = Arc { _unArc :: Int } 14 | 15 | data Direction = Negative | Positive 16 | data Dart s = Dart { _arc :: Arc s, _direction :: Direction } 17 | $(makeLenses ''Dart) 18 | 19 | data Fancy k (a :: k) = MkFancy { _unFancy1 :: k, _unFancy2 :: Proxy a } 20 | $(makeLenses ''Fancy) 21 | -------------------------------------------------------------------------------- /tests/doctests.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Main (doctests) 4 | -- Copyright : (C) 2012-14 Edward Kmett 5 | -- License : BSD-style (see the file LICENSE) 6 | -- Maintainer : Edward Kmett 7 | -- Stability : provisional 8 | -- Portability : portable 9 | -- 10 | -- This module exists to add dependencies 11 | ----------------------------------------------------------------------------- 12 | module Main where 13 | 14 | main :: IO () 15 | main = do 16 | putStrLn "This test-suite exists only to add dependencies" 17 | putStrLn "To run doctests: " 18 | putStrLn " cabal build all --enable-tests" 19 | putStrLn " cabal-docspec" 20 | --------------------------------------------------------------------------------