optics-extra (empty) → 0.1
raw patch · 27 files changed
+3434/−0 lines, 27 filesdep +arraydep +basedep +bytestringsetup-changed
Dependencies added: array, base, bytestring, containers, hashable, mtl, optics-core, text, transformers, unordered-containers, vector
Files
- LICENSE +62/−0
- Setup.hs +4/−0
- optics-extra.cabal +86/−0
- src/Data/ByteString/Lazy/Optics.hs +134/−0
- src/Data/ByteString/Optics.hs +145/−0
- src/Data/ByteString/Strict/Optics.hs +133/−0
- src/Data/HashMap/Optics.hs +78/−0
- src/Data/HashSet/Optics.hs +45/−0
- src/Data/Text/Lazy/Optics.hs +172/−0
- src/Data/Text/Optics.hs +116/−0
- src/Data/Text/Strict/Optics.hs +165/−0
- src/Data/Vector/Generic/Optics.hs +193/−0
- src/Data/Vector/Optics.hs +79/−0
- src/Optics/At.hs +189/−0
- src/Optics/Cons.hs +138/−0
- src/Optics/Each.hs +88/−0
- src/Optics/Empty.hs +69/−0
- src/Optics/Extra.hs +14/−0
- src/Optics/Extra/Internal/ByteString.hs +298/−0
- src/Optics/Extra/Internal/Vector.hs +27/−0
- src/Optics/Extra/Internal/Zoom.hs +252/−0
- src/Optics/Indexed.hs +97/−0
- src/Optics/Passthrough.hs +42/−0
- src/Optics/State.hs +84/−0
- src/Optics/State/Operators.hs +155/−0
- src/Optics/View.hs +158/−0
- src/Optics/Zoom.hs +411/−0
+ LICENSE view
@@ -0,0 +1,62 @@+Copyright (c) 2017-2019, Well-Typed LLP++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Well-Typed LLP nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+++This software incorporates code from the lens package (available from+https://hackage.haskell.org/package/lens) under the following license:+++Copyright 2012-2016 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple++main :: IO ()+main = defaultMain
+ optics-extra.cabal view
@@ -0,0 +1,86 @@+name: optics-extra+version: 0.1+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: 1.24+maintainer: optics@well-typed.com+author: Andrzej Rybczak+tested-with: ghc ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1+synopsis: Extra utilities and instances for optics-core+category: Data, Optics, Lenses+description:+ This package provides extra definitions and instances that extend the+ @optics-core@ package, without incurring too many dependencies. See the+ @optics@ package for more documentation.++bug-reports: https://github.com/well-typed/optics/issues+source-repository head+ type: git+ location: https://github.com/well-typed/optics.git+ subdir: optics-extra++library+ default-language: Haskell2010+ hs-source-dirs: src+ ghc-options: -Wall++ build-depends: base >= 4.9 && <5+ , array >= 0.5.1.1 && <0.6+ , bytestring >= 0.10.8 && <0.11+ , containers >= 0.5.7.1 && <0.7+ , hashable >= 1.1.1 && <1.4+ , mtl >= 2.2.2 && <2.3+ , optics-core >= 0.1 && <1.0+ , text >= 1.2 && <1.3+ , transformers >= 0.5 && <0.6+ , unordered-containers >= 0.2.6 && <0.3+ , vector >= 0.11 && <0.13++ exposed-modules: Optics.Extra++ -- optic utilities+ Optics.At+ Optics.Cons+ Optics.Each+ Optics.Empty+ Optics.Indexed+ Optics.Passthrough+ Optics.State+ Optics.State.Operators+ Optics.View+ Optics.Zoom++ -- optics for data types+ Data.ByteString.Lazy.Optics+ Data.ByteString.Optics+ Data.ByteString.Strict.Optics+ Data.HashMap.Optics+ Data.HashSet.Optics+ Data.Text.Lazy.Optics+ Data.Text.Optics+ Data.Text.Strict.Optics+ Data.Vector.Generic.Optics+ Data.Vector.Optics++ -- internal modules+ Optics.Extra.Internal.ByteString+ Optics.Extra.Internal.Vector+ Optics.Extra.Internal.Zoom++ default-extensions: BangPatterns+ DefaultSignatures+ DeriveFunctor+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ InstanceSigs+ LambdaCase+ MultiParamTypeClasses+ RankNTypes+ ScopedTypeVariables+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators
+ src/Data/ByteString/Lazy/Optics.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PatternSynonyms #-}+-- | Lazy 'ByteString' lenses.+module Data.ByteString.Lazy.Optics+ ( packedBytes, unpackedBytes, bytes+ , packedChars, unpackedChars, chars+ , pattern Bytes+ , pattern Chars+ ) where++import Data.ByteString.Lazy as Words+import Data.ByteString.Lazy.Char8 as Char8+import Data.Int (Int64)+import Data.Word (Word8)++import Optics.Core+import Optics.Extra.Internal.ByteString++-- | 'Data.ByteString.Lazy.pack' (or 'Data.ByteString.Lazy.unpack') a list of+-- bytes into a 'ByteString'.+--+-- @+-- 'packedBytes' ≡ 're' 'unpackedBytes'+-- 'Data.ByteString.pack' x ≡ x '^.' 'packedBytes'+-- 'Data.ByteString.unpack' x ≡ x '^.' 're' 'packedBytes'+-- @+--+-- >>> [104,101,108,108,111] ^. packedBytes == Char8.pack "hello"+-- True+packedBytes :: Iso' [Word8] ByteString+packedBytes = iso Words.pack Words.unpack+{-# INLINE packedBytes #-}++-- | 'Data.ByteString.Lazy.unpack' (or 'Data.ByteString.Lazy.pack') a+-- 'ByteString' into a list of bytes.+--+-- @+-- 'unpackedBytes' ≡ 're' 'packedBytes'+-- 'Data.ByteString.unpack' x ≡ x '^.' 'unpackedBytes'+-- 'Data.ByteString.pack' x ≡ x '^.' 're' 'unpackedBytes'+-- @+--+-- >>> "hello" ^. packedChars % unpackedBytes+-- [104,101,108,108,111]+unpackedBytes :: Iso' ByteString [Word8]+unpackedBytes = re packedBytes+{-# INLINE unpackedBytes #-}++-- | Traverse the individual bytes in a 'ByteString'.+--+-- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion+-- enable zippers to seek to locations more quickly and accelerate many monoidal+-- queries, but up to associativity (and constant factors) it is equivalent to+-- the much slower:+--+-- @+-- 'bytes' ≡ 'unpackedBytes' '%' 'traversed'+-- @+--+-- >>> anyOf bytes (== 0x80) (Char8.pack "hello")+-- False+--+-- Note that when just using this as a 'Setter', @'sets'+-- 'Data.ByteString.Lazy.map'@ can be more efficient.+bytes :: IxTraversal' Int64 ByteString Word8+bytes = traversedLazy+{-# INLINE bytes #-}++-- | 'Data.ByteString.Lazy.Char8.pack' (or 'Data.ByteString.Lazy.Char8.unpack')+-- a list of characters into a 'ByteString'.+--+-- When writing back to the 'ByteString' it is assumed that every 'Char' lies+-- between @'\x00'@ and @'\xff'@.+--+-- @+-- 'packedChars' ≡ 're' 'unpackedChars'+-- 'Data.ByteString.Char8.pack' x ≡ x '^.' 'packedChars'+-- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 're' 'packedChars'+-- @+--+-- >>> foldOf (packedChars % each % to (\w -> let x = showHex w "" in if Prelude.length x == 1 then '0':x else x)) "hello"+-- "68656c6c6f"+packedChars :: Iso' String ByteString+packedChars = iso Char8.pack Char8.unpack+{-# INLINE packedChars #-}++-- | 'Data.ByteString.Lazy.Char8.unpack' (or 'Data.ByteString.Lazy.Char8.pack')+-- a list of characters into a 'ByteString'+--+-- When writing back to the 'ByteString' it is assumed that every 'Char' lies+-- between @'\x00'@ and @'\xff'@.+--+-- @+-- 'unpackedChars' ≡ 're' 'packedChars'+-- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'unpackedChars'+-- 'Data.ByteString.Char8.pack' x ≡ x '^.' 're' 'unpackedChars'+-- @+--+-- >>> [104,101,108,108,111] ^. packedBytes % unpackedChars+-- "hello"+unpackedChars :: Iso' ByteString String+unpackedChars = re packedChars+{-# INLINE unpackedChars #-}++-- | Traverse the individual bytes in a 'ByteString' as characters.+--+-- When writing back to the 'ByteString' it is assumed that every 'Char' lies+-- between @'\x00'@ and @'\xff'@.+--+-- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like fashion+-- enable zippers to seek to locations more quickly and accelerate many monoidal+-- queries, but up to associativity (and constant factors) it is equivalent to:+--+-- @+-- 'chars' = 'unpackedChars' '%' 'traversed'+-- @+--+-- >>> anyOf chars (== 'h') $ Char8.pack "hello"+-- True+chars :: IxTraversal' Int64 ByteString Char+chars = traversedLazy8+{-# INLINE chars #-}++pattern Bytes :: [Word8] -> ByteString+pattern Bytes b <- (view unpackedBytes -> b) where+ Bytes b = review unpackedBytes b++pattern Chars :: [Char] -> ByteString+pattern Chars b <- (view unpackedChars -> b) where+ Chars b = review unpackedChars b++-- $setup+-- >>> import Numeric+-- >>> import Optics.Each
+ src/Data/ByteString/Optics.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PatternSynonyms #-}+module Data.ByteString.Optics+ ( IsByteString(..)+ , unpackedBytes+ , unpackedChars+ , pattern Bytes+ , pattern Chars+ ) where++import Data.ByteString as Strict+import Data.ByteString.Lazy as Lazy+import Data.Int+import Data.Word+import qualified Data.ByteString.Lazy.Optics as Lazy+import qualified Data.ByteString.Strict.Optics as Strict++import Optics.Core++-- | Traversals for ByteStrings.+class IsByteString t where+ -- | 'Data.ByteString.pack' (or 'Data.ByteString.unpack') a list of bytes into+ -- a strict or lazy 'ByteString'.+ --+ -- @+ -- 'Data.ByteString.pack' x ≡ x '^.' 'packedBytes'+ -- 'Data.ByteString.unpack' x ≡ x '^.' 're' 'packedBytes'+ -- 'packedBytes' ≡ 're' 'unpackedBytes'+ -- @+ packedBytes :: Iso' [Word8] t++ -- | 'Data.ByteString.Char8.pack' (or 'Data.ByteString.Char8.unpack') a list+ -- of characters into a strict or lazy 'ByteString'.+ --+ -- When writing back to the 'ByteString' it is assumed that every 'Char' lies+ -- between @'\x00'@ and @'\xff'@.+ --+ -- @+ -- 'Data.ByteString.Char8.pack' x ≡ x '^.' 'packedChars'+ -- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 're' 'packedChars'+ -- 'packedChars' ≡ 're' 'unpackedChars'+ -- @+ packedChars :: Iso' String t++ -- | Traverse each 'Word8' in a strict or lazy 'ByteString'+ --+ --+ -- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like+ -- fashion enable zippers to seek to locations more quickly and accelerate+ -- many monoidal queries, but up to associativity (and constant factors) it is+ -- equivalent to the much slower:+ --+ -- @+ -- 'bytes' ≡ 'unpackedBytes' '.' 'traversed'+ -- @+ --+ -- @+ -- 'anyOf' 'bytes' ('==' 0x80) :: 'ByteString' -> 'Bool'+ -- @+ bytes :: IxTraversal' Int64 t Word8++ -- | Traverse the individual bytes in a strict or lazy 'ByteString' as+ -- characters.+ --+ -- When writing back to the 'ByteString' it is assumed that every 'Char' lies+ -- between @'\x00'@ and @'\xff'@.+ --+ -- This 'Traversal' walks each strict 'ByteString' chunk in a tree-like+ -- fashion enable zippers to seek to locations more quickly and accelerate+ -- many monoidal queries, but up to associativity (and constant factors) it is+ -- equivalent to the much slower:+ --+ -- @+ -- 'chars' ≡ 'unpackedChars' '.' 'traversed'+ -- @+ --+ -- @+ -- 'anyOf' 'chars' ('==' \'c\') :: 'ByteString' -> 'Bool'+ -- @+ chars :: IxTraversal' Int64 t Char++-- | 'Data.ByteString.unpack' (or 'Data.ByteString.pack') a 'ByteString' into a+-- list of bytes.+--+-- @+-- 'unpackedBytes' ≡ 're' 'packedBytes'+-- 'Data.ByteString.unpack' x ≡ x '^.' 'unpackedBytes'+-- 'Data.ByteString.pack' x ≡ x '^.' 're' 'unpackedBytes'+-- @+--+-- @+-- 'unpackedBytes' :: 'Iso'' 'Data.ByteString.ByteString' ['Word8']+-- 'unpackedBytes' :: 'Iso'' 'Data.ByteString.Lazy.ByteString' ['Word8']+-- @+unpackedBytes :: IsByteString t => Iso' t [Word8]+unpackedBytes = re packedBytes+{-# INLINE unpackedBytes #-}++pattern Bytes :: IsByteString t => [Word8] -> t+pattern Bytes b <- (view unpackedBytes -> b) where+ Bytes b = review unpackedBytes b++pattern Chars :: IsByteString t => [Char] -> t+pattern Chars b <- (view unpackedChars -> b) where+ Chars b = review unpackedChars b++-- | 'Data.ByteString.Char8.unpack' (or 'Data.ByteString.Char8.pack') a list of+-- characters into a strict (or lazy) 'ByteString'+--+-- When writing back to the 'ByteString' it is assumed that every 'Char' lies+-- between @'\x00'@ and @'\xff'@.+--+-- @+-- 'unpackedChars' ≡ 're' 'packedChars'+-- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'unpackedChars'+-- 'Data.ByteString.Char8.pack' x ≡ x '^.' 're' 'unpackedChars'+-- @+--+-- @+-- 'unpackedChars' :: 'Iso'' 'Data.ByteString.ByteString' 'String'+-- 'unpackedChars' :: 'Iso'' 'Data.ByteString.Lazy.ByteString' 'String'+-- @+unpackedChars :: IsByteString t => Iso' t String+unpackedChars = re packedChars+{-# INLINE unpackedChars #-}++instance IsByteString Strict.ByteString where+ packedBytes = Strict.packedBytes+ packedChars = Strict.packedChars+ bytes = Strict.bytes+ chars = Strict.chars+ {-# INLINE packedBytes #-}+ {-# INLINE packedChars #-}+ {-# INLINE bytes #-}+ {-# INLINE chars #-}++instance IsByteString Lazy.ByteString where+ packedBytes = Lazy.packedBytes+ packedChars = Lazy.packedChars+ bytes = Lazy.bytes+ chars = Lazy.chars+ {-# INLINE packedBytes #-}+ {-# INLINE packedChars #-}+ {-# INLINE bytes #-}+ {-# INLINE chars #-}
+ src/Data/ByteString/Strict/Optics.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PatternSynonyms #-}+module Data.ByteString.Strict.Optics+ ( packedBytes, unpackedBytes, bytes+ , packedChars, unpackedChars, chars+ , pattern Bytes+ , pattern Chars+ ) where++import Data.ByteString as Words+import Data.ByteString.Char8 as Char8+import Data.Int+import Data.Word++import Optics.Core+import Optics.Extra.Internal.ByteString++-- | 'Data.ByteString.pack' (or 'Data.ByteString.unpack') a list of bytes into a 'ByteString'+--+-- @+-- 'packedBytes' ≡ 're' 'unpackedBytes'+-- 'Data.ByteString.pack' x ≡ x '^.' 'packedBytes'+-- 'Data.ByteString.unpack' x ≡ x '^.' 're' 'packedBytes'+-- @+--+-- >>> [104,101,108,108,111] ^. packedBytes+-- "hello"+packedBytes :: Iso' [Word8] ByteString+packedBytes = iso Words.pack Words.unpack+{-# INLINE packedBytes #-}++-- | 'Data.ByteString.unpack' (or 'Data.ByteString.pack') a 'ByteString' into a+-- list of bytes.+--+-- @+-- 'unpackedBytes' ≡ 're' 'packedBytes'+-- 'Data.ByteString.unpack' x ≡ x '^.' 'unpackedBytes'+-- 'Data.ByteString.pack' x ≡ x '^.' 're' 'unpackedBytes'+-- @+--+-- >>> "hello" ^. packedChars % unpackedBytes+-- [104,101,108,108,111]+unpackedBytes :: Iso' ByteString [Word8]+unpackedBytes = re packedBytes+{-# INLINE unpackedBytes #-}++-- | Traverse each 'Word8' in a 'ByteString'.+--+-- This 'Traversal' walks the 'ByteString' in a tree-like fashion enable zippers+-- to seek to locations in logarithmic time and accelerating many monoidal+-- queries, but up to associativity (and constant factors) it is equivalent to+-- the much slower:+--+-- @+-- 'bytes' ≡ 'unpackedBytes' '%' 'traversed'+-- @+--+-- >>> anyOf bytes (== 0x80) (Char8.pack "hello")+-- False+--+-- Note that when just using this as a 'Setter', @'sets' 'Data.ByteString.map'@+-- can be more efficient.+bytes :: IxTraversal' Int64 ByteString Word8+bytes = traversedStrictTree+{-# INLINE bytes #-}++-- | 'Data.ByteString.Char8.pack' (or 'Data.ByteString.Char8.unpack') a list of+-- characters into a 'ByteString'+--+-- When writing back to the 'ByteString' it is assumed that every 'Char' lies+-- between @'\x00'@ and @'\xff'@.+--+-- @+-- 'packedChars' ≡ 're' 'unpackedChars'+-- 'Data.ByteString.Char8.pack' x ≡ x '^.' 'packedChars'+-- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 're' 'packedChars'+-- @+--+-- >>> foldOf (packedChars % each % to (\w -> let x = showHex w "" in if Prelude.length x == 1 then '0':x else x)) "hello"+-- "68656c6c6f"+packedChars :: Iso' String ByteString+packedChars = iso Char8.pack Char8.unpack+{-# INLINE packedChars #-}++-- | 'Data.ByteString.Char8.unpack' (or 'Data.ByteString.Char8.pack') a list of+-- characters into a 'ByteString'+--+-- When writing back to the 'ByteString' it is assumed that every 'Char' lies+-- between @'\x00'@ and @'\xff'@.+--+-- @+-- 'unpackedChars' ≡ 're' 'packedChars'+-- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'unpackedChars'+-- 'Data.ByteString.Char8.pack' x ≡ x '^.' 're' 'unpackedChars'+-- @+--+-- >>> [104,101,108,108,111] ^. packedBytes % unpackedChars+-- "hello"+unpackedChars :: Iso' ByteString String+unpackedChars = re packedChars+{-# INLINE unpackedChars #-}++-- | Traverse the individual bytes in a 'ByteString' as characters.+--+-- When writing back to the 'ByteString' it is assumed that every 'Char' lies+-- between @'\x00'@ and @'\xff'@.+--+-- This 'Traversal' walks the 'ByteString' in a tree-like fashion enable zippers+-- to seek to locations in logarithmic time and accelerating many monoidal+-- queries, but up to associativity (and constant factors) it is equivalent to+-- the much slower:+--+-- @+-- 'chars' = 'unpackedChars' '%' 'traversed'+-- @+--+-- >>> anyOf chars (== 'h') $ Char8.pack "hello"+-- True+chars :: IxTraversal' Int64 ByteString Char+chars = traversedStrictTree8+{-# INLINE chars #-}++pattern Bytes :: [Word8] -> ByteString+pattern Bytes b <- (view unpackedBytes -> b) where+ Bytes b = review unpackedBytes b++pattern Chars :: [Char] -> ByteString+pattern Chars b <- (view unpackedChars -> b) where+ Chars b = review unpackedChars b++-- $setup+-- >>> import Numeric+-- >>> import Optics.Each
+ src/Data/HashMap/Optics.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE CPP #-}+-- |+-- Module: Data.HashMap.Optics+-- Description: Optics for working with 'Data.Map.HashMap's.+--+-- This module exists to provide documentation for lenses for working with+-- 'HashMap', which might otherwise be obscured by their genericity.+--+-- 'HashMap' is an instance of 'Optics.At.Core.At' and provides+-- 'Optics.At.Core.at' as a lens on values at keys:+--+-- >>> HashMap.fromList [(1, "world")] ^. at 1+-- Just "world"+--+-- >>> HashMap.empty & at 1 .~ Just "world"+-- fromList [(1,"world")]+--+-- >>> HashMap.empty & at 0 .~ Just "hello"+-- fromList [(0,"hello")]+--+-- We can traverse, fold over, and map over key-value pairs in a 'HashMap',+-- thanks to indexed traversals, folds and setters.+--+-- >>> iover imapped const $ HashMap.fromList [(1, "Venus")]+-- fromList [(1,1)]+--+-- >>> ifoldMapOf ifolded (\i _ -> Sum i) $ HashMap.fromList [(2, "Earth"), (3, "Mars")]+-- Sum {getSum = 5}+--+-- >>> itraverseOf_ ifolded (curry print) $ HashMap.fromList [(4, "Jupiter")]+-- (4,"Jupiter")+--+-- >>> itoListOf ifolded $ HashMap.fromList [(5, "Saturn")]+-- [(5,"Saturn")]+--+-- A related class, 'Optics.At.Core.Ixed', allows us to use 'Optics.At.Core.ix'+-- to traverse a value at a particular key.+--+-- >>> HashMap.fromList [(2, "Earth")] & ix 2 %~ ("New " ++)+-- fromList [(2,"New Earth")]+--+-- >>> preview (ix 8) HashMap.empty+-- Nothing+--+module Data.HashMap.Optics+ ( toMapOf+ , at'+ ) where++import Data.Hashable+import Data.HashMap.Lazy as HashMap++import Optics.Core++-- | Construct a hash map from an 'IxFold'.+--+-- The construction is left-biased (see 'HashMap.union'), i.e. the first+-- occurences of keys in the fold or traversal order are preferred.+--+-- >>> toMapOf ifolded ["hello", "world"]+-- fromList [(0,"hello"),(1,"world")]+--+-- >>> toMapOf (folded % ifolded) [('a',"alpha"),('b', "beta")]+-- fromList [('a',"alpha"),('b',"beta")]+--+-- >>> toMapOf (folded % ifolded) [('a', "hello"), ('b', "world"), ('a', "dummy")]+-- fromList [('a',"hello"),('b',"world")]+--+toMapOf+ :: (Is k A_Fold, is `HasSingleIndex` i, Eq i, Hashable i)+ => Optic' k is s a -> s -> HashMap i a+toMapOf o = ifoldMapOf o HashMap.singleton+{-# INLINE toMapOf #-}++-- $setup+-- >>> import Data.Monoid+-- >>> import Optics.At ()+-- >>> import Optics.Indexed ()
+ src/Data/HashSet/Optics.hs view
@@ -0,0 +1,45 @@+-- |+-- Module: Data.HashSet.Optics+-- Description: Optics for working with 'HashSet's.+--+-- This module defines optics for constructing and manipulating finite+-- 'HashSet's.+--+module Data.HashSet.Optics+ ( setmapped+ , setOf+ ) where++import Data.Hashable+import Data.HashSet as HashSet++import Optics.Fold+import Optics.Optic+import Optics.Setter++-- | This 'Setter' can be used to change the type of a 'HashSet' by mapping the+-- elements to new values.+--+-- Sadly, you can't create a valid 'Optics.Traversal.Traversal' for a 'HashSet',+-- but you can manipulate it by reading using 'Optics.Fold.folded' and+-- reindexing it via 'setmapped'.+--+-- >>> over setmapped (+1) (fromList [1,2,3,4])+-- fromList [2,3,4,5]+setmapped :: (Eq b, Hashable b) => Setter (HashSet a) (HashSet b) a b+setmapped = sets HashSet.map+{-# INLINE setmapped #-}++-- | Construct a 'HashSet' from a fold.+--+-- >>> setOf folded ["hello","world"]+-- fromList ["hello","world"]+--+-- >>> setOf (folded % _2) [("hello",1),("world",2),("!!!",3)]+-- fromList [1,2,3]+setOf :: (Is k A_Fold, Eq a, Hashable a) => Optic' k is s a -> s -> HashSet a+setOf l = foldMapOf l HashSet.singleton+{-# INLINE setOf #-}++-- $setup+-- >>> import Optics.Core
+ src/Data/Text/Lazy/Optics.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+-- |+-- Module: Data.Text.Lazy.Optics+-- Description: Optics for working with lazy 'Text.Text'.+--+-- This module provides 'Iso's for converting lazy 'Text.Text' to or from a+-- 'String' or 'Builder', and an 'IxTraversal' for traversing the individual+-- characters of a 'Text.Text'.+--+-- If you need to work with both strict and lazy text, "Data.Text.Optics"+-- provides combinators that support both varieties using a typeclass.+--+module Data.Text.Lazy.Optics+ ( packed+ , unpacked+ , _Text+ , text+ , builder+ , utf8+ , pattern Text+ ) where++import Data.ByteString.Lazy as ByteString+import Data.Text.Lazy as Text+import Data.Text.Lazy.Builder+import Data.Text.Lazy.Encoding++import Optics.Core+import Optics.Internal.Fold+import Optics.Internal.IxFold+import Optics.Internal.IxTraversal+import Optics.Internal.Optic+import Optics.Internal.Profunctor++-- | This isomorphism can be used to 'pack' (or 'unpack') lazy 'Text.Text'.+--+-- >>> "hello" ^. packed -- :: Text+-- "hello"+--+-- @+-- 'pack' x ≡ x 'Optics.Operators.^.' 'packed'+-- 'unpack' x ≡ x 'Optics.Operators.^.' 're' 'packed'+-- 'packed' ≡ 're' 'unpacked'+-- @+packed :: Iso' String Text+packed = iso Text.pack Text.unpack+{-# INLINE packed #-}++-- | This isomorphism can be used to 'unpack' (or 'pack') lazy 'Text.Text'.+--+-- >>> Text.pack "hello" ^. unpacked -- :: String+-- "hello"+--+-- @+-- 'pack' x ≡ x 'Optics.Operators.^.' 're' 'unpacked'+-- 'unpack' x ≡ x 'Optics.Operators.^.' 'packed'+-- @+--+-- This 'Iso' is provided for notational convenience rather than out of great+-- need, since+--+-- @+-- 'unpacked' ≡ 're' 'packed'+-- @+unpacked :: Iso' Text String+unpacked = Optic unpacked__+{-# INLINE unpacked #-}++-- | This is an alias for 'unpacked' that makes it clearer how to use it with+-- @('Optics.Operators.#')@.+--+-- @+-- '_Text' = 're' 'packed'+-- @+--+-- >>> _Text # "hello" -- :: Text+-- "hello"+_Text :: Iso' Text String+_Text = re packed+{-# INLINE _Text #-}++-- | Convert between lazy 'Text.Text' and 'Builder' .+--+-- @+-- 'fromLazyText' x ≡ x 'Optics.Operators.^.' 'builder'+-- 'toLazyText' x ≡ x 'Optics.Operators.^.' 're' 'builder'+-- @+builder :: Iso' Text Builder+builder = iso fromLazyText toLazyText+{-# INLINE builder #-}++-- | Traverse the individual characters in a 'Text.Text'.+--+-- >>> anyOf text (=='c') $ Text.pack "chello"+-- True+--+-- @+-- 'text' = 'unpacked' % 'traversed'+-- @+--+-- When the type is unambiguous, you can also use the more general 'each'.+--+-- @+-- 'text' ≡ 'each'+-- @+--+-- Note that when just using this as a 'Setter', @'sets' 'Data.Text.Lazy.map'@+-- can be more efficient.+text :: IxTraversal' Int Text Char+text = Optic text__+{-# INLINE text #-}++-- | Encode\/Decode a lazy 'Text.Text' to\/from lazy 'ByteString', via UTF-8.+--+-- Note: This function does not decode lazily, as it must consume the entire+-- input before deciding whether or not it fails.+--+-- >>> ByteString.unpack (utf8 # Text.pack "☃")+-- [226,152,131]+utf8 :: Prism' ByteString Text+utf8 = prism' encodeUtf8 (preview _Right . decodeUtf8')+{-# INLINE utf8 #-}++pattern Text :: String -> Text+pattern Text a <- (view _Text -> a) where+ Text a = review _Text a++----------------------------------------+-- Internal implementations++-- | Internal implementation of 'unpacked'.+unpacked__ :: Profunctor p => Optic__ p i i Text Text String String+unpacked__ = dimap Text.unpack Text.pack+{-# INLINE unpacked__ #-}++-- | Internal implementation of 'text'.+text__ :: Traversing p => Optic__ p j (Int -> j) Text Text Char Char+text__ = unpacked__ . itraversed__+{-# INLINE [0] text__ #-}++{-# RULES++"lazy text__ -> foldr"+ forall (o :: Forget r j Char Char). text__ o = foldring__ Text.foldr (reForget o)+ :: Forget r (Int -> j) Text Text++"lazy text__ -> ifoldr"+ forall (o :: IxForget r j Char Char). text__ o = ifoldring__ ifoldrLazy o+ :: IxForget r (Int -> j) Text Text++"lazy text__ -> map"+ forall (o :: FunArrow j Char Char). text__ o+ = roam Text.map (reFunArrow o)+ :: FunArrow (Int -> j) Text Text++"lazy text__ -> imap"+ forall (o :: IxFunArrow j Char Char). text__ o = iroam imapLazy o+ :: IxFunArrow (Int -> j) Text Text++#-}++-- | Indexed fold for 'text__'.+ifoldrLazy :: (Int -> Char -> a -> a) -> a -> Text -> a+ifoldrLazy f z xs =+ Text.foldr (\x g i -> i `seq` f i x (g (i + 1))) (const z) xs 0+{-# INLINE ifoldrLazy #-}++-- | Indexed setter for 'text__'.+imapLazy :: (Int -> Char -> Char) -> Text -> Text+imapLazy f = snd . Text.mapAccumL (\i a -> i `seq` (i + 1, f i a)) 0+{-# INLINE imapLazy #-}
+ src/Data/Text/Optics.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PatternSynonyms #-}+-- |+-- Module: Data.Text.Optics+-- Description: Optics for working with strict or lazy 'Text'.+--+-- This module provides 'Iso's for converting strict or lazy 'Text' to or from a+-- 'String' or 'Builder', and an 'IxTraversal' for traversing the individual+-- characters of a 'Text'.+--+-- The same combinators support both strict and lazy text using the 'IsText'+-- typeclass. You can import "Data.Text.Strict.Optics" or+-- "Data.Text.Lazy.Optics" instead if you prefer monomorphic versions.+--+module Data.Text.Optics+ ( IsText(..)+ , unpacked+ , _Text+ , pattern Text+ ) where++import Data.Text as Strict+import Data.Text.Lazy as Lazy+import Data.Text.Lazy.Builder++import Optics.Core+import qualified Data.Text.Lazy.Optics as Lazy+import qualified Data.Text.Strict.Optics as Strict++-- | Traversals for strict or lazy 'Text'+class IsText t where+ -- | This isomorphism can be used to 'pack' (or 'unpack') strict or lazy+ -- 'Text'.+ --+ -- @+ -- 'pack' x ≡ x 'Optics.Operators.^.' 'packed'+ -- 'unpack' x ≡ x 'Optics.Operators.^.' 're' 'packed'+ -- 'packed' ≡ 're' 'unpacked'+ -- @+ packed :: Iso' String t++ -- | Convert between strict or lazy 'Text' and a 'Builder'.+ --+ -- @+ -- 'fromText' x ≡ x 'Optics.Operators.^.' 'builder'+ -- @+ builder :: Iso' t Builder++ -- | Traverse the individual characters in strict or lazy 'Text'.+ --+ -- @+ -- 'text' = 'unpacked' . 'traversed'+ -- @+ text :: IxTraversal' Int t Char+ text = unpacked % itraversed+ {-# INLINE text #-}++instance IsText String where+ packed = iso id id+ text = itraversed+ builder = Lazy.packed % builder+ {-# INLINE packed #-}+ {-# INLINE text #-}+ {-# INLINE builder #-}++-- | This isomorphism can be used to 'unpack' (or 'pack') both strict or lazy+-- 'Text'.+--+-- @+-- 'unpack' x ≡ x 'Optics.Operators.^.' 'unpacked'+-- 'pack' x ≡ x 'Optics.Operators.^.' 're' 'unpacked'+-- @+--+-- This 'Iso' is provided for notational convenience rather than out of great+-- need, since+--+-- @+-- 'unpacked' ≡ 're' 'packed'+-- @+--+unpacked :: IsText t => Iso' t String+unpacked = re packed+{-# INLINE unpacked #-}++-- | This is an alias for 'unpacked' that makes it clearer how to use it with+-- @('Optics.Operators.#')@.+--+-- @+-- '_Text' = 're' 'packed'+-- @+--+-- >>> _Text # "hello" :: Strict.Text+-- "hello"+_Text :: IsText t => Iso' t String+_Text = re packed+{-# INLINE _Text #-}++pattern Text :: IsText t => String -> t+pattern Text a <- (view _Text -> a) where+ Text a = review _Text a++instance IsText Strict.Text where+ packed = Strict.packed+ builder = Strict.builder+ text = Strict.text+ {-# INLINE packed #-}+ {-# INLINE builder #-}+ {-# INLINE text #-}++instance IsText Lazy.Text where+ packed = Lazy.packed+ builder = Lazy.builder+ text = Lazy.text+ {-# INLINE packed #-}+ {-# INLINE builder #-}+ {-# INLINE text #-}
+ src/Data/Text/Strict/Optics.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PatternSynonyms #-}+-- |+-- Module: Data.Text.Strict.Optics+-- Description: Optics for working with strict 'Strict.Text'.+--+-- This module provides 'Iso's for converting strict 'Strict.Text' to or from a+-- 'String' or 'Builder', and an 'IxTraversal' for traversing the individual+-- characters of a 'Strict.Text'.+--+-- If you need to work with both strict and lazy text, "Data.Text.Optics"+-- provides combinators that support both varieties using a typeclass.+--+module Data.Text.Strict.Optics+ ( packed+ , unpacked+ , builder+ , text+ , utf8+ , _Text+ , pattern Text+ ) where++import Data.ByteString (ByteString)+import Data.Text as Strict+import Data.Text.Encoding+import Data.Text.Lazy (toStrict)+import Data.Text.Lazy.Builder++import Optics.Core+import Optics.Internal.Fold+import Optics.Internal.IxFold+import Optics.Internal.IxTraversal+import Optics.Internal.Optic+import Optics.Internal.Profunctor++-- | This isomorphism can be used to 'pack' (or 'unpack') strict 'Strict.Text'.+--+--+-- >>> "hello" ^. packed -- :: Text+-- "hello"+--+-- @+-- 'pack' x ≡ x 'Optics.Operators.^.' 'packed'+-- 'unpack' x ≡ x 'Optics.Operators.^.' 're' 'packed'+-- 'packed' ≡ 're' 'unpacked'+-- 'packed' ≡ 'iso' 'pack' 'unpack'+-- @+packed :: Iso' String Text+packed = iso pack unpack+{-# INLINE packed #-}++-- | This isomorphism can be used to 'unpack' (or 'pack') strict 'Strict.Text'.+--+-- >>> Strict.pack "hello" ^. unpacked -- :: String+-- "hello"+--+-- This 'Iso' is provided for notational convenience rather than out of great+-- need, since+--+-- @+-- 'unpacked' ≡ 're' 'packed'+-- @+--+-- @+-- 'pack' x ≡ x 'Optics.Operators.^.' 're' 'unpacked'+-- 'unpack' x ≡ x 'Optics.Operators.^.' 'packed'+-- 'unpacked' ≡ 'iso' 'unpack' 'pack'+-- @+unpacked :: Iso' Text String+unpacked = Optic unpacked__+{-# INLINE unpacked #-}++-- | This is an alias for 'unpacked' that makes it more obvious how to use it+-- with 'Optics.Operators.#'+--+-- >> _Text # "hello" -- :: Text+-- "hello"+_Text :: Iso' Text String+_Text = unpacked+{-# INLINE _Text #-}++-- | Convert between strict 'Strict.Text' and 'Builder' .+--+-- @+-- 'fromText' x ≡ x 'Optics.Operators.^.' 'builder'+-- 'toStrict' ('toLazyText' x) ≡ x 'Optics.Operators.^.' 're' 'builder'+-- @+builder :: Iso' Text Builder+builder = iso fromText (toStrict . toLazyText)+{-# INLINE builder #-}++-- | Traverse the individual characters in strict 'Strict.Text'.+--+-- >>> anyOf text (=='o') (Strict.pack "hello")+-- True+--+-- When the type is unambiguous, you can also use the more general 'each'.+--+-- @+-- 'text' ≡ 'unpacked' % 'traversed'+-- 'text' ≡ 'each'+-- @+--+-- Note that when just using this as a 'Setter', @'sets' 'Data.Text.map'@ can be+-- more efficient.+text :: IxTraversal' Int Text Char+text = Optic text__+{-# INLINE text #-}++-- | Encode\/Decode a strict 'Strict.Text' to\/from strict 'ByteString', via UTF-8.+--+-- >>> utf8 # Strict.pack "☃"+-- "\226\152\131"+utf8 :: Prism' ByteString Text+utf8 = prism' encodeUtf8 (preview _Right . decodeUtf8')+{-# INLINE utf8 #-}++pattern Text :: String -> Text+pattern Text a <- (view _Text -> a) where+ Text a = review _Text a++----------------------------------------+-- Internal implementations++-- | Internal implementation of 'unpacked'.+unpacked__ :: Profunctor p => Optic__ p i i Text Text String String+unpacked__ = dimap unpack pack+{-# INLINE unpacked__ #-}++-- | Internal implementation of 'text'.+text__ :: Traversing p => Optic__ p j (Int -> j) Text Text Char Char+text__ = unpacked__ . itraversed__+{-# INLINE [0] text__ #-}++{-# RULES++"strict text__ -> foldr"+ forall (o :: Forget r j Char Char). text__ o = foldring__ Strict.foldr (reForget o)+ :: Forget r (Int -> j) Text Text++"strict text__ -> ifoldr"+ forall (o :: IxForget r j Char Char). text__ o = ifoldring__ ifoldrStrict o+ :: IxForget r (Int -> j) Text Text++"strict text__ -> map"+ forall (o :: FunArrow j Char Char). text__ o = roam Strict.map (reFunArrow o)+ :: FunArrow (Int -> j) Text Text++"strict text__ -> imap"+ forall (o :: IxFunArrow j Char Char). text__ o = iroam imapStrict o+ :: IxFunArrow (Int -> j) Text Text++#-}++-- | Indexed fold for 'text__'.+ifoldrStrict :: (Int -> Char -> a -> a) -> a -> Text -> a+ifoldrStrict f z xs =+ Strict.foldr (\x g i -> i `seq` f i x (g (i + 1))) (const z) xs 0+{-# INLINE ifoldrStrict #-}++-- | Indexed setter for 'text__'.+imapStrict :: (Int -> Char -> Char) -> Text -> Text+imapStrict f = snd . Strict.mapAccumL (\i a -> i `seq` (i + 1, f i a)) 0+{-# INLINE imapStrict #-}
+ src/Data/Vector/Generic/Optics.hs view
@@ -0,0 +1,193 @@+-- | This module provides lenses and traversals for working with generic+-- vectors.+module Data.Vector.Generic.Optics+ ( toVectorOf+ -- * Isomorphisms+ , forced+ , vector+ , asStream+ , asStreamR+ , cloned+ , converted+ -- * Lenses+ , sliced+ -- * Traversal of individual indices+ , ordinals+ , vectorIx+ , vectorTraverse+ ) where++import Data.Vector.Fusion.Bundle (Bundle)+import Data.Vector.Generic as V hiding (zip, filter, indexed)+import Data.Vector.Generic.New (New)+import Prelude hiding ((++), length, null, head, tail, init, last, map, reverse)++import Optics.Core+import Optics.Extra.Internal.Vector+import Optics.Internal.Fold+import Optics.Internal.IxFold+import Optics.Internal.Profunctor+import Optics.Internal.Optic++-- | @sliced i n@ provides a 'Lens' that edits the @n@ elements starting at+-- index @i@ from a 'Lens'.+--+-- This is only a valid 'Lens' if you do not change the length of the resulting+-- 'Vector'.+--+-- Attempting to return a longer or shorter vector will result in violations of+-- the 'Lens' laws.+--+-- >>> Vector.fromList [1..10] ^. sliced 2 5 == Vector.fromList [3,4,5,6,7]+-- True+--+-- >>> (Vector.fromList [1..10] & sliced 2 5 % mapped .~ 0) == Vector.fromList [1,2,0,0,0,0,0,8,9,10]+-- True+sliced+ :: Vector v a+ => Int -- ^ @i@ starting index+ -> Int -- ^ @n@ length+ -> Lens' (v a) (v a)+sliced i n = lensVL $ \f v ->+ (\v0 -> v // zip [i..i+n-1] (V.toList v0)) <$> f (slice i n v)+{-# INLINE sliced #-}++-- | Similar to 'toListOf', but returning a 'Vector'.+--+-- >>> (toVectorOf each (8,15) :: Vector.Vector Int) == Vector.fromList [8,15]+-- True+toVectorOf+ :: (Is k A_Fold, Vector v a)+ => Optic' k is s a+ -> s+ -> v a+toVectorOf l s = fromList (toListOf l s)+{-# INLINE toVectorOf #-}++-- | Convert a list to a 'Vector' (or back.)+--+-- >>> ([1,2,3] ^. vector :: Vector.Vector Int) == Vector.fromList [1,2,3]+-- True+--+-- >>> Vector.fromList [0,8,15] ^. re vector+-- [0,8,15]+vector+ :: (Vector v a, Vector v b)+ => Iso [a] [b] (v a) (v b)+vector = iso fromList V.toList+{-# INLINE vector #-}++-- | Convert a 'Vector' to a finite 'Bundle' (or back.)+asStream+ :: (Vector v a, Vector v b)+ => Iso (v a) (v b) (Bundle v a) (Bundle v b)+asStream = iso stream unstream+{-# INLINE asStream #-}++-- | Convert a 'Vector' to a finite 'Bundle' from right to left (or back.)+asStreamR+ :: (Vector v a, Vector v b)+ => Iso (v a) (v b) (Bundle v a) (Bundle v b)+asStreamR = iso streamR unstreamR+{-# INLINE asStreamR #-}++-- | Convert a 'Vector' back and forth to an initializer that when run produces+-- a copy of the 'Vector'.+cloned :: Vector v a => Iso' (v a) (New v a)+cloned = iso clone new+{-# INLINE cloned #-}++-- | Convert a 'Vector' to a version that doesn't retain any extra memory.+forced :: (Vector v a, Vector v b) => Iso (v a) (v b) (v a) (v b)+forced = iso force force+{-# INLINE forced #-}++-- | This 'Traversal' will ignore any duplicates in the supplied list of+-- indices.+--+-- >>> toListOf (ordinals [1,3,2,5,9,10]) $ Vector.fromList [2,4..40]+-- [4,8,6,12,20,22]+ordinals :: forall v a. Vector v a => [Int] -> IxTraversal' Int (v a) a+ordinals is = itraversalVL $ \f v ->+ (v //) <$> traverse (\i -> (,) i <$> f i (v ! i)) (ordinalNub (length v) is)+{-# INLINE ordinals #-}++-- | Like 'ix' but polymorphic in the vector type.+vectorIx :: V.Vector v a => Int -> Traversal' (v a) a+vectorIx i = traversalVL $ \f v ->+ if 0 <= i && i < V.length v+ then (\a -> v V.// [(i, a)]) <$> f (v V.! i)+ else pure v+{-# INLINE vectorIx #-}++-- | Indexed vector traversal for a generic vector.+vectorTraverse+ :: forall v w a b. (V.Vector v a, V.Vector w b)+ => IxTraversal Int (v a) (w b) a b+vectorTraverse = Optic vectorTraverse__+{-# INLINE vectorTraverse #-}++-- | Different vector implementations are isomorphic to each other.+converted+ :: (Vector v a, Vector w a, Vector v b, Vector w b)+ => Iso (v a) (v b) (w a) (w b)+converted = iso convert convert+{-# INLINE converted #-}++----------------------------------------+-- Internal implementations++vectorTraverse__+ :: (Traversing p, V.Vector v a, V.Vector w b)+ => Optic__ p j (Int -> j) (v a) (w b) a b+vectorTraverse__ = conjoined__ vectorTraverseNoIx__ vectorTraverseIx__+{-# INLINE [0] vectorTraverse__ #-}++vectorTraverseNoIx__+ :: (Traversing p, V.Vector v a, V.Vector w b)+ => Optic__ p j j (v a) (w b) a b+vectorTraverseNoIx__ = wander $ \f v ->+ let !n = V.length v in V.fromListN n <$> traverse f (V.toList v)+{-# INLINE vectorTraverseNoIx__ #-}++vectorTraverseIx__+ :: (Traversing p, V.Vector v a, V.Vector w b)+ => Optic__ p j (Int -> j) (v a) (w b) a b+vectorTraverseIx__ = iwander $ \f v ->+ let !n = V.length v in V.fromListN n <$> itraverse f (V.toList v)+{-# INLINE vectorTraverseIx__ #-}++-- Because vectorTraverse__ inlines late, GHC needs rewrite rules for all cases+-- in order to generate optimal code for each of them. The ones that rewrite+-- traversal into a traversal correspond to an early inline.++{-# RULES++"vectorTraverse__ -> traversed"+ forall (o :: Star g j a b). vectorTraverse__ o = vectorTraverseNoIx__ (reStar o)+ :: (V.Vector v a, V.Vector w b) => Star g (Int -> j) (v a) (w b)++"vectorTraverse__ -> folded"+ forall (o :: Forget r j a b). vectorTraverse__ o = foldring__ V.foldr (reForget o)+ :: (V.Vector v a, V.Vector v b) => Forget r (Int -> j) (v a) (v b)++"vectorTraverse__ -> mapped"+ forall (o :: FunArrow j a b). vectorTraverse__ o = roam V.map (reFunArrow o)+ :: (V.Vector v a, V.Vector v b) => FunArrow (Int -> j) (v a) (v b)++"vectorTraverse__ -> itraversed"+ forall (o :: IxStar g j a b). vectorTraverse__ o = vectorTraverseIx__ o+ :: (V.Vector v a, V.Vector w b) => IxStar g (Int -> j) (v a) (w b)++"vectorTraverse__ -> ifolded"+ forall (o :: IxForget r j a b). vectorTraverse__ o = ifoldring__ V.ifoldr o+ :: (V.Vector v a, V.Vector v b) => IxForget r (Int -> j) (v a) (v b)++"vectorTraverse__ -> imapped"+ forall (o :: IxFunArrow j a b). vectorTraverse__ o = iroam V.imap o+ :: (V.Vector v a, V.Vector v b) => IxFunArrow (Int -> j) (v a) (v b)++#-}++-- $setup+-- >>> import qualified Data.Vector as Vector
+ src/Data/Vector/Optics.hs view
@@ -0,0 +1,79 @@+-- | This module provides lenses and traversals for working with vectors.+module Data.Vector.Optics+ ( toVectorOf+ -- * Isomorphisms+ , vector+ , forced+ -- * Lenses+ , sliced+ -- * Traversal of individual indices+ , ordinals+ ) where++import Data.Vector as Vector hiding (zip, filter, indexed)+import Prelude hiding ((++), length, null, head, tail, init, last, map, reverse)++import Optics.Core+import qualified Data.Vector.Generic.Optics as G++-- | @sliced i n@ provides a 'Lens' that edits the @n@ elements starting at+-- index @i@ from a 'Lens'.+--+-- This is only a valid 'Lens' if you do not change the length of the resulting+-- 'Vector'.+--+-- Attempting to return a longer or shorter vector will result in violations of+-- the 'Lens' laws.+--+-- >>> Vector.fromList [1..10] ^. sliced 2 5 == Vector.fromList [3,4,5,6,7]+-- True+--+-- >>> (Vector.fromList [1..10] & sliced 2 5 % mapped .~ 0) == Vector.fromList [1,2,0,0,0,0,0,8,9,10]+-- True+sliced+ :: Int -- ^ @i@ starting index+ -> Int -- ^ @n@ length+ -> Lens' (Vector a) (Vector a)+sliced = G.sliced+{-# INLINE sliced #-}++-- | Similar to 'toListOf', but returning a 'Vector'.+--+-- >>> toVectorOf each (8,15) == Vector.fromList [8,15]+-- True+toVectorOf+ :: Is k A_Fold+ => Optic' k is s a+ -> s+ -> Vector a+toVectorOf = G.toVectorOf+{-# INLINE toVectorOf #-}++-- | Convert a list to a 'Vector' (or back)+--+-- >>> [1,2,3] ^. vector == Vector.fromList [1,2,3]+-- True+--+-- >>> [1,2,3] ^. vector % re vector+-- [1,2,3]+--+-- >>> Vector.fromList [0,8,15] ^. re vector % vector == Vector.fromList [0,8,15]+-- True+vector :: Iso [a] [b] (Vector a) (Vector b)+vector = G.vector+{-# INLINE vector #-}++-- | Convert a 'Vector' to a version that doesn't retain any extra+-- memory.+forced :: Iso (Vector a) (Vector b) (Vector a) (Vector b)+forced = G.forced+{-# INLINE forced #-}++-- | This 'Traversal' will ignore any duplicates in the supplied list of+-- indices.+--+-- >>> toListOf (ordinals [1,3,2,5,9,10]) $ Vector.fromList [2,4..40]+-- [4,8,6,12,20,22]+ordinals :: forall a. [Int] -> IxTraversal' Int (Vector a) a+ordinals = G.ordinals+{-# INLINE ordinals #-}
+ src/Optics/At.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module: Optics.At+-- Description: Optics for 'Data.Map.Map' and 'Data.Set.Set'-like containers.+--+-- This module provides optics for 'Data.Map.Map' and 'Data.Set.Set'-like+-- containers, including an 'AffineTraversal' to traverse a key in a map or an+-- element of a sequence:+--+-- >>> preview (ix 1) ['a','b','c']+-- Just 'b'+--+-- a 'Lens' to get, set or delete a key in a map:+--+-- >>> set (at 0) (Just 'b') (Map.fromList [(0, 'a')])+-- fromList [(0,'b')]+--+-- and a 'Lens' to insert or remove an element of a set:+--+-- >>> IntSet.fromList [1,2,3,4] & contains 3 .~ False+-- fromList [1,2,4]+--+-- This module includes the core definitions from "Optics.At.Core" along with+-- extra (orphan) instances.+--+module Optics.At+ (+ -- * Type families+ Index+ , IxValue++ -- * Ixed+ , Ixed(..)+ , ixAt++ -- * At+ , At(..)+ , at'+ , sans++ -- * Contains+ , Contains(..)+ ) where++import Data.ByteString as StrictB+import Data.ByteString.Lazy as LazyB+import Data.HashMap.Lazy as HashMap+import Data.HashSet as HashSet+import Data.Hashable+import Data.Int+import Data.Text as StrictT+import Data.Text.Lazy as LazyT+import Data.Vector as Vector hiding (indexed)+import Data.Vector.Primitive as Prim+import Data.Vector.Storable as Storable+import Data.Vector.Unboxed as Unboxed hiding (indexed)+import Data.Word++import Optics.Core++type instance Index (HashSet a) = a+type instance Index (HashMap k a) = k+type instance Index (Vector.Vector a) = Int+type instance Index (Prim.Vector a) = Int+type instance Index (Storable.Vector a) = Int+type instance Index (Unboxed.Vector a) = Int+type instance Index StrictT.Text = Int+type instance Index LazyT.Text = Int64+type instance Index StrictB.ByteString = Int+type instance Index LazyB.ByteString = Int64++-- Contains++instance (Eq a, Hashable a) => Contains (HashSet a) where+ contains k = lensVL $ \f s -> f (HashSet.member k s) <&> \b ->+ if b then HashSet.insert k s else HashSet.delete k s+ {-# INLINE contains #-}++-- Ixed++type instance IxValue (HashMap k a) = a+-- Default implementation uses HashMap.alterF+instance (Eq k, Hashable k) => Ixed (HashMap k a)++type instance IxValue (HashSet k) = ()+instance (Eq k, Hashable k) => Ixed (HashSet k) where+ ix k = atraversalVL $ \point f m ->+ if HashSet.member k m+ then f () <&> \() -> HashSet.insert k m+ else point m+ {-# INLINE ix #-}++type instance IxValue (Vector.Vector a) = a+instance Ixed (Vector.Vector a) where+ ix i = atraversalVL $ \point f v ->+ if 0 <= i && i < Vector.length v+ then f (v Vector.! i) <&> \a -> v Vector.// [(i, a)]+ else point v+ {-# INLINE ix #-}++type instance IxValue (Prim.Vector a) = a+instance Prim a => Ixed (Prim.Vector a) where+ ix i = atraversalVL $ \point f v ->+ if 0 <= i && i < Prim.length v+ then f (v Prim.! i) <&> \a -> v Prim.// [(i, a)]+ else point v+ {-# INLINE ix #-}++type instance IxValue (Storable.Vector a) = a+instance Storable a => Ixed (Storable.Vector a) where+ ix i = atraversalVL $ \point f v ->+ if 0 <= i && i < Storable.length v+ then f (v Storable.! i) <&> \a -> v Storable.// [(i, a)]+ else point v+ {-# INLINE ix #-}++type instance IxValue (Unboxed.Vector a) = a+instance Unbox a => Ixed (Unboxed.Vector a) where+ ix i = atraversalVL $ \point f v ->+ if 0 <= i && i < Unboxed.length v+ then f (v Unboxed.! i) <&> \a -> v Unboxed.// [(i, a)]+ else point v+ {-# INLINE ix #-}++type instance IxValue StrictT.Text = Char+instance Ixed StrictT.Text where+ ix e = atraversalVL $ \point f s ->+ case StrictT.splitAt e s of+ (l, mr) -> case StrictT.uncons mr of+ Nothing -> point s+ Just (c, xs) -> f c <&> \d -> StrictT.concat [l, StrictT.singleton d, xs]+ {-# INLINE ix #-}++type instance IxValue LazyT.Text = Char+instance Ixed LazyT.Text where+ ix e = atraversalVL $ \point f s ->+ case LazyT.splitAt e s of+ (l, mr) -> case LazyT.uncons mr of+ Nothing -> point s+ Just (c, xs) -> f c <&> \d -> LazyT.append l (LazyT.cons d xs)+ {-# INLINE ix #-}++type instance IxValue StrictB.ByteString = Word8+instance Ixed StrictB.ByteString where+ ix e = atraversalVL $ \point f s ->+ case StrictB.splitAt e s of+ (l, mr) -> case StrictB.uncons mr of+ Nothing -> point s+ Just (c, xs) -> f c <&> \d -> StrictB.concat [l, StrictB.singleton d, xs]+ {-# INLINE ix #-}++type instance IxValue LazyB.ByteString = Word8+instance Ixed LazyB.ByteString where+ -- TODO: we could be lazier, returning each chunk as it is passed+ ix e = atraversalVL $ \point f s ->+ case LazyB.splitAt e s of+ (l, mr) -> case LazyB.uncons mr of+ Nothing -> point s+ Just (c, xs) -> f c <&> \d -> LazyB.append l (LazyB.cons d xs)+ {-# INLINE ix #-}++-- At++instance (Eq k, Hashable k) => At (HashMap k a) where+#if MIN_VERSION_unordered_containers(0,2,10)+ at k = lensVL $ \f -> HashMap.alterF f k+#else+ at k = lensVL $ \f m ->+ let mv = HashMap.lookup k m+ in f mv <&> \r -> case r of+ Nothing -> maybe m (const (HashMap.delete k m)) mv+ Just v' -> HashMap.insert k v' m+#endif+ {-# INLINE at #-}++instance (Eq k, Hashable k) => At (HashSet k) where+ at k = lensVL $ \f m ->+ let mv = if HashSet.member k m+ then Just ()+ else Nothing+ in f mv <&> \r -> case r of+ Nothing -> maybe m (const (HashSet.delete k m)) mv+ Just () -> HashSet.insert k m+ {-# INLINE at #-}++-- $setup+-- >>> import qualified Data.IntSet as IntSet+-- >>> import qualified Data.Map as Map
+ src/Optics/Cons.hs view
@@ -0,0 +1,138 @@+-- |+-- Module: Optics.Cons+-- Description: Optics to access the left or right element of a container.+--+-- This module defines the 'Cons' and 'Snoc' classes, which provide 'Prism's for+-- the leftmost and rightmost elements of a container, respectively.+--+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Optics.Cons+ (+ -- * Cons+ Cons(..)+ , (<|)+ , cons+ , uncons+ , _head, _tail+ , pattern (:<)+ -- * Snoc+ , Snoc(..)+ , (|>)+ , snoc+ , unsnoc+ , _init, _last+ , pattern (:>)+ ) where++import Data.Vector (Vector)+import Data.Vector.Primitive (Prim)+import Data.Vector.Storable (Storable)+import Data.Vector.Unboxed (Unbox)+import Data.Word+import qualified Data.ByteString as StrictB+import qualified Data.ByteString.Lazy as LazyB+import qualified Data.Text as StrictT+import qualified Data.Text.Lazy as LazyT+import qualified Data.Vector as Vector+import qualified Data.Vector.Primitive as Prim+import qualified Data.Vector.Storable as Storable+import qualified Data.Vector.Unboxed as Unbox++import Optics.Core++-- Cons++instance Cons StrictB.ByteString StrictB.ByteString Word8 Word8 where+ _Cons = prism' (uncurry StrictB.cons) StrictB.uncons+ {-# INLINE _Cons #-}++instance Cons LazyB.ByteString LazyB.ByteString Word8 Word8 where+ _Cons = prism' (uncurry LazyB.cons) LazyB.uncons+ {-# INLINE _Cons #-}++instance Cons StrictT.Text StrictT.Text Char Char where+ _Cons = prism' (uncurry StrictT.cons) StrictT.uncons+ {-# INLINE _Cons #-}++instance Cons LazyT.Text LazyT.Text Char Char where+ _Cons = prism' (uncurry LazyT.cons) LazyT.uncons+ {-# INLINE _Cons #-}++instance Cons (Vector a) (Vector b) a b where+ _Cons = prism (uncurry Vector.cons) $ \v ->+ if Vector.null v+ then Left Vector.empty+ else Right (Vector.unsafeHead v, Vector.unsafeTail v)+ {-# INLINE _Cons #-}++instance (Prim a, Prim b) => Cons (Prim.Vector a) (Prim.Vector b) a b where+ _Cons = prism (uncurry Prim.cons) $ \v ->+ if Prim.null v+ then Left Prim.empty+ else Right (Prim.unsafeHead v, Prim.unsafeTail v)+ {-# INLINE _Cons #-}++instance (Storable a, Storable b) => Cons (Storable.Vector a) (Storable.Vector b) a b where+ _Cons = prism (uncurry Storable.cons) $ \v ->+ if Storable.null v+ then Left Storable.empty+ else Right (Storable.unsafeHead v, Storable.unsafeTail v)+ {-# INLINE _Cons #-}++instance (Unbox a, Unbox b) => Cons (Unbox.Vector a) (Unbox.Vector b) a b where+ _Cons = prism (uncurry Unbox.cons) $ \v ->+ if Unbox.null v+ then Left Unbox.empty+ else Right (Unbox.unsafeHead v, Unbox.unsafeTail v)+ {-# INLINE _Cons #-}++-- Snoc++instance Snoc (Vector a) (Vector b) a b where+ _Snoc = prism (uncurry Vector.snoc) $ \v -> if Vector.null v+ then Left Vector.empty+ else Right (Vector.unsafeInit v, Vector.unsafeLast v)+ {-# INLINE _Snoc #-}++instance (Prim a, Prim b) => Snoc (Prim.Vector a) (Prim.Vector b) a b where+ _Snoc = prism (uncurry Prim.snoc) $ \v -> if Prim.null v+ then Left Prim.empty+ else Right (Prim.unsafeInit v, Prim.unsafeLast v)+ {-# INLINE _Snoc #-}++instance (Storable a, Storable b) => Snoc (Storable.Vector a) (Storable.Vector b) a b where+ _Snoc = prism (uncurry Storable.snoc) $ \v -> if Storable.null v+ then Left Storable.empty+ else Right (Storable.unsafeInit v, Storable.unsafeLast v)+ {-# INLINE _Snoc #-}++instance (Unbox a, Unbox b) => Snoc (Unbox.Vector a) (Unbox.Vector b) a b where+ _Snoc = prism (uncurry Unbox.snoc) $ \v -> if Unbox.null v+ then Left Unbox.empty+ else Right (Unbox.unsafeInit v, Unbox.unsafeLast v)+ {-# INLINE _Snoc #-}++instance Snoc StrictB.ByteString StrictB.ByteString Word8 Word8 where+ _Snoc = prism (uncurry StrictB.snoc) $ \v -> if StrictB.null v+ then Left StrictB.empty+ else Right (StrictB.init v, StrictB.last v)+ {-# INLINE _Snoc #-}++instance Snoc LazyB.ByteString LazyB.ByteString Word8 Word8 where+ _Snoc = prism (uncurry LazyB.snoc) $ \v -> if LazyB.null v+ then Left LazyB.empty+ else Right (LazyB.init v, LazyB.last v)+ {-# INLINE _Snoc #-}++instance Snoc StrictT.Text StrictT.Text Char Char where+ _Snoc = prism (uncurry StrictT.snoc) $ \v -> if StrictT.null v+ then Left StrictT.empty+ else Right (StrictT.init v, StrictT.last v)+ {-# INLINE _Snoc #-}++instance Snoc LazyT.Text LazyT.Text Char Char where+ _Snoc = prism (uncurry LazyT.snoc) $ \v -> if LazyT.null v+ then Left LazyT.empty+ else Right (LazyT.init v, LazyT.last v)+ {-# INLINE _Snoc #-}
+ src/Optics/Each.hs view
@@ -0,0 +1,88 @@+-- |+-- Module: Optics.Each+-- Description: An 'IxTraversal' for 'each' element of a (potentially monomorphic) container.+--+-- This module defines the 'Each' class, which provides an 'IxTraversal' that+-- extracts 'each' element of a (potentially monomorphic) container.+--+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Optics.Each+ (+ -- * Each+ Each(..)+ ) where++import Data.ByteString as SB+import Data.ByteString.Lazy as LB+import Data.HashMap.Lazy as HashMap+import Data.Int+import Data.Text as ST+import Data.Text.Lazy as LT+import Data.Text.Optics (text)+import Data.Vector.Generic.Optics (vectorTraverse)+import Data.Vector.Primitive (Prim)+import Data.Vector.Storable (Storable)+import Data.Vector.Unboxed (Unbox)+import Data.Word+import qualified Data.Vector as V+import qualified Data.Vector.Primitive as VP+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as VU++import Optics.Core+import Optics.Indexed ()+import Optics.Extra.Internal.ByteString++-- Extra instances++-- | @'each' :: 'IxTraversal' k ('HashMap' k a) ('HashMap' k b) a b@+instance k ~ k' => Each k (HashMap k a) (HashMap k' b) a b where+ -- traverseWithKey has best performance for all flavours for some reason.+ each = itraversalVL HashMap.traverseWithKey+ {-# INLINE[1] each #-}++-- | @'each' :: 'IxTraversal' Int ('V.Vector' a) ('V.Vector' b) a b@+instance Each Int (V.Vector a) (V.Vector b) a b where+ each = vectorTraverse+ {-# INLINE[1] each #-}++-- | @'each' :: ('Prim' a, 'Prim' b) => 'IxTraversal' Int ('Prim.Vector' a)+-- ('Prim.Vector' b) a b@+instance (Prim a, Prim b) => Each Int (VP.Vector a) (VP.Vector b) a b where+ each = vectorTraverse+ {-# INLINE[1] each #-}++-- | @'each' :: ('Storable' a, 'Storable' b) => 'IxTraversal' 'Int' ('VS.Vector'+-- a) ('VS.Vector' b) a b@+instance (Storable a, Storable b) => Each Int (VS.Vector a) (VS.Vector b) a b where+ each = vectorTraverse+ {-# INLINE[1] each #-}++-- | @'each' :: ('Unbox' a, 'Unbox' b) => 'IxTraversal' 'Int' ('VU.Vector' a)+-- ('VU.Vector' b) a b@+instance (Unbox a, Unbox b ) => Each Int (VU.Vector a) (VU.Vector b) a b where+ each = vectorTraverse+ {-# INLINE[1] each #-}++-- | @'each' :: 'IxTraversal' 'Int' 'ST.Text' 'ST.Text' 'Char' 'Char'@+instance (a ~ Char, b ~ Char) => Each Int ST.Text ST.Text a b where+ each = text+ {-# INLINE[1] each #-}++-- | @'each' :: 'IxTraversal' 'Int64' 'LT.Text' 'LT.Text' 'Char' 'Char'@+instance (a ~ Char, b ~ Char) => Each Int LT.Text LT.Text a b where+ each = text+ {-# INLINE[1] each #-}++-- | @'each' :: 'IxTraversal' 'Int' 'SB.ByteString' 'SB.ByteString' 'Word8'+-- 'Word8'@+instance (a ~ Word8, b ~ Word8) => Each Int64 SB.ByteString SB.ByteString a b where+ each = traversedStrictTree+ {-# INLINE[1] each #-}++-- | @'each' :: 'IxTraversal' 'Int64' 'LB.ByteString' 'LB.ByteString' 'Word8'+-- 'Word8'@+instance (a ~ Word8, b ~ Word8) => Each Int64 LB.ByteString LB.ByteString a b where+ each = traversedLazy+ {-# INLINE[1] each #-}
+ src/Optics/Empty.hs view
@@ -0,0 +1,69 @@+-- |+-- Module: Optics.Empty+-- Description: A 'Prism' for a type that may be '_Empty'.+--+-- This module defines the 'AsEmpty' class, which provides a 'Prism' for a type+-- that may be '_Empty'.+--+-- >>> isn't _Empty [1,2,3]+-- True+--+-- >>> case Nothing of { Empty -> True; _ -> False }+-- True+--+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Optics.Empty+ ( AsEmpty(..)+ , pattern Empty+ ) where++import Data.ByteString as StrictB+import Data.ByteString.Lazy as LazyB+import Data.HashMap.Lazy as HashMap+import Data.HashSet as HashSet+import Data.Text as StrictT+import Data.Text.Lazy as LazyT+import Data.Vector as Vector+import Data.Vector.Storable as Storable+import Data.Vector.Unboxed as Unboxed++import Optics.Core++-- Extra instances++instance AsEmpty (HashMap k a) where+ _Empty = nearly HashMap.empty HashMap.null+ {-# INLINE _Empty #-}++instance AsEmpty (HashSet a) where+ _Empty = nearly HashSet.empty HashSet.null+ {-# INLINE _Empty #-}++instance AsEmpty (Vector.Vector a) where+ _Empty = nearly Vector.empty Vector.null+ {-# INLINE _Empty #-}++instance Unbox a => AsEmpty (Unboxed.Vector a) where+ _Empty = nearly Unboxed.empty Unboxed.null+ {-# INLINE _Empty #-}++instance Storable a => AsEmpty (Storable.Vector a) where+ _Empty = nearly Storable.empty Storable.null+ {-# INLINE _Empty #-}++instance AsEmpty StrictB.ByteString where+ _Empty = nearly StrictB.empty StrictB.null+ {-# INLINE _Empty #-}++instance AsEmpty LazyB.ByteString where+ _Empty = nearly LazyB.empty LazyB.null+ {-# INLINE _Empty #-}++instance AsEmpty StrictT.Text where+ _Empty = nearly StrictT.empty StrictT.null+ {-# INLINE _Empty #-}++instance AsEmpty LazyT.Text where+ _Empty = nearly LazyT.empty LazyT.null+ {-# INLINE _Empty #-}
+ src/Optics/Extra.hs view
@@ -0,0 +1,14 @@+module Optics.Extra+ ( module Optics.Core+ , module O+ ) where++import Optics.Core++import Optics.At as O+import Optics.Cons as O+import Optics.Each as O+import Optics.Empty as O+import Optics.Indexed as O+import Optics.View as O+import Optics.Zoom as O
+ src/Optics/Extra/Internal/ByteString.hs view
@@ -0,0 +1,298 @@+-- | This module spends a lot of time fiddling around with 'Data.ByteString'+-- internals to work around <http://hackage.haskell.org/trac/ghc/ticket/7556> on+-- older Haskell Platforms and to improve constant and asymptotic factors in our+-- performance.+----------------------------------------------------------------------------+module Optics.Extra.Internal.ByteString+ ( traversedStrictTree+ , traversedStrictTree8+ , traversedLazy+ , traversedLazy8+ ) where++import Data.Bits+import Data.Char+import Data.Int+import Data.Word+import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Storable+import GHC.Base (unsafeChr)+import GHC.ForeignPtr (mallocPlainForeignPtrBytes)+import GHC.IO (unsafeDupablePerformIO)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BL8+import qualified Data.ByteString.Internal as BI+import qualified Data.ByteString.Unsafe as BU++import Optics.Core+import Optics.Internal.Fold+import Optics.Internal.IxFold+import Optics.Internal.Optic+import Optics.Internal.Profunctor++-- | Traverse a strict 'B.ByteString' in a relatively balanced fashion, as a+-- balanced tree with biased runs of elements at the leaves.+traversedStrictTree :: IxTraversal' Int64 B.ByteString Word8+traversedStrictTree = Optic traversedStrictTree__+{-# INLINE traversedStrictTree #-}++-- | Traverse a strict 'B.ByteString' in a relatively balanced fashion, as a+-- balanced tree with biased runs of elements at the leaves, pretending the+-- bytes are chars.+traversedStrictTree8 :: IxTraversal' Int64 B8.ByteString Char+traversedStrictTree8 = Optic traversedStrictTree8__+{-# INLINE traversedStrictTree8 #-}++-- | An 'IxTraversal' of the individual bytes in a lazy 'BL.ByteString'.+traversedLazy :: IxTraversal' Int64 BL.ByteString Word8+traversedLazy = Optic traversedLazy__+{-# INLINE traversedLazy #-}++-- | An 'IxTraversal' of the individual bytes in a lazy 'BL.ByteString'+-- pretending the bytes are chars.+traversedLazy8 :: IxTraversal' Int64 BL.ByteString Char+traversedLazy8 = Optic traversedLazy8__+{-# INLINE traversedLazy8 #-}++----------------------------------------+-- Internal implementations++grain :: Int64+grain = 32+{-# INLINE grain #-}++-- | Internal version of 'traversedStrictTree'.+traversedStrictTree__+ :: Traversing p+ => Optic__ p j (Int64 -> j) B.ByteString B.ByteString Word8 Word8+traversedStrictTree__ = iwander $ \f bs ->+ let len = B.length bs+ go !i !j+ | i + grain < j, k <- i + shiftR (j - i) 1 =+ (\l r q -> l q >> r q) <$> go i k <*> go k j+ | otherwise = run i j+ run !(i::Int64) !(j::Int64)+ | i == j = pure (\_ -> return ())+ | otherwise =+ let !i' = fromIntegral i+ !x = BU.unsafeIndex bs i'+ in (\y ys q -> pokeByteOff q i' y >> ys q)+ <$> f i x+ <*> run (i + 1) j+ in unsafeCreate len <$> go 0 (fromIntegral len)+{-# INLINE [0] traversedStrictTree__ #-}++{-# RULES++"bytes -> map"+ forall (o :: FunArrow j Word8 Word8). traversedStrictTree__ o+ = roam B.map (reFunArrow o)+ :: FunArrow (Int64 -> j) B.ByteString B.ByteString++"bytes -> imap"+ forall (o :: IxFunArrow j Word8 Word8). traversedStrictTree__ o = iroam imapB o+ :: IxFunArrow (Int64 -> j) B.ByteString B.ByteString++"bytes -> foldr"+ forall (o :: Forget r j Word8 Word8). traversedStrictTree__ o+ = foldring__ B.foldr (reForget o)+ :: Forget r (Int64 -> j) B.ByteString B.ByteString++"bytes -> ifoldr"+ forall (o :: IxForget r j Word8 Word8). traversedStrictTree__ o+ = ifoldring__ ifoldrB o+ :: IxForget r (Int64 -> j) B.ByteString B.ByteString++#-}++-- | Indexed setter for 'traversedStrictTree__'.+imapB :: (Int64 -> Word8 -> Word8) -> B.ByteString -> B.ByteString+imapB f = snd . B.mapAccumL (\i a -> i `seq` (i + 1, f i a)) 0+{-# INLINE imapB #-}++-- | Indexed fold for 'traversedStrictTree__'.+ifoldrB :: (Int64 -> Word8 -> a -> a) -> a -> B.ByteString -> a+ifoldrB f z xs = B.foldr (\x g i -> i `seq` f i x (g (i + 1))) (const z) xs 0+{-# INLINE ifoldrB #-}++----------------------------------------++-- | Internal version of 'traversedStrictTree8'.+traversedStrictTree8__+ :: Traversing p+ => Optic__ p j (Int64 -> j) B8.ByteString B8.ByteString Char Char+traversedStrictTree8__ = iwander $ \f bs ->+ let len = B.length bs+ go !i !j+ | i + grain < j, k <- i + shiftR (j - i) 1 =+ (\l r q -> l q >> r q) <$> go i k <*> go k j+ | otherwise = run i j+ run !(i::Int64) !(j::Int64)+ | i == j = pure (\_ -> return ())+ | otherwise =+ let !i' = fromIntegral i+ !x = BU.unsafeIndex bs i'+ in (\y ys q -> pokeByteOff q i' (c2w y) >> ys q)+ <$> f i (w2c x)+ <*> run (i + 1) j+ in unsafeCreate len <$> go 0 (fromIntegral len)+{-# INLINE [0] traversedStrictTree8__ #-}++{-# RULES++"chars -> map"+ forall (o :: FunArrow j Char Char). traversedStrictTree8__ o+ = roam B8.map (reFunArrow o)+ :: FunArrow (Int64 -> j) B8.ByteString B8.ByteString++"chars -> imap"+ forall (o :: IxFunArrow j Char Char). traversedStrictTree8__ o = iroam imapB8 o+ :: IxFunArrow (Int64 -> j) B8.ByteString B8.ByteString++"chars -> foldr"+ forall (o :: Forget r j Char Char). traversedStrictTree8__ o+ = foldring__ B8.foldr (reForget o)+ :: Forget r (Int64 -> j) B8.ByteString B8.ByteString++"chars -> ifoldr"+ forall (o :: IxForget r j Char Char). traversedStrictTree8__ o+ = ifoldring__ ifoldrB8 o+ :: IxForget r (Int64 -> j) B8.ByteString B8.ByteString++#-}++-- | Indexed setter for 'traversedStrictTree8__'.+imapB8 :: (Int64 -> Char -> Char) -> B.ByteString -> B.ByteString+imapB8 f = snd . B8.mapAccumL (\i a -> i `seq` (i + 1, f i a)) 0+{-# INLINE imapB8 #-}++-- | Indexed fold for 'traversedStrictTree8__'.+ifoldrB8 :: (Int64 -> Char -> a -> a) -> a -> B.ByteString -> a+ifoldrB8 f z xs = B8.foldr (\x g i -> i `seq` f i x (g (i + 1))) (const z) xs 0+{-# INLINE ifoldrB8 #-}++----------------------------------------++-- | Internal version of 'traversedLazy'.+traversedLazy__+ :: Traversing p+ => Optic__ p j (Int64 -> j) BL.ByteString BL.ByteString Word8 Word8+traversedLazy__ = iwander $ \f lbs ->+ let go c fcs acc =+ let !acc' = acc + fromIntegral (B.length c)+ rest = reindexed (\x -> acc + x) traversedStrictTree+ in BL.append . BL.fromStrict <$> itraverseOf rest f c <*> fcs acc'+ in BL.foldrChunks go (\_ -> pure BL.empty) lbs 0+{-# INLINE [1] traversedLazy__ #-}++{-# RULES++"sets lazy bytestring"+ forall (o :: FunArrow j Word8 Word8). traversedLazy__ o+ = roam BL.map (reFunArrow o)+ :: FunArrow (Int64 -> j) BL.ByteString BL.ByteString++"isets lazy bytestring"+ forall (o :: IxFunArrow j Word8 Word8). traversedLazy__ o = iroam imapBL o+ :: IxFunArrow (Int64 -> j) BL.ByteString BL.ByteString++"gets lazy bytestring"+ forall (o :: Forget r j Word8 Word8). traversedLazy__ o+ = foldring__ BL.foldr (reForget o)+ :: Forget r (Int64 -> j) BL.ByteString BL.ByteString++"igets lazy bytestring"+ forall (o :: IxForget r j Word8 Word8). traversedLazy__ o = ifoldring__ ifoldrBL o+ :: IxForget r (Int64 -> j) BL.ByteString BL.ByteString++#-}++-- | Indexed setter for 'traversedLazy__'.+imapBL :: (Int64 -> Word8 -> Word8) -> BL.ByteString -> BL.ByteString+imapBL f = snd . BL.mapAccumL (\i a -> i `seq` (i + 1, f i a)) 0+{-# INLINE imapBL #-}++-- | Indexed fold for 'traversedLazy__'.+ifoldrBL :: (Int64 -> Word8 -> a -> a) -> a -> BL.ByteString -> a+ifoldrBL f z xs = BL.foldr (\x g i -> i `seq` f i x (g (i + 1))) (const z) xs 0+{-# INLINE ifoldrBL #-}++----------------------------------------++-- | Internal version of 'traversedLazy8'.+traversedLazy8__+ :: Traversing p+ => Optic__ p j (Int64 -> j) BL.ByteString BL.ByteString Char Char+traversedLazy8__ = iwander $ \f lbs ->+ let go c fcs acc =+ let !acc' = acc + fromIntegral (B.length c)+ rest = reindexed (\x -> acc + x) traversedStrictTree8+ in BL.append . BL.fromStrict <$> itraverseOf rest f c <*> fcs acc'+ in BL.foldrChunks go (\_ -> pure BL.empty) lbs 0+{-# INLINE [1] traversedLazy8__ #-}++{-# RULES++"sets lazy char bytestring"+ forall (o :: FunArrow j Char Char). traversedLazy8__ o+ = roam BL8.map (reFunArrow o)+ :: FunArrow (Int64 -> j) BL8.ByteString BL8.ByteString++"isets lazy char bytestring"+ forall (o :: IxFunArrow j Char Char). traversedLazy8__ o = iroam imapBL8 o+ :: IxFunArrow (Int64 -> j) BL8.ByteString BL8.ByteString++"gets lazy char bytestring"+ forall (o :: Forget r j Char Char). traversedLazy8__ o+ = foldring__ BL8.foldr (reForget o)+ :: Forget r (Int64 -> j) BL8.ByteString BL8.ByteString++"igets lazy char bytestring"+ forall (o :: IxForget r j Char Char). traversedLazy8__ o = ifoldring__ ifoldrBL8 o+ :: IxForget r (Int64 -> j) BL.ByteString BL.ByteString++#-}++-- | Indexed setter for 'traversedLazy8__'.+imapBL8 :: (Int64 -> Char -> Char) -> BL8.ByteString -> BL8.ByteString+imapBL8 f = snd . BL8.mapAccumL (\i a -> i `seq` (i + 1, f i a)) 0+{-# INLINE imapBL8 #-}++-- | Indexed fold for 'traversedLazy8__'.+ifoldrBL8 :: (Int64 -> Char -> a -> a) -> a -> BL8.ByteString -> a+ifoldrBL8 f z xs = BL8.foldr (\x g i -> i `seq` f i x (g (i + 1))) (const z) xs 0+{-# INLINE ifoldrBL8 #-}++------------------------------------------------------------------------------+-- ByteString guts+------------------------------------------------------------------------------++-- | Conversion between 'Word8' and 'Char'. Should compile to a no-op.+w2c :: Word8 -> Char+w2c = unsafeChr . fromIntegral+{-# INLINE w2c #-}++-- | Unsafe conversion between 'Char' and 'Word8'. This is a no-op and silently+-- truncates to 8 bits Chars > '\255'. It is provided as convenience for+-- ByteString construction.+c2w :: Char -> Word8+c2w = fromIntegral . ord+{-# INLINE c2w #-}++-- | A way of creating ByteStrings outside the IO monad. The @Int@ argument+-- gives the final size of the ByteString. Unlike 'createAndTrim' the ByteString+-- is not reallocated if the final size is less than the estimated size.+unsafeCreate :: Int -> (Ptr Word8 -> IO ()) -> B.ByteString+unsafeCreate l f = unsafeDupablePerformIO (create l f)+{-# INLINE unsafeCreate #-}++-- | Create ByteString of size @l@ and use action @f@ to fill it's contents.+create :: Int -> (Ptr Word8 -> IO ()) -> IO B.ByteString+create l f = do+ fp <- mallocPlainForeignPtrBytes l+ withForeignPtr fp $ \p -> f p+ return $! BI.PS fp 0 l+{-# INLINE create #-}
+ src/Optics/Extra/Internal/Vector.hs view
@@ -0,0 +1,27 @@+module Optics.Extra.Internal.Vector+ ( ordinalNub+ ) where++import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet++-- | Return the the subset of given ordinals within a given bound and in order+-- of the first occurrence seen.+--+-- Bound: @0 <= x < l@+--+-- >>> ordinalNub 3 [-1,2,1,4,2,3]+-- [2,1]+ordinalNub ::+ Int {- ^ strict upper bound -} ->+ [Int] {- ^ ordinals -} ->+ [Int] {- ^ unique, in-bound ordinals, in order seen -}+ordinalNub l xs = foldr (ordinalNubHelper l) (const []) xs IntSet.empty++ordinalNubHelper :: Int -> Int -> (IntSet -> [Int]) -> (IntSet -> [Int])+ordinalNubHelper l x next seen+ | outOfBounds || notUnique = next seen+ | otherwise = x : next (IntSet.insert x seen)+ where+ outOfBounds = x < 0 || l <= x+ notUnique = x `IntSet.member` seen
+ src/Optics/Extra/Internal/Zoom.hs view
@@ -0,0 +1,252 @@+module Optics.Extra.Internal.Zoom+ (+ -- * Zoom+ Focusing(..)+ , stateZoom+ , stateZoomMaybe+ , stateZoomMany+ , FocusingWith(..)+ , rwsZoom+ , rwsZoomMaybe+ , rwsZoomMany+ , May(..)+ , shuffleMay+ , Err(..)+ , shuffleErr+ -- * Magnify+ , Effect(..)+ , EffectRWS(..)+ , rwsMagnify+ , rwsMagnifyMaybe+ , rwsMagnifyMany+ -- * Misc+ , shuffleS+ , shuffleW+ ) where++import Data.Coerce+import Data.Monoid+import qualified Data.Semigroup as SG++import Optics.Core+import Optics.Internal.Utils++-- | Used by 'Optics.Zoom.Zoom' to 'Optics.Zoom.zoom' into+-- 'Control.Monad.State.StateT'.+newtype Focusing m c s = Focusing { unfocusing :: m (c, s) }++instance Monad m => Functor (Focusing m c) where+ fmap f (Focusing m) = Focusing $ do+ (c, s) <- m+ pure (c, f s)+ {-# INLINE fmap #-}++instance (Monad m, Monoid s) => Applicative (Focusing m s) where+ pure s = Focusing $ pure (mempty, s)+ Focusing mf <*> Focusing ms = Focusing $ do+ (c, f) <- mf+ (c', s) <- ms+ pure (c `mappend` c', f s)+ {-# INLINE pure #-}+ {-# INLINE (<*>) #-}++stateZoom+ :: (Is k A_Lens, Monad m)+ => Optic' k is t s+ -> (s -> m (c, s))+ -> (t -> m (c, t))+stateZoom o m = unfocusing #. toLensVL o (Focusing #. m)+{-# INLINE stateZoom #-}++stateZoomMaybe+ :: (Is k An_AffineTraversal, Monad m)+ => Optic' k is t s+ -> (s -> m (c, s))+ -> (t -> m (Maybe c, t))+stateZoomMaybe o m =+ fmap (coerce :: (First c, t) -> (Maybe c, t))+ . unfocusing+ #. traverseOf (castOptic @An_AffineTraversal o)+ (Focusing #. over (mapped % _1) (First #. Just) . m)+{-# INLINE stateZoomMaybe #-}++stateZoomMany+ :: (Is k A_Traversal, Monad m, Monoid c)+ => Optic' k is t s+ -> (s -> m (c, s))+ -> (t -> m (c, t))+stateZoomMany o m = unfocusing #. traverseOf o (Focusing #. m)+{-# INLINE stateZoomMany #-}++----------------------------------------++-- | Used by 'Optics.Zoom.Zoom' to 'Optics.Zoom.zoom' into+-- 'Control.Monad.RWS.RWST'.+newtype FocusingWith w m c s = FocusingWith { unfocusingWith :: m (c, s, w) }++instance Monad m => Functor (FocusingWith w m s) where+ fmap f (FocusingWith m) = FocusingWith $ do+ (c, s, w) <- m+ pure (c, f s, w)+ {-# INLINE fmap #-}++instance (Monad m, Monoid s, Monoid w) => Applicative (FocusingWith w m s) where+ pure s = FocusingWith $ pure (mempty, s, mempty)+ FocusingWith mf <*> FocusingWith ms = FocusingWith $ do+ (c, f, w) <- mf+ (c', s, w') <- ms+ pure (c `mappend` c', f s, w `mappend` w')+ {-# INLINE pure #-}+ {-# INLINE (<*>) #-}++rwsZoom+ :: (Is k A_Lens, Monad m)+ => Optic' k is t s+ -> (r -> s -> m (c, s, w))+ -> (r -> t -> m (c, t, w))+rwsZoom o m = \r -> unfocusingWith #. toLensVL o (FocusingWith #. m r)+{-# INLINE rwsZoom #-}++rwsZoomMaybe+ :: (Is k An_AffineTraversal, Monad m, Monoid w)+ => Optic' k is t s+ -> (r -> s -> m (c, s, w))+ -> (r -> t -> m (Maybe c, t, w))+rwsZoomMaybe o m = \r ->+ fmap (coerce :: (First c, t, w) -> (Maybe c, t, w))+ . unfocusingWith+ #. traverseOf (castOptic @An_AffineTraversal o)+ (FocusingWith #. over (mapped % _1) (First #. Just) . m r)+{-# INLINE rwsZoomMaybe #-}++rwsZoomMany+ :: (Is k A_Traversal, Monad m, Monoid w, Monoid c)+ => Optic' k is t s+ -> (r -> s -> m (c, s, w))+ -> (r -> t -> m (c, t, w))+rwsZoomMany o m = \r -> unfocusingWith #. traverseOf o (FocusingWith #. m r)+{-# INLINE rwsZoomMany #-}++----------------------------------------++-- | Make a 'Monoid' out of 'Maybe' for error handling.+newtype May a = May { getMay :: Maybe a }++instance SG.Semigroup a => SG.Semigroup (May a) where+ May (Just a) <> May (Just b) = May $ Just (a SG.<> b)+ _ <> _ = May Nothing+ {-# INLINE (<>) #-}++instance Monoid a => Monoid (May a) where+ mempty = May $ Just mempty+ May (Just a) `mappend` May (Just b) = May $ Just (a `mappend` b)+ _ `mappend` _ = May Nothing+ {-# INLINE mempty #-}+ {-# INLINE mappend #-}++shuffleMay :: Maybe (May c) -> May (Maybe c)+shuffleMay = \case+ Nothing -> May (Just Nothing)+ Just (May c) -> May (Just <$> c)+{-# INLINE shuffleMay #-}++----------------------------------------++-- | Make a 'Monoid' out of 'Either' for error handling.+newtype Err e a = Err { getErr :: Either e a }++instance SG.Semigroup a => SG.Semigroup (Err e a) where+ Err (Right a) <> Err (Right b) = Err $ Right (a SG.<> b)+ Err (Left e) <> _ = Err $ Left e+ _ <> Err (Left e) = Err $ Left e+ {-# INLINE (<>) #-}++instance Monoid a => Monoid (Err e a) where+ mempty = Err $ Right mempty+ Err (Right a) `mappend` Err (Right b) = Err $ Right (a `mappend` b)+ Err (Left e) `mappend` _ = Err $ Left e+ _ `mappend` Err (Left e) = Err $ Left e+ {-# INLINE mempty #-}+ {-# INLINE mappend #-}++shuffleErr :: Maybe (Err e c) -> Err e (Maybe c)+shuffleErr = \case+ Nothing -> Err (Right Nothing)+ Just (Err ec) -> Err (Just <$> ec)+{-# INLINE shuffleErr #-}++----------------------------------------++-- | Wrap a monadic effect.+newtype Effect m r = Effect { getEffect :: m r }++instance (Monad m, SG.Semigroup r) => SG.Semigroup (Effect m r) where+ Effect ma <> Effect mb = Effect $ (SG.<>) <$> ma <*> mb+ {-# INLINE (<>) #-}++instance (Monad m, Monoid r) => Monoid (Effect m r) where+ mempty = Effect $ pure mempty+ Effect ma `mappend` Effect mb = Effect $ mappend <$> ma <*> mb+ {-# INLINE mempty #-}+ {-# INLINE mappend #-}++----------------------------------------++-- | Wrap a monadic effect. Used when magnifying 'Control.Monad.RWS.RWST'.+newtype EffectRWS w s m c = EffectRWS { getEffectRWS :: s -> m (c, s, w) }++instance+ (SG.Semigroup c, SG.Semigroup w, Monad m+ ) => SG.Semigroup (EffectRWS w s m c) where+ EffectRWS ma <> EffectRWS mb = EffectRWS $ \s -> do+ (c, s', w) <- ma s+ (c', s'', w') <- mb s'+ pure (c SG.<> c', s'', w SG.<> w')+ {-# INLINE (<>) #-}++instance (Monoid c, Monoid w, Monad m) => Monoid (EffectRWS w s m c) where+ mempty = EffectRWS $ \s -> pure (mempty, s, mempty)+ EffectRWS ma `mappend` EffectRWS mb = EffectRWS $ \s -> do+ (c, s', w) <- ma s+ (c', s'', w') <- mb s'+ pure (c `mappend` c', s'', w `mappend` w')+ {-# INLINE mempty #-}+ {-# INLINE mappend #-}++rwsMagnify+ :: Is k A_Getter+ => Optic' k is a b+ -> (b -> s -> f (c, s, w))+ -> (a -> s -> f (c, s, w))+rwsMagnify o m = getEffectRWS #. views o (EffectRWS #. m)+{-# INLINE rwsMagnify #-}++rwsMagnifyMaybe+ :: (Is k An_AffineFold, Applicative m, Monoid w)+ => Optic' k is a b+ -> (b -> s -> m (c, s, w))+ -> (a -> s -> m (Maybe c, s, w))+rwsMagnifyMaybe o m = \r s -> maybe+ (pure (Nothing, s, mempty))+ (\e -> over (mapped % _1) Just $ getEffectRWS e s)+ (previews o (EffectRWS #. m) r)+{-# INLINE rwsMagnifyMaybe #-}++rwsMagnifyMany+ :: (Is k A_Fold, Monad m, Monoid w, Monoid c)+ => Optic' k is a b+ -> (b -> s -> m (c, s, w))+ -> (a -> s -> m (c, s, w))+rwsMagnifyMany o m = getEffectRWS #. foldMapOf o (EffectRWS #. m)+{-# INLINE rwsMagnifyMany #-}++----------------------------------------+-- Misc++shuffleS :: s -> Maybe (c, s) -> (Maybe c, s)+shuffleS s = maybe (Nothing, s) (over _1 Just)+{-# INLINE shuffleS #-}++shuffleW :: Monoid w => Maybe (c, w) -> (Maybe c, w)+shuffleW = maybe (Nothing, mempty) (over _1 Just)+{-# INLINE shuffleW #-}
+ src/Optics/Indexed.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module: Optics.Indexed+-- Description: Definitions of indexed optics.+--+-- This module defines general functionality for indexed optics. See the+-- "Indexed optics" section of the overview documentation in the @Optics@ module+-- of the main @optics@ package for more details.+--+-- Unlike "Optics.Indexed.Core", this includes the definitions from modules for+-- specific indexed optic flavours such as "Optics.IxTraversal", and includes+-- additional instances for 'FunctorWithIndex' and similar classes.+--+module Optics.Indexed+ (+ -- * Class for optic kinds that can be indexed+ IxOptic(..)++ , conjoined++ -- * Composition of indexed optics+ , (<%>)+ , (%>)+ , (<%)+ , reindexed+ , icompose+ , icompose3+ , icompose4+ , icompose5+ , icomposeN++ -- * Indexed optic flavours+ , module Optics.IxAffineFold+ , module Optics.IxAffineTraversal+ , module Optics.IxFold+ , module Optics.IxGetter+ , module Optics.IxLens+ , module Optics.IxSetter+ , module Optics.IxTraversal++ -- * Functors with index+ , FunctorWithIndex (..)+ -- ** Foldable with index+ , FoldableWithIndex (..)+ , itraverse_+ , ifor_+ -- ** Traversable with index+ , TraversableWithIndex (..)+ , ifor+ ) where++import qualified Data.HashMap.Lazy as HM+import qualified Data.Vector as V++import Optics.Indexed.Core+import Optics.IxAffineFold+import Optics.IxAffineTraversal+import Optics.IxFold+import Optics.IxGetter+import Optics.IxLens+import Optics.IxSetter+import Optics.IxTraversal++----------------------------------------+-- Extra *WithIndex instances++-- HashMap++instance FunctorWithIndex k (HM.HashMap k) where+ imap = HM.mapWithKey+ {-# INLINE imap #-}+instance FoldableWithIndex k (HM.HashMap k) where+ ifoldr = HM.foldrWithKey+ ifoldl' = HM.foldlWithKey' . flip+ {-# INLINE ifoldr #-}+ {-# INLINE ifoldl' #-}+instance TraversableWithIndex k (HM.HashMap k) where+ itraverse = HM.traverseWithKey+ {-# INLINE itraverse #-}++-- Vector++instance FunctorWithIndex Int V.Vector where+ imap = V.imap+ {-# INLINE imap #-}+instance FoldableWithIndex Int V.Vector where+ ifoldMap f = ifoldr (\i -> mappend . f i) mempty+ ifoldr = V.ifoldr+ ifoldl' = V.ifoldl' . flip+ {-# INLINE ifoldMap #-}+ {-# INLINE ifoldr #-}+ {-# INLINE ifoldl' #-}+instance TraversableWithIndex Int V.Vector where+ itraverse f v =+ let !n = V.length v in V.fromListN n <$> itraverse f (V.toList v)+ {-# INLINE itraverse #-}
+ src/Optics/Passthrough.hs view
@@ -0,0 +1,42 @@+module Optics.Passthrough where++import Optics.Internal.Optic+import Optics.AffineTraversal+import Optics.Lens+import Optics.Prism+import Optics.Traversal+import Optics.View++class (Is k A_Traversal, ViewableOptic k r) => PermeableOptic k r where+ -- | Modify the target of an 'Optic' returning extra information of type 'r'.+ passthrough+ :: Optic k is s t a b+ -> (a -> (r, b))+ -> s+ -> (ViewResult k r, t)++instance PermeableOptic An_Iso r where+ passthrough = toLensVL+ {-# INLINE passthrough #-}++instance PermeableOptic A_Lens r where+ passthrough = toLensVL+ {-# INLINE passthrough #-}++instance PermeableOptic A_Prism r where+ passthrough o f s = withPrism o $ \bt sta -> case sta s of+ Left t -> (Nothing, t)+ Right a -> case f a of+ (r, b) -> (Just r, bt b)+ {-# INLINE passthrough #-}++instance PermeableOptic An_AffineTraversal r where+ passthrough o f s = withAffineTraversal o $ \sta sbt -> case sta s of+ Left t -> (Nothing, t)+ Right a -> case f a of+ (r, b) -> (Just r, sbt s b)+ {-# INLINE passthrough #-}++instance Monoid r => PermeableOptic A_Traversal r where+ passthrough = traverseOf+ {-# INLINE passthrough #-}
+ src/Optics/State.hs view
@@ -0,0 +1,84 @@+-- |+-- Module: Optics.State+-- Description: 'Setter' utilities for working with 'MonadState'.+--+-- This module contains utilities for working with 'Setter's in a 'MonadState'+-- context. If you prefer operator versions, you may wish to import+-- "Optics.State.Operators".+--+module Optics.State+ ( modifying+ , modifying'+ , assign+ , assign'+ ) where++import Control.Monad.State++import Optics.Core++-- | Map over the target(s) of an 'Optic' in our monadic state.+--+-- >>> execState (do modifying _1 (*10); modifying _2 $ stimes 5) (6,"o")+-- (60,"ooooo")+--+-- >>> execState (modifying each $ stimes 2) ("a","b")+-- ("aa","bb")+modifying+ :: (Is k A_Setter, MonadState s m)+ => Optic k is s s a b+ -> (a -> b)+ -> m ()+modifying o = modify . over o+{-# INLINE modifying #-}++-- | Version of 'modifying' that is strict in both optic application and state+-- modification.+--+-- >>> flip evalState ('a','b') $ modifying _1 (errorWithoutStackTrace "oops")+-- ()+--+-- >>> flip evalState ('a','b') $ modifying' _1 (errorWithoutStackTrace "oops")+-- *** Exception: oops+modifying'+ :: (Is k A_Setter, MonadState s m)+ => Optic k is s s a b+ -> (a -> b)+ -> m ()+modifying' o = modify' . over' o+{-# INLINE modifying' #-}++-- | Replace the target(s) of an 'Optic' in our monadic state with a new value,+-- irrespective of the old.+--+-- >>> execState (do assign _1 'c'; assign _2 'd') ('a','b')+-- ('c','d')+--+-- >>> execState (assign each 'c') ('a','b')+-- ('c','c')+assign+ :: (Is k A_Setter, MonadState s m)+ => Optic k is s s a b+ -> b+ -> m ()+assign o = modifying o . const+{-# INLINE assign #-}++-- | Version of 'assign' that is strict in both optic application and state+-- modification.+--+-- >>> flip evalState ('a','b') $ assign _1 (errorWithoutStackTrace "oops")+-- ()+--+-- >>> flip evalState ('a','b') $ assign' _1 (errorWithoutStackTrace "oops")+-- *** Exception: oops+assign'+ :: (Is k A_Setter, MonadState s m)+ => Optic k is s s a b+ -> b+ -> m ()+assign' o = modifying' o . const+{-# INLINE assign' #-}++-- $setup+-- >>> import Data.Semigroup
+ src/Optics/State/Operators.hs view
@@ -0,0 +1,155 @@+-- |+-- Module: Optics.State.Operators+-- Description: Infix operators for state-modifying optics.+--+-- Defines infix operators for the operations in "Optics.State". These+-- operators are not exposed by the main @Optics@ module, but must be imported+-- explicitly.+--+module Optics.State.Operators (+ -- * State modifying optics+ (.=), (?=), (%=),+ -- * State modifying optics with passthrough+ (%%=),+ -- * Returning new value+ (<.=), (<?=), (<%=),+ -- * Returning old value+ (<<.=), (<<?=), (<<%=),+ -- * Passthrough+ PermeableOptic (..),+ ) where++import Control.Monad.State (MonadState)+import qualified Control.Monad.State as State++import Optics.Core+import Optics.Passthrough+import Optics.State+import Optics.View++infix 4 .=, ?=, %=++-- | Replace the target(s) of an 'Optic' in our monadic state with a new value,+-- irrespective of the old.+--+-- This is an infix version of 'assign'.+(.=)+ :: (Is k A_Setter, MonadState s m)+ => Optic k is s s a b+ -> b+ -> m ()+(.=) = assign+{-# INLINE (.=) #-}++-- | Replace the target(s) of an 'Optic' in our monadic state with 'Just' a new+-- value, irrespective of the old.+(?=)+ :: (Is k A_Setter, MonadState s m)+ => Optic k is s s (Maybe a) (Maybe b)+ -> b+ -> m ()+(?=) = \o -> assign o . Just+{-# INLINE (?=) #-}++-- | Map over the target(s) of an 'Optic' in our monadic state.+--+-- This is an infix version of 'modifying'.+(%=)+ :: (Is k A_Setter, MonadState s m)+ => Optic k is s s a b+ -> (a -> b)+ -> m ()+(%=) = modifying+{-# INLINE (%=) #-}++-------------------------------------------------------------------------------+-- Extra stuff+-------------------------------------------------------------------------------++-- | Modify the target of an 'PermeableOptic' in the current state returning+-- some extra information of type depending on the optic (@r@, @Maybe r@ or+-- monoidal summary).+infix 4 %%=+(%%=)+ :: (PermeableOptic k r, MonadState s m)+ => Optic k is s s a b+ -> (a -> (r, b))+ -> m (ViewResult k r)+o %%= f = State.state (passthrough o f)+{-# INLINE (%%=) #-}++-------------------------------------------------------------------------------+-- Returning new value+-------------------------------------------------------------------------------++infix 4 <.=, <?=, <%=++-- | Modify the target of a 'PermeableOptic' into your 'Monad''s state by a user+-- supplied function and return the result.+(<%=)+ :: (PermeableOptic k b, MonadState s m)+ => Optic k is s s a b+ -> (a -> b)+ -> m (ViewResult k b)+o <%= f = o %%= \a -> let b = f a in (b, b)+{-# INLINE (<%=) #-}++-- | Set 'Just' a value with pass-through.+--+-- This is useful for chaining assignment without round-tripping through your+-- 'Monad' stack.+(<?=)+ :: (PermeableOptic k (Maybe b), MonadState s m)+ => Optic k is s s (Maybe a) (Maybe b)+ -> b+ -> m (ViewResult k (Maybe b))+o <?= b = o <.= Just b+{-# INLINE (<?=) #-}++-- | Set with pass-through.+--+-- This is useful for chaining assignment without round-tripping through your+-- 'Monad' stack.+(<.=)+ :: (PermeableOptic k b, MonadState s m)+ => Optic k is s s a b+ -> b+ -> m (ViewResult k b)+o <.= b = o <%= const b+{-# INLINE (<.=) #-}++-------------------------------------------------------------------------------+-- Returning old value+-------------------------------------------------------------------------------++infix 4 <<.=, <<?=, <<%=++-- | Modify the target of a 'PermeableOptic' into your 'Monad''s state by a user+-- supplied function and return the /old/ value that was replaced.+(<<%=)+ :: (PermeableOptic k a, MonadState s m)+ => Optic k is s s a b+ -> (a -> b)+ -> m (ViewResult k a)+o <<%= f = o %%= \a -> (a, f a)+{-# INLINE (<<%=) #-}++-- | Replace the target of a 'PermeableOptic' into your 'Monad''s state with+-- 'Just' a user supplied value and return the /old/ value that was replaced.+(<<?=)+ :: (PermeableOptic k (Maybe a), MonadState s m)+ => Optic k is s s (Maybe a) (Maybe b)+ -> b+ -> m (ViewResult k (Maybe a))+o <<?= b = o <<.= Just b+{-# INLINE (<<?=) #-}++-- | Replace the target of a 'PermeableOptic' into your 'Monad''s state with a+-- user supplied value and return the /old/ value that was replaced.+(<<.=)+ :: (PermeableOptic k a, MonadState s m)+ => Optic k is s s a b+ -> b+ -> m (ViewResult k a)+o <<.= b = o <<%= const b+{-# INLINE (<<.=) #-}
+ src/Optics/View.hs view
@@ -0,0 +1,158 @@+-- | EXPERIMENTAL+module Optics.View where++import Control.Monad.Reader.Class+import Control.Monad.State+import Control.Monad.Writer++import Optics.Core++-- | Generalized view (even more powerful than @view@ from the lens library).+--+-- View the value(s) pointed to by an optic.+--+-- The type of the result depends on the optic. You get:+--+-- * Exactly one result @a@ with 'Iso', 'Lens', 'ReversedPrism' and+-- 'Getter'.+--+-- * At most one result @Maybe a@ with 'Prism', 'AffineTraversal' and+-- 'AffineFold'.+--+-- * Monoidal summary of all results @Monoid a => a@ with 'Traversal'+-- and 'Fold'.+--+-- When in doubt, use specific, flavour restricted versions. This function is+-- mostly useful for things such as 'Optics.Passthrough.passthrough'.+--+class ViewableOptic k r where+ type ViewResult k r :: *+ gview+ :: MonadReader s m+ => Optic' k is s r+ -> m (ViewResult k r)+ gviews+ :: MonadReader s m+ => Optic' k is s a+ -> (a -> r)+ -> m (ViewResult k r)++instance ViewableOptic An_Iso r where+ type ViewResult An_Iso r = r+ gview = asks . view+ gviews o = asks . views o+ {-# INLINE gview #-}+ {-# INLINE gviews #-}++instance ViewableOptic A_Lens r where+ type ViewResult A_Lens r = r+ gview = asks . view+ gviews o = asks . views o+ {-# INLINE gview #-}+ {-# INLINE gviews #-}++instance ViewableOptic A_ReversedPrism r where+ type ViewResult A_ReversedPrism r = r+ gview = asks . view+ gviews o = asks . views o+ {-# INLINE gview #-}+ {-# INLINE gviews #-}++instance ViewableOptic A_Getter r where+ type ViewResult A_Getter r = r+ gview = asks . view+ gviews o = asks . views o+ {-# INLINE gview #-}+ {-# INLINE gviews #-}++instance ViewableOptic A_Prism r where+ type ViewResult A_Prism r = Maybe r+ gview = asks . preview+ gviews o = asks . previews o+ {-# INLINE gview #-}+ {-# INLINE gviews #-}++instance ViewableOptic An_AffineTraversal r where+ type ViewResult An_AffineTraversal r = Maybe r+ gview = asks . preview+ gviews o = asks . previews o+ {-# INLINE gview #-}+ {-# INLINE gviews #-}++instance ViewableOptic An_AffineFold r where+ type ViewResult An_AffineFold r = Maybe r+ gview = asks . preview+ gviews o = asks . previews o+ {-# INLINE gview #-}+ {-# INLINE gviews #-}++instance Monoid r => ViewableOptic A_Traversal r where+ type ViewResult A_Traversal r = r+ gview = asks . foldOf+ gviews o = asks . foldMapOf o+ {-# INLINE gview #-}+ {-# INLINE gviews #-}++instance Monoid r => ViewableOptic A_Fold r where+ type ViewResult A_Fold r = r+ gview = asks . foldOf+ gviews o = asks . foldMapOf o+ {-# INLINE gview #-}+ {-# INLINE gviews #-}++-- | Use the target of a 'Lens', 'Iso', or 'Getter' in the current state, or use+-- a summary of a 'Fold' or 'Traversal' that points to a monoidal value.+--+-- >>> evalState (use _1) ('a','b')+-- 'a'+--+-- >>> evalState (use _2) ("hello","world")+-- "world"+use+ :: (ViewableOptic k a, MonadState s m)+ => Optic' k is s a+ -> m (ViewResult k a)+use o = gets (gview o)+{-# INLINE use #-}++-- | Use the target of a 'Lens', 'Iso' or 'Getter' in the current state, or use+-- a summary of a 'Fold' or 'Traversal' that points to a monoidal value.+--+-- >>> evalState (uses _1 length) ("hello","world")+-- 5+uses+ :: (ViewableOptic k r, MonadState s m)+ => Optic' k is s a+ -> (a -> r)+ -> m (ViewResult k r)+uses o f = gets (gviews o f)+{-# INLINE uses #-}++-- | This is a generalized form of 'listen' that only extracts the portion of+-- the log that is focused on by a 'Getter'. If given a 'Fold' or a 'Traversal'+-- then a monoidal summary of the parts of the log that are visited will be+-- returned.+listening+ :: (ViewableOptic k r, MonadWriter s m)+ => Optic' k is s r+ -> m a+ -> m (a, ViewResult k r)+listening o m = do+ (a, w) <- listen m+ return (a, gview o w)+{-# INLINE listening #-}++-- | This is a generalized form of 'listen' that only extracts the portion of+-- the log that is focused on by a 'Getter'. If given a 'Fold' or a 'Traversal'+-- then a monoidal summary of the parts of the log that are visited will be+-- returned.+listenings+ :: (ViewableOptic k r, MonadWriter s m)+ => Optic' k is s a+ -> (a -> r)+ -> m b+ -> m (b, ViewResult k r)+listenings o f m = do+ (a, w) <- listen m+ return (a, gviews o f w)+{-# INLINE listenings #-}
+ src/Optics/Zoom.hs view
@@ -0,0 +1,411 @@+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}+module Optics.Zoom+ (+ -- * Zoom+ Zoom(..)+ -- * Magnify+ , Magnify(..)+ , MagnifyMany(..)+ ) where++import Control.Monad.Reader as Reader+import Control.Monad.State+import Control.Monad.Trans.Error+import Control.Monad.Trans.Except+import Control.Monad.Trans.Identity+import Control.Monad.Trans.List+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.RWS.Lazy as L+import Control.Monad.Trans.RWS.Strict as S+import Control.Monad.Trans.State.Lazy as L+import Control.Monad.Trans.State.Strict as S+import Control.Monad.Trans.Writer.Lazy as L+import Control.Monad.Trans.Writer.Strict as S++import Optics.Core+import Optics.Internal.Utils+import Optics.Extra.Internal.Zoom++-- Chosen so that they have lower fixity than ('%=').+infixr 2 `zoom`, `zoomMaybe`, `zoomMany`+infixr 2 `magnify`, `magnifyMaybe`, `magnifyMany`++------------------------------------------------------------------------------+-- Zoom+------------------------------------------------------------------------------++-- | This class allows us to 'zoom' in, changing the 'State' supplied by many+-- different monad transformers, potentially quite deep in a monad transformer+-- stack.+--+-- Its functions can be used to run a monadic action in a larger 'State' than it+-- was defined in, using a 'Lens'', an 'AffineTraversal'' or a 'Traversal''.+--+-- This is commonly used to lift actions in a simpler 'State' 'Monad' into a+-- 'State' 'Monad' with a larger 'State' type.+--+-- When used with a 'Traversal'' over multiple values, the actions for each+-- target are executed sequentially and the results are aggregated.+--+-- This can be used to edit pretty much any 'Monad' transformer stack with a+-- 'State' in it!+--+-- >>> flip L.evalState ('a','b') $ zoom _1 $ use equality+-- 'a'+--+-- >>> flip S.execState ('a','b') $ zoom _1 $ equality .= 'c'+-- ('c','b')+--+-- >>> flip L.execState [(1,2),(3,4)] $ zoomMany traversed $ _2 %= (*10)+-- [(1,20),(3,40)]+--+-- >>> flip S.runState [('a',"b"),('c',"d")] $ zoomMany traversed $ _2 <%= (\x -> x <> x)+-- ("bbdd",[('a',"bb"),('c',"dd")])+--+-- >>> flip S.evalState ("a","b") $ zoomMany each (use equality)+-- "ab"+--+class+ (MonadState s m, MonadState t n+ ) => Zoom m n s t | m -> s, n -> t, m t -> n, n s -> m where+ zoom+ :: Is k A_Lens+ => Optic' k is t s+ -> m c+ -> n c++ zoomMaybe+ :: Is k An_AffineTraversal+ => Optic' k is t s+ -> m c+ -> n (Maybe c)++ zoomMany+ :: (Is k A_Traversal, Monoid c)+ => Optic' k is t s+ -> m c+ -> n c++instance Monad m => Zoom (S.StateT s m) (S.StateT t m) s t where+ zoom o = \(S.StateT m) -> S.StateT $ stateZoom o m+ zoomMaybe o = \(S.StateT m) -> S.StateT $ stateZoomMaybe o m+ zoomMany o = \(S.StateT m) -> S.StateT $ stateZoomMany o m+ {-# INLINE zoom #-}+ {-# INLINE zoomMaybe #-}+ {-# INLINE zoomMany #-}++instance Monad m => Zoom (L.StateT s m) (L.StateT t m) s t where+ zoom o = \(L.StateT m) -> L.StateT $ stateZoom o m+ zoomMaybe o = \(L.StateT m) -> L.StateT $ stateZoomMaybe o m+ zoomMany o = \(L.StateT m) -> L.StateT $ stateZoomMany o m+ {-# INLINE zoom #-}+ {-# INLINE zoomMaybe #-}+ {-# INLINE zoomMany #-}++instance Zoom m n s t => Zoom (ReaderT e m) (ReaderT e n) s t where+ zoom o = \(ReaderT m) -> ReaderT (zoom o . m)+ zoomMaybe o = \(ReaderT m) -> ReaderT (zoomMaybe o . m)+ zoomMany o = \(ReaderT m) -> ReaderT (zoomMany o . m)+ {-# INLINE zoom #-}+ {-# INLINE zoomMaybe #-}+ {-# INLINE zoomMany #-}++instance Zoom m n s t => Zoom (IdentityT m) (IdentityT n) s t where+ zoom o = \(IdentityT m) -> IdentityT (zoom o m)+ zoomMaybe o = \(IdentityT m) -> IdentityT (zoomMaybe o m)+ zoomMany o = \(IdentityT m) -> IdentityT (zoomMany o m)+ {-# INLINE zoom #-}+ {-# INLINE zoomMaybe #-}+ {-# INLINE zoomMany #-}++instance (Monoid w, Monad m) => Zoom (S.RWST r w s m) (S.RWST r w t m) s t where+ zoom o = \(S.RWST m) -> S.RWST $ rwsZoom o m+ zoomMaybe o = \(S.RWST m) -> S.RWST $ rwsZoomMaybe o m+ zoomMany o = \(S.RWST m) -> S.RWST $ rwsZoomMany o m+ {-# INLINE zoom #-}+ {-# INLINE zoomMaybe #-}+ {-# INLINE zoomMany #-}++instance (Monoid w, Monad m) => Zoom (L.RWST r w s m) (L.RWST r w t m) s t where+ zoom o = \(L.RWST m) -> L.RWST $ rwsZoom o m+ zoomMaybe o = \(L.RWST m) -> L.RWST $ rwsZoomMaybe o m+ zoomMany o = \(L.RWST m) -> L.RWST $ rwsZoomMany o m+ {-# INLINE zoom #-}+ {-# INLINE zoomMaybe #-}+ {-# INLINE zoomMany #-}++instance (Monoid w, Zoom m n s t) => Zoom (S.WriterT w m) (S.WriterT w n) s t where+ zoom o = S.WriterT #. zoom o .# S.runWriterT+ zoomMaybe o = S.WriterT #. fmap shuffleW . zoomMaybe o .# S.runWriterT+ zoomMany o = S.WriterT #. zoomMany o .# S.runWriterT+ {-# INLINE zoom #-}+ {-# INLINE zoomMaybe #-}+ {-# INLINE zoomMany #-}++instance (Monoid w, Zoom m n s t) => Zoom (L.WriterT w m) (L.WriterT w n) s t where+ zoom o = L.WriterT #. zoom o .# L.runWriterT+ zoomMaybe o = L.WriterT #. fmap shuffleW . zoomMaybe o .# L.runWriterT+ zoomMany o = L.WriterT #. zoomMany o .# L.runWriterT+ {-# INLINE zoom #-}+ {-# INLINE zoomMaybe #-}+ {-# INLINE zoomMany #-}++instance Zoom m n s t => Zoom (ListT m) (ListT n) s t where+ zoom o = ListT #. zoom o .# runListT+ zoomMaybe o = ListT #. fmap sequenceA . zoomMaybe o .# runListT+ zoomMany o = ListT #. zoomMany o .# runListT+ {-# INLINE zoom #-}+ {-# INLINE zoomMaybe #-}+ {-# INLINE zoomMany #-}++instance Zoom m n s t => Zoom (MaybeT m) (MaybeT n) s t where+ zoom o =+ MaybeT #. zoom o .# runMaybeT+ zoomMaybe o =+ MaybeT #. fmap (getMay . shuffleMay) . zoomMaybe o . fmap May .# runMaybeT+ zoomMany o =+ MaybeT #. fmap getMay . zoomMany o . fmap May .# runMaybeT+ {-# INLINE zoom #-}+ {-# INLINE zoomMaybe #-}+ {-# INLINE zoomMany #-}++instance (Error e, Zoom m n s t) => Zoom (ErrorT e m) (ErrorT e n) s t where+ zoom o =+ ErrorT #. zoom o .# runErrorT+ zoomMaybe o =+ ErrorT #. fmap (getErr . shuffleErr) . zoomMaybe o . fmap Err .# runErrorT+ zoomMany o =+ ErrorT #. fmap getErr . zoomMany o . fmap Err .# runErrorT+ {-# INLINE zoom #-}+ {-# INLINE zoomMaybe #-}+ {-# INLINE zoomMany #-}++instance Zoom m n s t => Zoom (ExceptT e m) (ExceptT e n) s t where+ zoom o =+ ExceptT #. zoom o .# runExceptT+ zoomMaybe o =+ ExceptT #. fmap (getErr . shuffleErr) . zoomMaybe o . fmap Err .# runExceptT+ zoomMany o =+ ExceptT #. fmap getErr . zoomMany o . fmap Err .# runExceptT+ {-# INLINE zoom #-}+ {-# INLINE zoomMaybe #-}+ {-# INLINE zoomMany #-}++------------------------------------------------------------------------------+-- Magnify+------------------------------------------------------------------------------++-- | This class allows us to 'magnify' part of the environment, changing the+-- environment supplied by many different 'Monad' transformers. Unlike 'zoom'+-- this can change the environment of a deeply nested 'Monad' transformer.+--+-- Its functions can be used to run a monadic action in a larger environment+-- than it was defined in, using a 'Getter' or an 'AffineFold'.+--+-- They act like 'Control.Monad.Reader.Class.local', but can in many cases+-- change the type of the environment as well.+--+-- They're commonly used to lift actions in a simpler 'Reader' 'Monad' into a+-- 'Monad' with a larger environment type.+--+-- They can be used to edit pretty much any 'Monad' transformer stack with an+-- environment in it:+--+-- >>> (1,2) & magnify _2 (+1)+-- 3+--+-- >>> flip runReader (1,2) $ magnify _1 Reader.ask+-- 1+--+-- >>> flip runReader (1,2,[10..20]) $ magnifyMaybe (_3 % _tail) Reader.ask+-- Just [11,12,13,14,15,16,17,18,19,20]+--+class+ (MonadReader b m, MonadReader a n+ ) => Magnify m n b a | m -> b, n -> a, m a -> n, n b -> m where+ magnify+ :: Is k A_Getter+ => Optic' k is a b+ -> m c+ -> n c++ magnifyMaybe+ :: Is k An_AffineFold+ => Optic' k is a b+ -> m c+ -> n (Maybe c)++-- | Extends 'Magnify' with an ability to magnify using a 'Fold' over multiple+-- targets so that actions for each one are executed sequentially and the+-- results are aggregated.+--+-- There is however no sensible instance of 'MagnifyMany' for 'StateT'.+class+ (MonadReader b m, MonadReader a n, Magnify m n b a+ ) => MagnifyMany m n b a | m -> b, n -> a, m a -> n, n b -> m where+ magnifyMany+ :: (Is k A_Fold, Monoid c)+ => Optic' k is a b+ -> m c+ -> n c++-- | @+-- 'magnify' = 'views'+-- 'magnifyMaybe' = 'previews'+-- @+instance Magnify ((->) b) ((->) a) b a where+ magnify = views+ magnifyMaybe = previews+ {-# INLINE magnify #-}+ {-# INLINE magnifyMaybe #-}++-- | @+-- 'magnifyMany' = 'foldMapOf'+-- @+instance MagnifyMany ((->) b) ((->) a) b a where+ magnifyMany = foldMapOf+ {-# INLINE magnifyMany #-}++instance Monad m => Magnify (ReaderT b m) (ReaderT a m) b a where+ magnify o = \(ReaderT m) ->+ ReaderT $ \r -> getEffect (views o (Effect #. m) r)+ magnifyMaybe o = \(ReaderT m) ->+ ReaderT $ \r -> traverse getEffect (previews o (Effect #. m) r)+ {-# INLINE magnify #-}+ {-# INLINE magnifyMaybe #-}++instance Monad m => MagnifyMany (ReaderT b m) (ReaderT a m) b a where+ magnifyMany o = \(ReaderT m) ->+ ReaderT $ \r -> getEffect (foldMapOf o (Effect #. m) r)+ {-# INLINE magnifyMany #-}++instance (Monad m, Monoid w) => Magnify (S.RWST b w s m) (S.RWST a w s m) b a where+ magnify o = \(S.RWST m) -> S.RWST $ rwsMagnify o m+ magnifyMaybe o = \(S.RWST m) -> S.RWST $ rwsMagnifyMaybe o m+ {-# INLINE magnify #-}+ {-# INLINE magnifyMaybe #-}++instance+ (Monad m, Monoid w+ ) => MagnifyMany (S.RWST b w s m) (S.RWST a w s m) b a where+ magnifyMany o = \(S.RWST m) -> S.RWST $ rwsMagnifyMany o m+ {-# INLINE magnifyMany #-}++instance (Monad m, Monoid w) => Magnify (L.RWST b w s m) (L.RWST a w s m) b a where+ magnify o = \(L.RWST m) -> L.RWST $ rwsMagnify o m+ magnifyMaybe o = \(L.RWST m) -> L.RWST $ rwsMagnifyMaybe o m+ {-# INLINE magnify #-}+ {-# INLINE magnifyMaybe #-}++instance+ (Monad m, Monoid w+ ) => MagnifyMany (L.RWST b w s m) (L.RWST a w s m) b a where+ magnifyMany o = \(L.RWST m) -> L.RWST $ rwsMagnifyMany o m+ {-# INLINE magnifyMany #-}++instance Magnify m n b a => Magnify (IdentityT m) (IdentityT n) b a where+ magnify o = \(IdentityT m) -> IdentityT (magnify o m)+ magnifyMaybe o = \(IdentityT m) -> IdentityT (magnifyMaybe o m)+ {-# INLINE magnify #-}+ {-# INLINE magnifyMaybe #-}++instance MagnifyMany m n b a => MagnifyMany (IdentityT m) (IdentityT n) b a where+ magnifyMany o = \(IdentityT m) -> IdentityT (magnifyMany o m)+ {-# INLINE magnifyMany #-}++instance Magnify m n b a => Magnify (S.StateT s m) (S.StateT s n) b a where+ magnify o = \(S.StateT m) -> S.StateT $ magnify o . m+ magnifyMaybe o = \(S.StateT m) -> S.StateT $ \s ->+ fmap (shuffleS s) $ magnifyMaybe o (m s)+ {-# INLINE magnify #-}+ {-# INLINE magnifyMaybe #-}++-- No instance for MagnifyMany (S.StateT s m) (S.StateT s n) b a++instance Magnify m n b a => Magnify (L.StateT s m) (L.StateT s n) b a where+ magnify o = \(L.StateT m) -> L.StateT $ magnify o . m+ magnifyMaybe o = \(L.StateT m) -> L.StateT $ \s ->+ fmap (shuffleS s) $ magnifyMaybe o (m s)+ {-# INLINE magnify #-}+ {-# INLINE magnifyMaybe #-}++-- No instance for MagnifyMany (L.StateT s m) (L.StateT s n) b a++instance+ (Monoid w, Magnify m n b a+ ) => Magnify (S.WriterT w m) (S.WriterT w n) b a where+ magnify o = S.WriterT #. magnify o .# S.runWriterT+ magnifyMaybe o = S.WriterT #. fmap shuffleW . magnifyMaybe o .# S.runWriterT+ {-# INLINE magnify #-}+ {-# INLINE magnifyMaybe #-}++instance+ (Monoid w, MagnifyMany m n b a+ ) => MagnifyMany (S.WriterT w m) (S.WriterT w n) b a where+ magnifyMany o = S.WriterT #. magnifyMany o .# S.runWriterT+ {-# INLINE magnifyMany #-}++instance+ (Monoid w, Magnify m n b a+ ) => Magnify (L.WriterT w m) (L.WriterT w n) b a where+ magnify o = L.WriterT #. magnify o .# L.runWriterT+ magnifyMaybe o = L.WriterT #. fmap shuffleW . magnifyMaybe o .# L.runWriterT+ {-# INLINE magnify #-}+ {-# INLINE magnifyMaybe #-}++instance+ (Monoid w, MagnifyMany m n b a+ ) => MagnifyMany (L.WriterT w m) (L.WriterT w n) b a where+ magnifyMany o = L.WriterT #. magnifyMany o .# L.runWriterT+ {-# INLINE magnifyMany #-}++instance Magnify m n b a => Magnify (ListT m) (ListT n) b a where+ magnify o = ListT #. magnify o .# runListT+ magnifyMaybe o = ListT #. fmap sequenceA . magnifyMaybe o .# runListT+ {-# INLINE magnify #-}+ {-# INLINE magnifyMaybe #-}++instance MagnifyMany m n b a => MagnifyMany (ListT m) (ListT n) b a where+ magnifyMany o = ListT #. magnifyMany o .# runListT+ {-# INLINE magnifyMany #-}++instance Magnify m n b a => Magnify (MaybeT m) (MaybeT n) b a where+ magnify o = MaybeT #. magnify o .# runMaybeT+ magnifyMaybe o =+ MaybeT #. fmap (getMay . shuffleMay) . magnifyMaybe o . fmap May .# runMaybeT+ {-# INLINE magnify #-}+ {-# INLINE magnifyMaybe #-}++instance MagnifyMany m n b a => MagnifyMany (MaybeT m) (MaybeT n) b a where+ magnifyMany o = MaybeT #. fmap getMay . magnifyMany o . fmap May .# runMaybeT+ {-# INLINE magnifyMany #-}++instance (Error e, Magnify m n b a) => Magnify (ErrorT e m) (ErrorT e n) b a where+ magnify o = ErrorT #. magnify o .# runErrorT+ magnifyMaybe o =+ ErrorT #. fmap (getErr . shuffleErr) . magnifyMaybe o . fmap Err .# runErrorT+ {-# INLINE magnify #-}+ {-# INLINE magnifyMaybe #-}++instance+ (Error e, MagnifyMany m n b a+ ) => MagnifyMany (ErrorT e m) (ErrorT e n) b a where+ magnifyMany o = ErrorT #. fmap getErr . magnifyMany o . fmap Err .# runErrorT+ {-# INLINE magnifyMany #-}++instance Magnify m n b a => Magnify (ExceptT e m) (ExceptT e n) b a where+ magnify o = ExceptT #. magnify o .# runExceptT+ magnifyMaybe o =+ ExceptT #. fmap (getErr . shuffleErr) . magnifyMaybe o . fmap Err .# runExceptT+ {-# INLINE magnify #-}+ {-# INLINE magnifyMaybe #-}++instance MagnifyMany m n b a => MagnifyMany (ExceptT e m) (ExceptT e n) b a where+ magnifyMany o = ExceptT #. fmap getErr . magnifyMany o . fmap Err .# runExceptT+ {-# INLINE magnifyMany #-}++-- $setup+-- >>> import Data.Monoid+-- >>> import Optics.State.Operators+-- >>> import Optics.View