mono-traversable 0.2.0.0 → 0.3.0.0
raw patch · 9 files changed
+1101/−244 lines, 9 filesdep +QuickCheckdep +vector-instancesdep ~containersdep ~semigroupsdep ~transformers
Dependencies added: QuickCheck, vector-instances
Dependency ranges changed: containers, semigroups, transformers, unordered-containers, vector
Files
- README.md +35/−1
- mono-traversable.cabal +14/−1
- src/Data/Containers.hs +279/−6
- src/Data/GrowingAppend.hs +41/−0
- src/Data/MinLen.hs +91/−0
- src/Data/MonoTraversable.hs +254/−6
- src/Data/NonNull.hs +137/−216
- src/Data/Sequences.hs +63/−13
- test/Spec.hs +187/−1
README.md view
@@ -1,6 +1,40 @@ mono-traversable ================ -Type classes for mapping, folding, and traversing monomorphic containers+Type classes for mapping, folding, and traversing monomorphic containers. Contains even more experimental code for abstracting containers and sequences. ++Adding instances+----------------++If you have a data type which is a member of one of the relevant typeclasses ([Functor](http://hackage.haskell.org/package/base-4.6.0.1/docs/Data-Functor.html),+[Foldable](http://hackage.haskell.org/package/base-4.6.0.1/docs/Data-Foldable.html),+[Traversable](http://hackage.haskell.org/package/base-4.6.0.1/docs/Data-Traversable.html)), its quite easy to add an instance for +[MonoFunctor](https://hackage.haskell.org/package/mono-traversable-0.2.0.0/docs/Data-MonoTraversable.html#t:MonoFunctor), [MonoFoldable](https://hackage.haskell.org/package/mono-traversable-0.2.0.0/docs/Data-MonoTraversable.html#t:MonoFoldable) or [MonoTraversable](https://hackage.haskell.org/package/mono-traversable-0.2.0.0/docs/Data-MonoTraversable.html#t:MonoTraversable).++You just have to declare the proper ```type instance```:++```Haskell+ {-# LANGUAGE TypeFamilies #-}+ + (...)+ + -- type instance Element T.Text = Char -- already defined+ -- type instance Element [a] = a -- here for example+ type instance Element (CustomType a) = a+```++And then, the needed instances:++```Haskell+ instance MonoFunctor (CustomType a)+ instance MonoFoldable (CustomType a)+ instance MonoTraversable (CustomType a)+```+ ++in your code, and your ready to use ```CustomType a``` with the functions defined in this package.++**Note**: if your type is as _monomorphic container_ without the proper typeclasses, then you will have to provide an implementation. However, this should be fairly simple, as it can be seen [in the code](https://hackage.haskell.org/package/mono-traversable-0.2.0.0/docs/src/Data-MonoTraversable.html#line-234)+ [](http://travis-ci.org/snoyberg/mono-traversable)
mono-traversable.cabal view
@@ -1,5 +1,5 @@ name: mono-traversable-version: 0.2.0.0+version: 0.3.0.0 synopsis: Type classes for mapping, folding, and traversing monomorphic containers description: Monomorphic variants of the Functor, Foldable, and Traversable typeclasses. Contains even more experimental code for abstracting containers and sequences. homepage: https://github.com/snoyberg/mono-traversable@@ -18,6 +18,8 @@ Data.MonoTraversable Data.Sequences Data.NonNull+ Data.MinLen+ other-modules: Data.GrowingAppend build-depends: base >= 4 && < 5 , containers >= 0.4 , unordered-containers >=0.2@@ -29,6 +31,7 @@ , vector >=0.10 , semigroupoids >=3.0 , comonad >=3.0.3+ , vector-instances hs-source-dirs: src default-language: Haskell2010 @@ -43,3 +46,13 @@ , bytestring , text , hspec+ , transformers+ , vector+ , QuickCheck+ , semigroups+ , containers+ , unordered-containers+ +source-repository head+ type: git+ location: git://github.com/snoyberg/mono-traversable.git
src/Data/Containers.hs view
@@ -2,15 +2,23 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-} -- | Warning: This module should be considered highly experimental. module Data.Containers where +import Prelude hiding (lookup)+import Data.Maybe (fromMaybe)+#if MIN_VERSION_containers(0, 5, 0)+import qualified Data.Map.Strict as Map+#else import qualified Data.Map as Map+#endif import qualified Data.HashMap.Strict as HashMap import Data.Hashable (Hashable) import qualified Data.Set as Set import qualified Data.HashSet as HashSet-import Data.Monoid (Monoid)+import Data.Monoid (Monoid (..))+import Data.Semigroup (Semigroup) import Data.MonoTraversable (MonoFunctor(..), MonoFoldable, MonoTraversable, Element) import qualified Data.IntMap as IntMap import Data.Function (on)@@ -23,7 +31,7 @@ import qualified Data.ByteString as ByteString import Control.Arrow ((***)) -class (Monoid set, MonoFoldable set) => SetContainer set where+class (Monoid set, Semigroup set, MonoFoldable set, Eq (ContainerKey set)) => SetContainer set where type ContainerKey set member :: ContainerKey set -> set -> Bool notMember :: ContainerKey set -> set -> Bool@@ -78,16 +86,54 @@ difference = IntSet.difference intersection = IntSet.intersection -instance Ord key => SetContainer [(key, value)] where+instance Eq key => SetContainer [(key, value)] where type ContainerKey [(key, value)] = key member k = List.any ((== k) . fst) notMember k = not . member k union = List.unionBy ((==) `on` fst)- x `difference` y = Map.toList (Map.fromList x `Map.difference` Map.fromList y)+ x `difference` y =+ loop x+ where+ loop [] = []+ loop ((k, v):rest) =+ case lookup k y of+ Nothing -> (k, v) : loop rest+ Just _ -> loop rest intersection = List.intersectBy ((==) `on` fst) +-- | A guaranteed-polymorphic @Map@, which allows for more polymorphic versions+-- of functions.+class PolyMap map where+ differenceMap :: map value1 -> map value2 -> map value1+ {-+ differenceWithMap :: (value1 -> value2 -> Maybe value1)+ -> map value1 -> map value2 -> map value1+ -}+ intersectionMap :: map value1 -> map value2 -> map value1+ intersectionWithMap :: (value1 -> value2 -> value3)+ -> map value1 -> map value2 -> map value3++instance Ord key => PolyMap (Map.Map key) where+ differenceMap = Map.difference+ --differenceWithMap = Map.differenceWith+ intersectionMap = Map.intersection+ intersectionWithMap = Map.intersectionWith++instance (Eq key, Hashable key) => PolyMap (HashMap.HashMap key) where+ differenceMap = HashMap.difference+ --differenceWithMap = HashMap.differenceWith+ intersectionMap = HashMap.intersection+ intersectionWithMap = HashMap.intersectionWith++instance PolyMap IntMap.IntMap where+ differenceMap = IntMap.difference+ --differenceWithMap = IntMap.differenceWith+ intersectionMap = IntMap.intersection+ intersectionWithMap = IntMap.intersectionWith+ class (MonoTraversable map, SetContainer map) => IsMap map where- -- | Using just @Element@ can lead to very confusing error messages.+ -- | In some cases, @MapValue@ and @Element@ will be different, e.g., the+ -- @IsMap@ instance of associated lists. type MapValue map lookup :: ContainerKey map -> map -> Maybe (MapValue map) insertMap :: ContainerKey map -> MapValue map -> map -> map@@ -96,6 +142,183 @@ mapFromList :: [(ContainerKey map, MapValue map)] -> map mapToList :: map -> [(ContainerKey map, MapValue map)] + findWithDefault :: MapValue map -> ContainerKey map -> map -> MapValue map+ findWithDefault def key = fromMaybe def . lookup key++ insertWith :: (MapValue map -> MapValue map -> MapValue map)+ -> ContainerKey map+ -> MapValue map+ -> map+ -> map+ insertWith f k v m =+ v' `seq` insertMap k v' m+ where+ v' =+ case lookup k m of+ Nothing -> v+ Just vold -> f v vold++ insertWithKey+ :: (ContainerKey map -> MapValue map -> MapValue map -> MapValue map)+ -> ContainerKey map+ -> MapValue map+ -> map+ -> map+ insertWithKey f k v m =+ v' `seq` insertMap k v' m+ where+ v' =+ case lookup k m of+ Nothing -> v+ Just vold -> f k v vold++ insertLookupWithKey+ :: (ContainerKey map -> MapValue map -> MapValue map -> MapValue map)+ -> ContainerKey map+ -> MapValue map+ -> map+ -> (Maybe (MapValue map), map)+ insertLookupWithKey f k v m =+ v' `seq` (mold, insertMap k v' m)+ where+ (mold, v') =+ case lookup k m of+ Nothing -> (Nothing, v)+ Just vold -> (Just vold, f k v vold)++ adjustMap+ :: (MapValue map -> MapValue map)+ -> ContainerKey map+ -> map+ -> map+ adjustMap f k m =+ case lookup k m of+ Nothing -> m+ Just v ->+ let v' = f v+ in v' `seq` insertMap k v' m++ adjustWithKey+ :: (ContainerKey map -> MapValue map -> MapValue map)+ -> ContainerKey map+ -> map+ -> map+ adjustWithKey f k m =+ case lookup k m of+ Nothing -> m+ Just v ->+ let v' = f k v+ in v' `seq` insertMap k v' m++ updateMap+ :: (MapValue map -> Maybe (MapValue map))+ -> ContainerKey map+ -> map+ -> map+ updateMap f k m =+ case lookup k m of+ Nothing -> m+ Just v ->+ case f v of+ Nothing -> deleteMap k m+ Just v' -> v' `seq` insertMap k v' m++ updateWithKey+ :: (ContainerKey map -> MapValue map -> Maybe (MapValue map))+ -> ContainerKey map+ -> map+ -> map+ updateWithKey f k m =+ case lookup k m of+ Nothing -> m+ Just v ->+ case f k v of+ Nothing -> deleteMap k m+ Just v' -> v' `seq` insertMap k v' m++ updateLookupWithKey+ :: (ContainerKey map -> MapValue map -> Maybe (MapValue map))+ -> ContainerKey map+ -> map+ -> (Maybe (MapValue map), map)+ updateLookupWithKey f k m =+ case lookup k m of+ Nothing -> (Nothing, m)+ Just v ->+ case f k v of+ Nothing -> (Just v, deleteMap k m)+ Just v' -> v' `seq` (Just v', insertMap k v' m)++ alterMap+ :: (Maybe (MapValue map) -> Maybe (MapValue map))+ -> ContainerKey map+ -> map+ -> map+ alterMap f k m =+ case f mold of+ Nothing ->+ case mold of+ Nothing -> m+ Just _ -> deleteMap k m+ Just v -> insertMap k v m+ where+ mold = lookup k m++ unionWith+ :: (MapValue map -> MapValue map -> MapValue map)+ -> map+ -> map+ -> map+ unionWith f x y =+ mapFromList $ loop $ mapToList x ++ mapToList y+ where+ loop [] = []+ loop ((k, v):rest) =+ case List.lookup k rest of+ Nothing -> (k, v) : loop rest+ Just v' -> (k, f v v') : loop (deleteMap k rest)++ unionWithKey+ :: (ContainerKey map -> MapValue map -> MapValue map -> MapValue map)+ -> map+ -> map+ -> map+ unionWithKey f x y =+ mapFromList $ loop $ mapToList x ++ mapToList y+ where+ loop [] = []+ loop ((k, v):rest) =+ case List.lookup k rest of+ Nothing -> (k, v) : loop rest+ Just v' -> (k, f k v v') : loop (deleteMap k rest)++ unionsWith+ :: (MapValue map -> MapValue map -> MapValue map)+ -> [map]+ -> map+ unionsWith _ [] = mempty+ unionsWith _ [x] = x+ unionsWith f (x:y:z) = unionsWith f (unionWith f x y:z)++ mapWithKey+ :: (ContainerKey map -> MapValue map -> MapValue map)+ -> map+ -> map+ mapWithKey f =+ mapFromList . map go . mapToList+ where+ go (k, v) = (k, f k v)++ mapKeysWith+ :: (MapValue map -> MapValue map -> MapValue map)+ -> (ContainerKey map -> ContainerKey map)+ -> map+ -> map+ mapKeysWith g f =+ mapFromList . unionsWith g . map go . mapToList+ where+ go (k, v) = [(f k, v)]+ instance Ord key => IsMap (Map.Map key value) where type MapValue (Map.Map key value) = value lookup = Map.lookup@@ -105,6 +328,22 @@ mapFromList = Map.fromList mapToList = Map.toList + findWithDefault = Map.findWithDefault+ insertWith = Map.insertWith+ insertWithKey = Map.insertWithKey+ insertLookupWithKey = Map.insertLookupWithKey+ adjustMap = Map.adjust+ adjustWithKey = Map.adjustWithKey+ updateMap = Map.update+ updateWithKey = Map.updateWithKey+ updateLookupWithKey = Map.updateLookupWithKey+ alterMap = Map.alter+ unionWith = Map.unionWith+ unionWithKey = Map.unionWithKey+ unionsWith = Map.unionsWith+ mapWithKey = Map.mapWithKey+ mapKeysWith = Map.mapKeysWith+ instance (Eq key, Hashable key) => IsMap (HashMap.HashMap key value) where type MapValue (HashMap.HashMap key value) = value lookup = HashMap.lookup@@ -114,6 +353,22 @@ mapFromList = HashMap.fromList mapToList = HashMap.toList + --findWithDefault = HashMap.findWithDefault+ insertWith = HashMap.insertWith+ --insertWithKey = HashMap.insertWithKey+ --insertLookupWithKey = HashMap.insertLookupWithKey+ adjustMap = HashMap.adjust+ --adjustWithKey = HashMap.adjustWithKey+ --updateMap = HashMap.update+ --updateWithKey = HashMap.updateWithKey+ --updateLookupWithKey = HashMap.updateLookupWithKey+ --alterMap = HashMap.alter+ unionWith = HashMap.unionWith+ --unionWithKey = HashMap.unionWithKey+ --unionsWith = HashMap.unionsWith+ --mapWithKey = HashMap.mapWithKey+ --mapKeysWith = HashMap.mapKeysWith+ instance IsMap (IntMap.IntMap value) where type MapValue (IntMap.IntMap value) = value lookup = IntMap.lookup@@ -123,7 +378,25 @@ mapFromList = IntMap.fromList mapToList = IntMap.toList -instance Ord key => IsMap [(key, value)] where+ findWithDefault = IntMap.findWithDefault+ insertWith = IntMap.insertWith+ insertWithKey = IntMap.insertWithKey+ insertLookupWithKey = IntMap.insertLookupWithKey+ adjustMap = IntMap.adjust+ adjustWithKey = IntMap.adjustWithKey+ updateMap = IntMap.update+ updateWithKey = IntMap.updateWithKey+ --updateLookupWithKey = IntMap.updateLookupWithKey+ alterMap = IntMap.alter+ unionWith = IntMap.unionWith+ unionWithKey = IntMap.unionWithKey+ unionsWith = IntMap.unionsWith+ mapWithKey = IntMap.mapWithKey+#if MIN_VERSION_containers(0, 5, 0)+ mapKeysWith = IntMap.mapKeysWith+#endif++instance Eq key => IsMap [(key, value)] where type MapValue [(key, value)] = value lookup = List.lookup insertMap k v = ((k, v):) . deleteMap k
+ src/Data/GrowingAppend.hs view
@@ -0,0 +1,41 @@+module Data.GrowingAppend where++import Data.MonoTraversable+import Data.Semigroup+import qualified Data.Sequence as Seq+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Storable as VS+import Data.Vector.Instances ()+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as Map+import qualified Data.HashMap.Strict as HashMap+import Data.Hashable (Hashable)+import qualified Data.Set as Set+import qualified Data.HashSet as HashSet+import qualified Data.IntSet as IntSet+import qualified Data.IntMap as IntMap++-- | olength (x <> y) >= olength x + olength y+class (Semigroup mono, MonoFoldable mono) => GrowingAppend mono++instance GrowingAppend (Seq.Seq a)+instance GrowingAppend [a]+instance GrowingAppend (V.Vector a)+instance U.Unbox a => GrowingAppend (U.Vector a)+instance VS.Storable a => GrowingAppend (VS.Vector a)+instance GrowingAppend S.ByteString+instance GrowingAppend L.ByteString+instance GrowingAppend T.Text+instance GrowingAppend TL.Text+instance GrowingAppend (NE.NonEmpty a)+instance Ord k => GrowingAppend (Map.Map k v)+instance (Eq k, Hashable k) => GrowingAppend (HashMap.HashMap k v)+instance Ord v => GrowingAppend (Set.Set v)+instance (Eq v, Hashable v) => GrowingAppend (HashSet.HashSet v)+instance GrowingAppend IntSet.IntSet+instance GrowingAppend (IntMap.IntMap v)
+ src/Data/MinLen.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+module Data.MinLen+ ( -- * Type level naturals+ Zero (..)+ , Succ (..)+ , TypeNat (..)+ -- * Minimum length newtype wrapper+ , MinLen+ , unMinLen+ , toMinLenZero+ , toMinLen+ , mlcons+ , mlappend+ , mlunion+ , head+ , last+ , tail+ , init+ , GrowingAppend+ ) where++import Prelude (Num (..), error, Maybe (..), Int, Ordering (..))+import Control.Category+import Data.MonoTraversable+import Data.Sequences+import Data.Monoid (Monoid (..))+import Data.Semigroup (Semigroup (..))+import Data.GrowingAppend++-- Type level naturals+data Zero = Zero+data Succ nat = Succ nat++class TypeNat nat where+ toValueNat :: Num i => nat -> i+instance TypeNat Zero where+ toValueNat Zero = 0+instance TypeNat nat => TypeNat (Succ nat) where+ toValueNat (Succ nat) = 1 + toValueNat nat++type family AddNat x y+type instance AddNat Zero y = y+type instance AddNat (Succ x) y = AddNat x (Succ y)++type family MaxNat x y+type instance MaxNat Zero y = y+type instance MaxNat x Zero = x+type instance MaxNat (Succ x) (Succ y) = Succ (MaxNat x y)++newtype MinLen nat mono = MinLen { unMinLen :: mono }++natProxy :: MinLen nat mono -> nat+natProxy = error "Data.MinLen.natProxy"++toMinLenZero :: mono -> MinLen Zero mono+toMinLenZero = MinLen++toMinLen :: (MonoFoldable mono, TypeNat nat) => mono -> Maybe (MinLen nat mono)+toMinLen mono =+ case ocompareLength mono (toValueNat nat :: Int) of+ LT -> Nothing+ _ -> Just res'+ where+ nat = natProxy res'+ res' = MinLen mono++mlcons :: IsSequence seq => Element seq -> MinLen nat seq -> MinLen (Succ nat) seq+mlcons e (MinLen seq) = MinLen (cons e seq)++mlappend :: IsSequence seq => MinLen x seq -> MinLen y seq -> MinLen (AddNat x y) seq+mlappend (MinLen x) (MinLen y) = MinLen (x `mappend` y)++head :: MonoTraversable mono => MinLen (Succ nat) mono -> Element mono+head = headEx . unMinLen++last :: MonoTraversable mono => MinLen (Succ nat) mono -> Element mono+last = lastEx . unMinLen++tail :: IsSequence seq => MinLen (Succ nat) seq -> MinLen nat seq+tail = MinLen . tailEx . unMinLen++init :: IsSequence seq => MinLen (Succ nat) seq -> MinLen nat seq+init = MinLen . initEx . unMinLen++instance GrowingAppend mono => Semigroup (MinLen nat mono) where+ MinLen x <> MinLen y = MinLen (x <> y)++mlunion :: GrowingAppend mono => MinLen x mono -> MinLen y mono -> MinLen (MaxNat x y) mono+mlunion (MinLen x) (MinLen y) = MinLen (x <> y)
src/Data/MonoTraversable.hs view
@@ -37,11 +37,19 @@ import Data.Word (Word8) import Data.Int (Int, Int64) import GHC.Exts (build)-import Prelude (Bool (..), const, Char, flip, ($), IO, Maybe, Either,- replicate, (+), Integral, Ordering (..), compare, fromIntegral, Num)+import Prelude (Bool (..), const, Char, flip, ($), IO, Maybe (..), Either (..),+ replicate, (+), Integral, Ordering (..), compare, fromIntegral, Num, (>=),+ seq, otherwise, maybe, Ord, (-))+import qualified Prelude+import qualified Data.ByteString.Internal as Unsafe+import qualified Foreign.ForeignPtr.Unsafe as Unsafe+import Foreign.Ptr (plusPtr)+import Foreign.ForeignPtr (touchForeignPtr)+import Foreign.Storable (peek) import Control.Arrow (Arrow) import Data.Tree (Tree) import Data.Sequence (Seq, ViewL, ViewR)+import qualified Data.Sequence as Seq import Data.IntMap (IntMap) import Data.IntSet (IntSet) import Data.Semigroup (Option)@@ -69,9 +77,12 @@ import Data.Semigroupoid.Static (Static) import Data.Set (Set) import Data.HashSet (HashSet)+import qualified Data.Vector as V import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Storable as VS import qualified Data.IntSet as IntSet+import Data.Semigroup (Semigroup, Option (..))+import qualified Data.ByteString.Unsafe as SU type family Element mono type instance Element S.ByteString = Word8@@ -226,11 +237,47 @@ oforM_ :: (MonoFoldable mono, Monad m) => mono -> (Element mono -> m b) -> m () oforM_ = flip omapM_+ {-# INLINE oforM_ #-} ofoldlM :: (MonoFoldable mono, Monad m) => (a -> Element mono -> m a) -> a -> mono -> m a ofoldlM f z0 xs = ofoldr f' return xs z0 where f' x k z = f z x >>= k- ++ -- | Note: this is a partial function. On an empty @MonoFoldable@, it will+ -- throw an exception. See "Data.NonNull" for a total version of this+ -- function.+ ofoldMap1Ex :: Semigroup m => (Element mono -> m) -> mono -> m+ ofoldMap1Ex f = maybe (Prelude.error "Data.MonoTraversable.ofoldMap1Ex") id+ . getOption . ofoldMap (Option . Just . f)++ -- | Note: this is a partial function. On an empty @MonoFoldable@, it will+ -- throw an exception. See "Data.NonNull" for a total version of this+ -- function.+ ofoldr1Ex :: (Element mono -> Element mono -> Element mono) -> mono -> Element mono+ default ofoldr1Ex :: (t a ~ mono, a ~ Element (t a), F.Foldable t)+ => (a -> a -> a) -> mono -> a+ ofoldr1Ex = F.foldr1++ -- | Note: this is a partial function. On an empty @MonoFoldable@, it will+ -- throw an exception. See "Data.NonNull" for a total version of this+ -- function.+ ofoldl1Ex' :: (Element mono -> Element mono -> Element mono) -> mono -> Element mono+ default ofoldl1Ex' :: (t a ~ mono, a ~ Element (t a), F.Foldable t)+ => (a -> a -> a) -> mono -> a+ ofoldl1Ex' = F.foldl1++ headEx :: mono -> Element mono+ headEx = ofoldr1Ex const++ lastEx :: mono -> Element mono+ lastEx = ofoldl1Ex' (flip const)++ unsafeHead :: mono -> Element mono+ unsafeHead = headEx++ unsafeLast :: mono -> Element mono+ unsafeLast = lastEx+ instance MonoFoldable S.ByteString where ofoldMap f = ofoldr (mappend . f) mempty ofoldr = S.foldr@@ -240,6 +287,22 @@ oany = S.any onull = S.null olength = S.length++ omapM_ f (Unsafe.PS fptr offset len) = do+ let start = Unsafe.unsafeForeignPtrToPtr fptr `plusPtr` offset+ end = start `plusPtr` len+ loop ptr+ | ptr >= end = Unsafe.inlinePerformIO (touchForeignPtr fptr) `seq` return ()+ | otherwise = do+ _ <- f (Unsafe.inlinePerformIO (peek ptr))+ loop (ptr `plusPtr` 1)+ loop start+ {-# INLINE omapM_ #-}+ ofoldr1Ex = S.foldr1+ ofoldl1Ex' = S.foldl1'+ headEx = S.head+ lastEx = S.last+ unsafeHead = SU.unsafeHead instance MonoFoldable L.ByteString where ofoldMap f = ofoldr (mappend . f) mempty ofoldr = L.foldr@@ -249,6 +312,12 @@ oany = L.any onull = L.null olength64 = L.length+ omapM_ f = omapM_ (omapM_ f) . L.toChunks+ {-# INLINE omapM_ #-}+ ofoldr1Ex = L.foldr1+ ofoldl1Ex' = L.foldl1'+ headEx = L.head+ lastEx = L.last instance MonoFoldable T.Text where ofoldMap f = ofoldr (mappend . f) mempty ofoldr = T.foldr@@ -258,6 +327,10 @@ oany = T.any onull = T.null olength = T.length+ ofoldr1Ex = T.foldr1+ ofoldl1Ex' = T.foldl1'+ headEx = T.head+ lastEx = T.last instance MonoFoldable TL.Text where ofoldMap f = ofoldr (mappend . f) mempty ofoldr = TL.foldr@@ -267,6 +340,10 @@ oany = TL.any onull = TL.null olength64 = TL.length+ ofoldr1Ex = TL.foldr1+ ofoldl1Ex' = TL.foldl1'+ headEx = TL.head+ lastEx = TL.last instance MonoFoldable IntSet where ofoldMap f = ofoldr (mappend . f) mempty ofoldr = IntSet.foldr@@ -274,12 +351,16 @@ otoList = IntSet.toList onull = IntSet.null olength = IntSet.size+ ofoldr1Ex f = ofoldr1Ex f . IntSet.toList+ ofoldl1Ex' f = ofoldl1Ex' f . IntSet.toList instance MonoFoldable [a] where otoList = id {-# INLINE otoList #-} instance MonoFoldable (Maybe a) instance MonoFoldable (Tree a)-instance MonoFoldable (Seq a)+instance MonoFoldable (Seq a) where+ headEx = flip Seq.index 1+ lastEx xs = Seq.index xs (Seq.length xs - 1) instance MonoFoldable (ViewL a) instance MonoFoldable (ViewR a) instance MonoFoldable (IntMap a)@@ -288,7 +369,20 @@ instance MonoFoldable (Identity a) instance MonoFoldable (Map k v) instance MonoFoldable (HashMap k v)-instance MonoFoldable (Vector a)+instance MonoFoldable (Vector a) where+ ofoldr = V.foldr+ ofoldl' = V.foldl'+ otoList = V.toList+ oall = V.all+ oany = V.any+ onull = V.null+ olength = V.length+ ofoldr1Ex = V.foldr1+ ofoldl1Ex' = V.foldl1'+ headEx = V.head+ lastEx = V.last+ unsafeHead = V.unsafeHead+ unsafeLast = V.unsafeLast instance MonoFoldable (Set e) instance MonoFoldable (HashSet e) instance U.Unbox a => MonoFoldable (U.Vector a) where@@ -300,6 +394,12 @@ oany = U.any onull = U.null olength = U.length+ ofoldr1Ex = U.foldr1+ ofoldl1Ex' = U.foldl1'+ headEx = U.head+ lastEx = U.last+ unsafeHead = U.unsafeHead+ unsafeLast = U.unsafeLast instance VS.Storable a => MonoFoldable (VS.Vector a) where ofoldMap f = ofoldr (mappend . f) mempty ofoldr = VS.foldr@@ -309,7 +409,45 @@ oany = VS.any onull = VS.null olength = VS.length+ ofoldr1Ex = VS.foldr1+ ofoldl1Ex' = VS.foldl1'+ headEx = VS.head+ lastEx = VS.last+ unsafeHead = VS.unsafeHead+ unsafeLast = VS.unsafeLast+instance MonoFoldable (Either a b) where+ ofoldMap f = ofoldr (mappend . f) mempty+ ofoldr f b (Right a) = f a b+ ofoldr _ b (Left _) = b+ ofoldl' f a (Right b) = f a b+ ofoldl' _ a (Left _) = a+ otoList (Left _) = []+ otoList (Right b) = [b]+ oall _ (Left _) = True+ oall f (Right b) = f b+ oany _ (Left _) = False+ oany f (Right b) = f b+ onull (Left _) = True+ onull (Right _) = False+ olength (Left _) = 0+ olength (Right _) = 1+ ofoldr1Ex _ (Left _) = Prelude.error "ofoldr1Ex on Either"+ ofoldr1Ex _ (Right x) = x+ ofoldl1Ex' _ (Left _) = Prelude.error "ofoldl1Ex' on Either"+ ofoldl1Ex' _ (Right x) = x +-- | like Data.List.head, but not partial+headMay :: MonoFoldable mono => mono -> Maybe (Element mono)+headMay mono+ | onull mono = Nothing+ | otherwise = Just (headEx mono)++-- | like Data.List.last, but not partial+lastMay :: MonoFoldable mono => mono -> Maybe (Element mono)+lastMay mono+ | onull mono = Nothing+ | otherwise = Just (lastEx mono)+ -- | The 'sum' function computes the sum of the numbers of a structure. osum :: (MonoFoldable mono, Num (Element mono)) => mono -> Element mono osum = getSum . ofoldMap Sum@@ -318,7 +456,7 @@ oproduct :: (MonoFoldable mono, Num (Element mono)) => mono -> Element mono oproduct = Data.Monoid.getProduct . ofoldMap Data.Monoid.Product -class (MonoFoldable mono, Monoid mono) => MonoFoldableMonoid mono where+class (MonoFoldable mono, Monoid mono) => MonoFoldableMonoid mono where -- FIXME is this really just MonoMonad? oconcatMap :: (Element mono -> mono) -> mono -> mono oconcatMap = ofoldMap instance (MonoFoldable (t a), Monoid (t a)) => MonoFoldableMonoid (t a) -- FIXME@@ -331,6 +469,111 @@ instance MonoFoldableMonoid TL.Text where oconcatMap = TL.concatMap +-- | A typeclass for @MonoFoldable@s containing elements which are an instance+-- of @Ord@.+class (MonoFoldable mono, Ord (Element mono)) => MonoFoldableOrd mono where+ maximumEx :: mono -> Element mono+ maximumEx = maximumByEx compare++ maximumByEx :: (Element mono -> Element mono -> Ordering) -> mono -> Element mono+ maximumByEx f =+ ofoldl1Ex' go+ where+ go x y =+ case f x y of+ LT -> y+ _ -> x++ minimumEx :: mono -> Element mono+ minimumEx = minimumByEx compare++ minimumByEx :: (Element mono -> Element mono -> Ordering) -> mono -> Element mono+ minimumByEx f =+ ofoldl1Ex' go+ where+ go x y =+ case f x y of+ GT -> y+ _ -> x++instance MonoFoldableOrd S.ByteString where+ maximumEx = S.maximum+ {-# INLINE maximumEx #-}+ minimumEx = S.minimum+ {-# INLINE minimumEx #-}+instance MonoFoldableOrd L.ByteString where+ maximumEx = L.maximum+ {-# INLINE maximumEx #-}+ minimumEx = L.minimum+ {-# INLINE minimumEx #-}+instance MonoFoldableOrd T.Text where+ maximumEx = T.maximum+ {-# INLINE maximumEx #-}+ minimumEx = T.minimum+ {-# INLINE minimumEx #-}+instance MonoFoldableOrd TL.Text where+ maximumEx = TL.maximum+ {-# INLINE maximumEx #-}+ minimumEx = TL.minimum+ {-# INLINE minimumEx #-}+instance MonoFoldableOrd IntSet+instance Ord a => MonoFoldableOrd [a]+instance Ord a => MonoFoldableOrd (Maybe a)+instance Ord a => MonoFoldableOrd (Tree a)+instance Ord a => MonoFoldableOrd (Seq a)+instance Ord a => MonoFoldableOrd (ViewL a)+instance Ord a => MonoFoldableOrd (ViewR a)+instance Ord a => MonoFoldableOrd (IntMap a)+instance Ord a => MonoFoldableOrd (Option a)+instance Ord a => MonoFoldableOrd (NonEmpty a)+instance Ord a => MonoFoldableOrd (Identity a)+instance Ord v => MonoFoldableOrd (Map k v)+instance Ord v => MonoFoldableOrd (HashMap k v)+instance Ord a => MonoFoldableOrd (Vector a) where+ maximumEx = V.maximum+ maximumByEx = V.maximumBy+ minimumEx = V.minimum+ minimumByEx = V.minimumBy+instance Ord e => MonoFoldableOrd (Set e)+instance Ord e => MonoFoldableOrd (HashSet e)+instance (U.Unbox a, Ord a) => MonoFoldableOrd (U.Vector a) where+ maximumEx = U.maximum+ maximumByEx = U.maximumBy+ minimumEx = U.minimum+ minimumByEx = U.minimumBy+instance (Ord a, VS.Storable a) => MonoFoldableOrd (VS.Vector a) where+ maximumEx = VS.maximum+ maximumByEx = VS.maximumBy+ minimumEx = VS.minimum+ minimumByEx = VS.minimumBy+instance Ord b => MonoFoldableOrd (Either a b) where++maximumMay :: MonoFoldableOrd mono => mono -> Maybe (Element mono)+maximumMay mono+ | onull mono = Nothing+ | otherwise = Just (maximumEx mono)++maximumByMay :: MonoFoldableOrd mono+ => (Element mono -> Element mono -> Ordering)+ -> mono+ -> Maybe (Element mono)+maximumByMay f mono+ | onull mono = Nothing+ | otherwise = Just (maximumByEx f mono)++minimumMay :: MonoFoldableOrd mono => mono -> Maybe (Element mono)+minimumMay mono+ | onull mono = Nothing+ | otherwise = Just (minimumEx mono)++minimumByMay :: MonoFoldableOrd mono+ => (Element mono -> Element mono -> Ordering)+ -> mono+ -> Maybe (Element mono)+minimumByMay f mono+ | onull mono = Nothing+ | otherwise = Just (minimumByEx f mono)+ class (MonoFunctor mono, MonoFoldable mono) => MonoTraversable mono where otraverse :: Applicative f => (Element mono -> f (Element mono)) -> mono -> f mono default otraverse :: (Traversable t, mono ~ t a, a ~ Element mono, Applicative f) => (Element mono -> f (Element mono)) -> mono -> f mono@@ -369,6 +612,11 @@ instance VS.Storable a => MonoTraversable (VS.Vector a) where otraverse f = fmap VS.fromList . traverse f . VS.toList omapM = VS.mapM+instance MonoTraversable (Either a b) where+ otraverse _ (Left a) = pure (Left a)+ otraverse f (Right b) = fmap Right (f b)+ omapM _ (Left a) = return (Left a)+ omapM f (Right b) = liftM Right (f b) ofor :: (MonoTraversable mono, Applicative f) => mono -> (Element mono -> f (Element mono)) -> f mono ofor = flip otraverse
src/Data/NonNull.hs view
@@ -8,49 +8,52 @@ -- | Warning, this is Experimental! -- -- Data.NonNull attempts to extend the concepts from--- 'Data.List.NonEmpty' to any 'IsSequence'.------ 'NonNull' is for a sequence with 1 or more elements.--- 'Stream' is for a 'NonNull' that supports efficient--- modification of the front of the sequence.+-- 'Data.List.NonEmpty' to any 'MonoFoldable'. ----- This code is experimental and likely to change dramatically and future versions.--- Please send your feedback.+-- 'NonNull' is a typeclass for a container with 1 or more elements.+-- 'Data.List.NonEmpty' and 'NotEmpty a' are members of the typeclass module Data.NonNull ( NonNull(..)- , SafeSequence(..)+ , fromNonEmpty+ , ncons+ , nuncons+ , splitFirst+ , nfilter+ , nfilterM+ , nReplicate+ , head+ , tail+ , last+ , init , NotEmpty- , MonoFoldable1(..)- , OrdNonNull(..)+ , asNotEmpty+ , ofoldMap1+ , ofold1+ , ofoldr1+ , ofoldl1'+ , maximum+ , maximumBy+ , minimum+ , minimumBy , (<|) ) where -import Prelude hiding (head, tail, init, last, reverse, seq, filter, replicate)+import Prelude hiding (head, tail, init, last, reverse, seq, filter, replicate, maximum, minimum) import Data.MonoTraversable import Data.Sequences import Control.Exception.Base (Exception, throw) import Data.Semigroup import qualified Data.Monoid as Monoid import Data.Data-import Data.Maybe (fromMaybe) import qualified Data.List.NonEmpty as NE-import qualified Data.Foldable as F -import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Vector as V-import qualified Data.Vector.Unboxed as U-import qualified Data.Vector.Storable as VS-import qualified Data.Sequence as Seq- data NullError = NullError String deriving (Show, Typeable) instance Exception NullError --- | a 'NonNull' sequence has 1 or more items--- In contrast, 'IsSequence' is allowed to have zero items.+-- | a 'NonNull' has 1 or more items --+-- In contrast, 'MonoFoldable' is allowed to have zero items.+-- -- Any NonNull functions that -- decreases the number of elements in the sequences -- will return a different 'Nullable' type.@@ -63,19 +66,16 @@ -- With NonNull rather than always reacting with null checks we can proactively encode in our program when we know that a type is NonNull. -- Now we have an invariant encoded in our types, making our program easier to understand. -- This information is leveraged to avoid awkward null checking later on.-class (SemiSequence seq, IsSequence (Nullable seq), Element seq ~ Element (Nullable seq)) => NonNull seq where- type Nullable seq-- -- | safely construct a 'NonNull' sequence from a 'NonEmpty' list- fromNonEmpty :: NE.NonEmpty (Element seq) -> seq+class (MonoFoldable mono, MonoFoldable (Nullable mono), Element mono ~ Element (Nullable mono)) => NonNull mono where+ type Nullable mono -- | safely convert a 'Nullable' to a 'NonNull'- fromNullable :: Nullable seq -> Maybe seq+ fromNullable :: Nullable mono -> Maybe mono -- | convert a 'Nullable' with elements to a 'NonNull' -- throw an exception if the 'Nullable' is empty. -- do not use this unless you have proved your structure is non-null- nonNull :: Nullable seq -> seq+ nonNull :: Nullable mono -> mono nonNull nullable = case fromNullable nullable of Nothing -> throw $ NullError "Data.NonNull.nonNull (NonNull default): expected non-null" Just xs -> xs@@ -86,68 +86,88 @@ -- nonNullUnsafe :: Nullable seq -> seq -- | convert a 'NonNull' to a 'Nullable'- toNullable :: seq -> Nullable seq+ toNullable :: mono -> Nullable mono - -- | Like cons, prepends an element.- -- However, the prepend is to a Nullable, creating a 'NonNull'- --- -- Generally this uses cons underneath.- -- cons is not efficient for most data structures.- --- -- Alternatives:- -- * if you don't need to cons, use 'fromNullable' or 'nonNull' if you can create your structure in one go.- -- * if you need to cons, you might be able to start off with an efficient data structure such as a 'NonEmpty' List.- -- 'fronNonEmpty' will convert that to your data structure using the structure's fromList function.- ncons :: Element seq -> Nullable seq -> seq+-- | safely construct a 'NonNull' from a 'NonEmpty' list+fromNonEmpty :: (NonNull seq, IsSequence (Nullable seq)) => NE.NonEmpty (Element seq) -> seq+fromNonEmpty = nonNull . fromList . NE.toList+{-# INLINE fromNonEmpty #-} - -- | like 'uncons' of 'SemiSequence'- nuncons :: seq -> (Element seq, Maybe seq)- nuncons xs = case uncons $ toNullable xs of- Nothing -> error "Data.NonNull.nuncons: data structure is null, it should be non-null"- Just (x, xsNullable) -> (x, fromNullable xsNullable)+-- | Like cons, prepends an element.+-- However, the prepend is to a Nullable, creating a 'NonNull'+--+-- Generally this uses cons underneath.+-- cons is not efficient for most data structures.+--+-- Alternatives:+-- * if you don't need to cons, use 'fromNullable' or 'nonNull' if you can create your structure in one go.+-- * if you need to cons, you might be able to start off with an efficient data structure such as a 'NonEmpty' List.+-- 'fronNonEmpty' will convert that to your data structure using the structure's fromList function.+ncons :: (NonNull seq, SemiSequence (Nullable seq)) => Element seq -> Nullable seq -> seq+ncons x xs = nonNull $ cons x xs - -- | like 'uncons' of 'SemiSequence'- splitFirst :: seq -> (Element seq, Nullable seq)- splitFirst xs = case uncons $ toNullable xs of- Nothing -> error "Data.NonNull.splitFirst: data structure is null, it should be non-null"- Just tup -> tup+-- | like 'uncons' of 'SemiSequence'+nuncons :: (NonNull seq, IsSequence (Nullable seq)) => seq -> (Element seq, Maybe seq)+nuncons xs = case uncons $ toNullable xs of+ Nothing -> error "Data.NonNull.nuncons: data structure is null, it should be non-null"+ Just (x, xsNullable) -> (x, fromNullable xsNullable) +-- | like 'uncons' of 'SemiSequence'+splitFirst :: (IsSequence (Nullable seq), NonNull seq) => seq -> (Element seq, Nullable seq)+splitFirst xs = case uncons $ toNullable xs of+ Nothing -> error "Data.NonNull.splitFirst: data structure is null, it should be non-null"+ Just tup -> tup - -- | like 'Sequence.filter', but starts with a NonNull- nfilter :: (Element seq -> Bool) -> seq -> Nullable seq - -- | like 'Sequence.filterM', but starts with a NonNull- nfilterM :: Monad m => (Element seq -> m Bool) -> seq -> m (Nullable seq)+-- | like 'Sequence.filter', but starts with a NonNull+nfilter :: (NonNull seq, IsSequence (Nullable seq))+ => (Element seq -> Bool) -> seq -> Nullable seq+nfilter f = filter f . toNullable - -- | i must be > 0. like 'Sequence.replicate'- nReplicate :: Index seq -> Element seq -> seq+-- | like 'Sequence.filterM', but starts with a NonNull+nfilterM :: (NonNull seq, Monad m, IsSequence (Nullable seq))+ => (Element seq -> m Bool) -> seq -> m (Nullable seq)+nfilterM f = filterM f . toNullable +-- | i must be > 0. like 'Sequence.replicate'+--+-- i <= 0 is treated the same as providing 1+nReplicate :: (NonNull seq, Num (Index (Nullable seq)), Ord (Index (Nullable seq)), IsSequence (Nullable seq))+ => Index (Nullable seq) -> Element seq -> seq+nReplicate i = nonNull . replicate (max 1 i)+ {- maybeToNullable :: (Monoid (Nullable seq), NonNull seq) => Maybe seq -> Nullable seq maybeToNullable Nothing = mempty maybeToNullable (Just xs) = toNullable xs -} --- | SafeSequence contains functions that would be partial on a 'Nullable'-class SafeSequence seq where- -- | like Data.List, but not partial on a NonEmpty- head :: seq -> Element seq- -- | like Data.List, but not partial on a NonEmpty- tail :: seq -> Nullable seq- -- | like Data.List, but not partial on a NonEmpty- last :: seq -> Element seq- -- | like Data.List, but not partial on a NonEmpty- init :: seq -> Nullable seq+-- | like Data.List, but not partial on a NonEmpty+head :: (MonoFoldable (Nullable seq), NonNull seq) => seq -> Element seq+head = headEx . toNullable+{-# INLINE head #-} +-- | like Data.List, but not partial on a NonEmpty+tail :: (IsSequence (Nullable seq), NonNull seq) => seq -> Nullable seq+tail = tailEx . toNullable+{-# INLINE tail #-} +-- | like Data.List, but not partial on a NonEmpty+last :: (MonoFoldable (Nullable seq), NonNull seq) => seq -> Element seq+last = lastEx . toNullable+{-# INLINE last #-} +-- | like Data.List, but not partial on a NonEmpty+init :: (IsSequence (Nullable seq), NonNull seq) => seq -> Nullable seq+init = initEx . toNullable+{-# INLINE init #-} ++ -- | NonNull list reuses 'Data.List.NonEmpty' instance NonNull (NE.NonEmpty a) where type Nullable (NE.NonEmpty a) = [a] - fromNonEmpty = id- {-# INLINE fromNonEmpty #-} fromNullable = NE.nonEmpty nonNull = NE.fromList@@ -155,23 +175,7 @@ toNullable = NE.toList - ncons = (NE.:|) - nfilter = NE.filter- nfilterM f = filterM f . toNullable-- nReplicate i x = NE.unfold unfold i- where- unfold countdown | countdown < 1 = (x, Nothing)- | otherwise = (x, Just (countdown - 1))--instance SafeSequence (NE.NonEmpty a) where- head = NE.head- tail = NE.tail- last = NE.last- init = NE.init-- -- | a newtype wrapper indicating there are 1 or more elements -- unwrap with 'toNullable' newtype NotEmpty seq = NotEmpty { fromNotEmpty :: seq }@@ -181,6 +185,13 @@ deriving instance MonoFoldable seq => MonoFoldable (NotEmpty seq) deriving instance MonoTraversable seq => MonoTraversable (NotEmpty seq) +-- | Helper functions for type inferences.+--+-- Since 0.3.0+asNotEmpty :: NotEmpty a -> NotEmpty a+asNotEmpty = id+{-# INLINE asNotEmpty #-}+ instance Monoid seq => Semigroup (NotEmpty seq) where x <> y = NotEmpty (fromNotEmpty x `Monoid.mappend` fromNotEmpty y) sconcat = NotEmpty . Monoid.mconcat . fmap fromNotEmpty . NE.toList@@ -200,11 +211,10 @@ -- normally we favor defaulting, should we use it here?--- this re-uses IsSequence functions and IsSequence uses defaulting-instance IsSequence seq => NonNull (NotEmpty seq) where+-- this re-uses MonoFoldable functions and MonoFoldable uses defaulting+instance MonoFoldable seq => NonNull (NotEmpty seq) where type Nullable (NotEmpty seq) = seq - fromNonEmpty = NotEmpty . fromList . NE.toList fromNullable xs | onull xs = Nothing | otherwise = Just $ NotEmpty xs @@ -213,142 +223,53 @@ -- nonNullUnsafe = NotEmpty toNullable = fromNotEmpty- ncons x xs = NotEmpty $ cons x xs - -- | i must be > 0. like 'Sequence.replicate'- -- < 0 produces a 1 element NonEmpty- nReplicate i x | i < 1 = ncons x mempty- | otherwise = NotEmpty $ replicate i x-- nfilter f = filter f . toNullable- nfilterM f = filterM f . toNullable---instance SafeSequence (NotEmpty (Seq.Seq a)) where- head = flip Seq.index 1 . fromNotEmpty- last (NotEmpty xs) = Seq.index xs (Seq.length xs - 1)- tail = Seq.drop 1 . fromNotEmpty- init (NotEmpty xs) = Seq.take (Seq.length xs - 1) xs--instance SafeSequence (NotEmpty (V.Vector a)) where- head = V.head . fromNotEmpty- tail = V.tail . fromNotEmpty- last = V.last . fromNotEmpty- init = V.init . fromNotEmpty--instance U.Unbox a => SafeSequence (NotEmpty (U.Vector a)) where- head = U.head . fromNotEmpty- tail = U.tail . fromNotEmpty- last = U.last . fromNotEmpty- init = U.init . fromNotEmpty--instance VS.Storable a => SafeSequence (NotEmpty (VS.Vector a)) where- head = VS.head . fromNotEmpty- tail = VS.tail . fromNotEmpty- last = VS.last . fromNotEmpty- init = VS.init . fromNotEmpty--instance SafeSequence (NotEmpty S.ByteString) where- head = S.head . fromNotEmpty- tail = S.tail . fromNotEmpty- last = S.last . fromNotEmpty- init = S.init . fromNotEmpty--instance SafeSequence (NotEmpty T.Text) where- head = T.head . fromNotEmpty- tail = T.tail . fromNotEmpty- last = T.last . fromNotEmpty- init = T.init . fromNotEmpty--instance SafeSequence (NotEmpty L.ByteString) where- head = L.head . fromNotEmpty- tail = L.tail . fromNotEmpty- last = L.last . fromNotEmpty- init = L.init . fromNotEmpty--instance SafeSequence (NotEmpty TL.Text) where- head = TL.head . fromNotEmpty- tail = TL.tail . fromNotEmpty- last = TL.last . fromNotEmpty- init = TL.init . fromNotEmpty- infixr 5 <| -- | Prepend an element to a NonNull-(<|) :: NonNull seq => Element seq -> seq -> seq-(<|) = cons----- | fold operations that assume one or more elements--- Guaranteed to be safe on a NonNull-class (NonNull seq, MonoFoldable (Nullable seq)) => MonoFoldable1 seq where- ofoldMap1 :: Semigroup m => (Element seq -> m) -> seq -> m- ofoldMap1 f = maybe (error "Data.NonNull.foldMap1 (MonoFoldable1)") id . getOption . ofoldMap (Option . Just . f) . toNullable-- -- ofold1 :: (Semigroup m ~ Element seq) => seq -> Element seq- -- ofold1 = ofoldMap1 id-- -- @'foldr1' f = 'Prelude.foldr1' f . 'otoList'@- ofoldr1 :: (Element seq -> Element seq -> Element seq) -> seq -> Element seq- ofoldr1 f = fromMaybe (error "Data.NonNull.foldr1 (MonoFoldable1): empty structure") .- (ofoldr mf Nothing) . toNullable- where- mf x Nothing = Just x- mf x (Just y) = Just (f x y)-- -- | A variant of 'ofoldl\'' that has no base case,- -- and thus may only be applied to non-empty structures.- --- -- @'foldl1\'' f = 'Prelude.foldl1' f . 'otoList'@- ofoldl1' :: (Element seq -> Element seq -> Element seq) -> seq -> Element seq- ofoldl1' f = fromMaybe (error "ofoldl1': empty structure") .- (ofoldl' mf Nothing) . toNullable- where- mf Nothing y = Just y- mf (Just x) y = Just (f x y)+(<|) :: (SemiSequence (Nullable seq), NonNull seq) => Element seq -> seq -> seq+x <| y = ncons x (toNullable y) -instance MonoFoldable1 (NE.NonEmpty a)--- normally we favor defaulting, should we be using it here?-instance (MonoFoldable mono, IsSequence mono) => MonoFoldable1 (NotEmpty mono)+ofoldMap1 :: (NonNull seq, Semigroup m) => (Element seq -> m) -> seq -> m+ofoldMap1 f = ofoldMap1Ex f . toNullable+{-# INLINE ofoldMap1 #-} +ofold1 :: (NonNull seq, Semigroup (Element seq)) => seq -> Element seq+ofold1 = ofoldMap1 id+{-# INLINE ofold1 #-} -class (MonoFoldable1 seq, OrdSequence (Nullable seq)) => OrdNonNull seq where- -- | like Data.List, but not partial on a NonNull- maximum :: seq -> Element seq- default maximum :: (MonoFoldable1 seq) => seq -> Element seq- maximum = ofoldr1 max+-- @'foldr1' f = 'Prelude.foldr1' f . 'otoList'@+ofoldr1 :: NonNull seq => (Element seq -> Element seq -> Element seq) -> seq -> Element seq+ofoldr1 f = ofoldr1Ex f . toNullable+{-# INLINE ofoldr1 #-} - -- | like Data.List, but not partial on a NonNull- minimum :: seq -> Element seq- default minimum :: (MonoFoldable1 seq, Element (Nullable seq) ~ Element seq) => seq -> Element seq- minimum = ofoldr1 min+-- | A variant of 'ofoldl\'' that has no base case,+-- and thus may only be applied to non-empty structures.+--+-- @'foldl1\'' f = 'Prelude.foldl1' f . 'otoList'@+ofoldl1' :: NonNull seq => (Element seq -> Element seq -> Element seq) -> seq -> Element seq+ofoldl1' f = ofoldl1Ex' f . toNullable+{-# INLINE ofoldl1' #-} - -- | like Data.List, but not partial on a NonNull- maximumBy :: (Element seq -> Element seq -> Ordering) -> seq -> Element seq- default maximumBy :: (MonoFoldable1 seq) => (Element seq -> Element seq -> Ordering) -> seq -> Element seq- maximumBy cmp = ofoldr1 max'- where max' x y = case cmp x y of- GT -> x- _ -> y+-- | like Data.List, but not partial on a NonNull+maximum :: (MonoFoldableOrd (Nullable seq), NonNull seq) => seq -> Element seq+maximum = maximumEx . toNullable+{-# INLINE maximum #-} - -- | like Data.List, but not partial on a NonNull- minimumBy :: (Element seq -> Element seq -> Ordering) -> seq -> Element seq- default minimumBy :: (MonoFoldable1 seq) => (Element seq -> Element seq -> Ordering) -> seq -> Element seq- minimumBy cmp = ofoldr1 min'- where min' x y = case cmp x y of- GT -> y- _ -> x+-- | like Data.List, but not partial on a NonNull+minimum :: (MonoFoldableOrd (Nullable seq), NonNull seq) => seq -> Element seq+minimum = minimumEx . toNullable+{-# INLINE minimum #-} -instance Ord a => OrdNonNull (NE.NonEmpty a) where- maximum = F.maximum- minimum = F.minimum- maximumBy = F.maximumBy- minimumBy = F.minimumBy+-- | like Data.List, but not partial on a NonNull+maximumBy :: (MonoFoldableOrd (Nullable seq), NonNull seq)+ => (Element seq -> Element seq -> Ordering) -> seq -> Element seq+maximumBy cmp = maximumByEx cmp . toNullable+{-# INLINE maximumBy #-} -instance Ord a => OrdNonNull (NotEmpty (Seq.Seq a))-instance Ord a => OrdNonNull (NotEmpty (V.Vector a))-instance OrdNonNull (NotEmpty (S.ByteString))-instance OrdNonNull (NotEmpty (L.ByteString))-instance OrdNonNull (NotEmpty (T.Text))-instance OrdNonNull (NotEmpty (TL.Text))+-- | like Data.List, but not partial on a NonNull+minimumBy :: (MonoFoldableOrd (Nullable seq), NonNull seq)+ => (Element seq -> Element seq -> Ordering) -> seq -> Element seq+minimumBy cmp = minimumByEx cmp . toNullable+{-# INLINE minimumBy #-}
src/Data/Sequences.hs view
@@ -11,7 +11,7 @@ import Data.Int (Int64, Int) import qualified Data.List as List import qualified Control.Monad (filterM, replicateM)-import Prelude (Bool (..), Monad (..), Maybe (..), Ordering (..), Ord (..), Eq (..), Functor (..), fromIntegral, otherwise, (-), not, fst, snd, Integral, ($), flip)+import Prelude (Bool (..), Monad (..), Maybe (..), Ordering (..), Ord (..), Eq (..), Functor (..), fromIntegral, otherwise, (-), not, fst, snd, Integral, ($), flip, maybe, error) import Data.Char (Char, isSpace) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L@@ -26,6 +26,7 @@ import qualified Data.Vector.Storable as VS import Data.String (IsString) import qualified Data.List.NonEmpty as NE+import qualified Data.ByteString.Unsafe as SU -- | 'SemiSequence' was created to share code between 'IsSequence' and 'NonNull'. -- You should always use 'IsSequence' or 'NonNull' rather than using 'SemiSequence'@@ -88,12 +89,21 @@ splitAt :: Index seq -> seq -> (seq, seq) splitAt i = (fromList *** fromList) . List.genericSplitAt i . otoList + unsafeSplitAt :: Index seq -> seq -> (seq, seq)+ unsafeSplitAt i seq = (unsafeTake i seq, unsafeDrop i seq)+ take :: Index seq -> seq -> seq take i = fst . splitAt i + unsafeTake :: Index seq -> seq -> seq+ unsafeTake = take+ drop :: Index seq -> seq -> seq drop i = snd . splitAt i + unsafeDrop :: Index seq -> seq -> seq+ unsafeDrop = drop+ partition :: (Element seq -> Bool) -> seq -> (seq, seq) partition f = (fromList *** fromList) . List.partition f . otoList @@ -134,7 +144,18 @@ permutations :: seq -> [seq] permutations = List.map fromList . List.permutations . otoList + tailEx :: seq -> seq+ tailEx = snd . maybe (error "Data.Sequences.tailEx") id . uncons + initEx :: seq -> seq+ initEx = fst . maybe (error "Data.Sequences.initEx") id . unsnoc++ unsafeTail :: seq -> seq+ unsafeTail = tailEx++ unsafeInit :: seq -> seq+ unsafeInit = initEx+ defaultFind :: MonoFoldable seq => (Element seq -> Bool) -> seq -> Maybe (Element seq) defaultFind f = List.find f . otoList @@ -154,14 +175,6 @@ defaultSnoc seq e = fromList (otoList seq List.++ [e]) --- | like Data.List.head, but not partial-headMay :: IsSequence seq => seq -> Maybe (Element seq)-headMay = fmap fst . uncons---- | like Data.List.last, but not partial-lastMay :: IsSequence seq => seq -> Maybe (Element seq)-lastMay = fmap snd . unsnoc- -- | like Data.List.tail, but an input of @mempty@ returns @mempty@ tailDef :: IsSequence seq => seq -> seq tailDef xs = case uncons xs of@@ -241,13 +254,18 @@ takeWhile = S.takeWhile splitAt = S.splitAt take = S.take+ unsafeTake = SU.unsafeTake drop = S.drop+ unsafeDrop = SU.unsafeDrop partition = S.partition uncons = S.uncons unsnoc s | S.null s = Nothing | otherwise = Just (S.init s, S.last s) groupBy = S.groupBy+ tailEx = S.tail+ initEx = S.init+ unsafeTail = SU.unsafeTail instance SemiSequence T.Text where type Index T.Text = Int@@ -276,6 +294,8 @@ | T.null t = Nothing | otherwise = Just (T.init t, T.last t) groupBy = T.groupBy+ tailEx = T.tail+ initEx = T.init instance SemiSequence L.ByteString where type Index L.ByteString = Int64@@ -304,6 +324,8 @@ | L.null s = Nothing | otherwise = Just (L.init s, L.last s) groupBy = L.groupBy+ tailEx = L.tail+ initEx = L.init instance SemiSequence TL.Text where type Index TL.Text = Int64@@ -332,6 +354,8 @@ | TL.null t = Nothing | otherwise = Just (TL.init t, TL.last t) groupBy = TL.groupBy+ tailEx = TL.tail+ initEx = TL.init instance SemiSequence (Seq.Seq a) where type Index (Seq.Seq a) = Int@@ -367,6 +391,8 @@ Seq.EmptyR -> Nothing xs Seq.:> x -> Just (xs, x) --groupBy = Seq.groupBy+ tailEx = Seq.drop 1+ initEx xs = Seq.take (Seq.length xs - 1) xs instance SemiSequence (V.Vector a) where type Index (V.Vector a) = Int@@ -392,6 +418,8 @@ splitAt = V.splitAt take = V.take drop = V.drop+ unsafeTake = V.unsafeTake+ unsafeDrop = V.unsafeDrop partition = V.partition uncons v | V.null v = Nothing@@ -400,6 +428,10 @@ | V.null v = Nothing | otherwise = Just (V.init v, V.last v) --groupBy = V.groupBy+ tailEx = V.tail+ initEx = V.init+ unsafeTail = V.unsafeTail+ unsafeInit = V.unsafeInit instance U.Unbox a => SemiSequence (U.Vector a) where type Index (U.Vector a) = Int@@ -425,6 +457,8 @@ splitAt = U.splitAt take = U.take drop = U.drop+ unsafeTake = U.unsafeTake+ unsafeDrop = U.unsafeDrop partition = U.partition uncons v | U.null v = Nothing@@ -433,6 +467,10 @@ | U.null v = Nothing | otherwise = Just (U.init v, U.last v) --groupBy = U.groupBy+ tailEx = U.tail+ initEx = U.init+ unsafeTail = U.unsafeTail+ unsafeInit = U.unsafeInit instance VS.Storable a => SemiSequence (VS.Vector a) where type Index (VS.Vector a) = Int@@ -458,6 +496,8 @@ splitAt = VS.splitAt take = VS.take drop = VS.drop+ unsafeTake = VS.unsafeTake+ unsafeDrop = VS.unsafeDrop partition = VS.partition uncons v | VS.null v = Nothing@@ -466,6 +506,10 @@ | VS.null v = Nothing | otherwise = Just (VS.init v, VS.last v) --groupBy = U.groupBy+ tailEx = VS.tail+ initEx = VS.init+ unsafeTail = VS.unsafeTail+ unsafeInit = VS.unsafeInit class (IsSequence seq, Eq (Element seq)) => EqSequence seq where stripPrefix :: seq -> seq -> Maybe seq@@ -556,7 +600,7 @@ instance (Eq a, U.Unbox a) => EqSequence (U.Vector a) instance (Eq a, VS.Storable a) => EqSequence (VS.Vector a) -class (EqSequence seq, Ord (Element seq)) => OrdSequence seq where+class (EqSequence seq, MonoFoldableOrd seq) => OrdSequence seq where sort :: seq -> seq sort = fromList . List.sort . otoList @@ -570,9 +614,15 @@ instance OrdSequence T.Text instance OrdSequence TL.Text instance Ord a => OrdSequence (Seq.Seq a)-instance Ord a => OrdSequence (V.Vector a)-instance (Ord a, U.Unbox a) => OrdSequence (U.Vector a)-instance (Ord a, VS.Storable a) => OrdSequence (VS.Vector a)++instance Ord a => OrdSequence (V.Vector a) where+ -- FIXME more efficient sort++instance (Ord a, U.Unbox a) => OrdSequence (U.Vector a) where+ -- FIXME more efficient sort++instance (Ord a, VS.Storable a) => OrdSequence (VS.Vector a) where+ -- FIXME more efficient sort class (IsSequence t, IsString t, Element t ~ Char) => Textual t where words :: t -> [t]
test/Spec.hs view
@@ -1,13 +1,34 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-} module Spec where import Test.Hspec import Test.Hspec.QuickCheck+import Test.QuickCheck (Arbitrary) import Data.MonoTraversable import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Storable as VS import Data.Sequences-import Prelude (Bool (..), ($), IO, min, abs, Eq (..), (&&), fromIntegral, Ord (..), String, mod, Int, show)+import Prelude (Bool (..), ($), IO, min, abs, Eq (..), (&&), fromIntegral, Ord (..), String, mod, Int, show,+ return, asTypeOf, (.), Show, id, (+), succ, Maybe (..), (*), mod, map, flip)+import qualified Prelude+import Control.Monad.Trans.Writer+import qualified Data.NonNull as NN+import qualified Data.List.NonEmpty as NE+import qualified Data.Semigroup as SG+import qualified Data.Map as Map+import qualified Data.IntMap as IntMap+import qualified Data.HashMap.Strict as HashMap+import Data.Containers+import qualified Data.IntSet as IntSet+import Control.Arrow (first, second) main :: IO () main = hspec $ do@@ -57,3 +78,168 @@ test "hello\r\nthere\nworld" "hello" "there\nworld" test "hello\n\r\nworld" "hello" "\r\nworld" test "" "" ""+ describe "omapM_" $ do+ let test typ dummy = prop typ $ \input ->+ let res = execWriter $ omapM_ (tell . return) (fromList input `asTypeOf` dummy)+ in res == input+ test "strict ByteString" S.empty+ test "lazy ByteString" L.empty+ test "strict Text" T.empty+ test "lazy Text" TL.empty+ describe "NonNull" $ do+ let test' forceTyp typ dummy = describe typ $ do+ prop "head" $ \x xs ->+ let nn = forceTyp $ NN.ncons x (fromList xs `asTypeOf` dummy)+ in NN.head nn `shouldBe` x+ prop "tail" $ \x xs ->+ let nn = forceTyp $ NN.ncons x (fromList xs `asTypeOf` dummy)+ in NN.tail nn `shouldBe` fromList xs+ prop "last" $ \x xs ->+ let nn = reverse $ forceTyp $ NN.ncons x (fromList xs `asTypeOf` dummy)+ in NN.last nn `shouldBe` x+ prop "init" $ \x xs ->+ let nn = reverse $ forceTyp $ NN.ncons x (fromList xs `asTypeOf` dummy)+ in NN.init nn `shouldBe` reverse (fromList xs)+ prop "maximum" $ \x xs ->+ let nn = reverse $ forceTyp $ NN.ncons x (fromList xs `asTypeOf` dummy)+ in NN.maximum nn `shouldBe` Prelude.maximum (x:xs)+ prop "maximumBy" $ \x xs ->+ let nn = reverse $ forceTyp $ NN.ncons x (fromList xs `asTypeOf` dummy)+ in NN.maximumBy compare nn `shouldBe` Prelude.maximum (x:xs)+ prop "minimum" $ \x xs ->+ let nn = reverse $ forceTyp $ NN.ncons x (fromList xs `asTypeOf` dummy)+ in NN.minimum nn `shouldBe` Prelude.minimum (x:xs)+ prop "minimumBy" $ \x xs ->+ let nn = reverse $ forceTyp $ NN.ncons x (fromList xs `asTypeOf` dummy)+ in NN.minimumBy compare nn `shouldBe` Prelude.minimum (x:xs)+ prop "ofoldMap1" $ \x xs ->+ let nn = forceTyp $ NN.ncons x (fromList xs `asTypeOf` dummy)+ in SG.getMax (NN.ofoldMap1 SG.Max nn) `shouldBe` Prelude.maximum (x:xs)+ prop "ofoldr1" $ \x xs ->+ let nn = forceTyp $ NN.ncons x (fromList xs `asTypeOf` dummy)+ in NN.ofoldr1 (Prelude.min) nn `shouldBe` Prelude.minimum (x:xs)+ prop "ofoldl1'" $ \x xs ->+ let nn = forceTyp $ NN.ncons x (fromList xs `asTypeOf` dummy)+ in NN.ofoldl1' (Prelude.min) nn `shouldBe` Prelude.minimum (x:xs)++ test :: (OrdSequence typ, Arbitrary (Element typ), Show (Element typ), Show typ, Eq typ, Eq (Element typ))+ => String -> typ -> Spec+ test = test' NN.asNotEmpty+ test "strict ByteString" S.empty+ test "lazy ByteString" L.empty+ test "strict Text" T.empty+ test "lazy Text" TL.empty+ test "Vector" (V.empty :: V.Vector Int)+ test "unboxed Vector" (U.empty :: U.Vector Int)+ test "storable Vector" (VS.empty :: VS.Vector Int)+ test "list" ([5 :: Int])+ test' (id :: NE.NonEmpty Int -> NE.NonEmpty Int) "NonEmpty" ([] :: [Int])++ describe "Containers" $ do+ let test typ dummy xlookup xinsert xdelete = describe typ $ do+ prop "difference" $ \(filterDups -> xs) (filterDups -> ys) -> do+ let m1 = mapFromList xs `difference` mapFromList ys+ m2 = mapFromList (xs `difference` ys) `asTypeOf` dummy+ m1 `shouldBe` m2+ prop "lookup" $ \(fixK -> k) (filterDups -> xs) -> do+ let m = mapFromList xs+ v1 = lookup k m+ v2 = lookup k (xs :: [(Int, Int)])+ v3 = xlookup k m+ v1 `shouldBe` v2+ v1 `shouldBe` v3+ prop "insert" $ \(fixK -> k) v (filterDups -> xs) -> do+ let m = mapFromList (xs :: [(Int, Int)])+ m1 = insertMap k v m+ m2 = mapFromList (insertMap k v xs)+ m3 = xinsert k v m+ m1 `shouldBe` m2+ m1 `shouldBe` m3+ prop "delete" $ \(fixK -> k) (filterDups -> xs) -> do+ let m = mapFromList (xs :: [(Int, Int)]) `asTypeOf` dummy+ m1 = deleteMap k m+ m2 = mapFromList (deleteMap k xs)+ m3 = xdelete k m+ m1 `shouldBe` m2+ m1 `shouldBe` m3+ prop "singletonMap" $ \(fixK -> k) v -> do+ singletonMap k v `shouldBe` (mapFromList [(k, v)] `asTypeOf` dummy)+ prop "findWithDefault" $ \(fixK -> k) v (filterDups -> xs) -> do+ let m = mapFromList xs `asTypeOf` dummy+ findWithDefault v k m `shouldBe` findWithDefault v k xs+ prop "insertWith" $ \(fixK -> k) v (filterDups -> xs) -> do+ let m = mapFromList xs `asTypeOf` dummy+ f = (+)+ insertWith f k v m `shouldBe` mapFromList (insertWith f k v xs)+ prop "insertWithKey" $ \(fixK -> k) v (filterDups -> xs) -> do+ let m = mapFromList xs `asTypeOf` dummy+ f x y z = x + y + z+ insertWithKey f k v m `shouldBe` mapFromList (insertWithKey f k v xs)+ prop "insertLookupWithKey" $ \(fixK -> k) v (filterDups -> xs) -> do+ let m = mapFromList xs `asTypeOf` dummy+ f x y z = x + y + z+ insertLookupWithKey f k v m `shouldBe`+ second mapFromList (insertLookupWithKey f k v xs)+ prop "adjustMap" $ \(fixK -> k) (filterDups -> xs) -> do+ let m = mapFromList xs `asTypeOf` dummy+ adjustMap succ k m `shouldBe` mapFromList (adjustMap succ k xs)+ prop "adjustWithKey" $ \(fixK -> k) (filterDups -> xs) -> do+ let m = mapFromList xs `asTypeOf` dummy+ adjustWithKey (+) k m `shouldBe` mapFromList (adjustWithKey (+) k xs)+ prop "updateMap" $ \(fixK -> k) (filterDups -> xs) -> do+ let m = mapFromList xs `asTypeOf` dummy+ f i = if i < 0 then Nothing else Just $ i * 2+ updateMap f k m `shouldBe` mapFromList (updateMap f k xs)+ prop "updateWithKey" $ \(fixK -> k) (filterDups -> xs) -> do+ let m = mapFromList xs `asTypeOf` dummy+ f k i = if i < 0 then Nothing else Just $ i * k+ updateWithKey f k m `shouldBe` mapFromList (updateWithKey f k xs)+ prop "updateLookupWithKey" $ \(fixK -> k) (filterDups -> xs) -> do+ let m = mapFromList xs `asTypeOf` dummy+ f k i = if i < 0 then Nothing else Just $ i * k+ updateLookupWithKey f k m `shouldBe` second mapFromList (updateLookupWithKey f k xs)+ prop "alter" $ \(fixK -> k) (filterDups -> xs) -> do+ let m = mapFromList xs `asTypeOf` dummy+ f Nothing = Just (-1)+ f (Just i) = if i < 0 then Nothing else Just (i * 2)+ lookup k (alterMap f k m) `shouldBe` f (lookup k m)+ prop "unionWith" $ \(filterDups -> xs) (filterDups -> ys) -> do+ let m1 = unionWith (+)+ (mapFromList xs `asTypeOf` dummy)+ (mapFromList ys `asTypeOf` dummy)+ m2 = mapFromList (unionWith (+) xs ys)+ m1 `shouldBe` m2+ prop "unionWithKey" $ \(filterDups -> xs) (filterDups -> ys) -> do+ let f k x y = k + x + y+ m1 = unionWithKey f+ (mapFromList xs `asTypeOf` dummy)+ (mapFromList ys `asTypeOf` dummy)+ m2 = mapFromList (unionWithKey f xs ys)+ m1 `shouldBe` m2+ prop "unionsWith" $ \(map filterDups -> xss) -> do+ let ms = map mapFromList xss `asTypeOf` [dummy]+ unionsWith (+) ms `shouldBe` mapFromList (unionsWith (+) xss)+ prop "mapWithKey" $ \(filterDups -> xs) -> do+ let m1 = mapWithKey (+) (mapFromList xs) `asTypeOf` dummy+ m2 = mapFromList $ mapWithKey (+) xs+ m1 `shouldBe` m2+ prop "mapKeysWith" $ \(filterDups -> xs) -> do+ let m1 = mapKeysWith (+) f (mapFromList xs) `asTypeOf` dummy+ m2 = mapFromList $ mapKeysWith (+) f xs+ f = flip mod 5+ m1 `shouldBe` m2+ filterDups :: [(Int, v)] -> [(Int, v)]+ filterDups =+ loop IntSet.empty . map (first (`mod` 20))+ where+ loop _ [] = []+ loop used ((k, v):rest)+ | k `member` used = loop used rest+ | Prelude.otherwise = (k, v) : loop (insertSet k used) rest++ fixK :: Int -> Int+ fixK = flip mod 20++ test "Data.Map" Map.empty Map.lookup Map.insert Map.delete+ test "Data.IntMap" IntMap.empty IntMap.lookup IntMap.insert IntMap.delete+ test "Data.HashMap" HashMap.empty HashMap.lookup HashMap.insert HashMap.delete