diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/optics-extra.cabal b/optics-extra.cabal new file mode 100644 --- /dev/null +++ b/optics-extra.cabal @@ -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 diff --git a/src/Data/ByteString/Lazy/Optics.hs b/src/Data/ByteString/Lazy/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Lazy/Optics.hs @@ -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 diff --git a/src/Data/ByteString/Optics.hs b/src/Data/ByteString/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Optics.hs @@ -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 #-} diff --git a/src/Data/ByteString/Strict/Optics.hs b/src/Data/ByteString/Strict/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Strict/Optics.hs @@ -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 diff --git a/src/Data/HashMap/Optics.hs b/src/Data/HashMap/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashMap/Optics.hs @@ -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 () diff --git a/src/Data/HashSet/Optics.hs b/src/Data/HashSet/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashSet/Optics.hs @@ -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 diff --git a/src/Data/Text/Lazy/Optics.hs b/src/Data/Text/Lazy/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Lazy/Optics.hs @@ -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 #-} diff --git a/src/Data/Text/Optics.hs b/src/Data/Text/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Optics.hs @@ -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 #-} diff --git a/src/Data/Text/Strict/Optics.hs b/src/Data/Text/Strict/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Strict/Optics.hs @@ -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 #-} diff --git a/src/Data/Vector/Generic/Optics.hs b/src/Data/Vector/Generic/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vector/Generic/Optics.hs @@ -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 diff --git a/src/Data/Vector/Optics.hs b/src/Data/Vector/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vector/Optics.hs @@ -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 #-} diff --git a/src/Optics/At.hs b/src/Optics/At.hs new file mode 100644 --- /dev/null +++ b/src/Optics/At.hs @@ -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 diff --git a/src/Optics/Cons.hs b/src/Optics/Cons.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Cons.hs @@ -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 #-} diff --git a/src/Optics/Each.hs b/src/Optics/Each.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Each.hs @@ -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 #-} diff --git a/src/Optics/Empty.hs b/src/Optics/Empty.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Empty.hs @@ -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 #-} diff --git a/src/Optics/Extra.hs b/src/Optics/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Extra.hs @@ -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 diff --git a/src/Optics/Extra/Internal/ByteString.hs b/src/Optics/Extra/Internal/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Extra/Internal/ByteString.hs @@ -0,0 +1,298 @@ +-- | This module spends a lot of time fiddling around with 'Data.ByteString' +-- internals to work around 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 #-} diff --git a/src/Optics/Extra/Internal/Vector.hs b/src/Optics/Extra/Internal/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Extra/Internal/Vector.hs @@ -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 diff --git a/src/Optics/Extra/Internal/Zoom.hs b/src/Optics/Extra/Internal/Zoom.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Extra/Internal/Zoom.hs @@ -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 #-} diff --git a/src/Optics/Indexed.hs b/src/Optics/Indexed.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Indexed.hs @@ -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 #-} diff --git a/src/Optics/Passthrough.hs b/src/Optics/Passthrough.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Passthrough.hs @@ -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 #-} diff --git a/src/Optics/State.hs b/src/Optics/State.hs new file mode 100644 --- /dev/null +++ b/src/Optics/State.hs @@ -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 diff --git a/src/Optics/State/Operators.hs b/src/Optics/State/Operators.hs new file mode 100644 --- /dev/null +++ b/src/Optics/State/Operators.hs @@ -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 + (<.=), ( 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 <.=, 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. +( Optic k is s s (Maybe a) (Maybe b) + -> b + -> m (ViewResult k (Maybe b)) +o Optic k is s s a b + -> b + -> m (ViewResult k b) +o <.= b = o <%= const b +{-# INLINE (<.=) #-} + +------------------------------------------------------------------------------- +-- Returning old value +------------------------------------------------------------------------------- + +infix 4 <<.=, < 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. +(< Optic k is s s (Maybe a) (Maybe b) + -> b + -> m (ViewResult k (Maybe a)) +o < Optic k is s s a b + -> b + -> m (ViewResult k a) +o <<.= b = o <<%= const b +{-# INLINE (<<.=) #-} diff --git a/src/Optics/View.hs b/src/Optics/View.hs new file mode 100644 --- /dev/null +++ b/src/Optics/View.hs @@ -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 #-} diff --git a/src/Optics/Zoom.hs b/src/Optics/Zoom.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Zoom.hs @@ -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