diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,97 @@ +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. + + +This software incorporates code from the profunctors package (available from +https://hackage.haskell.org/package/profunctors) under the following license: + +Copyright 2011-2015 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. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +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/diagrams/AffineFold.png b/diagrams/AffineFold.png new file mode 100644 Binary files /dev/null and b/diagrams/AffineFold.png differ diff --git a/diagrams/AffineTraversal.png b/diagrams/AffineTraversal.png new file mode 100644 Binary files /dev/null and b/diagrams/AffineTraversal.png differ diff --git a/diagrams/Fold.png b/diagrams/Fold.png new file mode 100644 Binary files /dev/null and b/diagrams/Fold.png differ diff --git a/diagrams/Getter.png b/diagrams/Getter.png new file mode 100644 Binary files /dev/null and b/diagrams/Getter.png differ diff --git a/diagrams/Iso.png b/diagrams/Iso.png new file mode 100644 Binary files /dev/null and b/diagrams/Iso.png differ diff --git a/diagrams/Lens.png b/diagrams/Lens.png new file mode 100644 Binary files /dev/null and b/diagrams/Lens.png differ diff --git a/diagrams/Prism.png b/diagrams/Prism.png new file mode 100644 Binary files /dev/null and b/diagrams/Prism.png differ diff --git a/diagrams/ReversedLens.png b/diagrams/ReversedLens.png new file mode 100644 Binary files /dev/null and b/diagrams/ReversedLens.png differ diff --git a/diagrams/ReversedPrism.png b/diagrams/ReversedPrism.png new file mode 100644 Binary files /dev/null and b/diagrams/ReversedPrism.png differ diff --git a/diagrams/Review.png b/diagrams/Review.png new file mode 100644 Binary files /dev/null and b/diagrams/Review.png differ diff --git a/diagrams/Setter.png b/diagrams/Setter.png new file mode 100644 Binary files /dev/null and b/diagrams/Setter.png differ diff --git a/diagrams/Traversal.png b/diagrams/Traversal.png new file mode 100644 Binary files /dev/null and b/diagrams/Traversal.png differ diff --git a/diagrams/reoptics.png b/diagrams/reoptics.png new file mode 100644 Binary files /dev/null and b/diagrams/reoptics.png differ diff --git a/optics-core.cabal b/optics-core.cabal new file mode 100644 --- /dev/null +++ b/optics-core.cabal @@ -0,0 +1,126 @@ +name: optics-core +version: 0.1 +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: 1.24 +maintainer: optics@well-typed.com +author: Adam Gundry, Andres Löh, Andrzej Rybczak, Oleg Grenrus +tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1, GHCJS ==8.4 +synopsis: Optics as an abstract interface: core definitions +category: Data, Optics, Lenses +description: + This package makes it possible to define and use Lenses, Traversals, Prisms + and other optics, using an abstract interface. + . + This variant provides core definitions with a minimal dependency footprint. + See the @optics@ package (and its dependencies) for documentation and the + "batteries-included" variant. + +extra-doc-files: + diagrams/*.png + +bug-reports: https://github.com/well-typed/optics/issues +source-repository head + type: git + location: https://github.com/well-typed/optics.git + subdir: optics-core + +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall + + build-depends: base >= 4.9 && <5 + , array >= 0.5.1.1 && <0.6 + , containers >= 0.5.7.1 && <0.7 + , transformers >= 0.5 && <0.6 + + exposed-modules: Optics.Core + + -- main optic type + Optics.Optic + + -- optic kinds + Optics.AffineFold + Optics.AffineTraversal + Optics.Fold + Optics.Getter + Optics.Iso + Optics.IxAffineFold + Optics.IxAffineTraversal + Optics.IxFold + Optics.IxGetter + Optics.IxLens + Optics.IxSetter + Optics.IxTraversal + Optics.Lens + Optics.Prism + Optics.ReversedLens + Optics.ReversedPrism + Optics.Review + Optics.Setter + Optics.Traversal + + -- optic utilities + Optics.Arrow + Optics.At.Core + Optics.Coerce + Optics.Cons.Core + Optics.Each.Core + Optics.Empty.Core + Optics.Indexed.Core + Optics.Label + Optics.Operators + Optics.Re + Optics.ReadOnly + + -- optics for data types + Data.Either.Optics + Data.IntMap.Optics + Data.IntSet.Optics + Data.List.Optics + Data.Map.Optics + Data.Maybe.Optics + Data.Sequence.Optics + Data.Set.Optics + Data.Tree.Optics + Data.Tuple.Optics + Data.Typeable.Optics + GHC.Generics.Optics + Numeric.Optics + + -- internal modules + Optics.Internal.Bi + Optics.Internal.Concrete + Optics.Internal.Fold + Optics.Internal.Indexed + Optics.Internal.IxFold + Optics.Internal.IxSetter + Optics.Internal.IxTraversal + Optics.Internal.Optic + Optics.Internal.Optic.Subtyping + Optics.Internal.Optic.TypeLevel + Optics.Internal.Optic.Types + Optics.Internal.Profunctor + Optics.Internal.Setter + Optics.Internal.Tagged + Optics.Internal.Traversal + Optics.Internal.Utils + + default-extensions: BangPatterns + DefaultSignatures + DeriveFunctor + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + InstanceSigs + LambdaCase + MultiParamTypeClasses + RankNTypes + ScopedTypeVariables + TupleSections + TypeApplications + TypeFamilies + TypeOperators diff --git a/src/Data/Either/Optics.hs b/src/Data/Either/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Data/Either/Optics.hs @@ -0,0 +1,35 @@ +-- | Module: Data.Either.Optics +-- Description: 'Prism's for the 'Either' datatype. +-- +-- This module defines 'Prism's for the constructors of the 'Either' datatype. +module Data.Either.Optics + ( _Left + , _Right + ) + where + +import Optics.Prism + +-- | A 'Prism' that matches on the 'Left' constructor of 'Either'. +_Left :: Prism (Either a b) (Either c b) a c +_Left = + prism + Left + (\ x -> + case x of + Left y -> Right y + Right y -> Left (Right y) + ) +{-# INLINE _Left #-} + +-- | A 'Prism' that matches on the 'Right' constructor of 'Either'. +_Right :: Prism (Either a b) (Either a c) b c +_Right = + prism + Right + (\ x -> + case x of + Left y -> Left (Left y) + Right y -> Right y + ) +{-# INLINE _Right #-} diff --git a/src/Data/IntMap/Optics.hs b/src/Data/IntMap/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Data/IntMap/Optics.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE CPP #-} +-- | 'IntMap' is an instance of 'Optics.At.Core.At' and provides +-- 'Optics.At.Core.at' as a lens on values at keys: +-- +-- >>> IntMap.fromList [(1, "world")] ^. at 1 +-- Just "world" +-- +-- >>> IntMap.empty & at 1 .~ Just "world" +-- fromList [(1,"world")] +-- +-- >>> IntMap.empty & at 0 .~ Just "hello" +-- fromList [(0,"hello")] +-- +-- We can traverse, fold over, and map over key-value pairs in a 'IntMap', +-- thanks to indexed traversals, folds and setters. +-- +-- >>> iover imapped const $ IntMap.fromList [(1, "Venus")] +-- fromList [(1,1)] +-- +-- >>> ifoldMapOf ifolded (\i _ -> Sum i) $ IntMap.fromList [(2, "Earth"), (3, "Mars")] +-- Sum {getSum = 5} +-- +-- >>> itraverseOf_ ifolded (curry print) $ IntMap.fromList [(4, "Jupiter")] +-- (4,"Jupiter") +-- +-- >>> itoListOf ifolded $ IntMap.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. +-- +-- >>> IntMap.fromList [(2, "Earth")] & ix 2 %~ ("New " ++) +-- fromList [(2,"New Earth")] +-- +-- >>> preview (ix 8) IntMap.empty +-- Nothing +-- +module Data.IntMap.Optics + ( toMapOf + , lt + , gt + , le + , ge + ) where + +import Data.IntMap as IntMap + +import Optics.IxAffineTraversal +import Optics.IxFold +import Optics.Optic + +-- | Construct a map from an 'IxFold'. +-- +-- The construction is left-biased (see 'IntMap.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) [(1,"alpha"),(2, "beta")] +-- fromList [(1,"alpha"),(2,"beta")] +-- +-- >>> toMapOf (icompose (\a b -> 10*a+b) $ ifolded % ifolded) ["foo", "bar"] +-- fromList [(0,'f'),(1,'o'),(2,'o'),(10,'b'),(11,'a'),(12,'r')] +-- +-- >>> toMapOf (folded % ifolded) [(1, "hello"), (2, "world"), (1, "dummy")] +-- fromList [(1,"hello"),(2,"world")] +-- +toMapOf + :: (Is k A_Fold, is `HasSingleIndex` Int) + => Optic' k is s a -> s -> IntMap a +toMapOf o = ifoldMapOf o IntMap.singleton +{-# INLINE toMapOf #-} + +-- | Focus on the largest key smaller than the given one and its corresponding +-- value. +-- +-- >>> IntMap.fromList [(1, "hi"), (2, "there")] & over (lt 2) (++ "!") +-- fromList [(1,"hi!"),(2,"there")] +-- +-- >>> ipreview (lt 1) $ IntMap.fromList [(1, 'x'), (2, 'y')] +-- Nothing +lt :: Int -> IxAffineTraversal' Int (IntMap v) v +lt k = iatraversalVL $ \point f s -> + case lookupLT k s of + Nothing -> point s + Just (k', v) -> f k' v <&> \v' -> IntMap.insert k' v' s +{-# INLINE lt #-} + +-- | Focus on the smallest key greater than the given one and its corresponding +-- value. +-- +-- >>> IntMap.fromList [(1, "hi"), (2, "there")] & over (gt 2) (++ "!") +-- fromList [(1,"hi"),(2,"there")] +-- +-- >>> ipreview (gt 1) $ IntMap.fromList [(1, 'x'), (2, 'y')] +-- Just (2,'y') +gt :: Int -> IxAffineTraversal' Int (IntMap v) v +gt k = iatraversalVL $ \point f s -> + case lookupGT k s of + Nothing -> point s + Just (k', v) -> f k' v <&> \v' -> IntMap.insert k' v' s +{-# INLINE gt #-} + +-- | Focus on the largest key smaller or equal than the given one and its +-- corresponding value. +-- +-- >>> IntMap.fromList [(1, "hi"), (2, "there")] & over (le 2) (++ "!") +-- fromList [(1,"hi"),(2,"there!")] +-- +-- >>> ipreview (le 1) $ IntMap.fromList [(1, 'x'), (2, 'y')] +-- Just (1,'x') +le :: Int -> IxAffineTraversal' Int (IntMap v) v +le k = iatraversalVL $ \point f s -> + case lookupLE k s of + Nothing -> point s + Just (k', v) -> f k' v <&> \v' -> IntMap.insert k' v' s +{-# INLINE le #-} + +-- | Focus on the smallest key greater or equal than the given one and its +-- corresponding value. +-- +-- >>> IntMap.fromList [(1, "hi"), (3, "there")] & over (ge 2) (++ "!") +-- fromList [(1,"hi"),(3,"there!")] +-- +-- >>> ipreview (ge 2) $ IntMap.fromList [(1, 'x'), (3, 'y')] +-- Just (3,'y') +ge :: Int -> IxAffineTraversal' Int (IntMap v) v +ge k = iatraversalVL $ \point f s -> + case lookupGE k s of + Nothing -> point s + Just (k', v) -> f k' v <&> \v' -> IntMap.insert k' v' s +{-# INLINE ge #-} + +-- $setup +-- >>> import Data.Monoid +-- >>> import Optics.Core diff --git a/src/Data/IntSet/Optics.hs b/src/Data/IntSet/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Data/IntSet/Optics.hs @@ -0,0 +1,53 @@ +-- | +-- Module: Data.IntSet.Optics +-- Description: Optics for working with 'IntSet's. +-- +-- This module defines optics for constructing and manipulating finite 'IntSet's. +-- +module Data.IntSet.Optics + ( members + , setmapped + , setOf + ) where + +import Data.IntSet as IntSet + +import Optics.Fold +import Optics.Optic +import Optics.Setter + +-- | IntSet isn't Foldable, but this 'Fold' can be used to access the members of +-- an 'IntSet'. +-- +-- >>> sumOf members $ setOf folded [1,2,3,4] +-- 10 +members :: Fold IntSet Int +members = folding IntSet.toAscList +{-# INLINE members #-} + +-- | This 'Setter' can be used to change the type of a 'IntSet' by mapping the +-- elements to new values. +-- +-- Sadly, you can't create a valid 'Optics.Traversal.Traversal' for an 'IntSet', +-- 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 :: Setter' IntSet Int +setmapped = sets IntSet.map +{-# INLINE setmapped #-} + +-- | Construct an 'IntSet' from a fold. +-- +-- >>> setOf folded [1,2,3,4] +-- fromList [1,2,3,4] +-- +-- >>> setOf (folded % _2) [("hello",1),("world",2),("!!!",3)] +-- fromList [1,2,3] +setOf :: Is k A_Fold => Optic' k is s Int -> s -> IntSet +setOf l = foldMapOf l IntSet.singleton +{-# INLINE setOf #-} + +-- $setup +-- >>> import Optics.Core diff --git a/src/Data/List/Optics.hs b/src/Data/List/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/Optics.hs @@ -0,0 +1,123 @@ +-- | +-- Module: Data.List.Optics +-- Description: Traversals for manipulating parts of a list. +-- +-- Additional optics for manipulating lists are present more generically in this +-- package. +-- +-- The 'Optics.At.Core.Ixed' class allows traversing the element at a specific +-- list index. +-- +-- >>> [0..10] ^? ix 4 +-- Just 4 +-- +-- >>> [0..5] & ix 4 .~ 2 +-- [0,1,2,3,2,5] +-- +-- >>> [0..10] ^? ix 14 +-- Nothing +-- +-- >>> [0..5] & ix 14 .~ 2 +-- [0,1,2,3,4,5] +-- +-- The 'Optics.Cons.Core.Cons' and 'Optics.Empty.Core.AsEmpty' classes provide +-- 'Optics.Prism.Prism's for list constructors. +-- +-- >>> [1..10] ^? _Cons +-- Just (1,[2,3,4,5,6,7,8,9,10]) +-- +-- >>> [] ^? _Cons +-- Nothing +-- +-- >>> [] ^? _Empty +-- Just () +-- +-- >>> _Cons # (1, _Empty # ()) :: [Int] +-- [1] +-- +-- Additionally, 'Optics.Cons.Core.Snoc' provides a 'Optics.Prism.Prism' for +-- accessing the end of a list. Note that this 'Optics.Prism.Prism' always will +-- need to traverse the whole list. +-- +-- >>> [1..5] ^? _Snoc +-- Just ([1,2,3,4],5) +-- +-- >>> _Snoc # ([1,2],5) +-- [1,2,5] +-- +-- Finally, it's possible to traverse, fold over, and map over index-value pairs +-- thanks to instances of 'Optics.Indexed.Core.TraversableWithIndex', +-- 'Optics.Indexed.Core.FoldableWithIndex', and +-- 'Optics.Indexed.Core.FunctorWithIndex'. +-- +-- >>> imap (,) "Hello" +-- [(0,'H'),(1,'e'),(2,'l'),(3,'l'),(4,'o')] +-- +-- >>> ifoldMap replicate "Hello" +-- "ellllloooo" +-- +-- >>> itraverse_ (curry print) "Hello" +-- (0,'H') +-- (1,'e') +-- (2,'l') +-- (3,'l') +-- (4,'o') +-- +---------------------------------------------------------------------------- +module Data.List.Optics + ( prefixed + , suffixed + ) where + +import Control.Monad (guard) +import Data.List + +import Optics.Prism + +-- | A 'Prism' stripping a prefix from a list when used as a +-- 'Optics.Traversal.Traversal', or prepending that prefix when run backwards: +-- +-- >>> "preview" ^? prefixed "pre" +-- Just "view" +-- +-- >>> "review" ^? prefixed "pre" +-- Nothing +-- +-- >>> prefixed "pre" # "amble" +-- "preamble" +prefixed :: Eq a => [a] -> Prism' [a] [a] +prefixed ps = prism' (ps ++) (stripPrefix ps) +{-# INLINE prefixed #-} + +-- | A 'Prism' stripping a suffix from a list when used as a +-- 'Optics.Traversal.Traversal', or appending that suffix when run backwards: +-- +-- >>> "review" ^? suffixed "view" +-- Just "re" +-- +-- >>> "review" ^? suffixed "tire" +-- Nothing +-- +-- >>> suffixed ".o" # "hello" +-- "hello.o" +suffixed :: Eq a => [a] -> Prism' [a] [a] +suffixed qs = prism' (++ qs) (stripSuffix qs) +{-# INLINE suffixed #-} + +---------------------------------------- +-- Internal + +stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] +stripSuffix qs xs0 = go xs0 zs + where + zs = drp qs xs0 + drp (_:ps) (_:xs) = drp ps xs + drp [] xs = xs + drp _ [] = [] + go (_:xs) (_:ys) = go xs ys + go xs [] = zipWith const xs0 zs <$ guard (xs == qs) + go [] _ = Nothing -- impossible +{-# INLINE stripSuffix #-} + +-- $setup +-- >>> import Optics.Core diff --git a/src/Data/Map/Optics.hs b/src/Data/Map/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Data/Map/Optics.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module: Data.Map.Optics +-- Description: Optics for working with 'Data.Map.Map's. +-- +-- This module exists to provide documentation for lenses for working with +-- 'Map', which might otherwise be obscured by their genericity. +-- +-- 'Map' is an instance of 'Optics.At.Core.At' and provides 'Optics.At.Core.at' +-- as a lens on values at keys: +-- +-- >>> Map.fromList [(1, "world")] ^. at 1 +-- Just "world" +-- +-- >>> Map.empty & at 1 .~ Just "world" +-- fromList [(1,"world")] +-- +-- >>> Map.empty & at 0 .~ Just "hello" +-- fromList [(0,"hello")] +-- +-- We can traverse, fold over, and map over key-value pairs in a 'Map', +-- thanks to indexed traversals, folds and setters. +-- +-- >>> iover imapped const $ Map.fromList [(1, "Venus")] +-- fromList [(1,1)] +-- +-- >>> ifoldMapOf ifolded (\i _ -> Sum i) $ Map.fromList [(2, "Earth"), (3, "Mars")] +-- Sum {getSum = 5} +-- +-- >>> itraverseOf_ ifolded (curry print) $ Map.fromList [(4, "Jupiter")] +-- (4,"Jupiter") +-- +-- >>> itoListOf ifolded $ Map.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. +-- +-- >>> Map.fromList [(2, "Earth")] & ix 2 %~ ("New " ++) +-- fromList [(2,"New Earth")] +-- +-- >>> preview (ix 8) Map.empty +-- Nothing +-- +module Data.Map.Optics + ( toMapOf + , lt + , gt + , le + , ge + ) where + +import Data.Map as Map + +import Optics.IxAffineTraversal +import Optics.IxFold +import Optics.Optic + +-- | Construct a map from an 'IxFold'. +-- +-- The construction is left-biased (see 'Map.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 (ifolded <%> ifolded) ["foo", "bar"] +-- fromList [((0,0),'f'),((0,1),'o'),((0,2),'o'),((1,0),'b'),((1,1),'a'),((1,2),'r')] +-- +-- >>> toMapOf (folded % ifolded) [('a', "hello"), ('b', "world"), ('a', "dummy")] +-- fromList [('a',"hello"),('b',"world")] +-- +toMapOf + :: (Is k A_Fold, is `HasSingleIndex` i, Ord i) + => Optic' k is s a -> s -> Map i a +toMapOf o = ifoldMapOf o Map.singleton +{-# INLINE toMapOf #-} + +-- | Focus on the largest key smaller than the given one and its corresponding +-- value. +-- +-- >>> Map.fromList [('a', "hi"), ('b', "there")] & over (lt 'b') (++ "!") +-- fromList [('a',"hi!"),('b',"there")] +-- +-- >>> ipreview (lt 'a') $ Map.fromList [('a', 'x'), ('b', 'y')] +-- Nothing +lt :: Ord k => k -> IxAffineTraversal' k (Map k v) v +lt k = iatraversalVL $ \point f s -> + case lookupLT k s of + Nothing -> point s + Just (k', v) -> f k' v <&> \v' -> Map.insert k' v' s +{-# INLINE lt #-} + +-- | Focus on the smallest key greater than the given one and its corresponding +-- value. +-- +-- >>> Map.fromList [('a', "hi"), ('b', "there")] & over (gt 'b') (++ "!") +-- fromList [('a',"hi"),('b',"there")] +-- +-- >>> ipreview (gt 'a') $ Map.fromList [('a', 'x'), ('b', 'y')] +-- Just ('b','y') +gt :: Ord k => k -> IxAffineTraversal' k (Map k v) v +gt k = iatraversalVL $ \point f s -> + case lookupGT k s of + Nothing -> point s + Just (k', v) -> f k' v <&> \v' -> Map.insert k' v' s +{-# INLINE gt #-} + +-- | Focus on the largest key smaller or equal than the given one and its +-- corresponding value. +-- +-- >>> Map.fromList [('a', "hi"), ('b', "there")] & over (le 'b') (++ "!") +-- fromList [('a',"hi"),('b',"there!")] +-- +-- >>> ipreview (le 'a') $ Map.fromList [('a', 'x'), ('b', 'y')] +-- Just ('a','x') +le :: Ord k => k -> IxAffineTraversal' k (Map k v) v +le k = iatraversalVL $ \point f s -> + case lookupLE k s of + Nothing -> point s + Just (k', v) -> f k' v <&> \v' -> Map.insert k' v' s +{-# INLINE le #-} + +-- | Focus on the smallest key greater or equal than the given one and its +-- corresponding value. +-- +-- >>> Map.fromList [('a', "hi"), ('c', "there")] & over (ge 'b') (++ "!") +-- fromList [('a',"hi"),('c',"there!")] +-- +-- >>> ipreview (ge 'b') $ Map.fromList [('a', 'x'), ('c', 'y')] +-- Just ('c','y') +ge :: Ord k => k -> IxAffineTraversal' k (Map k v) v +ge k = iatraversalVL $ \point f s -> + case lookupGE k s of + Nothing -> point s + Just (k', v) -> f k' v <&> \v' -> Map.insert k' v' s +{-# INLINE ge #-} + +-- $setup +-- >>> import Data.Monoid +-- >>> import Optics.Core diff --git a/src/Data/Maybe/Optics.hs b/src/Data/Maybe/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Data/Maybe/Optics.hs @@ -0,0 +1,36 @@ +-- | +-- Module: Data.Maybe.Optics +-- Description: 'Prism's for the 'Maybe' datatype. +-- +-- This module defines 'Prism's for the constructors of the 'Maybe' datatype. +module Data.Maybe.Optics + ( _Nothing + , _Just + ) + where + +import Optics.Prism + +-- | A 'Prism' that matches on the 'Nothing' constructor of 'Maybe'. +_Nothing :: Prism' (Maybe a) () +_Nothing = + prism + (\ () -> Nothing) + (\ x -> + case x of + Nothing -> Right () + Just y -> Left (Just y) + ) +{-# INLINE _Nothing #-} + +-- | A 'Prism' that matches on the 'Just' constructor of 'Maybe'. +_Just :: Prism (Maybe a) (Maybe b) a b +_Just = + prism + Just + (\ x -> + case x of + Nothing -> Left Nothing + Just y -> Right y + ) +{-# INLINE _Just #-} diff --git a/src/Data/Sequence/Optics.hs b/src/Data/Sequence/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sequence/Optics.hs @@ -0,0 +1,140 @@ +-- | +-- Module: Data.Sequence.Optics +-- Description: Optics for working with 'Seq's. +-- +-- This module defines optics for constructing and manipulating finite 'Seq's. +-- +module Data.Sequence.Optics + ( viewL, viewR + , sliced, slicedTo, slicedFrom + , seqOf + ) where + +import Data.Sequence as Seq + +import Optics.Internal.Indexed +import Optics.Fold +import Optics.Iso +import Optics.IxTraversal +import Optics.Optic +import Optics.Traversal + +-- * Sequence isomorphisms + +-- | A 'Seq' is isomorphic to a 'ViewL' +-- +-- @'viewl' m ≡ m 'Optics.Operators.^.' 'viewL'@ +-- +-- >>> Seq.fromList [1,2,3] ^. viewL +-- 1 :< fromList [2,3] +-- +-- >>> Seq.empty ^. viewL +-- EmptyL +-- +-- >>> EmptyL ^. re viewL +-- fromList [] +-- +-- >>> review viewL $ 1 Seq.:< fromList [2,3] +-- fromList [1,2,3] +viewL :: Iso (Seq a) (Seq b) (ViewL a) (ViewL b) +viewL = iso viewl $ \xs -> case xs of + EmptyL -> mempty + a Seq.:< as -> a Seq.<| as +{-# INLINE viewL #-} + +-- | A 'Seq' is isomorphic to a 'ViewR' +-- +-- @'viewr' m ≡ m 'Optics.Operators.^.' 'viewR'@ +-- +-- >>> Seq.fromList [1,2,3] ^. viewR +-- fromList [1,2] :> 3 +-- +-- >>> Seq.empty ^. viewR +-- EmptyR +-- +-- >>> EmptyR ^. re viewR +-- fromList [] +-- +-- >>> review viewR $ fromList [1,2] Seq.:> 3 +-- fromList [1,2,3] +viewR :: Iso (Seq a) (Seq b) (ViewR a) (ViewR b) +viewR = iso viewr $ \xs -> case xs of + EmptyR -> mempty + as Seq.:> a -> as Seq.|> a +{-# INLINE viewR #-} + +-- | Traverse the first @n@ elements of a 'Seq' +-- +-- >>> fromList [1,2,3,4,5] ^.. slicedTo 2 +-- [1,2] +-- +-- >>> fromList [1,2,3,4,5] & slicedTo 2 %~ (*10) +-- fromList [10,20,3,4,5] +-- +-- >>> fromList [1,2,4,5,6] & slicedTo 10 .~ 0 +-- fromList [0,0,0,0,0] +slicedTo :: Int -> IxTraversal' Int (Seq a) a +slicedTo n = conjoined noix ix + where + noix = traversalVL $ \f m -> case Seq.splitAt n m of + (l, r) -> (>< r) <$> traverse f l + + ix = itraversalVL $ \f m -> case Seq.splitAt n m of + (l, r) -> (>< r) <$> itraverse f l +{-# INLINE slicedTo #-} + +-- | Traverse all but the first @n@ elements of a 'Seq' +-- +-- >>> fromList [1,2,3,4,5] ^.. slicedFrom 2 +-- [3,4,5] +-- +-- >>> fromList [1,2,3,4,5] & slicedFrom 2 %~ (*10) +-- fromList [1,2,30,40,50] +-- +-- >>> fromList [1,2,3,4,5] & slicedFrom 10 .~ 0 +-- fromList [1,2,3,4,5] +slicedFrom :: Int -> IxTraversal' Int (Seq a) a +slicedFrom n = conjoined noix ix + where + noix = traversalVL $ \f m -> case Seq.splitAt n m of + (l, r) -> (l ><) <$> traverse f r + + ix = itraversalVL $ \f m -> case Seq.splitAt n m of + (l, r) -> (l ><) <$> itraverse (f . (+n)) r +{-# INLINE slicedFrom #-} + +-- | Traverse all the elements numbered from @i@ to @j@ of a 'Seq' +-- +-- >>> fromList [1,2,3,4,5] & sliced 1 3 %~ (*10) +-- fromList [1,20,30,4,5] +-- +-- >>> fromList [1,2,3,4,5] ^.. sliced 1 3 +-- [2,3] +-- +-- >>> fromList [1,2,3,4,5] & sliced 1 3 .~ 0 +-- fromList [1,0,0,4,5] +sliced :: Int -> Int -> IxTraversal' Int (Seq a) a +sliced i j = conjoined noix ix + where + noix = traversalVL $ \f s -> case Seq.splitAt i s of + (l, mr) -> case Seq.splitAt (j-i) mr of + (m, r) -> traverse f m <&> \n -> l >< n >< r + + ix = itraversalVL $ \f s -> case Seq.splitAt i s of + (l, mr) -> case Seq.splitAt (j-i) mr of + (m, r) -> itraverse (f . (+i)) m <&> \n -> l >< n >< r +{-# INLINE sliced #-} + +-- | Construct a 'Seq' from a fold. +-- +-- >>> seqOf folded ["hello","world"] +-- fromList ["hello","world"] +-- +-- >>> seqOf (folded % _2) [("hello",1),("world",2),("!!!",3)] +-- fromList [1,2,3] +seqOf :: Is k A_Fold => Optic' k is s a -> s -> Seq a +seqOf l = foldMapOf l Seq.singleton +{-# INLINE seqOf #-} + +-- $setup +-- >>> import Optics.Core diff --git a/src/Data/Set/Optics.hs b/src/Data/Set/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Data/Set/Optics.hs @@ -0,0 +1,43 @@ +-- | +-- Module: Data.Set.Optics +-- Description: Optics for working with 'Set's. +-- +-- This module defines optics for constructing and manipulating finite 'Set's. +-- +module Data.Set.Optics + ( setmapped + , setOf + ) where + +import Data.Set as Set + +import Optics.Fold +import Optics.Optic +import Optics.Setter + +-- | This 'Setter' can be used to change the type of a 'Set' by mapping the +-- elements to new values. +-- +-- Sadly, you can't create a valid 'Optics.Traversal.Traversal' for a 'Set', 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 :: Ord b => Setter (Set a) (Set b) a b +setmapped = sets Set.map +{-# INLINE setmapped #-} + +-- | Construct a set 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, Ord a) => Optic' k is s a -> s -> Set a +setOf l = foldMapOf l Set.singleton +{-# INLINE setOf #-} + +-- $setup +-- >>> import Optics.Core diff --git a/src/Data/Tree/Optics.hs b/src/Data/Tree/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/Optics.hs @@ -0,0 +1,32 @@ +-- | +-- Module: Data.Tree.Optics +-- Description: Optics for working with 'Tree's. +-- +-- This module defines optics for manipulating 'Tree's. +-- +module Data.Tree.Optics + ( root + , branches + ) where + +import Data.Tree + +import Optics.Lens + +-- | A 'Lens' that focuses on the root of a 'Tree'. +-- +-- >>> view root $ Node 42 [] +-- 42 +root :: Lens' (Tree a) a +root = lensVL $ \f (Node a as) -> (`Node` as) <$> f a +{-# INLINE root #-} + +-- | A 'Lens' returning the direct descendants of the root of a 'Tree' +-- +-- @'Optics.Getter.view' 'branches' ≡ 'subForest'@ +branches :: Lens' (Tree a) [Tree a] +branches = lensVL $ \f (Node a as) -> Node a <$> f as +{-# INLINE branches #-} + +-- $setup +-- >>> import Optics.Core diff --git a/src/Data/Tuple/Optics.hs b/src/Data/Tuple/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tuple/Optics.hs @@ -0,0 +1,519 @@ +-- | +-- Module: Data.Tuple.Optics +-- Description: 'Lens'es for tuple types. +-- +-- This module defines 'Lens'es for the fields of tuple types. These are +-- overloaded using the 'Field1' to 'Field9' typeclasses, so that '_1' can be +-- used as a 'Lens' for the first field of a tuple with any number of fields (up +-- to the maximum supported tuple size, which is currently 9). For example: +-- +-- >>> view _1 ('a','b','c') +-- 'a' +-- +-- >>> set _3 True ('a','b','c') +-- ('a','b',True) +-- +-- If a single-constructor datatype has a 'Generic' instance, the corresponding +-- @FieldN@ instances can be defined using their default methods: +-- +-- >>> :set -XDeriveGeneric +-- >>> data T a = MkT Int a deriving (Generic, Show) +-- >>> instance Field1 (T a) (T a) Int Int +-- >>> instance Field2 (T a) (T b) a b +-- +-- >>> set _2 'x' (MkT 1 False) +-- MkT 1 'x' +-- +{-# LANGUAGE UndecidableInstances #-} +module Data.Tuple.Optics + ( + -- * Tuples + Field1(..) + , Field2(..) + , Field3(..) + , Field4(..) + , Field5(..) + , Field6(..) + , Field7(..) + , Field8(..) + , Field9(..) + -- * Strict variations + , _1', _2', _3', _4', _5', _6', _7', _8', _9' + ) where + +import Data.Functor.Identity +import Data.Functor.Product +import Data.Proxy +import GHC.Generics ((:*:)(..), Generic(..), K1, M1, U1) + +import GHC.Generics.Optics +import Optics.Lens +import Optics.Optic + +-- | Provides access to 1st field of a tuple. +class Field1 s t a b | s -> a, t -> b, s b -> t, t a -> s where + -- | Access the 1st field of a tuple (and possibly change its type). + -- + -- >>> (1,2) ^. _1 + -- 1 + -- + -- >>> (1,2) & _1 .~ "hello" + -- ("hello",2) + -- + -- >>> traverseOf _1 putStrLn ("hello","world") + -- hello + -- ((),"world") + -- + -- This can also be used on larger tuples as well: + -- + -- >>> (1,2,3,4,5) & _1 %~ (+41) + -- (42,2,3,4,5) + _1 :: Lens s t a b + default _1 :: (Generic s, Generic t, GIxed N0 (Rep s) (Rep t) a b) + => Lens s t a b + _1 = ix proxyN0 + {-# INLINE[1] _1 #-} + +instance Field1 (Identity a) (Identity b) a b where + _1 = lensVL $ \f (Identity a) -> Identity <$> f a + {-# INLINE[1] _1 #-} + +instance Field1 (Product f g a) (Product f' g a) (f a) (f' a) where + _1 = lensVL $ \f ~(Pair a b) -> flip Pair b <$> f a + {-# INLINE[1] _1 #-} + +instance Field1 ((f :*: g) p) ((f' :*: g) p) (f p) (f' p) where + _1 = lensVL $ \f ~(l :*: r) -> (:*: r) <$> f l + {-# INLINE[1] _1 #-} + +instance Field1 (a,b) (a',b) a a' where + _1 = lensVL $ \k ~(a,b) -> k a <&> \a' -> (a',b) + {-# INLINE[1] _1 #-} + +instance Field1 (a,b,c) (a',b,c) a a' where + _1 = lensVL $ \k ~(a,b,c) -> k a <&> \a' -> (a',b,c) + {-# INLINE[1] _1 #-} + +instance Field1 (a,b,c,d) (a',b,c,d) a a' where + _1 = lensVL $ \k ~(a,b,c,d) -> k a <&> \a' -> (a',b,c,d) + {-# INLINE[1] _1 #-} + +instance Field1 (a,b,c,d,e) (a',b,c,d,e) a a' where + _1 = lensVL $ \k ~(a,b,c,d,e) -> k a <&> \a' -> (a',b,c,d,e) + {-# INLINE[1] _1 #-} + +instance Field1 (a,b,c,d,e,f) (a',b,c,d,e,f) a a' where + _1 = lensVL $ \k ~(a,b,c,d,e,f) -> k a <&> \a' -> (a',b,c,d,e,f) + {-# INLINE[1] _1 #-} + +instance Field1 (a,b,c,d,e,f,g) (a',b,c,d,e,f,g) a a' where + _1 = lensVL $ \k ~(a,b,c,d,e,f,g) -> k a <&> \a' -> (a',b,c,d,e,f,g) + {-# INLINE[1] _1 #-} + +instance Field1 (a,b,c,d,e,f,g,h) (a',b,c,d,e,f,g,h) a a' where + _1 = lensVL $ \k ~(a,b,c,d,e,f,g,h) -> k a <&> \a' -> (a',b,c,d,e,f,g,h) + {-# INLINE[1] _1 #-} + +instance Field1 (a,b,c,d,e,f,g,h,i) (a',b,c,d,e,f,g,h,i) a a' where + _1 = lensVL $ \k ~(a,b,c,d,e,f,g,h,i) -> k a <&> \a' -> (a',b,c,d,e,f,g,h,i) + {-# INLINE[1] _1 #-} + +-- | Provides access to the 2nd field of a tuple. +class Field2 s t a b | s -> a, t -> b, s b -> t, t a -> s where + -- | Access the 2nd field of a tuple. + -- + -- >>> _2 .~ "hello" $ (1,(),3,4) + -- (1,"hello",3,4) + -- + -- >>> (1,2,3,4) & _2 %~ (*3) + -- (1,6,3,4) + -- + -- >>> traverseOf _2 print (1,2) + -- 2 + -- (1,()) + _2 :: Lens s t a b + default _2 :: (Generic s, Generic t, GIxed N1 (Rep s) (Rep t) a b) + => Lens s t a b + _2 = ix proxyN1 + {-# INLINE[1] _2 #-} + +instance Field2 (Product f g a) (Product f g' a) (g a) (g' a) where + _2 = lensVL $ \f ~(Pair a b) -> Pair a <$> f b + {-# INLINE[1] _2 #-} + +instance Field2 ((f :*: g) p) ((f :*: g') p) (g p) (g' p) where + _2 = lensVL $ \f ~(l :*: r) -> (l :*:) <$> f r + {-# INLINE[1] _2 #-} + +instance Field2 (a,b) (a,b') b b' where + _2 = lensVL $ \k ~(a,b) -> k b <&> \b' -> (a,b') + {-# INLINE[1] _2 #-} + +instance Field2 (a,b,c) (a,b',c) b b' where + _2 = lensVL $ \k ~(a,b,c) -> k b <&> \b' -> (a,b',c) + {-# INLINE[1] _2 #-} + +instance Field2 (a,b,c,d) (a,b',c,d) b b' where + _2 = lensVL $ \k ~(a,b,c,d) -> k b <&> \b' -> (a,b',c,d) + {-# INLINE[1] _2 #-} + +instance Field2 (a,b,c,d,e) (a,b',c,d,e) b b' where + _2 = lensVL $ \k ~(a,b,c,d,e) -> k b <&> \b' -> (a,b',c,d,e) + {-# INLINE[1] _2 #-} + +instance Field2 (a,b,c,d,e,f) (a,b',c,d,e,f) b b' where + _2 = lensVL $ \k ~(a,b,c,d,e,f) -> k b <&> \b' -> (a,b',c,d,e,f) + {-# INLINE[1] _2 #-} + +instance Field2 (a,b,c,d,e,f,g) (a,b',c,d,e,f,g) b b' where + _2 = lensVL $ \k ~(a,b,c,d,e,f,g) -> k b <&> \b' -> (a,b',c,d,e,f,g) + {-# INLINE[1] _2 #-} + +instance Field2 (a,b,c,d,e,f,g,h) (a,b',c,d,e,f,g,h) b b' where + _2 = lensVL $ \k ~(a,b,c,d,e,f,g,h) -> k b <&> \b' -> (a,b',c,d,e,f,g,h) + {-# INLINE[1] _2 #-} + +instance Field2 (a,b,c,d,e,f,g,h,i) (a,b',c,d,e,f,g,h,i) b b' where + _2 = lensVL $ \k ~(a,b,c,d,e,f,g,h,i) -> k b <&> \b' -> (a,b',c,d,e,f,g,h,i) + {-# INLINE[1] _2 #-} + +-- | Provides access to the 3rd field of a tuple. +class Field3 s t a b | s -> a, t -> b, s b -> t, t a -> s where + -- | Access the 3rd field of a tuple. + _3 :: Lens s t a b + default _3 :: (Generic s, Generic t, GIxed N2 (Rep s) (Rep t) a b) + => Lens s t a b + _3 = ix proxyN2 + {-# INLINE[1] _3 #-} + +instance Field3 (a,b,c) (a,b,c') c c' where + _3 = lensVL $ \k ~(a,b,c) -> k c <&> \c' -> (a,b,c') + {-# INLINE[1] _3 #-} + +instance Field3 (a,b,c,d) (a,b,c',d) c c' where + _3 = lensVL $ \k ~(a,b,c,d) -> k c <&> \c' -> (a,b,c',d) + {-# INLINE[1] _3 #-} + +instance Field3 (a,b,c,d,e) (a,b,c',d,e) c c' where + _3 = lensVL $ \k ~(a,b,c,d,e) -> k c <&> \c' -> (a,b,c',d,e) + {-# INLINE[1] _3 #-} + +instance Field3 (a,b,c,d,e,f) (a,b,c',d,e,f) c c' where + _3 = lensVL $ \k ~(a,b,c,d,e,f) -> k c <&> \c' -> (a,b,c',d,e,f) + {-# INLINE[1] _3 #-} + +instance Field3 (a,b,c,d,e,f,g) (a,b,c',d,e,f,g) c c' where + _3 = lensVL $ \k ~(a,b,c,d,e,f,g) -> k c <&> \c' -> (a,b,c',d,e,f,g) + {-# INLINE[1] _3 #-} + +instance Field3 (a,b,c,d,e,f,g,h) (a,b,c',d,e,f,g,h) c c' where + _3 = lensVL $ \k ~(a,b,c,d,e,f,g,h) -> k c <&> \c' -> (a,b,c',d,e,f,g,h) + {-# INLINE[1] _3 #-} + +instance Field3 (a,b,c,d,e,f,g,h,i) (a,b,c',d,e,f,g,h,i) c c' where + _3 = lensVL $ \k ~(a,b,c,d,e,f,g,h,i) -> k c <&> \c' -> (a,b,c',d,e,f,g,h,i) + {-# INLINE[1] _3 #-} + +-- | Provide access to the 4th field of a tuple. +class Field4 s t a b | s -> a, t -> b, s b -> t, t a -> s where + -- | Access the 4th field of a tuple. + _4 :: Lens s t a b + default _4 :: (Generic s, Generic t, GIxed N3 (Rep s) (Rep t) a b) + => Lens s t a b + _4 = ix proxyN3 + {-# INLINE[1] _4 #-} + +instance Field4 (a,b,c,d) (a,b,c,d') d d' where + _4 = lensVL $ \k ~(a,b,c,d) -> k d <&> \d' -> (a,b,c,d') + {-# INLINE[1] _4 #-} + +instance Field4 (a,b,c,d,e) (a,b,c,d',e) d d' where + _4 = lensVL $ \k ~(a,b,c,d,e) -> k d <&> \d' -> (a,b,c,d',e) + {-# INLINE[1] _4 #-} + +instance Field4 (a,b,c,d,e,f) (a,b,c,d',e,f) d d' where + _4 = lensVL $ \k ~(a,b,c,d,e,f) -> k d <&> \d' -> (a,b,c,d',e,f) + {-# INLINE[1] _4 #-} + +instance Field4 (a,b,c,d,e,f,g) (a,b,c,d',e,f,g) d d' where + _4 = lensVL $ \k ~(a,b,c,d,e,f,g) -> k d <&> \d' -> (a,b,c,d',e,f,g) + {-# INLINE[1] _4 #-} + +instance Field4 (a,b,c,d,e,f,g,h) (a,b,c,d',e,f,g,h) d d' where + _4 = lensVL $ \k ~(a,b,c,d,e,f,g,h) -> k d <&> \d' -> (a,b,c,d',e,f,g,h) + {-# INLINE[1] _4 #-} + +instance Field4 (a,b,c,d,e,f,g,h,i) (a,b,c,d',e,f,g,h,i) d d' where + _4 = lensVL $ \k ~(a,b,c,d,e,f,g,h,i) -> k d <&> \d' -> (a,b,c,d',e,f,g,h,i) + {-# INLINE[1] _4 #-} + +-- | Provides access to the 5th field of a tuple. +class Field5 s t a b | s -> a, t -> b, s b -> t, t a -> s where + -- | Access the 5th field of a tuple. + _5 :: Lens s t a b + default _5 :: (Generic s, Generic t, GIxed N4 (Rep s) (Rep t) a b) + => Lens s t a b + _5 = ix proxyN4 + {-# INLINE[1] _5 #-} + +instance Field5 (a,b,c,d,e) (a,b,c,d,e') e e' where + _5 = lensVL $ \k ~(a,b,c,d,e) -> k e <&> \e' -> (a,b,c,d,e') + {-# INLINE[1] _5 #-} + +instance Field5 (a,b,c,d,e,f) (a,b,c,d,e',f) e e' where + _5 = lensVL $ \k ~(a,b,c,d,e,f) -> k e <&> \e' -> (a,b,c,d,e',f) + {-# INLINE[1] _5 #-} + +instance Field5 (a,b,c,d,e,f,g) (a,b,c,d,e',f,g) e e' where + _5 = lensVL $ \k ~(a,b,c,d,e,f,g) -> k e <&> \e' -> (a,b,c,d,e',f,g) + {-# INLINE[1] _5 #-} + +instance Field5 (a,b,c,d,e,f,g,h) (a,b,c,d,e',f,g,h) e e' where + _5 = lensVL $ \k ~(a,b,c,d,e,f,g,h) -> k e <&> \e' -> (a,b,c,d,e',f,g,h) + {-# INLINE[1] _5 #-} + +instance Field5 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e',f,g,h,i) e e' where + _5 = lensVL $ \k ~(a,b,c,d,e,f,g,h,i) -> k e <&> \e' -> (a,b,c,d,e',f,g,h,i) + {-# INLINE[1] _5 #-} + +-- | Provides access to the 6th element of a tuple. +class Field6 s t a b | s -> a, t -> b, s b -> t, t a -> s where + -- | Access the 6th field of a tuple. + _6 :: Lens s t a b + default _6 :: (Generic s, Generic t, GIxed N5 (Rep s) (Rep t) a b) + => Lens s t a b + _6 = ix proxyN5 + {-# INLINE[1] _6 #-} + +instance Field6 (a,b,c,d,e,f) (a,b,c,d,e,f') f f' where + _6 = lensVL $ \k ~(a,b,c,d,e,f) -> k f <&> \f' -> (a,b,c,d,e,f') + {-# INLINE[1] _6 #-} + +instance Field6 (a,b,c,d,e,f,g) (a,b,c,d,e,f',g) f f' where + _6 = lensVL $ \k ~(a,b,c,d,e,f,g) -> k f <&> \f' -> (a,b,c,d,e,f',g) + {-# INLINE[1] _6 #-} + +instance Field6 (a,b,c,d,e,f,g,h) (a,b,c,d,e,f',g,h) f f' where + _6 = lensVL $ \k ~(a,b,c,d,e,f,g,h) -> k f <&> \f' -> (a,b,c,d,e,f',g,h) + {-# INLINE[1] _6 #-} + +instance Field6 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f',g,h,i) f f' where + _6 = lensVL $ \k ~(a,b,c,d,e,f,g,h,i) -> k f <&> \f' -> (a,b,c,d,e,f',g,h,i) + {-# INLINE[1] _6 #-} + +-- | Provide access to the 7th field of a tuple. +class Field7 s t a b | s -> a, t -> b, s b -> t, t a -> s where + -- | Access the 7th field of a tuple. + _7 :: Lens s t a b + default _7 :: (Generic s, Generic t, GIxed N6 (Rep s) (Rep t) a b) + => Lens s t a b + _7 = ix proxyN6 + {-# INLINE[1] _7 #-} + +instance Field7 (a,b,c,d,e,f,g) (a,b,c,d,e,f,g') g g' where + _7 = lensVL $ \k ~(a,b,c,d,e,f,g) -> k g <&> \g' -> (a,b,c,d,e,f,g') + {-# INLINE[1] _7 #-} + +instance Field7 (a,b,c,d,e,f,g,h) (a,b,c,d,e,f,g',h) g g' where + _7 = lensVL $ \k ~(a,b,c,d,e,f,g,h) -> k g <&> \g' -> (a,b,c,d,e,f,g',h) + {-# INLINE[1] _7 #-} + +instance Field7 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f,g',h,i) g g' where + _7 = lensVL $ \k ~(a,b,c,d,e,f,g,h,i) -> k g <&> \g' -> (a,b,c,d,e,f,g',h,i) + {-# INLINE[1] _7 #-} + +-- | Provide access to the 8th field of a tuple. +class Field8 s t a b | s -> a, t -> b, s b -> t, t a -> s where + -- | Access the 8th field of a tuple. + _8 :: Lens s t a b + default _8 :: (Generic s, Generic t, GIxed N7 (Rep s) (Rep t) a b) + => Lens s t a b + _8 = ix proxyN7 + {-# INLINE[1] _8 #-} + +instance Field8 (a,b,c,d,e,f,g,h) (a,b,c,d,e,f,g,h') h h' where + _8 = lensVL $ \k ~(a,b,c,d,e,f,g,h) -> k h <&> \h' -> (a,b,c,d,e,f,g,h') + {-# INLINE[1] _8 #-} + +instance Field8 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f,g,h',i) h h' where + _8 = lensVL $ \k ~(a,b,c,d,e,f,g,h,i) -> k h <&> \h' -> (a,b,c,d,e,f,g,h',i) + {-# INLINE[1] _8 #-} + +-- | Provides access to the 9th field of a tuple. +class Field9 s t a b | s -> a, t -> b, s b -> t, t a -> s where + -- | Access the 9th field of a tuple. + _9 :: Lens s t a b + default _9 :: (Generic s, Generic t, GIxed N8 (Rep s) (Rep t) a b) + => Lens s t a b + _9 = ix proxyN8 + {-# INLINE[1] _9 #-} + +instance Field9 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f,g,h,i') i i' where + _9 = lensVL $ \k ~(a,b,c,d,e,f,g,h,i) -> k i <&> \i' -> (a,b,c,d,e,f,g,h,i') + {-# INLINE[1] _9 #-} + +-- Strict versions of the _1 .. _9 operations + +-- | Strict version of '_1' +_1' :: Field1 s t a b => Lens s t a b +_1' = equality' % _1 +{-# INLINE _1' #-} + +-- | Strict version of '_2' +_2' :: Field2 s t a b => Lens s t a b +_2' = equality' % _2 +{-# INLINE _2' #-} + +-- | Strict version of '_3' +_3' :: Field3 s t a b => Lens s t a b +_3' = equality' % _3 +{-# INLINE _3' #-} + +-- | Strict version of '_4' +_4' :: Field4 s t a b => Lens s t a b +_4' = equality' % _4 +{-# INLINE _4' #-} + +-- | Strict version of '_5' +_5' :: Field5 s t a b => Lens s t a b +_5' = equality' % _5 +{-# INLINE _5' #-} + +-- | Strict version of '_6' +_6' :: Field6 s t a b => Lens s t a b +_6' = equality' % _6 +{-# INLINE _6' #-} + +-- | Strict version of '_7' +_7' :: Field7 s t a b => Lens s t a b +_7' = equality' % _7 +{-# INLINE _7' #-} + +-- | Strict version of '_8' +_8' :: Field8 s t a b => Lens s t a b +_8' = equality' % _8 +{-# INLINE _8' #-} + +-- | Strict version of '_9' +_9' :: Field9 s t a b => Lens s t a b +_9' = equality' % _9 +{-# INLINE _9' #-} + +ix :: (Generic s, Generic t, GIxed n (Rep s) (Rep t) a b) => f n -> Lens s t a b +ix n = generic % gix n +{-# INLINE ix #-} + +-- TODO: this can be replaced by generic-optics position +type family GSize (f :: * -> *) +type instance GSize U1 = Z +type instance GSize (K1 i c) = S Z +type instance GSize (M1 i c f) = GSize f +type instance GSize (a :*: b) = Add (GSize a) (GSize b) + +class GIxed n s t a b | n s -> a, n t -> b, n s b -> t, n t a -> s where + gix :: f n -> Lens (s x) (t x) a b + +instance GIxed N0 (K1 i a) (K1 i b) a b where + gix _ = castOptic _K1 + {-# INLINE gix #-} + +instance GIxed n s t a b => GIxed n (M1 i c s) (M1 i c t) a b where + gix n = _M1 % gix n + {-# INLINE gix #-} + +instance (p ~ GT (GSize s) n, + p ~ GT (GSize t) n, + GIxed' p n s s' t t' a b) + => GIxed n (s :*: s') (t :*: t') a b where + gix = gix' (Proxy @p) + {-# INLINE gix #-} + +class (p ~ GT (GSize s) n, + p ~ GT (GSize t) n) + => GIxed' p n s s' t t' a b | p n s s' -> a + , p n t t' -> b + , p n s s' b -> t t' + , p n t t' a -> s s' where + gix' :: f p -> g n -> Lens ((s :*: s') x) ((t :*: t') x) a b + +instance (GT (GSize s) n ~ T, + GT (GSize t) n ~ T, + GIxed n s t a b) + => GIxed' T n s s' t s' a b where + gix' _ n = _1 % gix n + {-# INLINE gix' #-} + +instance (GT (GSize s) n ~ F, + n' ~ Subtract (GSize s) n, + GIxed n' s' t' a b) + => GIxed' F n s s' s t' a b where + gix' _ _ = _2 % gix (Proxy @n') + {-# INLINE gix' #-} + +data Z +data S a + +data T +data F + +type family Add x y +type instance Add Z y = y +type instance Add (S x) y = S (Add x y) + +type family Subtract x y +type instance Subtract Z x = x +type instance Subtract (S x) (S y) = Subtract x y + +type family GT x y +type instance GT Z x = F +type instance GT (S x) Z = T +type instance GT (S x) (S y) = GT x y + +type N0 = Z +type N1 = S N0 +type N2 = S N1 +type N3 = S N2 +type N4 = S N3 +type N5 = S N4 +type N6 = S N5 +type N7 = S N6 +type N8 = S N7 + +proxyN0 :: Proxy N0 +proxyN0 = Proxy +{-# INLINE proxyN0 #-} + +proxyN1 :: Proxy N1 +proxyN1 = Proxy +{-# INLINE proxyN1 #-} + +proxyN2 :: Proxy N2 +proxyN2 = Proxy +{-# INLINE proxyN2 #-} + +proxyN3 :: Proxy N3 +proxyN3 = Proxy +{-# INLINE proxyN3 #-} + +proxyN4 :: Proxy N4 +proxyN4 = Proxy +{-# INLINE proxyN4 #-} + +proxyN5 :: Proxy N5 +proxyN5 = Proxy +{-# INLINE proxyN5 #-} + +proxyN6 :: Proxy N6 +proxyN6 = Proxy +{-# INLINE proxyN6 #-} + +proxyN7 :: Proxy N7 +proxyN7 = Proxy +{-# INLINE proxyN7 #-} + +proxyN8 :: Proxy N8 +proxyN8 = Proxy +{-# INLINE proxyN8 #-} + +-- $setup +-- >>> import Optics.Core diff --git a/src/Data/Typeable/Optics.hs b/src/Data/Typeable/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Data/Typeable/Optics.hs @@ -0,0 +1,27 @@ +-- | +-- Module: Data.Typeable.Optics +-- Description: Optics for working with 'Typeable'. +-- +module Data.Typeable.Optics + ( _cast + , _gcast + ) where + +import Data.Typeable +import Data.Maybe + +import Optics.AffineTraversal + +-- | An 'AffineTraversal'' for working with a 'cast' of a 'Typeable' value. +_cast :: (Typeable s, Typeable a) => AffineTraversal' s a +_cast = atraversalVL $ \point f s -> case cast s of + Just a -> fromMaybe (error "_cast: recast failed") . cast <$> f a + Nothing -> point s +{-# INLINE _cast #-} + +-- | An 'AffineTraversal'' for working with a 'gcast' of a 'Typeable' value. +_gcast :: (Typeable s, Typeable a) => AffineTraversal' (c s) (c a) +_gcast = atraversalVL $ \point f s -> case gcast s of + Just a -> fromMaybe (error "_gcast: recast failed") . gcast <$> f a + Nothing -> point s +{-# INLINE _gcast #-} diff --git a/src/GHC/Generics/Optics.hs b/src/GHC/Generics/Optics.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Generics/Optics.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE PolyKinds #-} +-- | +-- Module: GHC.Generics.Optics +-- Description: Optics for types defined in "GHC.Generics". +-- +-- Note: "GHC.Generics" exports a number of names that collide with "Optics" +-- (at least 'GHC.Generics.to'). +-- +-- You can use hiding or imports to mitigate this to an extent, and the +-- following imports, represent a fair compromise for user code: +-- +-- @ +-- import "Optics" +-- import "GHC.Generics" hiding (to) +-- import "GHC.Generics.Optics" +-- @ +-- +-- You can use 'generic' to replace 'GHC.Generics.from' and 'GHC.Generics.to' +-- from "GHC.Generics". +-- +module GHC.Generics.Optics + ( generic + , generic1 + , _V1 + , _U1 + , _Par1 + , _Rec1 + , _K1 + , _M1 + , _L1 + , _R1 + ) where + +import qualified GHC.Generics as GHC (to, from, to1, from1) +import GHC.Generics (Generic, Rep, Generic1, Rep1, (:+:) (..), V1, U1 (..), + K1 (..), M1 (..), Par1 (..), Rec1 (..)) + +import Optics.Iso +import Optics.Lens +import Optics.Prism + +-- | Convert from the data type to its representation (or back) +-- +-- >>> view (generic % re generic) "hello" :: String +-- "hello" +-- +generic :: (Generic a, Generic b) => Iso a b (Rep a c) (Rep b c) +generic = iso GHC.from GHC.to +{-# INLINE generic #-} + +-- | Convert from the data type to its representation (or back) +generic1 :: Generic1 f => Iso (f a) (f b) (Rep1 f a) (Rep1 f b) +generic1 = iso GHC.from1 GHC.to1 +{-# INLINE generic1 #-} + +_V1 :: Lens (V1 s) (V1 t) a b +_V1 = lens absurd absurd where + absurd !_a = undefined +{-# INLINE _V1 #-} + +_U1 :: Iso (U1 p) (U1 q) () () +_U1 = iso (const ()) (const U1) +{-# INLINE _U1 #-} + +_Par1 :: Iso (Par1 p) (Par1 q) p q +_Par1 = iso unPar1 Par1 +{-# INLINE _Par1 #-} + +_Rec1 :: Iso (Rec1 f p) (Rec1 g q) (f p) (g q) +_Rec1 = iso unRec1 Rec1 +{-# INLINE _Rec1 #-} + +_K1 :: Iso (K1 i c p) (K1 j d q) c d +_K1 = iso unK1 K1 +{-# INLINE _K1 #-} + +_M1 :: Iso (M1 i c f p) (M1 j d g q) (f p) (g q) +_M1 = iso unM1 M1 +{-# INLINE _M1 #-} + +_L1 :: Prism ((a :+: c) t) ((b :+: c) t) (a t) (b t) +_L1 = prism L1 reviewer + where + reviewer (L1 v) = Right v + reviewer (R1 v) = Left (R1 v) +{-# INLINE _L1 #-} + +_R1 :: Prism ((c :+: a) t) ((c :+: b) t) (a t) (b t) +_R1 = prism R1 reviewer + where + reviewer (R1 v) = Right v + reviewer (L1 v) = Left (L1 v) +{-# INLINE _R1 #-} + +-- $setup +-- >>> import Optics.Core diff --git a/src/Numeric/Optics.hs b/src/Numeric/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Optics.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module: Numeric.Optics +-- Description: Optics for working with numeric types. +-- +module Numeric.Optics + ( base + , integral + -- * Predefined bases + , binary + , octal + , decimal + , hex + -- * Arithmetic lenses + , adding + , subtracting + , multiplying + , dividing + , exponentiating + , negated + , pattern Integral + ) where + +import Data.Char (chr, ord, isAsciiLower, isAsciiUpper, isDigit) +import Data.Maybe (fromMaybe) +import GHC.Stack +import Numeric (readInt, showIntAtBase) + +import Data.Tuple.Optics +import Optics.AffineFold +import Optics.Iso +import Optics.Optic +import Optics.Prism +import Optics.Review +import Optics.Setter + +-- | This 'Prism' can be used to model the fact that every 'Prelude.Integral' +-- type is a subset of 'Integer'. +-- +-- Embedding through the 'Prism' only succeeds if the 'Integer' would pass +-- through unmodified when re-extracted. +integral :: (Integral a, Integral b) => Prism Integer Integer a b +integral = prism toInteger $ \i -> let a = fromInteger i in + if toInteger a == i + then Right a + else Left i +{-# INLINE integral #-} + +-- | Pattern synonym that can be used to construct or pattern match on an +-- 'Integer' as if it were of any 'Prelude.Integral' type. +pattern Integral :: forall a. Integral a => a -> Integer +pattern Integral a <- (preview integral -> Just a) where + Integral a = review integral a + +-- | A prism that shows and reads integers in base-2 through base-36 +-- +-- Note: This is an improper prism, since leading 0s are stripped when reading. +-- +-- >>> "100" ^? base 16 +-- Just 256 +-- +-- >>> 1767707668033969 ^. re (base 36) +-- "helloworld" +base :: (HasCallStack, Integral a) => Int -> Prism' String a +base b + | b < 2 || b > 36 = error ("base: Invalid base " ++ show b) + | otherwise = prism intShow intRead + where + intShow n = showSigned' (showIntAtBase (toInteger b) intToDigit') (toInteger n) "" + + intRead s = + case readSigned' (readInt (fromIntegral b) (isDigit' b) digitToInt') s of + [(n,"")] -> Right n + _ -> Left s +{-# INLINE base #-} + +-- | Like 'Data.Char.intToDigit', but handles up to base-36 +intToDigit' :: HasCallStack => Int -> Char +intToDigit' i + | i >= 0 && i < 10 = chr (ord '0' + i) + | i >= 10 && i < 36 = chr (ord 'a' + i - 10) + | otherwise = error ("intToDigit': Invalid int " ++ show i) +{-# INLINE intToDigit' #-} + +-- | Like 'Data.Char.digitToInt', but handles up to base-36 +digitToInt' :: HasCallStack => Char -> Int +digitToInt' c = fromMaybe (error ("digitToInt': Invalid digit " ++ show c)) + (digitToIntMay c) +{-# INLINE digitToInt' #-} + +-- | A safe variant of 'digitToInt'' +digitToIntMay :: Char -> Maybe Int +digitToIntMay c + | isDigit c = Just (ord c - ord '0') + | isAsciiLower c = Just (ord c - ord 'a' + 10) + | isAsciiUpper c = Just (ord c - ord 'A' + 10) + | otherwise = Nothing +{-# INLINE digitToIntMay #-} + +-- | Select digits that fall into the given base +isDigit' :: Int -> Char -> Bool +isDigit' b c = case digitToIntMay c of + Just i -> i < b + _ -> False +{-# INLINE isDigit' #-} + +-- | A simpler variant of 'Numeric.showSigned' that only prepends a dash and +-- doesn't know about parentheses +showSigned' :: Real a => (a -> ShowS) -> a -> ShowS +showSigned' f n + | n < 0 = showChar '-' . f (negate n) + | otherwise = f n +{-# INLINE showSigned' #-} + +-- | A simpler variant of 'Numeric.readSigned' that supports any base, only +-- recognizes an initial dash and doesn't know about parentheses +readSigned' :: Real a => ReadS a -> ReadS a +readSigned' f ('-':xs) = f xs <&> over _1 negate +readSigned' f xs = f xs +{-# INLINE readSigned' #-} + +-- | @'binary' = 'base' 2@ +binary :: Integral a => Prism' String a +binary = base 2 +{-# INLINE binary #-} + +-- | @'octal' = 'base' 8@ +octal :: Integral a => Prism' String a +octal = base 8 +{-# INLINE octal #-} + +-- | @'decimal' = 'base' 10@ +decimal :: Integral a => Prism' String a +decimal = base 10 +{-# INLINE decimal #-} + +-- | @'hex' = 'base' 16@ +hex :: Integral a => Prism' String a +hex = base 16 +{-# INLINE hex #-} + +-- | @'adding' n = 'iso' (+n) (subtract n)@ +-- +-- >>> [1..3] ^.. traversed % adding 1000 +-- [1001,1002,1003] +adding :: Num a => a -> Iso' a a +adding n = iso (+n) (subtract n) +{-# INLINE adding #-} + +-- | @ +-- 'subtracting' n = 'iso' (subtract n) ((+n) +-- 'subtracting' n = 'Optics.Re.re' ('adding' n) +-- @ +subtracting :: Num a => a -> Iso' a a +subtracting n = iso (subtract n) (+n) +{-# INLINE subtracting #-} + +-- | @'multiplying' n = iso (*n) (/n)@ +-- +-- Note: This errors for n = 0 +-- +-- >>> 5 & multiplying 1000 %~ (+3) +-- 5.003 +-- +-- >>> let fahrenheit = multiplying (9/5) % adding 32 in 230 ^. re fahrenheit +-- 110.0 +multiplying :: (Fractional a, Eq a) => a -> Iso' a a +multiplying 0 = error "Numeric.Optics.multiplying: factor 0" +multiplying n = iso (*n) (/n) +{-# INLINE multiplying #-} + +-- | @ +-- 'dividing' n = 'iso' (/n) (*n) +-- 'dividing' n = 'Optics.Re.re' ('multiplying' n)@ +-- +-- Note: This errors for n = 0 +dividing :: (Fractional a, Eq a) => a -> Iso' a a +dividing 0 = error "Numeric.Optics.dividing: divisor 0" +dividing n = iso (/n) (*n) +{-# INLINE dividing #-} + +-- | @'exponentiating' n = 'iso' (**n) (**recip n)@ +-- +-- Note: This errors for n = 0 +-- +-- >>> au (coerced1 @Sum % re (exponentiating 2)) (foldMapOf each) (3,4) == 5 +-- True +exponentiating :: (Floating a, Eq a) => a -> Iso' a a +exponentiating 0 = error "Numeric.Optics.exponentiating: exponent 0" +exponentiating n = iso (**n) (**recip n) +{-# INLINE exponentiating #-} + +-- | @'negated' = 'iso' 'negate' 'negate'@ +-- +-- >>> au (coerced1 @Sum % negated) (foldMapOf each) (3,4) == 7 +-- True +-- +-- >>> au (coerced1 @Sum) (foldMapOf (each % negated)) (3,4) == -7 +-- True +negated :: Num a => Iso' a a +negated = iso negate negate +{-# INLINE negated #-} + +-- $setup +-- >>> import Data.Monoid +-- >>> import Optics.Core diff --git a/src/Optics/AffineFold.hs b/src/Optics/AffineFold.hs new file mode 100644 --- /dev/null +++ b/src/Optics/AffineFold.hs @@ -0,0 +1,114 @@ +-- | +-- Module: Optics.AffineFold +-- Description: A 'Optics.Fold.Fold' that contains at most one element. +-- +-- An 'AffineFold' is a 'Optics.Fold.Fold' that contains at most one +-- element, or a 'Optics.Getter.Getter' where the function may be +-- partial. +-- +module Optics.AffineFold + ( + -- * Formation + AffineFold + + -- * Introduction + , afolding + + -- * Elimination + , preview + , previews + + -- * Computation + -- | + -- + -- @ + -- 'preview' ('afolding' f) ≡ f + -- @ + + -- * Additional introduction forms + , filtered + + -- * Additional elimination forms + , isn't + + -- * Semigroup structure + , afailing + + -- * Subtyping + , An_AffineFold + -- | <> + ) where + +import Data.Maybe + +import Optics.Internal.Bi +import Optics.Internal.Profunctor +import Optics.Internal.Optic + +-- | Type synonym for an affine fold. +type AffineFold s a = Optic' An_AffineFold NoIx s a + +-- | Retrieve the value targeted by an 'AffineFold'. +-- +-- >>> let _Right = prism Right $ either (Left . Left) Right +-- +-- >>> preview _Right (Right 'x') +-- Just 'x' +-- +-- >>> preview _Right (Left 'y') +-- Nothing +-- +preview :: Is k An_AffineFold => Optic' k is s a -> s -> Maybe a +preview o = previews o id +{-# INLINE preview #-} + +-- | Retrieve a function of the value targeted by an 'AffineFold'. +previews :: Is k An_AffineFold => Optic' k is s a -> (a -> r) -> s -> Maybe r +previews o = \f -> runForgetM $ + getOptic (castOptic @An_AffineFold o) $ ForgetM (Just . f) +{-# INLINE previews #-} + +-- | Create an 'AffineFold' from a partial function. +-- +-- >>> preview (afolding listToMaybe) "foo" +-- Just 'f' +-- +afolding :: (s -> Maybe a) -> AffineFold s a +afolding f = Optic (contrabimap (\s -> maybe (Left s) Right (f s)) Left . right') +{-# INLINE afolding #-} + +-- | Filter result(s) of a fold that don't satisfy a predicate. +filtered :: (a -> Bool) -> AffineFold a a +filtered p = Optic (visit (\point f a -> if p a then f a else point a)) +{-# INLINE filtered #-} + +-- | Try the first 'AffineFold'. If it returns no entry, try the second one. +-- +-- >>> preview (ix 1 % re _Left `afailing` ix 2 % re _Right) [0,1,2,3] +-- Just (Left 1) +-- +-- >>> preview (ix 42 % re _Left `afailing` ix 2 % re _Right) [0,1,2,3] +-- Just (Right 2) +-- +-- /Note:/ There is no 'Optics.Fold.summing' equivalent, because @asumming = afailing@. +-- +afailing + :: (Is k An_AffineFold, Is l An_AffineFold) + => Optic' k is s a + -> Optic' l js s a + -> AffineFold s a +afailing a b = afolding $ \s -> maybe (preview b s) Just (preview a s) +infixl 3 `afailing` -- Same as (<|>) +{-# INLINE afailing #-} + +-- | Check to see if this 'AffineFold' doesn't match. +-- +-- >>> isn't _Just Nothing +-- True +-- +isn't :: Is k An_AffineFold => Optic' k is s a -> s -> Bool +isn't k s = not (isJust (preview k s)) +{-# INLINE isn't #-} + +-- $setup +-- >>> import Optics.Core diff --git a/src/Optics/AffineTraversal.hs b/src/Optics/AffineTraversal.hs new file mode 100644 --- /dev/null +++ b/src/Optics/AffineTraversal.hs @@ -0,0 +1,188 @@ +-- | +-- Module: Optics.AffineTraversal +-- Description: A 'Optics.Traversal.Traversal' that applies to at most one element. +-- +-- An 'AffineTraversal' is a 'Optics.Traversal.Traversal' that +-- applies to at most one element. +-- +-- These arise most frequently as the composition of a +-- 'Optics.Lens.Lens' with a 'Optics.Prism.Prism'. +-- +module Optics.AffineTraversal + ( + -- * Formation + AffineTraversal + , AffineTraversal' + + -- * Introduction + , atraversal + + -- * Elimination + -- | An 'AffineTraversal' is in particular an 'Optics.AffineFold.AffineFold' + -- and a 'Optics.Setter.Setter', therefore you can specialise types to obtain: + -- + -- @ + -- 'Optics.AffineFold.preview' :: 'AffineTraversal' s t a b -> s -> Maybe a + -- @ + -- + -- @ + -- 'Optics.Setter.over' :: 'AffineTraversal' s t a b -> (a -> b) -> s -> t + -- 'Optics.Setter.set' :: 'AffineTraversal' s t a b -> b -> s -> t + -- @ + , matching + + -- * Computation + -- | + -- + -- @ + -- 'matching' ('atraversal' f g) ≡ f + -- 'Data.Either.isRight' (f s) => 'Optics.Setter.set' ('atraversal' f g) b s ≡ g s b + -- @ + + -- * Additional introduction forms + -- | See 'Optics.Cons.Core._head', 'Optics.Cons.Core._tail', + -- 'Optics.Cons.Core._init' and 'Optics.Cons.Core._last' for + -- 'AffineTraversal's for container types. + , unsafeFiltered + + -- * Additional elimination forms + , withAffineTraversal + + -- * Subtyping + , An_AffineTraversal + -- | <> + + -- * van Laarhoven encoding + , AffineTraversalVL + , AffineTraversalVL' + , atraversalVL + , toAtraversalVL + ) + where + +import Optics.Internal.Concrete +import Optics.Internal.Optic +import Optics.Internal.Profunctor + +-- | Type synonym for a type-modifying affine traversal. +type AffineTraversal s t a b = Optic An_AffineTraversal NoIx s t a b + +-- | Type synonym for a type-preserving affine traversal. +type AffineTraversal' s a = Optic' An_AffineTraversal NoIx s a + +-- | Type synonym for a type-modifying van Laarhoven affine traversal. +-- +-- Note: this isn't exactly van Laarhoven representation as there is +-- no @Pointed@ class (which would be a superclass of 'Applicative' +-- that contains 'pure' but not '<*>'). You can interpret the first +-- argument as a dictionary of @Pointed@ that supplies the @point@ +-- function (i.e. the implementation of 'pure'). +-- +-- A 'Optics.Traversal.TraversalVL' has 'Applicative' available and +-- hence can combine the effects arising from multiple elements using +-- '<*>'. In contrast, an 'AffineTraversalVL' has no way to combine +-- effects from multiple elements, so it must act on at most one +-- element. (It can act on none at all thanks to the availability of +-- @point@.) +-- +type AffineTraversalVL s t a b = + forall f. Functor f => (forall r. r -> f r) -> (a -> f b) -> s -> f t + +-- | Type synonym for a type-preserving van Laarhoven affine traversal. +type AffineTraversalVL' s a = AffineTraversalVL s s a a + +-- | Build an affine traversal from a matcher and an updater. +-- +-- If you want to build an 'AffineTraversal' from the van Laarhoven +-- representation, use 'atraversalVL'. +atraversal :: (s -> Either t a) -> (s -> b -> t) -> AffineTraversal s t a b +atraversal match update = Optic $ + -- Do not define atraversal in terms of atraversalVL, mixing profunctor-style + -- definitions with VL style implementation can lead to subpar generated code. + dimap (\s -> (match s, update s)) + (\(etb, f) -> either id f etb) + . first' + . right' +{-# INLINE atraversal #-} + +-- | Work with an affine traversal as a matcher and an updater. +withAffineTraversal + :: Is k An_AffineTraversal + => Optic k is s t a b + -> ((s -> Either t a) -> (s -> b -> t) -> r) + -> r +withAffineTraversal o = \k -> + case getOptic (castOptic @An_AffineTraversal o) (AffineMarket (\_ b -> b) Right) of + AffineMarket update match -> k match update +{-# INLINE withAffineTraversal #-} + +-- | Build an affine traversal from the van Laarhoven representation. +-- +-- Example: +-- +-- >>> :{ +-- azSnd = atraversalVL $ \point f ab@(a, b) -> +-- if a >= 'a' && a <= 'z' +-- then (a, ) <$> f b +-- else point ab +-- :} +-- +-- >>> preview azSnd ('a', "Hi") +-- Just "Hi" +-- +-- >>> preview azSnd ('@', "Hi") +-- Nothing +-- +-- >>> over azSnd (++ "!!!") ('f', "Hi") +-- ('f',"Hi!!!") +-- +-- >>> set azSnd "Bye" ('Y', "Hi") +-- ('Y',"Hi") +-- +atraversalVL :: AffineTraversalVL s t a b -> AffineTraversal s t a b +atraversalVL f = Optic (visit f) +{-# INLINE atraversalVL #-} + +-- | Convert an affine traversal to its van Laarhoven representation. +toAtraversalVL + :: Is k An_AffineTraversal + => Optic k is s t a b + -> AffineTraversalVL s t a b +toAtraversalVL o point = + runStarA . getOptic (castOptic @An_AffineTraversal o) . StarA point +{-# INLINE toAtraversalVL #-} + +-- | Retrieve the value targeted by an 'AffineTraversal' or return the original +-- value while allowing the type to change if it does not match. +-- +-- @ +-- 'Optics.AffineFold.preview' o ≡ 'either' ('const' 'Nothing') 'id' . 'matching' o +-- @ +matching :: Is k An_AffineTraversal => Optic k is s t a b -> s -> Either t a +matching o = withAffineTraversal o $ \match _ -> match +{-# INLINE matching #-} + +-- | Filter result(s) of a traversal that don't satisfy a predicate. +-- +-- /Note:/ This is /not/ a legal 'Optics.Traversal.Traversal', unless you are +-- very careful not to invalidate the predicate on the target. +-- +-- As a counter example, consider that given @evens = 'unsafeFiltered' 'even'@ +-- the second 'Optics.Traversal.Traversal' law is violated: +-- +-- @ +-- 'Optics.Setter.over' evens 'succ' '.' 'Optics.over' evens 'succ' '/=' 'Optics.Setter.over' evens ('succ' '.' 'succ') +-- @ +-- +-- So, in order for this to qualify as a legal 'Optics.Traversal.Traversal' you +-- can only use it for actions that preserve the result of the predicate! +-- +-- For a safe variant see 'Optics.IxTraversal.indices' (or +-- 'Optics.AffineFold.filtered' for read-only optics). +-- +unsafeFiltered :: (a -> Bool) -> AffineTraversal' a a +unsafeFiltered p = atraversalVL (\point f a -> if p a then f a else point a) +{-# INLINE unsafeFiltered #-} + +-- $setup +-- >>> import Optics.Core diff --git a/src/Optics/Arrow.hs b/src/Optics/Arrow.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Arrow.hs @@ -0,0 +1,119 @@ +-- | +-- Module: Optics.Arrow +-- Description: Turn optics into arrow transformers. +module Optics.Arrow + ( ArrowOptic(..) + , assignA + ) where + +import Control.Arrow +import Data.Coerce +import qualified Control.Category as C + +import Optics.AffineTraversal +import Optics.Prism +import Optics.Setter +import Optics.Internal.Optic +import Optics.Internal.Profunctor +import Optics.Internal.Utils + +newtype WrappedArrow p i a b = WrapArrow { unwrapArrow :: p a b } + +instance C.Category p => C.Category (WrappedArrow p i) where + WrapArrow f . WrapArrow g = WrapArrow (f C.. g) + id = WrapArrow C.id + {-# INLINE (.) #-} + {-# INLINE id #-} + +instance Arrow p => Arrow (WrappedArrow p i) where + arr = WrapArrow #. arr + first = WrapArrow #. first .# unwrapArrow + second = WrapArrow #. second .# unwrapArrow + WrapArrow a *** WrapArrow b = WrapArrow (a *** b) + WrapArrow a &&& WrapArrow b = WrapArrow (a &&& b) + {-# INLINE arr #-} + {-# INLINE first #-} + {-# INLINE second #-} + {-# INLINE (***) #-} + {-# INLINE (&&&) #-} + +instance Arrow p => Profunctor (WrappedArrow p) where + dimap f g k = arr f >>> k >>> arr g + lmap f k = arr f >>> k + rmap g k = k >>> arr g + {-# INLINE dimap #-} + {-# INLINE lmap #-} + {-# INLINE rmap #-} + + lcoerce' = lmap coerce + rcoerce' = rmap coerce + {-# INLINE lcoerce' #-} + {-# INLINE rcoerce' #-} + +instance Arrow p => Strong (WrappedArrow p) where + first' (WrapArrow k) = WrapArrow (first k) + second' (WrapArrow k) = WrapArrow (second k) + {-# INLINE first' #-} + {-# INLINE second' #-} + +instance ArrowChoice p => Choice (WrappedArrow p) where + left' (WrapArrow k) = WrapArrow (left k) + right' (WrapArrow k) = WrapArrow (right k) + {-# INLINE left' #-} + {-# INLINE right' #-} + +instance ArrowChoice p => Visiting (WrappedArrow p) + +class Arrow arr => ArrowOptic k arr where + -- | Turn an optic into an arrow transformer. + overA :: Optic k is s t a b -> arr a b -> arr s t + +instance Arrow arr => ArrowOptic An_Iso arr where + overA = overA__ + {-# INLINE overA #-} + +instance Arrow arr => ArrowOptic A_Lens arr where + overA = overA__ + {-# INLINE overA #-} + +instance ArrowChoice arr => ArrowOptic A_Prism arr where + overA = overA__ + {-# INLINE overA #-} + +instance ArrowChoice arr => ArrowOptic An_AffineTraversal arr where + overA = overA__ + {-# INLINE overA #-} + +-- | Run an arrow command and use the output to set all the targets of an optic +-- to the result. +-- +-- @ +-- runKleisli action ((), (), ()) where +-- action = assignA _1 (Kleisli (const getVal1)) +-- \>>> assignA _2 (Kleisli (const getVal2)) +-- \>>> assignA _3 (Kleisli (const getVal3)) +-- getVal1 :: Either String Int +-- getVal1 = ... +-- getVal2 :: Either String Bool +-- getVal2 = ... +-- getVal3 :: Either String Char +-- getVal3 = ... +-- @ +-- +-- has the type @'Either' 'String' ('Int', 'Bool', 'Char')@ +assignA + :: (Is k A_Setter, Arrow arr) + => Optic k is s t a b + -> arr s b -> arr s t +assignA o p = arr (flip $ set o) &&& p >>> arr (uncurry id) +{-# INLINE assignA #-} + +---------------------------------------- + +-- | Internal implementation of overA. +overA__ + :: (p ~ WrappedArrow arr, Profunctor p, Constraints k p) + => Optic k is s t a b + -> arr a b -> arr s t +overA__ o = unwrapArrow #. getOptic o .# WrapArrow +{-# INLINE overA__ #-} diff --git a/src/Optics/At/Core.hs b/src/Optics/At/Core.hs new file mode 100644 --- /dev/null +++ b/src/Optics/At/Core.hs @@ -0,0 +1,485 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module: Optics.At.Core +-- Description: Optics for 'Map' and 'Set'-like containers. +-- +-- This module provides optics for 'Map' and '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] +-- +-- The @Optics.At@ module from @optics-extra@ provides additional instances of +-- the classes defined here. +-- +module Optics.At.Core + ( + -- * Type families + Index + , IxValue + + -- * Ixed + , Ixed(..) + , ixAt + + -- * At + , At(..) + , at' + , sans + + -- * Contains + , Contains(..) + ) where + +import Data.Array.IArray as Array +import Data.Array.Unboxed +import Data.Complex +import Data.Functor.Identity +import Data.IntMap as IntMap +import Data.IntSet as IntSet +import Data.List.NonEmpty as NonEmpty +import Data.Map as Map +import Data.Sequence as Seq +import Data.Set as Set +import Data.Tree + +import Data.Maybe.Optics +import Optics.AffineTraversal +import Optics.Iso +import Optics.Lens +import Optics.Optic +import Optics.Setter + +-- | Type family that takes a key-value container type and returns the type of +-- keys (indices) into the container, for example @'Index' ('Map' k a) ~ k@. +-- This is shared by 'Ixed', 'At' and 'Contains'. +type family Index (s :: *) :: * +type instance Index (e -> a) = e +type instance Index IntSet = Int +type instance Index (Set a) = a +type instance Index [a] = Int +type instance Index (NonEmpty a) = Int +type instance Index (Seq a) = Int +type instance Index (a,b) = Int +type instance Index (a,b,c) = Int +type instance Index (a,b,c,d) = Int +type instance Index (a,b,c,d,e) = Int +type instance Index (a,b,c,d,e,f) = Int +type instance Index (a,b,c,d,e,f,g) = Int +type instance Index (a,b,c,d,e,f,g,h) = Int +type instance Index (a,b,c,d,e,f,g,h,i) = Int +type instance Index (IntMap a) = Int +type instance Index (Map k a) = k +type instance Index (Array.Array i e) = i +type instance Index (UArray i e) = i +type instance Index (Complex a) = Int +type instance Index (Identity a) = () +type instance Index (Maybe a) = () +type instance Index (Tree a) = [Int] + +-- | This class provides a simple 'Lens' that lets you view (and modify) +-- information about whether or not a container contains a given 'Index'. +-- Instances are provided for 'Set'-like containers only. +class Contains m where + -- | + -- >>> IntSet.fromList [1,2,3,4] ^. contains 3 + -- True + -- + -- >>> IntSet.fromList [1,2,3,4] ^. contains 5 + -- False + -- + -- >>> IntSet.fromList [1,2,3,4] & contains 3 .~ False + -- fromList [1,2,4] + contains :: Index m -> Lens' m Bool + +instance Contains IntSet where + contains k = lensVL $ \f s -> f (IntSet.member k s) <&> \b -> + if b then IntSet.insert k s else IntSet.delete k s + {-# INLINE contains #-} + +instance Ord a => Contains (Set a) where + contains k = lensVL $ \f s -> f (Set.member k s) <&> \b -> + if b then Set.insert k s else Set.delete k s + {-# INLINE contains #-} + +-- | Type family that takes a key-value container type and returns the type of +-- values stored in the container, for example @'IxValue' ('Map' k a) ~ a@. This +-- is shared by both 'Ixed' and 'At'. +type family IxValue (m :: *) :: * + +-- | Provides a simple 'AffineTraversal' lets you traverse the value at a given +-- key in a 'Map' or element at an ordinal position in a list or 'Seq'. +class Ixed m where + -- | /NB:/ Setting the value of this 'AffineTraversal' will only set the value + -- in 'at' if it is already present. + -- + -- If you want to be able to insert /missing/ values, you want 'at'. + -- + -- >>> [1,2,3,4] & ix 2 %~ (*10) + -- [1,2,30,4] + -- + -- >>> "abcd" & ix 2 .~ 'e' + -- "abed" + -- + -- >>> "abcd" ^? ix 2 + -- Just 'c' + -- + -- >>> [] ^? ix 2 + -- Nothing + ix :: Index m -> AffineTraversal' m (IxValue m) + default ix :: At m => Index m -> AffineTraversal' m (IxValue m) + ix = ixAt + {-# INLINE ix #-} + +-- | A definition of 'ix' for types with an 'At' instance. This is the default +-- if you don't specify a definition for 'ix'. +ixAt :: At m => Index m -> AffineTraversal' m (IxValue m) +ixAt = \i -> at i % _Just +{-# INLINE ixAt #-} + +type instance IxValue (e -> a) = a +instance Eq e => Ixed (e -> a) where + ix e = atraversalVL $ \_ p f -> p (f e) <&> \a e' -> if e == e' then a else f e' + {-# INLINE ix #-} + +type instance IxValue (Maybe a) = a +instance Ixed (Maybe a) where + ix () = castOptic @An_AffineTraversal _Just + {-# INLINE ix #-} + +type instance IxValue [a] = a +instance Ixed [a] where + ix k = atraversalVL (ixListVL k) + {-# INLINE ix #-} + +type instance IxValue (NonEmpty a) = a +instance Ixed (NonEmpty a) where + ix k = atraversalVL $ \point f xs0 -> + if k < 0 + then point xs0 + else let go (a:|as) 0 = f a <&> (:|as) + go (a:|as) i = (a:|) <$> ixListVL (i - 1) point f as + in go xs0 k + {-# INLINE ix #-} + +type instance IxValue (Identity a) = a +instance Ixed (Identity a) where + ix () = atraversalVL $ \_ f (Identity a) -> Identity <$> f a + {-# INLINE ix #-} + +type instance IxValue (Tree a) = a +instance Ixed (Tree a) where + ix xs0 = atraversalVL $ \point f -> + let go [] (Node a as) = f a <&> \a' -> Node a' as + go (i:is) t@(Node a as) + | i < 0 = point t + | otherwise = Node a <$> ixListVL i point (go is) as + in go xs0 + {-# INLINE ix #-} + +type instance IxValue (Seq a) = a +instance Ixed (Seq a) where + ix i = atraversalVL $ \point f m -> + if 0 <= i && i < Seq.length m + then f (Seq.index m i) <&> \a -> Seq.update i a m + else point m + {-# INLINE ix #-} + +type instance IxValue (IntMap a) = a +-- Default implementation uses IntMap.alterF +instance Ixed (IntMap a) + +type instance IxValue (Map k a) = a +-- Default implementation uses Map.alterF +instance Ord k => Ixed (Map k a) + +type instance IxValue (Set k) = () +instance Ord k => Ixed (Set k) where + ix k = atraversalVL $ \point f m -> + if Set.member k m + then f () <&> \() -> Set.insert k m + else point m + {-# INLINE ix #-} + +type instance IxValue IntSet = () +instance Ixed IntSet where + ix k = atraversalVL $ \point f m -> + if IntSet.member k m + then f () <&> \() -> IntSet.insert k m + else point m + {-# INLINE ix #-} + +type instance IxValue (Array.Array i e) = e +-- | +-- @ +-- arr 'Array.!' i ≡ arr 'Optics.Operators.^.' 'ix' i +-- arr '//' [(i,e)] ≡ 'ix' i 'Optics.Operators..~' e '$' arr +-- @ +instance Ix i => Ixed (Array.Array i e) where + ix i = atraversalVL $ \point f arr -> + if inRange (bounds arr) i + then f (arr Array.! i) <&> \e -> arr Array.// [(i,e)] + else point arr + {-# INLINE ix #-} + +type instance IxValue (UArray i e) = e +-- | +-- @ +-- arr 'Array.!' i ≡ arr 'Optics.Operators.^.' 'ix' i +-- arr '//' [(i,e)] ≡ 'ix' i 'Optics.Operators..~' e '$' arr +-- @ +instance (IArray UArray e, Ix i) => Ixed (UArray i e) where + ix i = atraversalVL $ \point f arr -> + if inRange (bounds arr) i + then f (arr Array.! i) <&> \e -> arr Array.// [(i,e)] + else point arr + {-# INLINE ix #-} + +-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a) a@ +type instance IxValue (a0, a2) = a0 +instance (a0 ~ a1) => Ixed (a0, a1) where + ix i = atraversalVL $ \point f ~s@(a0, a1) -> + case i of + 0 -> (,a1) <$> f a0 + 1 -> (a0,) <$> f a1 + _ -> point s + +-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a, a) a@ +type instance IxValue (a0, a1, a2) = a0 +instance (a0 ~ a1, a0 ~ a2) => Ixed (a0, a1, a2) where + ix i = atraversalVL $ \point f ~s@(a0, a1, a2) -> + case i of + 0 -> (,a1,a2) <$> f a0 + 1 -> (a0,,a2) <$> f a1 + 2 -> (a0,a1,) <$> f a2 + _ -> point s + +-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a, a, a) a@ +type instance IxValue (a0, a1, a2, a3) = a0 +instance (a0 ~ a1, a0 ~ a2, a0 ~ a3) => Ixed (a0, a1, a2, a3) where + ix i = atraversalVL $ \point f ~s@(a0, a1, a2, a3) -> + case i of + 0 -> (,a1,a2,a3) <$> f a0 + 1 -> (a0,,a2,a3) <$> f a1 + 2 -> (a0,a1,,a3) <$> f a2 + 3 -> (a0,a1,a2,) <$> f a3 + _ -> point s + +-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a, a, a, a) a@ +type instance IxValue (a0, a1, a2, a3, a4) = a0 +instance (a0 ~ a1, a0 ~ a2, a0 ~ a3, a0 ~ a4) => Ixed (a0, a1, a2, a3, a4) where + ix i = atraversalVL $ \point f ~s@(a0, a1, a2, a3, a4) -> + case i of + 0 -> (,a1,a2,a3,a4) <$> f a0 + 1 -> (a0,,a2,a3,a4) <$> f a1 + 2 -> (a0,a1,,a3,a4) <$> f a2 + 3 -> (a0,a1,a2,,a4) <$> f a3 + 4 -> (a0,a1,a2,a3,) <$> f a4 + _ -> point s + +-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a, a, a, a, a) a@ +type instance IxValue (a0, a1, a2, a3, a4, a5) = a0 +instance + (a0 ~ a1, a0 ~ a2, a0 ~ a3, a0 ~ a4, a0 ~ a5 + ) => Ixed (a0, a1, a2, a3, a4, a5) where + ix i = atraversalVL $ \point f ~s@(a0, a1, a2, a3, a4, a5) -> + case i of + 0 -> (,a1,a2,a3,a4,a5) <$> f a0 + 1 -> (a0,,a2,a3,a4,a5) <$> f a1 + 2 -> (a0,a1,,a3,a4,a5) <$> f a2 + 3 -> (a0,a1,a2,,a4,a5) <$> f a3 + 4 -> (a0,a1,a2,a3,,a5) <$> f a4 + 5 -> (a0,a1,a2,a3,a4,) <$> f a5 + _ -> point s + +-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a, a, a, a, a, a) a@ +type instance IxValue (a0, a1, a2, a3, a4, a5, a6) = a0 +instance + (a0 ~ a1, a0 ~ a2, a0 ~ a3, a0 ~ a4, a0 ~ a5, a0 ~ a6 + ) => Ixed (a0, a1, a2, a3, a4, a5, a6) where + ix i = atraversalVL $ \point f ~s@(a0, a1, a2, a3, a4, a5, a6) -> + case i of + 0 -> (,a1,a2,a3,a4,a5,a6) <$> f a0 + 1 -> (a0,,a2,a3,a4,a5,a6) <$> f a1 + 2 -> (a0,a1,,a3,a4,a5,a6) <$> f a2 + 3 -> (a0,a1,a2,,a4,a5,a6) <$> f a3 + 4 -> (a0,a1,a2,a3,,a5,a6) <$> f a4 + 5 -> (a0,a1,a2,a3,a4,,a6) <$> f a5 + 6 -> (a0,a1,a2,a3,a4,a5,) <$> f a6 + _ -> point s + +-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a, a, a, a, a, a, a) a@ +type instance IxValue (a0, a1, a2, a3, a4, a5, a6, a7) = a0 +instance + (a0 ~ a1, a0 ~ a2, a0 ~ a3, a0 ~ a4, a0 ~ a5, a0 ~ a6, a0 ~ a7 + ) => Ixed (a0, a1, a2, a3, a4, a5, a6, a7) where + ix i = atraversalVL $ \point f ~s@(a0, a1, a2, a3, a4, a5, a6, a7) -> + case i of + 0 -> (,a1,a2,a3,a4,a5,a6,a7) <$> f a0 + 1 -> (a0,,a2,a3,a4,a5,a6,a7) <$> f a1 + 2 -> (a0,a1,,a3,a4,a5,a6,a7) <$> f a2 + 3 -> (a0,a1,a2,,a4,a5,a6,a7) <$> f a3 + 4 -> (a0,a1,a2,a3,,a5,a6,a7) <$> f a4 + 5 -> (a0,a1,a2,a3,a4,,a6,a7) <$> f a5 + 6 -> (a0,a1,a2,a3,a4,a5,,a7) <$> f a6 + 7 -> (a0,a1,a2,a3,a4,a5,a6,) <$> f a7 + _ -> point s + +-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a, a, a, a, a, a, a, a) a@ +type instance IxValue (a0, a1, a2, a3, a4, a5, a6, a7, a8) = a0 +instance + (a0 ~ a1, a0 ~ a2, a0 ~ a3, a0 ~ a4, a0 ~ a5, a0 ~ a6, a0 ~ a7, a0 ~ a8 + ) => Ixed (a0, a1, a2, a3, a4, a5, a6, a7, a8) where + ix i = atraversalVL $ \point f ~s@(a0, a1, a2, a3, a4, a5, a6, a7, a8) -> + case i of + 0 -> (,a1,a2,a3,a4,a5,a6,a7,a8) <$> f a0 + 1 -> (a0,,a2,a3,a4,a5,a6,a7,a8) <$> f a1 + 2 -> (a0,a1,,a3,a4,a5,a6,a7,a8) <$> f a2 + 3 -> (a0,a1,a2,,a4,a5,a6,a7,a8) <$> f a3 + 4 -> (a0,a1,a2,a3,,a5,a6,a7,a8) <$> f a4 + 5 -> (a0,a1,a2,a3,a4,,a6,a7,a8) <$> f a5 + 6 -> (a0,a1,a2,a3,a4,a5,,a7,a8) <$> f a6 + 7 -> (a0,a1,a2,a3,a4,a5,a6,,a8) <$> f a7 + 8 -> (a0,a1,a2,a3,a4,a5,a6,a7,) <$> f a8 + _ -> point s + +-- | 'At' provides a 'Lens' that can be used to read, write or delete the value +-- associated with a key in a 'Map'-like container on an ad hoc basis. +-- +-- An instance of 'At' should satisfy: +-- +-- @ +-- 'ix' k ≡ 'at' k '%' '_Just' +-- @ +class Ixed m => At m where + -- | + -- >>> Map.fromList [(1,"world")] ^. at 1 + -- Just "world" + -- + -- >>> at 1 ?~ "hello" $ Map.empty + -- fromList [(1,"hello")] + -- + -- /Note:/ Usage of this function might introduce space leaks if you're not + -- careful to make sure that values put inside the 'Just' constructor are + -- evaluated. To force the values and avoid such leaks, use 'at'' instead. + -- + -- /Note:/ 'Map'-like containers form a reasonable instance, but not + -- 'Array'-like ones, where you cannot satisfy the 'Lens' laws. + at :: Index m -> Lens' m (Maybe (IxValue m)) + +-- | Version of 'at' strict in the value inside the `Just` constructor. +-- +-- Example: +-- +-- >>> (at () .~ Just (error "oops") $ Nothing) `seq` () +-- () +-- +-- >>> (at' () .~ Just (error "oops") $ Nothing) `seq` () +-- *** Exception: oops +-- ... +-- +-- >>> view (at ()) (Just $ error "oops") `seq` () +-- () +-- +-- >>> view (at' ()) (Just $ error "oops") `seq` () +-- *** Exception: oops +-- ... +-- +-- It also works as expected for other data structures: +-- +-- >>> (at 1 .~ Just (error "oops") $ Map.empty) `seq` () +-- () +-- +-- >>> (at' 1 .~ Just (error "oops") $ Map.empty) `seq` () +-- *** Exception: oops +-- ... +at' :: At m => Index m -> Lens' m (Maybe (IxValue m)) +at' k = at k % iso f f + where + f = \case + Just !x -> Just x + Nothing -> Nothing +{-# INLINE at' #-} + +-- | Delete the value associated with a key in a 'Map'-like container +-- +-- @ +-- 'sans' k = 'at' k 'Optics.Operators..~' Nothing +-- @ +sans :: At m => Index m -> m -> m +sans k = set (at k) Nothing +{-# INLINE sans #-} + +instance At (Maybe a) where + at () = lensVL id + {-# INLINE at #-} + +instance At (IntMap a) where +#if MIN_VERSION_containers(0,5,8) + at k = lensVL $ \f -> IntMap.alterF f k +#else + at k = lensVL $ \f m -> + let mv = IntMap.lookup k m + in f mv <&> \r -> case r of + Nothing -> maybe m (const (IntMap.delete k m)) mv + Just v' -> IntMap.insert k v' m +#endif + {-# INLINE at #-} + +instance Ord k => At (Map k a) where +#if MIN_VERSION_containers(0,5,8) + at k = lensVL $ \f -> Map.alterF f k +#else + at k = lensVL $ \f m -> + let mv = Map.lookup k m + in f mv <&> \r -> case r of + Nothing -> maybe m (const (Map.delete k m)) mv + Just v' -> Map.insert k v' m +#endif + {-# INLINE at #-} + +instance At IntSet where + at k = lensVL $ \f m -> + let mv = if IntSet.member k m + then Just () + else Nothing + in f mv <&> \r -> case r of + Nothing -> maybe m (const (IntSet.delete k m)) mv + Just () -> IntSet.insert k m + {-# INLINE at #-} + +instance Ord k => At (Set k) where + at k = lensVL $ \f m -> + let mv = if Set.member k m + then Just () + else Nothing + in f mv <&> \r -> case r of + Nothing -> maybe m (const (Set.delete k m)) mv + Just () -> Set.insert k m + {-# INLINE at #-} + +---------------------------------------- +-- Internal + +ixListVL :: Int -> AffineTraversalVL' [a] a +ixListVL k point f xs0 = + if k < 0 + then point xs0 + else let go [] _ = point [] + go (a:as) 0 = f a <&> (:as) + go (a:as) i = (a:) <$> (go as $! i - 1) + in go xs0 k +{-# INLINE ixListVL #-} + +-- $setup +-- >>> import Optics.Core diff --git a/src/Optics/Coerce.hs b/src/Optics/Coerce.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Coerce.hs @@ -0,0 +1,60 @@ +-- | +-- Module: Optics.Coerce +-- Description: Operators to 'coerce' the type parameters of 'Optic'. +-- +-- This module defines operations to 'coerce' the type parameters of optics to +-- a representationally equal type. For example, if we have +-- +-- > newtype MkInt = MkInt Int +-- +-- and +-- +-- > l :: Lens' S Int +-- +-- then +-- +-- > coerceA @Int @MkInt l :: Lens' S MkInt +-- +module Optics.Coerce + ( coerceS + , coerceT + , coerceA + , coerceB + ) where + +import Data.Coerce + +import Optics.Internal.Optic +import Optics.Internal.Profunctor + +-- | Lift 'coerce' to the @s@ parameter of an optic. +coerceS + :: Coercible s s' + => Optic k is s t a b + -> Optic k is s' t a b +coerceS = \(Optic o) -> Optic (lcoerce . o) +{-# INLINE coerceS #-} + +-- | Lift 'coerce' to the @t@ parameter of an optic. +coerceT + :: Coercible t t' + => Optic k is s t a b + -> Optic k is s t' a b +coerceT = \(Optic o) -> Optic (rcoerce . o) +{-# INLINE coerceT #-} + +-- | Lift 'coerce' to the @a@ parameter of an optic. +coerceA + :: Coercible a a' + => Optic k is s t a b + -> Optic k is s t a' b +coerceA = \(Optic o) -> Optic (o . lcoerce) +{-# INLINE coerceA #-} + +-- | Lift 'coerce' to the @b@ parameter of an optic. +coerceB + :: Coercible b b' + => Optic k is s t a b + -> Optic k is s t a b' +coerceB = \(Optic o) -> Optic (o . rcoerce) +{-# INLINE coerceB #-} diff --git a/src/Optics/Cons/Core.hs b/src/Optics/Cons/Core.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Cons/Core.hs @@ -0,0 +1,338 @@ +-- | +-- Module: Optics.Cons.Core +-- 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. +-- +-- Note that orphan instances for these classes are defined in the @Optics.Cons@ +-- module from @optics-extra@, so if you are not simply depending on @optics@ +-- you may wish to import that module instead. +-- +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +module Optics.Cons.Core + ( + -- * Cons + Cons(..) + , (<|) + , cons + , uncons + , _head, _tail + , pattern (:<) + -- * Snoc + , Snoc(..) + , (|>) + , snoc + , unsnoc + , _init, _last + , pattern (:>) + ) where + +import Control.Applicative (ZipList(..)) +import Data.Coerce +import Data.Sequence hiding ((<|), (|>), (:<), (:>)) +import qualified Data.Sequence as Seq + +import Data.Tuple.Optics +import Optics.AffineFold +import Optics.AffineTraversal +import Optics.Coerce +import Optics.Optic +import Optics.Prism +import Optics.Review + +infixr 5 <|, `cons` +infixl 5 |>, `snoc` + +-- | Pattern synonym for matching on the leftmost element of a structure. +-- +-- >>> case ['a','b','c'] of (x :< _) -> x +-- 'a' +-- +pattern (:<) :: forall s a. Cons s s a a => a -> s -> s +pattern (:<) a s <- (preview _Cons -> Just (a, s)) where + (:<) a s = review _Cons (a, s) + +infixr 5 :< +infixl 5 :> + +-- | Pattern synonym for matching on the rightmost element of a structure. +-- +-- >>> case ['a','b','c'] of (_ :> x) -> x +-- 'c' +-- +pattern (:>) :: forall s a. Snoc s s a a => s -> a -> s +pattern (:>) s a <- (preview _Snoc -> Just (s, a)) where + (:>) a s = review _Snoc (a, s) + +------------------------------------------------------------------------------ +-- Cons +------------------------------------------------------------------------------ + +-- | This class provides a way to attach or detach elements on the left +-- side of a structure in a flexible manner. +class Cons s t a b | s -> a, t -> b, s b -> t, t a -> s where + -- | + -- + -- @ + -- '_Cons' :: 'Prism' [a] [b] (a, [a]) (b, [b]) + -- '_Cons' :: 'Prism' ('Seq' a) ('Seq' b) (a, 'Seq' a) (b, 'Seq' b) + -- '_Cons' :: 'Prism' (Vector a) (Vector b) (a, Vector a) (b, Vector b) + -- '_Cons' :: 'Prism'' 'String' ('Char', 'String') + -- '_Cons' :: 'Prism'' Text ('Char', Text) + -- '_Cons' :: 'Prism'' ByteString ('Data.Word.Word8', ByteString) + -- @ + _Cons :: Prism s t (a, s) (b, t) + +instance Cons [a] [b] a b where + _Cons = prism (uncurry (:)) $ \ aas -> case aas of + (a:as) -> Right (a, as) + [] -> Left [] + {-# INLINE _Cons #-} + +instance Cons (ZipList a) (ZipList b) a b where + _Cons = coerceS . coerceT . coerceA . coerceB $ listCons + where + listCons :: Prism [a] [b] (a, [a]) (b, [b]) + listCons = _Cons + + {-# INLINE _Cons #-} + +instance Cons (Seq a) (Seq b) a b where + _Cons = prism (uncurry (Seq.<|)) $ \aas -> case viewl aas of + a Seq.:< as -> Right (a, as) + EmptyL -> Left mempty + {-# INLINE _Cons #-} + +-- | 'cons' an element onto a container. +-- +-- This is an infix alias for 'cons'. +-- +-- >>> 1 <| [] +-- [1] +-- +-- >>> 'a' <| "bc" +-- "abc" +-- +-- >>> 1 <| [] +-- [1] +-- +-- >>> 1 <| [2, 3] +-- [1,2,3] +(<|) :: Cons s s a a => a -> s -> s +(<|) = curry (review _Cons) +{-# INLINE (<|) #-} + +-- | 'cons' an element onto a container. +-- +-- >>> cons 'a' "" +-- "a" +-- +-- >>> cons 'a' "bc" +-- "abc" +cons :: Cons s s a a => a -> s -> s +cons = curry (review _Cons) +{-# INLINE cons #-} + +-- | Attempt to extract the left-most element from a container, and a version of +-- the container without that element. +-- +-- >>> uncons [] +-- Nothing +-- +-- >>> uncons [1, 2, 3] +-- Just (1,[2,3]) +uncons :: Cons s s a a => s -> Maybe (a, s) +uncons = preview _Cons +{-# INLINE uncons #-} + +-- | An 'AffineTraversal' reading and writing to the 'head' of a /non-empty/ +-- container. +-- +-- >>> "abc" ^? _head +-- Just 'a' +-- +-- >>> "abc" & _head .~ 'd' +-- "dbc" +-- +-- >>> [1,2,3] & _head %~ (*10) +-- [10,2,3] +-- +-- >>> [] & _head %~ absurd +-- [] +-- +-- >>> [1,2,3] ^? _head +-- Just 1 +-- +-- >>> [] ^? _head +-- Nothing +-- +-- >>> [1,2] ^? _head +-- Just 1 +-- +-- >>> [] & _head .~ 1 +-- [] +-- +-- >>> [0] & _head .~ 2 +-- [2] +-- +-- >>> [0,1] & _head .~ 2 +-- [2,1] +_head :: Cons s s a a => AffineTraversal' s a +_head = _Cons % _1 +{-# INLINE _head #-} + +-- | An 'AffineTraversal' reading and writing to the 'tail' of a /non-empty/ +-- container. +-- +-- >>> "ab" & _tail .~ "cde" +-- "acde" +-- +-- >>> [] & _tail .~ [1,2] +-- [] +-- +-- >>> [1,2,3,4,5] & _tail % traversed %~ (*10) +-- [1,20,30,40,50] +-- +-- >>> [1,2] & _tail .~ [3,4,5] +-- [1,3,4,5] +-- +-- >>> [] & _tail .~ [1,2] +-- [] +-- +-- >>> "abc" ^? _tail +-- Just "bc" +-- +-- >>> "hello" ^? _tail +-- Just "ello" +-- +-- >>> "" ^? _tail +-- Nothing +_tail :: Cons s s a a => AffineTraversal' s s +_tail = _Cons % _2 +{-# INLINE _tail #-} + +------------------------------------------------------------------------------ +-- Snoc +------------------------------------------------------------------------------ + +-- | This class provides a way to attach or detach elements on the right side of +-- a structure in a flexible manner. +class Snoc s t a b | s -> a, t -> b, s b -> t, t a -> s where + _Snoc :: Prism s t (s, a) (t, b) + +instance Snoc [a] [b] a b where + _Snoc = prism (\(as,a) -> as Prelude.++ [a]) $ \aas -> if Prelude.null aas + then Left [] + else Right (Prelude.init aas, Prelude.last aas) + {-# INLINE _Snoc #-} + +instance Snoc (ZipList a) (ZipList b) a b where + _Snoc = withPrism listSnoc $ \listReview listPreview -> + prism (coerce listReview) (coerce listPreview) where + + listSnoc :: Prism [a] [b] ([a], a) ([b], b) + listSnoc = _Snoc + + {-# INLINE _Snoc #-} + +instance Snoc (Seq a) (Seq b) a b where + _Snoc = prism (uncurry (Seq.|>)) $ \aas -> case viewr aas of + as Seq.:> a -> Right (as, a) + EmptyR -> Left mempty + {-# INLINE _Snoc #-} + +-- | An 'AffineTraversal' reading and replacing all but the a last element of a +-- /non-empty/ container. +-- +-- >>> "abcd" ^? _init +-- Just "abc" +-- +-- >>> "" ^? _init +-- Nothing +-- +-- >>> "ab" & _init .~ "cde" +-- "cdeb" +-- +-- >>> [] & _init .~ [1,2] +-- [] +-- +-- >>> [1,2,3,4] & _init % traversed %~ (*10) +-- [10,20,30,4] +-- +-- >>> [1,2,3] ^? _init +-- Just [1,2] +-- +-- >>> "hello" ^? _init +-- Just "hell" +-- +-- >>> [] ^? _init +-- Nothing +_init :: Snoc s s a a => AffineTraversal' s s +_init = _Snoc % _1 +{-# INLINE _init #-} + +-- | An 'AffineTraversal' reading and writing to the last element of a +-- /non-empty/ container. +-- +-- >>> "abc" ^? _last +-- Just 'c' +-- +-- >>> "" ^? _last +-- Nothing +-- +-- >>> [1,2,3] & _last %~ (+1) +-- [1,2,4] +-- +-- >>> [1,2] ^? _last +-- Just 2 +-- +-- >>> [] & _last .~ 1 +-- [] +-- +-- >>> [0] & _last .~ 2 +-- [2] +-- +-- >>> [0,1] & _last .~ 2 +-- [0,2] +_last :: Snoc s s a a => AffineTraversal' s a +_last = _Snoc % _2 +{-# INLINE _last #-} + +-- | 'snoc' an element onto the end of a container. +-- +-- This is an infix alias for 'snoc'. +-- +-- >>> "" |> 'a' +-- "a" +-- +-- >>> "bc" |> 'a' +-- "bca" +(|>) :: Snoc s s a a => s -> a -> s +(|>) = curry (review _Snoc) +{-# INLINE (|>) #-} + +-- | 'snoc' an element onto the end of a container. +-- +-- >>> snoc "hello" '!' +-- "hello!" +snoc :: Snoc s s a a => s -> a -> s +snoc = curry (review _Snoc) +{-# INLINE snoc #-} + +-- | Attempt to extract the right-most element from a container, and a version +-- of the container without that element. +-- +-- >>> unsnoc "hello!" +-- Just ("hello",'!') +-- +-- >>> unsnoc "" +-- Nothing +unsnoc :: Snoc s s a a => s -> Maybe (s, a) +unsnoc s = preview _Snoc s +{-# INLINE unsnoc #-} + +-- $setup +-- >>> import Data.Void +-- >>> import Optics.Core diff --git a/src/Optics/Core.hs b/src/Optics/Core.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Core.hs @@ -0,0 +1,68 @@ +-- | +-- +-- Module: Optics.Core +-- Description: The core optics functionality re-exported. +-- +-- See the @Optics@ module in the main @optics@ package for overview +-- documentation. +-- +module Optics.Core + ( + -- * Basic definitions + module Optics.Optic + + -- * Kinds of optic + , module O + + -- * Indexed optics + , module I + + -- * Overloaded labels + , module Optics.Label + + -- * Combinators + , module P + + -- * Optics for basic data types + , module D + ) + where + +import Optics.AffineFold as O +import Optics.AffineTraversal as O +import Optics.Fold as O +import Optics.Getter as O +import Optics.Iso as O +import Optics.IxAffineFold as O +import Optics.IxAffineTraversal as O +import Optics.IxFold as O +import Optics.IxGetter as O +import Optics.IxLens as O +import Optics.IxSetter as O +import Optics.IxTraversal as O +import Optics.Lens as O +import Optics.ReversedLens as O +import Optics.Prism as O +import Optics.ReversedPrism as O +import Optics.Review as O +import Optics.Setter as O +import Optics.Traversal as O + +import Optics.Indexed.Core as I + +import Optics.Arrow as P +import Optics.At.Core as P +import Optics.Coerce as P +import Optics.Cons.Core as P +import Optics.Each.Core as P +import Optics.Empty.Core as P +import Optics.Operators as P +import Optics.Re as P +import Optics.ReadOnly as P + +import Optics.Label +import Optics.Optic + +import Data.Either.Optics as D +import Data.Maybe.Optics as D +import Data.Tuple.Optics as D diff --git a/src/Optics/Each/Core.hs b/src/Optics/Each/Core.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Each/Core.hs @@ -0,0 +1,196 @@ +-- | +-- Module: Optics.Each.Core +-- 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. +-- +-- Note that orphan instances for this class are defined in the @Optics.Each@ +-- module from @optics-extra@, so if you are not simply depending on @optics@ +-- you may wish to import that module instead. +-- +{-# LANGUAGE UndecidableInstances #-} +module Optics.Each.Core + ( + -- * Each + Each(..) + ) where + +import Data.Array +import Data.Complex +import Data.Functor.Identity +import Data.IntMap as IntMap +import Data.List.NonEmpty +import Data.Map as Map +import Data.Sequence as Seq +import Data.Tree as Tree + +import Optics.IxTraversal + +-- | Extract 'each' element of a (potentially monomorphic) container. +-- +-- >>> over each (*10) (1,2,3) +-- (10,20,30) +-- +-- >>> iover each (\i a -> a*10 + succ i) (1,2,3) +-- (11,22,33) +-- +class Each i s t a b | s -> i a, t -> i b, s b -> t, t a -> s where + each :: IxTraversal i s t a b + + default each + :: (TraversableWithIndex i g, s ~ g a, t ~ g b) + => IxTraversal i s t a b + each = itraversed + {-# INLINE[1] each #-} + +-- | @'each' :: 'IxTraversal' 'Int' (a, a) (b, b) a b@ +instance + (a ~ a1, + b ~ b1 + ) => Each Int (a, a1) + (b, b1) a b where + each = itraversalVL $ \f (a0, a1) -> + (,) <$> f 0 a0 <*> f 1 a1 + {-# INLINE[1] each #-} + +-- | @'each' :: 'IxTraversal' 'Int' (a, a, a) (b, b, b) a b@ +instance + (a ~ a1, a ~ a2, + b ~ b1, b ~ b2 + ) => Each Int (a, a1, a2) + (b, b1, b2) a b where + each = itraversalVL $ \f (a0, a1, a2) -> + (,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2 + {-# INLINE[1] each #-} + +-- | @'each' :: 'IxTraversal' 'Int' (a, a, a, a) (b, b, b, b) a b@ +instance + (a ~ a1, a ~ a2, a ~ a3, + b ~ b1, b ~ b2, b ~ b3 + ) => Each Int (a, a1, a2, a3) + (b, b1, b2, b3) a b where + each = itraversalVL $ \f (a0, a1, a2, a3) -> + (,,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2 <*> f 3 a3 + {-# INLINE[1] each #-} + +-- | @'each' :: 'IxTraversal' 'Int' (a, a, a, a, a) (b, b, b, b, b) a b@ +instance + (a ~ a1, a ~ a2, a ~ a3, a ~ a4, + b ~ b1, b ~ b2, b ~ b3, b ~ b4 + ) => Each Int (a, a1, a2, a3, a4) + (b, b1, b2, b3, b4) a b where + each = itraversalVL $ \f (a0, a1, a2, a3, a4) -> + (,,,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2 <*> f 3 a3 <*> f 4 a4 + {-# INLINE[1] each #-} + +-- | @'each' :: 'IxTraversal' 'Int' (a, a, a, a, a, a) (b, b, b, b, b, b) a b@ +instance + (a ~ a1, a ~ a2, a ~ a3, a ~ a4, a ~ a5, + b ~ b1, b ~ b2, b ~ b3, b ~ b4, b ~ b5 + ) => Each Int (a, a1, a2, a3, a4, a5) + (b, b1, b2, b3, b4, b5) a b where + each = itraversalVL $ \f (a0, a1, a2, a3, a4, a5) -> + (,,,,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2 <*> f 3 a3 <*> f 4 a4 + <*> f 5 a5 + {-# INLINE[1] each #-} + +-- | @'each' :: 'IxTraversal' 'Int' (a, a, a, a, a, a, a) (b, b, b, b, b, b, b) +-- a b@ +instance + (a ~ a1, a ~ a2, a ~ a3, a ~ a4, a ~ a5, a ~ a6, + b ~ b1, b ~ b2, b ~ b3, b ~ b4, b ~ b5, b ~ b6 + ) => Each Int (a, a1, a2, a3, a4, a5, a6) + (b, b1, b2, b3, b4, b5, b6) a b where + each = itraversalVL $ \f (a0, a1, a2, a3, a4, a5, a6) -> + (,,,,,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2 <*> f 3 a3 <*> f 4 a4 + <*> f 5 a5 <*> f 6 a6 + {-# INLINE[1] each #-} + +-- | @'each' :: 'IxTraversal' 'Int' (a, a, a, a, a, a, a, a) (b, b, b, b, b, b, +-- b, b) a b@ +instance + (a ~ a1, a ~ a2, a ~ a3, a ~ a4, a ~ a5, a ~ a6, a ~ a7, + b ~ b1, b ~ b2, b ~ b3, b ~ b4, b ~ b5, b ~ b6, b ~ b7 + ) => Each Int (a, a1, a2, a3, a4, a5, a6, a7) + (b, b1, b2, b3, b4, b5, b6, b7) a b where + each = itraversalVL $ \f (a0, a1, a2, a3, a4, a5, a6, a7) -> + (,,,,,,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2 <*> f 3 a3 <*> f 4 a4 + <*> f 5 a5 <*> f 6 a6 <*> f 7 a7 + {-# INLINE[1] each #-} + +-- | @'each' :: 'IxTraversal' 'Int' (a, a, a, a, a, a, a, a, a) (b, b, b, b, b, +-- b, b, b, b) a b@ +instance + (a ~ a1, a ~ a2, a ~ a3, a ~ a4, a ~ a5, a ~ a6, a ~ a7, a ~ a8, + b ~ b1, b ~ b2, b ~ b3, b ~ b4, b ~ b5, b ~ b6, b ~ b7, b ~ b8 + ) => Each Int (a, a1, a2, a3, a4, a5, a6, a7, a8) + (b, b1, b2, b3, b4, b5, b6, b7, b8) a b where + each = itraversalVL $ \f (a0, a1, a2, a3, a4, a5, a6, a7, a8) -> + (,,,,,,,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2 <*> f 3 a3 <*> f 4 a4 + <*> f 5 a5 <*> f 6 a6 <*> f 7 a7 <*> f 8 a8 + {-# INLINE[1] each #-} + +-- | @'each' :: 'IxTraversal' 'Int' (a, a, a, a, a, a, a, a, a, a) (b, b, b, b, +-- b, b, b, b, b, b) a b@ +instance + (a ~ a1, a ~ a2, a ~ a3, a ~ a4, a ~ a5, a ~ a6, a ~ a7, a ~ a8, a ~ a9, + b ~ b1, b ~ b2, b ~ b3, b ~ b4, b ~ b5, b ~ b6, b ~ b7, b ~ b8, b ~ b9 + ) => Each Int (a, a1, a2, a3, a4, a5, a6, a7, a8, a9) + (b, b1, b2, b3, b4, b5, b6, b7, b8, b9) a b where + each = itraversalVL $ \f (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) -> + (,,,,,,,,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2 <*> f 3 a3 <*> f 4 a4 + <*> f 5 a5 <*> f 6 a6 <*> f 7 a7 <*> f 8 a8 <*> f 9 a9 + {-# INLINE[1] each #-} + +-- | @'each' :: 'IxTraversal' ('Either' () ()) ('Either' a a) ('Either' b b) a +-- b@ +instance + (a ~ a', b ~ b' + ) => Each (Either () ()) (Either a a') (Either b b') a b where + each = itraversalVL $ \f -> \case + Left a -> Left <$> f (Left ()) a + Right a -> Right <$> f (Right ()) a + {-# INLINE[1] each #-} + +-- | @'each' :: ('RealFloat' a, 'RealFloat' b) => 'IxTraversal' (Either () ()) +-- ('Complex' a) ('Complex' b) a b@ +instance Each (Either () ()) (Complex a) (Complex b) a b where + each = itraversalVL $ \f (a :+ b) -> (:+) <$> f (Left ()) a <*> f (Right ()) b + {-# INLINE[1] each #-} + +-- | @'each' :: 'IxTraversal' k ('Map' k a) ('Map' k b) a b@ +instance k ~ k' => Each k (Map k a) (Map k' b) a b where + -- traverseWithKey has best performance for all flavours for some reason. + each = itraversalVL Map.traverseWithKey + {-# INLINE[1] each #-} + +-- | @'each' :: 'IxTraversal' 'Int' ('IntMap' a) ('IntMap' b) a b@ +instance Each Int (IntMap a) (IntMap b) a b where + -- traverseWithKey has best performance for all flavours for some reason. + each = itraversalVL IntMap.traverseWithKey + {-# INLINE[1] each #-} + +-- | @'each' :: 'IxTraversal' 'Int' [a] [b] a b@ +instance Each Int [a] [b] a b + +-- | @'each' :: 'IxTraversal' 'Int' (NonEmpty a) (NonEmpty b) a b@ +instance Each Int (NonEmpty a) (NonEmpty b) a b + +-- | @'each' :: 'IxTraversal' () ('Identity' a) ('Identity' b) a b@ +instance Each () (Identity a) (Identity b) a b + +-- | @'each' :: 'IxTraversal' () ('Maybe' a) ('Maybe' b) a b@ +instance Each () (Maybe a) (Maybe b) a b + +-- | @'each' :: 'IxTraversal' 'Int' ('Seq' a) ('Seq' b) a b@ +instance Each Int (Seq a) (Seq b) a b + +-- | @'each' :: 'IxTraversal' [Int] ('Tree' a) ('Tree' b) a b@ +instance Each [Int] (Tree a) (Tree b) a b + +-- | @'each' :: 'Ix' i => 'IxTraversal' i ('Array' i a) ('Array' i b) a b@ +instance (Ix i, i ~ j) => Each i (Array i a) (Array j b) a b + +-- $setup +-- >>> import Optics.Core diff --git a/src/Optics/Empty/Core.hs b/src/Optics/Empty/Core.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Empty/Core.hs @@ -0,0 +1,147 @@ +-- | +-- Module: Optics.Empty.Core +-- 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'. +-- +-- Note that orphan instances for this class are defined in the @Optics.Empty@ +-- module from @optics-extra@, so if you are not simply depending on @optics@ +-- you may wish to import that module instead. +-- +-- >>> isn't _Empty [1,2,3] +-- True +-- +-- >>> case Nothing of { Empty -> True; _ -> False } +-- True +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +module Optics.Empty.Core + ( AsEmpty(..) + , pattern Empty + ) where + +import Control.Applicative (ZipList(..)) +import Data.IntMap as IntMap +import Data.IntSet as IntSet +import Data.Map as Map +import Data.Maybe +import Data.Monoid +import Data.Set as Set +import qualified Data.Sequence as Seq + +import Data.Maybe.Optics +import Optics.AffineTraversal +import Optics.Internal.Utils +import Optics.Iso +import Optics.Fold +import Optics.Optic +import Optics.Prism +import Optics.Review + +#if !defined(mingw32_HOST_OS) && !defined(ghcjs_HOST_OS) +import GHC.Event +#endif + +-- | Class for types that may be '_Empty'. +-- +class AsEmpty a where + -- | + -- + -- >>> isn't _Empty [1,2,3] + -- True + _Empty :: Prism' a () + default _Empty :: (Monoid a, Eq a) => Prism' a () + _Empty = only mempty + {-# INLINE _Empty #-} + +-- | Pattern synonym for matching on any type with an 'AsEmpty' instance. +-- +-- >>> case Nothing of { Empty -> True; _ -> False } +-- True +-- +pattern Empty :: forall a. AsEmpty a => a +pattern Empty <- (has _Empty -> True) where + Empty = review _Empty () + +{- Default Monoid instances -} +instance AsEmpty Ordering +instance AsEmpty () +instance AsEmpty Any +instance AsEmpty All +#if !defined(mingw32_HOST_OS) && !defined(ghcjs_HOST_OS) +instance AsEmpty Event +#endif +instance (Eq a, Num a) => AsEmpty (Product a) +instance (Eq a, Num a) => AsEmpty (Sum a) + +instance AsEmpty (Maybe a) where + _Empty = _Nothing + {-# INLINE _Empty #-} + +instance AsEmpty (Last a) where + _Empty = nearly (Last Nothing) (isNothing .# getLast) + {-# INLINE _Empty #-} + +instance AsEmpty (First a) where + _Empty = nearly (First Nothing) (isNothing .# getFirst) + {-# INLINE _Empty #-} + +instance AsEmpty a => AsEmpty (Dual a) where + _Empty = iso getDual Dual % _Empty + {-# INLINE _Empty #-} + +instance (AsEmpty a, AsEmpty b) => AsEmpty (a, b) where + _Empty = prism' + (\() -> (review _Empty (), review _Empty ())) + (\(s, s') -> case matching _Empty s of + Right () -> case matching _Empty s' of + Right () -> Just () + Left _ -> Nothing + Left _ -> Nothing) + {-# INLINE _Empty #-} + +instance (AsEmpty a, AsEmpty b, AsEmpty c) => AsEmpty (a, b, c) where + _Empty = prism' + (\() -> (review _Empty (), review _Empty (), review _Empty ())) + (\(s, s', s'') -> case matching _Empty s of + Right () -> case matching _Empty s' of + Right () -> case matching _Empty s'' of + Right () -> Just () + Left _ -> Nothing + Left _ -> Nothing + Left _ -> Nothing) + {-# INLINE _Empty #-} + +instance AsEmpty [a] where + _Empty = nearly [] Prelude.null + {-# INLINE _Empty #-} + +instance AsEmpty (ZipList a) where + _Empty = nearly (ZipList []) (Prelude.null . getZipList) + {-# INLINE _Empty #-} + +instance AsEmpty (Map k a) where + _Empty = nearly Map.empty Map.null + {-# INLINE _Empty #-} + +instance AsEmpty (IntMap a) where + _Empty = nearly IntMap.empty IntMap.null + {-# INLINE _Empty #-} + +instance AsEmpty (Set a) where + _Empty = nearly Set.empty Set.null + {-# INLINE _Empty #-} + +instance AsEmpty IntSet where + _Empty = nearly IntSet.empty IntSet.null + {-# INLINE _Empty #-} + +instance AsEmpty (Seq.Seq a) where + _Empty = nearly Seq.empty Seq.null + {-# INLINE _Empty #-} + +-- $setup +-- >>> import Optics.Core diff --git a/src/Optics/Fold.hs b/src/Optics/Fold.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Fold.hs @@ -0,0 +1,652 @@ +-- | +-- Module: Optics.Fold +-- Description: Extracts elements from a container. +-- +-- A @'Fold' S A@ has the ability to extract some number of elements of type @A@ +-- from a container of type @S@. For example, 'toListOf' can be used to obtain +-- the contained elements as a list. Unlike a 'Optics.Traversal.Traversal', +-- there is no way to set or update elements. +-- +-- This can be seen as a generalisation of 'traverse_', where the type @S@ does +-- not need to be a type constructor with @A@ as the last parameter. +-- +-- A close relative is the 'Optics.AffineFold.AffineFold', which is a 'Fold' +-- that contains at most one element. +-- +module Optics.Fold + ( + -- * Formation + Fold + + -- * Introduction + , foldVL + + -- * Elimination + , foldOf + , foldMapOf + , foldrOf + , foldlOf' + , toListOf + , sequenceOf_ + , traverseOf_ + , forOf_ + + -- * Computation + -- + -- | + -- + -- @ + -- 'traverseOf_' ('foldVL' f) ≡ f + -- @ + + -- * Additional introduction forms + , folded + , folding + , foldring + , unfolded + + -- * Additional elimination forms + -- | See also 'Data.Set.Optics.setOf', which constructs a 'Data.Set.Set' from a 'Fold'. + , has + , hasn't + , headOf + , lastOf + , andOf + , orOf + , allOf + , anyOf + , noneOf + , productOf + , sumOf + , asumOf + , msumOf + , elemOf + , notElemOf + , lengthOf + , maximumOf + , minimumOf + , maximumByOf + , minimumByOf + , findOf + , findMOf + , lookupOf + + -- * Combinators + , pre + , backwards_ + + -- * Semigroup structure + , summing + , failing + + -- * Subtyping + , A_Fold + -- | <> + ) + where + +import Control.Applicative +import Control.Applicative.Backwards +import Control.Monad +import Data.Foldable +import Data.Function +import Data.Monoid + +import Optics.Internal.Bi +import Optics.Internal.Fold +import Optics.Internal.Optic +import Optics.Internal.Profunctor +import Optics.Internal.Utils +import Optics.AffineFold + +-- | Type synonym for a fold. +type Fold s a = Optic' A_Fold NoIx s a + +-- | Obtain a 'Fold' by lifting 'traverse_' like function. +-- +-- @ +-- 'foldVL' '.' 'traverseOf_' ≡ 'id' +-- 'traverseOf_' '.' 'foldVL' ≡ 'id' +-- @ +foldVL + :: (forall f. Applicative f => (a -> f u) -> s -> f v) + -> Fold s a +foldVL f = Optic (foldVL__ f) +{-# INLINE foldVL #-} + +-- | Combine the results of a fold using a monoid. +foldOf :: (Is k A_Fold, Monoid a) => Optic' k is s a -> s -> a +foldOf o = foldMapOf o id +{-# INLINE foldOf #-} + +-- | Fold via embedding into a monoid. +foldMapOf :: (Is k A_Fold, Monoid m) => Optic' k is s a -> (a -> m) -> s -> m +foldMapOf o = runForget #. getOptic (castOptic @A_Fold o) .# Forget +{-# INLINE foldMapOf #-} + +-- | Fold right-associatively. +foldrOf :: Is k A_Fold => Optic' k is s a -> (a -> r -> r) -> r -> s -> r +foldrOf o = \arr r s -> (\e -> appEndo e r) $ foldMapOf o (Endo #. arr) s +{-# INLINE foldrOf #-} + +-- | Fold left-associatively, and strictly. +foldlOf' :: Is k A_Fold => Optic' k is s a -> (r -> a -> r) -> r -> s -> r +foldlOf' o = \rar r0 s -> foldrOf o (\a rr r -> rr $! rar r a) id s r0 +{-# INLINE foldlOf' #-} + +-- | Fold to a list. +toListOf :: Is k A_Fold => Optic' k is s a -> s -> [a] +toListOf o = foldrOf o (:) [] +{-# INLINE toListOf #-} + +---------------------------------------- + +-- | Traverse over all of the targets of a 'Fold', computing an +-- 'Applicative'-based answer, but unlike 'Optics.Traversal.traverseOf' do not +-- construct a new structure. 'traverseOf_' generalizes +-- 'Data.Foldable.traverse_' to work over any 'Fold'. +-- +-- >>> traverseOf_ each putStrLn ("hello","world") +-- hello +-- world +-- +-- @ +-- 'Data.Foldable.traverse_' ≡ 'traverseOf_' 'folded' +-- @ +traverseOf_ + :: (Is k A_Fold, Applicative f) + => Optic' k is s a + -> (a -> f r) -> s -> f () +traverseOf_ o = \f -> runTraversed . foldMapOf o (Traversed #. f) +{-# INLINE traverseOf_ #-} + +-- | A version of 'traverseOf_' with the arguments flipped. +forOf_ + :: (Is k A_Fold, Applicative f) + => Optic' k is s a + -> s -> (a -> f r) -> f () +forOf_ = flip . traverseOf_ +{-# INLINE forOf_ #-} + +-- | Evaluate each action in observed by a 'Fold' on a structure from left to +-- right, ignoring the results. +-- +-- @ +-- 'sequenceA_' ≡ 'sequenceOf_' 'folded' +-- @ +-- +-- >>> sequenceOf_ each (putStrLn "hello",putStrLn "world") +-- hello +-- world +sequenceOf_ + :: (Is k A_Fold, Applicative f) + => Optic' k is s (f a) + -> s -> f () +sequenceOf_ o = runTraversed . foldMapOf o Traversed +{-# INLINE sequenceOf_ #-} + +---------------------------------------- + +-- | Fold via the 'Foldable' class. +folded :: Foldable f => Fold (f a) a +folded = Optic folded__ +{-# INLINE folded #-} + +-- | Obtain a 'Fold' by lifting an operation that returns a 'Foldable' result. +-- +-- This can be useful to lift operations from @Data.List@ and elsewhere into a +-- 'Fold'. +-- +-- >>> toListOf (folding tail) [1,2,3,4] +-- [2,3,4] +folding :: Foldable f => (s -> f a) -> Fold s a +folding f = Optic (contrafirst f . foldVL__ traverse_) +{-# INLINE folding #-} + +-- | Obtain a 'Fold' by lifting 'foldr' like function. +-- +-- >>> toListOf (foldring foldr) [1,2,3,4] +-- [1,2,3,4] +foldring + :: (forall f. Applicative f => (a -> f u -> f u) -> f v -> s -> f w) + -> Fold s a +foldring fr = Optic (foldring__ fr) +{-# INLINE foldring #-} + +-- | Build a 'Fold' that unfolds its values from a seed. +-- +-- @ +-- 'Prelude.unfoldr' ≡ 'toListOf' '.' 'unfolded' +-- @ +-- +-- >>> toListOf (unfolded $ \b -> if b == 0 then Nothing else Just (b, b - 1)) 10 +-- [10,9,8,7,6,5,4,3,2,1] +unfolded :: (s -> Maybe (a, s)) -> Fold s a +unfolded step = foldVL $ \f -> fix $ \loop b -> + case step b of + Just (a, b') -> f a *> loop b' + Nothing -> pure () +{-# INLINE unfolded #-} + +-- | Convert a fold to an 'AffineFold' that visits the first element of the +-- original fold. +pre :: Is k A_Fold => Optic' k is s a -> AffineFold s a +pre = afolding . headOf +{-# INLINE pre #-} + +-- | This allows you to traverse the elements of a 'Fold' in the opposite order. +backwards_ + :: Is k A_Fold + => Optic' k is s a + -> Fold s a +backwards_ o = foldVL $ \f -> forwards #. traverseOf_ o (Backwards #. f) +{-# INLINE backwards_ #-} + +-- | Return entries of the first 'Fold', then the second one. +-- +-- >>> toListOf (_1 % ix 0 `summing` _2 % ix 1) ([1,2], [4,7,1]) +-- [1,7] +-- +summing + :: (Is k A_Fold, Is l A_Fold) + => Optic' k is s a + -> Optic' l js s a + -> Fold s a +summing a b = foldVL $ \f s -> traverseOf_ a f s *> traverseOf_ b f s +infixr 6 `summing` -- Same as (<>) +{-# INLINE summing #-} + +-- | Try the first 'Fold'. If it returns no entries, try the second one. +failing + :: (Is k A_Fold, Is l A_Fold) + => Optic' k is s a + -> Optic' l js s a + -> Fold s a +failing a b = foldVL $ \f s -> + let OrT visited fu = traverseOf_ a (wrapOrT . f) s + in if visited + then fu + else traverseOf_ b f s +infixl 3 `failing` -- Same as (<|>) +{-# INLINE failing #-} + +---------------------------------------- +-- Special folds + +-- | Check to see if this optic matches 1 or more entries. +-- +-- >>> has _Left (Left 12) +-- True +-- +-- >>> has _Right (Left 12) +-- False +-- +-- This will always return 'True' for a 'Optics.Lens.Lens' or +-- 'Optics.Getter.Getter'. +-- +-- >>> has _1 ("hello","world") +-- True +has :: Is k A_Fold => Optic' k is s a -> s -> Bool +has o = getAny #. foldMapOf o (\_ -> Any True) +{-# INLINE has #-} + +-- | Check to see if this 'Fold' or 'Optics.Traversal.Traversal' has +-- no matches. +-- +-- >>> hasn't _Left (Right 12) +-- True +-- +-- >>> hasn't _Left (Left 12) +-- False +hasn't :: Is k A_Fold => Optic' k is s a -> s -> Bool +hasn't o = getAll #. foldMapOf o (\_ -> All False) +{-# INLINE hasn't #-} + +-- | Retrieve the first entry of a 'Fold'. +-- +-- >>> headOf folded [1..10] +-- Just 1 +-- +-- >>> headOf each (1,2) +-- Just 1 +headOf :: Is k A_Fold => Optic' k is s a -> s -> Maybe a +headOf o = getLeftmost . foldMapOf o LLeaf +{-# INLINE headOf #-} + +-- | Retrieve the last entry of a 'Fold'. +-- +-- >>> lastOf folded [1..10] +-- Just 10 +-- +-- >>> lastOf each (1,2) +-- Just 2 +lastOf :: Is k A_Fold => Optic' k is s a -> s -> Maybe a +lastOf o = getRightmost . foldMapOf o RLeaf +{-# INLINE lastOf #-} + +-- | Returns 'True' if every target of a 'Fold' is 'True'. +-- +-- >>> andOf each (True, False) +-- False +-- >>> andOf each (True, True) +-- True +-- +-- @ +-- 'Data.Foldable.and' ≡ 'andOf' 'folded' +-- @ +andOf :: Is k A_Fold => Optic' k is s Bool -> s -> Bool +andOf o = getAll #. foldMapOf o All +{-# INLINE andOf #-} + +-- | Returns 'True' if any target of a 'Fold' is 'True'. +-- +-- >>> orOf each (True, False) +-- True +-- >>> orOf each (False, False) +-- False +-- +-- @ +-- 'Data.Foldable.or' ≡ 'orOf' 'folded' +-- @ +orOf :: Is k A_Fold => Optic' k is s Bool -> s -> Bool +orOf o = getAny #. foldMapOf o Any +{-# INLINE orOf #-} + +-- | Returns 'True' if any target of a 'Fold' satisfies a predicate. +-- +-- >>> anyOf each (=='x') ('x','y') +-- True +anyOf :: Is k A_Fold => Optic' k is s a -> (a -> Bool) -> s -> Bool +anyOf o = \f -> getAny #. foldMapOf o (Any #. f) +{-# INLINE anyOf #-} + +-- | Returns 'True' if every target of a 'Fold' satisfies a predicate. +-- +-- >>> allOf each (>=3) (4,5) +-- True +-- >>> allOf folded (>=2) [1..10] +-- False +-- +-- @ +-- 'Data.Foldable.all' ≡ 'allOf' 'folded' +-- @ +allOf :: Is k A_Fold => Optic' k is s a -> (a -> Bool) -> s -> Bool +allOf o = \f -> getAll #. foldMapOf o (All #. f) +{-# INLINE allOf #-} + +-- | Returns 'True' only if no targets of a 'Fold' satisfy a predicate. +-- +-- >>> noneOf each (not . isn't _Nothing) (Just 3, Just 4, Just 5) +-- True +-- >>> noneOf (folded % folded) (<10) [[13,99,20],[3,71,42]] +-- False +noneOf :: Is k A_Fold => Optic' k is s a -> (a -> Bool) -> s -> Bool +noneOf o = \f -> not . anyOf o f +{-# INLINE noneOf #-} + +-- | Calculate the 'Product' of every number targeted by a 'Fold'. +-- +-- >>> productOf each (4,5) +-- 20 +-- >>> productOf folded [1,2,3,4,5] +-- 120 +-- +-- @ +-- 'Data.Foldable.product' ≡ 'productOf' 'folded' +-- @ +-- +-- This operation may be more strict than you would expect. If you want a lazier +-- version use @\\o -> 'getProduct' '.' 'foldMapOf' o 'Product'@. +productOf :: (Is k A_Fold, Num a) => Optic' k is s a -> s -> a +productOf o = foldlOf' o (*) 1 +{-# INLINE productOf #-} + +-- | Calculate the 'Sum' of every number targeted by a 'Fold'. +-- +-- >>> sumOf each (5,6) +-- 11 +-- >>> sumOf folded [1,2,3,4] +-- 10 +-- >>> sumOf (folded % each) [(1,2),(3,4)] +-- 10 +-- +-- @ +-- 'Data.Foldable.sum' ≡ 'sumOf' 'folded' +-- @ +-- +-- This operation may be more strict than you would expect. If you want a lazier +-- version use @\\o -> 'getSum' '.' 'foldMapOf' o 'Sum'@ +sumOf :: (Is k A_Fold, Num a) => Optic' k is s a -> s -> a +sumOf o = foldlOf' o (+) 0 +{-# INLINE sumOf #-} + +-- | The sum of a collection of actions. +-- +-- >>> asumOf each ("hello","world") +-- "helloworld" +-- +-- >>> asumOf each (Nothing, Just "hello", Nothing) +-- Just "hello" +-- +-- @ +-- 'asum' ≡ 'asumOf' 'folded' +-- @ +asumOf :: (Is k A_Fold, Alternative f) => Optic' k is s (f a) -> s -> f a +asumOf o = foldrOf o (<|>) empty +{-# INLINE asumOf #-} + +-- | The sum of a collection of actions. +-- +-- >>> msumOf each ("hello","world") +-- "helloworld" +-- +-- >>> msumOf each (Nothing, Just "hello", Nothing) +-- Just "hello" +-- +-- @ +-- 'msum' ≡ 'msumOf' 'folded' +-- @ +msumOf :: (Is k A_Fold, MonadPlus m) => Optic' k is s (m a) -> s -> m a +msumOf o = foldrOf o mplus mzero +{-# INLINE msumOf #-} + +-- | Does the element occur anywhere within a given 'Fold' of the structure? +-- +-- >>> elemOf each "hello" ("hello","world") +-- True +-- +-- @ +-- 'elem' ≡ 'elemOf' 'folded' +-- @ +elemOf :: (Is k A_Fold, Eq a) => Optic' k is s a -> a -> s -> Bool +elemOf o = anyOf o . (==) +{-# INLINE elemOf #-} + +-- | Does the element not occur anywhere within a given 'Fold' of the structure? +-- +-- >>> notElemOf each 'd' ('a','b','c') +-- True +-- +-- >>> notElemOf each 'a' ('a','b','c') +-- False +-- +-- @ +-- 'notElem' ≡ 'notElemOf' 'folded' +-- @ +notElemOf :: (Is k A_Fold, Eq a) => Optic' k is s a -> a -> s -> Bool +notElemOf o = allOf o . (/=) +{-# INLINE notElemOf #-} + +-- | Calculate the number of targets there are for a 'Fold' in a given +-- container. +-- +-- /Note:/ This can be rather inefficient for large containers and just like +-- 'length', this will not terminate for infinite folds. +-- +-- @ +-- 'length' ≡ 'lengthOf' 'folded' +-- @ +-- +-- >>> lengthOf _1 ("hello",()) +-- 1 +-- +-- >>> lengthOf folded [1..10] +-- 10 +-- +-- >>> lengthOf (folded % folded) [[1,2],[3,4],[5,6]] +-- 6 +lengthOf :: Is k A_Fold => Optic' k is s a -> s -> Int +lengthOf o = foldlOf' o (\ n _ -> 1 + n) 0 +{-# INLINE lengthOf #-} + +-- | Obtain the maximum element (if any) targeted by a 'Fold' safely. +-- +-- Note: 'maximumOf' on a valid 'Optics.Iso.Iso', 'Optics.Lens.Lens' +-- or 'Optics.Getter.Getter' will always return 'Just' a value. +-- +-- >>> maximumOf folded [1..10] +-- Just 10 +-- +-- >>> maximumOf folded [] +-- Nothing +-- +-- >>> maximumOf (folded % filtered even) [1,4,3,6,7,9,2] +-- Just 6 +-- +-- @ +-- 'maximum' ≡ 'Data.Maybe.fromMaybe' ('error' \"empty\") '.' 'maximumOf' 'folded' +-- @ +-- +-- In the interest of efficiency, This operation has semantics more strict than +-- strictly necessary. @\\o -> 'Data.Semigroup.getMax' . 'foldMapOf' o 'Data.Semigroup.Max'@ has lazier +-- semantics but could leak memory. +maximumOf :: (Is k A_Fold, Ord a) => Optic' k is s a -> s -> Maybe a +maximumOf o = foldlOf' o mf Nothing where + mf Nothing y = Just $! y + mf (Just x) y = Just $! max x y +{-# INLINE maximumOf #-} + +-- | Obtain the minimum element (if any) targeted by a 'Fold' safely. +-- +-- Note: 'minimumOf' on a valid 'Optics.Iso.Iso', 'Optics.Lens.Lens' +-- or 'Optics.Getter.Getter' will always return 'Just' a value. +-- +-- >>> minimumOf folded [1..10] +-- Just 1 +-- +-- >>> minimumOf folded [] +-- Nothing +-- +-- >>> minimumOf (folded % filtered even) [1,4,3,6,7,9,2] +-- Just 2 +-- +-- @ +-- 'minimum' ≡ 'Data.Maybe.fromMaybe' ('error' \"empty\") '.' 'minimumOf' 'folded' +-- @ +-- +-- In the interest of efficiency, This operation has semantics more strict than +-- strictly necessary. @\\o -> 'Data.Semigroup.getMin' . 'foldMapOf' o 'Data.Semigroup.Min'@ has lazier +-- semantics but could leak memory. +minimumOf :: (Is k A_Fold, Ord a) => Optic' k is s a -> s -> Maybe a +minimumOf o = foldlOf' o mf Nothing where + mf Nothing y = Just $! y + mf (Just x) y = Just $! min x y +{-# INLINE minimumOf #-} + +-- | Obtain the maximum element (if any) targeted by a 'Fold' according to a +-- user supplied 'Ordering'. +-- +-- >>> maximumByOf folded (compare `on` length) ["mustard","relish","ham"] +-- Just "mustard" +-- +-- In the interest of efficiency, This operation has semantics more strict than +-- strictly necessary. +-- +-- @ +-- 'Data.Foldable.maximumBy' cmp ≡ 'Data.Maybe.fromMaybe' ('error' \"empty\") '.' 'maximumByOf' 'folded' cmp +-- @ +maximumByOf :: Is k A_Fold => Optic' k is s a -> (a -> a -> Ordering) -> s -> Maybe a +maximumByOf o = \cmp -> + let mf Nothing y = Just $! y + mf (Just x) y = Just $! if cmp x y == GT then x else y + in foldlOf' o mf Nothing +{-# INLINE maximumByOf #-} + +-- | Obtain the minimum element (if any) targeted by a 'Fold' according to a +-- user supplied 'Ordering'. +-- +-- In the interest of efficiency, This operation has semantics more strict than +-- strictly necessary. +-- +-- >>> minimumByOf folded (compare `on` length) ["mustard","relish","ham"] +-- Just "ham" +-- +-- @ +-- 'minimumBy' cmp ≡ 'Data.Maybe.fromMaybe' ('error' \"empty\") '.' 'minimumByOf' 'folded' cmp +-- @ +minimumByOf :: Is k A_Fold => Optic' k is s a -> (a -> a -> Ordering) -> s -> Maybe a +minimumByOf o = \cmp -> + let mf Nothing y = Just $! y + mf (Just x) y = Just $! if cmp x y == GT then y else x + in foldlOf' o mf Nothing +{-# INLINE minimumByOf #-} + +-- | The 'findOf' function takes a 'Fold', a predicate and a structure and +-- returns the leftmost element of the structure matching the predicate, or +-- 'Nothing' if there is no such element. +-- +-- >>> findOf each even (1,3,4,6) +-- Just 4 +-- +-- >>> findOf folded even [1,3,5,7] +-- Nothing +-- +-- @ +-- 'Data.Foldable.find' ≡ 'findOf' 'folded' +-- @ +findOf :: Is k A_Fold => Optic' k is s a -> (a -> Bool) -> s -> Maybe a +findOf o = \f -> foldrOf o (\a y -> if f a then Just a else y) Nothing +{-# INLINE findOf #-} + +-- | The 'findMOf' function takes a 'Fold', a monadic predicate and a structure +-- and returns in the monad the leftmost element of the structure matching the +-- predicate, or 'Nothing' if there is no such element. +-- +-- >>> findMOf each (\x -> print ("Checking " ++ show x) >> return (even x)) (1,3,4,6) +-- "Checking 1" +-- "Checking 3" +-- "Checking 4" +-- Just 4 +-- +-- >>> findMOf each (\x -> print ("Checking " ++ show x) >> return (even x)) (1,3,5,7) +-- "Checking 1" +-- "Checking 3" +-- "Checking 5" +-- "Checking 7" +-- Nothing +-- +-- @ +-- 'findMOf' 'folded' :: (Monad m, Foldable f) => (a -> m Bool) -> f a -> m (Maybe a) +-- @ +findMOf :: (Is k A_Fold, Monad m) => Optic' k is s a -> (a -> m Bool) -> s -> m (Maybe a) +findMOf o = \f -> foldrOf o + (\a y -> f a >>= \r -> if r then pure (Just a) else y) + (pure Nothing) +{-# INLINE findMOf #-} + +-- | The 'lookupOf' function takes a 'Fold', a key, and a structure containing +-- key/value pairs. It returns the first value corresponding to the given +-- key. This function generalizes 'lookup' to work on an arbitrary 'Fold' +-- instead of lists. +-- +-- >>> lookupOf folded 4 [(2, 'a'), (4, 'b'), (4, 'c')] +-- Just 'b' +-- +-- >>> lookupOf folded 2 [(2, 'a'), (4, 'b'), (4, 'c')] +-- Just 'a' +lookupOf :: (Is k A_Fold, Eq a) => Optic' k is s (a, v) -> a -> s -> Maybe v +lookupOf o a = foldrOf o (\(a', v) next -> if a == a' then Just v else next) Nothing +{-# INLINE lookupOf #-} + +-- $setup +-- >>> import Optics.Core diff --git a/src/Optics/Getter.hs b/src/Optics/Getter.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Getter.hs @@ -0,0 +1,62 @@ +-- | +-- Module: Optics.Getter +-- Description: A function considered as an 'Optic'. +-- +-- A 'Getter' is simply a function considered as an 'Optic'. +-- +-- Given a function @f :: S -> A@, we can convert it into a +-- @'Getter' S A@ using 'to', and convert back to a function using 'view'. +-- +-- This is typically useful not when you have functions/'Getter's +-- alone, but when you are composing multiple 'Optic's to produce a +-- 'Getter'. +-- +module Optics.Getter + ( + -- * Formation + Getter + + -- * Introduction + , to + + -- * Elimination + , view + , views + + -- * Computation + -- | + -- + -- @ + -- 'view' ('to' f) ≡ f + -- @ + + -- * Well-formedness + -- | A 'Getter' is not subject to any laws. + + -- * Subtyping + , A_Getter + -- | <> + ) + where + +import Optics.Internal.Bi +import Optics.Internal.Optic +import Optics.Internal.Profunctor + +-- | Type synonym for a getter. +type Getter s a = Optic' A_Getter NoIx s a + +-- | View the value pointed to by a getter. +view :: Is k A_Getter => Optic' k is s a -> s -> a +view o = views o id +{-# INLINE view #-} + +-- | View the function of the value pointed to by a getter. +views :: Is k A_Getter => Optic' k is s a -> (a -> r) -> s -> r +views o = \f -> runForget $ getOptic (castOptic @A_Getter o) (Forget f) +{-# INLINE views #-} + +-- | Build a getter from a function. +to :: (s -> a) -> Getter s a +to f = Optic (lmap f . rphantom) +{-# INLINE to #-} diff --git a/src/Optics/Indexed/Core.hs b/src/Optics/Indexed/Core.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Indexed/Core.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE DataKinds #-} +-- | +-- Module: Optics.Indexed.Core +-- Description: Core definitions for indexed optics. +-- +-- This module defines basic 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. +-- +module Optics.Indexed.Core + ( + -- * 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 Optics.Internal.Indexed +import Optics.Internal.Optic +import Optics.Internal.Profunctor + +import Optics.AffineFold +import Optics.AffineTraversal +import Optics.Fold +import Optics.Getter +import Optics.IxAffineFold +import Optics.IxAffineTraversal +import Optics.IxFold +import Optics.IxGetter +import Optics.IxLens +import Optics.IxSetter +import Optics.IxTraversal +import Optics.Lens +import Optics.Setter +import Optics.Traversal + +-- | Compose two indexed optics. Their indices are composed as a pair. +-- +-- >>> itoListOf (ifolded <%> ifolded) ["foo", "bar"] +-- [((0,0),'f'),((0,1),'o'),((0,2),'o'),((1,0),'b'),((1,1),'a'),((1,2),'r')] +-- +infixl 9 <%> +(<%>) + :: (m ~ Join k l, Is k m, Is l m, IxOptic m s t a b, + is `HasSingleIndex` i, js `HasSingleIndex` j) + => Optic k is s t u v + -> Optic l js u v a b + -> Optic m (WithIx (i, j)) s t a b +o <%> o' = icompose (,) (o % o') +{-# INLINE (<%>) #-} + +-- | Compose two indexed optics and drop indices of the left one. (If you want +-- to compose a non-indexed and an indexed optic, you can just use ('%').) +-- +-- >>> itoListOf (ifolded %> ifolded) ["foo", "bar"] +-- [(0,'f'),(1,'o'),(2,'o'),(0,'b'),(1,'a'),(2,'r')] +-- +infixl 9 %> +(%>) + :: (m ~ Join k l, Is k m, Is l m, IxOptic k s t u v, NonEmptyIndices is) + => Optic k is s t u v + -> Optic l js u v a b + -> Optic m js s t a b +o %> o' = noIx o % o' +{-# INLINE (%>) #-} + +-- | Compose two indexed optics and drop indices of the right one. (If you want +-- to compose an indexed and a non-indexed optic, you can just use ('%').) +-- +-- >>> itoListOf (ifolded <% ifolded) ["foo", "bar"] +-- [(0,'f'),(0,'o'),(0,'o'),(1,'b'),(1,'a'),(1,'r')] +-- +infixl 9 <% +(<%) + :: (m ~ Join k l, Is l m, Is k m, IxOptic l u v a b, NonEmptyIndices js) + => Optic k is s t u v + -> Optic l js u v a b + -> Optic m is s t a b +o <% o' = o % noIx o' +{-# INLINE (<%) #-} + +-- | Remap the index. +-- +-- >>> itoListOf (reindexed succ ifolded) "foo" +-- [(1,'f'),(2,'o'),(3,'o')] +-- +-- >>> itoListOf (ifolded %& reindexed succ) "foo" +-- [(1,'f'),(2,'o'),(3,'o')] +-- +reindexed + :: is `HasSingleIndex` i + => (i -> j) + -> Optic k is s t a b + -> Optic k (WithIx j) s t a b +reindexed = icomposeN +{-# INLINE reindexed #-} + +-- | Flatten indices obtained from two indexed optics. +-- +-- >>> itoListOf (ifolded % ifolded %& icompose (,)) ["foo","bar"] +-- [((0,0),'f'),((0,1),'o'),((0,2),'o'),((1,0),'b'),((1,1),'a'),((1,2),'r')] +-- +icompose + :: (i -> j -> ix) + -> Optic k '[i, j] s t a b + -> Optic k (WithIx ix) s t a b +icompose = icomposeN +{-# INLINE icompose #-} + +-- | Flatten indices obtained from three indexed optics. +-- +-- >>> itoListOf (ifolded % ifolded % ifolded %& icompose3 (,,)) [["foo","bar"],["xyz"]] +-- [((0,0,0),'f'),((0,0,1),'o'),((0,0,2),'o'),((0,1,0),'b'),((0,1,1),'a'),((0,1,2),'r'),((1,0,0),'x'),((1,0,1),'y'),((1,0,2),'z')] +-- +icompose3 + :: (i1 -> i2 -> i3 -> ix) + -> Optic k '[i1, i2, i3] s t a b + -> Optic k (WithIx ix) s t a b +icompose3 = icomposeN +{-# INLINE icompose3 #-} + +-- | Flatten indices obtained from four indexed optics. +icompose4 + :: (i1 -> i2 -> i3 -> i4 -> ix) + -> Optic k '[i1, i2, i3, i4] s t a b + -> Optic k (WithIx ix) s t a b +icompose4 = icomposeN +{-# INLINE icompose4 #-} + +-- | Flatten indices obtained from five indexed optics. +icompose5 + :: (i1 -> i2 -> i3 -> i4 -> i5 -> ix) + -> Optic k '[i1, i2, i3, i4, i5] s t a b + -> Optic k (WithIx ix) s t a b +icompose5 = icomposeN +{-# INLINE icompose5 #-} + +-- | Flatten indices obtained from arbitrary number of indexed optics. +icomposeN + :: forall k i is s t a b + . (CurryCompose is, NonEmptyIndices is) + => Curry is i + -> Optic k is s t a b + -> Optic k (WithIx i) s t a b +icomposeN f (Optic o) = Optic (ixcontramap (\ij -> composeN @is ij f) . o) +{-# INLINE icomposeN #-} + +---------------------------------------- +-- IxOptic + +-- | Class for optic kinds that can have indices. +class IxOptic k s t a b where + -- | Convert an indexed optic to its unindexed equivalent. + noIx + :: NonEmptyIndices is + => Optic k is s t a b + -> Optic k NoIx s t a b + +instance (s ~ t, a ~ b) => IxOptic A_Getter s t a b where + noIx o = to (view o) + {-# INLINE noIx #-} + +instance IxOptic A_Lens s t a b where + noIx o = lensVL (toLensVL o) + {-# INLINE noIx #-} + +instance IxOptic An_AffineTraversal s t a b where + noIx o = atraversalVL (toAtraversalVL o) + {-# INLINE noIx #-} + +instance (s ~ t, a ~ b) => IxOptic An_AffineFold s t a b where + noIx o = afolding (preview o) + {-# INLINE noIx #-} + +instance IxOptic A_Traversal s t a b where + noIx o = traversalVL (traverseOf o) + {-# INLINE noIx #-} + +instance (s ~ t, a ~ b) => IxOptic A_Fold s t a b where + noIx o = foldVL (traverseOf_ o) + {-# INLINE noIx #-} + +instance IxOptic A_Setter s t a b where + noIx o = sets (over o) + {-# INLINE noIx #-} + +-- $setup +-- >>> import Optics.Core diff --git a/src/Optics/Internal/Bi.hs b/src/Optics/Internal/Bi.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Internal/Bi.hs @@ -0,0 +1,69 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | Classes for co- and contravariant bifunctors. +-- +-- This module is intended for internal use only, and may change without warning +-- in subsequent releases. +module Optics.Internal.Bi where + +import Data.Void + +import Optics.Internal.Profunctor + +-- | Class for (covariant) bifunctors. +class Bifunctor p where + bimap :: (a -> b) -> (c -> d) -> p i a c -> p i b d + first :: (a -> b) -> p i a c -> p i b c + second :: (c -> d) -> p i a c -> p i a d + +-- | Class for contravariant bifunctors. +class Bicontravariant p where + contrabimap :: (b -> a) -> (d -> c) -> p i a c -> p i b d + contrafirst :: (b -> a) -> p i a c -> p i b c + contrasecond :: (c -> b) -> p i a b -> p i a c + +instance Bicontravariant (Forget r) where + contrabimap f _g (Forget k) = Forget (k . f) + contrafirst f (Forget k) = Forget (k . f) + contrasecond _g (Forget k) = Forget k + {-# INLINE contrabimap #-} + {-# INLINE contrafirst #-} + {-# INLINE contrasecond #-} + +instance Bicontravariant (ForgetM r) where + contrabimap f _g (ForgetM k) = ForgetM (k . f) + contrafirst f (ForgetM k) = ForgetM (k . f) + contrasecond _g (ForgetM k) = ForgetM k + {-# INLINE contrabimap #-} + {-# INLINE contrafirst #-} + {-# INLINE contrasecond #-} + +instance Bicontravariant (IxForget r) where + contrabimap f _g (IxForget k) = IxForget (\i -> k i . f) + contrafirst f (IxForget k) = IxForget (\i -> k i . f) + contrasecond _g (IxForget k) = IxForget k + {-# INLINE contrabimap #-} + {-# INLINE contrafirst #-} + {-# INLINE contrasecond #-} + +instance Bicontravariant (IxForgetM r) where + contrabimap f _g (IxForgetM k) = IxForgetM (\i -> k i . f) + contrafirst f (IxForgetM k) = IxForgetM (\i -> k i . f) + contrasecond _g (IxForgetM k) = IxForgetM k + {-# INLINE contrabimap #-} + {-# INLINE contrafirst #-} + {-# INLINE contrasecond #-} + +---------------------------------------- + +-- | If @p@ is a 'Profunctor' and a 'Bifunctor' then its left parameter must be +-- phantom. +lphantom :: (Profunctor p, Bifunctor p) => p i a c -> p i b c +lphantom = first absurd . lmap absurd +{-# INLINE lphantom #-} + +-- | If @p@ is a 'Profunctor' and 'Bicontravariant' then its right parameter +-- must be phantom. +rphantom :: (Profunctor p, Bicontravariant p) => p i c a -> p i c b +rphantom = rmap absurd . contrasecond absurd +{-# INLINE rphantom #-} diff --git a/src/Optics/Internal/Concrete.hs b/src/Optics/Internal/Concrete.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Internal/Concrete.hs @@ -0,0 +1,117 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | Concrete representation types for certain optics. +-- +-- This module is intended for internal use only, and may change without warning +-- in subsequent releases. +module Optics.Internal.Concrete + ( Exchange(..) + , Store(..) + , Market(..) + , AffineMarket(..) + ) where + +import Data.Bifunctor + +import Optics.Internal.Profunctor + +-- | Type to represent the components of an isomorphism. +data Exchange a b i s t = + Exchange (s -> a) (b -> t) + +instance Profunctor (Exchange a b) where + dimap ss tt (Exchange sa bt) = Exchange (sa . ss) (tt . bt) + lmap ss (Exchange sa bt) = Exchange (sa . ss) bt + rmap tt (Exchange sa bt) = Exchange sa (tt . bt) + {-# INLINE dimap #-} + {-# INLINE lmap #-} + {-# INLINE rmap #-} + +-- | Type to represent the components of a lens. +data Store a b i s t = Store (s -> a) (s -> b -> t) + +instance Profunctor (Store a b) where + dimap f g (Store get set) = Store (get . f) (\s -> g . set (f s)) + lmap f (Store get set) = Store (get . f) (\s -> set (f s)) + rmap g (Store get set) = Store get (\s -> g . set s) + {-# INLINE dimap #-} + {-# INLINE lmap #-} + {-# INLINE rmap #-} + +instance Strong (Store a b) where + first' (Store get set) = Store (get . fst) (\(s, c) b -> (set s b, c)) + second' (Store get set) = Store (get . snd) (\(c, s) b -> (c, set s b)) + {-# INLINE first' #-} + {-# INLINE second' #-} + +-- | Type to represent the components of a prism. +data Market a b i s t = Market (b -> t) (s -> Either t a) + +instance Functor (Market a b i s) where + fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta) + {-# INLINE fmap #-} + +instance Profunctor (Market a b) where + dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f) + lmap f (Market bt seta) = Market bt (seta . f) + rmap g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta) + {-# INLINE dimap #-} + {-# INLINE lmap #-} + {-# INLINE rmap #-} + +instance Choice (Market a b) where + left' (Market bt seta) = Market (Left . bt) $ \sc -> case sc of + Left s -> case seta s of + Left t -> Left (Left t) + Right a -> Right a + Right c -> Left (Right c) + right' (Market bt seta) = Market (Right . bt) $ \cs -> case cs of + Left c -> Left (Left c) + Right s -> case seta s of + Left t -> Left (Right t) + Right a -> Right a + {-# INLINE left' #-} + {-# INLINE right' #-} + +-- | Type to represent the components of an affine traversal. +data AffineMarket a b i s t = AffineMarket (s -> b -> t) (s -> Either t a) + +instance Profunctor (AffineMarket a b) where + dimap f g (AffineMarket sbt seta) = AffineMarket + (\s b -> g (sbt (f s) b)) + (either (Left . g) Right . seta . f) + lmap f (AffineMarket sbt seta) = AffineMarket + (\s b -> sbt (f s) b) + (seta . f) + rmap g (AffineMarket sbt seta) = AffineMarket + (\s b -> g (sbt s b)) + (either (Left . g) Right . seta) + {-# INLINE dimap #-} + {-# INLINE lmap #-} + {-# INLINE rmap #-} + +instance Choice (AffineMarket a b) where + left' (AffineMarket sbt seta) = AffineMarket + (\e b -> bimap (flip sbt b) id e) + (\sc -> case sc of + Left s -> bimap Left id (seta s) + Right c -> Left (Right c)) + right' (AffineMarket sbt seta) = AffineMarket + (\e b -> bimap id (flip sbt b) e) + (\sc -> case sc of + Left c -> Left (Left c) + Right s -> bimap Right id (seta s)) + {-# INLINE left' #-} + {-# INLINE right' #-} + +instance Strong (AffineMarket a b) where + first' (AffineMarket sbt seta) = AffineMarket + (\(a, c) b -> (sbt a b, c)) + (\(a, c) -> bimap (,c) id (seta a)) + second' (AffineMarket sbt seta) = AffineMarket + (\(c, a) b -> (c, sbt a b)) + (\(c, a) -> bimap (c,) id (seta a)) + {-# INLINE first' #-} + {-# INLINE second' #-} + +instance Visiting (AffineMarket a b) diff --git a/src/Optics/Internal/Fold.hs b/src/Optics/Internal/Fold.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Internal/Fold.hs @@ -0,0 +1,113 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | Internal implementation details of folds. +-- +-- This module is intended for internal use only, and may change without warning +-- in subsequent releases. +module Optics.Internal.Fold where + +import Data.Functor +import Data.Foldable +import Data.Maybe +import qualified Data.Semigroup as SG + +import Optics.Internal.Bi +import Optics.Internal.Optic +import Optics.Internal.Profunctor + +-- | Internal implementation of 'Optics.Fold.foldVL'. +foldVL__ + :: (Bicontravariant p, Traversing p) + => (forall f. Applicative f => (a -> f u) -> s -> f v) + -> Optic__ p i i s t a b +foldVL__ f = rphantom . wander f . rphantom +{-# INLINE foldVL__ #-} + +-- | Internal implementation of 'Optics.Fold.folded'. +folded__ + :: (Bicontravariant p, Traversing p, Foldable f) + => Optic__ p i i (f a) (f b) a b +folded__ = foldVL__ traverse_ +{-# INLINE folded__ #-} + +-- | Internal implementation of 'Optics.Fold.foldring'. +foldring__ + :: (Bicontravariant p, Traversing p) + => (forall f. Applicative f => (a -> f u -> f u) -> f v -> s -> f w) + -> Optic__ p i i s t a b +foldring__ fr = foldVL__ $ \f -> void . fr (\a -> (f a *>)) (pure v) + where + v = error "foldring__: value used" +{-# INLINE foldring__ #-} + +------------------------------------------------------------------------------ +-- Leftmost and Rightmost +------------------------------------------------------------------------------ + +-- | Used for 'Optics.Fold.headOf' and 'Optics.IxFold.iheadOf'. +data Leftmost a = LPure | LLeaf a | LStep (Leftmost a) + +instance SG.Semigroup (Leftmost a) where + x <> y = LStep $ case x of + LPure -> y + LLeaf _ -> x + LStep x' -> case y of + -- The last two cases make headOf produce a Just as soon as any element is + -- encountered, and possibly serve as a micro-optimisation; this behaviour + -- can be disabled by replacing them with _ -> mappend x y'. Note that + -- this means that firstOf (backwards folded) [1..] is Just _|_. + LPure -> x' + LLeaf a -> LLeaf $ fromMaybe a (getLeftmost x') + LStep y' -> x' SG.<> y' + +instance Monoid (Leftmost a) where + mempty = LPure + mappend = (SG.<>) + {-# INLINE mempty #-} + {-# INLINE mappend #-} + +-- | Extract the 'Leftmost' element. This will fairly eagerly determine that it +-- can return 'Just' the moment it sees any element at all. +getLeftmost :: Leftmost a -> Maybe a +getLeftmost LPure = Nothing +getLeftmost (LLeaf a) = Just a +getLeftmost (LStep x) = go x + where + -- Make getLeftmost non-recursive so it might be inlined for LPure/LLeaf. + go LPure = Nothing + go (LLeaf a) = Just a + go (LStep a) = go a + +-- | Used for 'Optics.Fold.lastOf' and 'Optics.IxFold.ilastOf'. +data Rightmost a = RPure | RLeaf a | RStep (Rightmost a) + +instance SG.Semigroup (Rightmost a) where + x <> y = RStep $ case y of + RPure -> x + RLeaf _ -> y + RStep y' -> case x of + -- The last two cases make lastOf produce a Just as soon as any element is + -- encountered, and possibly serve as a micro-optimisation; this behaviour + -- can be disabled by replacing them with _ -> mappend x y'. Note that + -- this means that lastOf folded [1..] is Just _|_. + RPure -> y' + RLeaf a -> RLeaf $ fromMaybe a (getRightmost y') + RStep x' -> mappend x' y' + +instance Monoid (Rightmost a) where + mempty = RPure + mappend = (SG.<>) + {-# INLINE mempty #-} + {-# INLINE mappend #-} + +-- | Extract the 'Rightmost' element. This will fairly eagerly determine that it +-- can return 'Just' the moment it sees any element at all. +getRightmost :: Rightmost a -> Maybe a +getRightmost RPure = Nothing +getRightmost (RLeaf a) = Just a +getRightmost (RStep x) = go x + where + -- Make getRightmost non-recursive so it might be inlined for RPure/RLeaf. + go RPure = Nothing + go (RLeaf a) = Just a + go (RStep a) = go a diff --git a/src/Optics/Internal/Indexed.hs b/src/Optics/Internal/Indexed.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Internal/Indexed.hs @@ -0,0 +1,604 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | Internal implementation details of indexed optics. +-- +-- This module is intended for internal use only, and may change without warning +-- in subsequent releases. +module Optics.Internal.Indexed where + +import Control.Applicative +import Control.Applicative.Backwards +import Control.Monad.Trans.Identity +import Control.Monad.Trans.Reader +import Data.Functor.Compose +import Data.Functor.Identity +import Data.Functor.Product +import Data.Functor.Reverse +import Data.Functor.Sum +import Data.Ix +import Data.List.NonEmpty +import Data.Monoid hiding (Product, Sum) +import Data.Proxy +import Data.Tree +import Data.Void +import GHC.Generics +import GHC.TypeLits +import qualified Data.Array as Array +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import qualified Data.Sequence as Seq + +import Optics.Internal.Optic +import Optics.Internal.Profunctor +import Optics.Internal.Utils + +-- | Show useful error message when a function expects optics without indices. +class is ~ NoIx => AcceptsEmptyIndices (f :: Symbol) (is :: [*]) + +instance + ( TypeError + ('Text "‘" ':<>: 'Text f ':<>: 'Text "’ accepts only optics with no indices") + , (x ': xs) ~ NoIx + ) => AcceptsEmptyIndices f (x ': xs) + +instance AcceptsEmptyIndices f '[] + +-- | Check whether a list of indices is not empty and generate sensible error +-- message if it's not. +class NonEmptyIndices (is :: [*]) + +instance + ( TypeError + ('Text "Indexed optic is expected") + ) => NonEmptyIndices '[] + +instance NonEmptyIndices (x ': xs) + +-- | Generate sensible error messages in case a user tries to pass either an +-- unindexed optic or indexed optic with unflattened indices where indexed optic +-- with a single index is expected. +class is ~ '[i] => HasSingleIndex (is :: [*]) (i :: *) + +instance HasSingleIndex '[i] i + +instance + ( TypeError + ('Text "Indexed optic is expected") + , '[] ~ '[i] + ) => HasSingleIndex '[] i + +instance + ( TypeError + ('Text "Use (<%>) or icompose to combine indices of type " + ':<>: ShowTypes is) + , is ~ '[i1, i2] + , is ~ '[i] + ) => HasSingleIndex '[i1, i2] i + +instance + ( TypeError + ('Text "Use icompose3 to combine indices of type " + ':<>: ShowTypes is) + , is ~ '[i1, i2, i3] + , is ~ '[i] + ) => HasSingleIndex [i1, i2, i3] i + +instance + ( TypeError + ('Text "Use icompose4 to combine indices of type " + ':<>: ShowTypes is) + , is ~ '[i1, i2, i3, i4] + , is ~ '[i] + ) => HasSingleIndex '[i1, i2, i3, i4] i + +instance + ( TypeError + ('Text "Use icompose5 to flatten indices of type " + ':<>: ShowTypes is) + , is ~ '[i1, i2, i3, i4, i5] + , is ~ '[i] + ) => HasSingleIndex '[i1, i2, i3, i4, i5] i + +instance + ( TypeError + ('Text "Use icomposeN to flatten indices of type " + ':<>: ShowTypes is) + , is ~ (i1 ': i2 ': i3 ': i4 ': i5 ': i6 : is') + , is ~ '[i] + ) => HasSingleIndex (i1 ': i2 ': i3 ': i4 ': i5 ': i6 ': is') i + +---------------------------------------- +-- Helpers for HasSingleIndex + +type family ShowTypes (types :: [*]) :: ErrorMessage where + ShowTypes '[i] = QuoteType i + ShowTypes '[i, j] = QuoteType i ':<>: 'Text " and " ':<>: QuoteType j + ShowTypes (i ': is) = QuoteType i ':<>: 'Text ", " ':<>: ShowTypes is + +---------------------------------------- + +data IntT f a = IntT {-# UNPACK #-} !Int (f a) + +unIntT :: IntT f a -> f a +unIntT (IntT _ fa) = fa + +newtype Indexing f a = Indexing { runIndexing :: Int -> IntT f a } + +instance Functor f => Functor (Indexing f) where + fmap f (Indexing m) = Indexing $ \i -> case m i of + IntT j x -> IntT j (fmap f x) + {-# INLINE fmap #-} + +instance Applicative f => Applicative (Indexing f) where + pure x = Indexing $ \i -> IntT i (pure x) + {-# INLINE pure #-} + Indexing mf <*> Indexing ma = Indexing $ \i -> case mf i of + IntT j ff -> case ma j of + IntT k fa -> IntT k (ff <*> fa) + {-# INLINE (<*>) #-} + +-- | Index a traversal by position of visited elements. +indexing + :: ((a -> Indexing f b) -> s -> Indexing f t) + -> ((Int -> a -> f b) -> s -> f t) +indexing l iafb s = + unIntT $ runIndexing (l (\a -> Indexing (\i -> IntT (i + 1) (iafb i a))) s) 0 +{-# INLINE indexing #-} + +---------------------------------------- + +-- | Construct a conjoined indexed optic that provides a separate code path when +-- used without indices. Useful for defining indexed optics that are as +-- efficient as their unindexed equivalents when used without indices. +-- +-- /Note:/ @'conjoined' f g@ is well-defined if and only if @f ≡ +-- 'Optics.Indexed.Core.noIx' g@. +conjoined + :: is `HasSingleIndex` i + => Optic k NoIx s t a b + -> Optic k is s t a b + -> Optic k is s t a b +conjoined (Optic f) (Optic g) = Optic (conjoined__ f g) +{-# INLINE conjoined #-} + +---------------------------------------- + +-- | Class for 'Functor's that have an additional read-only index available. +class Functor f => FunctorWithIndex i f | f -> i where + imap :: (i -> a -> b) -> f a -> f b + default imap + :: TraversableWithIndex i f => (i -> a -> b) -> f a -> f b + imap f = runIxFunArrow (iwander itraverse (IxFunArrow f)) id + {-# INLINE imap #-} + +-- | Class for 'Foldable's that have an additional read-only index available. +class (FunctorWithIndex i f, Foldable f + ) => FoldableWithIndex i f | f -> i where + ifoldMap :: Monoid m => (i -> a -> m) -> f a -> m + default ifoldMap + :: (TraversableWithIndex i f, Monoid m) => (i -> a -> m) -> f a -> m + ifoldMap f = runIxForget (iwander itraverse (IxForget f)) id + {-# INLINE ifoldMap #-} + + ifoldr :: (i -> a -> b -> b) -> b -> f a -> b + ifoldr iabb b0 = (\e -> appEndo e b0) . ifoldMap (\i -> Endo #. iabb i) + {-# INLINE ifoldr #-} + + ifoldl' :: (i -> b -> a -> b) -> b -> f a -> b + ifoldl' ibab b0 s = ifoldr (\i a bb b -> bb $! ibab i b a) id s b0 + {-# INLINE ifoldl' #-} + +-- | Traverse 'FoldableWithIndex' ignoring the results. +itraverse_ :: (FoldableWithIndex i t, Applicative f) => (i -> a -> f b) -> t a -> f () +itraverse_ f = runTraversed . ifoldMap (\i -> Traversed #. f i) +{-# INLINE itraverse_ #-} + +-- | Flipped 'itraverse_'. +ifor_ :: (FoldableWithIndex i t, Applicative f) => t a -> (i -> a -> f b) -> f () +ifor_ = flip itraverse_ +{-# INLINE ifor_ #-} + +-- | Class for 'Traversable's that have an additional read-only index available. +class (FoldableWithIndex i t, Traversable t + ) => TraversableWithIndex i t | t -> i where + itraverse :: Applicative f => (i -> a -> f b) -> t a -> f (t b) + +-- | Flipped 'itraverse' +ifor :: (TraversableWithIndex i t, Applicative f) => t a -> (i -> a -> f b) -> f (t b) +ifor = flip itraverse +{-# INLINE ifor #-} + +---------------------------------------- +-- Instances + +-- Identity + +instance FunctorWithIndex () Identity where + imap f (Identity a) = Identity (f () a) + {-# INLINE imap #-} + +instance FoldableWithIndex () Identity where + ifoldMap f (Identity a) = f () a + {-# INLINE ifoldMap #-} + +instance TraversableWithIndex () Identity where + itraverse f (Identity a) = Identity <$> f () a + {-# INLINE itraverse #-} + +-- (,) k + +instance FunctorWithIndex k ((,) k) where + imap f (k, a) = (k, f k a) + {-# INLINE imap #-} + +instance FoldableWithIndex k ((,) k) where + ifoldMap = uncurry + {-# INLINE ifoldMap #-} + +instance TraversableWithIndex k ((,) k) where + itraverse f (k, a) = (,) k <$> f k a + {-# INLINE itraverse #-} + +-- (->) r + +instance FunctorWithIndex r ((->) r) where + imap f g x = f x (g x) + {-# INLINE imap #-} + +-- [] + +instance FunctorWithIndex Int [] +instance FoldableWithIndex Int [] +instance TraversableWithIndex Int [] where + -- Faster than @indexing traverse@, also best for folds and setters. + itraverse f = traverse (uncurry f) . Prelude.zip [0..] + {-# INLINE itraverse #-} + +-- ZipList + +instance FunctorWithIndex Int ZipList +instance FoldableWithIndex Int ZipList +instance TraversableWithIndex Int ZipList where + itraverse f (ZipList xs) = ZipList <$> itraverse f xs + {-# INLINE itraverse #-} + +-- NonEmpty + +instance FunctorWithIndex Int NonEmpty +instance FoldableWithIndex Int NonEmpty +instance TraversableWithIndex Int NonEmpty where + itraverse f ~(a :| as) = + (:|) <$> f 0 a <*> traverse (uncurry f) (Prelude.zip [1..] as) + {-# INLINE itraverse #-} + +-- Maybe + +instance FunctorWithIndex () Maybe where + imap f = fmap (f ()) + {-# INLINE imap #-} +instance FoldableWithIndex () Maybe where + ifoldMap f = foldMap (f ()) + {-# INLINE ifoldMap #-} +instance TraversableWithIndex () Maybe where + itraverse f = traverse (f ()) + {-# INLINE itraverse #-} + +-- Seq + +-- | The position in the 'Seq.Seq' is available as the index. +instance FunctorWithIndex Int Seq.Seq where + imap = Seq.mapWithIndex + {-# INLINE imap #-} +instance FoldableWithIndex Int Seq.Seq where +#if MIN_VERSION_containers(0,5,8) + ifoldMap = Seq.foldMapWithIndex +#else + ifoldMap f = ifoldr (\i -> mappend . f i) mempty +#endif + {-# INLINE ifoldMap #-} + + ifoldr = Seq.foldrWithIndex + {-# INLINE ifoldr #-} + +instance TraversableWithIndex Int Seq.Seq where + -- This is much faster than Seq.traverseWithIndex. wut? + itraverse f = sequenceA . Seq.mapWithIndex f + {-# INLINE itraverse #-} + +-- IntMap + +instance FunctorWithIndex Int IntMap.IntMap where + imap = IntMap.mapWithKey + {-# INLINE imap #-} +instance FoldableWithIndex Int IntMap.IntMap where + ifoldMap = IntMap.foldMapWithKey + ifoldr = IntMap.foldrWithKey + ifoldl' = IntMap.foldlWithKey' . flip + {-# INLINE ifoldMap #-} + {-# INLINE ifoldr #-} + {-# INLINE ifoldl' #-} +instance TraversableWithIndex Int IntMap.IntMap where + itraverse = IntMap.traverseWithKey + {-# INLINE itraverse #-} + +-- Map + +instance FunctorWithIndex k (Map.Map k) where + imap = Map.mapWithKey + {-# INLINE imap #-} +instance FoldableWithIndex k (Map.Map k) where + ifoldMap = Map.foldMapWithKey + ifoldr = Map.foldrWithKey + ifoldl' = Map.foldlWithKey' . flip + {-# INLINE ifoldMap #-} + {-# INLINE ifoldr #-} + {-# INLINE ifoldl' #-} +instance TraversableWithIndex k (Map.Map k) where + itraverse = Map.traverseWithKey + {-# INLINE itraverse #-} + +-- Array + +instance Ix i => FunctorWithIndex i (Array.Array i) where + imap f arr = Array.listArray (Array.bounds arr) + . fmap (uncurry f) $ Array.assocs arr + {-# INLINE imap #-} + +instance Ix i => FoldableWithIndex i (Array.Array i) where + ifoldMap f = foldMap (uncurry f) . Array.assocs + {-# INLINE ifoldMap #-} + +instance Ix i => TraversableWithIndex i (Array.Array i) where + itraverse f arr = Array.listArray (Array.bounds arr) + <$> traverse (uncurry f) (Array.assocs arr) + {-# INLINE itraverse #-} + +-- Compose + +instance (FunctorWithIndex i f, FunctorWithIndex j g + ) => FunctorWithIndex (i, j) (Compose f g) where + imap f (Compose fg) = Compose $ imap (\k -> imap (f . (,) k)) fg + {-# INLINE imap #-} + +instance (FoldableWithIndex i f, FoldableWithIndex j g + ) => FoldableWithIndex (i, j) (Compose f g) where + ifoldMap f (Compose fg) = ifoldMap (\k -> ifoldMap (f . (,) k)) fg + {-# INLINE ifoldMap #-} + +instance (TraversableWithIndex i f, TraversableWithIndex j g + ) => TraversableWithIndex (i, j) (Compose f g) where + itraverse f (Compose fg) = + Compose <$> itraverse (\k -> itraverse (f . (,) k)) fg + {-# INLINE itraverse #-} + +-- Sum + +instance (FunctorWithIndex i f, FunctorWithIndex j g + ) => FunctorWithIndex (Either i j) (Sum f g) where + imap q (InL fa) = InL (imap (q . Left) fa) + imap q (InR ga) = InR (imap (q . Right) ga) + {-# INLINE imap #-} + +instance (FoldableWithIndex i f, FoldableWithIndex j g + ) => FoldableWithIndex (Either i j) (Sum f g) where + ifoldMap q (InL fa) = ifoldMap (q . Left) fa + ifoldMap q (InR ga) = ifoldMap (q . Right) ga + {-# INLINE ifoldMap #-} + +instance (TraversableWithIndex i f, TraversableWithIndex j g + ) => TraversableWithIndex (Either i j) (Sum f g) where + itraverse q (InL fa) = InL <$> itraverse (q . Left) fa + itraverse q (InR ga) = InR <$> itraverse (q . Right) ga + {-# INLINE itraverse #-} + +-- Product + +instance (FunctorWithIndex i f, FunctorWithIndex j g + ) => FunctorWithIndex (Either i j) (Product f g) where + imap f (Pair a b) = Pair (imap (f . Left) a) (imap (f . Right) b) + {-# INLINE imap #-} + +instance (FoldableWithIndex i f, FoldableWithIndex j g + ) => FoldableWithIndex (Either i j) (Product f g) where + ifoldMap f (Pair a b) = + ifoldMap (f . Left) a `mappend` ifoldMap (f . Right) b + {-# INLINE ifoldMap #-} + +instance (TraversableWithIndex i f, TraversableWithIndex j g + ) => TraversableWithIndex (Either i j) (Product f g) where + itraverse f (Pair a b) = + Pair <$> itraverse (f . Left) a <*> itraverse (f . Right) b + {-# INLINE itraverse #-} + +-- Tree + +instance FunctorWithIndex [Int] Tree where + imap f (Node a as) = Node (f [] a) $ imap (\i -> imap (f . (:) i)) as + {-# INLINE imap #-} + +instance FoldableWithIndex [Int] Tree where + ifoldMap f (Node a as) = + f [] a `mappend` ifoldMap (\i -> ifoldMap (f . (:) i)) as + {-# INLINE ifoldMap #-} + +instance TraversableWithIndex [Int] Tree where + itraverse f (Node a as) = + Node <$> f [] a <*> itraverse (\i -> itraverse (f . (:) i)) as + {-# INLINE itraverse #-} + +-- Proxy + +instance FunctorWithIndex Void Proxy where + imap _ Proxy = Proxy + {-# INLINE imap #-} + +instance FoldableWithIndex Void Proxy where + ifoldMap _ _ = mempty + {-# INLINE ifoldMap #-} + +instance TraversableWithIndex Void Proxy where + itraverse _ _ = pure Proxy + {-# INLINE itraverse #-} + +-- Backwards + +instance FunctorWithIndex i f => FunctorWithIndex i (Backwards f) where + imap f = Backwards . imap f . forwards + {-# INLINE imap #-} + +instance FoldableWithIndex i f => FoldableWithIndex i (Backwards f) where + ifoldMap f = ifoldMap f . forwards + {-# INLINE ifoldMap #-} + +instance TraversableWithIndex i f => TraversableWithIndex i (Backwards f) where + itraverse f = fmap Backwards . itraverse f . forwards + {-# INLINE itraverse #-} + +-- Reverse + +instance FunctorWithIndex i f => FunctorWithIndex i (Reverse f) where + imap f = Reverse . imap f . getReverse + {-# INLINE imap #-} + +instance FoldableWithIndex i f => FoldableWithIndex i (Reverse f) where + ifoldMap f = getDual . ifoldMap (\i -> Dual #. f i) . getReverse + {-# INLINE ifoldMap #-} + +instance TraversableWithIndex i f => TraversableWithIndex i (Reverse f) where + itraverse f = + fmap Reverse . forwards . itraverse (\i -> Backwards . f i) . getReverse + {-# INLINE itraverse #-} + +-- IdentityT + +instance FunctorWithIndex i m => FunctorWithIndex i (IdentityT m) where + imap f (IdentityT m) = IdentityT $ imap f m + {-# INLINE imap #-} + +instance FoldableWithIndex i m => FoldableWithIndex i (IdentityT m) where + ifoldMap f (IdentityT m) = ifoldMap f m + {-# INLINE ifoldMap #-} + +instance TraversableWithIndex i m => TraversableWithIndex i (IdentityT m) where + itraverse f (IdentityT m) = IdentityT <$> itraverse f m + {-# INLINE itraverse #-} + +-- ReaderT + +instance FunctorWithIndex i m => FunctorWithIndex (e, i) (ReaderT e m) where + imap f (ReaderT m) = ReaderT $ \k -> imap (f . (,) k) (m k) + {-# INLINE imap #-} + +-- Generics + +instance FunctorWithIndex Void V1 where + imap _ v = v `seq` undefined + {-# INLINE imap #-} + +instance FoldableWithIndex Void V1 where + ifoldMap _ v = v `seq` undefined + +instance TraversableWithIndex Void V1 where + itraverse _ v = v `seq` undefined + +instance FunctorWithIndex Void U1 where + imap _ U1 = U1 + {-# INLINE imap #-} + +instance FoldableWithIndex Void U1 where + ifoldMap _ _ = mempty + {-# INLINE ifoldMap #-} + +instance TraversableWithIndex Void U1 where + itraverse _ U1 = pure U1 + {-# INLINE itraverse #-} + +instance FunctorWithIndex () Par1 where + imap f = fmap (f ()) + {-# INLINE imap #-} + +instance FoldableWithIndex () Par1 where + ifoldMap f (Par1 a) = f () a + {-# INLINE ifoldMap #-} + +instance TraversableWithIndex () Par1 where + itraverse f (Par1 a) = Par1 <$> f () a + {-# INLINE itraverse #-} + +instance (FunctorWithIndex i f, FunctorWithIndex j g + ) => FunctorWithIndex (i, j) (f :.: g) where + imap q (Comp1 fga) = Comp1 (imap (\k -> imap (q . (,) k)) fga) + {-# INLINE imap #-} + +instance (FoldableWithIndex i f, FoldableWithIndex j g + ) => FoldableWithIndex (i, j) (f :.: g) where + ifoldMap q (Comp1 fga) = ifoldMap (\k -> ifoldMap (q . (,) k)) fga + {-# INLINE ifoldMap #-} + +instance (TraversableWithIndex i f, TraversableWithIndex j g + ) => TraversableWithIndex (i, j) (f :.: g) where + itraverse q (Comp1 fga) = + Comp1 <$> itraverse (\k -> itraverse (q . (,) k)) fga + {-# INLINE itraverse #-} + +instance (FunctorWithIndex i f, FunctorWithIndex j g + ) => FunctorWithIndex (Either i j) (f :*: g) where + imap q (fa :*: ga) = imap (q . Left) fa :*: imap (q . Right) ga + {-# INLINE imap #-} + +instance (FoldableWithIndex i f, FoldableWithIndex j g + ) => FoldableWithIndex (Either i j) (f :*: g) where + ifoldMap q (fa :*: ga) = + ifoldMap (q . Left) fa `mappend` ifoldMap (q . Right) ga + {-# INLINE ifoldMap #-} + +instance (TraversableWithIndex i f, TraversableWithIndex j g + ) => TraversableWithIndex (Either i j) (f :*: g) where + itraverse q (fa :*: ga) = + (:*:) <$> itraverse (q . Left) fa <*> itraverse (q . Right) ga + {-# INLINE itraverse #-} + +instance (FunctorWithIndex i f, FunctorWithIndex j g + ) => FunctorWithIndex (Either i j) (f :+: g) where + imap q (L1 fa) = L1 (imap (q . Left) fa) + imap q (R1 ga) = R1 (imap (q . Right) ga) + {-# INLINE imap #-} + +instance (FoldableWithIndex i f, FoldableWithIndex j g + ) => FoldableWithIndex (Either i j) (f :+: g) where + ifoldMap q (L1 fa) = ifoldMap (q . Left) fa + ifoldMap q (R1 ga) = ifoldMap (q . Right) ga + {-# INLINE ifoldMap #-} + +instance (TraversableWithIndex i f, TraversableWithIndex j g + ) => TraversableWithIndex (Either i j) (f :+: g) where + itraverse q (L1 fa) = L1 <$> itraverse (q . Left) fa + itraverse q (R1 ga) = R1 <$> itraverse (q . Right) ga + {-# INLINE itraverse #-} + +instance FunctorWithIndex i f => FunctorWithIndex i (Rec1 f) where + imap q (Rec1 f) = Rec1 (imap q f) + {-# INLINE imap #-} + +instance FoldableWithIndex i f => FoldableWithIndex i (Rec1 f) where + ifoldMap q (Rec1 f) = ifoldMap q f + {-# INLINE ifoldMap #-} + +instance TraversableWithIndex i f => TraversableWithIndex i (Rec1 f) where + itraverse q (Rec1 f) = Rec1 <$> itraverse q f + {-# INLINE itraverse #-} + +instance FunctorWithIndex Void (K1 i c) where + imap _ (K1 c) = K1 c + {-# INLINE imap #-} + +instance FoldableWithIndex Void (K1 i c) where + ifoldMap _ _ = mempty + {-# INLINE ifoldMap #-} + +instance TraversableWithIndex Void (K1 i c) where + itraverse _ (K1 a) = pure (K1 a) + {-# INLINE itraverse #-} diff --git a/src/Optics/Internal/IxFold.hs b/src/Optics/Internal/IxFold.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Internal/IxFold.hs @@ -0,0 +1,41 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | Internal implementation details of indexed folds. +-- +-- This module is intended for internal use only, and may change without warning +-- in subsequent releases. +module Optics.Internal.IxFold where + +import Data.Functor +import Data.Foldable + +import Optics.Internal.Bi +import Optics.Internal.Indexed +import Optics.Internal.Profunctor +import Optics.Internal.Optic +import Optics.Internal.Fold + +-- | Internal implementation of 'Optics.IxFold.ifoldVL'. +ifoldVL__ + :: (Bicontravariant p, Traversing p) + => (forall f. Applicative f => (i -> a -> f u) -> s -> f v) + -> Optic__ p j (i -> j) s t a b +ifoldVL__ f = rphantom . iwander f . rphantom +{-# INLINE ifoldVL__ #-} + +-- | Internal implementation of 'Optics.IxFold.ifolded'. +ifolded__ + :: (Bicontravariant p, Traversing p, FoldableWithIndex i f) + => Optic__ p j (i -> j) (f a) t a b +ifolded__ = conjoined__ (foldVL__ traverse_) (ifoldVL__ itraverse_) +{-# INLINE ifolded__ #-} + +-- | Internal implementation of 'Optics.IxFold.ifoldring'. +ifoldring__ + :: (Bicontravariant p, Traversing p) + => (forall f. Applicative f => (i -> a -> f u -> f u) -> f v -> s -> f w) + -> Optic__ p j (i -> j) s t a b +ifoldring__ fr = ifoldVL__ $ \f -> void . fr (\i a -> (f i a *>)) (pure v) + where + v = error "ifoldring__: value used" +{-# INLINE ifoldring__ #-} diff --git a/src/Optics/Internal/IxSetter.hs b/src/Optics/Internal/IxSetter.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Internal/IxSetter.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | Internal implementation details of indexed setters. +-- +-- This module is intended for internal use only, and may change without warning +-- in subsequent releases. +module Optics.Internal.IxSetter where + +import Optics.Internal.Indexed +import Optics.Internal.Optic +import Optics.Internal.Profunctor + +-- | Internal implementation of 'Optics.IxSetter.imapped'. +imapped__ + :: (Mapping p, FunctorWithIndex i f) + => Optic__ p j (i -> j) (f a) (f b) a b +imapped__ = conjoined__ (roam fmap) (iroam imap) +{-# INLINE imapped__ #-} diff --git a/src/Optics/Internal/IxTraversal.hs b/src/Optics/Internal/IxTraversal.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Internal/IxTraversal.hs @@ -0,0 +1,54 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | Internal implementation details of indexed traversals. +-- +-- This module is intended for internal use only, and may change without warning +-- in subsequent releases. +module Optics.Internal.IxTraversal where + +import Optics.Internal.Fold +import Optics.Internal.Indexed +import Optics.Internal.IxFold +import Optics.Internal.IxSetter +import Optics.Internal.Optic +import Optics.Internal.Profunctor +import Optics.Internal.Setter + +-- | Internal implementation of 'Optics.IxTraversal.itraversed'. +itraversed__ + :: (Traversing p, TraversableWithIndex i f) + => Optic__ p j (i -> j) (f a) (f b) a b +itraversed__ = conjoined__ (wander traverse) (iwander itraverse) +{-# INLINE [0] itraversed__ #-} + +-- Because itraversed__ 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 + +"itraversed__ -> wander traverse" + forall (o :: Star g j a b). itraversed__ o = wander traverse (reStar o) + :: TraversableWithIndex i f => Star g (i -> j) (f a) (f b) + +"itraversed__ -> folded__" + forall (o :: Forget r j a b). itraversed__ o = folded__ (reForget o) + :: FoldableWithIndex i f => Forget r (i -> j) (f a) (f b) + +"itraversed__ -> mapped__" + forall (o :: FunArrow j a b). itraversed__ o = mapped__ (reFunArrow o) + :: FunctorWithIndex i f => FunArrow (i -> j) (f a) (f b) + +"itraversed__ -> itraverse" + forall (o :: IxStar g j a b). itraversed__ o = iwander itraverse o + :: TraversableWithIndex i f => IxStar g (i -> j) (f a) (f b) + +"itraversed__ -> ifolded__" + forall (o :: IxForget r j a b). itraversed__ o = ifolded__ o + :: FoldableWithIndex i f => IxForget r (i -> j) (f a) (f b) + +"itraversed__ -> imapped__" + forall (o :: IxFunArrow j a b). itraversed__ o = imapped__ o + :: FunctorWithIndex i f => IxFunArrow (i -> j) (f a) (f b) + +#-} diff --git a/src/Optics/Internal/Optic.hs b/src/Optics/Internal/Optic.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Internal/Optic.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | Core optic types and subtyping machinery. +-- +-- This module contains the core 'Optic' types, and the underlying +-- machinery that we need in order to implement the subtyping between +-- various different flavours of optics. +-- +-- The composition operator for optics is also defined here. +-- +-- This module is intended for internal use only, and may change without +-- warning in subsequent releases. +-- +module Optics.Internal.Optic + ( Optic(..) + , Optic' + , Optic_ + , Optic__ + , NoIx + , WithIx + , castOptic + , (%) + , (%%) + , (%&) + , IsProxy(..) + -- * Labels + , LabelOptic(..) + , LabelOptic' + -- * Re-exports + , module Optics.Internal.Optic.Subtyping + , module Optics.Internal.Optic.Types + , module Optics.Internal.Optic.TypeLevel + ) where + +import Data.Function ((&)) +import Data.Proxy (Proxy (..)) +import Data.Type.Equality +import GHC.OverloadedLabels +import GHC.TypeLits + +import Optics.Internal.Optic.Subtyping +import Optics.Internal.Optic.TypeLevel +import Optics.Internal.Optic.Types +import Optics.Internal.Profunctor + +-- to make %% simpler +import Unsafe.Coerce (unsafeCoerce) + +-- | An alias for an empty index-list +type NoIx = '[] + +-- | Singleton index list +type WithIx i = '[i] + +-- | Wrapper newtype for the whole family of optics. +-- +-- The first parameter @k@ identifies the particular optic kind (e.g. 'A_Lens' +-- or 'A_Traversal'). +-- +-- The parameter @is@ is a list of types available as indices. This will +-- typically be 'NoIx' for unindexed optics, or 'WithIx' for optics with a +-- single index. See the "Indexed optics" section of the overview documentation +-- in the @Optics@ module of the main @optics@ package for more details. +-- +-- The parameters @s@ and @t@ represent the "big" structure, +-- whereas @a@ and @b@ represent the "small" structure. +-- +newtype Optic (k :: *) (is :: [*]) s t a b = Optic + { getOptic :: forall p i. Profunctor p + => Optic_ k p i (Curry is i) s t a b + } + +-- | Common special case of 'Optic' where source and target types are equal. +-- +-- Here, we need only one "big" and one "small" type. For lenses, this +-- means that in the restricted form we cannot do type-changing updates. +-- +type Optic' k is s a = Optic k is s s a a + +-- | Type representing the various kinds of optics. +-- +-- The tag parameter @k@ is translated into constraints on @p@ +-- via the type family 'Constraints'. +-- +type Optic_ k p i j s t a b = Constraints k p => Optic__ p i j s t a b + +-- | Optic internally as a profunctor transformation. +type Optic__ p i j s t a b = p i a b -> p j s t + +-- | Proxy type for use as an argument to 'implies'. +-- +data IsProxy (k :: *) (l :: *) (p :: * -> * -> * -> *) = + IsProxy + +-- | Explicit cast from one optic flavour to another. +-- +-- The resulting optic kind is given in the first type argument, so you can use +-- TypeApplications to set it. For example +-- +-- @ +-- 'castOptic' @'A_Lens' o +-- @ +-- +-- turns @o@ into a 'Optics.Lens.Lens'. +-- +-- This is the identity function, modulo some constraint jiggery-pokery. +-- +castOptic + :: forall destKind srcKind is s t a b + . Is srcKind destKind + => Optic srcKind is s t a b + -> Optic destKind is s t a b +castOptic (Optic o) = Optic (implies' o) + where + implies' + :: forall p i + . Optic_ srcKind p i (Curry is i) s t a b + -> Optic_ destKind p i (Curry is i) s t a b + implies' x = implies (IsProxy :: IsProxy srcKind destKind p) x +{-# INLINE castOptic #-} + +-- | Compose two optics of compatible flavours. +-- +-- Returns an optic of the appropriate supertype. If either or both optics are +-- indexed, the composition preserves all the indices. +-- +infixl 9 % +(%) :: (Is k m, Is l m, m ~ Join k l, ks ~ Append is js) + => Optic k is s t u v + -> Optic l js u v a b + -> Optic m ks s t a b +o % o' = castOptic o %% castOptic o' +{-# INLINE (%) #-} + +-- | Compose two optics of the same flavour. +-- +-- Normally you can simply use ('%') instead, but this may be useful to help +-- type inference if the type of one of the optics is otherwise +-- under-constrained. +infixl 9 %% +(%%) :: forall k is js ks s t u v a b. ks ~ Append is js + => Optic k is s t u v + -> Optic k js u v a b + -> Optic k ks s t a b +Optic o %% Optic o' = Optic oo + where + -- unsafeCoerce to the rescue, for a proof see below. + oo :: forall p i. Profunctor p => Optic_ k p i (Curry ks i) s t a b + oo = (unsafeCoerce + :: Optic_ k p i (Curry is (Curry js i)) s t a b + -> Optic_ k p i (Curry ks i ) s t a b) + (o . o') +{-# INLINE (%%) #-} + +-- | Flipped function application, specialised to optics and binding tightly. +-- +-- Useful for post-composing optics transformations: +-- +-- >>> toListOf (ifolded %& ifiltered (\i s -> length s <= i)) ["", "a","abc"] +-- ["","a"] +-- +infixl 9 %& +(%&) :: Optic k is s t a b + -> (Optic k is s t a b -> Optic l js s' t' a' b') + -> Optic l js s' t' a' b' +(%&) = (&) +{-# INLINE (%&) #-} + + +-- | +-- +-- 'AppendProof' is a very simple class which provides a witness +-- +-- @ +-- foldr f (foldr f init xs) ys = foldr f init (ys ++ xs) +-- where f = (->) +-- @ +-- +-- It shows that usage of 'unsafeCoerce' in '(%%)' is, in fact, safe. +-- +class Append xs ys ~ zs => AppendProof (xs :: [*]) (ys :: [*]) (zs :: [*]) + | xs ys -> zs, zs xs -> ys {- , zs ys -> xs -} where + appendProof :: Proxy i -> Curry xs (Curry ys i) :~: Curry zs i + +instance ys ~ zs => AppendProof '[] ys zs where + appendProof _ = Refl + +instance + (Append (x : xs) ys ~ (x : zs), AppendProof xs ys zs + ) => AppendProof (x ': xs) ys (x ': zs) where + appendProof + :: forall i. Proxy i + -> Curry (x ': xs) (Curry ys i) :~: Curry (x ': zs) i + appendProof i = case appendProof @xs @ys @zs i of + Refl -> Refl + +---------------------------------------- +-- Labels + +-- | Support for overloaded labels as optics. An overloaded label @#foo@ can be +-- used as an optic if there is an instance of @'LabelOptic' "foo" k s t a b@. +-- +-- See "Optics.Label" for examples and further details. +-- +class LabelOptic (name :: Symbol) k s t a b | name s -> k a + , name t -> k b + , name s b -> t + , name t a -> s where + -- | Used to interpret overloaded label syntax. An overloaded label @#foo@ + -- corresponds to @'labelOptic' \@"foo"@. + labelOptic :: Optic k NoIx s t a b + +-- | If no instance matches, GHC tends to bury error messages "No instance for +-- LabelOptic..." within a ton of other error messages about ambiguous type +-- variables and overlapping instances which are irrelevant and confusing. Use +-- overlappable instance providing a custom type error to cut its efforts short. +instance {-# OVERLAPPABLE #-} + (LabelOptic name k s t a b, + TypeError + ('Text "No instance for LabelOptic " ':<>: 'ShowType name + ':<>: 'Text " " ':<>: QuoteType k + ':<>: 'Text " " ':<>: QuoteType s + ':<>: 'Text " " ':<>: QuoteType t + ':<>: 'Text " " ':<>: QuoteType a + ':<>: 'Text " " ':<>: QuoteType b + ':$$: 'Text " (maybe you forgot to define it or misspelled a name?)") + ) => LabelOptic name k s t a b where + labelOptic = error "unreachable" + +-- | Type synonym for a type-preserving optic as overloaded label. +type LabelOptic' name k s a = LabelOptic name k s s a a + +instance + (LabelOptic name k s t a b, is ~ NoIx + ) => IsLabel name (Optic k is s t a b) where +#if __GLASGOW_HASKELL__ >= 802 + fromLabel = labelOptic @name @k @s @t @a @b +#else + fromLabel _ = labelOptic @name @k @s @t @a @b +#endif + +-- $setup +-- >>> import Optics.Core diff --git a/src/Optics/Internal/Optic/Subtyping.hs b/src/Optics/Internal/Optic/Subtyping.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Internal/Optic/Subtyping.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | Instances to implement the subtyping hierarchy between optics. +-- +-- This module is intended for internal use only, and may change without warning +-- in subsequent releases. +module Optics.Internal.Optic.Subtyping where + +import GHC.TypeLits (ErrorMessage(..), TypeError) + +import Optics.Internal.Optic.Types + +-- | Subtyping relationship between kinds of optics. +-- +-- An instance of @'Is' k l@ means that any @'Optics.Optic.Optic' k@ can be used +-- as an @'Optics.Optic.Optic' l@. For example, we have an @'Is' 'A_Lens' +-- 'A_Traversal'@ instance, but not @'Is' 'A_Traversal' 'A_Lens'@. +-- +-- This class needs instances for all possible combinations of tags. +-- +class Is k l where + -- | Witness of the subtyping relationship. + implies :: + proxy k l p -> (Constraints k p => r) -> (Constraints l p => r) + +-- | Overlappable instance for a custom type error. +instance {-# OVERLAPPABLE #-} TypeError ('ShowType k + ':<>: 'Text " cannot be used as " + ':<>: 'ShowType l + ) => Is k l where + implies = error "unreachable" + +-- | Every kind of optic can be used as itself. +instance Is k k where + implies _ = id + +---------------------------------------- + +-- BEGIN GENERATED CONTENT + +-- An_Iso +instance Is An_Iso A_ReversedLens where implies _ = id +instance Is An_Iso A_ReversedPrism where implies _ = id +instance Is An_Iso A_Prism where implies _ = id +instance Is An_Iso A_Review where implies _ = id +instance Is An_Iso A_Lens where implies _ = id +instance Is An_Iso A_Getter where implies _ = id +instance Is An_Iso An_AffineTraversal where implies _ = id +instance Is An_Iso An_AffineFold where implies _ = id +instance Is An_Iso A_Traversal where implies _ = id +instance Is An_Iso A_Fold where implies _ = id +instance Is An_Iso A_Setter where implies _ = id +-- A_ReversedLens +instance Is A_ReversedLens A_Review where implies _ = id +-- A_ReversedPrism +instance Is A_ReversedPrism A_Getter where implies _ = id +instance Is A_ReversedPrism An_AffineFold where implies _ = id +instance Is A_ReversedPrism A_Fold where implies _ = id +-- A_Prism +instance Is A_Prism A_Review where implies _ = id +instance Is A_Prism An_AffineTraversal where implies _ = id +instance Is A_Prism An_AffineFold where implies _ = id +instance Is A_Prism A_Traversal where implies _ = id +instance Is A_Prism A_Fold where implies _ = id +instance Is A_Prism A_Setter where implies _ = id +-- A_Lens +instance Is A_Lens A_Getter where implies _ = id +instance Is A_Lens An_AffineTraversal where implies _ = id +instance Is A_Lens An_AffineFold where implies _ = id +instance Is A_Lens A_Traversal where implies _ = id +instance Is A_Lens A_Fold where implies _ = id +instance Is A_Lens A_Setter where implies _ = id +-- A_Getter +instance Is A_Getter An_AffineFold where implies _ = id +instance Is A_Getter A_Fold where implies _ = id +-- An_AffineTraversal +instance Is An_AffineTraversal An_AffineFold where implies _ = id +instance Is An_AffineTraversal A_Traversal where implies _ = id +instance Is An_AffineTraversal A_Fold where implies _ = id +instance Is An_AffineTraversal A_Setter where implies _ = id +-- An_AffineFold +instance Is An_AffineFold A_Fold where implies _ = id +-- A_Traversal +instance Is A_Traversal A_Fold where implies _ = id +instance Is A_Traversal A_Setter where implies _ = id + +-- END GENERATED CONTENT + +---------------------------------------- + +-- | Computes the least upper bound of two optics kinds. +-- +-- @Join k l@ represents the least upper bound of an @Optic k@ and an @Optic +-- l@. This means in particular that composition of an @Optic k@ and an @Optic +-- k@ will yield an @Optic (Join k l)@. +-- +type family Join (k :: *) (l :: *) where + -- BEGIN GENERATED CONTENT + -- An_Iso----- + Join An_Iso A_ReversedLens = A_ReversedLens + Join An_Iso A_ReversedPrism = A_ReversedPrism + Join An_Iso A_Prism = A_Prism + Join An_Iso A_Review = A_Review + Join An_Iso A_Lens = A_Lens + Join An_Iso A_Getter = A_Getter + Join An_Iso An_AffineTraversal = An_AffineTraversal + Join An_Iso An_AffineFold = An_AffineFold + Join An_Iso A_Traversal = A_Traversal + Join An_Iso A_Fold = A_Fold + Join An_Iso A_Setter = A_Setter + + -- A_ReversedLens----- + Join A_ReversedLens An_Iso = A_ReversedLens + -- no Join with A_ReversedPrism + Join A_ReversedLens A_Prism = A_Review + Join A_ReversedLens A_Review = A_Review + -- no Join with A_Lens + -- no Join with A_Getter + -- no Join with An_AffineTraversal + -- no Join with An_AffineFold + -- no Join with A_Traversal + -- no Join with A_Fold + -- no Join with A_Setter + + -- A_ReversedPrism----- + Join A_ReversedPrism An_Iso = A_ReversedPrism + -- no Join with A_ReversedLens + Join A_ReversedPrism A_Prism = An_AffineFold + -- no Join with A_Review + Join A_ReversedPrism A_Lens = A_Getter + Join A_ReversedPrism A_Getter = A_Getter + Join A_ReversedPrism An_AffineTraversal = An_AffineFold + Join A_ReversedPrism An_AffineFold = An_AffineFold + Join A_ReversedPrism A_Traversal = A_Fold + Join A_ReversedPrism A_Fold = A_Fold + -- no Join with A_Setter + + -- A_Prism----- + Join A_Prism An_Iso = A_Prism + Join A_Prism A_ReversedLens = A_Review + Join A_Prism A_ReversedPrism = An_AffineFold + Join A_Prism A_Review = A_Review + Join A_Prism A_Lens = An_AffineTraversal + Join A_Prism A_Getter = An_AffineFold + Join A_Prism An_AffineTraversal = An_AffineTraversal + Join A_Prism An_AffineFold = An_AffineFold + Join A_Prism A_Traversal = A_Traversal + Join A_Prism A_Fold = A_Fold + Join A_Prism A_Setter = A_Setter + + -- A_Review----- + Join A_Review An_Iso = A_Review + Join A_Review A_ReversedLens = A_Review + -- no Join with A_ReversedPrism + Join A_Review A_Prism = A_Review + -- no Join with A_Lens + -- no Join with A_Getter + -- no Join with An_AffineTraversal + -- no Join with An_AffineFold + -- no Join with A_Traversal + -- no Join with A_Fold + -- no Join with A_Setter + + -- A_Lens----- + Join A_Lens An_Iso = A_Lens + -- no Join with A_ReversedLens + Join A_Lens A_ReversedPrism = A_Getter + Join A_Lens A_Prism = An_AffineTraversal + -- no Join with A_Review + Join A_Lens A_Getter = A_Getter + Join A_Lens An_AffineTraversal = An_AffineTraversal + Join A_Lens An_AffineFold = An_AffineFold + Join A_Lens A_Traversal = A_Traversal + Join A_Lens A_Fold = A_Fold + Join A_Lens A_Setter = A_Setter + + -- A_Getter----- + Join A_Getter An_Iso = A_Getter + -- no Join with A_ReversedLens + Join A_Getter A_ReversedPrism = A_Getter + Join A_Getter A_Prism = An_AffineFold + -- no Join with A_Review + Join A_Getter A_Lens = A_Getter + Join A_Getter An_AffineTraversal = An_AffineFold + Join A_Getter An_AffineFold = An_AffineFold + Join A_Getter A_Traversal = A_Fold + Join A_Getter A_Fold = A_Fold + -- no Join with A_Setter + + -- An_AffineTraversal----- + Join An_AffineTraversal An_Iso = An_AffineTraversal + -- no Join with A_ReversedLens + Join An_AffineTraversal A_ReversedPrism = An_AffineFold + Join An_AffineTraversal A_Prism = An_AffineTraversal + -- no Join with A_Review + Join An_AffineTraversal A_Lens = An_AffineTraversal + Join An_AffineTraversal A_Getter = An_AffineFold + Join An_AffineTraversal An_AffineFold = An_AffineFold + Join An_AffineTraversal A_Traversal = A_Traversal + Join An_AffineTraversal A_Fold = A_Fold + Join An_AffineTraversal A_Setter = A_Setter + + -- An_AffineFold----- + Join An_AffineFold An_Iso = An_AffineFold + -- no Join with A_ReversedLens + Join An_AffineFold A_ReversedPrism = An_AffineFold + Join An_AffineFold A_Prism = An_AffineFold + -- no Join with A_Review + Join An_AffineFold A_Lens = An_AffineFold + Join An_AffineFold A_Getter = An_AffineFold + Join An_AffineFold An_AffineTraversal = An_AffineFold + Join An_AffineFold A_Traversal = A_Fold + Join An_AffineFold A_Fold = A_Fold + -- no Join with A_Setter + + -- A_Traversal----- + Join A_Traversal An_Iso = A_Traversal + -- no Join with A_ReversedLens + Join A_Traversal A_ReversedPrism = A_Fold + Join A_Traversal A_Prism = A_Traversal + -- no Join with A_Review + Join A_Traversal A_Lens = A_Traversal + Join A_Traversal A_Getter = A_Fold + Join A_Traversal An_AffineTraversal = A_Traversal + Join A_Traversal An_AffineFold = A_Fold + Join A_Traversal A_Fold = A_Fold + Join A_Traversal A_Setter = A_Setter + + -- A_Fold----- + Join A_Fold An_Iso = A_Fold + -- no Join with A_ReversedLens + Join A_Fold A_ReversedPrism = A_Fold + Join A_Fold A_Prism = A_Fold + -- no Join with A_Review + Join A_Fold A_Lens = A_Fold + Join A_Fold A_Getter = A_Fold + Join A_Fold An_AffineTraversal = A_Fold + Join A_Fold An_AffineFold = A_Fold + Join A_Fold A_Traversal = A_Fold + -- no Join with A_Setter + + -- A_Setter----- + Join A_Setter An_Iso = A_Setter + -- no Join with A_ReversedLens + -- no Join with A_ReversedPrism + Join A_Setter A_Prism = A_Setter + -- no Join with A_Review + Join A_Setter A_Lens = A_Setter + -- no Join with A_Getter + Join A_Setter An_AffineTraversal = A_Setter + -- no Join with An_AffineFold + Join A_Setter A_Traversal = A_Setter + -- no Join with A_Fold + + -- END GENERATED CONTENT + + -- Every optic kinds can be joined with itself. + Join k k = k + + -- Everything else is a type error. + Join k l = TypeError ('ShowType k + ':<>: 'Text " cannot be composed with " + ':<>: 'ShowType l) diff --git a/src/Optics/Internal/Optic/TypeLevel.hs b/src/Optics/Internal/Optic/TypeLevel.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Internal/Optic/TypeLevel.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | This module is intended for internal use only, and may change without +-- warning in subsequent releases. +module Optics.Internal.Optic.TypeLevel where + +import GHC.TypeLits + +-- | Show a type surrounded by quote marks. +type family QuoteType (x :: *) :: ErrorMessage where + QuoteType x = 'Text "‘" ':<>: 'ShowType x ':<>: 'Text "’" + +-- | Curry a type-level list. +-- +-- In pseudo (dependent-)Haskell: +-- +-- @ +-- 'Curry' xs y = 'foldr' (->) y xs +-- @ +type family Curry (xs :: [*]) (y :: *) :: * where + Curry '[] y = y + Curry (x ': xs) y = x -> Curry xs y + +-- | Append two type-level lists together. +type family Append (xs :: [*]) (ys :: [*]) :: [*] where + Append '[] ys = ys -- needed for (<%>) and (%>) + Append xs '[] = xs -- needed for (<%) + Append (x ': xs) ys = x ': Append xs ys + +-- | Class that is inhabited by all type-level lists @xs@, providing the ability +-- to compose a function under @'Curry' xs@. +class CurryCompose xs where + -- | Compose a function under @'Curry' xs@. This generalises @('.')@ (aka + -- 'fmap' for @(->)@) to work for curried functions with one argument for each + -- type in the list. + composeN :: (i -> j) -> Curry xs i -> Curry xs j + +instance CurryCompose '[] where + composeN = id + {-# INLINE composeN #-} + +instance CurryCompose xs => CurryCompose (x ': xs) where + composeN ij f = composeN @xs ij . f + {-# INLINE composeN #-} diff --git a/src/Optics/Internal/Optic/Types.hs b/src/Optics/Internal/Optic/Types.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Internal/Optic/Types.hs @@ -0,0 +1,54 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | This module is intended for internal use only, and may change without +-- warning in subsequent releases. +module Optics.Internal.Optic.Types where + +import GHC.Exts (Constraint) + +import Optics.Internal.Bi +import Optics.Internal.Profunctor + +-- | Tag for an iso. +data An_Iso +-- | Tag for a lens. +data A_Lens +-- | Tag for a prism. +data A_Prism +-- | Tag for an affine traversal. +data An_AffineTraversal +-- | Tag for a traversal. +data A_Traversal +-- | Tag for a setter. +data A_Setter +-- | Tag for a reversed prism. +data A_ReversedPrism +-- | Tag for a getter. +data A_Getter +-- | Tag for an affine fold. +data An_AffineFold +-- | Tag for a fold. +data A_Fold +-- | Tag for a reversed lens. +data A_ReversedLens +-- | Tag for a review. +data A_Review + +-- | Mapping tag types @k@ to constraints on @p@. +-- +-- Using this type family we define the constraints that the various flavours of +-- optics have to fulfill. +-- +type family Constraints (k :: *) (p :: * -> * -> * -> *) :: Constraint where + Constraints An_Iso p = Profunctor p + Constraints A_Lens p = Strong p + Constraints A_ReversedLens p = Costrong p + Constraints A_Prism p = Choice p + Constraints A_ReversedPrism p = Cochoice p + Constraints An_AffineTraversal p = Visiting p + Constraints A_Traversal p = Traversing p + Constraints A_Setter p = Mapping p + Constraints A_Getter p = (Bicontravariant p, Cochoice p, Strong p) + Constraints An_AffineFold p = (Bicontravariant p, Cochoice p, Visiting p) + Constraints A_Fold p = (Bicontravariant p, Cochoice p, Traversing p) + Constraints A_Review p = (Bifunctor p, Choice p, Costrong p) diff --git a/src/Optics/Internal/Profunctor.hs b/src/Optics/Internal/Profunctor.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Internal/Profunctor.hs @@ -0,0 +1,705 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | Definitions of concrete profunctors and profunctor classes. +-- +-- This module is intended for internal use only, and may change without warning +-- in subsequent releases. +module Optics.Internal.Profunctor where + +import Data.Coerce (Coercible, coerce) +import Data.Functor.Const +import Data.Functor.Identity + +import Optics.Internal.Utils + +---------------------------------------- +-- Concrete profunctors + +-- | Needed for traversals. +newtype Star f i a b = Star { runStar :: a -> f b } + +-- | Needed for getters and folds. +newtype Forget r i a b = Forget { runForget :: a -> r } + +-- | Needed for affine folds. +newtype ForgetM r i a b = ForgetM { runForgetM :: a -> Maybe r } + +-- | Needed for setters. +newtype FunArrow i a b = FunArrow { runFunArrow :: a -> b } + +-- | Needed for indexed traversals. +newtype IxStar f i a b = IxStar { runIxStar :: i -> a -> f b } + +-- | Needed for indexed folds. +newtype IxForget r i a b = IxForget { runIxForget :: i -> a -> r } + +-- | Needed for indexed affine folds. +newtype IxForgetM r i a b = IxForgetM { runIxForgetM :: i -> a -> Maybe r } + +-- | Needed for indexed setters. +newtype IxFunArrow i a b = IxFunArrow { runIxFunArrow :: i -> a -> b } + +---------------------------------------- +-- Utils + +-- Needed for strict application of (indexed) setters. +-- +-- Credit for this goes to Eric Mertens, see +-- . +data Identity' a = Identity' {-# UNPACK #-} !() a + deriving Functor + +instance Applicative Identity' where + pure a = Identity' () a + {-# INLINE pure #-} + Identity' () f <*> Identity' () x = Identity' () (f x) + {-# INLINE (<*>) #-} + +-- | Mark a value for evaluation to whnf. +-- +-- This allows us to, when applying a setter to a structure, evaluate only the +-- parts that we modify. If an optic focuses on multiple targets, Applicative +-- instance of Identity' makes sure that we force evaluation of all of them, but +-- we leave anything else alone. +-- +wrapIdentity' :: a -> Identity' a +wrapIdentity' a = Identity' (a `seq` ()) a +{-# INLINE wrapIdentity' #-} + +unwrapIdentity' :: Identity' a -> a +unwrapIdentity' (Identity' () a) = a +{-# INLINE unwrapIdentity' #-} + +---------------------------------------- + +-- | Needed for conversion of affine traversal back to its VL representation. +data StarA f i a b = StarA (forall r. r -> f r) (a -> f b) + +-- | Unwrap 'StarA'. +runStarA :: StarA f i a b -> a -> f b +runStarA (StarA _ k) = k +{-# INLINE runStarA #-} + +-- | Needed for conversion of indexed affine traversal back to its VL +-- representation. +data IxStarA f i a b = IxStarA (forall r. r -> f r) (i -> a -> f b) + +-- | Unwrap 'StarA'. +runIxStarA :: IxStarA f i a b -> i -> a -> f b +runIxStarA (IxStarA _ k) = k +{-# INLINE runIxStarA #-} + +---------------------------------------- + +-- | Repack 'Star' to change its index type. +reStar :: Star f i a b -> Star f j a b +reStar (Star k) = Star k +{-# INLINE reStar #-} + +-- | Repack 'Forget' to change its index type. +reForget :: Forget r i a b -> Forget r j a b +reForget (Forget k) = Forget k +{-# INLINE reForget #-} + +-- | Repack 'FunArrow' to change its index type. +reFunArrow :: FunArrow i a b -> FunArrow j a b +reFunArrow (FunArrow k) = FunArrow k +{-# INLINE reFunArrow #-} + +---------------------------------------- +-- Classes and instances + +class Profunctor p where + dimap :: (a -> b) -> (c -> d) -> p i b c -> p i a d + lmap :: (a -> b) -> p i b c -> p i a c + rmap :: (c -> d) -> p i b c -> p i b d + + lcoerce' :: Coercible a b => p i a c -> p i b c + default lcoerce' + :: Coercible (p i a c) (p i b c) + => p i a c + -> p i b c + lcoerce' = coerce + {-# INLINE lcoerce' #-} + + rcoerce' :: Coercible a b => p i c a -> p i c b + default rcoerce' + :: Coercible (p i c a) (p i c b) + => p i c a + -> p i c b + rcoerce' = coerce + {-# INLINE rcoerce' #-} + + conjoined__ + :: (p i a b -> p i s t) + -> (p i a b -> p j s t) + -> (p i a b -> p j s t) + default conjoined__ + :: Coercible (p i s t) (p j s t) + => (p i a b -> p i s t) + -> (p i a b -> p j s t) + -> (p i a b -> p j s t) + conjoined__ f _ = coerce . f + {-# INLINE conjoined__ #-} + + ixcontramap :: (j -> i) -> p i a b -> p j a b + default ixcontramap + :: Coercible (p i a b) (p j a b) + => (j -> i) + -> p i a b + -> p j a b + ixcontramap _ = coerce + {-# INLINE ixcontramap #-} + +-- | 'rcoerce'' with type arguments rearranged for TypeApplications. +rcoerce :: (Coercible a b, Profunctor p) => p i c a -> p i c b +rcoerce = rcoerce' +{-# INLINE rcoerce #-} + +-- | 'lcoerce'' with type arguments rearranged for TypeApplications. +lcoerce :: (Coercible a b, Profunctor p) => p i a c -> p i b c +lcoerce = lcoerce' +{-# INLINE lcoerce #-} + +instance Functor f => Profunctor (StarA f) where + dimap f g (StarA point k) = StarA point (fmap g . k . f) + lmap f (StarA point k) = StarA point (k . f) + rmap g (StarA point k) = StarA point (fmap g . k) + {-# INLINE dimap #-} + {-# INLINE lmap #-} + {-# INLINE rmap #-} + + rcoerce' = rmap coerce + {-# INLINE rcoerce' #-} + +instance Functor f => Profunctor (Star f) where + dimap f g (Star k) = Star (fmap g . k . f) + lmap f (Star k) = Star (k . f) + rmap g (Star k) = Star (fmap g . k) + {-# INLINE dimap #-} + {-# INLINE lmap #-} + {-# INLINE rmap #-} + + rcoerce' = rmap coerce + {-# INLINE rcoerce' #-} + +instance Profunctor (Forget r) where + dimap f _ (Forget k) = Forget (k . f) + lmap f (Forget k) = Forget (k . f) + rmap _g (Forget k) = Forget k + {-# INLINE dimap #-} + {-# INLINE lmap #-} + {-# INLINE rmap #-} + +instance Profunctor (ForgetM r) where + dimap f _ (ForgetM k) = ForgetM (k . f) + lmap f (ForgetM k) = ForgetM (k . f) + rmap _g (ForgetM k) = ForgetM k + {-# INLINE dimap #-} + {-# INLINE lmap #-} + {-# INLINE rmap #-} + +instance Profunctor FunArrow where + dimap f g (FunArrow k) = FunArrow (g . k . f) + lmap f (FunArrow k) = FunArrow (k . f) + rmap g (FunArrow k) = FunArrow (g . k) + {-# INLINE dimap #-} + {-# INLINE lmap #-} + {-# INLINE rmap #-} + +instance Functor f => Profunctor (IxStarA f) where + dimap f g (IxStarA point k) = IxStarA point (\i -> fmap g . k i . f) + lmap f (IxStarA point k) = IxStarA point (\i -> k i . f) + rmap g (IxStarA point k) = IxStarA point (\i -> fmap g . k i) + {-# INLINE dimap #-} + {-# INLINE lmap #-} + {-# INLINE rmap #-} + + rcoerce' = rmap coerce + {-# INLINE rcoerce' #-} + + conjoined__ _ f = f + ixcontramap ij (IxStarA point k) = IxStarA point $ \i -> k (ij i) + {-# INLINE conjoined__ #-} + {-# INLINE ixcontramap #-} + +instance Functor f => Profunctor (IxStar f) where + dimap f g (IxStar k) = IxStar (\i -> fmap g . k i . f) + lmap f (IxStar k) = IxStar (\i -> k i . f) + rmap g (IxStar k) = IxStar (\i -> fmap g . k i) + {-# INLINE dimap #-} + {-# INLINE lmap #-} + {-# INLINE rmap #-} + + rcoerce' = rmap coerce + {-# INLINE rcoerce' #-} + + conjoined__ _ f = f + ixcontramap ij (IxStar k) = IxStar $ \i -> k (ij i) + {-# INLINE conjoined__ #-} + {-# INLINE ixcontramap #-} + +instance Profunctor (IxForget r) where + dimap f _ (IxForget k) = IxForget (\i -> k i . f) + lmap f (IxForget k) = IxForget (\i -> k i . f) + rmap _g (IxForget k) = IxForget k + {-# INLINE dimap #-} + {-# INLINE lmap #-} + {-# INLINE rmap #-} + + conjoined__ _ f = f + ixcontramap ij (IxForget k) = IxForget $ \i -> k (ij i) + {-# INLINE conjoined__ #-} + {-# INLINE ixcontramap #-} + +instance Profunctor (IxForgetM r) where + dimap f _ (IxForgetM k) = IxForgetM (\i -> k i . f) + lmap f (IxForgetM k) = IxForgetM (\i -> k i . f) + rmap _g (IxForgetM k) = IxForgetM k + {-# INLINE dimap #-} + {-# INLINE lmap #-} + {-# INLINE rmap #-} + + conjoined__ _ f = f + ixcontramap ij (IxForgetM k) = IxForgetM $ \i -> k (ij i) + {-# INLINE conjoined__ #-} + {-# INLINE ixcontramap #-} + +instance Profunctor IxFunArrow where + dimap f g (IxFunArrow k) = IxFunArrow (\i -> g . k i . f) + lmap f (IxFunArrow k) = IxFunArrow (\i -> k i . f) + rmap g (IxFunArrow k) = IxFunArrow (\i -> g . k i) + {-# INLINE dimap #-} + {-# INLINE lmap #-} + {-# INLINE rmap #-} + + conjoined__ _ f = f + ixcontramap ij (IxFunArrow k) = IxFunArrow $ \i -> k (ij i) + {-# INLINE conjoined__ #-} + {-# INLINE ixcontramap #-} + +---------------------------------------- + +class Profunctor p => Strong p where + first' :: p i a b -> p i (a, c) (b, c) + second' :: p i a b -> p i (c, a) (c, b) + + -- There are a few places where default implementation is good enough. + linear + :: (forall f. Functor f => (a -> f b) -> s -> f t) + -> p i a b + -> p i s t + linear f = dimap + ((\(Context bt a) -> (a, bt)) . f (Context id)) + (\(b, bt) -> bt b) + . first' + {-# INLINE linear #-} + + -- There are a few places where default implementation is good enough. + ilinear + :: (forall f. Functor f => (i -> a -> f b) -> s -> f t) + -> p j a b + -> p (i -> j) s t + default ilinear + :: Coercible (p j s t) (p (i -> j) s t) + => (forall f. Functor f => (i -> a -> f b) -> s -> f t) + -> p j a b + -> p (i -> j) s t + ilinear f = coerce . linear (\afb -> f $ \_ -> afb) + {-# INLINE ilinear #-} + +instance Functor f => Strong (StarA f) where + first' (StarA point k) = StarA point $ \ ~(a, c) -> (\b' -> (b', c)) <$> k a + second' (StarA point k) = StarA point $ \ ~(c, a) -> (,) c <$> k a + {-# INLINE first' #-} + {-# INLINE second' #-} + + linear f (StarA point k) = StarA point (f k) + {-# INLINE linear #-} + +instance Functor f => Strong (Star f) where + first' (Star k) = Star $ \ ~(a, c) -> (\b' -> (b', c)) <$> k a + second' (Star k) = Star $ \ ~(c, a) -> (,) c <$> k a + {-# INLINE first' #-} + {-# INLINE second' #-} + + linear f (Star k) = Star (f k) + {-# INLINE linear #-} + +instance Strong (Forget r) where + first' (Forget k) = Forget (k . fst) + second' (Forget k) = Forget (k . snd) + {-# INLINE first' #-} + {-# INLINE second' #-} + + linear f (Forget k) = Forget (getConst #. f (Const #. k)) + {-# INLINE linear #-} + +instance Strong (ForgetM r) where + first' (ForgetM k) = ForgetM (k . fst) + second' (ForgetM k) = ForgetM (k . snd) + {-# INLINE first' #-} + {-# INLINE second' #-} + + linear f (ForgetM k) = ForgetM (getConst #. f (Const #. k)) + {-# INLINE linear #-} + +instance Strong FunArrow where + first' (FunArrow k) = FunArrow $ \ ~(a, c) -> (k a, c) + second' (FunArrow k) = FunArrow $ \ ~(c, a) -> (c, k a) + {-# INLINE first' #-} + {-# INLINE second' #-} + + linear f (FunArrow k) = FunArrow $ runIdentity #. f (Identity #. k) + {-# INLINE linear #-} + +instance Functor f => Strong (IxStarA f) where + first' (IxStarA point k) = IxStarA point $ \i ~(a, c) -> (\b' -> (b', c)) <$> k i a + second' (IxStarA point k) = IxStarA point $ \i ~(c, a) -> (,) c <$> k i a + {-# INLINE first' #-} + {-# INLINE second' #-} + + linear f (IxStarA point k) = IxStarA point $ \i -> f (k i) + ilinear f (IxStarA point k) = IxStarA point $ \ij -> f $ \i -> k (ij i) + {-# INLINE linear #-} + {-# INLINE ilinear #-} + +instance Functor f => Strong (IxStar f) where + first' (IxStar k) = IxStar $ \i ~(a, c) -> (\b' -> (b', c)) <$> k i a + second' (IxStar k) = IxStar $ \i ~(c, a) -> (,) c <$> k i a + {-# INLINE first' #-} + {-# INLINE second' #-} + + linear f (IxStar k) = IxStar $ \i -> f (k i) + ilinear f (IxStar k) = IxStar $ \ij -> f $ \i -> k (ij i) + {-# INLINE linear #-} + {-# INLINE ilinear #-} + +instance Strong (IxForget r) where + first' (IxForget k) = IxForget $ \i -> k i . fst + second' (IxForget k) = IxForget $ \i -> k i . snd + {-# INLINE first' #-} + {-# INLINE second' #-} + + linear f (IxForget k) = IxForget $ \i -> getConst #. f (Const #. k i) + ilinear f (IxForget k) = IxForget $ \ij -> getConst #. f (\i -> Const #. k (ij i)) + {-# INLINE linear #-} + {-# INLINE ilinear #-} + +instance Strong (IxForgetM r) where + first' (IxForgetM k) = IxForgetM $ \i -> k i . fst + second' (IxForgetM k) = IxForgetM $ \i -> k i . snd + {-# INLINE first' #-} + {-# INLINE second' #-} + + linear f (IxForgetM k) = IxForgetM $ \i -> getConst #. f (Const #. k i) + ilinear f (IxForgetM k) = IxForgetM $ \ij -> getConst #. f (\i -> Const #. k (ij i)) + {-# INLINE linear #-} + {-# INLINE ilinear #-} + +instance Strong IxFunArrow where + first' (IxFunArrow k) = IxFunArrow $ \i ~(a, c) -> (k i a, c) + second' (IxFunArrow k) = IxFunArrow $ \i ~(c, a) -> (c, k i a) + {-# INLINE first' #-} + {-# INLINE second' #-} + + linear f (IxFunArrow k) = IxFunArrow $ \i -> + runIdentity #. f (Identity #. k i) + ilinear f (IxFunArrow k) = IxFunArrow $ \ij -> + runIdentity #. f (\i -> Identity #. k (ij i)) + {-# INLINE linear #-} + {-# INLINE ilinear #-} + +---------------------------------------- + +class Profunctor p => Costrong p where + unfirst :: p i (a, d) (b, d) -> p i a b + unsecond :: p i (d, a) (d, b) -> p i a b + +---------------------------------------- + +class Profunctor p => Choice p where + left' :: p i a b -> p i (Either a c) (Either b c) + right' :: p i a b -> p i (Either c a) (Either c b) + +instance Functor f => Choice (StarA f) where + left' (StarA point k) = StarA point $ either (fmap Left . k) (point . Right) + right' (StarA point k) = StarA point $ either (point . Left) (fmap Right . k) + {-# INLINE left' #-} + {-# INLINE right' #-} + +instance Applicative f => Choice (Star f) where + left' (Star k) = Star $ either (fmap Left . k) (pure . Right) + right' (Star k) = Star $ either (pure . Left) (fmap Right . k) + {-# INLINE left' #-} + {-# INLINE right' #-} + +instance Monoid r => Choice (Forget r) where + left' (Forget k) = Forget $ either k (const mempty) + right' (Forget k) = Forget $ either (const mempty) k + {-# INLINE left' #-} + {-# INLINE right' #-} + +instance Choice (ForgetM r) where + left' (ForgetM k) = ForgetM $ either k (const Nothing) + right' (ForgetM k) = ForgetM $ either (const Nothing) k + {-# INLINE left' #-} + {-# INLINE right' #-} + +instance Choice FunArrow where + left' (FunArrow k) = FunArrow $ either (Left . k) Right + right' (FunArrow k) = FunArrow $ either Left (Right . k) + {-# INLINE left' #-} + {-# INLINE right' #-} + +instance Functor f => Choice (IxStarA f) where + left' (IxStarA point k) = + IxStarA point $ \i -> either (fmap Left . k i) (point . Right) + right' (IxStarA point k) = + IxStarA point $ \i -> either (point . Left) (fmap Right . k i) + {-# INLINE left' #-} + {-# INLINE right' #-} + +instance Applicative f => Choice (IxStar f) where + left' (IxStar k) = IxStar $ \i -> either (fmap Left . k i) (pure . Right) + right' (IxStar k) = IxStar $ \i -> either (pure . Left) (fmap Right . k i) + {-# INLINE left' #-} + {-# INLINE right' #-} + +instance Monoid r => Choice (IxForget r) where + left' (IxForget k) = IxForget $ \i -> either (k i) (const mempty) + right' (IxForget k) = IxForget $ \i -> either (const mempty) (k i) + {-# INLINE left' #-} + {-# INLINE right' #-} + +instance Choice (IxForgetM r) where + left' (IxForgetM k) = IxForgetM $ \i -> either (k i) (const Nothing) + right' (IxForgetM k) = IxForgetM $ \i -> either (const Nothing) (k i) + {-# INLINE left' #-} + {-# INLINE right' #-} + +instance Choice IxFunArrow where + left' (IxFunArrow k) = IxFunArrow $ \i -> either (Left . k i) Right + right' (IxFunArrow k) = IxFunArrow $ \i -> either Left (Right . k i) + {-# INLINE left' #-} + {-# INLINE right' #-} + +---------------------------------------- + +class Profunctor p => Cochoice p where + unleft :: p i (Either a d) (Either b d) -> p i a b + unright :: p i (Either d a) (Either d b) -> p i a b + +instance Cochoice (Forget r) where + unleft (Forget k) = Forget (k . Left) + unright (Forget k) = Forget (k . Right) + {-# INLINE unleft #-} + {-# INLINE unright #-} + +instance Cochoice (ForgetM r) where + unleft (ForgetM k) = ForgetM (k . Left) + unright (ForgetM k) = ForgetM (k . Right) + {-# INLINE unleft #-} + {-# INLINE unright #-} + +instance Cochoice (IxForget r) where + unleft (IxForget k) = IxForget $ \i -> k i . Left + unright (IxForget k) = IxForget $ \i -> k i . Right + {-# INLINE unleft #-} + {-# INLINE unright #-} + +instance Cochoice (IxForgetM r) where + unleft (IxForgetM k) = IxForgetM (\i -> k i . Left) + unright (IxForgetM k) = IxForgetM (\i -> k i . Right) + {-# INLINE unleft #-} + {-# INLINE unright #-} + +---------------------------------------- + +class (Choice p, Strong p) => Visiting p where + visit + :: forall i s t a b + . (forall f. Functor f => (forall r. r -> f r) -> (a -> f b) -> s -> f t) + -> p i a b + -> p i s t + visit f = + let match :: s -> Either a t + match s = f Right Left s + update :: s -> b -> t + update s b = runIdentity $ f Identity (\_ -> Identity b) s + in dimap (\s -> (match s, s)) + (\(ebt, s) -> either (update s) id ebt) + . first' + . left' + {-# INLINE visit #-} + + ivisit + :: (forall f. Functor f => (forall r. r -> f r) -> (i -> a -> f b) -> s -> f t) + -> p j a b + -> p (i -> j) s t + default ivisit + :: Coercible (p j s t) (p (i -> j) s t) + => (forall f. Functor f => (forall r. r -> f r) -> (i -> a -> f b) -> s -> f t) + -> p j a b + -> p (i -> j) s t + ivisit f = coerce . visit (\point afb -> f point $ \_ -> afb) + {-# INLINE ivisit #-} + + +instance Functor f => Visiting (StarA f) where + visit f (StarA point k) = StarA point $ f point k + ivisit f (StarA point k) = StarA point $ f point (\_ -> k) + {-# INLINE visit #-} + {-# INLINE ivisit #-} + +instance Applicative f => Visiting (Star f) where + visit f (Star k) = Star $ f pure k + ivisit f (Star k) = Star $ f pure (\_ -> k) + {-# INLINE visit #-} + {-# INLINE ivisit #-} + +instance Monoid r => Visiting (Forget r) where + visit f (Forget k) = Forget $ getConst #. f pure (Const #. k) + ivisit f (Forget k) = Forget $ getConst #. f pure (\_ -> Const #. k) + {-# INLINE visit #-} + {-# INLINE ivisit #-} + +instance Visiting (ForgetM r) where + visit f (ForgetM k) = + ForgetM $ getConst #. f (\_ -> Const Nothing) (Const #. k) + ivisit f (ForgetM k) = + ForgetM $ getConst #. f (\_ -> Const Nothing) (\_ -> Const #. k) + {-# INLINE visit #-} + {-# INLINE ivisit #-} + +instance Visiting FunArrow where + visit f (FunArrow k) = FunArrow $ runIdentity #. f pure (Identity #. k) + ivisit f (FunArrow k) = FunArrow $ runIdentity #. f pure (\_ -> Identity #. k) + {-# INLINE visit #-} + {-# INLINE ivisit #-} + +instance Functor f => Visiting (IxStarA f) where + visit f (IxStarA point k) = IxStarA point $ \i -> f point (k i) + ivisit f (IxStarA point k) = IxStarA point $ \ij -> f point $ \i -> k (ij i) + {-# INLINE visit #-} + {-# INLINE ivisit #-} + +instance Applicative f => Visiting (IxStar f) where + visit f (IxStar k) = IxStar $ \i -> f pure (k i) + ivisit f (IxStar k) = IxStar $ \ij -> f pure $ \i -> k (ij i) + {-# INLINE visit #-} + {-# INLINE ivisit #-} + +instance Monoid r => Visiting (IxForget r) where + visit f (IxForget k) = + IxForget $ \i -> getConst #. f pure (Const #. k i) + ivisit f (IxForget k) = + IxForget $ \ij -> getConst #. f pure (\i -> Const #. k (ij i)) + {-# INLINE visit #-} + {-# INLINE ivisit #-} + +instance Visiting (IxForgetM r) where + visit f (IxForgetM k) = + IxForgetM $ \i -> getConst #. f (\_ -> Const Nothing) (Const #. k i) + ivisit f (IxForgetM k) = + IxForgetM $ \ij -> getConst #. f (\_ -> Const Nothing) (\i -> Const #. k (ij i)) + {-# INLINE visit #-} + {-# INLINE ivisit #-} + +instance Visiting IxFunArrow where + visit f (IxFunArrow k) = + IxFunArrow $ \i -> runIdentity #. f pure (Identity #. k i) + ivisit f (IxFunArrow k) = + IxFunArrow $ \ij -> runIdentity #. f pure (\i -> Identity #. k (ij i)) + {-# INLINE visit #-} + {-# INLINE ivisit #-} + +---------------------------------------- + +class Visiting p => Traversing p where + wander + :: (forall f. Applicative f => (a -> f b) -> s -> f t) + -> p i a b + -> p i s t + iwander + :: (forall f. Applicative f => (i -> a -> f b) -> s -> f t) + -> p j a b + -> p (i -> j) s t + +instance Applicative f => Traversing (Star f) where + wander f (Star k) = Star $ f k + iwander f (Star k) = Star $ f (\_ -> k) + {-# INLINE wander #-} + {-# INLINE iwander #-} + +instance Monoid r => Traversing (Forget r) where + wander f (Forget k) = Forget $ getConst #. f (Const #. k) + iwander f (Forget k) = Forget $ getConst #. f (\_ -> Const #. k) + {-# INLINE wander #-} + {-# INLINE iwander #-} + +instance Traversing FunArrow where + wander f (FunArrow k) = FunArrow $ runIdentity #. f (Identity #. k) + iwander f (FunArrow k) = FunArrow $ runIdentity #. f (\_ -> Identity #. k) + {-# INLINE wander #-} + {-# INLINE iwander #-} + +instance Applicative f => Traversing (IxStar f) where + wander f (IxStar k) = IxStar $ \i -> f (k i) + iwander f (IxStar k) = IxStar $ \ij -> f $ \i -> k (ij i) + {-# INLINE wander #-} + {-# INLINE iwander #-} + +instance Monoid r => Traversing (IxForget r) where + wander f (IxForget k) = + IxForget $ \i -> getConst #. f (Const #. k i) + iwander f (IxForget k) = + IxForget $ \ij -> getConst #. f (\i -> Const #. k (ij i)) + {-# INLINE wander #-} + {-# INLINE iwander #-} + +instance Traversing IxFunArrow where + wander f (IxFunArrow k) = + IxFunArrow $ \i -> runIdentity #. f (Identity #. k i) + iwander f (IxFunArrow k) = + IxFunArrow $ \ij -> runIdentity #. f (\i -> Identity #. k (ij i)) + {-# INLINE wander #-} + {-# INLINE iwander #-} + +---------------------------------------- + +class Traversing p => Mapping p where + roam + :: ((a -> b) -> s -> t) + -> p i a b + -> p i s t + iroam + :: ((i -> a -> b) -> s -> t) + -> p j a b + -> p (i -> j) s t + +instance Mapping (Star Identity') where + roam f (Star k) = Star $ wrapIdentity' . f (unwrapIdentity' . k) + iroam f (Star k) = Star $ wrapIdentity' . f (\_ -> unwrapIdentity' . k) + {-# INLINE roam #-} + {-# INLINE iroam #-} + +instance Mapping FunArrow where + roam f (FunArrow k) = FunArrow $ f k + iroam f (FunArrow k) = FunArrow $ f (const k) + {-# INLINE roam #-} + {-# INLINE iroam #-} + +instance Mapping (IxStar Identity') where + roam f (IxStar k) = + IxStar $ \i -> wrapIdentity' . f (unwrapIdentity' . k i) + iroam f (IxStar k) = + IxStar $ \ij -> wrapIdentity' . f (\i -> unwrapIdentity' . k (ij i)) + {-# INLINE roam #-} + {-# INLINE iroam #-} + +instance Mapping IxFunArrow where + roam f (IxFunArrow k) = IxFunArrow $ \i -> f (k i) + iroam f (IxFunArrow k) = IxFunArrow $ \ij -> f $ \i -> k (ij i) + {-# INLINE roam #-} + {-# INLINE iroam #-} diff --git a/src/Optics/Internal/Setter.hs b/src/Optics/Internal/Setter.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Internal/Setter.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | Internal implementation details of setters. +-- +-- This module is intended for internal use only, and may change without warning +-- in subsequent releases. +module Optics.Internal.Setter where + +import Optics.Internal.Profunctor +import Optics.Internal.Optic + +-- | Internal implementation of 'Optics.Setter.mapped'. +mapped__ + :: (Mapping p, Functor f) + => Optic__ p i i (f a) (f b) a b +mapped__ = roam fmap +{-# INLINE mapped__ #-} diff --git a/src/Optics/Internal/Tagged.hs b/src/Optics/Internal/Tagged.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Internal/Tagged.hs @@ -0,0 +1,50 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | Based on the @tagged@ package. +-- +-- This module is intended for internal use only, and may change without warning +-- in subsequent releases. +-- +module Optics.Internal.Tagged where + +import Data.Coerce + +import Optics.Internal.Bi +import Optics.Internal.Profunctor +import Optics.Internal.Utils + +-- | Tag a value with not one but two phantom type parameters (so that 'Tagged' +-- can be used as an indexed profunctor). +newtype Tagged i a b = Tagged { unTagged :: b } + +instance Functor (Tagged i a) where + fmap f = Tagged #. f .# unTagged + {-# INLINE fmap #-} + +instance Bifunctor Tagged where + bimap _f g = Tagged #. g .# unTagged + first _f = coerce + second g = Tagged #. g .# unTagged + {-# INLINE bimap #-} + {-# INLINE first #-} + {-# INLINE second #-} + +instance Profunctor Tagged where + dimap _f g = Tagged #. g .# unTagged + lmap _f = coerce + rmap g = Tagged #. g .# unTagged + {-# INLINE dimap #-} + {-# INLINE lmap #-} + {-# INLINE rmap #-} + +instance Choice Tagged where + left' = Tagged #. Left .# unTagged + right' = Tagged #. Right .# unTagged + {-# INLINE left' #-} + {-# INLINE right' #-} + +instance Costrong Tagged where + unfirst (Tagged bd) = Tagged (fst bd) + unsecond (Tagged db) = Tagged (snd db) + {-# INLINE unfirst #-} + {-# INLINE unsecond #-} diff --git a/src/Optics/Internal/Traversal.hs b/src/Optics/Internal/Traversal.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Internal/Traversal.hs @@ -0,0 +1,39 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | Internal implementation details of traversals. +-- +-- This module is intended for internal use only, and may change without warning +-- in subsequent releases. +module Optics.Internal.Traversal where + +import Optics.Internal.Optic +import Optics.Internal.Profunctor +import Optics.Internal.Fold +import Optics.Internal.Setter + +-- | Internal implementation of 'Optics.Traversal.traversed'. +traversed__ + :: (Traversing p, Traversable f) + => Optic__ p i i (f a) (f b) a b +traversed__ = wander traverse +{-# INLINE [0] traversed__ #-} + +-- Because traversed__ inlines late, GHC needs rewrite rules for all cases in +-- order to generate optimal code for each of them. The one that rewrites +-- traversal into a traversal correspond to an early inline. + +{-# RULES + +"traversed__ -> wander traverse" + forall (o :: Star g i a b). traversed__ o = wander traverse o + :: Traversable f => Star g i (f a) (f b) + +"traversed__ -> folded__" + forall (o :: Forget r i a b). traversed__ o = folded__ o + :: Foldable f => Forget r i (f a) (f b) + +"traversed__ -> mapped__" + forall (o :: FunArrow i a b). traversed__ o = mapped__ o + :: Functor f => FunArrow i (f a) (f b) + +#-} diff --git a/src/Optics/Internal/Utils.hs b/src/Optics/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Internal/Utils.hs @@ -0,0 +1,67 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | This module is intended for internal use only, and may change without warning +-- in subsequent releases. +module Optics.Internal.Utils where + +import Data.Coerce +import qualified Data.Semigroup as SG + +data Context a b t = Context (b -> t) a + deriving Functor + +-- | Composition operator where the first argument must be an identity +-- function up to representational equivalence (e.g. a newtype wrapper +-- or unwrapper), and will be ignored at runtime. +(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c) +(#.) _f = coerce +infixl 8 .# +{-# INLINE (#.) #-} + +-- | Composition operator where the second argument must be an +-- identity function up to representational equivalence (e.g. a +-- newtype wrapper or unwrapper), and will be ignored at runtime. +(.#) :: Coercible a b => (b -> c) -> (a -> b) -> (a -> c) +(.#) f _g = coerce f +infixr 9 #. +{-# INLINE (.#) #-} + +---------------------------------------- + +-- | Helper for 'Optics.Fold.traverseOf_' and the like for better +-- efficiency than the foldr-based version. +-- +-- Note that the argument @a@ of the result should not be used. +newtype Traversed f a = Traversed (f a) + +runTraversed :: Functor f => Traversed f a -> f () +runTraversed (Traversed fa) = () <$ fa +{-# INLINE runTraversed #-} + +instance Applicative f => SG.Semigroup (Traversed f a) where + Traversed ma <> Traversed mb = Traversed (ma *> mb) + {-# INLINE (<>) #-} + +instance Applicative f => Monoid (Traversed f a) where + mempty = Traversed (pure (error "Traversed: value used")) + mappend = (SG.<>) + {-# INLINE mempty #-} + {-# INLINE mappend #-} + +---------------------------------------- + +-- | Helper for 'Optics.Fold.failing' family to visit the first fold only once. +data OrT f a = OrT !Bool (f a) + deriving Functor + +instance Applicative f => Applicative (OrT f) where + pure = OrT False . pure + OrT a f <*> OrT b x = OrT (a || b) (f <*> x) + {-# INLINE pure #-} + {-# INLINE (<*>) #-} + +-- | Wrap the applicative action in 'OrT' so that we know later that it was +-- executed. +wrapOrT :: f a -> OrT f a +wrapOrT = OrT True +{-# INLINE wrapOrT #-} diff --git a/src/Optics/Iso.hs b/src/Optics/Iso.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Iso.hs @@ -0,0 +1,274 @@ +-- | +-- Module: Optics.Iso +-- Description: Translates between types with the same structure. +-- +-- An 'Iso'morphism expresses the fact that two types have the +-- same structure, and hence can be converted from one to the other in +-- either direction. +-- +module Optics.Iso + ( + -- * Formation + Iso + , Iso' + + -- * Introduction + , iso + + -- * Elimination + -- | An 'Iso' is in particular a 'Optics.Getter.Getter', a + -- 'Optics.Review.Review' and a 'Optics.Setter.Setter', therefore you can + -- specialise types to obtain: + -- + -- @ + -- 'Optics.Getter.view' :: 'Iso' s t a b -> s -> a + -- 'Optics.Review.review' :: 'Iso' s t a b -> b -> t + -- @ + -- + -- @ + -- 'Optics.Setter.over' :: 'Iso' s t a b -> (a -> b) -> s -> t + -- 'Optics.Setter.set' :: 'Iso' s t a b -> b -> s -> t + -- @ + + -- * Computation + -- | + -- + -- @ + -- 'Optics.Getter.view' ('iso' f g) ≡ f + -- 'Optics.Review.review' ('iso' f g) ≡ g + -- @ + + -- * Well-formedness + -- | The functions translating back and forth must be mutually inverse: + -- + -- @ + -- 'Optics.Getter.view' i . 'Optics.Getter.review' i ≡ 'id' + -- 'Optics.Getter.review' i . 'Optics.Getter.view' i ≡ 'id' + -- @ + + -- * Additional introduction forms + , equality + , simple + , coerced + , coercedTo + , coerced1 + , curried + , uncurried + , flipped + , involuted + , Swapped(..) + + -- * Additional elimination forms + , withIso + , au + , under + + -- * Combinators + -- | The 'Optics.Re.re' combinator can be used to reverse an 'Iso': + -- + -- @ + -- 'Optics.Re.re' :: 'Iso' s t a b -> 'Iso' b a t s + -- @ + , mapping + + -- * Subtyping + , An_Iso + -- | <> + ) + where + +import Data.Tuple +import Data.Bifunctor +import Data.Coerce + +import Optics.Internal.Concrete +import Optics.Internal.Optic +import Optics.Internal.Profunctor + +-- | Type synonym for a type-modifying iso. +type Iso s t a b = Optic An_Iso NoIx s t a b + +-- | Type synonym for a type-preserving iso. +type Iso' s a = Optic' An_Iso NoIx s a + +-- | Build an iso from a pair of inverse functions. +-- +-- If you want to build an 'Iso' from the van Laarhoven representation, use +-- @isoVL@ from the @optics-vl@ package. +iso :: (s -> a) -> (b -> t) -> Iso s t a b +iso f g = Optic (dimap f g) +{-# INLINE iso #-} + +-- | Extract the two components of an isomorphism. +withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r +withIso o k = case getOptic o (Exchange id id) of + Exchange sa bt -> k sa bt +{-# INLINE withIso #-} + +-- | Based on @ala@ from Conor McBride's work on Epigram. +-- +-- This version is generalized to accept any 'Iso', not just a @newtype@. +-- +-- >>> au (coerced1 @Sum) foldMap [1,2,3,4] +-- 10 +-- +-- You may want to think of this combinator as having the following, simpler +-- type: +-- +-- @ +-- au :: 'Iso' s t a b -> ((b -> t) -> e -> s) -> e -> a +-- @ +au :: Functor f => Iso s t a b -> ((b -> t) -> f s) -> f a +au k = withIso k $ \sa bt f -> sa <$> f bt +{-# INLINE au #-} + +-- | The opposite of working 'Optics.Setter.over' a 'Optics.Setter.Setter' is +-- working 'under' an isomorphism. +-- +-- @ +-- 'under' ≡ 'Optics.Setter.over' '.' 'Optics.Re.re' +-- @ +under :: Iso s t a b -> (t -> s) -> b -> a +under k = withIso k $ \sa bt ts -> sa . ts . bt +{-# INLINE under #-} + +---------------------------------------- +-- Isomorphisms + +-- | This can be used to lift any 'Iso' into an arbitrary 'Functor'. +mapping + :: (Functor f, Functor g) + => Iso s t a b + -> Iso (f s) (g t) (f a) (g b) +mapping k = withIso k $ \sa bt -> iso (fmap sa) (fmap bt) +{-# INLINE mapping #-} + +-- | Capture type constraints as an isomorphism. +-- +-- /Note:/ This is the identity optic: +-- +-- >>> :t view equality +-- view equality :: a -> a +equality :: (s ~ a, t ~ b) => Iso s t a b +equality = Optic id +{-# INLINE equality #-} + +-- | Proof of reflexivity. +simple :: Iso' a a +simple = Optic id +{-# INLINE simple #-} + +-- | Data types that are representationally equal are isomorphic. +-- +-- >>> view coerced 'x' :: Identity Char +-- Identity 'x' +-- +coerced :: (Coercible s a, Coercible t b) => Iso s t a b +coerced = Optic (lcoerce' . rcoerce') +{-# INLINE coerced #-} + +-- | Type-preserving version of 'coerced' with type parameters rearranged for +-- TypeApplications. +-- +-- >>> newtype MkInt = MkInt Int deriving Show +-- +-- >>> over (coercedTo @Int) (*3) (MkInt 2) +-- MkInt 6 +-- +coercedTo :: forall a s. Coercible s a => Iso' s a +coercedTo = Optic (lcoerce' . rcoerce') +{-# INLINE coercedTo #-} + +-- | Special case of 'coerced' for trivial newtype wrappers. +-- +-- >>> over (coerced1 @Identity) (++ "bar") (Identity "foo") +-- Identity "foobar" +-- +coerced1 + :: forall f s a. (Coercible s (f s), Coercible a (f a)) + => Iso (f s) (f a) s a +coerced1 = Optic (lcoerce' . rcoerce') +{-# INLINE coerced1 #-} + +-- | The canonical isomorphism for currying and uncurrying a function. +-- +-- @ +-- 'curried' = 'iso' 'curry' 'uncurry' +-- @ +-- +-- >>> view curried fst 3 4 +-- 3 +-- +curried :: Iso ((a, b) -> c) ((d, e) -> f) (a -> b -> c) (d -> e -> f) +curried = iso curry uncurry +{-# INLINE curried #-} + +-- | The canonical isomorphism for uncurrying and currying a function. +-- +-- @ +-- 'uncurried' = 'iso' 'uncurry' 'curry' +-- @ +-- +-- @ +-- 'uncurried' = 'Optics.Re.re' 'curried' +-- @ +-- +-- >>> (view uncurried (+)) (1,2) +-- 3 +-- +uncurried :: Iso (a -> b -> c) (d -> e -> f) ((a, b) -> c) ((d, e) -> f) +uncurried = iso uncurry curry +{-# INLINE uncurried #-} + +-- | The isomorphism for flipping a function. +-- +-- >>> (view flipped (,)) 1 2 +-- (2,1) +-- +flipped :: Iso (a -> b -> c) (a' -> b' -> c') (b -> a -> c) (b' -> a' -> c') +flipped = iso flip flip +{-# INLINE flipped #-} + +-- | Given a function that is its own inverse, this gives you an 'Iso' using it +-- in both directions. +-- +-- @ +-- 'involuted' ≡ 'Control.Monad.join' 'iso' +-- @ +-- +-- >>> "live" ^. involuted reverse +-- "evil" +-- +-- >>> "live" & involuted reverse %~ ('d':) +-- "lived" +involuted :: (a -> a) -> Iso' a a +involuted a = iso a a +{-# INLINE involuted #-} + +-- | This class provides for symmetric bifunctors. +class Bifunctor p => Swapped p where + -- | + -- @ + -- 'swapped' '.' 'swapped' ≡ 'id' + -- 'first' f '.' 'swapped' = 'swapped' '.' 'second' f + -- 'second' g '.' 'swapped' = 'swapped' '.' 'first' g + -- 'bimap' f g '.' 'swapped' = 'swapped' '.' 'bimap' g f + -- @ + -- + -- >>> view swapped (1,2) + -- (2,1) + -- + swapped :: Iso (p a b) (p c d) (p b a) (p d c) + +instance Swapped (,) where + swapped = iso swap swap + {-# INLINE swapped #-} + +instance Swapped Either where + swapped = iso (either Right Left) (either Right Left) + {-# INLINE swapped #-} + +-- $setup +-- >>> import Data.Functor.Identity +-- >>> import Data.Monoid +-- >>> import Optics.Core diff --git a/src/Optics/IxAffineFold.hs b/src/Optics/IxAffineFold.hs new file mode 100644 --- /dev/null +++ b/src/Optics/IxAffineFold.hs @@ -0,0 +1,83 @@ +-- | +-- Module: Optics.IxAffineFold +-- Description: An indexed version of an 'Optics.AffineFold.AffineFold'. +-- +-- An 'IxAffineFold' is an indexed version of an 'Optics.AffineFold.AffineFold'. +-- See the "Indexed optics" section of the overview documentation in the +-- @Optics@ module of the main @optics@ package for more details on indexed +-- optics. +-- +module Optics.IxAffineFold + ( + -- * Formation + IxAffineFold + + -- * Introduction + , iafolding + + -- * Elimination + , ipreview + , ipreviews + + -- * Computation + -- | + -- + -- @ + -- 'ipreview' ('iafolding' f) ≡ f + -- @ + + -- * Semigroup structure + , iafailing + + -- * Subtyping + , An_AffineFold + ) where + +import Optics.AffineFold +import Optics.Internal.Bi +import Optics.Internal.Indexed +import Optics.Internal.Profunctor +import Optics.Internal.Optic + +-- | Type synonym for an indexed affine fold. +type IxAffineFold i s a = Optic' An_AffineFold (WithIx i) s a + +-- | Retrieve the value along with its index targeted by an 'IxAffineFold'. +ipreview + :: (Is k An_AffineFold, is `HasSingleIndex` i) + => Optic' k is s a + -> s -> Maybe (i, a) +ipreview o = ipreviews o (,) +{-# INLINE ipreview #-} + +-- | Retrieve a function of the value and its index targeted by an +-- 'IxAffineFold'. +ipreviews + :: (Is k An_AffineFold, is `HasSingleIndex` i) + => Optic' k is s a + -> (i -> a -> r) -> s -> Maybe r +ipreviews o = \f -> runIxForgetM + (getOptic (castOptic @An_AffineFold o) . IxForgetM $ \i -> Just . f i) + id +{-# INLINE ipreviews #-} + +-- | Create an 'IxAffineFold' from a partial function. +iafolding :: (s -> Maybe (i, a)) -> IxAffineFold i s a +iafolding g = Optic + $ ivisit (\point f s -> maybe (point s) (uncurry f) $ g s) + . rphantom +{-# INLINE iafolding #-} + +-- | Try the first 'IxAffineFold'. If it returns no entry, try the second one. +-- +-- /Note:/ There is no 'Optics.IxFold.isumming' equivalent, because @iasumming = iafailing@. +iafailing + :: (Is k An_AffineFold, Is l An_AffineFold, + is1 `HasSingleIndex` i, is2 `HasSingleIndex` i) + => Optic' k is1 s a + -> Optic' l is2 s a + -> IxAffineFold i s a +iafailing a b = conjoined (afailing a b) $ iafolding $ \s -> + maybe (ipreview b s) Just (ipreview a s) +infixl 3 `iafailing` -- Same as (<|>) +{-# INLINE iafailing #-} diff --git a/src/Optics/IxAffineTraversal.hs b/src/Optics/IxAffineTraversal.hs new file mode 100644 --- /dev/null +++ b/src/Optics/IxAffineTraversal.hs @@ -0,0 +1,88 @@ +-- | +-- Module: Optics.IxAffineTraversal +-- Description: An indexed version of an 'Optics.AffineTraversal.AffineTraversal'. +-- +-- An 'IxAffineTraversal' is an indexed version of an +-- 'Optics.AffineTraversal.AffineTraversal'. See the "Indexed optics" section +-- of the overview documentation in the @Optics@ module of the main @optics@ +-- package for more details on indexed optics. +-- +module Optics.IxAffineTraversal + ( + -- * Formation + IxAffineTraversal + , IxAffineTraversal' + + -- * Introduction + , iatraversal + + -- * Elimination + -- | An 'IxAffineTraversal' is in particular an + -- 'Optics.IxAffineFold.IxAffineFold' and an 'Optics.IxSetter.IxSetter', + -- therefore you can specialise types to obtain: + -- + -- @ + -- 'Optics.IxAffineFold.ipreview' :: 'IxAffineTraversal' i s t a b -> s -> Maybe (i, a) + -- @ + -- + -- @ + -- 'Optics.IxSetter.iover' :: 'IxAffineTraversal' i s t a b -> (i -> a -> b) -> s -> t + -- 'Optics.IxSetter.iset' :: 'IxAffineTraversal' i s t a b -> (i -> b) -> s -> t + -- @ + + -- * Subtyping + , An_AffineTraversal + + -- * van Laarhoven encoding + , IxAffineTraversalVL + , IxAffineTraversalVL' + , iatraversalVL + , toIxAtraversalVL + ) where + +import Optics.Internal.Indexed +import Optics.Internal.Optic +import Optics.Internal.Profunctor + +-- | Type synonym for a type-modifying indexed affine traversal. +type IxAffineTraversal i s t a b = Optic An_AffineTraversal (WithIx i) s t a b + +-- | Type synonym for a type-preserving indexed affine traversal. +type IxAffineTraversal' i s a = Optic' An_AffineTraversal (WithIx i) s a + +-- | Type synonym for a type-modifying van Laarhoven indexed affine traversal. +-- +-- Note: this isn't exactly van Laarhoven representation as there is no +-- @Pointed@ class (which would be a superclass of 'Applicative' that contains +-- 'pure' but not '<*>'). You can interpret the first argument as a dictionary +-- of @Pointed@ that supplies the @point@ function (i.e. the implementation of +-- 'pure'). +-- +type IxAffineTraversalVL i s t a b = + forall f. Functor f => (forall r. r -> f r) -> (i -> a -> f b) -> s -> f t + +-- | Type synonym for a type-preserving van Laarhoven indexed affine traversal. +type IxAffineTraversalVL' i s a = IxAffineTraversalVL i s s a a + +-- | Build an indexed affine traversal from a matcher and an updater. +-- +-- If you want to build an 'IxAffineTraversal' from the van Laarhoven +-- representation, use 'iatraversalVL'. +iatraversal :: (s -> Either t (i, a)) -> (s -> b -> t) -> IxAffineTraversal i s t a b +iatraversal match update = iatraversalVL $ \point f s -> + either point (\a -> update s <$> uncurry f a) (match s) +{-# INLINE iatraversal #-} + +-- | Build an indexed affine traversal from the van Laarhoven representation. +iatraversalVL :: IxAffineTraversalVL i s t a b -> IxAffineTraversal i s t a b +iatraversalVL f = Optic (ivisit f) +{-# INLINE iatraversalVL #-} + +-- | Convert an indexed affine traversal to its van Laarhoven representation. +toIxAtraversalVL + :: (Is k An_AffineTraversal, is `HasSingleIndex` i) + => Optic k is s t a b + -> IxAffineTraversalVL i s t a b +toIxAtraversalVL o point = \f -> + runIxStarA (getOptic (castOptic @An_AffineTraversal o) (IxStarA point f)) id +{-# INLINE toIxAtraversalVL #-} diff --git a/src/Optics/IxFold.hs b/src/Optics/IxFold.hs new file mode 100644 --- /dev/null +++ b/src/Optics/IxFold.hs @@ -0,0 +1,350 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +-- | +-- Module: Optics.IxFold +-- Description: An indexed version of an 'Optics.Fold.Fold'. +-- +-- An 'IxFold' is an indexed version of an 'Optics.Fold.Fold'. See the "Indexed +-- optics" section of the overview documentation in the @Optics@ module of the +-- main @optics@ package for more details on indexed optics. +-- +module Optics.IxFold + ( + -- * Formation + IxFold + + -- * Introduction + , ifoldVL + + -- * Elimination + , ifoldMapOf + , ifoldrOf + , ifoldlOf' + , itoListOf + , itraverseOf_ + , iforOf_ + + -- * Additional introduction forms + , ifolded + , ifolding + , ifoldring + + -- * Additional elimination forms + -- | See also 'Data.Map.Optics.toMapOf', which constructs a 'Data.Map.Map' from an 'IxFold'. + , iheadOf + , ilastOf + , ianyOf + , iallOf + , inoneOf + , ifindOf + , ifindMOf + + -- * Combinators + , ipre + , ifiltered + , ibackwards_ + + -- * Semigroup structure + , isumming + , ifailing + + -- * Subtyping + , A_Fold + + -- * Re-exports + , FoldableWithIndex(..) + ) where + +import Control.Applicative.Backwards +import Data.Monoid + +import Optics.Internal.Bi +import Optics.Internal.Indexed +import Optics.Internal.Fold +import Optics.Internal.IxFold +import Optics.Internal.Optic +import Optics.Internal.Profunctor +import Optics.Internal.Utils +import Optics.IxAffineFold +import Optics.Fold + +-- | Type synonym for an indexed fold. +type IxFold i s a = Optic' A_Fold (WithIx i) s a + +-- | Obtain an indexed fold by lifting 'itraverse_' like function. +-- +-- @ +-- 'ifoldVL' '.' 'itraverseOf_' ≡ 'id' +-- 'itraverseOf_' '.' 'ifoldVL' ≡ 'id' +-- @ +ifoldVL + :: (forall f. Applicative f => (i -> a -> f u) -> s -> f v) + -> IxFold i s a +ifoldVL f = Optic (ifoldVL__ f) +{-# INLINE ifoldVL #-} + +-- | Fold with index via embedding into a monoid. +ifoldMapOf + :: (Is k A_Fold, Monoid m, is `HasSingleIndex` i) + => Optic' k is s a + -> (i -> a -> m) -> s -> m +ifoldMapOf o = \f -> runIxForget (getOptic (castOptic @A_Fold o) (IxForget f)) id +{-# INLINE ifoldMapOf #-} + +-- | Fold with index right-associatively. +ifoldrOf + :: (Is k A_Fold, is `HasSingleIndex` i) + => Optic' k is s a + -> (i -> a -> r -> r) -> r -> s -> r +ifoldrOf o = \iarr r0 s -> (\e -> appEndo e r0) $ ifoldMapOf o (\i -> Endo #. iarr i) s +{-# INLINE ifoldrOf #-} + +-- | Fold with index left-associatively, and strictly. +ifoldlOf' + :: (Is k A_Fold, is `HasSingleIndex` i) + => Optic' k is s a + -> (i -> r -> a -> r) -> r -> s -> r +ifoldlOf' o = \irar r0 s -> ifoldrOf o (\i a rr r -> rr $! irar i r a) id s r0 +{-# INLINE ifoldlOf' #-} + +-- | Fold with index to a list. +-- +-- >>> itoListOf (folded % ifolded) ["abc", "def"] +-- [(0,'a'),(1,'b'),(2,'c'),(0,'d'),(1,'e'),(2,'f')] +-- +-- /Note:/ currently indexed optics can be used as non-indexed. +-- +-- >>> toListOf (folded % ifolded) ["abc", "def"] +-- "abcdef" +-- +itoListOf + :: (Is k A_Fold, is `HasSingleIndex` i) + => Optic' k is s a + -> s -> [(i, a)] +itoListOf o = ifoldrOf o (\i -> (:) . (i, )) [] +{-# INLINE itoListOf #-} + +---------------------------------------- + +-- | Traverse over all of the targets of an 'IxFold', computing an +-- 'Applicative'-based answer, but unlike 'Optics.IxTraversal.itraverseOf' do +-- not construct a new structure. +-- +-- >>> itraverseOf_ each (curry print) ("hello","world") +-- (0,"hello") +-- (1,"world") +-- +itraverseOf_ + :: (Is k A_Fold, Applicative f, is `HasSingleIndex` i) + => Optic' k is s a + -> (i -> a -> f r) -> s -> f () +#if __GLASGOW_HASKELL__ == 802 +-- GHC 8.2.2 needs this to optimize away profunctors when f is not supplied. +itraverseOf_ o = \f -> +#else +itraverseOf_ o f = +#endif + runTraversed . ifoldMapOf o (\i -> Traversed #. f i) +{-# INLINE itraverseOf_ #-} + +-- | A version of 'itraverseOf_' with the arguments flipped. +iforOf_ + :: (Is k A_Fold, Applicative f, is `HasSingleIndex` i) + => Optic' k is s a + -> s -> (i -> a -> f r) -> f () +iforOf_ = flip . itraverseOf_ +{-# INLINE iforOf_ #-} + +---------------------------------------- + +-- | Indexed fold via 'FoldableWithIndex' class. +ifolded :: FoldableWithIndex i f => IxFold i (f a) a +ifolded = Optic ifolded__ +{-# INLINE ifolded #-} + +-- | Obtain an 'IxFold' by lifting an operation that returns a +-- 'FoldableWithIndex' result. +-- +-- This can be useful to lift operations from @Data.List@ and elsewhere into an +-- 'IxFold'. +-- +-- >>> itoListOf (ifolding words) "how are you" +-- [(0,"how"),(1,"are"),(2,"you")] +ifolding :: FoldableWithIndex i f => (s -> f a) -> IxFold i s a +ifolding f = Optic $ contrafirst f . ifolded__ +{-# INLINE ifolding #-} + +-- | Obtain an 'IxFold' by lifting 'ifoldr' like function. +-- +-- >>> itoListOf (ifoldring ifoldr) "hello" +-- [(0,'h'),(1,'e'),(2,'l'),(3,'l'),(4,'o')] +ifoldring + :: (forall f. Applicative f => (i -> a -> f u -> f u) -> f v -> s -> f w) + -> IxFold i s a +ifoldring fr = Optic (ifoldring__ fr) +{-# INLINE ifoldring #-} + +-- | Convert an indexed fold to an 'IxAffineFold' that visits the first element +-- of the original fold. +ipre + :: (Is k A_Fold, is `HasSingleIndex` i) + => Optic' k is s a + -> IxAffineFold i s a +ipre = iafolding . iheadOf +{-# INLINE ipre #-} + +-- | Filter results of an 'IxFold' that don't satisfy a predicate. +-- +-- >>> toListOf (ifolded %& ifiltered (>)) [3,2,1,0] +-- [1,0] +-- +ifiltered + :: (Is k A_Fold, is `HasSingleIndex` i) + => (i -> a -> Bool) + -> Optic' k is s a + -> IxFold i s a +ifiltered p o = ifoldVL $ \f -> + itraverseOf_ o (\i a -> if p i a then f i a else pure ()) +{-# INLINE ifiltered #-} +-- Note: technically this should be defined per optic kind: +-- +-- ifiltered :: _ -> IxFold i s a -> IxFold i s a +-- ifiltered :: _ -> IxGetter i s a -> IxAffineFold i s a +-- ifiltered :: _ -> IxAffineFold i s a -> IxAffineFold i s a +-- +-- and similarly for (non-existent) unsafeIFiltered. + +-- | This allows you to traverse the elements of an 'IxFold' in the opposite +-- order. +ibackwards_ + :: (Is k A_Fold, is `HasSingleIndex` i) + => Optic' k is s a + -> IxFold i s a +ibackwards_ o = conjoined (backwards_ o) $ ifoldVL $ \f -> + forwards #. itraverseOf_ o (\i -> Backwards #. f i) +{-# INLINE ibackwards_ #-} + +-- | Return entries of the first 'IxFold', then the second one. +isumming + :: (Is k A_Fold, Is l A_Fold, + is1 `HasSingleIndex` i, is2 `HasSingleIndex` i) + => Optic' k is1 s a + -> Optic' l is2 s a + -> IxFold i s a +isumming a b = conjoined (summing a b) $ ifoldVL $ \f s -> + itraverseOf_ a f s *> itraverseOf_ b f s +infixr 6 `isumming` -- Same as (<>) +{-# INLINE isumming #-} + +-- | Try the first 'IxFold'. If it returns no entries, try the second one. +ifailing + :: (Is k A_Fold, Is l A_Fold, is1 `HasSingleIndex` i, is2 `HasSingleIndex` i) + => Optic' k is1 s a + -> Optic' l is2 s a + -> IxFold i s a +ifailing a b = conjoined (failing a b) $ ifoldVL $ \f s -> + let OrT visited fu = itraverseOf_ a (\i -> wrapOrT . f i) s + in if visited + then fu + else itraverseOf_ b f s +infixl 3 `ifailing` -- Same as (<|>) +{-# INLINE ifailing #-} + +---------------------------------------- +-- Special folds + +-- | Retrieve the first entry of an 'IxFold' along with its index. +-- +-- >>> iheadOf ifolded [1..10] +-- Just (0,1) +iheadOf + :: (Is k A_Fold, is `HasSingleIndex` i) + => Optic' k is s a -> s -> Maybe (i, a) +iheadOf o = getLeftmost . ifoldMapOf o (\i -> LLeaf . (i, )) +{-# INLINE iheadOf #-} + +-- | Retrieve the last entry of an 'IxFold' along with its index. +-- +-- >>> ilastOf ifolded [1..10] +-- Just (9,10) +ilastOf + :: (Is k A_Fold, is `HasSingleIndex` i) + => Optic' k is s a -> s -> Maybe (i, a) +ilastOf o = getRightmost . ifoldMapOf o (\i -> RLeaf . (i, )) +{-# INLINE ilastOf #-} + +-- | Return whether or not any element viewed through an 'IxFold' satisfies a +-- predicate, with access to the @i@. +-- +-- When you don't need access to the index then 'anyOf' is more flexible in what +-- it accepts. +-- +-- @ +-- 'anyOf' o ≡ 'ianyOf' o '.' 'const' +-- @ +ianyOf + :: (Is k A_Fold, is `HasSingleIndex` i) + => Optic' k is s a -> (i -> a -> Bool) -> s -> Bool +ianyOf o = \f -> getAny #. ifoldMapOf o (\i -> Any #. f i) +{-# INLINE ianyOf #-} + +-- | Return whether or not all elements viewed through an 'IxFold' satisfy a +-- predicate, with access to the @i@. +-- +-- When you don't need access to the index then 'allOf' is more flexible in what +-- it accepts. +-- +-- @ +-- 'allOf' o ≡ 'iallOf' o '.' 'const' +-- @ +iallOf + :: (Is k A_Fold, is `HasSingleIndex` i) + => Optic' k is s a -> (i -> a -> Bool) -> s -> Bool +iallOf o = \f -> getAll #. ifoldMapOf o (\i -> All #. f i) +{-# INLINE iallOf #-} + +-- | Return whether or not none of the elements viewed through an 'IxFold' +-- satisfy a predicate, with access to the @i@. +-- +-- When you don't need access to the index then 'noneOf' is more flexible in +-- what it accepts. +-- +-- @ +-- 'noneOf' o ≡ 'inoneOf' o '.' 'const' +-- @ +inoneOf + :: (Is k A_Fold, is `HasSingleIndex` i) + => Optic' k is s a -> (i -> a -> Bool) -> s -> Bool +inoneOf o = \f -> not . ianyOf o f +{-# INLINE inoneOf #-} + +-- | The 'ifindOf' function takes an 'IxFold', a predicate that is also supplied +-- the index, a structure and returns the left-most element of the structure +-- along with its index matching the predicate, or 'Nothing' if there is no such +-- element. +-- +-- When you don't need access to the index then 'findOf' is more flexible in +-- what it accepts. +ifindOf + :: (Is k A_Fold, is `HasSingleIndex` i) + => Optic' k is s a -> (i -> a -> Bool) -> s -> Maybe (i, a) +ifindOf o = \p -> iheadOf (ifiltered p o) +{-# INLINE ifindOf #-} + +-- | The 'ifindMOf' function takes an 'IxFold', a monadic predicate that is also +-- supplied the index, a structure and returns in the monad the left-most +-- element of the structure matching the predicate, or 'Nothing' if there is no +-- such element. +-- +-- When you don't need access to the index then 'findMOf' is more flexible in +-- what it accepts. +ifindMOf + :: (Is k A_Fold, Monad m, is `HasSingleIndex` i) + => Optic' k is s a -> (i -> a -> m Bool) -> s -> m (Maybe (i, a)) +ifindMOf o = \f -> ifoldrOf o + (\i a y -> f i a >>= \r -> if r then pure (Just (i, a)) else y) + (pure Nothing) +{-# INLINE ifindMOf #-} + +-- $setup +-- >>> import Optics.Core diff --git a/src/Optics/IxGetter.hs b/src/Optics/IxGetter.hs new file mode 100644 --- /dev/null +++ b/src/Optics/IxGetter.hs @@ -0,0 +1,61 @@ +-- | +-- Module: Optics.IxGetter +-- Description: An indexed version of an 'Optics.Getter.Getter'. +-- +-- An 'IxGetter' is an indexed version of an 'Optics.Getter.Getter'. See the +-- "Indexed optics" section of the overview documentation in the @Optics@ module +-- of the main @optics@ package for more details on indexed optics. +-- +module Optics.IxGetter + ( + -- * Formation + IxGetter + + -- * Introduction + , ito + , selfIndex + + -- * Elimination + , iview + , iviews + + -- * Subtyping + , A_Getter + ) where + +import Optics.Internal.Bi +import Optics.Internal.Indexed +import Optics.Internal.Optic +import Optics.Internal.Profunctor + +-- | Type synonym for an indexed getter. +type IxGetter i s a = Optic' A_Getter (WithIx i) s a + +-- | Build an indexed getter from a function. +-- +-- >>> iview (ito id) ('i', 'x') +-- ('i','x') +ito :: (s -> (i, a)) -> IxGetter i s a +ito f = Optic (lmap f . ilinear uncurry . rphantom) +{-# INLINE ito #-} + +-- | Use a value itself as its own index. This is essentially an indexed version +-- of 'Optics.Iso.equality'. +selfIndex :: IxGetter a a a +selfIndex = ito (\a -> (a, a)) +{-# INLINE selfIndex #-} + +-- | View the value pointed to by an indexed getter. +iview + :: (Is k A_Getter, is `HasSingleIndex` i) + => Optic' k is s a -> s -> (i, a) +iview o = iviews o (,) +{-# INLINE iview #-} + +-- | View the function of the value pointed to by an indexed getter. +iviews + :: (Is k A_Getter, is `HasSingleIndex` i) + => Optic' k is s a -> (i -> a -> r) -> s -> r +iviews o = \f -> + runIxForget (getOptic (castOptic @A_Getter o) (IxForget f)) id +{-# INLINE iviews #-} diff --git a/src/Optics/IxLens.hs b/src/Optics/IxLens.hs new file mode 100644 --- /dev/null +++ b/src/Optics/IxLens.hs @@ -0,0 +1,111 @@ +-- | +-- Module: Optics.IxLens +-- Description: An indexed version of an 'Optics.Lens.Lens'. +-- +-- An 'IxLens' is an indexed version of an 'Optics.Lens.Lens'. See the "Indexed +-- optics" section of the overview documentation in the @Optics@ module of the +-- main @optics@ package for more details on indexed optics. +-- +module Optics.IxLens + ( + -- * Formation + IxLens + , IxLens' + + -- * Introduction + , ilens + + -- * Elimination + -- | An 'IxLens' is in particular an 'Optics.IxGetter.IxGetter' and an + -- 'Optics.IxSetter.IxSetter', therefore you can specialise types to obtain: + -- + -- @ + -- 'Optics.IxGetter.iview' :: 'IxLens' i s t a b -> s -> (i, a) + -- @ + -- + -- @ + -- 'Optics.IxSetter.iover' :: 'IxLens' i s t a b -> (i -> a -> b) -> s -> t + -- 'Optics.IxSetter.iset' :: 'IxLens' i s t a b -> (i -> b) -> s -> t + -- @ + + -- * Additional introduction forms + , devoid + + -- * Subtyping + , A_Lens + + -- * van Laarhoven encoding + , IxLensVL + , IxLensVL' + , ilensVL + , toIxLensVL + , withIxLensVL + ) where + +import Data.Void + +import Optics.Internal.Indexed +import Optics.Internal.Optic +import Optics.Internal.Profunctor + +-- | Type synonym for a type-modifying indexed lens. +type IxLens i s t a b = Optic A_Lens (WithIx i) s t a b + +-- | Type synonym for a type-preserving indexed lens. +type IxLens' i s a = Optic' A_Lens (WithIx i) s a + +-- | Type synonym for a type-modifying van Laarhoven indexed lens. +type IxLensVL i s t a b = + forall f. Functor f => (i -> a -> f b) -> s -> f t + +-- | Type synonym for a type-preserving van Laarhoven indexed lens. +type IxLensVL' i s a = IxLensVL i s s a a + +-- | Build an indexed lens from a getter and a setter. +-- +-- If you want to build an 'IxLens' from the van Laarhoven representation, use +-- 'ilensVL'. +ilens :: (s -> (i, a)) -> (s -> b -> t) -> IxLens i s t a b +ilens get set = ilensVL $ \f s -> set s <$> uncurry f (get s) +{-# INLINE ilens #-} + +-- | Build an indexed lens from the van Laarhoven representation. +ilensVL :: IxLensVL i s t a b -> IxLens i s t a b +ilensVL f = Optic (ilinear f) +{-# INLINE ilensVL #-} + +-- | Convert an indexed lens to its van Laarhoven representation. +toIxLensVL + :: (Is k A_Lens, is `HasSingleIndex` i) + => Optic k is s t a b + -> IxLensVL i s t a b +toIxLensVL o = \f -> + runIxStar (getOptic (castOptic @A_Lens o) (IxStar f)) id +{-# INLINE toIxLensVL #-} + +-- | Work with an indexed lens in the van Laarhoven representation. +withIxLensVL + :: (Is k A_Lens, is `HasSingleIndex` i) + => Optic k is s t a b + -> (IxLensVL i s t a b -> r) + -> r +withIxLensVL o k = k (toIxLensVL o) +{-# INLINE withIxLensVL #-} + +---------------------------------------- +-- Lenses + +-- | There is an indexed field for every type in the 'Void'. +-- +-- >>> set (mapped % devoid) 1 [] +-- [] +-- +-- >>> over (_Just % devoid) abs Nothing +-- Nothing +-- +devoid :: IxLens' i Void a +devoid = ilens absurd const +{-# INLINE devoid #-} + +-- $setup +-- >>> import Optics.Core diff --git a/src/Optics/IxSetter.hs b/src/Optics/IxSetter.hs new file mode 100644 --- /dev/null +++ b/src/Optics/IxSetter.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE DataKinds #-} +-- | +-- Module: Optics.IxSetter +-- Description: An indexed version of an 'Optics.Setter.Setter'. +-- +-- An 'IxSetter' is an indexed version of an 'Optics.Setter.Setter'. See the +-- "Indexed optics" section of the overview documentation in the @Optics@ module +-- of the main @optics@ package for more details on indexed optics. +-- +module Optics.IxSetter + ( + -- * Formation + IxSetter + , IxSetter' + + -- * Introduction + , isets + + -- * Elimination + , iover + + -- * Computation + -- | + -- + -- @ + -- 'iover' ('isets' f) ≡ f + -- @ + + -- * Well-formedness + -- | + -- + -- * __PutPut__: Setting twice is the same as setting once: + -- + -- @ + -- 'Optics.Setter.iset' l v' ('Optics.Setter.iset' l v s) ≡ 'Optics.Setter.iset' l v' s + -- @ + -- + -- * __Functoriality__: 'IxSetter's must preserve identities and composition: + -- + -- @ + -- 'iover' s ('const' 'id') ≡ 'id' + -- 'iover' s f '.' 'iover' s g ≡ 'iover' s (\i -> f i '.' g i) + -- @ + + -- * Additional introduction forms + , imapped + + -- * Additional elimination forms + , iset + , iset' + , iover' + + -- * Subtyping + , A_Setter + + -- * Re-exports + , FunctorWithIndex(..) + ) where + +import Optics.Internal.Indexed +import Optics.Internal.IxSetter +import Optics.Internal.Optic +import Optics.Internal.Profunctor + +-- | Type synonym for a type-modifying indexed setter. +type IxSetter i s t a b = Optic A_Setter (WithIx i) s t a b + +-- | Type synonym for a type-preserving indexed setter. +type IxSetter' i s a = Optic' A_Setter (WithIx i) s a + +-- | Apply an indexed setter as a modifier. +iover + :: (Is k A_Setter, is `HasSingleIndex` i) + => Optic k is s t a b + -> (i -> a -> b) -> s -> t +iover o = \f -> runIxFunArrow (getOptic (castOptic @A_Setter o) (IxFunArrow f)) id +{-# INLINE iover #-} + +-- | Apply an indexed setter as a modifier, strictly. +iover' + :: (Is k A_Setter, is `HasSingleIndex` i) + => Optic k is s t a b + -> (i -> a -> b) -> s -> t +iover' o = \f -> + let star = getOptic (castOptic @A_Setter o) $ IxStar (\i -> wrapIdentity' . f i) + in unwrapIdentity' . runIxStar star id + +{-# INLINE iover' #-} + +-- | Apply an indexed setter. +-- +-- @ +-- 'iset' o f ≡ 'iover' o (\i _ -> f i) +-- @ +-- +iset + :: (Is k A_Setter, is `HasSingleIndex` i) + => Optic k is s t a b + -> (i -> b) -> s -> t +iset o = \f -> iover o (\i _ -> f i) +{-# INLINE iset #-} + +-- | Apply an indexed setter, strictly. +iset' + :: (Is k A_Setter, is `HasSingleIndex` i) + => Optic k is s t a b + -> (i -> b) -> s -> t +iset' o = \f -> iover' o (\i _ -> f i) +{-# INLINE iset' #-} + +-- | Build an indexed setter from a function to modify the element(s). +isets + :: ((i -> a -> b) -> s -> t) + -> IxSetter i s t a b +isets f = Optic (iroam f) +{-# INLINE isets #-} + +-- | Indexed setter via the 'FunctorWithIndex' class. +-- +-- @ +-- 'iover' 'imapped' ≡ 'imap' +-- @ +imapped :: FunctorWithIndex i f => IxSetter i (f a) (f b) a b +imapped = Optic imapped__ +{-# INLINE imapped #-} diff --git a/src/Optics/IxTraversal.hs b/src/Optics/IxTraversal.hs new file mode 100644 --- /dev/null +++ b/src/Optics/IxTraversal.hs @@ -0,0 +1,326 @@ +{-# LANGUAGE DataKinds #-} +-- | +-- Module: Optics.IxTraversal +-- Description: An indexed version of an 'Optics.Traversal.Traversal'. +-- +-- An 'IxTraversal' is an indexed version of an 'Optics.Traversal.Traversal'. +-- See the "Indexed optics" section of the overview documentation in the +-- @Optics@ module of the main @optics@ package for more details on indexed +-- optics. +-- +module Optics.IxTraversal + ( + -- * Formation + IxTraversal + , IxTraversal' + + -- * Introduction + , itraversalVL + + -- * Elimination + , itraverseOf + + -- * Computation + -- | + -- + -- @ + -- 'itraverseOf' ('itraversalVL' f) ≡ f + -- @ + + -- * Well-formedness + -- | + -- + -- @ + -- 'itraverseOf' o ('const' 'pure') ≡ 'pure' + -- 'fmap' ('itraverseOf' o f) . 'itraverseOf' o g ≡ 'Data.Functor.Compose.getCompose' . 'itraverseOf' o (\\ i -> 'Data.Functor.Compose.Compose' . 'fmap' (f i) . g i) + -- @ + -- + + -- * Additional introduction forms + -- | See also 'Optics.Each.Core.each', which is an 'IxTraversal' over each element of a (potentially monomorphic) container. + , itraversed + , ignored + , elementsOf + , elements + , elementOf + , element + + -- * Additional elimination forms + , iforOf + , imapAccumLOf + , imapAccumROf + , iscanl1Of + , iscanr1Of + , ifailover + , ifailover' + + -- * Combinators + , indices + , ibackwards + , ipartsOf + + -- * Subtyping + , A_Traversal + + -- * van Laarhoven encoding + -- | The van Laarhoven representation of an 'IxTraversal' directly expresses + -- how it lifts an effectful operation @I -> A -> F B@ on elements and their + -- indices to act on structures @S -> F T@. Thus 'itraverseOf' converts an + -- 'IxTraversal' to a 'IxTraversalVL'. + , IxTraversalVL + , IxTraversalVL' + + -- * Re-exports + , TraversableWithIndex(..) + ) where + +import Control.Applicative.Backwards +import Control.Monad.Trans.State +import Data.Functor.Identity + +import Optics.Internal.Indexed +import Optics.Internal.IxTraversal +import Optics.Internal.Profunctor +import Optics.Internal.Optic +import Optics.Internal.Utils +import Optics.IxLens +import Optics.IxFold +import Optics.ReadOnly +import Optics.Traversal + +-- | Type synonym for a type-modifying indexed traversal. +type IxTraversal i s t a b = Optic A_Traversal (WithIx i) s t a b + +-- | Type synonym for a type-preserving indexed traversal. +type IxTraversal' i s a = Optic' A_Traversal (WithIx i) s a + +-- | Type synonym for a type-modifying van Laarhoven indexed traversal. +type IxTraversalVL i s t a b = + forall f. Applicative f => (i -> a -> f b) -> s -> f t + +-- | Type synonym for a type-preserving van Laarhoven indexed traversal. +type IxTraversalVL' i s a = IxTraversalVL i s s a a + +-- | Build an indexed traversal from the van Laarhoven representation. +-- +-- @ +-- 'itraversalVL' '.' 'itraverseOf' ≡ 'id' +-- 'itraverseOf' '.' 'itraversalVL' ≡ 'id' +-- @ +itraversalVL :: IxTraversalVL i s t a b -> IxTraversal i s t a b +itraversalVL t = Optic (iwander t) +{-# INLINE itraversalVL #-} + +---------------------------------------- + +-- | Map each element of a structure targeted by a 'IxTraversal' (supplying the +-- index), evaluate these actions from left to right, and collect the results. +-- +-- This yields the van Laarhoven representation of an indexed traversal. +itraverseOf + :: (Is k A_Traversal, Applicative f, is `HasSingleIndex` i) + => Optic k is s t a b + -> (i -> a -> f b) -> s -> f t +itraverseOf o = \f -> + runIxStar (getOptic (castOptic @A_Traversal o) (IxStar f)) id +{-# INLINE itraverseOf #-} + +-- | A version of 'itraverseOf' with the arguments flipped. +iforOf + :: (Is k A_Traversal, Applicative f, is `HasSingleIndex` i) + => Optic k is s t a b + -> s -> (i -> a -> f b) -> f t +iforOf = flip . itraverseOf +{-# INLINE iforOf #-} + +-- | Generalizes 'Data.Traversable.mapAccumL' to an arbitrary 'IxTraversal'. +-- +-- 'imapAccumLOf' accumulates state from left to right. +-- +-- @ +-- 'Optics.Traversal.mapAccumLOf' o ≡ 'imapAccumLOf' o '.' 'const' +-- @ +imapAccumLOf + :: (Is k A_Traversal, is `HasSingleIndex` i) + => Optic k is s t a b + -> (i -> acc -> a -> (b, acc)) -> acc -> s -> (t, acc) +imapAccumLOf o = \f acc0 s -> + let g i a = state $ \acc -> f i acc a + in runState (itraverseOf o g s) acc0 +{-# INLINE imapAccumLOf #-} + +-- | Generalizes 'Data.Traversable.mapAccumR' to an arbitrary 'IxTraversal'. +-- +-- 'imapAccumROf' accumulates state from right to left. +-- +-- @ +-- 'Optics.Traversal.mapAccumROf' o ≡ 'imapAccumROf' o '.' 'const' +-- @ +imapAccumROf + :: (Is k A_Traversal, is `HasSingleIndex` i) + => Optic k is s t a b + -> (i -> acc -> a -> (b, acc)) -> acc -> s -> (t, acc) +imapAccumROf = imapAccumLOf . ibackwards +{-# INLINE imapAccumROf #-} + +-- | This permits the use of 'scanl1' over an arbitrary 'IxTraversal'. +iscanl1Of + :: (Is k A_Traversal, is `HasSingleIndex` i) + => Optic k is s t a a + -> (i -> a -> a -> a) -> s -> t +iscanl1Of o = \f -> + let step i ms a = case ms of + Nothing -> (a, Just a) + Just s -> let r = f i s a in (r, Just r) + in fst . imapAccumLOf o step Nothing +{-# INLINE iscanl1Of #-} + +-- | This permits the use of 'scanr1' over an arbitrary 'IxTraversal'. +iscanr1Of + :: (Is k A_Traversal, is `HasSingleIndex` i) + => Optic k is s t a a + -> (i -> a -> a -> a) -> s -> t +iscanr1Of o f = fst . imapAccumROf o step Nothing + where + step i ms a = case ms of + Nothing -> (a, Just a) + Just s -> let r = f i a s in (r, Just r) +{-# INLINE iscanr1Of #-} + +-- | Try to map a function which uses the index over this 'IxTraversal', +-- returning 'Nothing' if the 'IxTraversal' has no targets. +ifailover + :: (Is k A_Traversal, is `HasSingleIndex` i) + => Optic k is s t a b + -> (i -> a -> b) -> s -> Maybe t +ifailover o = \f s -> + let OrT visited t = itraverseOf o (\i -> wrapOrT . Identity #. f i) s + in if visited + then Just (runIdentity t) + else Nothing +{-# INLINE ifailover #-} + +-- | Version of 'ifailover' strict in the application of the function. +ifailover' + :: (Is k A_Traversal, is `HasSingleIndex` i) + => Optic k is s t a b + -> (i -> a -> b) -> s -> Maybe t +ifailover' o = \f s -> + let OrT visited t = itraverseOf o (\i -> wrapOrT . wrapIdentity' . f i) s + in if visited + then Just (unwrapIdentity' t) + else Nothing +{-# INLINE ifailover' #-} + +---------------------------------------- +-- Traversals + +-- | Indexed traversal via the 'TraversableWithIndex' class. +-- +-- @ +-- 'itraverseOf' 'itraversed' ≡ 'itraverse' +-- @ +-- +-- >>> iover (itraversed <%> itraversed) (,) ["ab", "cd"] +-- [[((0,0),'a'),((0,1),'b')],[((1,0),'c'),((1,1),'d')]] +-- +itraversed + :: TraversableWithIndex i f + => IxTraversal i (f a) (f b) a b +itraversed = Optic itraversed__ +{-# INLINE itraversed #-} + +-- | This is the trivial empty 'IxTraversal'. +-- +-- >>> 6 & ignored %~ absurd +-- 6 +ignored :: IxTraversal i s s a b +ignored = itraversalVL $ \_ -> pure + +---------------------------------------- +-- Traversal combinators + +-- | Filter results of an 'IxTraversal' that don't satisfy a predicate on the +-- indices. +-- +-- >>> toListOf (itraversed %& indices even) "foobar" +-- "foa" +-- +indices + :: (Is k A_Traversal, is `HasSingleIndex` i) + => (i -> Bool) + -> Optic k is s t a a + -> IxTraversal i s t a a +indices p o = itraversalVL $ \f -> + itraverseOf o $ \i a -> if p i then f i a else pure a +{-# INLINE indices #-} + +-- | This allows you to 'traverse' the elements of an indexed traversal in the +-- opposite order. +ibackwards + :: (Is k A_Traversal, is `HasSingleIndex` i) + => Optic k is s t a b + -> IxTraversal i s t a b +ibackwards o = conjoined (backwards o) $ itraversalVL $ \f -> + forwards #. itraverseOf o (\i -> Backwards #. f i) +{-# INLINE ibackwards #-} + +-- | Traverse selected elements of a 'Traversal' where their ordinal positions +-- match a predicate. +elementsOf + :: Is k A_Traversal + => Optic k is s t a a + -> (Int -> Bool) + -> IxTraversal Int s t a a +elementsOf o = \p -> itraversalVL $ \f -> + indexing (traverseOf o) $ \i a -> if p i then f i a else pure a +{-# INLINE elementsOf #-} + +-- | Traverse elements of a 'Traversable' container where their ordinal +-- positions match a predicate. +-- +-- @ +-- 'elements' ≡ 'elementsOf' 'traverse' +-- @ +elements :: Traversable f => (Int -> Bool) -> IxTraversal' Int (f a) a +elements = elementsOf traversed +{-# INLINE elements #-} + +-- | Traverse the /nth/ element of a 'Traversal' if it exists. +-- +-- TODO: the result ideally should be an indexed affine traversal. +elementOf + :: Is k A_Traversal + => Optic k is s t a a + -> Int + -> IxTraversal Int s t a a +elementOf o = \i -> elementsOf o (== i) +{-# INLINE elementOf #-} + +-- | Traverse the /nth/ element of a 'Traversable' container. +-- +-- @ +-- 'element' ≡ 'elementOf' 'traversed' +-- @ +element :: Traversable f => Int -> IxTraversal' Int (f a) a +element = elementOf traversed +{-# INLINE element #-} + +-- | An indexed version of 'partsOf' that receives the entire list of indices as +-- its indices. +ipartsOf + :: forall k is i s t a. (Is k A_Traversal, is `HasSingleIndex` i) + => Optic k is s t a a + -> IxLens [i] s t [a] [a] +ipartsOf o = conjoined (partsOf o) $ ilensVL $ \f s -> + evalState (traverseOf o update s) + <$> uncurry f (unzip $ itoListOf (getting $ castOptic @A_Traversal o) s) + where + update a = get >>= \case + [] -> pure a + a' : as' -> put as' >> pure a' +{-# INLINE ipartsOf #-} + +-- $setup +-- >>> import Data.Void +-- >>> import Optics.Core diff --git a/src/Optics/Label.hs b/src/Optics/Label.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Label.hs @@ -0,0 +1,201 @@ +-- | +-- Module: Optics.Label +-- Description: Overloaded labels as optics +-- +-- Overloaded labels are a solution to Haskell's namespace problem for records. +-- The @-XOverloadedLabels@ extension allows a new expression syntax for labels, +-- a prefix @#@ sign followed by an identifier, e.g. @#foo@. These expressions +-- can then be given an interpretation that depends on the type at which they +-- are used and the text of the label. +-- +-- The following example shows how overloaded labels can be used as optics. +-- +-- == Example +-- +-- Consider the following: +-- +-- >>> :set -XDataKinds +-- >>> :set -XFlexibleContexts +-- >>> :set -XFlexibleInstances +-- >>> :set -XMultiParamTypeClasses +-- >>> :set -XOverloadedLabels +-- >>> :set -XTypeFamilies +-- >>> :set -XUndecidableInstances +-- >>> :{ +-- data Human = Human +-- { humanName :: String +-- , humanAge :: Integer +-- , humanPets :: [Pet] +-- } deriving Show +-- data Pet +-- = Cat { petName :: String, petAge :: Int, petLazy :: Bool } +-- | Fish { petName :: String, petAge :: Int } +-- deriving Show +-- :} +-- +-- The following instances can be generated by @makeFieldLabels@ from +-- @Optics.TH@ in the @optics-th@ package: +-- +-- >>> :{ +-- instance (a ~ String, b ~ String) => LabelOptic "name" A_Lens Human Human a b where +-- labelOptic = lensVL $ \f s -> (\v -> s { humanName = v }) <$> f (humanName s) +-- instance (a ~ Integer, b ~ Integer) => LabelOptic "age" A_Lens Human Human a b where +-- labelOptic = lensVL $ \f s -> (\v -> s { humanAge = v }) <$> f (humanAge s) +-- instance (a ~ [Pet], b ~ [Pet]) => LabelOptic "pets" A_Lens Human Human a b where +-- labelOptic = lensVL $ \f s -> (\v -> s { humanPets = v }) <$> f (humanPets s) +-- instance (a ~ String, b ~ String) => LabelOptic "name" A_Lens Pet Pet a b where +-- labelOptic = lensVL $ \f s -> (\v -> s { petName = v }) <$> f (petName s) +-- instance (a ~ Int, b ~ Int) => LabelOptic "age" A_Lens Pet Pet a b where +-- labelOptic = lensVL $ \f s -> (\v -> s { petAge = v }) <$> f (petAge s) +-- instance (a ~ Bool, b ~ Bool) => LabelOptic "lazy" An_AffineTraversal Pet Pet a b where +-- labelOptic = atraversalVL $ \point f s -> case s of +-- Cat name age lazy -> (\lazy' -> Cat name age lazy') <$> f lazy +-- _ -> point s +-- :} +-- +-- Here is some test data: +-- +-- >>> :{ +-- peter :: Human +-- peter = Human "Peter" 13 [ Fish "Goldie" 1 +-- , Cat "Loopy" 3 False +-- , Cat "Sparky" 2 True +-- ] +-- :} +-- +-- Now we can ask for Peter's name: +-- +-- >>> view #name peter +-- "Peter" +-- +-- or for names of his pets: +-- +-- >>> toListOf (#pets % folded % #name) peter +-- ["Goldie","Loopy","Sparky"] +-- +-- We can check whether any of his pets is lazy: +-- +-- >>> orOf (#pets % folded % #lazy) peter +-- True +-- +-- or how things might be be a year from now: +-- +-- >>> peter & over #age (+1) & over (#pets % mapped % #age) (+1) +-- Human {humanName = "Peter", humanAge = 14, humanPets = [Fish {petName = "Goldie", petAge = 2},Cat {petName = "Loopy", petAge = 4, petLazy = False},Cat {petName = "Sparky", petAge = 3, petLazy = True}]} +-- +-- Perhaps Peter is going on vacation and needs to leave his pets at home: +-- +-- >>> peter & set #pets [] +-- Human {humanName = "Peter", humanAge = 13, humanPets = []} +-- +-- +-- == Structure of 'LabelOptic' instances +-- +-- You might wonder why instances above are written in form +-- +-- @ +-- instance (a ~ [Pet], b ~ [Pet]) => LabelOptic "pets" A_Lens Human Human a b where +-- @ +-- +-- instead of +-- +-- @ +-- instance LabelOptic "pets" A_Lens Human Human [Pet] [Pet] where +-- @ +-- +-- The reason is that using the first form ensures that GHC always matches on +-- the instance if either @s@ or @t@ is known and verifies type equalities +-- later, which not only makes type inference better, but also allows it to +-- generate good error messages. +-- +-- For example, if you try to write @peter & set #pets []@ with the appropriate +-- LabelOptic instance in the second form, you get the following: +-- +-- @ +-- :16:1: error: +-- • No instance for LabelOptic "pets" ‘A_Lens’ ‘Human’ ‘()’ ‘[Pet]’ ‘[a0]’ +-- (maybe you forgot to define it or misspelled a name?) +-- • In the first argument of ‘print’, namely ‘it’ +-- In a stmt of an interactive GHCi command: print it +-- @ +-- +-- That's because empty list doesn't have type @[Pet]@, it has type @[r]@ and +-- GHC doesn't have enough information to match on the instance we +-- provided. We'd need to either annotate the list: @peter & set #pets +-- ([]::[Pet])@ or the result type: @peter & set #pets [] :: Human@, which is +-- suboptimal. +-- +-- Here are more examples of confusing error messages if the instance for +-- @LabelOptic "age"@ is written without type equalities: +-- +-- @ +-- λ> view #age peter :: Char +-- +-- :28:6: error: +-- • No instance for LabelOptic "age" ‘k0’ ‘Human’ ‘Human’ ‘Char’ ‘Char’ +-- (maybe you forgot to define it or misspelled a name?) +-- • In the first argument of ‘view’, namely ‘#age’ +-- In the expression: view #age peter :: Char +-- In an equation for ‘it’: it = view #age peter :: Char +-- λ> peter & set #age "hi" +-- +-- :29:1: error: +-- • No instance for LabelOptic "age" ‘k’ ‘Human’ ‘b’ ‘a’ ‘[Char]’ +-- (maybe you forgot to define it or misspelled a name?) +-- • When checking the inferred type +-- it :: forall k b a. ((TypeError ...), Is k A_Setter) => b +-- @ +-- +-- If we use the first form, error messages become more accurate: +-- +-- @ +-- λ> view #age peter :: Char +-- :31:6: error: +-- • Couldn't match type ‘Char’ with ‘Integer’ +-- arising from the overloaded label ‘#age’ +-- • In the first argument of ‘view’, namely ‘#age’ +-- In the expression: view #age peter :: Char +-- In an equation for ‘it’: it = view #age peter :: Char +-- λ> peter & set #age "hi" +-- +-- :32:13: error: +-- • Couldn't match type ‘[Char]’ with ‘Integer’ +-- arising from the overloaded label ‘#age’ +-- • In the first argument of ‘set’, namely ‘#age’ +-- In the second argument of ‘(&)’, namely ‘set #age "hi"’ +-- In the expression: peter & set #age "hi" +-- @ +-- +-- == Limitations arising from functional dependencies +-- +-- Functional dependencies guarantee good type inference, but also +-- create limitations. We can split them into two groups: +-- +-- - @name s -> k a@, @name t -> k b@ +-- +-- - @name s b -> t@, @name t a -> s@ +-- +-- The first group ensures that when we compose two optics, the middle type is +-- unambiguous. The consequence is that it's not possible to create label optics +-- with @a@ or @b@ referencing type variables not referenced in @s@ or @t@, +-- i.e. getters for fields of rank 2 type or reviews for constructors with +-- existentially quantified types inside. +-- +-- The second group ensures that when we perform a chain of updates, the middle +-- type is unambiguous. The consequence is that it's not possible to define +-- label optics that: +-- +-- - Modify phantom type parameters of type @s@ or @t@. +-- +-- - Modify type parameters of type @s@ or @t@ if @a@ or @b@ contain ambiguous +-- applications of type families to these type parameters. +-- +module Optics.Label + ( LabelOptic(..) + , LabelOptic' + ) where + +import Optics.Internal.Optic + +-- $setup +-- >>> import Optics.Core diff --git a/src/Optics/Lens.hs b/src/Optics/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Lens.hs @@ -0,0 +1,226 @@ +-- | +-- Module: Optics.Lens +-- Description: A generalised or first-class field. +-- +-- A 'Lens' is a generalised or first-class field. +-- +-- If we have a value @s :: S@, and a @l :: 'Lens'' S A@, we can /get/ +-- the "field value" of type @A@ using @'Optics.Getter.view' l s@. We +-- can also /update/ (or /put/ or /set/) the value using +-- 'Optics.Setter.over' (or 'Optics.Setter.set'). +-- +-- For example, given the following definitions: +-- +-- >>> data Human = Human { _name :: String, _location :: String } deriving Show +-- >>> let human = Human "Bob" "London" +-- +-- we can make a 'Lens' for @_name@ field: +-- +-- >>> let name = lens _name $ \s x -> s { _name = x } +-- +-- which we can use as a 'Optics.Getter.Getter': +-- +-- >>> view name human +-- "Bob" +-- +-- or a 'Optics.Setter.Setter': +-- +-- >>> set name "Robert" human +-- Human {_name = "Robert", _location = "London"} +-- +module Optics.Lens + ( + -- * Formation + Lens + , Lens' + + -- * Introduction + , lens + + -- * Elimination + -- | A 'Lens' is in particular a 'Optics.Getter.Getter' and a + -- 'Optics.Setter.Setter', therefore you can specialise types to obtain: + -- + -- @ + -- 'Optics.Getter.view' :: 'Lens' s t a b -> s -> a + -- @ + -- + -- @ + -- 'Optics.Setter.over' :: 'Lens' s t a b -> (a -> b) -> s -> t + -- 'Optics.Setter.set' :: 'Lens' s t a b -> b -> s -> t + -- @ + -- + + -- * Computation + -- | + -- + -- @ + -- 'Optics.Getter.view' ('lens' f g) s ≡ f s + -- 'Optics.Setter.set' ('lens' f g) a s ≡ g s a + -- @ + + -- * Well-formedness + -- | + -- + -- * __GetPut__: You get back what you put in: + -- + -- @ + -- 'Optics.Getter.view' l ('Optics.Setter.set' l v s) ≡ v + -- @ + -- + -- * __PutGet__: Putting back what you got doesn’t change anything: + -- + -- @ + -- 'Optics.Setter.set' l ('Optics.Getter.view' l s) s ≡ s + -- @ + -- + -- * __PutPut__: Setting twice is the same as setting once: + -- + -- @ + -- 'Optics.Setter.set' l v' ('Optics.Setter.set' l v s) ≡ 'Optics.Setter.set' l v' s + -- @ + -- + + -- * Additional introduction forms + -- | See "Data.Tuple.Optics" for 'Lens'es for tuples. + , equality' + , chosen + , alongside + , united + + -- * Additional elimination forms + , withLens + + -- * Subtyping + , A_Lens + -- | <> + + -- * van Laarhoven encoding + -- | The van Laarhoven encoding of lenses is isomorphic to the profunctor + -- encoding used internally by @optics@, but converting back and forth may + -- have a performance penalty. + , LensVL + , LensVL' + , lensVL + , toLensVL + , withLensVL + ) + where + +import Optics.Internal.Concrete +import Optics.Internal.Optic +import Optics.Internal.Profunctor +import Optics.Internal.Utils + +-- | Type synonym for a type-modifying lens. +type Lens s t a b = Optic A_Lens NoIx s t a b + +-- | Type synonym for a type-preserving lens. +type Lens' s a = Optic' A_Lens NoIx s a + +-- | Type synonym for a type-modifying van Laarhoven lens. +type LensVL s t a b = forall f. Functor f => (a -> f b) -> s -> f t + +-- | Type synonym for a type-preserving van Laarhoven lens. +type LensVL' s a = LensVL s s a a + +-- | Build a lens from a getter and a setter, which must respect the +-- well-formedness laws. +-- +-- If you want to build a 'Lens' from the van Laarhoven representation, use +-- 'lensVL'. +lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b +lens get set = Optic $ + -- Do not define lens in terms of lensVL, mixing profunctor-style definitions + -- with VL style implementation can lead to subpar generated code, + -- i.e. updating often gets and then sets as opposed to updating in place. + dimap (\s -> (get s, s)) + (\(b, s) -> set s b) + . first' +{-# INLINE lens #-} + +-- | Work with a lens as a getter and a setter. +-- +-- @ +-- 'withLens' ('lens' f g) k ≡ k f g +-- @ +withLens + :: Is k A_Lens + => Optic k is s t a b + -> ((s -> a) -> (s -> b -> t) -> r) + -> r +withLens o k = case getOptic (castOptic @A_Lens o) $ Store id (\_ -> id) of + Store get set -> k get set +{-# INLINE withLens #-} + +-- | Build a lens from the van Laarhoven representation. +lensVL :: LensVL s t a b -> Lens s t a b +lensVL l = Optic (linear l) +{-# INLINE lensVL #-} + +-- | Convert a lens to the van Laarhoven representation. +toLensVL :: Is k A_Lens => Optic k is s t a b -> LensVL s t a b +toLensVL o = runStar #. getOptic (castOptic @A_Lens o) .# Star +{-# INLINE toLensVL #-} + +-- | Work with a lens in the van Laarhoven representation. +withLensVL + :: Is k A_Lens + => Optic k is s t a b + -> (LensVL s t a b -> r) + -> r +withLensVL o k = k (toLensVL o) +{-# INLINE withLensVL #-} + +---------------------------------------- +-- Lenses + +-- | Strict version of 'Optics.Iso.equality'. +-- +-- Useful for strictifying optics with lazy (irrefutable) pattern matching by +-- precomposition, e.g. +-- +-- @ +-- 'Data.Tuple.Optics._1'' = 'equality'' % 'Data.Tuple.Optics._1' +-- @ +equality' :: Lens a b a b +equality' = lensVL ($!) +{-# INLINE equality' #-} + +-- | Focus on both sides of an 'Either'. +chosen :: Lens (Either a a) (Either b b) a b +chosen = lensVL $ \f -> either (fmap Left . f) (fmap Right . f) +{-# INLINE chosen #-} + +-- | Make a 'Lens' from two other lenses by executing them on their respective +-- halves of a product. +-- +-- >>> (Left 'a', Right 'b') ^. alongside chosen chosen +-- ('a','b') +-- +-- >>> (Left 'a', Right 'b') & alongside chosen chosen .~ ('c','d') +-- (Left 'c',Right 'd') +alongside + :: (Is k A_Lens, Is l A_Lens) + => Optic k is s t a b + -> Optic l js s' t' a' b' + -> Lens (s, s') (t, t') (a, a') (b, b') +alongside l r = withLens l $ \getl setl -> + withLens r $ \getr setr -> + lens (\(s, s') -> (getl s, getr s' )) + (\(s, s') (b, b') -> (setl s b, setr s' b')) +{-# INLINE alongside #-} + +-- | We can always retrieve a @()@ from any type. +-- +-- >>> view united "hello" +-- () +-- +-- >>> set united () "hello" +-- "hello" +united :: Lens' a () +united = lens (const ()) const +{-# INLINE united #-} + +-- $setup +-- >>> import Optics.Core diff --git a/src/Optics/Operators.hs b/src/Optics/Operators.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Operators.hs @@ -0,0 +1,114 @@ +-- | +-- Module: Optics.Operators +-- Description: Definitions of infix operators for optics. +-- +-- Defines some infix operators for optics operations. This is a deliberately +-- small collection. +-- +-- If you like operators, you may also wish to import @Optics.State.Operators@ +-- from the @optics-extra@ package. +-- +module Optics.Operators + ( (^.) + , (^..) + , (^?) + , (#) + , (%~) + , (%!~) + , (.~) + , (!~) + , (?~) + , (?!~) + ) + where + +import Optics.AffineFold +import Optics.Fold +import Optics.Getter +import Optics.Optic +import Optics.Review +import Optics.Setter + +-- | Flipped infix version of 'view'. +(^.) :: Is k A_Getter => s -> Optic' k is s a -> a +(^.) = flip view +{-# INLINE (^.) #-} + +infixl 8 ^. + +-- | Flipped infix version of 'preview'. +(^?) :: Is k An_AffineFold => s -> Optic' k is s a -> Maybe a +(^?) = flip preview +{-# INLINE (^?) #-} + +infixl 8 ^? + +-- | Flipped infix version of 'toListOf'. +(^..) :: Is k A_Fold => s -> Optic' k is s a -> [a] +(^..) = flip toListOf +{-# INLINE (^..) #-} + +infixl 8 ^.. + +-- | Flipped infix version of 'review'. +(#) :: Is k A_Review => Optic' k is t b -> b -> t +(#) = review +{-# INLINE (#) #-} + +infixr 8 # + +-- | Infix version of 'over'. +(%~) :: Is k A_Setter => Optic k is s t a b -> (a -> b) -> s -> t +(%~) = over +{-# INLINE (%~) #-} + +infixr 4 %~ + +-- | Infix version of 'over''. +(%!~) :: Is k A_Setter => Optic k is s t a b -> (a -> b) -> s -> t +(%!~) = over' +{-# INLINE (%!~) #-} + +infixr 4 %!~ + +-- | Infix version of 'set'. +(.~) :: Is k A_Setter => Optic k is s t a b -> b -> s -> t +(.~) = set +{-# INLINE (.~) #-} + +infixr 4 .~ + +-- | Infix version of 'set''. +(!~) :: Is k A_Setter => Optic k is s t a b -> b -> s -> t +(!~) = set' +{-# INLINE (!~) #-} + +infixr 4 !~ + +-- | Set the target of a 'Setter' to 'Just' a value. +-- +-- @ +-- o '?~' b ≡ 'set' o ('Just' b) +-- @ +-- +-- >>> Nothing & equality ?~ 'x' +-- Just 'x' +-- +-- >>> Map.empty & at 3 ?~ 'x' +-- fromList [(3,'x')] +(?~) :: Is k A_Setter => Optic k is s t a (Maybe b) -> b -> s -> t +(?~) = \o -> set o . Just +{-# INLINE (?~) #-} + +infixr 4 ?~ + +-- | Strict version of ('?~'). +(?!~) :: Is k A_Setter => Optic k is s t a (Maybe b) -> b -> s -> t +(?!~) = \o !b -> set' o (Just b) +{-# INLINE (?!~) #-} + +infixr 4 ?!~ + +-- $setup +-- >>> import qualified Data.Map as Map +-- >>> import Optics.Core diff --git a/src/Optics/Optic.hs b/src/Optics/Optic.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Optic.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module: Optics.Optic +-- Description: Common abstraction for all kinds of optics. +-- +-- This module provides core definitions: +-- +-- * an opaque 'Optic' type, which is parameterised over a type representing an +-- optic kind (instantiated with tag types such as 'A_Lens'); +-- +-- * the optic composition operator ('%'); +-- +-- * the subtyping relation 'Is' with an accompanying 'castOptic' function to +-- convert an optic kind; +-- +-- * the 'Join' operation used to find the optic kind resulting from a +-- composition. +-- +-- Each optic kind is identified by a "tag type" (such as 'A_Lens'), which is an +-- empty data type. The type of the actual optics (such as 'Optics.Lens.Lens') +-- is obtained by applying 'Optic' to the tag type. +-- +-- See the @Optics@ module in the main @optics@ package for overview +-- documentation. +-- +module Optics.Optic + ( Optic + , Optic' + + -- * Subtyping + , castOptic + , Is + , Join + + -- * Composition + , (%) + , (%%) + , (%&) + + -- * Indexed optics + , NoIx + , WithIx + , Append + , NonEmptyIndices + , HasSingleIndex + , AcceptsEmptyIndices + + -- * Base re-exports + , (&) + , (<&>) + ) + where + +import Data.Function + +import Optics.Internal.Indexed +import Optics.Internal.Optic + +#if MIN_VERSION_base(4,11,0) +import Data.Functor ((<&>)) +#else +-- | Infix flipped 'fmap'. +-- +-- @ +-- ('<&>') = 'flip' 'fmap' +-- @ +(<&>) :: Functor f => f a -> (a -> b) -> f b +as <&> f = f <$> as +{-# INLINE (<&>) #-} +infixl 1 <&> +#endif diff --git a/src/Optics/Prism.hs b/src/Optics/Prism.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Prism.hs @@ -0,0 +1,188 @@ +-- | +-- Module: Optics.Prism +-- Description: A generalised or first-class constructor. +-- +-- A 'Prism' generalises the notion of a constructor (just as a +-- 'Optics.Lens.Lens' generalises the notion of a field). +-- +module Optics.Prism + ( + -- * Formation + Prism + , Prism' + + -- * Introduction + , prism + + -- * Elimination + -- | A 'Prism' is in particular an 'Optics.AffineFold.AffineFold', a + -- 'Optics.Review.Review' and a 'Optics.Setter.Setter', therefore you can + -- specialise types to obtain: + -- + -- @ + -- 'Optics.AffineFold.preview' :: 'Prism' s t a b -> s -> Maybe a + -- 'Optics.Review.review' :: 'Prism' s t a b -> b -> t + -- @ + -- + -- @ + -- 'Optics.Setter.over' :: 'Prism' s t a b -> (a -> b) -> s -> t + -- 'Optics.Setter.set' :: 'Prism' s t a b -> b -> s -> t + -- @ + + -- * Computation + -- | + -- + -- @ + -- 'Optics.Review.review' ('prism' f g) ≡ f + -- 'Optics.AffineTraversal.matching' ('prism' f g) ≡ g + -- @ + + -- * Well-formedness + -- | + -- + -- @ + -- 'Optics.AffineTraversal.matching' o ('Optics.Review.review' o b) ≡ 'Right' b + -- 'Optics.AffineTraversal.matching' o s ≡ 'Right' a => 'Optics.Review.review' o a ≡ s + -- @ + + -- * Additional introduction forms + -- | See "Data.Maybe.Optics" and "Data.Either.Optics" for 'Prism's for the + -- corresponding types, and 'Optics.Cons.Core._Cons', 'Optics.Cons.Core._Snoc' + -- and 'Optics.Empty.Core._Empty' for 'Prism's for container types. + , prism' + , only + , nearly + + -- * Additional elimination forms + , withPrism + + -- * Combinators + , aside + , without + , below + + -- * Subtyping + , A_Prism + -- | <> + ) + where + +import Control.Monad +import Data.Bifunctor + +import Optics.Internal.Concrete +import Optics.Internal.Optic +import Optics.Internal.Profunctor + +-- | Type synonym for a type-modifying prism. +type Prism s t a b = Optic A_Prism NoIx s t a b + +-- | Type synonym for a type-preserving prism. +type Prism' s a = Optic' A_Prism NoIx s a + +-- | Build a prism from a constructor and a matcher, which must respect the +-- well-formedness laws. +-- +-- If you want to build a 'Prism' from the van Laarhoven representation, use +-- @prismVL@ from the @optics-vl@ package. +prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b +prism construct match = Optic $ dimap match (either id construct) . right' +{-# INLINE prism #-} + +-- | This is usually used to build a 'Prism'', when you have to use an operation +-- like 'Data.Typeable.cast' which already returns a 'Maybe'. +prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b +prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s)) +{-# INLINE prism' #-} + +-- | Work with a 'Prism' as a constructor and a matcher. +withPrism + :: Is k A_Prism + => Optic k is s t a b + -> ((b -> t) -> (s -> Either t a) -> r) + -> r +withPrism o k = case getOptic (castOptic @A_Prism o) (Market id Right) of + Market construct match -> k construct match +{-# INLINE withPrism #-} + +---------------------------------------- + +-- | Use a 'Prism' to work over part of a structure. +aside :: Is k A_Prism => Optic k is s t a b -> Prism (e, s) (e, t) (e, a) (e, b) +aside k = + withPrism k $ \bt seta -> + prism (fmap bt) $ \(e,s) -> + case seta s of + Left t -> Left (e,t) + Right a -> Right (e,a) +{-# INLINE aside #-} + +-- | Given a pair of prisms, project sums. +-- +-- Viewing a 'Prism' as a co-'Optics.Lens.Lens', this combinator can be seen to +-- be dual to 'Optics.Lens.alongside'. +without + :: (Is k A_Prism, Is l A_Prism) + => Optic k is s t a b + -> Optic l is u v c d + -> Prism (Either s u) (Either t v) (Either a c) (Either b d) +without k = + withPrism k $ \bt seta k' -> + withPrism k' $ \dv uevc -> + prism (bimap bt dv) $ \su -> + case su of + Left s -> bimap Left Left (seta s) + Right u -> bimap Right Right (uevc u) +{-# INLINE without #-} + +-- | Lift a 'Prism' through a 'Traversable' functor, giving a 'Prism' that +-- matches only if all the elements of the container match the 'Prism'. +below + :: (Is k A_Prism, Traversable f) + => Optic' k is s a + -> Prism' (f s) (f a) +below k = + withPrism k $ \bt seta -> + prism (fmap bt) $ \s -> + case traverse seta s of + Left _ -> Left s + Right t -> Right t +{-# INLINE below #-} + +-- | This 'Prism' compares for exact equality with a given value. +-- +-- >>> only 4 # () +-- 4 +-- +-- >>> 5 ^? only 4 +-- Nothing +only :: Eq a => a -> Prism' a () +only a = prism' (\() -> a) $ guard . (a ==) +{-# INLINE only #-} + +-- | This 'Prism' compares for approximate equality with a given value and a +-- predicate for testing, an example where the value is the empty list and the +-- predicate checks that a list is empty (same as 'Optics.Empty._Empty' with the +-- 'Optics.Empty.AsEmpty' list instance): +-- +-- >>> nearly [] null # () +-- [] +-- >>> [1,2,3,4] ^? nearly [] null +-- Nothing +-- +-- @'nearly' [] 'Prelude.null' :: 'Prism'' [a] ()@ +-- +-- To comply with the 'Prism' laws the arguments you supply to @nearly a p@ are +-- somewhat constrained. +-- +-- We assume @p x@ holds iff @x ≡ a@. Under that assumption then this is a valid +-- 'Prism'. +-- +-- This is useful when working with a type where you can test equality for only +-- a subset of its values, and the prism selects such a value. +nearly :: a -> (a -> Bool) -> Prism' a () +nearly a p = prism' (\() -> a) $ guard . p +{-# INLINE nearly #-} + +-- $setup +-- >>> import Optics.Core diff --git a/src/Optics/Re.hs b/src/Optics/Re.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Re.hs @@ -0,0 +1,170 @@ +-- | +-- Module: Optics.Re +-- Description: The 're' operator allows some optics to be reversed. +-- +-- Some optics can be reversed with 're'. This is mainly useful to invert +-- 'Optics.Iso.Iso's: +-- +-- >>> let _Identity = iso runIdentity Identity +-- >>> view (_1 % re _Identity) ('x', "yz") +-- Identity 'x' +-- +-- Yet we can use a 'Optics.Lens.Lens' as a 'Optics.Review.Review' too: +-- +-- >>> review (re _1) ('x', "yz") +-- 'x' +-- +-- In the following diagram, red arrows illustrate how 're' transforms optics. +-- The 'Optics.ReversedLens.ReversedLens' and +-- 'Optics.ReversedPrism.ReversedPrism' optic kinds are backwards versions of +-- 'Optics.Lens.Lens' and 'Optics.Prism.Prism' respectively, and are present so +-- that @'re' . 're'@ does not change the optic kind. +-- +-- <> +-- +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilyDependencies #-} +module Optics.Re + ( ReversibleOptic(..) + ) where + +import Data.Coerce + +import Optics.Internal.Bi +import Optics.Internal.Indexed +import Optics.Internal.Optic +import Optics.Internal.Profunctor + +-- | Class for optics that can be 're'versed. +class ReversibleOptic k where + -- | Injective type family that maps an optic kind to the optic kind produced + -- by 're'versing it. + -- + -- @ + -- 'ReversedOptic' 'An_Iso' = 'An_Iso' + -- 'ReversedOptic' 'A_Prism' = 'A_ReversedPrism' + -- 'ReversedOptic' 'A_ReversedPrism' = 'A_Prism' + -- 'ReversedOptic' 'A_Lens' = 'A_ReversedLens' + -- 'ReversedOptic' 'A_ReversedLens' = 'A_Lens' + -- 'ReversedOptic' 'A_Getter' = 'A_Review' + -- 'ReversedOptic' 'A_Review' = 'A_Getter' + -- @ + type ReversedOptic k = r | r -> k + -- | Reverses optics, turning around 'Optics.Iso.Iso' into 'Optics.Iso.Iso', + -- 'Optics.Prism.Prism' into 'Optics.ReversedPrism.ReversedPrism' (and + -- back), 'Optics.Lens.Lens' into 'Optics.ReversedLens.ReversedLens' (and back) + -- and 'Optics.Getter.Getter' into 'Optics.Review.Review' (and back). + re + :: "re" `AcceptsEmptyIndices` is + => Optic k is s t a b + -> Optic (ReversedOptic k) is b a t s + +instance ReversibleOptic An_Iso where + type ReversedOptic An_Iso = An_Iso + re o = Optic (re__ o) + {-# INLINE re #-} + +instance ReversibleOptic A_Prism where + type ReversedOptic A_Prism = A_ReversedPrism + re o = Optic (re__ o) + {-# INLINE re #-} + +instance ReversibleOptic A_ReversedPrism where + type ReversedOptic A_ReversedPrism = A_Prism + re o = Optic (re__ o) + {-# INLINE re #-} + +instance ReversibleOptic A_Lens where + type ReversedOptic A_Lens = A_ReversedLens + re o = Optic (re__ o) + {-# INLINE re #-} + +instance ReversibleOptic A_ReversedLens where + type ReversedOptic A_ReversedLens = A_Lens + re o = Optic (re__ o) + {-# INLINE re #-} + +instance ReversibleOptic A_Getter where + type ReversedOptic A_Getter = A_Review + re o = Optic (re__ o) + {-# INLINE re #-} + +instance ReversibleOptic A_Review where + type ReversedOptic A_Review = A_Getter + re o = Optic (re__ o) + {-# INLINE re #-} + +-- | Internal implementation of re. +re__ + :: (Profunctor p, Constraints k (Re p a b)) + => Optic k NoIx s t a b + -> Optic__ p i i b a t s +re__ o = unRe (getOptic o (Re id)) +{-# INLINE re__ #-} + +---------------------------------------- + +-- | Helper for reversing optics. +newtype Re p s t i a b = Re { unRe :: p i b a -> p i t s } + +instance Profunctor p => Profunctor (Re p s t) where + dimap f g (Re p) = Re (p . dimap g f) + lmap f (Re p) = Re (p . rmap f) + rmap g (Re p) = Re (p . lmap g) + {-# INLINE dimap #-} + {-# INLINE lmap #-} + {-# INLINE rmap #-} + + lcoerce' = lmap coerce + rcoerce' = rmap coerce + {-# INLINE lcoerce' #-} + {-# INLINE rcoerce' #-} + + conjoined__ = error "conjoined__(Re) shouldn't be reachable" + ixcontramap = error "ixcontramap(Re) shouldn't be reachable" + +instance Bicontravariant p => Bifunctor (Re p s t) where + bimap f g (Re p) = Re (p . contrabimap g f) + first f (Re p) = Re (p . contrasecond f) + second g (Re p) = Re (p . contrafirst g) + {-# INLINE bimap #-} + {-# INLINE first #-} + {-# INLINE second #-} + +instance Bifunctor p => Bicontravariant (Re p s t) where + contrabimap f g (Re p) = Re (p . bimap g f) + contrafirst f (Re p) = Re (p . second f) + contrasecond g (Re p) = Re (p . first g) + {-# INLINE contrabimap #-} + {-# INLINE contrafirst #-} + {-# INLINE contrasecond #-} + +instance Strong p => Costrong (Re p s t) where + unfirst (Re p) = Re (p . first') + unsecond (Re p) = Re (p . second') + {-# INLINE unfirst #-} + {-# INLINE unsecond #-} + +instance Costrong p => Strong (Re p s t) where + first' (Re p) = Re (p . unfirst) + second' (Re p) = Re (p . unsecond) + {-# INLINE first' #-} + {-# INLINE second' #-} + + ilinear _ = error "ilinear(Re) shouldn't be reachable" + +instance Choice p => Cochoice (Re p s t) where + unleft (Re p) = Re (p . left') + unright (Re p) = Re (p . right') + {-# INLINE unleft #-} + {-# INLINE unright #-} + +instance Cochoice p => Choice (Re p s t) where + left' (Re p) = Re (p . unleft) + right' (Re p) = Re (p . unright) + {-# INLINE left' #-} + {-# INLINE right' #-} + +-- $setup +-- >>> import Data.Functor.Identity +-- >>> import Optics.Core diff --git a/src/Optics/ReadOnly.hs b/src/Optics/ReadOnly.hs new file mode 100644 --- /dev/null +++ b/src/Optics/ReadOnly.hs @@ -0,0 +1,85 @@ +-- | +-- Module: Optics.ReadOnly +-- Description: Converting read-write optics into their read-only counterparts. +-- +-- This module defines 'getting', which turns a read-write optic into its +-- read-only counterpart. +-- +module Optics.ReadOnly + ( ToReadOnly(..) + ) where + +import Optics.Internal.Bi +import Optics.Internal.Optic +import Optics.Internal.Profunctor + +-- | Class for read-write optics that have their read-only counterparts. +class ToReadOnly k s t a b where + -- | Turn read-write optic into its read-only counterpart (or leave read-only + -- optics as-is). + -- + -- This is useful when you have an @optic :: 'Optic' k is s t a b@ of read-write + -- kind @k@ such that @s@, @t@, @a@, @b@ are rigid, there is no evidence that + -- @s ~ t@ and @a ~ b@ and you want to pass @optic@ to one of the functions + -- that accept read-only optic kinds. + -- + -- Example: + -- + -- @ + -- λ> let fstIntToChar = _1 :: Lens (Int, r) (Char, r) Int Char + -- λ> :t view fstIntToChar + -- + -- :1:6: error: + -- • Couldn't match type ‘Char’ with ‘Int’ + -- Expected type: Optic' A_Lens NoIx (Int, r) Int + -- Actual type: Lens (Int, r) (Char, r) Int Char + -- • In the first argument of ‘view’, namely ‘fstIntToChar’ + -- In the expression: view fstIntToChar + -- λ> :t view (getting fstIntToChar) + -- view (getting fstIntToChar) :: (Int, r) -> Int + -- @ + getting :: Optic k is s t a b -> Optic' (Join A_Getter k) is s a + +instance ToReadOnly An_Iso s t a b where + getting o = Optic (getting__ o) + {-# INLINE getting #-} + +instance ToReadOnly A_Lens s t a b where + getting o = Optic (getting__ o) + {-# INLINE getting #-} + +instance ToReadOnly A_Prism s t a b where + getting o = Optic (getting__ o) + {-# INLINE getting #-} + +instance ToReadOnly An_AffineTraversal s t a b where + getting o = Optic (getting__ o) + {-# INLINE getting #-} + +instance ToReadOnly A_Traversal s t a b where + getting o = Optic (getting__ o) + {-# INLINE getting #-} + +instance ToReadOnly A_ReversedPrism s t a b where + getting o = Optic (getting__ o) + {-# INLINE getting #-} + +instance (s ~ t, a ~ b) => ToReadOnly A_Getter s t a b where + getting = id + {-# INLINE getting #-} + +instance (s ~ t, a ~ b) => ToReadOnly An_AffineFold s t a b where + getting = id + {-# INLINE getting #-} + +instance (s ~ t, a ~ b) => ToReadOnly A_Fold s t a b where + getting = id + {-# INLINE getting #-} + +-- | Internal implementation of 'getting'. +getting__ + :: (Profunctor p, Bicontravariant p, Constraints k p) + => Optic k is s t a b + -> Optic__ p i (Curry is i) s s a a +getting__ (Optic o) = rphantom . o . rphantom +{-# INLINE getting__ #-} diff --git a/src/Optics/ReversedLens.hs b/src/Optics/ReversedLens.hs new file mode 100644 --- /dev/null +++ b/src/Optics/ReversedLens.hs @@ -0,0 +1,63 @@ +-- | +-- Module: Optics.ReversedLens +-- Description: A backwards 'Optics.Lens.Lens'. +-- +-- A 'ReversedLens' is a backwards 'Optics.Lens.Lens', i.e. a @'ReversedLens' s t +-- a b@ is equivalent to a @'Optics.Lens.Lens' b a t s@. These are typically +-- produced by calling 'Optics.Re.re' on a 'Optics.Lens.Lens'. They are +-- distinguished from a 'Optics.Review.Review' so that @'Optics.Re.re' +-- . 'Optics.Re.re'@ on a 'Optics.Lens.Lens' returns a 'Optics.Lens.Lens'. +-- +module Optics.ReversedLens + ( + -- * Formation + ReversedLens + , ReversedLens' + + -- * Introduction + -- | + -- + -- There is no canonical introduction form for 'ReversedLens', but you can use + -- 'Optics.Re.re' to construct one from a 'Optics.Lens.Lens': + -- + -- @ + -- (\\ f g -> 'Optics.Re.re' ('Optics.Lens.lens' f g)) :: (b -> t) -> (b -> s -> a) -> 'ReversedLens' s t a b + -- @ + + -- * Elimination + -- | + -- + -- A 'ReversedLens' is a 'Optics.Review.Review', so you can specialise types to obtain: + -- + -- @ + -- 'Optics.Review.review' :: 'ReversedLens'' s a -> a -> s + -- @ + -- + -- There is no corresponding optic kind for a backwards + -- 'Optics.Setter.Setter', but a reversed 'Optics.Setter.set' is definable + -- using 'Optics.Re.re': + -- + -- @ + -- 'Optics.Setter.set' . 'Optics.Re.re' :: 'ReversedLens' s t a b -> s -> b -> a + -- @ + + -- * Computation + -- | + -- + -- @ + -- 'Optics.Review.review' $ 'Optics.Re.re' ('Optics.Lens.lens' f g) ≡ f + -- 'Optics.Setter.set' . 'Optics.Re.re' $ 'Optics.Re.re' ('Optics.Lens.lens' f g) ≡ g + -- @ + + -- * Subtyping + , A_ReversedLens + -- | <> + ) where + +import Optics.Internal.Optic + +-- | Type synonym for a type-modifying reversed lens. +type ReversedLens s t a b = Optic A_ReversedLens NoIx s t a b + +-- | Type synonym for a type-preserving reversed lens. +type ReversedLens' t b = Optic' A_ReversedLens NoIx t b diff --git a/src/Optics/ReversedPrism.hs b/src/Optics/ReversedPrism.hs new file mode 100644 --- /dev/null +++ b/src/Optics/ReversedPrism.hs @@ -0,0 +1,63 @@ +-- | +-- Module: Optics.ReversedPrism +-- Description: A backwards 'Optics.Prism.Prism'. +-- +-- A 'ReversedPrism' is a backwards 'Optics.Prism.Prism', i.e. a +-- @'ReversedPrism' s t a b@ is equivalent to a @'Optics.Prism.Prism' b a t +-- s@. These are typically produced by calling 'Optics.Re.re' on a +-- 'Optics.Prism.Prism'. They are distinguished from a 'Optics.Getter.Getter' +-- so that @'Optics.Re.re' . 'Optics.Re.re'@ on a 'Optics.Prism.Prism' returns a +-- 'Optics.Prism.Prism'. +-- +module Optics.ReversedPrism + ( -- * Formation + ReversedPrism + , ReversedPrism' + + -- * Introduction + -- | + -- + -- There is no canonical introduction form for 'ReversedPrism', but you can + -- use 'Optics.Re.re' to construct one from a 'Optics.Prism.Prism': + -- + -- @ + -- (\\ f g -> 'Optics.Re.re' ('Optics.Prism.prism' f g)) :: (s -> a) -> (b -> Either a t) -> 'ReversedPrism' s t a b + -- @ + + -- * Elimination + -- | + -- + -- A 'ReversedPrism' is a 'Optics.Getter.Getter', so you can specialise + -- types to obtain: + -- + -- @ + -- 'Optics.Getter.view' :: 'ReversedPrism'' s a -> s -> a + -- @ + -- + -- There is no reversed 'Optics.AffineTraversal.matching' defined, but it is + -- definable using 'Optics.Re.re': + -- + -- @ + -- 'Optics.AffineTraversal.matching' . 'Optics.Re.re' :: 'ReversedPrism' s t a b -> b -> Either a t + -- @ + + -- * Computation + -- | + -- + -- @ + -- 'Optics.Getter.view' $ 'Optics.Re.re' ('Optics.Prism.prism' f g) ≡ f + -- 'Optics.AffineTraversal.matching' . 'Optics.Re.re' $ 'Optics.Re.re' ('Optics.Prism.prism' f g) ≡ g + -- @ + + -- * Subtyping + , A_ReversedPrism + -- | <> + ) where + +import Optics.Internal.Optic + +-- | Type synonym for a type-modifying reversed prism. +type ReversedPrism s t a b = Optic A_ReversedPrism NoIx s t a b + +-- | Type synonym for a type-preserving reversed prism. +type ReversedPrism' s a = Optic' A_ReversedPrism NoIx s a diff --git a/src/Optics/Review.hs b/src/Optics/Review.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Review.hs @@ -0,0 +1,55 @@ +-- | +-- Module: Optics.Review +-- Description: A backwards 'Optics.Getter.Getter', i.e. a function. +-- +-- A 'Review' is a backwards 'Optics.Getter.Getter', i.e. a +-- @'Review' T B@ is just a function @B -> T@. +-- +module Optics.Review + ( + -- * Formation + Review + + -- * Introduction + , unto + + -- * Elimination + , review + + -- * Computation + -- | + -- + -- @ + -- 'review' ('unto' f) = f + -- @ + + -- * Subtyping + , A_Review + -- | <> + ) + where + +import Optics.Internal.Bi +import Optics.Internal.Optic +import Optics.Internal.Profunctor +import Optics.Internal.Tagged +import Optics.Internal.Utils + +-- | Type synonym for a review. +type Review t b = Optic' A_Review NoIx t b + +-- | Retrieve the value targeted by a 'Review'. +-- +-- >>> review _Left "hi" +-- Left "hi" +review :: Is k A_Review => Optic' k is t b -> b -> t +review o = unTagged #. getOptic (castOptic @A_Review o) .# Tagged +{-# INLINE review #-} + +-- | An analogue of 'Optics.Getter.to' for reviews. +unto :: (b -> t) -> Review t b +unto f = Optic (lphantom . rmap f) +{-# INLINE unto #-} + +-- $setup +-- >>> import Optics.Core diff --git a/src/Optics/Setter.hs b/src/Optics/Setter.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Setter.hs @@ -0,0 +1,155 @@ +-- | +-- Module: Optics.Setter +-- Description: Applies an update to all contained values. +-- +-- A @'Setter' S T A B@ has the ability to lift a function of type +-- @A -> B@ 'over' a function of type @S -> T@, applying the function +-- to update all the @A@s contained in @S@. This can be used to 'set' +-- all the @A@s to a single value (by lifting a constant function). +-- +-- This can be seen as a generalisation of 'fmap', where the type @S@ +-- does not need to be a type constructor with @A@ as its last +-- parameter. +-- +module Optics.Setter + ( + -- * Formation + Setter + , Setter' + + -- * Introduction + , sets + + -- * Elimination + , over + + -- * Computation + -- | + -- + -- @ + -- 'over' ('sets' f) ≡ f + -- @ + + -- * Well-formedness + -- | + -- + -- * __PutPut__: Setting twice is the same as setting once: + -- + -- @ + -- 'Optics.Setter.set' l v' ('Optics.Setter.set' l v s) ≡ 'Optics.Setter.set' l v' s + -- @ + -- + -- * __Functoriality__: 'Setter's must preserve identities and composition: + -- + -- @ + -- 'over' s 'id' ≡ 'id' + -- 'over' s f '.' 'over' s g ≡ 'over' s (f '.' g) + -- @ + + -- * Additional introduction forms + -- | See also 'Data.Set.Optics.setmapped', which changes the elements of a 'Data.Set.Set'. + , mapped + + -- * Additional elimination forms + , set + , set' + , over' + + -- * Subtyping + , A_Setter + -- | <> + ) where + +import Optics.Internal.Optic +import Optics.Internal.Profunctor +import Optics.Internal.Setter + +-- | Type synonym for a type-modifying setter. +type Setter s t a b = Optic A_Setter NoIx s t a b + +-- | Type synonym for a type-preserving setter. +type Setter' s a = Optic' A_Setter NoIx s a + +-- | Apply a setter as a modifier. +over + :: Is k A_Setter + => Optic k is s t a b + -> (a -> b) -> s -> t +over o = \f -> runFunArrow $ getOptic (castOptic @A_Setter o) (FunArrow f) +{-# INLINE over #-} + +-- | Apply a setter as a modifier, strictly. +-- +-- TODO DOC: what exactly is the strictness property? +-- +-- Example: +-- +-- @ +-- f :: Int -> (Int, a) -> (Int, a) +-- f k acc +-- | k > 0 = f (k - 1) $ 'over'' 'Data.Tuple.Optics._1' (+1) acc +-- | otherwise = acc +-- @ +-- +-- runs in constant space, but would result in a space leak if used with 'over'. +-- +-- Note that replacing '$' with '$!' or 'Data.Tuple.Optics._1' with +-- 'Data.Tuple.Optics._1'' (which amount to the same thing) doesn't help when +-- 'over' is used, because the first coordinate of a pair is never forced. +-- +over' + :: Is k A_Setter + => Optic k is s t a b + -> (a -> b) -> s -> t +over' o = \f -> + let star = getOptic (castOptic @A_Setter o) $ Star (wrapIdentity' . f) + in unwrapIdentity' . runStar star +{-# INLINE over' #-} + +-- | Apply a setter. +-- +-- @ +-- 'set' o v ≡ 'over' o ('const' v) +-- @ +-- +-- >>> set _1 'x' ('y', 'z') +-- ('x','z') +-- +set + :: Is k A_Setter + => Optic k is s t a b + -> b -> s -> t +set o = over o . const +{-# INLINE set #-} + +-- | Apply a setter, strictly. +-- +-- TODO DOC: what exactly is the strictness property? +-- +set' + :: Is k A_Setter + => Optic k is s t a b + -> b -> s -> t +set' o = over' o . const +{-# INLINE set' #-} + +-- | Build a setter from a function to modify the element(s), which must respect +-- the well-formedness laws. +sets + :: ((a -> b) -> s -> t) + -> Setter s t a b +sets f = Optic (roam f) +{-# INLINE sets #-} + +-- | Create a 'Setter' for a 'Functor'. +-- +-- @ +-- 'over' 'mapped' ≡ 'fmap' +-- @ +-- +mapped :: Functor f => Setter (f a) (f b) a b +mapped = Optic mapped__ +{-# INLINE mapped #-} + +-- $setup +-- >>> import Optics.Core diff --git a/src/Optics/Traversal.hs b/src/Optics/Traversal.hs new file mode 100644 --- /dev/null +++ b/src/Optics/Traversal.hs @@ -0,0 +1,322 @@ +-- | +-- Module: Optics.Traversal +-- Description: Lifts an effectful operation on elements to act on structures. +-- +-- A 'Traversal' lifts an effectful operation on elements to act on structures +-- containing those elements. +-- +-- That is, given a function @op :: A -> F B@ where @F@ is 'Applicative', a +-- @'Traversal' S T A B@ can produce a function @S -> F T@ that applies @op@ to +-- all the @A@s contained in the @S@. +-- +-- This can be seen as a generalisation of 'traverse', where the type @S@ does +-- not need to be a type constructor with @A@ as the last parameter. +-- +-- A 'Lens' is a 'Traversal' that acts on a single value. +-- +-- A close relative is the 'Optics.AffineTraversal.AffineTraversal', which is a +-- 'Traversal' that acts on at most one value. +-- +module Optics.Traversal + ( + -- * Formation + Traversal + , Traversal' + + -- * Introduction + , traversalVL + + -- * Elimination + , traverseOf + + -- * Computation + -- | + -- + -- @ + -- 'traverseOf' ('traversalVL' f) ≡ f + -- @ + + -- * Well-formedness + -- | + -- + -- @ + -- 'traverseOf' o 'pure' ≡ 'pure' + -- 'fmap' ('traverseOf' o f) . 'traverseOf' o g ≡ 'Data.Functor.Compose.getCompose' . 'traverseOf' o ('Data.Functor.Compose.Compose' . 'fmap' f . g) + -- @ + + -- * Additional introduction forms + , traversed + + -- * Additional elimination forms + , forOf + , sequenceOf + , transposeOf + , mapAccumROf + , mapAccumLOf + , scanr1Of + , scanl1Of + , failover + , failover' + + -- * Combinators + , backwards + , partsOf + + -- * Subtyping + , A_Traversal + -- | <> + + -- * van Laarhoven encoding + -- | The van Laarhoven representation of a 'Traversal' directly expresses how + -- it lifts an effectful operation @A -> F B@ on elements to act on structures + -- @S -> F T@. Thus 'traverseOf' converts a 'Traversal' to a 'TraversalVL'. + , TraversalVL + , TraversalVL' + ) + where + +import Control.Applicative +import Control.Applicative.Backwards +import Control.Monad.Trans.State +import Data.Functor.Identity + +import Optics.Internal.Optic +import Optics.Internal.Profunctor +import Optics.Internal.Traversal +import Optics.Internal.Utils +import Optics.Lens +import Optics.Fold +import Optics.ReadOnly + +-- | Type synonym for a type-modifying traversal. +type Traversal s t a b = Optic A_Traversal NoIx s t a b + +-- | Type synonym for a type-preserving traversal. +type Traversal' s a = Optic' A_Traversal NoIx s a + +-- | Type synonym for a type-modifying van Laarhoven traversal. +type TraversalVL s t a b = forall f. Applicative f => (a -> f b) -> s -> f t + +-- | Type synonym for a type-preserving van Laarhoven traversal. +type TraversalVL' s a = TraversalVL s s a a + +-- | Build a traversal from the van Laarhoven representation. +-- +-- @ +-- 'traversalVL' '.' 'traverseOf' ≡ 'id' +-- 'traverseOf' '.' 'traversalVL' ≡ 'id' +-- @ +traversalVL :: TraversalVL s t a b -> Traversal s t a b +traversalVL t = Optic (wander t) +{-# INLINE traversalVL #-} + +-- | Map each element of a structure targeted by a 'Traversal', evaluate these +-- actions from left to right, and collect the results. +traverseOf + :: (Is k A_Traversal, Applicative f) + => Optic k is s t a b + -> (a -> f b) -> s -> f t +traverseOf o = \f -> runStar $ getOptic (castOptic @A_Traversal o) (Star f) +{-# INLINE traverseOf #-} + +-- | A version of 'traverseOf' with the arguments flipped. +forOf + :: (Is k A_Traversal, Applicative f) + => Optic k is s t a b + -> s -> (a -> f b) -> f t +forOf = flip . traverseOf +{-# INLINE forOf #-} + +-- | Evaluate each action in the structure from left to right, and collect the +-- results. +-- +-- >>> sequenceOf each ([1,2],[3,4]) +-- [(1,3),(1,4),(2,3),(2,4)] +-- +-- @ +-- 'sequence' ≡ 'sequenceOf' 'traversed' ≡ 'traverse' 'id' +-- 'sequenceOf' o ≡ 'traverseOf' o 'id' +-- @ +sequenceOf + :: (Is k A_Traversal, Applicative f) + => Optic k is s t (f b) b + -> s -> f t +sequenceOf o = traverseOf o id +{-# INLINE sequenceOf #-} + +-- | This generalizes 'Data.List.transpose' to an arbitrary 'Traversal'. +-- +-- Note: 'Data.List.transpose' handles ragged inputs more intelligently, but for +-- non-ragged inputs: +-- +-- >>> transposeOf traversed [[1,2,3],[4,5,6]] +-- [[1,4],[2,5],[3,6]] +-- +-- @ +-- 'Data.List.transpose' ≡ 'transposeOf' 'traverse' +-- @ +transposeOf + :: Is k A_Traversal + => Optic k is s t [a] a + -> s -> [t] +transposeOf o = getZipList #. traverseOf o ZipList +{-# INLINE transposeOf #-} + +-- | This generalizes 'Data.Traversable.mapAccumL' to an arbitrary 'Traversal'. +-- +-- @ +-- 'Data.Traversable.mapAccumL' ≡ 'mapAccumLOf' 'traverse' +-- @ +-- +-- 'mapAccumLOf' accumulates 'State' from left to right. +mapAccumLOf + :: Is k A_Traversal + => Optic k is s t a b + -> (acc -> a -> (b, acc)) -> acc -> s -> (t, acc) +mapAccumLOf o = \f acc0 s -> + let g a = state $ \acc -> f acc a + in runState (traverseOf o g s) acc0 + +{-# INLINE mapAccumLOf #-} + +-- | This generalizes 'Data.Traversable.mapAccumR' to an arbitrary 'Traversal'. +-- +-- @ +-- 'Data.Traversable.mapAccumR' ≡ 'mapAccumROf' 'traversed' +-- @ +-- +-- 'mapAccumROf' accumulates 'State' from right to left. +mapAccumROf + :: Is k A_Traversal + => Optic k is s t a b + -> (acc -> a -> (b, acc)) -> acc -> s -> (t, acc) +mapAccumROf = mapAccumLOf . backwards +{-# INLINE mapAccumROf #-} + +-- | This permits the use of 'scanl1' over an arbitrary 'Traversal'. +-- +-- @ +-- 'scanl1' ≡ 'scanl1Of' 'traversed' +-- @ +scanl1Of + :: Is k A_Traversal + => Optic k is s t a a + -> (a -> a -> a) -> s -> t +scanl1Of o = \f -> + let step Nothing a = (a, Just a) + step (Just s) a = let r = f s a in (r, Just r) + in fst . mapAccumLOf o step Nothing +{-# INLINE scanl1Of #-} + +-- | This permits the use of 'scanr1' over an arbitrary 'Traversal'. +-- +-- @ +-- 'scanr1' ≡ 'scanr1Of' 'traversed' +-- @ +scanr1Of + :: Is k A_Traversal + => Optic k is s t a a + -> (a -> a -> a) -> s -> t +scanr1Of o = \f -> + let step Nothing a = (a, Just a) + step (Just s) a = let r = f a s in (r, Just r) + in fst . mapAccumROf o step Nothing +{-# INLINE scanr1Of #-} + +-- | Try to map a function over this 'Traversal', returning Nothing if the +-- traversal has no targets. +-- +-- >>> failover (element 3) (*2) [1,2] +-- Nothing +-- +-- >>> failover _Left (*2) (Right 4) +-- Nothing +-- +-- >>> failover _Right (*2) (Right 4) +-- Just (Right 8) +-- +failover + :: Is k A_Traversal + => Optic k is s t a b + -> (a -> b) -> s -> Maybe t +failover o = \f s -> + let OrT visited t = traverseOf o (wrapOrT . Identity #. f) s + in if visited + then Just (runIdentity t) + else Nothing +{-# INLINE failover #-} + +-- | Version of 'failover' strict in the application of @f@. +failover' + :: Is k A_Traversal + => Optic k is s t a b + -> (a -> b) -> s -> Maybe t +failover' o = \f s -> + let OrT visited t = traverseOf o (wrapOrT . wrapIdentity' . f) s + in if visited + then Just (unwrapIdentity' t) + else Nothing +{-# INLINE failover' #-} + +---------------------------------------- +-- Traversals + +-- | Construct a 'Traversal' via the 'Traversable' class. +-- +-- @ +-- 'traverseOf' 'traversed' = 'traverse' +-- @ +-- +traversed :: Traversable t => Traversal (t a) (t b) a b +traversed = Optic traversed__ +{-# INLINE traversed #-} + +---------------------------------------- +-- Traversal combinators + +-- | This allows you to 'traverse' the elements of a traversal in the opposite +-- order. +backwards + :: Is k A_Traversal + => Optic k is s t a b + -> Traversal s t a b +backwards o = traversalVL $ \f -> forwards #. traverseOf o (Backwards #. f) +{-# INLINE backwards #-} + +-- | 'partsOf' turns a 'Traversal' into a 'Lens'. +-- +-- /Note:/ You should really try to maintain the invariant of the number of +-- children in the list. +-- +-- >>> ('a','b','c') & partsOf each .~ ['x','y','z'] +-- ('x','y','z') +-- +-- Any extras will be lost. If you do not supply enough, then the remainder will +-- come from the original structure. +-- +-- >>> ('a','b','c') & partsOf each .~ ['w','x','y','z'] +-- ('w','x','y') +-- +-- >>> ('a','b','c') & partsOf each .~ ['x','y'] +-- ('x','y','c') +-- +-- >>> ('b', 'a', 'd', 'c') & partsOf each %~ sort +-- ('a','b','c','d') +-- +-- So technically, this is only a 'Lens' if you do not change the number of +-- results it returns. +partsOf + :: forall k is s t a. Is k A_Traversal + => Optic k is s t a a + -> Lens s t [a] [a] +partsOf o = lensVL $ \f s -> evalState (traverseOf o update s) + <$> f (toListOf (getting $ castOptic @A_Traversal o) s) + where + update a = get >>= \case + a' : as' -> put as' >> pure a' + [] -> pure a +{-# INLINE partsOf #-} + +-- $setup +-- >>> import Data.List +-- >>> import Optics.Core