diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,12 @@ +# Changelog for mono-traversable-keys + +## _0.1.0_ Unreleased changes + + * Added `MonoAdjustable` type-class and initial instances + * Added `MonoIndexable` type-class and initial instances + * Added `MonoLookup` type-class and initial instances + * Added `MonoZip` type-class and initial instances + * Added `MonoZipWithKey` type-class and initial instances + * Added `MonoKeyed` type-class and initial instances + * Added `MonoFoldableWithKey` type-class and initial instances + * Added `MonoTraversableWithKey` type-class and initial instances diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Alex Washburn (c) 2019 + +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 Author name here 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,14 @@ +# mono-traversable-keys + +Provides type-classes for interacting with monomorphic containers in the following was: + + * zipping + * adjusting an element at a key + * safe indexing with a key + * unsafe indexing with a key + * mapping with a key + * folding with a key + * traversing with a key + * zipping with a key + +This package is the extension of two other popular libraries, [`mono-traversable`](http://hackage.haskell.org/package/mono-traversable) and [`keys`](http://hackage.haskell.org/package/keys), designed to provided the functionality of the `keys` package to the monomorphic containers enhanced by the `mono-traversable` package. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/mono-traversable-keys.cabal b/mono-traversable-keys.cabal new file mode 100644 --- /dev/null +++ b/mono-traversable-keys.cabal @@ -0,0 +1,84 @@ +cabal-version: 1.12 + +name: mono-traversable-keys +version: 0.1.0 +synopsis: Type-classes for interacting with monomorphic containers with a key +category: Containers, Data, Data Structures +build-type: Simple +license: BSD3 +license-file: LICENSE +copyright: (c) Alex Washburn 2019 +author: Alex Washburn +maintainer: hackage@recursion.ninja +homepage: https://github.com/recursion-ninja/mono-traversable-keys#readme +bug-reports: https://github.com/recursion-ninja/mono-traversable-keys/issues +description: + This is the extension of two other popular packages, + and + , + designed to provided the functionality of the @keys@ package to the monomorphic + containers enhanced by the @mono-traversable@ package. + +extra-source-files: + README.md + CHANGELOG.md + +tested-with: + GHC == 8.6.3 + GHC == 8.4.4 + GHC == 8.2.2 + GHC == 8.0.2 + GHC == 7.10.3 + +source-repository head + type: git + location: https://github.com/recursion-ninja/mono-traversable-keys + +library + + build-depends: + base >= 4.5 && < 5.0, + bytestring >= 0.9 && < 1.0, + containers >= 0.3 && < 0.7, + hashable >= 1.2 && < 2.0, + keys >= 3 && < 4.0, + mono-traversable >= 1 && < 2.0, + semigroups >= 0.8.3.1 && < 1.0, + text >= 0.11 && < 2.0, + transformers >= 0.2 && < 1.0, + unordered-containers >= 0.2.4 && < 1.0, + vector >= 0.10 && < 1.0, + vector-instances >= 3.4 && < 4.0 + + default-language: + Haskell2010 + + exposed-modules: + Data.MonoTraversable.Keys + + ghc-options: + -- Optimization flags + -fexpose-all-unfoldings + -fspecialise-aggressively + -- Sanity check warnings + -Wall + -fwarn-dodgy-foreign-imports + -fwarn-duplicate-exports + -fwarn-empty-enumerations + -fwarn-identities + -fwarn-incomplete-patterns + -fwarn-incomplete-record-updates + -fwarn-incomplete-uni-patterns + -fwarn-missing-fields + -fwarn-missing-signatures + -fwarn-overflowed-literals + -fwarn-overlapping-patterns + -fwarn-tabs + -fwarn-unused-binds + -fwarn-unused-do-bind + -fwarn-unused-imports + -fwarn-unused-matches + -fwarn-wrong-do-bind + + hs-source-dirs: + src diff --git a/src/Data/MonoTraversable/Keys.hs b/src/Data/MonoTraversable/Keys.hs new file mode 100644 --- /dev/null +++ b/src/Data/MonoTraversable/Keys.hs @@ -0,0 +1,2903 @@ +-- | +-- Type-classes mirroring type-classes from 'Data.Key', but working with +-- monomorphic containers. +-- +-- The motivation is that some commonly used data types (i.e., 'ByteString' and +-- 'Text') do not allow for instances of type-classes like 'Keyed', 'Indexable', +-- and 'FoldableWithKey', since they are monomorphic structures. This module +-- allows both monomorphic and polymorphic data types to be instances of the +-- same type-classes. +-- +-- All of the laws for the polymorphic type-classes apply to their monomorphic +-- cousins. +-- +-- Note that all type-classes have been prefixed with @Mono@, and functions have +-- been prefixed with @o@. The mnemonic is inherited from 'Data.MonoTraversable'. + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.MonoTraversable.Keys + ( MonoKey + -- * Keyed Monomorphic Structures + , MonoKeyed(..) + , MonoFoldableWithKey(..) + , MonoTraversableWithKey(..) + -- * Adjustable Monomorphic Structures + , MonoAdjustable(..) + -- * Zippable Monomorphic Structures + , MonoZip(..) + , MonoZipWithKey(..) + -- * Monomorphic Indexing / Querries + , MonoIndexable(..) + , MonoLookup(..) + -- * Monomorphic unwrapping with key + , ofoldlWithKeyUnwrap + , ofoldWithKeyMUnwrap + ) where + +import Control.Applicative +import Control.Arrow (Arrow) +--import Control.Comonad.Cofree (Cofree(..)) +import Control.Monad (Monad (..)) +--import Control.Monad.Free +import Control.Monad.Trans.Cont (ContT) +import Control.Monad.Trans.Identity (IdentityT) +import Control.Monad.Trans.List (ListT(..)) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Trans.Reader (ReaderT) +import Control.Monad.Trans.RWS (RWST(..)) +import qualified Control.Monad.Trans.RWS.Strict as S (RWST(..)) +import Control.Monad.Trans.State (StateT(..)) +import qualified Control.Monad.Trans.State.Strict as S (StateT(..), evalState, get, modify) +import Control.Monad.Trans.Writer (WriterT) +import qualified Control.Monad.Trans.Writer.Strict as S (WriterT) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.Foldable +import Data.Functor.Compose (Compose(..)) +import Data.Functor.Identity (Identity) +import Data.Functor.Product (Product(..)) +import Data.Hashable +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import Data.HashSet (HashSet) +import qualified Data.HashSet as HS +import Data.Int (Int) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IM +import Data.IntSet (IntSet) +import qualified Data.IntSet as IS +import Data.Key +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Map (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Monoid (Monoid(..)) +import Data.MonoTraversable (Element, MonoFoldable(..), MonoFunctor(..), MonoTraversable(..)) +--import Data.Proxy +import Data.Semigroup (Semigroup(..), Arg(..), Dual(..), Endo(..), Option(..)) +import Data.Sequence (Seq, ViewL(..), ViewR(..)) +import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set +--import Data.Tagged +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Tree (Tree(..)) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Data.Vector.Instances () +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as VSM +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed.Mutable as VUM +--import Data.Void +--import GHC.Generics +import Prelude hiding (lookup, zipWith) + + +-- | +-- Type family for getting the type of the key of a monomorphic container. +type family MonoKey key + +type instance MonoKey (r -> a) = () +type instance MonoKey [a] = Int +type instance MonoKey (a, b) = () +--type instance MonoKey ((g :.: f) a) = Key (f :.: g) +--type instance MonoKey ((f :*: g) a) = Key (f :*: g) +--type instance MonoKey ((f :+: g) a) = Key (f :+: g) +type instance MonoKey (Arg a b) = () +type instance MonoKey BS.ByteString = Int +type instance MonoKey BSL.ByteString = Int +--type instance MonoKey (Cofree f a) = Key (Cofree f) +type instance MonoKey (Compose f g a) = (MonoKey (f a), MonoKey (g a)) +type instance MonoKey (Const m a) = () +type instance MonoKey (ContT r m a) = () +type instance MonoKey (Either a b) = () +--type instance MonoKey (Free f a) = Key (Free f) +type instance MonoKey (HashMap k v) = k +type instance MonoKey (HashSet e) = Int +type instance MonoKey (Identity a) = () +type instance MonoKey (IdentityT m a) = () +type instance MonoKey (IntMap a) = Int +type instance MonoKey IntSet = Int +type instance MonoKey (IO a) = () +--type instance MonoKey (K1 i c a) = Key (K1 i c) +type instance MonoKey (ListT m a) = Int +type instance MonoKey (Map k v) = k +type instance MonoKey (Maybe a) = () +type instance MonoKey (MaybeT m a) = () +--type instance MonoKey (M1 i c f a) = Key (M1 i c f) +type instance MonoKey (NonEmpty a) = Int +type instance MonoKey (Option a) = () +--type instance MonoKey (Par1 a) = () +type instance MonoKey (Product f g a) = Either (Key f) (Key g) +--type instance MonoKey (Proxy a) = Void +type instance MonoKey (ReaderT r m a) = (r, Key m) +--type instance MonoKey (Rec1 f a) = Key (Rec1 f) +type instance MonoKey (RWST r w s m a) = () +type instance MonoKey (S.RWST r w s m a) = () +type instance MonoKey (Seq a) = Int +type instance MonoKey (Set e) = Int +type instance MonoKey (StateT s m a) = () +type instance MonoKey (S.StateT s m a) = () +--type instance MonoKey (Tagged a b) = () +type instance MonoKey T.Text = Int +type instance MonoKey TL.Text = Int +type instance MonoKey (Tree a) = Seq Int +--type instance MonoKey (U1 a) = Void +--type instance MonoKey (V1 a) = Void +type instance MonoKey (Vector a) = Int +type instance MonoKey (VU.Vector a) = Int +type instance MonoKey (VS.Vector a) = Int +type instance MonoKey (ViewL a) = () +type instance MonoKey (ViewR a) = () +type instance MonoKey (WrappedArrow a b c) = () +type instance MonoKey (WrappedMonad m a) = () +type instance MonoKey (WriterT w m a) = () +type instance MonoKey (S.WriterT w m a) = () +type instance MonoKey (ZipList a) = Int + + +-- | +-- Monomorphic containers that can be mapped over. +class MonoFunctor mono => MonoKeyed mono where + + -- | + -- Map over a monomorphic container + {-# INLINE omapWithKey #-} + omapWithKey :: (MonoKey mono -> Element mono -> Element mono) -> mono -> mono + + default omapWithKey :: (Keyed f, Element (f a) ~ a, MonoKey (f a) ~ Key f, f a ~ mono) + => (MonoKey mono -> Element mono -> Element mono) -> mono -> mono + omapWithKey = mapWithKey + + +-- | +-- Monomorphic containers that can be folded over thier pairs of elements and +-- corresponding keys. +class MonoFoldable mono => MonoFoldableWithKey mono where + {-# MINIMAL ofoldMapWithKey | ofoldlWithKey #-} + + otoKeyedList :: mono -> [(MonoKey mono, Element mono)] + otoKeyedList = ofoldrWithKey (\k v t -> (k,v):t) [] + + ofoldMapWithKey :: Monoid m => (MonoKey mono -> Element mono -> m) -> mono -> m + ofoldMapWithKey f = ofoldlWithKey (\a k v -> mappend (f k v) a) mempty + + ofoldrWithKey :: (MonoKey mono -> Element mono -> a -> a) -> a -> mono -> a + ofoldrWithKey f z t = appEndo (ofoldMapWithKey (\k v -> Endo (f k v)) t) z + + ofoldlWithKey :: (a -> MonoKey mono -> Element mono -> a) -> a -> mono -> a +{-- + default ofoldlWithKey + :: ( Keyed f + , Element (f a) ~ a + , MonoKey (f a) ~ Key f + , f a ~ mono + , FoldableWithKey f + ) + => (a -> MonoKey mono -> Element mono -> a) -> a -> mono -> a + ofoldlWithKey = foldlWithKey +--} + ofoldlWithKey f z t = appEndo (getDual (ofoldMapWithKey (\k a -> Dual (Endo (\b -> f b k a))) t)) z + + +-- | +-- Monomorphic containers that can be traversed from left to right over thier pairs of elements and corresponding keys. +class (MonoKeyed mono, MonoFoldableWithKey mono, MonoTraversable mono) => MonoTraversableWithKey mono where + {-# MINIMAL otraverseWithKey #-} + + -- | + -- Map each key-element pair of a monomorphic container to an action, + -- evaluate these actions from left to right, and collect the results. +-- {-# INLINE otraverseWithKey #-} + otraverseWithKey :: Applicative f => (MonoKey mono -> Element mono -> f (Element mono)) -> mono -> f mono + default otraverseWithKey :: (Applicative f, TraversableWithKey t, Element (t a) ~ a, MonoKey (t a) ~ Key t, t a ~ mono) + => (MonoKey mono -> Element mono -> f (Element mono)) -> mono -> f mono + otraverseWithKey = traverseWithKey + + -- | + -- Like 'otraverse' but with a Monad constraint. + {-# INLINE omapWithKeyM #-} + omapWithKeyM :: Monad m => (MonoKey mono -> Element mono -> m (Element mono)) -> mono-> m mono + omapWithKeyM f = unwrapMonad . otraverseWithKey (fmap WrapMonad . f) + + +-- | +-- Monomorphic container that can be querried by a key for an element. +class MonoLookup mono where + {-# MINIMAL olookup #-} + + olookup :: MonoKey mono -> mono -> Maybe (Element mono) + default olookup :: (Lookup f, Element (f a) ~ a, MonoKey (f a) ~ Key f, f a ~ mono) + => MonoKey mono -> mono -> Maybe (Element mono) + olookup = lookup + + +-- | +-- Monomorphic container that can be indexed by a key for an element. +class MonoLookup mono => MonoIndexable mono where + {-# MINIMAL oindex #-} + + oindex :: mono -> MonoKey mono -> Element mono + default oindex :: (Indexable f, Element (f a) ~ a, MonoKey (f a) ~ Key f, f a ~ mono) + => mono -> MonoKey mono -> Element mono + oindex = index + + +-- | +-- Monomorphic container that can adjust elements "in place." +class MonoFunctor mono => MonoAdjustable mono where + {-# MINIMAL oadjust #-} + + oadjust :: (Element mono -> Element mono) -> MonoKey mono -> mono -> mono + default oadjust :: (Adjustable f, Element (f a) ~ a, MonoKey (f a) ~ Key f, f a ~ mono) + => (Element mono -> Element mono) -> MonoKey mono -> mono -> mono + oadjust = adjust + + oreplace :: MonoKey mono -> Element mono -> mono -> mono + oreplace k v = oadjust (const v) k + + +-- | +-- Monomorphic container that can be zipped together, merging thier elements. +-- +-- Laws: +-- +-- @ +-- 'ozipWith' const u u === 'ozipWith' (flip const) u u === u +-- 'ozipWith' ('flip' f) x y === 'ozipWith' f y x +-- 'ozipWith' (\a b -> f (g a) (h b)) x y === 'ozipWith' f ('omap' g x) ('omap' h y) +-- @ +class MonoFunctor mono => MonoZip mono where + {-# MINIMAL ozipWith #-} + + ozipWith :: (Element mono -> Element mono -> Element mono) -> mono -> mono -> mono + + +-- | +-- Monomorphic container that can be zipped together, merging thier pairs of +-- elements and corresponding keys. +class (MonoKeyed mono, MonoZip mono) => MonoZipWithKey mono where + {-# MINIMAL ozipWithKey #-} + + ozipWithKey :: (MonoKey mono -> Element mono -> Element mono -> Element mono) -> mono -> mono -> mono +-- ozipWithKey f = ozap . omapWithKey f + + +-- * MonoKeyed Instances + + +-- | +-- @since 0.1.0 +instance MonoKeyed (r -> a) where + {-# INLINE omapWithKey #-} + + omapWithKey = omapWithUnitKey + + +-- | +-- @since 0.1.0 +instance MonoKeyed [a] + + +-- | +-- @since 0.1.0 +instance MonoKeyed (a, b) where + {-# INLINE omapWithKey #-} + + omapWithKey = omapWithUnitKey + + +-- | +-- @since 0.1.0 +instance MonoKeyed (Arg a b) where + {-# INLINE omapWithKey #-} + + omapWithKey = omapWithUnitKey + + +-- | +-- @since 0.1.0 +instance MonoKeyed BS.ByteString where + {-# INLINE omapWithKey #-} + + omapWithKey f = snd . BS.mapAccumL g 0 + where + g k v = (succ k, f k v) + + +-- | +-- @since 0.1.0 +instance MonoKeyed BSL.ByteString where + {-# INLINE omapWithKey #-} + + omapWithKey f = snd . BSL.mapAccumL g 0 + where + g k v = (succ k, f k v) + + +-- | +-- @since 0.1.0 +instance ( Keyed f + , Keyed g + , MonoKey (f a) ~ Key f + , MonoKey (g a) ~ Key g + ) => MonoKeyed (Compose f g a) + + +-- | +-- @since 0.1.0 +instance MonoKeyed (Const m a) where + {-# INLINE omapWithKey #-} + + omapWithKey = omapWithUnitKey + + +-- | +-- @since 0.1.0 +instance Functor m => MonoKeyed (ContT r m a) where + {-# INLINE omapWithKey #-} + + omapWithKey = omapWithUnitKey + + +-- | +-- @since 0.1.0 +instance MonoKeyed (Either a b) where + {-# INLINE omapWithKey #-} + + omapWithKey = omapWithUnitKey + + +-- | +-- @since 0.1.0 +instance MonoKeyed (HashMap k v) + + +-- Cannot instantiate because the map might violate the internal structure +-- instance MonoKeyed (HashSet v) + + +-- | +-- @since 0.1.0 +instance MonoKeyed (Identity a) + + +-- | +-- @since 0.1.0 +instance Functor m => MonoKeyed (IdentityT m a) where + {-# INLINE omapWithKey #-} + + omapWithKey = omapWithUnitKey + + +-- | +-- @since 0.1.0 +instance MonoKeyed (IntMap a) + + +-- Cannot instantiate because the map might violate the internal structure +-- instance MonoKeyed IntSet + + +-- | +-- @since 0.1.0 +instance MonoKeyed (IO a) where + {-# INLINE omapWithKey #-} + + omapWithKey = omapWithUnitKey + + +-- | +-- @since 0.1.0 +instance Functor m => MonoKeyed (ListT m a) where + {-# INLINE omapWithKey #-} + + omapWithKey f = ListT . fmap (omapWithKey f) . runListT + + +-- | +-- @since 0.1.0 +instance MonoKeyed (Map k v) + + +-- | +-- @since 0.1.0 +instance MonoKeyed (Maybe a) + + +-- | +-- @since 0.1.0 +instance Functor m => MonoKeyed (MaybeT m a) where + {-# INLINE omapWithKey #-} + + omapWithKey = omapWithUnitKey + + +-- | +-- @since 0.1.0 +instance MonoKeyed (NonEmpty a) + + +-- | +-- @since 0.1.0 +instance MonoKeyed (Option a) where + {-# INLINE omapWithKey #-} + + omapWithKey = omapWithUnitKey + + +-- | +-- @since 0.1.0 +instance ( Keyed f + , Keyed g + , MonoKey (f a) ~ Key f + , MonoKey (g a) ~ Key g + ) => MonoKeyed (Product f g a) + + +-- | +-- @since 0.1.0 +instance Keyed m => MonoKeyed (ReaderT r m a) + + +-- | +-- @since 0.1.0 +instance Functor m => MonoKeyed (RWST r w s m a) where + {-# INLINE omapWithKey #-} + + omapWithKey = omapWithUnitKey + + +-- | +-- @since 0.1.0 +instance Functor m => MonoKeyed (S.RWST r w s m a) where + {-# INLINE omapWithKey #-} + + omapWithKey = omapWithUnitKey + + +-- | +-- @since 0.1.0 +instance MonoKeyed (Seq a) + + +-- Cannot instantiate because the map might violate the internal structure +-- instance MonoKeyed Set + + +-- | +-- @since 0.1.0 +instance Functor m => MonoKeyed (StateT s m a) where + {-# INLINE omapWithKey #-} + + omapWithKey = omapWithUnitKey + + +-- | +-- @since 0.1.0 +instance Functor m => MonoKeyed (S.StateT s m a) where + {-# INLINE omapWithKey #-} + + omapWithKey = omapWithUnitKey + + +-- | +-- @since 0.1.0 +instance MonoKeyed T.Text where + {-# INLINE omapWithKey #-} + + omapWithKey f = snd . T.mapAccumL g 0 + where + g k v = (succ k, f k v) + + +-- | +-- @since 0.1.0 +instance MonoKeyed TL.Text where + {-# INLINE omapWithKey #-} + + omapWithKey f = snd . TL.mapAccumL g 0 + where + g k v = (succ k, f k v) + + +-- | +-- @since 0.1.0 +instance MonoKeyed (Tree a) + + +-- | +-- @since 0.1.0 +instance MonoKeyed (Vector a) + + +-- | +-- @since 0.1.0 +instance VU.Unbox a => MonoKeyed (VU.Vector a) where + {-# INLINE omapWithKey #-} + + omapWithKey = VU.imap + + +-- | +-- @since 0.1.0 +instance VS.Storable a => MonoKeyed (VS.Vector a) where + {-# INLINE omapWithKey #-} + + omapWithKey = VS.imap + + +-- | +-- @since 0.1.0 +instance MonoKeyed (ViewL a) where + {-# INLINE omapWithKey #-} + + omapWithKey = omapWithUnitKey + + +-- | +-- @since 0.1.0 +instance MonoKeyed (ViewR a) where + {-# INLINE omapWithKey #-} + + omapWithKey = omapWithUnitKey + + +-- | +-- @since 0.1.0 +instance Arrow a => MonoKeyed (WrappedArrow a b c) where + {-# INLINE omapWithKey #-} + + omapWithKey = omapWithUnitKey + + +-- | +-- @since 0.1.0 +instance Monad m => MonoKeyed (WrappedMonad m a) where + {-# INLINE omapWithKey #-} + + omapWithKey = omapWithUnitKey + + +-- | +-- @since 0.1.0 +instance Functor m => MonoKeyed (WriterT w m a) where + {-# INLINE omapWithKey #-} + + omapWithKey = omapWithUnitKey + + +-- | +-- @since 0.1.0 +instance Functor m => MonoKeyed (S.WriterT w m a) where + {-# INLINE omapWithKey #-} + + omapWithKey = omapWithUnitKey + + +-- | +-- @since 0.1.0 +instance MonoKeyed (ZipList a) + + +-- * MonoFoldable Instances + + +-- | +-- @since 0.1.0 +instance MonoFoldableWithKey [a] where + {-# INLINE ofoldlWithKey #-} + + ofoldlWithKey = monoFoldableWithIntegralKey + + +-- | +-- @since 0.1.0 +instance MonoFoldableWithKey (a, b) where + {-# INLINE ofoldMapWithKey #-} + + ofoldMapWithKey = monoFoldableWithUnitKey + + +-- | +-- @since 0.1.0 +instance MonoFoldableWithKey BS.ByteString where + {-# INLINE ofoldlWithKey #-} + + ofoldlWithKey = monoFoldableWithIntegralKey + + +-- | +-- @since 0.1.0 +instance MonoFoldableWithKey BSL.ByteString where + {-# INLINE ofoldlWithKey #-} + + ofoldlWithKey = monoFoldableWithIntegralKey + + +-- | +-- @since 0.1.0 +instance ( FoldableWithKey f + , FoldableWithKey g + , MonoKey (f a) ~ Key f + , MonoKey (g a) ~ Key g + ) => MonoFoldableWithKey (Compose f g a) where + {-# INLINE ofoldMapWithKey #-} + {-# INLINE ofoldrWithKey #-} + {-# INLINE ofoldlWithKey #-} + + ofoldMapWithKey = foldMapWithKey + + ofoldrWithKey = foldrWithKey + + ofoldlWithKey = foldlWithKey + + +-- | +-- @since 0.1.0 +instance MonoFoldableWithKey (Const m a) where + {-# INLINE ofoldMapWithKey #-} + + ofoldMapWithKey = monoFoldableWithUnitKey + + +-- | +-- @since 0.1.0 +instance MonoFoldableWithKey (Either a b) where + {-# INLINE ofoldMapWithKey #-} + + ofoldMapWithKey = monoFoldableWithUnitKey + + +-- | +-- @since 0.1.0 +instance MonoFoldableWithKey (HashMap k v) where + {-# INLINE ofoldrWithKey #-} + {-# INLINE ofoldlWithKey #-} + + ofoldrWithKey = HM.foldrWithKey + + ofoldlWithKey = HM.foldlWithKey' + + +-- | +-- @since 0.1.0 +instance MonoFoldableWithKey (HashSet v) where + {-# INLINE ofoldlWithKey #-} + + ofoldlWithKey = monoFoldableWithIntegralKey + + +-- | +-- @since 0.1.0 +instance MonoFoldableWithKey (Identity a) where + {-# INLINE ofoldMapWithKey #-} + + ofoldMapWithKey = monoFoldableWithUnitKey + + +-- | +-- @since 0.1.0 +instance Foldable f => MonoFoldableWithKey (IdentityT f a) where + {-# INLINE ofoldMapWithKey #-} + + ofoldMapWithKey = monoFoldableWithUnitKey + + +-- | +-- @since 0.1.0 +instance MonoFoldableWithKey (IntMap a) where + {-# INLINE ofoldMapWithKey #-} + {-# INLINE ofoldrWithKey #-} + {-# INLINE ofoldlWithKey #-} + + ofoldMapWithKey = IM.foldMapWithKey + + ofoldrWithKey = IM.foldrWithKey + + ofoldlWithKey = IM.foldlWithKey' + + +-- | +-- @since 0.1.0 +instance MonoFoldableWithKey IntSet where + {-# INLINE ofoldlWithKey #-} + + ofoldlWithKey = monoFoldableWithIntegralKey + + +-- | +-- @since 0.1.0 +instance Foldable f => MonoFoldableWithKey (ListT f a) where + {-# INLINE ofoldlWithKey #-} + + ofoldlWithKey = monoFoldableWithIntegralKey + + +-- | +-- @since 0.1.0 +instance MonoFoldableWithKey (Map k v) where + {-# INLINE ofoldMapWithKey #-} + {-# INLINE ofoldrWithKey #-} + {-# INLINE ofoldlWithKey #-} + + ofoldMapWithKey = Map.foldMapWithKey + + ofoldrWithKey = Map.foldrWithKey + + ofoldlWithKey = Map.foldlWithKey' + + +-- | +-- @since 0.1.0 +instance MonoFoldableWithKey (Maybe a) where + {-# INLINE ofoldMapWithKey #-} + + ofoldMapWithKey = monoFoldableWithUnitKey + + +-- | +-- @since 0.1.0 +instance Foldable f => MonoFoldableWithKey (MaybeT f a) where + {-# INLINE ofoldMapWithKey #-} + + ofoldMapWithKey = monoFoldableWithUnitKey + + +-- | +-- @since 0.1.0 +instance MonoFoldableWithKey (NonEmpty a) where + {-# INLINE ofoldlWithKey #-} + + ofoldlWithKey = monoFoldableWithIntegralKey + + +-- | +-- @since 0.1.0 +instance MonoFoldableWithKey (Option a) where + {-# INLINE ofoldMapWithKey #-} + + ofoldMapWithKey = monoFoldableWithUnitKey + + +-- | +-- @since 0.1.0 +instance ( FoldableWithKey f + , FoldableWithKey g + , MonoKey (f a) ~ Key f + , MonoKey (g a) ~ Key g + ) => MonoFoldableWithKey (Product f g a) where + {-# INLINE ofoldMapWithKey #-} + {-# INLINE ofoldrWithKey #-} + {-# INLINE ofoldlWithKey #-} + + ofoldMapWithKey = foldMapWithKey + + ofoldrWithKey = foldrWithKey + + ofoldlWithKey = foldlWithKey + + +-- | +-- @since 0.1.0 +instance MonoFoldableWithKey (Seq a) where + {-# INLINE ofoldMapWithKey #-} + {-# INLINE ofoldrWithKey #-} + {-# INLINE ofoldlWithKey #-} + + ofoldMapWithKey = foldMapWithKey + + ofoldrWithKey = Seq.foldrWithIndex + + ofoldlWithKey = Seq.foldlWithIndex + + +-- | +-- @since 0.1.0 +instance Ord e => MonoFoldableWithKey (Set e) where + {-# INLINE ofoldlWithKey #-} + + ofoldlWithKey = monoFoldableWithIntegralKey + + +-- | +-- @since 0.1.0 +instance MonoFoldableWithKey T.Text where + {-# INLINE ofoldlWithKey #-} + + ofoldlWithKey = monoFoldableWithIntegralKey + + +-- | +-- @since 0.1.0 +instance MonoFoldableWithKey TL.Text where + {-# INLINE ofoldlWithKey #-} + + ofoldlWithKey = monoFoldableWithIntegralKey + + +-- | +-- @since 0.1.0 +instance MonoFoldableWithKey (Tree a) where + {-# INLINE ofoldMapWithKey #-} + {-# INLINE ofoldrWithKey #-} + {-# INLINE ofoldlWithKey #-} + + ofoldMapWithKey = foldMapWithKey + + ofoldrWithKey = foldrWithKey + + ofoldlWithKey = foldlWithKey + + +-- | +-- @since 0.1.0 +instance MonoFoldableWithKey (Vector a) where + {-# INLINE ofoldrWithKey #-} + {-# INLINE ofoldlWithKey #-} + + ofoldrWithKey = V.ifoldr + + ofoldlWithKey = V.ifoldl' + + +-- | +-- @since 0.1.0 +instance VU.Unbox a => MonoFoldableWithKey (VU.Vector a) where + {-# INLINE ofoldrWithKey #-} + {-# INLINE ofoldlWithKey #-} + + ofoldrWithKey = VU.ifoldr + + ofoldlWithKey = VU.ifoldl' + + +-- | +-- @since 0.1.0 +instance VS.Storable a => MonoFoldableWithKey (VS.Vector a) where + {-# INLINE ofoldrWithKey #-} + {-# INLINE ofoldlWithKey #-} + + ofoldrWithKey = VS.ifoldr + + ofoldlWithKey = VS.ifoldl' + + +-- | +-- @since 0.1.0 +instance MonoFoldableWithKey (ViewL a) where + {-# INLINE ofoldMapWithKey #-} + + ofoldMapWithKey = monoFoldableWithUnitKey + + +-- | +-- @since 0.1.0 +instance MonoFoldableWithKey (ViewR a) where + {-# INLINE ofoldMapWithKey #-} + + ofoldMapWithKey = monoFoldableWithUnitKey + + +-- | +-- @since 0.1.0 +instance Foldable f => MonoFoldableWithKey (WriterT w f a) where + {-# INLINE ofoldMapWithKey #-} + + ofoldMapWithKey = monoFoldableWithUnitKey + + +-- | +-- @since 0.1.0 +instance Foldable f => MonoFoldableWithKey (S.WriterT w f a) where + {-# INLINE ofoldMapWithKey #-} + + ofoldMapWithKey = monoFoldableWithUnitKey + + +-- * MonoTraversableWithKey + + +-- | +-- @since 0.1.0 +instance MonoTraversableWithKey [a] where + {-# INLINE otraverseWithKey #-} + + otraverseWithKey = traverseWithKey + + +-- | +-- @since 0.1.0 +instance MonoTraversableWithKey (a, b) where + {-# INLINE otraverseWithKey #-} + + otraverseWithKey = monoTraversableWithUnitKey + + +-- | +-- @since 0.1.0 +instance MonoTraversableWithKey BS.ByteString where + {-# INLINE otraverseWithKey #-} + {-# INLINE omapWithKeyM #-} + + otraverseWithKey f = fmap BS.pack . traverseWithKey f . BS.unpack + + omapWithKeyM f = fmap BS.pack . mapWithKeyM f . BS.unpack + + +-- | +-- @since 0.1.0 +instance MonoTraversableWithKey BSL.ByteString where + {-# INLINE otraverseWithKey #-} + {-# INLINE omapWithKeyM #-} + + otraverseWithKey f = fmap BSL.pack . traverseWithKey f . BSL.unpack + + omapWithKeyM f = fmap BSL.pack . mapWithKeyM f . BSL.unpack + + +-- | +-- @since 0.1.0 +instance ( MonoKey (f a) ~ Key f + , MonoKey (g a) ~ Key g + , TraversableWithKey f + , TraversableWithKey g + ) => MonoTraversableWithKey (Compose f g a) where + {-# INLINE otraverseWithKey #-} + + otraverseWithKey = traverseWithKey + + +-- | +-- @since 0.1.0 +instance MonoTraversableWithKey (Const m a) where + {-# INLINE otraverseWithKey #-} + + otraverseWithKey = monoTraversableWithUnitKey + + +-- | +-- @since 0.1.0 +instance MonoTraversableWithKey (Either a b) where + {-# INLINE otraverseWithKey #-} + {-# INLINE omapWithKeyM #-} + + otraverseWithKey _ (Left a) = pure $ Left a + otraverseWithKey f (Right b) = Right <$> f () b + + omapWithKeyM = otraverseWithKey + + +-- | +-- @since 0.1.0 +instance MonoTraversableWithKey (HashMap k v) where + {-# INLINE otraverseWithKey #-} + + otraverseWithKey = traverseWithKey + + +-- | +-- @since 0.1.0 +instance MonoTraversableWithKey (Identity a) where + {-# INLINE otraverseWithKey #-} + + otraverseWithKey = traverseWithKey + + +-- | +-- @since 0.1.0 +instance Traversable f => MonoTraversableWithKey (IdentityT f a) where + {-# INLINE otraverseWithKey #-} + + otraverseWithKey = monoTraversableWithUnitKey + + +-- | +-- @since 0.1.0 +instance MonoTraversableWithKey (IntMap a) where + {-# INLINE otraverseWithKey #-} + + otraverseWithKey = traverseWithKey + + +-- | +-- @since 0.1.0 +instance Traversable f => MonoTraversableWithKey (ListT f a) where + + otraverseWithKey f = fmap ListT . traverse (traverseWithKey f) . runListT + + +-- | +-- @since 0.1.0 +instance MonoTraversableWithKey (Map k v) where + {-# INLINE otraverseWithKey #-} + + otraverseWithKey = traverseWithKey + + +-- | +-- @since 0.1.0 +instance MonoTraversableWithKey (Maybe a) where + {-# INLINE otraverseWithKey #-} + + otraverseWithKey = traverseWithKey + + +-- | +-- @since 0.1.0 +instance Traversable f => MonoTraversableWithKey (MaybeT f a) where + {-# INLINE otraverseWithKey #-} + + otraverseWithKey = monoTraversableWithUnitKey + + +-- | +-- @since 0.1.0 +instance MonoTraversableWithKey (NonEmpty a) where + {-# INLINE otraverseWithKey #-} + + otraverseWithKey = traverseWithKey + + +-- | +-- @since 0.1.0 +instance MonoTraversableWithKey (Option a) where + {-# INLINE otraverseWithKey #-} + + otraverseWithKey = monoTraversableWithUnitKey + + +-- | +-- @since 0.1.0 +instance ( MonoKey (f a) ~ Key f + , MonoKey (g a) ~ Key g + , TraversableWithKey f + , TraversableWithKey g + ) => MonoTraversableWithKey (Product f g a) where + {-# INLINE otraverseWithKey #-} + + otraverseWithKey = traverseWithKey + + +-- | +-- @since 0.1.0 +instance MonoTraversableWithKey (Seq a) where + {-# INLINE otraverseWithKey #-} + + otraverseWithKey = traverseWithKey + + +-- | +-- @since 0.1.0 +instance MonoTraversableWithKey T.Text where + {-# INLINE otraverseWithKey #-} + {-# INLINE omapWithKeyM #-} + + otraverseWithKey f = fmap T.pack . traverseWithKey f . T.unpack + + omapWithKeyM f = fmap T.pack . mapWithKeyM f . T.unpack + + +-- | +-- @since 0.1.0 +instance MonoTraversableWithKey TL.Text where + {-# INLINE otraverseWithKey #-} + {-# INLINE omapWithKeyM #-} + + otraverseWithKey f = fmap TL.pack . traverseWithKey f . TL.unpack + + omapWithKeyM f = fmap TL.pack . mapWithKeyM f . TL.unpack + + +-- | +-- @since 0.1.0 +instance MonoTraversableWithKey (Tree a) where + {-# INLINE otraverseWithKey #-} + + otraverseWithKey = traverseWithKey + + +-- | +-- @since 0.1.0 +instance MonoTraversableWithKey (Vector a) where + {-# INLINE otraverseWithKey #-} + + otraverseWithKey = traverseWithKey + + +-- | +-- @since 0.1.0 +instance VU.Unbox a => MonoTraversableWithKey (VU.Vector a) where + {-# INLINE otraverseWithKey #-} + {-# INLINE omapWithKeyM #-} + + otraverseWithKey f v = fmap (VU.fromListN (VU.length v)) . traverseWithKey f $ VU.toList v + + omapWithKeyM = otraverseWithKey + + +-- | +-- @since 0.1.0 +instance VS.Storable a => MonoTraversableWithKey (VS.Vector a) where + {-# INLINE otraverseWithKey #-} + {-# INLINE omapWithKeyM #-} + + otraverseWithKey f v = fmap (VS.fromListN (VS.length v)) . traverseWithKey f $ VS.toList v + + omapWithKeyM = otraverseWithKey + + +-- | +-- @since 0.1.0 +instance MonoTraversableWithKey (ViewL a) where + {-# INLINE otraverseWithKey #-} + + otraverseWithKey = monoTraversableWithUnitKey + + +-- | +-- @since 0.1.0 +instance MonoTraversableWithKey (ViewR a) where + {-# INLINE otraverseWithKey #-} + + otraverseWithKey = monoTraversableWithUnitKey + + +-- | +-- @since 0.1.0 +instance Traversable f => MonoTraversableWithKey (WriterT w f a) where + {-# INLINE otraverseWithKey #-} + + otraverseWithKey = monoTraversableWithUnitKey + + +-- | +-- @since 0.1.0 +instance Traversable f => MonoTraversableWithKey (S.WriterT w f a) where + {-# INLINE otraverseWithKey #-} + + otraverseWithKey = monoTraversableWithUnitKey + + +-- * MonoLookup Instances + + +-- | +-- @since 0.1.0 +instance MonoLookup [a] where + {-# INLINE olookup #-} + + olookup = lookup + + +-- | +-- @since 0.1.0 +instance MonoLookup (a, b) where + {-# INLINE olookup #-} + + olookup _ (_, v) = Just v + + +-- | +-- @since 0.1.0 +instance MonoLookup (Arg a b) where + {-# INLINE olookup #-} + + olookup _ (Arg _ v) = Just v + + +-- | +-- @since 0.1.0 +instance MonoLookup BS.ByteString where + {-# INLINE olookup #-} + + olookup i bs + | i < 0 + || i >= BS.length bs = Nothing + | otherwise = Just $ BS.index bs i + + +-- | +-- @since 0.1.0 +instance MonoLookup BSL.ByteString where + {-# INLINE olookup #-} + + olookup i bs + | i < 0 + || i >= fromEnum (BSL.length bs) = Nothing + | otherwise = Just . BSL.index bs $ toEnum i + + +-- | +-- @since 0.1.0 +instance ( Lookup f + , Lookup g + , MonoKey (f a) ~ Key f + , MonoKey (g a) ~ Key g + ) => MonoLookup (Compose f g a) where + {-# INLINE olookup #-} + + olookup = lookup + + +-- | +-- @since 0.1.0 +instance MonoLookup (Either a b) where + {-# INLINE olookup #-} + + olookup _ (Left _) = Nothing + olookup _ (Right v) = Just v + + +-- | +-- @since 0.1.0 +instance (Eq k, Hashable k) => MonoLookup (HashMap k v) where + {-# INLINE olookup #-} + + olookup = lookup + + +-- | +-- @since 0.1.0 +instance MonoLookup (HashSet v) where + {-# INLINE olookup #-} + + olookup = monoLookupFoldable + + +-- | +-- @since 0.1.0 +instance MonoLookup (Identity a) where + {-# INLINE olookup #-} + + olookup = lookup + + +-- | +-- @since 0.1.0 +instance MonoLookup (IntMap a) where + {-# INLINE olookup #-} + + olookup = lookup + + +-- | +-- @since 0.1.0 +instance MonoLookup IntSet where + {-# INLINE olookup #-} + + olookup = monoLookupFoldable + + +-- | +-- @since 0.1.0 +instance Ord k => MonoLookup (Map k v) where + {-# INLINE olookup #-} + + olookup = lookup + + +-- | +-- @since 0.1.0 +instance MonoLookup (Maybe a) where + {-# INLINE olookup #-} + + olookup = lookup + + +-- | +-- @since 0.1.0 +instance MonoLookup (NonEmpty a) where + {-# INLINE olookup #-} + + olookup = lookup + + +-- | +-- @since 0.1.0 +instance MonoLookup (Option a) where + {-# INLINE olookup #-} + + olookup = const getOption + + +-- | +-- @since 0.1.0 +instance ( Lookup f + , Lookup g + , MonoKey (f a) ~ Key f + , MonoKey (g a) ~ Key g + ) => MonoLookup (Product f g a) where + {-# INLINE olookup #-} + + olookup = lookup + + +-- | +-- @since 0.1.0 +instance Lookup m => MonoLookup (ReaderT r m a) where + {-# INLINE olookup #-} + + olookup = lookup + + +-- | +-- @since 0.1.0 +instance MonoLookup (Seq a) where + {-# INLINE olookup #-} + + olookup = lookup + + +-- | +-- @since 0.1.0 +instance Ord a => MonoLookup (Set a) where + {-# INLINE olookup #-} + + olookup = monoLookupFoldable + + +-- | +-- @since 0.1.0 +instance MonoLookup T.Text where + {-# INLINE olookup #-} + + olookup i ts + | i < 0 + || i >= T.length ts = Nothing + | otherwise = Just $ T.index ts i + + +-- | +-- @since 0.1.0 +instance MonoLookup TL.Text where + {-# INLINE olookup #-} + + olookup i ts + | i < 0 + || i >= fromEnum (TL.length ts) = Nothing + | otherwise = Just . TL.index ts $ toEnum i + + +-- | +-- @since 0.1.0 +instance MonoLookup (Tree a) where + {-# INLINE olookup #-} + + olookup = lookup + + +-- | +-- @since 0.1.0 +instance MonoLookup (Vector a) where + {-# INLINE olookup #-} + + olookup = lookup + + +-- | +-- @since 0.1.0 +instance VU.Unbox a => MonoLookup (VU.Vector a) where + {-# INLINE olookup #-} + + olookup = flip (VU.!?) + + +-- | +-- @since 0.1.0 +instance VS.Storable a => MonoLookup (VS.Vector a) where + {-# INLINE olookup #-} + + olookup = flip (VS.!?) + + +-- | +-- @since 0.1.0 +instance MonoLookup (ViewL a) where + {-# INLINE olookup #-} + + olookup _ EmptyL = Nothing + olookup _ (v:<_) = Just v + + +-- | +-- @since 0.1.0 +instance MonoLookup (ViewR a) where + {-# INLINE olookup #-} + + olookup _ EmptyR = Nothing + olookup _ (_:>v) = Just v + + +-- | +-- @since 0.1.0 +instance MonoLookup (ZipList a) where + {-# INLINE olookup #-} + + olookup = lookup + + +-- * MonoIndexable Instances + + +-- | +-- @since 0.1.0 +instance MonoIndexable [a] where + {-# INLINE oindex #-} + + oindex = index + + +-- | +-- @since 0.1.0 +instance MonoIndexable (a, b) where + {-# INLINE oindex #-} + + oindex (_, v) = const v + + +-- | +-- @since 0.1.0 +instance MonoIndexable (Arg a b) where + {-# INLINE oindex #-} + + oindex (Arg _ v) = const v + + +-- | +-- @since 0.1.0 +instance MonoIndexable BS.ByteString where + {-# INLINE oindex #-} + + oindex bs i + | i < 0 + || i >= BS.length bs = error $ mconcat [ "oindex on ByteString at point ", show i, " is outside the range: [0, ", show (BS.length bs - 1), "]."] + | otherwise = BS.index bs i + + +-- | +-- @since 0.1.0 +instance MonoIndexable BSL.ByteString where + {-# INLINE oindex #-} + + oindex bs i + | i < 0 + || i >= fromEnum (BSL.length bs) = error $ mconcat [ "oindex on Lazy ByteString at point ", show i, " is outside the range: [0, ", show (BSL.length bs - 1), "]."] + | otherwise = BSL.index bs $ toEnum i + + +-- | +-- @since 0.1.0 +instance ( Indexable f + , Indexable g + , MonoKey (f a) ~ Key f + , MonoKey (g a) ~ Key g + ) => MonoIndexable (Compose f g a) where + {-# INLINE oindex #-} + + oindex = index + + +-- | +-- @since 0.1.0 +instance MonoIndexable (Either a b) where + {-# INLINE oindex #-} + + oindex (Right v) = const v + oindex (Left _) = error + "oindex on Either is Left, cannot retreive a value. Consider using olookup instead." + + +-- | +-- @since 0.1.0 +instance (Eq k, Hashable k) => MonoIndexable (HashMap k v) where + {-# INLINE oindex #-} + + oindex = index + + +-- | +-- @since 0.1.0 +instance MonoIndexable (HashSet v) where + {-# INLINE oindex #-} + + oindex hs i = fromMaybe errorMessage $ olookup i hs + where + errorMessage = error $ mconcat + [ "oindex on HashSet at point " + , show i + , " is outside the range: [0, " + , show (HS.size hs - 1) + , "]." + ] + + +-- | +-- @since 0.1.0 +instance MonoIndexable (Identity a) where + {-# INLINE oindex #-} + + oindex = index + + +-- | +-- @since 0.1.0 +instance MonoIndexable (IntMap a) where + {-# INLINE oindex #-} + + oindex = index + + +-- | +-- @since 0.1.0 +instance MonoIndexable IntSet where + {-# INLINE oindex #-} + + oindex is i = fromMaybe errorMessage $ olookup i is + where + errorMessage = error $ mconcat + [ "oindex on IntSet at point " + , show i + , " is outside the range: [0, " + , show (IS.size is - 1) + , "]." + ] + + +-- | +-- @since 0.1.0 +instance Ord k => MonoIndexable (Map k v) where + {-# INLINE oindex #-} + + oindex = index + + +-- | +-- @since 0.1.0 +instance MonoIndexable (Maybe a) where + {-# INLINE oindex #-} + + oindex = index + + +-- | +-- @since 0.1.0 +instance MonoIndexable (NonEmpty a) where + {-# INLINE oindex #-} + + oindex = index + + +-- | +-- @since 0.1.0 +instance MonoIndexable (Option a) where + {-# INLINE oindex #-} + + oindex = flip . const $ fromMaybe errorMessage . getOption + where + errorMessage = error + "oindex on empty Option, cannot retreive a value. Consider using olookup instead." + + +-- | +-- @since 0.1.0 +instance ( Indexable f + , Indexable g + , MonoKey (f a) ~ Key f + , MonoKey (g a) ~ Key g + ) => MonoIndexable (Product f g a) where + {-# INLINE oindex #-} + + oindex = index + + +-- | +-- @since 0.1.0 +instance Indexable m => MonoIndexable (ReaderT r m a) where + {-# INLINE oindex #-} + + oindex = index + + +-- | +-- @since 0.1.0 +instance MonoIndexable (Seq a) where + {-# INLINE oindex #-} + + oindex = index + + +-- | +-- @since 0.1.0 +instance Ord a => MonoIndexable (Set a) where + {-# INLINE oindex #-} + + oindex s i = fromMaybe errorMessage $ olookup i s + where + errorMessage = error $ mconcat + [ "oindex on Set at point " + , show i + , " is outside the range: [0, " + , show (Set.size s - 1) + , "]." + ] + + +-- | +-- @since 0.1.0 +instance MonoIndexable T.Text where + {-# INLINE oindex #-} + + oindex ts i + | i < 0 + || i >= T.length ts = error $ mconcat [ "oindex on Text at point ", show i, " is outside the range: [0, ", show (T.length ts - 1), "]."] + | otherwise = T.index ts i + + +-- | +-- @since 0.1.0 +instance MonoIndexable TL.Text where + {-# INLINE oindex #-} + + oindex ts i + | i < 0 + || i >= fromEnum (TL.length ts) = error $ mconcat [ "oindex on Lazy Text at point ", show i, " is outside the range: [0, ", show (TL.length ts - 1), "]."] + | otherwise = TL.index ts $ toEnum i + + +-- | +-- @since 0.1.0 +instance MonoIndexable (Tree a) where + {-# INLINE oindex #-} + + oindex = index + + +-- | +-- @since 0.1.0 +instance MonoIndexable (Vector a) where + {-# INLINE oindex #-} + + oindex = index + + +-- | +-- @since 0.1.0 +instance VU.Unbox a => MonoIndexable (VU.Vector a) where + {-# INLINE oindex #-} + + oindex = (VU.!) + + +-- | +-- @since 0.1.0 +instance VS.Storable a => MonoIndexable (VS.Vector a) where + {-# INLINE oindex #-} + + oindex = (VS.!) + + +-- | +-- @since 0.1.0 +instance MonoIndexable (ViewL a) where + {-# INLINE oindex #-} + + oindex (v:<_) = const v + oindex EmptyL = error + "oindex on ViewL is EmptyL, cannot retreive a value. Consider using olookup instead." + + +-- | +-- @since 0.1.0 +instance MonoIndexable (ViewR a) where + {-# INLINE oindex #-} + + oindex (_:>v) = const v + oindex EmptyR = error + "oindex on ViewR is EmptyR, cannot retreive a value. Consider using olookup instead." + + +-- | +-- @since 0.1.0 +instance MonoIndexable (ZipList a) where + {-# INLINE oindex #-} + + oindex = index + + +-- * MonoAdjustable Instances + + +-- | +-- @since 0.1.0 +instance MonoAdjustable (r -> a) where + {-# INLINE oadjust #-} + + oadjust f _ g = f . g + + +-- | +-- @since 0.1.0 +instance MonoAdjustable [a] where + {-# INLINE oadjust #-} + + oadjust = adjust + + +-- | +-- @since 0.1.0 +instance MonoAdjustable (a, b) where + {-# INLINE oadjust #-} + + oadjust f = const $ fmap f + + +-- | +-- @since 0.1.0 +instance MonoAdjustable (Arg a b) where + {-# INLINE oadjust #-} + + oadjust f = const $ fmap f + + +-- | +-- @since 0.1.0 +instance MonoAdjustable BS.ByteString where + {-# INLINE oadjust #-} + + oadjust f i bs + | i < 0 + || i >= BS.length bs = bs + | otherwise = snd $ BS.mapAccumL g 0 bs + where + g k v = (succ k, if k == i then f v else v) + + +-- | +-- @since 0.1.0 +instance MonoAdjustable BSL.ByteString where + {-# INLINE oadjust #-} + + oadjust f i bs + | i < 0 + || i >= fromEnum (BSL.length bs) = bs + | otherwise = snd $ BSL.mapAccumL g 0 bs + where + g k v = (succ k, if k == i then f v else v) + + +-- | +-- @since 0.1.0 +instance MonoAdjustable (Const m a) where + {-# INLINE oadjust #-} + + oadjust = const $ const id + + +-- | +-- @since 0.1.0 +instance Functor m => MonoAdjustable (ContT r m a) where + {-# INLINE oadjust #-} + + oadjust f = const $ fmap f + + +-- | +-- @since 0.1.0 +instance MonoAdjustable (Either a b) where + {-# INLINE oadjust #-} + + oadjust f = const $ fmap f + + +-- | +-- @since 0.1.0 +instance (Eq k, Hashable k) => MonoAdjustable (HashMap k v) where + {-# INLINE oadjust #-} + + oadjust = HM.adjust + + +-- Cannot instantiate because the adjust might violate the internal structure +-- instance MonoAdjustable (HashSet v) + + +-- | +-- @since 0.1.0 +instance MonoAdjustable (Identity a) where + {-# INLINE oadjust #-} + + oadjust = adjust + + +-- | +-- @since 0.1.0 +instance Functor m => MonoAdjustable (IdentityT m a) where + {-# INLINE oadjust #-} + + oadjust f = const $ fmap f + + +-- | +-- @since 0.1.0 +instance MonoAdjustable (IntMap a) where + {-# INLINE oadjust #-} + + oadjust = IM.adjust + + +-- Cannot instantiate because the adjust might violate the internal structure +-- instance MonoAdjustable IntSet + + +-- | +-- @since 0.1.0 +instance MonoAdjustable (IO a) where + {-# INLINE oadjust #-} + + oadjust f = const $ fmap f + + +-- | +-- @since 0.1.0 +instance Functor m => MonoAdjustable (ListT m a) where + {-# INLINE oadjust #-} + + oadjust f i = ListT . fmap (adjust f i) . runListT + + +-- | +-- @since 0.1.0 +instance Ord k => MonoAdjustable (Map k v) where + {-# INLINE oadjust #-} + + oadjust = Map.adjust + + +-- | +-- @since 0.1.0 +instance MonoAdjustable (Maybe a) where + {-# INLINE oadjust #-} + + oadjust f = const $ fmap f + + +-- | +-- @since 0.1.0 +instance Functor m => MonoAdjustable (MaybeT m a) where + {-# INLINE oadjust #-} + + oadjust f = const $ fmap f + + +-- | +-- @since 0.1.0 +instance MonoAdjustable (NonEmpty a) where + {-# INLINE oadjust #-} + + oadjust = adjust + + +-- | +-- @since 0.1.0 +instance MonoAdjustable (Option a) where + {-# INLINE oadjust #-} + + oadjust f = const $ fmap f + + +-- | +-- @since 0.1.0 +instance ( Adjustable f + , Adjustable g + , MonoKey (f a) ~ Key f + , MonoKey (g a) ~ Key g + ) => MonoAdjustable (Product f g a) where + {-# INLINE oadjust #-} + + oadjust = adjust + + +-- | +-- @since 0.1.0 +instance Functor m => MonoAdjustable (ReaderT r m a) where + {-# INLINE oadjust #-} + + oadjust f = const $ fmap f + + +-- | +-- @since 0.1.0 +instance Functor m => MonoAdjustable (RWST r w s m a) where + {-# INLINE oadjust #-} + + oadjust f = const $ fmap f + + +-- | +-- @since 0.1.0 +instance Functor m => MonoAdjustable (S.RWST r w s m a) where + {-# INLINE oadjust #-} + + oadjust f = const $ fmap f + + +-- | +-- @since 0.1.0 +instance MonoAdjustable (Seq a) where + {-# INLINE oadjust #-} + + oadjust = adjust + + +-- Cannot instantiate because the adjust might violate the internal structure +-- instance MonoAdjustable Set + + +-- | +-- @since 0.1.0 +instance Functor m => MonoAdjustable (StateT s m a) where + {-# INLINE oadjust #-} + + oadjust f = const $ fmap f + + +-- | +-- @since 0.1.0 +instance Functor m => MonoAdjustable (S.StateT s m a) where + {-# INLINE oadjust #-} + + oadjust f = const $ fmap f + + +-- | +-- @since 0.1.0 +instance MonoAdjustable T.Text where + {-# INLINE oadjust #-} + + oadjust f i ts + | i < 0 + || i >= T.length ts = ts + | otherwise = snd $ T.mapAccumL g 0 ts + where + g k v = (succ k, if k == i then f v else v) + + +-- | +-- @since 0.1.0 +instance MonoAdjustable TL.Text where + {-# INLINE oadjust #-} + + oadjust f i ts + | i < 0 + || i >= fromEnum (TL.length ts) = ts + | otherwise = snd $ TL.mapAccumL g 0 ts + where + g k v = (succ k, if k == i then f v else v) + + +-- | +-- @since 0.1.0 +instance MonoAdjustable (Tree a) where + {-# INLINE oadjust #-} + + oadjust = adjust + + +-- | +-- @since 0.1.0 +instance MonoAdjustable (Vector a) where + {-# INLINE oadjust #-} + + oadjust = adjust + + +-- | +-- @since 0.1.0 +instance VU.Unbox a => MonoAdjustable (VU.Vector a) where + {-# INLINE oadjust #-} + + oadjust f i = VU.modify $ \v -> VUM.modify v f i + + +-- | +-- @since 0.1.0 +instance VS.Storable a => MonoAdjustable (VS.Vector a) where + {-# INLINE oadjust #-} + + oadjust f i = VS.modify $ \v -> VSM.modify v f i + + +-- | +-- @since 0.1.0 +instance MonoAdjustable (ViewL a) where + {-# INLINE oadjust #-} + + oadjust f = const $ fmap f + + +-- | +-- @since 0.1.0 +instance MonoAdjustable (ViewR a) where + {-# INLINE oadjust #-} + + oadjust f = const $ fmap f + + +-- | +-- @since 0.1.0 +instance Arrow a => MonoAdjustable (WrappedArrow a b c) where + {-# INLINE oadjust #-} + + oadjust f = const $ fmap f + + +-- | +-- @since 0.1.0 +instance Monad m => MonoAdjustable (WrappedMonad m a) where + {-# INLINE oadjust #-} + + oadjust f = const $ fmap f + + +-- | +-- @since 0.1.0 +instance Functor m => MonoAdjustable (WriterT w m a) where + {-# INLINE oadjust #-} + + oadjust f = const $ fmap f + + +-- | +-- @since 0.1.0 +instance Functor m => MonoAdjustable (S.WriterT w m a) where + {-# INLINE oadjust #-} + + oadjust f = const $ fmap f + + +-- | +-- @since 0.1.0 +instance MonoAdjustable (ZipList a) where + {-# INLINE oadjust #-} + + oadjust = adjust + + +-- * MonoZip Instances + + +-- | +-- @since 0.1.0 +instance MonoZip (r -> a) where + {-# INLINE ozipWith #-} + + ozipWith = zipWith + + +-- | +-- @since 0.1.0 +instance MonoZip [a] where + {-# INLINE ozipWith #-} + + ozipWith = zipWith + + +-- | +-- @since 0.1.0 +instance MonoZip (a, b) where + {-# INLINE ozipWith #-} + + ozipWith f (_, b1) (a, b2) = (a, f b1 b2) + + +-- | +-- @since 0.1.0 +instance MonoZip (Arg a b) where + {-# INLINE ozipWith #-} + + ozipWith f (Arg _ b1) (Arg a b2) = Arg a $ f b1 b2 + + +-- | +-- @since 0.1.0 +instance MonoZip BS.ByteString where + {-# INLINE ozipWith #-} + + ozipWith f bs = BS.pack . BS.zipWith f bs + + +-- | +-- @since 0.1.0 +instance MonoZip BSL.ByteString where + {-# INLINE ozipWith #-} + + ozipWith f bs = BSL.pack . BSL.zipWith f bs + + +-- | +-- @since 0.1.0 +instance ( Zip f + , Zip g + , MonoKey (f a) ~ Key f + , MonoKey (g a) ~ Key g + ) => MonoZip (Compose f g a) where + {-# INLINE ozipWith #-} + + ozipWith = zipWith + + +-- | +-- @since 0.1.0 +instance MonoZip (Const m a) where + {-# INLINE ozipWith #-} + + ozipWith = const $ const id + + +-- | +-- @since 0.1.0 +instance Functor m => MonoZip (ContT r m a) where + {-# INLINE ozipWith #-} + + ozipWith = liftA2 + + +-- | +-- @since 0.1.0 +instance MonoZip (Either a b) where + {-# INLINE ozipWith #-} + + ozipWith = liftA2 + + +-- | +-- @since 0.1.0 +instance (Eq k, Hashable k) => MonoZip (HashMap k v) where + {-# INLINE ozipWith #-} + + ozipWith f x y = HM.intersectionWith f x y <> HM.difference x y <> HM.difference y x + + +-- Cannot instantiate because the zip might violate the internal structure +-- instance MonoZip IntSet + + +-- | +-- @since 0.1.0 +instance MonoZip (Identity a) where + {-# INLINE ozipWith #-} + + ozipWith = zipWith + + +-- | +-- @since 0.1.0 +instance Applicative m => MonoZip (IdentityT m a) where + {-# INLINE ozipWith #-} + + ozipWith = liftA2 + + +-- | +-- @since 0.1.0 +instance MonoZip (IntMap a) where + {-# INLINE ozipWith #-} + + ozipWith f x y = IM.intersectionWith f x y <> IM.difference x y <> IM.difference y x + + +-- Cannot instantiate because the zip might violate the internal structure +-- instance MonoZip IntSet + + +-- | +-- @since 0.1.0 +instance MonoZip (IO a) where + {-# INLINE ozipWith #-} + + ozipWith = liftA2 + + +-- | +-- @since 0.1.0 +instance Applicative m => MonoZip (ListT m a) where + {-# INLINE ozipWith #-} + + ozipWith f x y = ListT $ zipWith f <$> runListT x <*> runListT y + + +-- | +-- @since 0.1.0 +instance Ord k => MonoZip (Map k v) where + {-# INLINE ozipWith #-} + + ozipWith f x y = Map.intersectionWith f x y <> Map.difference x y <> Map.difference y x + + +-- | +-- @since 0.1.0 +instance MonoZip (Maybe a) where + {-# INLINE ozipWith #-} + + ozipWith = liftA2 + + +-- | +-- @since 0.1.0 +instance Applicative m => MonoZip (MaybeT m a) where + {-# INLINE ozipWith #-} + + ozipWith f x y = MaybeT $ liftA2 f <$> runMaybeT x <*> runMaybeT y + + +-- | +-- @since 0.1.0 +instance MonoZip (NonEmpty a) where + {-# INLINE ozipWith #-} + + ozipWith f (x:|xs) (y :|ys) = f x y :| zipWith f xs ys + + +-- | +-- @since 0.1.0 +instance MonoZip (Option a) where + {-# INLINE ozipWith #-} + + ozipWith = liftA2 + + +-- | +-- @since 0.1.0 +instance ( Zip f + , Zip g + , MonoKey (f a) ~ Key f + , MonoKey (g a) ~ Key g + ) => MonoZip (Product f g a) where + {-# INLINE ozipWith #-} + + ozipWith = zipWith + + +-- | +-- @since 0.1.0 +instance Applicative m => MonoZip (ReaderT r m a) where + {-# INLINE ozipWith #-} + + ozipWith = liftA2 + + +-- | +-- @since 0.1.0 +instance (Applicative m, Semigroup w) => MonoZip (RWST r w s m a) where + {-# INLINE ozipWith #-} + + ozipWith f (RWST x) (RWST y) = RWST $ \r s -> + let g (a1, _, w1) (a2, _, w2) = (f a1 a2, s, w1 <> w2) + in g <$> x r s <*> y r s + + +-- | +-- @since 0.1.0 +instance (Applicative m, Semigroup w) => MonoZip (S.RWST r w s m a) where + {-# INLINE ozipWith #-} + + ozipWith f (S.RWST x) (S.RWST y) = S.RWST $ \r s -> + let g (a1, _, w1) (a2, _, w2) = (f a1 a2, s, w1 <> w2) + in g <$> x r s <*> y r s + + +-- | +-- @since 0.1.0 +instance MonoZip (Seq a) where + {-# INLINE ozipWith #-} + + ozipWith = zipWith + + +-- Cannot instantiate because the zip might violate the internal structure +-- instance MonoZip Set + + +-- | +-- @since 0.1.0 +instance Applicative m => MonoZip (StateT s m a) where + {-# INLINE ozipWith #-} + + ozipWith f (StateT x) (StateT y) = StateT $ \ s -> + let g (a1, _) (a2, _) = (f a1 a2, s) + in g <$> x s <*> y s + + +-- | +-- @since 0.1.0 +instance Applicative m => MonoZip (S.StateT s m a) where + {-# INLINE ozipWith #-} + + ozipWith f (S.StateT x) (S.StateT y) = S.StateT $ \ s -> + let g (a1, _) (a2, _) = (f a1 a2, s) + in g <$> x s <*> y s + + +-- | +-- @since 0.1.0 +instance MonoZip T.Text where + {-# INLINE ozipWith #-} + + ozipWith = T.zipWith + + +-- | +-- @since 0.1.0 +instance MonoZip TL.Text where + {-# INLINE ozipWith #-} + + ozipWith = TL.zipWith + + +-- | +-- @since 0.1.0 +instance MonoZip (Tree a) where + {-# INLINE ozipWith #-} + + ozipWith = zipWith + + +-- | +-- @since 0.1.0 +instance MonoZip (Vector a) where + {-# INLINE ozipWith #-} + + ozipWith = zipWith + + +-- | +-- @since 0.1.0 +instance VU.Unbox a => MonoZip (VU.Vector a) where + {-# INLINE ozipWith #-} + + ozipWith = VU.zipWith + + +-- | +-- @since 0.1.0 +instance VS.Storable a => MonoZip (VS.Vector a) where + {-# INLINE ozipWith #-} + + ozipWith = VS.zipWith + + +-- | +-- @since 0.1.0 +instance MonoZip (ViewL a) where + {-# INLINE ozipWith #-} + + ozipWith _ EmptyL _ = EmptyL + ozipWith _ _ EmptyL = EmptyL + ozipWith f (x:x) (ys:>y) = Seq.zipWith f xs ys :> f x y + + +-- | +-- @since 0.1.0 +instance Arrow a => MonoZip (WrappedArrow a b c) where + {-# INLINE ozipWith #-} + + ozipWith = liftA2 + + +-- | +-- @since 0.1.0 +instance Monad m => MonoZip (WrappedMonad m a) where + {-# INLINE ozipWith #-} + + ozipWith = liftA2 + + +-- | +-- @since 0.1.0 +instance (Applicative m, Monoid w) => MonoZip (WriterT w m a) where + {-# INLINE ozipWith #-} + + ozipWith = liftA2 + + +-- | +-- @since 0.1.0 +instance (Applicative m, Monoid w) => MonoZip (S.WriterT w m a) where + {-# INLINE ozipWith #-} + + ozipWith = liftA2 + + +-- | +-- @since 0.1.0 +instance MonoZip (ZipList a) where + {-# INLINE ozipWith #-} + + ozipWith = zipWith + + +-- * MonoZipWithKey + + +-- | +-- @since 0.1.0 +instance MonoZipWithKey (r -> a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey f = zipWith (f ()) + + +-- | +-- @since 0.1.0 +instance MonoZipWithKey [a] where + {-# INLINE ozipWithKey #-} + + ozipWithKey = zipWithKey + +-- | +-- @since 0.1.0 +instance MonoZipWithKey (a, b) where + {-# INLINE ozipWithKey #-} + + ozipWithKey f (_, b1) (a, b2) = (a, f () b1 b2) + + +-- | +-- @since 0.1.0 +instance MonoZipWithKey (Arg a b) where + {-# INLINE ozipWithKey #-} + + ozipWithKey f (Arg _ b1) (Arg a b2) = Arg a $ f () b1 b2 + + +-- | +-- @since 0.1.0 +instance MonoZipWithKey BS.ByteString where + {-# INLINE ozipWithKey #-} + + ozipWithKey f bs = BS.pack . zipWithKey f (BS.unpack bs) . BS.unpack + + +-- | +-- @since 0.1.0 +instance MonoZipWithKey BSL.ByteString where + {-# INLINE ozipWithKey #-} + + ozipWithKey f bs = BSL.pack . zipWithKey f (BSL.unpack bs) . BSL.unpack + + +-- | +-- @since 0.1.0 +instance ( ZipWithKey f + , ZipWithKey g + , MonoKey (f a) ~ Key f + , MonoKey (g a) ~ Key g + ) => MonoZipWithKey (Compose f g a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey = zipWithKey + + +-- | +-- @since 0.1.0 +instance MonoZipWithKey (Const m a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey = const $ const id + + +-- | +-- @since 0.1.0 +instance Functor m => MonoZipWithKey (ContT r m a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey f = liftA2 (f ()) + + +-- | +-- @since 0.1.0 +instance MonoZipWithKey (Either a b) where + {-# INLINE ozipWithKey #-} + + ozipWithKey f = liftA2 (f ()) + + +-- | +-- @since 0.1.0 +instance (Eq k, Hashable k) => MonoZipWithKey (HashMap k v) where + {-# INLINE ozipWithKey #-} + + ozipWithKey f x y = HM.intersectionWithKey f x y <> HM.difference x y <> HM.difference y x + + +-- Cannot instantiate because the map might violate the internal structure +-- instance MonoZipWithKey (HashSet v) + + +-- | +-- @since 0.1.0 +instance MonoZipWithKey (Identity a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey = zipWithKey + + +-- | +-- @since 0.1.0 +instance Applicative m => MonoZipWithKey (IdentityT m a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey f = liftA2 (f ()) + + +-- | +-- @since 0.1.0 +instance MonoZipWithKey (IntMap a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey f x y = IM.intersectionWithKey f x y <> IM.difference x y <> IM.difference y x + + +-- Cannot instantiate because the map might violate the internal structure +-- instance MonoZipWithKey IntSet + + +-- | +-- @since 0.1.0 +instance MonoZipWithKey (IO a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey f = liftA2 (f ()) + + +-- | +-- @since 0.1.0 +instance Applicative m => MonoZipWithKey (ListT m a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey f x y = ListT $ zipWithKey f <$> runListT x <*> runListT y + + +-- | +-- @since 0.1.0 +instance Ord k => MonoZipWithKey (Map k v) where + {-# INLINE ozipWithKey #-} + + ozipWithKey f x y = Map.intersectionWithKey f x y <> Map.difference x y <> Map.difference y x + + +-- | +-- @since 0.1.0 +instance MonoZipWithKey (Maybe a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey f = liftA2 (f ()) + + +-- | +-- @since 0.1.0 +instance Monad m => MonoZipWithKey (MaybeT m a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey f = liftA2 (f ()) + + +-- | +-- @since 0.1.0 +instance MonoZipWithKey (NonEmpty a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey = zipWithKey + + +-- | +-- @since 0.1.0 +instance MonoZipWithKey (Option a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey f = liftA2 (f ()) + + +-- | +-- @since 0.1.0 +instance ( ZipWithKey f + , ZipWithKey g + , MonoKey (f a) ~ Key f + , MonoKey (g a) ~ Key g + ) => MonoZipWithKey (Product f g a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey = zipWithKey + + +-- | +-- @since 0.1.0 +instance (Applicative m, ZipWithKey m) => MonoZipWithKey (ReaderT r m a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey = zipWithKey + + +-- | +-- @since 0.1.0 +instance (Applicative m, Semigroup w) => MonoZipWithKey (RWST r w s m a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey f (RWST x) (RWST y) = RWST $ \r s -> + let g (a1, _, w1) (a2, _, w2) = (f () a1 a2, s, w1 <> w2) + in g <$> x r s <*> y r s + + +-- | +-- @since 0.1.0 +instance (Applicative m, Semigroup w) => MonoZipWithKey (S.RWST r w s m a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey f (S.RWST x) (S.RWST y) = S.RWST $ \r s -> + let g (a1, _, w1) (a2, _, w2) = (f () a1 a2, s, w1 <> w2) + in g <$> x r s <*> y r s + + +-- | +-- @since 0.1.0 +instance MonoZipWithKey (Seq a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey = zipWithKey + + +-- Cannot instantiate because the map might violate the internal structure +-- instance MonoZipWithKey Set + + +-- | +-- @since 0.1.0 +instance Applicative m => MonoZipWithKey (StateT s m a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey f (StateT x) (StateT y) = StateT $ \ s -> + let g (a1, _) (a2, _) = (f () a1 a2, s) + in g <$> x s <*> y s + + +-- | +-- @since 0.1.0 +instance Applicative m => MonoZipWithKey (S.StateT s m a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey f (S.StateT x) (S.StateT y) = S.StateT $ \ s -> + let g (a1, _) (a2, _) = (f () a1 a2, s) + in g <$> x s <*> y s + + +-- | +-- @since 0.1.0 +instance MonoZipWithKey T.Text where + {-# INLINE ozipWithKey #-} + + ozipWithKey f ts = T.pack . zipWithKey f (T.unpack ts) . T.unpack + + +-- | +-- @since 0.1.0 +instance MonoZipWithKey TL.Text where + {-# INLINE ozipWithKey #-} + + ozipWithKey f ts = TL.pack . zipWithKey f (TL.unpack ts) . TL.unpack + + +-- | +-- @since 0.1.0 +instance MonoZipWithKey (Tree a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey = zipWithKey + + +-- | +-- @since 0.1.0 +instance MonoZipWithKey (Vector a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey = V.izipWith + + +-- | +-- @since 0.1.0 +instance VU.Unbox a => MonoZipWithKey (VU.Vector a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey = VU.izipWith + + +-- | +-- @since 0.1.0 +instance VS.Storable a => MonoZipWithKey (VS.Vector a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey = VS.izipWith + + +-- | +-- @since 0.1.0 +instance MonoZipWithKey (ViewL a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey _ EmptyL _ = EmptyL + ozipWithKey _ _ EmptyL = EmptyL + ozipWithKey f (x:x) (ys:>y) = Seq.fromList (zipWith (f ()) (toList xs) (toList ys)) :> f () x y + + +-- | +-- @since 0.1.0 +instance Arrow a => MonoZipWithKey (WrappedArrow a b c) where + {-# INLINE ozipWithKey #-} + + ozipWithKey f = liftA2 $ f () + + +-- | +-- @since 0.1.0 +instance Monad m => MonoZipWithKey (WrappedMonad m a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey f = liftA2 $ f () + + +-- | +-- @since 0.1.0 +instance (Applicative m, Monoid w) => MonoZipWithKey (WriterT w m a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey f = liftA2 $ f () + + +-- | +-- @since 0.1.0 +instance (Applicative m, Monoid w) => MonoZipWithKey (S.WriterT w m a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey f = liftA2 $ f () + + +-- | +-- @since 0.1.0 +instance MonoZipWithKey (ZipList a) where + {-# INLINE ozipWithKey #-} + + ozipWithKey = zipWithKey + + +-- * Unwraping functions + + +-- | +-- @since 0.1.0 +-- +-- A strict left fold, together with an unwrap function. +-- +-- This is convenient when the accumulator value is not the same as the final +-- expected type. It is provided mainly for integration with the +-- @[foldl](http://hackage.haskell.org/package/foldl)@ +-- package, to be used in conjunction with +-- @[purely](hackage.haskell.org/package/foldl/docs/Conrtol-Foldl.html#v:purely).@ +ofoldlWithKeyUnwrap :: MonoFoldableWithKey mono + => (x -> Element mono -> x) -> x -> (x -> b) -> mono -> b +ofoldlWithKeyUnwrap f x unwrap mono = unwrap (ofoldl' f x mono) + +-- | +-- @since 0.1.0 +-- +-- A monadic strict left fold, together with an unwrap function. +-- +-- Similar to 'foldlUnwrap', but allows monadic actions. To be used with +-- @[impurely](hackage.haskell.org/package/foldl/docs/Control-Foldl.html#v:impurely)@ +-- from @[foldl](http://hackage.haskell.org/package/foldl).@ +ofoldWithKeyMUnwrap :: (Monad m, MonoFoldableWithKey mono) + => (x -> Element mono -> m x) -> m x -> (x -> m b) -> mono -> m b +ofoldWithKeyMUnwrap f mx unwrap mono = do + x <- mx + x' <- ofoldlM f x mono + unwrap x' + + +-- * Utility Functions + + +omapWithUnitKey :: MonoFunctor mono => (() -> Element mono -> Element mono) -> mono -> mono +omapWithUnitKey f = omap (f ()) + + +{- +omapWithIntegralKey + :: ( Bounded i, Enum i, MonoTraversable mono) + => (i -> Element mono -> Element mono) -> mono -> mono +omapWithIntegralKey f = (`S.evalState` minBound) . omapM g + where + g e = do + k <- S.get + S.modify succ + return $ f k e +-} + + +monoFoldableWithUnitKey :: (Monoid m, MonoFoldable mono) => (() -> Element mono -> m) -> mono -> m +monoFoldableWithUnitKey f = ofoldMap (f ()) + + +monoFoldableWithIntegralKey + :: ( Integral i, MonoFoldable mono) + => (a -> i -> Element mono -> a) -> a -> mono -> a +monoFoldableWithIntegralKey f z = (`S.evalState` 0) . ofoldlM g z + where + g a e = do + !k <- S.get + S.modify succ + pure $ f a k e + + +monoTraversableWithUnitKey + :: (Applicative f, MonoTraversable mono) + => (() -> Element mono -> f (Element mono)) -> mono -> f mono +monoTraversableWithUnitKey f = otraverse (f ()) + + +monoLookupFoldable :: (Integral i, MonoFoldable mono) => i -> mono -> Maybe (Element mono) +monoLookupFoldable i t + | i < 0 = Nothing + | otherwise = go i $ otoList t + where + go _ [] = Nothing + go 0 [x] = Just x + go !n (_:xs) = go (n-1) xs