lens 3.1 → 3.2
raw patch · 21 files changed
+856/−254 lines, 21 files
Files
- CHANGELOG.markdown +11/−0
- examples/Brainfuck.hs +147/−0
- examples/bf-examples/99bottles.bf +60/−0
- examples/bf-examples/brainfuck.bf +6/−0
- examples/bf-examples/cat.bf +1/−0
- examples/bf-examples/helloworld.bf +23/−0
- examples/bf-examples/rot13.bf +23/−0
- examples/bf-examples/triangle.bf +33/−0
- examples/lens-examples.cabal +23/−1
- lens.cabal +6/−2
- src/Control/Lens.hs +3/−1
- src/Control/Lens/Fold.hs +26/−25
- src/Control/Lens/Getter.hs +11/−10
- src/Control/Lens/Internal.hs +216/−96
- src/Control/Lens/Loupe.hs +147/−0
- src/Control/Lens/Plated.hs +38/−23
- src/Control/Lens/Setter.hs +4/−3
- src/Control/Lens/Simple.hs +28/−0
- src/Control/Lens/Traversal.hs +5/−40
- src/Control/Lens/Tuple.hs +44/−44
- src/Control/Lens/Type.hs +1/−9
CHANGELOG.markdown view
@@ -1,3 +1,14 @@+3.2+---+* Made `elementOf` lazier and moved it from `Control.Lens.Traversal` to `Control.Lens.Plated`.+* Made `holesOf` and `partsOf` lazier to deal with infinite structures.+* Resolved issue #75. We now generate nicer core for most `Setter` and `Fold` operations, and some others.+* Made lenses for field access like `_1`, `_2`, etc. lazier.+* Added `Control.Lens.Loupe`, which provides a limited form of `Lens` that can be read from and written to and which can compose+ with other lenses, but can also be returned in a list or as a monadic result, but cannot be used directly for most combinators+ without cloning it first. It is easier to compose than a `ReifiedLens`, but slightly slower.+* Moved (`:=>`) and (`:->`) into `Control.Lens.Simple`, which is not exported by `Control.Lens` by default to reduce name conflicts with third party libraries.+ 3.1 --- * Simplified the type of `filtered`, so that it can be composed with other folds rather than be parameterized on one. Included the caveat that the new `filtered` is still not a legal `Traversal`, despite seeming to compose like one.
+ examples/Brainfuck.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE TypeOperators #-}+-----------------------------------------------------------------------------+-- |+-- Module : Brainfuck+-- Copyright : (C) 2012 Edward Kmett, nand`+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : TH, Rank2, NoMonomorphismRestriction+--+-- A simple interpreter for the esoteric programming language "Brainfuck"+-- written using lenses and zippers.+-----------------------------------------------------------------------------+module Main where++import Prelude hiding (Either(..))++import Control.Lens+import Control.Applicative+import Control.Monad.Free+import Control.Monad.RWS++import qualified Data.ByteString.Lazy as BS+import Data.Maybe (fromMaybe)+import qualified Data.Stream.Infinite as S+import Data.Word (Word8)++import System.Environment (getArgs)+import System.IO+++-- Low level syntax form++data Instr = Plus | Minus | Right | Left | Comma | Dot | Open | Close+type Code = [Instr]++parse :: String -> Code+parse = concatMap (maybe [] return . (`lookup` symbols))+ where symbols = [ ('+', Plus ), ('-', Minus), ('<', Left), ('>', Right)+ , (',', Comma), ('.', Dot ), ('[', Open), (']', Close) ]++-- Higher level semantic graph++data Brainfuck n+ = Succ n | Pred n -- Increment or decrement the current value+ | Next n | Prev n -- Shift memory left or right+ | Read n | Write n -- Input or output the current value++ -- Branching semantic, used for both sides of loops+ | Branch { zero :: n, nonzero :: n }++type Program = Free Brainfuck ()++compile :: Code -> Program+compile = fst . bracket []++bracket :: [Program] -> Code -> (Program, [Program])+bracket [] [] = (Pure (), [])+bracket _ [] = error "Mismatched opening bracket"+bracket [] (Close:_) = error "Mismatched closing bracket"++-- Match a closing bracket: Pop a forward continuation, push backwards+bracket (c:cs) (Close : xs) = (Free (Branch n c), n:bs)+ where (n, bs) = bracket cs xs++-- Match an opening bracket: Pop a backwards continuation, push forwards+bracket cs (Open : xs) = (Free (Branch b n), bs)+ where (n, b:bs) = bracket (n:cs) xs++-- Match any other symbol in the trivial way+bracket cs (x:xs) = over _1 (Free . f x) (bracket cs xs)+ where+ f Plus = Succ; f Minus = Pred+ f Right = Next; f Left = Prev+ f Comma = Read; f Dot = Write++-- * RWS-based interpreter++type Cell = Word8+type Input = S.Stream Cell+type Output = [Cell]+type Memory = Top :> [Cell] :> Cell -- list zipper++type Interpreter = RWS Input Output Memory ()++-- | Initial memory configuration+initial :: Memory+initial = zipper (replicate 30000 0) % fromWithin traverse++interpret :: Input -> Program -> Output+interpret i p = snd $ execRWS (run p) i initial++-- | Evaluation function+run :: Program -> Interpreter+run (Pure _) = return ()+run (Free f) = case f of+ Succ n -> focus += 1 >> run n+ Pred n -> focus -= 1 >> run n+ Next n -> modify wrapRight >> run n+ Prev n -> modify wrapLeft >> run n++ Read n -> do+ focus <~ asks S.head+ local S.tail $ run n++ Write n -> do+ tell . return =<< use focus+ run n++ Branch z n -> do+ c <- use focus+ run $ case c of 0 -> z; _ -> n++-- | Zipper helpers+wrapRight, wrapLeft :: (a :> b) -> (a :> b)+wrapRight = liftM2 fromMaybe leftmost right+wrapLeft = liftM2 fromMaybe rightmost left++-- Main program action to actually run this stuff++main :: IO ()+main = do+ as <- getArgs+ case as of+ -- STDIN is program+ [ ] -> do+ hSetBuffering stdin NoBuffering+ hSetBuffering stdout NoBuffering+ getContents >>= eval noInput++ -- STDIN is input+ [f] -> join $ eval <$> getInput <*> readFile f++ -- Malformed command line+ _ -> putStrLn "Usage: brainfuck [program]"++eval :: Input -> String -> IO ()+eval i = mapM_ putByte . interpret i . compile . parse+ where putByte = BS.putStr . BS.pack . return++-- | EOF is represented as 0+getInput :: IO Input+getInput = f <$> BS.getContents+ where f s = S.fromList (BS.unpack s ++ repeat 0)++noInput :: Input+noInput = S.repeat 0
+ examples/bf-examples/99bottles.bf view
@@ -0,0 +1,60 @@+99 Bottles of Beer in Urban Mueller's BrainF*** (The actual +name is impolite) + +by Ben Olmstead + +ANSI C interpreter available on the internet; due to +constraints in comments the address below needs to have the +stuff in parenthesis replaced with the appropriate symbol: + +http://www(dot)cats(dash)eye(dot)com/cet/soft/lang/bf/ + +Believe it or not this language is indeed Turing complete! +Combines the speed of BASIC with the ease of INTERCAL and +the readability of an IOCCC entry! + +>+++++++++[<+++++++++++>-]<[>[-]>[-]<<[>+>+<<-]>>[<<+>>-]>>> +[-]<<<+++++++++<[>>>+<<[>+>[-]<<-]>[<+>-]>[<<++++++++++>>>+< +-]<<-<-]+++++++++>[<->-]>>+>[<[-]<<+>>>-]>[-]+<<[>+>-<<-]<<< +[>>+>+<<<-]>>>[<<<+>>>-]>[<+>-]<<-[>[-]<[-]]>>+<[>[-]<-]<+++ ++++++[<++++++<++++++>>-]>>>[>+>+<<-]>>[<<+>>-]<[<<<<<.>>>>>- +]<<<<<<.>>[-]>[-]++++[<++++++++>-]<.>++++[<++++++++>-]<++.>+ +++++[<+++++++++>-]<.><+++++..--------.-------.>>[>>+>+<<<-]> +>>[<<<+>>>-]<[<<<<++++++++++++++.>>>>-]<<<<[-]>++++[<+++++++ ++>-]<.>+++++++++[<+++++++++>-]<--.---------.>+++++++[<------ +---->-]<.>++++++[<+++++++++++>-]<.+++..+++++++++++++.>++++++ +++[<---------->-]<--.>+++++++++[<+++++++++>-]<--.-.>++++++++ +[<---------->-]<++.>++++++++[<++++++++++>-]<++++.----------- +-.---.>+++++++[<---------->-]<+.>++++++++[<+++++++++++>-]<-. +>++[<----------->-]<.+++++++++++..>+++++++++[<---------->-]< +-----.---.>>>[>+>+<<-]>>[<<+>>-]<[<<<<<.>>>>>-]<<<<<<.>>>+++ ++[<++++++>-]<--.>++++[<++++++++>-]<++.>+++++[<+++++++++>-]<. +><+++++..--------.-------.>>[>>+>+<<<-]>>>[<<<+>>>-]<[<<<<++ +++++++++++++.>>>>-]<<<<[-]>++++[<++++++++>-]<.>+++++++++[<++ ++++++++>-]<--.---------.>+++++++[<---------->-]<.>++++++[<++ ++++++++++>-]<.+++..+++++++++++++.>++++++++++[<---------->-]< +-.---.>+++++++[<++++++++++>-]<++++.+++++++++++++.++++++++++. +------.>+++++++[<---------->-]<+.>++++++++[<++++++++++>-]<-. +-.---------.>+++++++[<---------->-]<+.>+++++++[<++++++++++>- +]<--.+++++++++++.++++++++.---------.>++++++++[<---------->-] +<++.>+++++[<+++++++++++++>-]<.+++++++++++++.----------.>++++ ++++[<---------->-]<++.>++++++++[<++++++++++>-]<.>+++[<-----> +-]<.>+++[<++++++>-]<..>+++++++++[<--------->-]<--.>+++++++[< +++++++++++>-]<+++.+++++++++++.>++++++++[<----------->-]<++++ +.>+++++[<+++++++++++++>-]<.>+++[<++++++>-]<-.---.++++++.---- +---.----------.>++++++++[<----------->-]<+.---.[-]<<<->[-]>[ +-]<<[>+>+<<-]>>[<<+>>-]>>>[-]<<<+++++++++<[>>>+<<[>+>[-]<<-] +>[<+>-]>[<<++++++++++>>>+<-]<<-<-]+++++++++>[<->-]>>+>[<[-]< +<+>>>-]>[-]+<<[>+>-<<-]<<<[>>+>+<<<-]>>>[<<<+>>>-]<>>[<+>-]< +<-[>[-]<[-]]>>+<[>[-]<-]<++++++++[<++++++<++++++>>-]>>>[>+>+ +<<-]>>[<<+>>-]<[<<<<<.>>>>>-]<<<<<<.>>[-]>[-]++++[<++++++++> +-]<.>++++[<++++++++>-]<++.>+++++[<+++++++++>-]<.><+++++..--- +-----.-------.>>[>>+>+<<<-]>>>[<<<+>>>-]<[<<<<++++++++++++++ +.>>>>-]<<<<[-]>++++[<++++++++>-]<.>+++++++++[<+++++++++>-]<- +-.---------.>+++++++[<---------->-]<.>++++++[<+++++++++++>-] +<.+++..+++++++++++++.>++++++++[<---------->-]<--.>+++++++++[ +<+++++++++>-]<--.-.>++++++++[<---------->-]<++.>++++++++[<++ +++++++++>-]<++++.------------.---.>+++++++[<---------->-]<+. +>++++++++[<+++++++++++>-]<-.>++[<----------->-]<.+++++++++++ +..>+++++++++[<---------->-]<-----.---.+++.---.[-]<<<] +
+ examples/bf-examples/brainfuck.bf view
@@ -0,0 +1,6 @@+>>>+[[-]>>[-]++>+>+++++++[<++++>>++<-]++>>+>+>+++++[>++>++++++<<-]+>>>,<++[[>[+->>]<[>>]<<-]<[<]<+>>[>]>[<+>-[[<+>-]>]<[[[-]<]++<-[<+++++++++>[<->-]>>]>>]]<<+]<]<[[<]>[[>]>>[>>]+[<<]<[<]<+>>-]>[>]+[->>]<<<<[[<<]<[<]+<<[+>+<<-[>-->+<<-[>++<[>>+<<-]]]>[<+>-]<]++>>-->[>]>>[>>]]<<[>>+<[[<]<]>[[<<]<[<]+[-<+>>-[<<+>++>-+[<->[<<+>>-]]]<[>+<-]>]>[>]>]>[>>]>>]<<[>>+>>+>>]<<[->>>>>>>>]<<[>.>>>>>>>]<<[+>->>>>>]<<[>,>>>]<<[>+>]<<[+<<]<]
+ examples/bf-examples/cat.bf view
@@ -0,0 +1,1 @@+,[.,]
+ examples/bf-examples/helloworld.bf view
@@ -0,0 +1,23 @@+Source: Wikipedia+++++++ +++++ initialize counter (cell #0) to 10+[ use loop to set the next four cells to 70/100/30/10+ > +++++ ++ add 7 to cell #1+ > +++++ +++++ add 10 to cell #2+ > +++ add 3 to cell #3+ > + add 1 to cell #4+ <<<< - decrement counter (cell #0)+]+> ++ . print 'H'+> + . print 'e'++++++ ++ . print 'l'+. print 'l'++++ . print 'o'+> ++ . print ' '+<< +++++ +++++ +++++ . print 'W'+> . print 'o'++++ . print 'r'+----- - . print 'l'+----- --- . print 'd'+> + . print '!'+> . print '\n'
+ examples/bf-examples/rot13.bf view
@@ -0,0 +1,23 @@+,+[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-+[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-+[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-+[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-+[>++++++++++++++<-+[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-+[>>+++++[<----->-]<<-+[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-+[>++++++++++++++<-+[>+<-[>+<-[>+<-[>+<-[>+<-+[>++++++++++++++<-+[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-+[>>+++++[<----->-]<<-+[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-+[>++++++++++++++<-+[>+<-]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]+]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]>.[-]<,]++of course any function char f(char) can be made easily on the same principle++[Daniel B Cristofani (cristofdathevanetdotcom)+http://www.hevanet.com/cristofd/brainfuck/]
+ examples/bf-examples/triangle.bf view
@@ -0,0 +1,33 @@+[ This program prints Sierpinski triangle on 80-column display. ] + > + + + + + + + [ < + + + + + + + + + + + > - ] > + + + + + + + + + + [ > + + + + + + < - ] > + > + + > > > + > + > > + < + < < < < < < < < + < [ - [ - > + < + ] > [ - < + > > > . < < ] > > > + [ [ + - > + + + + + + + + + + [ > + + + + + < - ] > + . < < [ - > + < + ] + > [ - > + + + + + + + + + + + < < + > ] > . [ + - ] > ] + ] + < < < [ - [ + - > + < ] + > [ + - < + > > > - [ - > + < ] + + > + [ - < - > ] < < + < ] < < < < ] + + + + + + + + + + + . + + + . [ - ] < ] + + + + + + * * * * * M a d e * B y : * N Y Y R I K K I * 2 0 0 2 * * * * *
examples/lens-examples.cabal view
@@ -20,12 +20,34 @@ type: git location: git://github.com/ekmett/lens.git +flag pong+ default: True++flag brainfuck+ default: True+ executable pong+ if !flag(pong)+ buildable: False+ build-depends:- base == 4.*,+ base, containers >= 0.4.2 && < 0.6, gloss == 1.7.*, lens, mtl >= 2.0.1 && < 2.2, random == 1.0.* main-is: Pong.hs++executable brainfuck+ if !flag(pong)+ buildable: False++ build-depends:+ base,+ lens == 3.2.*,+ free >= 3.0 && < 3.3,+ bytestring,+ mtl >= 2.0.1 && < 2.2,+ streams == 3.0.*+ main-is: Brainfuck.hs
lens.cabal view
@@ -1,6 +1,6 @@ name: lens category: Data, Lenses-version: 3.1+version: 3.2 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE@@ -37,7 +37,7 @@ . The core of this hierarchy looks like: .- <<https://github.com/ekmett/lens/wiki/images/Hierarchy-3.1.png>>+ <<https://github.com/ekmett/lens/wiki/images/Hierarchy-3.2.png>> . You can compose any two elements of the hierarchy above using (.) from the Prelude, and you can use any element of the hierarchy as any type it links to above it.@@ -94,6 +94,8 @@ examples/Pong.hs examples/Plates.hs examples/Aeson.hs+ examples/Brainfuck.hs+ examples/bf-examples/*.bf README.markdown CHANGELOG.markdown @@ -169,10 +171,12 @@ Control.Lens.Internal Control.Lens.Iso Control.Lens.Isomorphic+ Control.Lens.Loupe Control.Lens.Plated Control.Lens.Projection Control.Lens.Representable Control.Lens.Setter+ Control.Lens.Simple Control.Lens.Traversal Control.Lens.Tuple Control.Lens.Type
src/Control/Lens.hs view
@@ -41,7 +41,7 @@ -- -- <http://github.com/ekmett/lens/wiki> ----- <<http://github.com/ekmett/lens/wiki/images/Hierarchy-3.1.png>>+-- <<http://github.com/ekmett/lens/wiki/images/Hierarchy-3.2.png>> ---------------------------------------------------------------------------- module Control.Lens ( module Control.Lens.Type@@ -58,6 +58,7 @@ , module Control.Lens.IndexedLens , module Control.Lens.IndexedTraversal , module Control.Lens.IndexedSetter+ , module Control.Lens.Loupe , module Control.Lens.Plated , module Control.Lens.Projection , module Control.Lens.Representable@@ -81,6 +82,7 @@ import Control.Lens.IndexedSetter import Control.Lens.IndexedTraversal import Control.Lens.Iso+import Control.Lens.Loupe import Control.Lens.Plated import Control.Lens.Projection import Control.Lens.Representable
src/Control/Lens/Fold.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LiberalTypeSynonyms #-}@@ -120,7 +121,7 @@ -- | Obtain a 'Fold' from any 'Foldable'. folded :: Foldable f => Fold (f a) a-folded f = coerce . getFolding . foldMap (Folding . f)+folded f = coerce . getFolding . foldMap (folding# f) {-# INLINE folded #-} -- | Fold by repeating the input forever.@@ -185,11 +186,11 @@ -- This will demote an 'Control.Lens.IndexedTraversal.IndexedTraversal' or 'Control.Lens.IndexedFold.IndexedFold' to a regular 'Control.Lens.Traversal.Traversal' or 'Fold'; -- to preserve the indices, use 'Control.Lens.IndexedFold.ibackwards' instead. ----- Note: 'backwards' should have no impact on a 'Getter' 'Setter', 'Lens' or 'Control.Lens.Iso.Iso'.+-- Note: 'backwards' should have no impact on a 'Getter', 'Control.Lens.Setter.Setter', 'Lens' or 'Control.Lens.Iso.Iso'. ----- To change the direction of an 'Control.Lens.Iso.Iso', use 'from'.+-- To change the direction of an 'Control.Lens.Iso.Iso', use 'Control.Lens.Isomorphic.from'. backwards :: LensLike (Backwards f) s t a b -> LensLike f s t a b-backwards l f = forwards . l (Backwards . f)+backwards l f = forwards# $ l (backwards# f) {-# INLINE backwards #-} -- | Obtain a 'Fold' by taking elements from another 'Fold', 'Lens', 'Control.Lens.Iso.Iso', 'Getter' or 'Control.Lens.Traversal.Traversal' while a predicate holds.@@ -239,7 +240,7 @@ -- 'foldMapOf' :: 'Monoid' r => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r) -> s -> r -- @ foldMapOf :: Getting r s t a b -> (a -> r) -> s -> r-foldMapOf l f = runAccessor . l (Accessor . f)+foldMapOf l f = runAccessor# (l (accessor# f)) {-# INLINE foldMapOf #-} -- |@@ -255,7 +256,7 @@ -- 'foldOf' :: 'Monoid' m => 'Simple' 'Control.Lens.Traversal.Traversal' s m -> s -> m -- @ foldOf :: Getting a s t a b -> s -> a-foldOf l = runAccessor . l Accessor+foldOf l = runAccessor# (l Accessor) {-# INLINE foldOf #-} -- |@@ -271,7 +272,7 @@ -- 'foldrOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r -> r) -> r -> s -> r -- @ foldrOf :: Getting (Endo r) s t a b -> (a -> r -> r) -> r -> s -> r-foldrOf l f z t = appEndo (foldMapOf l (Endo . f) t) z+foldrOf l f z t = appEndo (foldMapOf l (endo# f) t) z {-# INLINE foldrOf #-} -- |@@ -287,7 +288,7 @@ -- 'foldlOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (r -> a -> r) -> r -> s -> r -- @ foldlOf :: Getting (Dual (Endo r)) s t a b -> (r -> a -> r) -> r -> s -> r-foldlOf l f z t = appEndo (getDual (foldMapOf l (Dual . Endo . flip f) t)) z+foldlOf l f z t = appEndo (getDual (foldMapOf l (dual# (endo# (flip f))) t)) z {-# INLINE foldlOf #-} -- | Extract a list of the targets of a 'Fold'. See also ('^..').@@ -353,7 +354,7 @@ -- 'andOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s 'Bool' -> s -> 'Bool' -- @ andOf :: Getting All s t Bool b -> s -> Bool-andOf l = getAll . foldMapOf l All+andOf l = getAll# (foldMapOf l All) {-# INLINE andOf #-} -- | Returns 'True' if any target of a 'Fold' is 'True'.@@ -373,7 +374,7 @@ -- 'orOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s 'Bool' -> s -> 'Bool' -- @ orOf :: Getting Any s t Bool b -> s -> Bool-orOf l = getAny . foldMapOf l Any+orOf l = getAny# (foldMapOf l Any) {-# INLINE orOf #-} -- | Returns 'True' if any target of a 'Fold' satisfies a predicate.@@ -394,7 +395,7 @@ -- 'anyOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> 'Bool') -> s -> 'Bool' -- @ anyOf :: Getting Any s t a b -> (a -> Bool) -> s -> Bool-anyOf l f = getAny . foldMapOf l (Any . f)+anyOf l f = getAny# $ foldMapOf l (any# f) {-# INLINE anyOf #-} -- | Returns 'True' if every target of a 'Fold' satisfies a predicate.@@ -414,7 +415,7 @@ -- 'allOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> 'Bool') -> s -> 'Bool' -- @ allOf :: Getting All s t a b -> (a -> Bool) -> s -> Bool-allOf l f = getAll . foldMapOf l (All . f)+allOf l f = getAll# $ foldMapOf l (all# f) {-# INLINE allOf #-} -- | Calculate the product of every number targeted by a 'Fold'@@ -434,7 +435,7 @@ -- 'productOf' :: 'Num' a => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> a -- @ productOf :: Getting (Product a) s t a b -> s -> a-productOf l = getProduct . foldMapOf l Product+productOf l = getProduct# $ foldMapOf l Product {-# INLINE productOf #-} -- | Calculate the sum of every number targeted by a 'Fold'.@@ -464,7 +465,7 @@ -- 'sumOf' :: 'Num' a => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> a -- @ sumOf :: Getting (Sum a) s t a b -> s -> a-sumOf l = getSum . foldMapOf l Sum+sumOf l = getSum# $ foldMapOf l Sum {-# INLINE sumOf #-} -- | Traverse over all of the targets of a 'Fold' (or 'Getter'), computing an 'Applicative' (or 'Functor') -based answer,@@ -495,7 +496,7 @@ -- 'traverseOf_' :: 'Applicative' f => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> f r) -> s -> f () -- @ traverseOf_ :: Functor f => Getting (Traversed f) s t a b -> (a -> f r) -> s -> f ()-traverseOf_ l f = getTraversed . foldMapOf l (Traversed . void . f)+traverseOf_ l f = getTraversed# (foldMapOf l (traversed# (void . f))) {-# INLINE traverseOf_ #-} -- | Traverse over all of the targets of a 'Fold' (or 'Getter'), computing an 'Applicative' (or 'Functor') -based answer,@@ -532,7 +533,7 @@ -- 'sequenceAOf_' :: 'Applicative' f => 'Simple' 'Control.Lens.Traversal.Traversal' s (f ()) -> s -> f () -- @ sequenceAOf_ :: Functor f => Getting (Traversed f) s t (f ()) b -> s -> f ()-sequenceAOf_ l = getTraversed . foldMapOf l (Traversed . void)+sequenceAOf_ l = getTraversed# (foldMapOf l (traversed# void)) {-# INLINE sequenceAOf_ #-} -- | Map each target of a 'Fold' on a structure to a monadic action, evaluate these actions from left to right, and ignore the results.@@ -547,7 +548,7 @@ -- 'mapMOf_' :: 'Monad' m => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> m r) -> s -> m () -- @ mapMOf_ :: Monad m => Getting (Sequenced m) s t a b -> (a -> m r) -> s -> m ()-mapMOf_ l f = getSequenced . foldMapOf l (Sequenced . liftM skip . f)+mapMOf_ l f = getSequenced# (foldMapOf l (sequenced# (liftM skip . f))) {-# INLINE mapMOf_ #-} skip :: a -> ()@@ -581,7 +582,7 @@ -- 'sequenceOf_' :: 'Monad' m => 'Simple' 'Control.Lens.Traversal.Traversal' s (m a) -> s -> m () -- @ sequenceOf_ :: Monad m => Getting (Sequenced m) s t (m a) b -> s -> m ()-sequenceOf_ l = getSequenced . foldMapOf l (Sequenced . liftM skip)+sequenceOf_ l = getSequenced# (foldMapOf l (sequenced# (liftM skip))) {-# INLINE sequenceOf_ #-} -- | The sum of a collection of actions, generalizing 'concatOf'.@@ -659,7 +660,7 @@ -- 'concatMapOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> [r]) -> s -> [r] -- @ concatMapOf :: Getting [r] s t a b -> (a -> [r]) -> s -> [r]-concatMapOf l ces = runAccessor . l (Accessor . ces)+concatMapOf l ces = runAccessor# (l (accessor# ces)) {-# INLINE concatMapOf #-} -- | Concatenate all of the lists targeted by a 'Fold' into a longer list.@@ -701,7 +702,7 @@ -- 'lengthOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> 'Int' -- @ lengthOf :: Getting (Sum Int) s t a b -> s -> Int-lengthOf l = getSum . foldMapOf l (\_ -> Sum 1)+lengthOf l = getSum# (foldMapOf l (\_ -> Sum 1)) {-# INLINE lengthOf #-} -- | Perform a safe 'head' of a 'Fold' or 'Control.Lens.Traversal.Traversal' or retrieve 'Just' the result@@ -717,7 +718,7 @@ -- 'headOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> 'Maybe' a -- @ headOf :: Getting (First a) s t a b -> s -> Maybe a-headOf l = getFirst . foldMapOf l (First . Just)+headOf l = getFirst# (foldMapOf l (first# Just)) {-# INLINE headOf #-} -- | Perform a safe 'head' of a 'Fold' or 'Control.Lens.Traversal.Traversal' or retrieve 'Just' the result@@ -736,7 +737,7 @@ -- ('^?') :: s -> 'Simple' 'Control.Lens.Traversal.Traversal' s a -> 'Maybe' a -- @ (^?) :: s -> Getting (First a) s t a b -> Maybe a-a ^? l = getFirst (foldMapOf l (First . Just) a)+a ^? l = getFirst (foldMapOf l (first# Just) a) {-# INLINE (^?) #-} -- | Perform a safe 'last' of a 'Fold' or 'Control.Lens.Traversal.Traversal' or retrieve 'Just' the result@@ -750,7 +751,7 @@ -- 'lastOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> 'Maybe' a -- @ lastOf :: Getting (Last a) s t a b -> s -> Maybe a-lastOf l = getLast . foldMapOf l (Last . Just)+lastOf l = getLast# (foldMapOf l (last# Just)) {-# INLINE lastOf #-} -- |@@ -775,7 +776,7 @@ -- 'nullOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> 'Bool' -- @ nullOf :: Getting All s t a b -> s -> Bool-nullOf l = getAll . foldMapOf l (\_ -> All False)+nullOf l = getAll# (foldMapOf l (\_ -> All False)) {-# INLINE nullOf #-} -- |@@ -864,7 +865,7 @@ -- 'findOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> 'Bool') -> s -> 'Maybe' a -- @ findOf :: Getting (First a) s t a b -> (a -> Bool) -> s -> Maybe a-findOf l p = getFirst . foldMapOf l step where+findOf l p = getFirst# (foldMapOf l step) where step a | p a = First (Just a) | otherwise = First Nothing
src/Control/Lens/Getter.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE MagicHash #-} {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -183,7 +184,7 @@ -- 'view' :: 'Monoid' m => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s m -> s -> m -- @ view :: Getting a s t a b -> s -> a-view l = runAccessor . l Accessor+view l = runAccessor# (l Accessor) {-# INLINE view #-} -- | View the value of a 'Getter', 'Control.Lens.Iso.Iso',@@ -200,14 +201,14 @@ -- 5 -- -- @--- 'views' :: 'Getter' s a -> (a -> b) -> s -> b+-- 'views' :: 'Getter' s a -> (a -> r) -> s -> r -- 'views' :: 'Monoid' m => 'Control.Lens.Fold.Fold' s a -> (a -> m) -> s -> m--- 'views' :: 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> (a -> b) -> s -> b--- 'views' :: 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> (a -> b) -> s -> b+-- 'views' :: 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> (a -> r) -> s -> r+-- 'views' :: 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> (a -> r) -> s -> r -- 'views' :: 'Monoid' m => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> m) -> s -> m -- @-views :: Getting m s t a b -> (a -> m) -> s -> m-views l f = runAccessor . l (Accessor . f)+views :: Getting r s t a b -> (a -> r) -> s -> r+views l f = runAccessor# (l (accessor# f)) {-# INLINE views #-} -- | View the value pointed to by a 'Getter', 'Control.Lens.Iso.Iso' or@@ -288,13 +289,13 @@ -- points to a monoidal value. -- -- @--- 'uses' :: 'MonadState' s m => 'Getter' s a -> (a -> e) -> m e+-- 'uses' :: 'MonadState' s m => 'Getter' s a -> (a -> r) -> m r -- 'uses' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Fold.Fold' s a -> (a -> r) -> m r--- 'uses' :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> (a -> e) -> m e--- 'uses' :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> (a -> e) -> m e+-- 'uses' :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> (a -> r) -> m r+-- 'uses' :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> (a -> r) -> m r -- 'uses' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r) -> m r -- @-uses :: MonadState s m => Getting e s t a b -> (a -> e) -> m e+uses :: MonadState s m => Getting r s t a b -> (a -> r) -> m r uses l f = State.gets (views l f) {-# INLINE uses #-}
src/Control/Lens/Internal.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MagicHash #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Trustworthy #-} #endif@@ -25,39 +26,7 @@ -- \"Family\" and need to add instances. -- -----------------------------------------------------------------------------module Control.Lens.Internal- (- -- * Implementation details- Context(..)- , Focusing(..)- , FocusingWith(..)- , FocusingPlus(..)- , FocusingOn(..)- , FocusingErr(..), Err(..)- , FocusingMay(..), May(..)- , Traversed(..)- , Sequenced(..)- , Indexing(..), IndexingResult(..)- , Min(..)- , getMin- , Max(..)- , getMax- , ElementOf(..)- , ElementOfResult(..)- , Bazaar(..), bazaar, duplicateBazaar, sell- , Effect(..)- , EffectRWS(..)- -- * Getter internals- , Gettable(..), Accessor(..), Effective(..), ineffective, noEffect, Folding(..)- -- * Setter internals- , Settable(..), Mutator(..)- -- * Zipper internals- , Level(..), levelWidth- , leftLevel, left1Level, leftmostLevel- , rightLevel, right1Level, rightmostLevel- , rezipLevel- , focusLevel- ) where+module Control.Lens.Internal where import Control.Applicative import Control.Applicative.Backwards@@ -74,7 +43,176 @@ import Data.Maybe import Data.Monoid import Data.Traversable+import Unsafe.Coerce +const# :: (a -> b) -> a -> Const b r+const# = unsafeCoerce++getConst# :: (a -> Const b r) -> a -> b+getConst# = unsafeCoerce++zipList# :: (a -> [b]) -> a -> ZipList b+zipList# = unsafeCoerce++getZipList# :: (a -> ZipList b) -> a -> [b]+getZipList# = unsafeCoerce++wrapMonad# :: (a -> m b) -> a -> WrappedMonad m b+wrapMonad# = unsafeCoerce++unwrapMonad# :: (a -> WrappedMonad m b) -> a -> m b+unwrapMonad# = unsafeCoerce++last# :: (a -> Maybe b) -> a -> Last b+last# = unsafeCoerce++getLast# :: (a -> Last b) -> a -> Maybe b+getLast# = unsafeCoerce++first# :: (a -> Maybe b) -> a -> First b+first# = unsafeCoerce++getFirst# :: (a -> First b) -> a -> Maybe b+getFirst# = unsafeCoerce++product# :: (a -> b) -> a -> Product b+product# = unsafeCoerce++getProduct# :: (a -> Product b) -> a -> b+getProduct# = unsafeCoerce++sum# :: (a -> b) -> a -> Sum b+sum# = unsafeCoerce++getSum# :: (a -> Sum b) -> a -> b+getSum# = unsafeCoerce++any# :: (a -> Bool) -> a -> Any+any# = unsafeCoerce++getAny# :: (a -> Any) -> a -> Bool+getAny# = unsafeCoerce++all# :: (a -> Bool) -> a -> All+all# = unsafeCoerce++getAll# :: (a -> All) -> a -> Bool+getAll# = unsafeCoerce++dual# :: (a -> b) -> a -> Dual b+dual# = unsafeCoerce++getDual# :: (a -> Dual b) -> a -> b+getDual# = unsafeCoerce++endo# :: (a -> b -> b) -> a -> Endo b+endo# = unsafeCoerce++appEndo# :: (a -> Endo b) -> a -> b -> b+appEndo# = unsafeCoerce++may# :: (a -> Maybe b) -> a -> May b+may# = unsafeCoerce++getMay# :: (a -> May b) -> a -> Maybe b+getMay# = unsafeCoerce++folding# :: (a -> f b) -> a -> Folding f b+folding# = unsafeCoerce++getFolding# :: (a -> Folding f b) -> a -> f b+getFolding# = unsafeCoerce++effect# :: (a -> m r) -> a -> Effect m r b+effect# = unsafeCoerce++getEffect# :: (a -> Effect m r b) -> a -> m r+getEffect# = unsafeCoerce++effectRWS# :: (a -> st -> m (s, st, w)) -> a -> EffectRWS w st m s b+effectRWS# = unsafeCoerce++getEffectRWS# :: (a -> EffectRWS w st m s b) -> a -> st -> m (s, st, w)+getEffectRWS# = unsafeCoerce++accessor# :: (a -> r) -> a -> Accessor r b+accessor# = unsafeCoerce++runAccessor# :: (a -> Accessor r b) -> a -> r+runAccessor# = unsafeCoerce++err# :: (a -> Either e b) -> a -> Err e b+err# = unsafeCoerce++getErr# :: (a -> Err e b) -> a -> Either e b+getErr# = unsafeCoerce++traversed# :: (a -> f ()) -> a -> Traversed f+traversed# = unsafeCoerce++getTraversed# :: (a -> Traversed f) -> a -> f ()+getTraversed# = unsafeCoerce++sequenced# :: (a -> f ()) -> a -> Sequenced f+sequenced# = unsafeCoerce++getSequenced# :: (a -> Sequenced f) -> a -> f ()+getSequenced# = unsafeCoerce++focusing# :: (a -> m (s, b)) -> a -> Focusing m s b+focusing# = unsafeCoerce++unfocusing# :: (a -> Focusing m s b) -> a -> m (s, b)+unfocusing# = unsafeCoerce++focusingWith# :: (a -> m (s, b, w)) -> a -> FocusingWith w m s b+focusingWith# = unsafeCoerce++unfocusingWith# :: (a -> FocusingWith w m s b) -> a -> m (s, b, w)+unfocusingWith# = unsafeCoerce++focusingPlus# :: (a -> k (s, w) b) -> a -> FocusingPlus w k s b+focusingPlus# = unsafeCoerce++unfocusingPlus# :: (a -> FocusingPlus w k s b) -> a -> k (s, w) b+unfocusingPlus# = unsafeCoerce++focusingOn# :: (a -> k (f s) b) -> a -> FocusingOn f k s b+focusingOn# = unsafeCoerce++unfocusingOn# :: (a -> FocusingOn f k s b) -> a -> k (f s) b+unfocusingOn# = unsafeCoerce++focusingMay# :: (a -> k (May s) b) -> a -> FocusingMay k s b+focusingMay# = unsafeCoerce++unfocusingMay# :: (a -> FocusingMay k s b) -> a -> k (May s) b+unfocusingMay# = unsafeCoerce++focusingErr# :: (a -> k (Err e s) b) -> a -> FocusingErr e k s b+focusingErr# = unsafeCoerce++unfocusingErr# :: (a -> FocusingErr e k s b) -> a -> k (Err e s) b+unfocusingErr# = unsafeCoerce++bazaar# :: (forall f. Applicative f => a -> (c -> f d) -> f t) -> a -> Bazaar c d t+bazaar# = unsafeCoerce++runBazaar# :: Applicative f => (a -> Bazaar c d t) -> a -> (c -> f d) -> f t+runBazaar# = unsafeCoerce++mutator# :: (a -> b) -> a -> Mutator b+mutator# = unsafeCoerce++runMutator# :: (a -> Mutator b) -> a -> b+runMutator# = unsafeCoerce++backwards# :: (a -> f b) -> a -> Backwards f b+backwards# = unsafeCoerce++forwards# :: (a -> Backwards f b) -> a -> f b+forwards# = unsafeCoerce+ ----------------------------------------------------------------------------- -- Functors -----------------------------------------------------------------------------@@ -167,26 +305,6 @@ pure = FocusingErr . pure FocusingErr kf <*> FocusingErr ka = FocusingErr (kf <*> ka) --- | The indexed store can be used to characterize a 'Control.Lens.Type.Lens'--- and is used by 'Control.Lens.Type.clone'-data Context a b s = Context (b -> s) a--instance Functor (Context a b) where- fmap f (Context g s) = Context (f . g) s--instance (a ~ b) => Comonad (Context a b) where- extract (Context f s) = f s- duplicate (Context f s) = Context (Context f) s- extend g (Context f s) = Context (g . Context f) s--instance (a ~ b) => ComonadStore a (Context a b) where- pos (Context _ s) = s- peek s (Context g _) = g s- peeks f (Context g s) = g (f s)- seek s (Context g _) = Context g s- seeks f (Context g s) = Context g (f s)- experiment f (Context g s) = g <$> f s- -- | The result of 'Indexing' data IndexingResult f a = IndexingResult (f a) {-# UNPACK #-} !Int @@ -252,39 +370,32 @@ getMax NoMax = Nothing getMax (Max a) = Just a --- | The result of trying to find the /n/th 'Control.Lens.Traversal.element' of a 'Control.Lens.Traversal.Traversal'.-data ElementOfResult f a- = Searching {-# UNPACK #-} !Int a- | Found {-# UNPACK #-} !Int (f a)- | NotFound String -instance Functor f => Functor (ElementOfResult f) where- fmap f (Searching i a) = Searching i (f a)- fmap f (Found i as) = Found i (fmap f as)- fmap _ (NotFound e) = NotFound e---- | Used to find the /n/th 'Control.Lens.Traversal.element' of a 'Control.Lens.Traversal.Traversal'.-newtype ElementOf f a = ElementOf { getElementOf :: Int -> ElementOfResult f a }+-- | The indexed store can be used to characterize a 'Control.Lens.Type.Lens'+-- and is used by 'Control.Lens.Type.clone'+--+-- @'Context' a b t@ is isomorphic to+-- @newtype Context a b t = Context { runContext :: forall f. Functor f => (a -> f b) -> f t }@,+-- and to @exists s. (s, 'Control.Lens.Type.Lens' s t a b)@.+--+-- A 'Context' is like a 'Control.Lens.Type.Lens' that has already been applied to a some structure.+data Context a b t = Context (b -> t) a -instance Functor f => Functor (ElementOf f) where- fmap f (ElementOf m) = ElementOf $ \i -> case m i of- Searching j a -> Searching j (f a)- Found j as -> Found j (fmap f as)- NotFound e -> NotFound e+instance Functor (Context a b) where+ fmap f (Context g t) = Context (f . g) t -instance Functor f => Applicative (ElementOf f) where- pure a = ElementOf $ \i -> Searching i a- ElementOf mf <*> ElementOf ma = ElementOf $ \i -> case mf i of- Found j ff -> case ma j of- Found _ _ -> NotFound "multiple results"- Searching k a -> Found k (fmap ($ a) ff)- NotFound e -> NotFound e- Searching j f -> case ma j of- Found k as -> Found k (fmap f as)- Searching k a -> Searching k (f a)- NotFound e -> NotFound e- NotFound e -> NotFound e+instance (a ~ b) => Comonad (Context a b) where+ extract (Context f a) = f a+ duplicate (Context f a) = Context (Context f) a+ extend g (Context f a) = Context (g . Context f) a +instance (a ~ b) => ComonadStore a (Context a b) where+ pos (Context _ a) = a+ peek b (Context g _) = g b+ peeks f (Context g a) = g (f a)+ seek a (Context g _) = Context g a+ seeks f (Context g a) = Context g (f a)+ experiment f (Context g a) = g <$> f a -- | This is used to characterize a 'Control.Lens.Traversal.Traversal'. --@@ -292,12 +403,21 @@ -- -- <http://twanvl.nl/blog/haskell/non-regular1> --+-- @'Bazaar' a b t@ is isomorphic to @data Bazaar a b t = Buy t | Trade (Bazaar a b (b -> t)) a@,+-- and to @exists s. (s, 'Control.Lens.Traversal.Traversal' s t a b)@.+--+-- A 'Bazaar' is like a 'Control.Lens.Traversal.Traversal' that has already been applied to some structure.+--+-- Where a @'Context' a b t@ holds an @a@ and a function from @b@ to+-- @t@, a @'Bazaar' a b t@ holds N @a@s and a function from N+-- @b@s to @t@.+-- -- Mnemonically, a 'Bazaar' holds many stores and you can easily add more. -- -- This is a final encoding of 'Bazaar'.-newtype Bazaar a b s = Bazaar { _runBazaar :: forall f. Applicative f => (a -> f b) -> f s }+newtype Bazaar a b t = Bazaar { runBazaar :: forall f. Applicative f => (a -> f b) -> f t } -instance Functor (Bazaar s t) where+instance Functor (Bazaar a b) where fmap f (Bazaar k) = Bazaar (fmap f . k) instance Applicative (Bazaar a b) where@@ -314,13 +434,13 @@ -- | Given an action to run for each matched pair, traverse a bazaar. ----- @'bazaar' :: 'Traversal' ('Bazaar' a b s) s a b@-bazaar :: Applicative f => (a -> f b) -> Bazaar a b s -> f s+-- @'bazaar' :: 'Control.Lens.Traversal.Traversal' ('Bazaar' a b t) t a b@+bazaar :: Applicative f => (a -> f b) -> Bazaar a b t -> f t bazaar afb (Bazaar m) = m afb {-# INLINE bazaar #-} -- | 'Bazaar' is an indexed 'Comonad'.-duplicateBazaar :: Bazaar a c s -> Bazaar a b (Bazaar b c s)+duplicateBazaar :: Bazaar a c t -> Bazaar a b (Bazaar b c t) duplicateBazaar (Bazaar m) = getCompose (m (Compose . fmap sell . sell)) {-# INLINE duplicateBazaar #-} -- duplicateBazaar' (Bazaar m) = Bazaar (\g -> getCompose (m (Compose . fmap sell . g)))@@ -330,7 +450,7 @@ sell i = Bazaar (\k -> k i) {-# INLINE sell #-} -instance (s ~ t) => ComonadApply (Bazaar s t) where+instance (a ~ b) => ComonadApply (Bazaar a b) where (<@>) = (<*>) -- | Wrap a monadic effect with a phantom type argument.@@ -404,13 +524,6 @@ --instance Gettable (EffectS st m s) where -- coerce (EffectS m) = EffectS m --- | This instance is a lie, but it is a useful lie.-instance Gettable f => Gettable (ElementOf f) where- coerce (ElementOf m) = ElementOf $ \i -> case m i of- Searching _ _ -> NotFound "coerced while searching" -- er...- Found j as -> Found j (coerce as)- NotFound s -> NotFound s- instance Gettable (Accessor r) where coerce (Accessor m) = Accessor m @@ -473,22 +586,29 @@ class Applicative f => Settable f where untainted :: f a -> a + untainted# :: (b -> f a) -> b -> a+ untainted# f = untainted . f+ -- | so you can pass our a 'Control.Lens.Setter.Setter' into combinators from other lens libraries instance Settable Identity where untainted = runIdentity+ untainted# = unsafeCoerce {-# INLINE untainted #-} -- | 'Control.Lens.Fold.backwards' instance Settable f => Settable (Backwards f) where untainted = untainted . forwards+ -- untainted# = untainted# forwards {-# INLINE untainted #-} instance (Settable f, Settable g) => Settable (Compose f g) where untainted = untainted . untainted . getCompose+ -- untainted# = untainted# (untainted# getCompose) {-# INLINE untainted #-} instance Settable Mutator where untainted = runMutator+ untainted# = unsafeCoerce {-# INLINE untainted #-} -- | 'Mutator' is just a renamed 'Identity' functor to give better error@@ -562,7 +682,7 @@ -- -- @'view' 'focusLevel' ≡ 'extract'@ ----- @'focusLevel' :: 'Simple' 'Lens' ('Level' a) a@+-- @'focusLevel' :: 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' ('Level' a) a@ focusLevel :: Functor f => (a -> f a) -> Level a -> f (Level a) focusLevel f (Level n ls a rs) = (\b -> Level n ls b rs) <$> f a {-# INLINE focusLevel #-}
+ src/Control/Lens/Loupe.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE CPP #-}++#ifndef MIN_VERSION_mtl+#define MIN_VERSION_mtl(x,y,z) 1+#endif++-------------------------------------------------------------------------------+-- |+-- Module : Control.Lens.Loupe+-- Copyright : (C) 2012 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : Rank2Types+--+-- A 'Loupe' is a minimalist 'Lens' suitable for storing in containers+-- or returning monadically that can still be composed with other lenses.+-------------------------------------------------------------------------------+module Control.Lens.Loupe+ (+ -- * Lenses+ Loupe+ , storing+ , (^#)+ , (#~), (#%~), (#%%~), (<#~), (<#%~)+ , (#=), (#%=), (#%%=), (<#=), (<#%=)++ -- * Simplified+ , SimpleLoupe+ ) where++import Control.Applicative as Applicative+import Control.Lens.Internal+import Control.Lens.Type+import Control.Monad.State.Class as State++-- $setup+-- >>> import Control.Lens++infixl 8 ^#+infixr 4 <#~, #~, #%~, <#%~, #%%~+infix 4 <#=, #=, #%=, <#%=, #%%=++-------------------------------------------------------------------------------+-- Lenses+-------------------------------------------------------------------------------++-- |+-- A @'Loupe' s t a b@ is almost a 'Lens'. It can be composed on the left of other lenses,+-- you can use 'cloneLens' to promote it to a 'Lens', and it provides a minimalist lens-like+-- interface. They can be used in an API where you need to pass around lenses inside containers+-- or as monadic results. Unlike a 'ReifiedLens' they can be composed and used directly, but +-- they are slightly lower performance.++-- 1) You get back what you put in:+--+-- @'Control.Lens.Setter.set' l b a '^#' l ≡ b@+--+-- 2) Putting back what you got doesn't change anything:+--+-- @'storing' l (a '^#' l) a ≡ a@+--+-- 3) Setting twice is the same as setting once:+--+-- @'storing' l c ('storing' l b a) ≡ 'storing' l c a@+--+-- These laws are strong enough that the 4 type parameters of a 'Loupe' cannot+-- vary fully independently. For more on how they interact, read the \"Why is+-- it a Lens Family?\" section of <http://comonad.com/reader/2012/mirrored-lenses/>.++type Loupe s t a b = LensLike (Context a b) s t a b++-- | @type 'SimpleLoupe' = 'Simple' 'Loupe'@+type SimpleLoupe s a = Loupe s s a a++-- | A 'Loupe'-specific version of ('Control.Lens.Getter.^.')+(^#) :: s -> Loupe s t a b -> a+s ^# l = case l (Context id) s of+ Context _ a -> a+{-# INLINE (^#) #-}++-- | A 'Loupe'-specific version of 'Control.Lens.Setter.set'+storing :: Loupe s t a b -> b -> s -> t+storing l b s = case l (Context id) s of+ Context g _ -> g b+{-# INLINE storing #-}++-- | A 'Loupe'-specific version of ('Control.Lens.Setter..~')+(#~) :: Loupe s t a b -> b -> s -> t+(#~) l b s = case l (Context id ) s of+ Context g _ -> g b+{-# INLINE (#~) #-}++-- | A 'Loupe'-specific version of ('Control.Lens.Setter.%~')+(#%~) :: Loupe s t a b -> (a -> b) -> s -> t+(#%~) l f s = case l (Context id) s of+ Context g a -> g (f a)+{-# INLINE (#%~) #-}++-- | A 'Loupe'-specific version of ('Control.Lens.Type.%%~')+(#%%~) :: Functor f => Loupe s t a b -> (a -> f b) -> s -> f t+(#%%~) l f s = case l (Context id) s of+ Context g a -> g <$> f a++-- | A 'Loupe'-specific version of ('Control.Lens.Setter..=')+(#=) :: MonadState s m => Loupe s s a b -> b -> m ()+l #= f = modify (l #~ f)+{-# INLINE (#=) #-}++-- | A 'Loupe'-specific version of ('Control.Lens.Setter.%=')+(#%=) :: MonadState s m => Loupe s s a b -> (a -> b) -> m ()+l #%= f = modify (l #%~ f)+{-# INLINE (#%=) #-}++-- | Modify the target of a 'Loupe' and return the result.+(<#%~) :: Loupe s t a b -> (a -> b) -> s -> (b, t)+l <#%~ f = \s -> case l (Context id) s of+ Context g a -> let b = f a in (b, g b)+{-# INLINE (<#%~) #-}++-- | Modify the target of a 'Loupe' into your monad's state by a user supplied function and return the result.+(<#%=) :: MonadState s m => Loupe s s a b -> (a -> b) -> m b+l <#%= f = l #%%= \a -> let b = f a in (b,b)+{-# INLINE (<#%=) #-}++-- | Modify the target of a 'Loupe' in the current monadic state, returning an auxillary result.+(#%%=) :: MonadState s m => Loupe s s a b -> (a -> (r, b)) -> m r+#if MIN_VERSION_mtl(2,1,1)+l #%%= f = State.state $ \s -> case l (Context id) s of+ Context g a -> g <$> f a+#else+l #%%= f = do+ Context g a <- State.gets (l (Context id))+ let (r, b) = f a+ State.put (g b)+ return r+#endif++-- | Replace the target of a 'Loupe' and return the new value.+(<#~) :: Loupe s t a b -> b -> s -> (b, t)+l <#~ b = \s -> (b, storing l b s)++-- | Replace the target of a 'Loupe' in the current monadic state, returning the new value.+(<#=) :: MonadState s m => Loupe s s a b -> b -> m b+l <#= b = do+ l #= b+ return b
src/Control/Lens/Plated.hs view
@@ -68,6 +68,10 @@ -- $compos , composOpFold + -- * Indexing into a Traversal+ , element+ , elementOf+ -- * Parts , parts , partsOf@@ -78,6 +82,7 @@ where import Control.Applicative+import Control.Monad.State import Control.Lens.Fold import Control.Lens.Getter import Control.Lens.Internal@@ -804,37 +809,47 @@ unsafePartsOf l f a = unsafeOuts b <$> f (ins b) where b = l sell a {-# INLINE unsafePartsOf #-} +------------------------------------------------------------------------------+-- Common Lenses+------------------------------------------------------------------------------++-- | A 'Lens' to 'Control.Lens.Getter.view'/'Control.Lens.Setter.set' the nth element 'elementOf' a 'Traversal', 'Lens' or 'Control.Lens.Iso.Iso'.+--+-- Attempts to access beyond the range of the 'Traversal' will cause an error.+--+-- >>> [[1],[3,4]]^.elementOf (traverse.traverse) 1+-- 3+elementOf :: Functor f => LensLike (Bazaar a a) s t a a -> Int -> LensLike f s t a a+elementOf l k f s = case holesOf l s !! k of+ Context g a -> g <$> f a++-- | Access the /nth/ element of a 'Traversable' container.+--+-- Attempts to access beyond the range of the 'Traversal' will cause an error.+--+-- @'element' ≡ 'elementOf' 'traverse'@+element :: Traversable t => Int -> Simple Lens (t a) a+element = elementOf traverse+ ------------------------------------------------------------------------------- -- Misc. ------------------------------------------------------------------------------- -ins :: Bazaar a b s -> [a]+ins :: Bazaar a b t -> [a] ins (Bazaar m) = getConst (m (Const . return)) {-# INLINE ins #-} -newtype Out s a = Out { withOut :: [s] -> (a, [s]) }--instance Functor (Out s) where- fmap f (Out m) = Out $ \cs -> case m cs of- (as, ds) -> (f as, ds)- {-# INLINE fmap #-}--instance Applicative (Out s) where- pure a = Out $ \cs -> (a, cs)- {-# INLINE pure #-}- Out mf <*> Out ma = Out $ \cs -> case mf cs of- (f, ds) -> case ma ds of- (a, es) -> (f a, es)- {-# INLINE (<*>) #-}+unsafeUncons :: [a] -> (a,[a])+unsafeUncons ~(a:as) = (a,as)+{-# INLINE unsafeUncons #-} -outs :: Bazaar a a s -> [a] -> s-outs (Bazaar m) = fst . withOut (m $ \c -> Out $ \cs -> case cs of- [] -> (c, [])- (d:ds) -> (d, ds))+outs :: Bazaar a a t -> [a] -> t+outs (Bazaar m) = evalState $ m $ \c -> state $ \cs -> case cs of+ [] -> (c,[])+ (d:ds) -> (d,ds) {-# INLINE outs #-} -unsafeOuts :: Bazaar a b s -> [b] -> s-unsafeOuts (Bazaar m) = fst . withOut (m $ \_ -> Out $ \cs -> case cs of- (d:ds) -> (d, ds)- [] -> error "unsafePartsOf: not enough elements were supplied")+unsafeOuts :: Bazaar a b t -> [b] -> t+unsafeOuts (Bazaar m) = evalState (m $ \_ -> state unsafeUncons) {-# INLINE unsafeOuts #-}+
src/Control/Lens/Setter.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE LiberalTypeSynonyms #-} -----------------------------------------------------------------------------@@ -167,7 +168,7 @@ -- Another way to view 'sets' is that it takes a \"semantic editor combinator\" -- and transforms it into a 'Setter'. sets :: ((a -> b) -> s -> t) -> Setter s t a b-sets f g = pure . f (untainted . g)+sets f g = pure . f (untainted# g) {-# INLINE sets #-} -----------------------------------------------------------------------------@@ -195,7 +196,7 @@ -- -- @'over' :: 'Setter' s t a b -> (a -> b) -> s -> t@ over :: Setting s t a b -> (a -> b) -> s -> t-over l f = runMutator . l (Mutator . f)+over l f = runMutator# (l (mutator# f)) {-# INLINE over #-} -- | Modify the target of a 'Control.Lens.Type.Lens' or all the targets of a 'Setter' or 'Control.Lens.Traversal.Traversal'@@ -249,7 +250,7 @@ -- 'set' :: 'Control.Lens.Traversal.Traversal' s t a b -> b -> s -> t -- @ set :: Setting s t a b -> b -> s -> t-set l b = runMutator . l (\_ -> Mutator b)+set l b = runMutator# (l (\_ -> Mutator b)) {-# INLINE set #-} -- | Modifies the target of a 'Control.Lens.Type.Lens' or all of the targets of a 'Setter' or
+ src/Control/Lens/Simple.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeOperators #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Lens.Simple+-- Copyright : (C) 2012 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : Rank2Types+--+-- Infix type operators for simple lenses and traversals.+----------------------------------------------------------------------------++module Control.Lens.Simple+ ( (:->)+ , (:=>)+ ) where++import Control.Applicative++infixr 0 :=>, :->++-- | This is a commonly used infix alias for a @'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens'@.+type s :-> a = forall f. Functor f => (a -> f a) -> s -> f s++-- | This is a commonly-used infix alias for a @'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal'@.+type s :=> a = forall f. Applicative f => (a -> f a) -> s -> f s
src/Control/Lens/Traversal.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE TypeOperators #-}@@ -30,12 +31,7 @@ ( -- * Lenses Traversal- , (:=>) - -- ** Lensing Traversals- , element- , elementOf- -- * Traversing and Lensing , traverseOf, forOf, sequenceAOf , mapMOf, forMOf, sequenceOf@@ -73,8 +69,6 @@ -- $setup -- >>> import Control.Lens -infixr 0 :=>- ------------------------------------------------------------------------------ -- Traversals ------------------------------------------------------------------------------@@ -109,9 +103,6 @@ -- | @type SimpleTraversal = 'Simple' 'Traversal'@ type SimpleTraversal s a = Traversal s s a a --- | This is a commonly-used infix alias for a @'Simple' 'Traversal'@.-type s :=> a = forall f. Applicative f => (a -> f a) -> s -> f s- -------------------------- -- Traversal Combinators --------------------------@@ -189,7 +180,7 @@ -- 'mapMOf' :: 'Monad' m => 'Traversal' s t a b -> (a -> m b) -> s -> m t -- @ mapMOf :: LensLike (WrappedMonad m) s t a b -> (a -> m b) -> s -> m t-mapMOf l cmd = unwrapMonad . l (WrapMonad . cmd)+mapMOf l cmd = unwrapMonad# (l (wrapMonad# cmd)) {-# INLINE mapMOf #-} -- | 'forMOf' is a flipped version of 'mapMOf', consistent with the definition of 'forM'.@@ -204,7 +195,7 @@ -- 'forMOf' :: 'Monad' m => 'Traversal' s t a b -> s -> (a -> m b) -> m t -- @ forMOf :: LensLike (WrappedMonad m) s t a b -> s -> (a -> m b) -> m t-forMOf l a cmd = unwrapMonad (l (WrapMonad . cmd) a)+forMOf l a cmd = unwrapMonad (l (wrapMonad# cmd) a) {-# INLINE forMOf #-} -- | Sequence the (monadic) effects targeted by a lens in a container from left to right.@@ -221,7 +212,7 @@ -- 'sequenceOf' :: 'Monad' m => 'Traversal' s t (m b) b -> s -> m t -- @ sequenceOf :: LensLike (WrappedMonad m) s t (m b) b -> s -> m t-sequenceOf l = unwrapMonad . l WrapMonad+sequenceOf l = unwrapMonad# (l WrapMonad) {-# INLINE sequenceOf #-} -- | This generalizes 'Data.List.transpose' to an arbitrary 'Traversal'.@@ -238,7 +229,7 @@ -- -- @'transposeOf' '_2' :: (b, [a]) -> [(b, a)]@ transposeOf :: LensLike ZipList s t [a] a -> s -> [t]-transposeOf l = getZipList . l ZipList+transposeOf l = getZipList# (l ZipList) {-# INLINE transposeOf #-} -- | This generalizes 'Data.Traversable.mapAccumR' to an arbitrary 'Traversal'.@@ -304,32 +295,6 @@ step Nothing a = (Just a, a) step (Just s) a = (Just r, r) where r = f s a {-# INLINE scanl1Of #-}----------------------------------------------------------------------------------- Common Lenses----------------------------------------------------------------------------------- | A 'Lens' to 'Control.Lens.Getter.view'/'Control.Lens.Setter.set' the nth element 'elementOf' a 'Traversal', 'Lens' or 'Control.Lens.Iso.Iso'.------ Attempts to access beyond the range of the 'Traversal' will cause an error.------ >>> [[1],[3,4]]^.elementOf (traverse.traverse) 1--- 3-elementOf :: Functor f => LensLike (ElementOf f) s t a a -> Int -> LensLike f s t a a-elementOf l i f s = case getElementOf (l go s) 0 of- Found _ ft -> ft- Searching _ _ -> error "elementOf: index out of range"- NotFound e -> error $ "elementOf: " ++ e- where- go a = ElementOf $ \j -> if i == j then Found (j + 1) (f a) else Searching (j + 1) a---- | Access the /nth/ element of a 'Traversable' container.------ Attempts to access beyond the range of the 'Traversal' will cause an error.------ @'element' ≡ 'elementOf' 'traverse'@-element :: Traversable t => Int -> t a :-> a-element = elementOf traverse ------------------------------------------------------------------------------ -- Traversals
src/Control/Lens/Tuple.hs view
@@ -59,35 +59,35 @@ _1 :: Lens s t a b instance Field1 (a,b) (a',b) a a' where- _1 k (a,b) = (\a' -> (a',b)) <$> k a+ _1 k ~(a,b) = (\a' -> (a',b)) <$> k a {-# INLINE _1 #-} instance Field1 (a,b,c) (a',b,c) a a' where- _1 k (a,b,c) = (\a' -> (a',b,c)) <$> k a+ _1 k ~(a,b,c) = (\a' -> (a',b,c)) <$> k a {-# INLINE _1 #-} instance Field1 (a,b,c,d) (a',b,c,d) a a' where- _1 k (a,b,c,d) = (\a' -> (a',b,c,d)) <$> k a+ _1 k ~(a,b,c,d) = (\a' -> (a',b,c,d)) <$> k a {-# INLINE _1 #-} instance Field1 (a,b,c,d,e) (a',b,c,d,e) a a' where- _1 k (a,b,c,d,e) = (\a' -> (a',b,c,d,e)) <$> k a+ _1 k ~(a,b,c,d,e) = (\a' -> (a',b,c,d,e)) <$> k a {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f) (a',b,c,d,e,f) a a' where- _1 k (a,b,c,d,e,f) = (\a' -> (a',b,c,d,e,f)) <$> k a+ _1 k ~(a,b,c,d,e,f) = (\a' -> (a',b,c,d,e,f)) <$> k a {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f,g) (a',b,c,d,e,f,g) a a' where- _1 k (a,b,c,d,e,f,g) = (\a' -> (a',b,c,d,e,f,g)) <$> k a+ _1 k ~(a,b,c,d,e,f,g) = (\a' -> (a',b,c,d,e,f,g)) <$> k a {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f,g,h) (a',b,c,d,e,f,g,h) a a' where- _1 k (a,b,c,d,e,f,g,h) = (\a' -> (a',b,c,d,e,f,g,h)) <$> k a+ _1 k ~(a,b,c,d,e,f,g,h) = (\a' -> (a',b,c,d,e,f,g,h)) <$> k a {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f,g,h,i) (a',b,c,d,e,f,g,h,i) a a' where- _1 k (a,b,c,d,e,f,g,h,i) = (\a' -> (a',b,c,d,e,f,g,h,i)) <$> k a+ _1 k ~(a,b,c,d,e,f,g,h,i) = (\a' -> (a',b,c,d,e,f,g,h,i)) <$> k a {-# INLINE _1 #-} -- | Provides access to the 2nd field of a tuple@@ -105,35 +105,35 @@ _2 :: Lens s t a b instance Field2 (a,b) (a,b') b b' where- _2 k (a,b) = (\b' -> (a,b')) <$> k b+ _2 k ~(a,b) = (\b' -> (a,b')) <$> k b {-# INLINE _2 #-} instance Field2 (a,b,c) (a,b',c) b b' where- _2 k (a,b,c) = (\b' -> (a,b',c)) <$> k b+ _2 k ~(a,b,c) = (\b' -> (a,b',c)) <$> k b {-# INLINE _2 #-} instance Field2 (a,b,c,d) (a,b',c,d) b b' where- _2 k (a,b,c,d) = (\b' -> (a,b',c,d)) <$> k b+ _2 k ~(a,b,c,d) = (\b' -> (a,b',c,d)) <$> k b {-# INLINE _2 #-} instance Field2 (a,b,c,d,e) (a,b',c,d,e) b b' where- _2 k (a,b,c,d,e) = (\b' -> (a,b',c,d,e)) <$> k b+ _2 k ~(a,b,c,d,e) = (\b' -> (a,b',c,d,e)) <$> k b {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f) (a,b',c,d,e,f) b b' where- _2 k (a,b,c,d,e,f) = (\b' -> (a,b',c,d,e,f)) <$> k b+ _2 k ~(a,b,c,d,e,f) = (\b' -> (a,b',c,d,e,f)) <$> k b {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f,g) (a,b',c,d,e,f,g) b b' where- _2 k (a,b,c,d,e,f,g) = (\b' -> (a,b',c,d,e,f,g)) <$> k b+ _2 k ~(a,b,c,d,e,f,g) = (\b' -> (a,b',c,d,e,f,g)) <$> k b {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f,g,h) (a,b',c,d,e,f,g,h) b b' where- _2 k (a,b,c,d,e,f,g,h) = (\b' -> (a,b',c,d,e,f,g,h)) <$> k b+ _2 k ~(a,b,c,d,e,f,g,h) = (\b' -> (a,b',c,d,e,f,g,h)) <$> k b {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f,g,h,i) (a,b',c,d,e,f,g,h,i) b b' where- _2 k (a,b,c,d,e,f,g,h,i) = (\b' -> (a,b',c,d,e,f,g,h,i)) <$> k b+ _2 k ~(a,b,c,d,e,f,g,h,i) = (\b' -> (a,b',c,d,e,f,g,h,i)) <$> k b {-# INLINE _2 #-} -- | Provides access to the 3rd field of a tuple@@ -142,31 +142,31 @@ _3 :: Lens s t a b instance Field3 (a,b,c) (a,b,c') c c' where- _3 k (a,b,c) = (\c' -> (a,b,c')) <$> k c+ _3 k ~(a,b,c) = (\c' -> (a,b,c')) <$> k c {-# INLINE _3 #-} instance Field3 (a,b,c,d) (a,b,c',d) c c' where- _3 k (a,b,c,d) = (\c' -> (a,b,c',d)) <$> k c+ _3 k ~(a,b,c,d) = (\c' -> (a,b,c',d)) <$> k c {-# INLINE _3 #-} instance Field3 (a,b,c,d,e) (a,b,c',d,e) c c' where- _3 k (a,b,c,d,e) = (\c' -> (a,b,c',d,e)) <$> k c+ _3 k ~(a,b,c,d,e) = (\c' -> (a,b,c',d,e)) <$> k c {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f) (a,b,c',d,e,f) c c' where- _3 k (a,b,c,d,e,f) = (\c' -> (a,b,c',d,e,f)) <$> k c+ _3 k ~(a,b,c,d,e,f) = (\c' -> (a,b,c',d,e,f)) <$> k c {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f,g) (a,b,c',d,e,f,g) c c' where- _3 k (a,b,c,d,e,f,g) = (\c' -> (a,b,c',d,e,f,g)) <$> k c+ _3 k ~(a,b,c,d,e,f,g) = (\c' -> (a,b,c',d,e,f,g)) <$> k c {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f,g,h) (a,b,c',d,e,f,g,h) c c' where- _3 k (a,b,c,d,e,f,g,h) = (\c' -> (a,b,c',d,e,f,g,h)) <$> k c+ _3 k ~(a,b,c,d,e,f,g,h) = (\c' -> (a,b,c',d,e,f,g,h)) <$> k c {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f,g,h,i) (a,b,c',d,e,f,g,h,i) c c' where- _3 k (a,b,c,d,e,f,g,h,i) = (\c' -> (a,b,c',d,e,f,g,h,i)) <$> k c+ _3 k ~(a,b,c,d,e,f,g,h,i) = (\c' -> (a,b,c',d,e,f,g,h,i)) <$> k c {-# INLINE _3 #-} -- | Provide access to the 4th field of a tuple@@ -175,27 +175,27 @@ _4 :: Lens s t a b instance Field4 (a,b,c,d) (a,b,c,d') d d' where- _4 k (a,b,c,d) = (\d' -> (a,b,c,d')) <$> k d+ _4 k ~(a,b,c,d) = (\d' -> (a,b,c,d')) <$> k d {-# INLINE _4 #-} instance Field4 (a,b,c,d,e) (a,b,c,d',e) d d' where- _4 k (a,b,c,d,e) = (\d' -> (a,b,c,d',e)) <$> k d+ _4 k ~(a,b,c,d,e) = (\d' -> (a,b,c,d',e)) <$> k d {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f) (a,b,c,d',e,f) d d' where- _4 k (a,b,c,d,e,f) = (\d' -> (a,b,c,d',e,f)) <$> k d+ _4 k ~(a,b,c,d,e,f) = (\d' -> (a,b,c,d',e,f)) <$> k d {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f,g) (a,b,c,d',e,f,g) d d' where- _4 k (a,b,c,d,e,f,g) = (\d' -> (a,b,c,d',e,f,g)) <$> k d+ _4 k ~(a,b,c,d,e,f,g) = (\d' -> (a,b,c,d',e,f,g)) <$> k d {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f,g,h) (a,b,c,d',e,f,g,h) d d' where- _4 k (a,b,c,d,e,f,g,h) = (\d' -> (a,b,c,d',e,f,g,h)) <$> k d+ _4 k ~(a,b,c,d,e,f,g,h) = (\d' -> (a,b,c,d',e,f,g,h)) <$> k d {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f,g,h,i) (a,b,c,d',e,f,g,h,i) d d' where- _4 k (a,b,c,d,e,f,g,h,i) = (\d' -> (a,b,c,d',e,f,g,h,i)) <$> k d+ _4 k ~(a,b,c,d,e,f,g,h,i) = (\d' -> (a,b,c,d',e,f,g,h,i)) <$> k d {-# INLINE _4 #-} -- | Provides access to the 5th field of a tuple@@ -204,23 +204,23 @@ _5 :: Lens s t a b instance Field5 (a,b,c,d,e) (a,b,c,d,e') e e' where- _5 k (a,b,c,d,e) = (\e' -> (a,b,c,d,e')) <$> k e+ _5 k ~(a,b,c,d,e) = (\e' -> (a,b,c,d,e')) <$> k e {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f) (a,b,c,d,e',f) e e' where- _5 k (a,b,c,d,e,f) = (\e' -> (a,b,c,d,e',f)) <$> k e+ _5 k ~(a,b,c,d,e,f) = (\e' -> (a,b,c,d,e',f)) <$> k e {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f,g) (a,b,c,d,e',f,g) e e' where- _5 k (a,b,c,d,e,f,g) = (\e' -> (a,b,c,d,e',f,g)) <$> k e+ _5 k ~(a,b,c,d,e,f,g) = (\e' -> (a,b,c,d,e',f,g)) <$> k e {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f,g,h) (a,b,c,d,e',f,g,h) e e' where- _5 k (a,b,c,d,e,f,g,h) = (\e' -> (a,b,c,d,e',f,g,h)) <$> k e+ _5 k ~(a,b,c,d,e,f,g,h) = (\e' -> (a,b,c,d,e',f,g,h)) <$> k e {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e',f,g,h,i) e e' where- _5 k (a,b,c,d,e,f,g,h,i) = (\e' -> (a,b,c,d,e',f,g,h,i)) <$> k e+ _5 k ~(a,b,c,d,e,f,g,h,i) = (\e' -> (a,b,c,d,e',f,g,h,i)) <$> k e {-# INLINE _5 #-} -- | Provides access to the 6th element of a tuple@@ -229,19 +229,19 @@ _6 :: Lens s t a b instance Field6 (a,b,c,d,e,f) (a,b,c,d,e,f') f f' where- _6 k (a,b,c,d,e,f) = (\f' -> (a,b,c,d,e,f')) <$> k f+ _6 k ~(a,b,c,d,e,f) = (\f' -> (a,b,c,d,e,f')) <$> k f {-# INLINE _6 #-} instance Field6 (a,b,c,d,e,f,g) (a,b,c,d,e,f',g) f f' where- _6 k (a,b,c,d,e,f,g) = (\f' -> (a,b,c,d,e,f',g)) <$> k f+ _6 k ~(a,b,c,d,e,f,g) = (\f' -> (a,b,c,d,e,f',g)) <$> k f {-# INLINE _6 #-} instance Field6 (a,b,c,d,e,f,g,h) (a,b,c,d,e,f',g,h) f f' where- _6 k (a,b,c,d,e,f,g,h) = (\f' -> (a,b,c,d,e,f',g,h)) <$> k f+ _6 k ~(a,b,c,d,e,f,g,h) = (\f' -> (a,b,c,d,e,f',g,h)) <$> k f {-# INLINE _6 #-} instance Field6 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f',g,h,i) f f' where- _6 k (a,b,c,d,e,f,g,h,i) = (\f' -> (a,b,c,d,e,f',g,h,i)) <$> k f+ _6 k ~(a,b,c,d,e,f,g,h,i) = (\f' -> (a,b,c,d,e,f',g,h,i)) <$> k f {-# INLINE _6 #-} -- | Provide access to the 7th field of a tuple@@ -250,15 +250,15 @@ _7 :: Lens s t a b instance Field7 (a,b,c,d,e,f,g) (a,b,c,d,e,f,g') g g' where- _7 k (a,b,c,d,e,f,g) = (\g' -> (a,b,c,d,e,f,g')) <$> k g+ _7 k ~(a,b,c,d,e,f,g) = (\g' -> (a,b,c,d,e,f,g')) <$> k g {-# INLINE _7 #-} instance Field7 (a,b,c,d,e,f,g,h) (a,b,c,d,e,f,g',h) g g' where- _7 k (a,b,c,d,e,f,g,h) = (\g' -> (a,b,c,d,e,f,g',h)) <$> k g+ _7 k ~(a,b,c,d,e,f,g,h) = (\g' -> (a,b,c,d,e,f,g',h)) <$> k g {-# INLINE _7 #-} instance Field7 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f,g',h,i) g g' where- _7 k (a,b,c,d,e,f,g,h,i) = (\g' -> (a,b,c,d,e,f,g',h,i)) <$> k g+ _7 k ~(a,b,c,d,e,f,g,h,i) = (\g' -> (a,b,c,d,e,f,g',h,i)) <$> k g {-# INLINE _7 #-} -- | Provide access to the 8th field of a tuple@@ -267,11 +267,11 @@ _8 :: Lens s t a b instance Field8 (a,b,c,d,e,f,g,h) (a,b,c,d,e,f,g,h') h h' where- _8 k (a,b,c,d,e,f,g,h) = (\h' -> (a,b,c,d,e,f,g,h')) <$> k h+ _8 k ~(a,b,c,d,e,f,g,h) = (\h' -> (a,b,c,d,e,f,g,h')) <$> k h {-# INLINE _8 #-} instance Field8 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f,g,h',i) h h' where- _8 k (a,b,c,d,e,f,g,h,i) = (\h' -> (a,b,c,d,e,f,g,h',i)) <$> k h+ _8 k ~(a,b,c,d,e,f,g,h,i) = (\h' -> (a,b,c,d,e,f,g,h',i)) <$> k h {-# INLINE _8 #-} -- | Provides access to the 9th field of a tuple@@ -280,5 +280,5 @@ _9 :: Lens s t a b instance Field9 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f,g,h,i') i i' where- _9 k (a,b,c,d,e,f,g,h,i) = (\i' -> (a,b,c,d,e,f,g,h,i')) <$> k i+ _9 k ~(a,b,c,d,e,f,g,h,i) = (\i' -> (a,b,c,d,e,f,g,h,i')) <$> k i {-# INLINE _9 #-}
src/Control/Lens/Type.hs view
@@ -56,7 +56,6 @@ -- * Lenses Lens , Simple- , (:->) , lens , simple@@ -103,10 +102,6 @@ -- $setup -- >>> import Control.Lens --- types-infixr 0 :->---- terms infixr 4 %%~ infix 4 %%= infixr 4 <+~, <*~, <-~, <//~, <^~, <^^~, <**~, <&&~, <||~, <%~, <<%~, <<.~@@ -170,9 +165,6 @@ -- 'Control.Lens.Setter.Setter', you may have to turn on @LiberalTypeSynonyms@. type Simple f s a = f s s a a --- | This is a commonly used infix alias for a @'Simple' 'Lens'@.-type s :-> a = forall f. Functor f => (a -> f a) -> s -> f s- -- | @type 'SimpleLens' = 'Simple' 'Lens'@ type SimpleLens s a = Lens s s a a @@ -281,7 +273,7 @@ -- | This lens can be used to change the result of a function but only where -- the arguments match the key given.-resultAt :: Eq e => e -> (e -> a) :-> a+resultAt :: Eq e => e -> Simple Lens (e -> a) a resultAt e afa ea = go <$> afa a where a = ea e go a' e' | e == e' = a'